Compare commits

...

11 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
19 changed files with 2768 additions and 494 deletions

View File

@ -2,15 +2,20 @@
All notable changes to the tp library are documented here. All notable changes to the tp library are documented here.
## 1.0.0 (Unreleased) ## 2.0.0 (Unreleased)
### Added ### 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. - 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. - 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. - 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.
- Additive transaction protocol v2 artifacts: transaction-scoped publication batches, structured v1 participant bridges, bounded opaque final-accept markers using the closed `tp-vector-slots/v1` primitive, immutable tagged outcomes, and property/revision shadow proofs over the unchanged v1 live writer. - Transaction protocol v2: transaction-scoped publication batches, structured
- `tp-runtime-manifest`, advertising `tp-transaction-protocol-v1+v2` without removing the v1 participant route. 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. - 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. - `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. - 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.
@ -18,6 +23,9 @@ All notable changes to the tp library are documented here.
### Changed ### 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. - `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. - 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. - Function-valued properties are always literal. Only values wrapped by `tp-computed` execute and participate in dependency collection.
@ -26,6 +34,12 @@ All notable changes to the tp library are documented here.
### Removed ### 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. - `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. - 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. - `tp-text`, `$variable` declaration syntax, automatic layer refresh, and character-level `tp-name`/`tp-layers`/`tp-meta` runtime storage.

View File

@ -5,7 +5,7 @@
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces) # make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
# make test-m0a # run current TP completion characterization # make test-m0a # run current TP completion characterization
# make test-m1a # run additive transaction contract + fault gates # make test-m1a # run additive transaction contract + fault gates
# make test-v1 # run every legacy suite with v2 artifacts disabled # make test-c1b # run the v2-only transaction regression gate
# make doctest # execute README examples against the code # make doctest # execute README examples against the code
# make benchmark # run reproducible correctness-first benchmarks # make benchmark # run reproducible correctness-first benchmarks
# make compile # byte-compile the library modules # make compile # byte-compile the library modules
@ -27,12 +27,11 @@ LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA)
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 \ 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 tp-query.el tp-palette.el tp-builtins.el tp.el
TESTS = $(wildcard $(TEST_DIR)/*-tests.el) TESTS = $(wildcard $(TEST_DIR)/*-tests.el)
V1_TESTS = $(filter-out $(TEST_DIR)/tp-transaction-tests.el,$(TESTS))
TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el
EXAMPLES = $(wildcard examples/*.el) EXAMPLES = $(wildcard examples/*.el)
DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
.PHONY: test test-m0a test-m1a test-v1 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: test:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
@ -53,10 +52,13 @@ test-m1a:
-l $(TEST_DIR)/tp-transaction-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")' --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-v1: test-c1b:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \ $(EMACS) -Q --batch $(LOADPATH) -l tp.el \
--eval '(setq tp--transaction-artifact-mode (quote v1))' \ -l $(TEST_DIR)/tp-binding-tests.el \
$(patsubst %,-l %,$(V1_TESTS)) -f ert-run-tests-batch-and-exit -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: test-shuffled:
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \

View File

@ -1,13 +1,13 @@
# TP # 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. 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). Chinese documentation: [README_CN.md](README_CN.md).
Complete public API reference: [API-REFERENCE.md](docs/API-REFERENCE.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. README remains the conceptual quick start.
## Requirements ## Requirements
@ -146,12 +146,14 @@ 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. 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 also builds an internal transaction-scoped batch view over the same v1 TP 2.0 drives the single live publication from exact transaction-scoped batch
participants, journals, surface snapshots, and single final accept. Shadow entries, one frozen participant vector, and the candidate-bound final accept.
mode compares canonical target artifacts and tagged outcomes with the one v1 The same journals, surface snapshots, and change group are shared rather than
writer; it never opens a second change group or writes a buffer twice. Generic copied. Transaction participants register through
opaque authority markers are bounded and whitelist-validated before final `tp-transaction-participate-v2`; TP has no alternate transaction writer or
accept, then reverse-restored before ordinary rollback on partial apply 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 accept failure. `tp-with-transaction` still returns its body value, and
internal outcomes remain observational side-channel evidence. internal outcomes remain observational side-channel evidence.
@ -183,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` | | 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` | | 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 | | 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`, read-only `tp-transaction-active-p`, `tp-runtime-manifest`, 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 | | 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` | | 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 | | Surfaces | mount/update/scoped update, materialize, live/revision/client-state, at-point, report/report-summary/inspect, unmount |
@ -201,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 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. 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 ## Examples

View File

@ -1,13 +1,13 @@
# TP # 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。 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)。 英文文档:[README.md](README.md)。
完整公共 API 参考:[API-REFERENCE.md](docs/API-REFERENCE.md)。本文负责概念 完整公共 API 参考:[API-REFERENCE.md](docs/API-REFERENCE.md)。本文负责概念
和快速开始API 参考按当前 TP 1.0 源码列出入口、参数语义、返回值和用法。 和快速开始API 参考按当前 TP 2.0 源码列出入口、参数语义、返回值和用法。
## 运行要求 ## 运行要求
@ -145,13 +145,14 @@ TP 为每个 property interval 保存 host baseline 和各个 TP contribution。
observer 只在成功提交之后运行observer failure 只记录,不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡rollback 不会把它重新创建。 observer 只在成功提交之后运行observer failure 只记录,不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡rollback 不会把它重新创建。
TP 还会在同一份 v1 participant、journal、surface snapshot 和 single final TP 2.0 从 transaction-scoped batch 的 exact entries、同一个冻结 participant
accept 上建立内部 transaction-scoped batch view。shadow mode 只比较 canonical vector 和 candidate-bound final accept 驱动唯一 live publicationjournal、
target artifact 与 tagged outcome仍由唯一 v1 writer 写入;不会建立第二个 surface snapshot 与 change group 仍只保留一份。transaction participant 统一通过
change group也不会双写 Buffer。generic opaque authority marker 在 final `tp-transaction-participate-v2` 注册,不再提供备用 transaction writer 或 runtime
accept 前完成固定上界与 whitelist 校验partial apply 或 accept failure 时先 route switch。generic opaque authority marker 在 final accept 前
逆序恢复 marker再执行普通 rollback。`tp-with-transaction` 仍返回 body 完成固定上界与 whitelist 校验partial apply 或 accept failure 时先逆序恢复
result内部 outcome 仅作为只读 side-channel evidence。 marker再执行普通 rollback。`tp-with-transaction` 仍返回 body result内部
outcome 仅作为只读 side-channel evidence。
ETAF 集成复用同一事务边界,只注册一个 opaque transaction participant。ETAF ETAF 集成复用同一事务边界,只注册一个 opaque transaction participant。ETAF
先准备 immutable generation 和 Ebox candidate再由 TP 按固定顺序完成 先准备 immutable generation 和 Ebox candidate再由 TP 按固定顺序完成
@ -179,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` | | 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` | | 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 | | 静态 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`、只读 `tp-transaction-active-p`、`tp-runtime-manifest`、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 | | 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` | | 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 | | Surface | mount/update/scoped update、materialize、live/revision/client-state、at-point、report/report-summary/inspect、unmount |
@ -196,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 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。 可复用静态声明使用 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 当前实现的完整公共入口索引。它以 tp.el 加载的模块为准;带
tp-- 前缀的函数、变量和结构体是内部实现,不属于本文的稳定 API。 tp-- 前缀的函数、变量和结构体是内部实现,不属于本文的稳定 API。
@ -226,10 +226,11 @@ tp-binding-dispose 释放单个 binding。
(tp-signal-dispose left) (tp-signal-dispose left)
(tp-signal-dispose right)) (tp-signal-dispose right))
(tp-transaction-participate (tp-with-transaction
'my-external-state (tp-transaction-participate-v2
(lambda () (my-publish)) :key 'my-structured-state
(lambda () (my-rollback))) :stage (lambda () (my-stage))
:rollback (lambda () (my-rollback))))
(tp-transaction-active-p) (tp-transaction-active-p)
@ -244,8 +245,10 @@ tp-binding-dispose 释放单个 binding。
tp-with-transaction 将 signal、binding、surface 和注册的 transaction tp-with-transaction 将 signal、binding、surface 和注册的 transaction
participant 一起原子处理。participant 必须在 active transaction 内注册; participant 一起原子处理。participant 必须在 active transaction 内注册;
publish 在 surface publication 后、source commit 前运行,失败时按逆序 stage 在 surface publication 后、source commit 前运行,失败时按逆序
rollback。tp-variable-signal 用 Emacs variable watcher 适配全局或指定 rollback。consumer 使用 `tp-transaction-participate-v2`;它
返回 key不暴露内部 participant 对象。tp-variable-signal 用 Emacs variable
watcher 适配全局或指定
Buffer 的变量,不是旧的 $variable API。 Buffer 的变量,不是旧的 $variable API。
tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已进入 tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已进入
@ -254,11 +257,16 @@ tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已
嵌套事务边界。 嵌套事务边界。
tp-runtime-manifest 返回防御性 capability snapshot本版本的 tp-runtime-manifest 返回防御性 capability snapshot本版本的
`:transaction-protocol``tp-transaction-protocol-v1+v2`。该声明是 additive `:transaction-protocol``tp-transaction-protocol-v2``:version` 为
`tp-transaction-participate` façade 与 live writer 都仍保留。 `"2.0.0"`。`:structured-participant-api` 指向
`:batch-artifacts``:shadow-proof` 为 non-nil`:batch-execution` 为 `tp-transaction-participate-v2``:batch-execute`、`:batch-artifacts` 和
`v1-bridge`,而 `:batch-execute` 明确为 nilstructured-core execute owner `:single-live-writer` 均为 non-nil。manifest 不再发布 execution route、
保留给后续受控 cutover不在 M1a 伪造第二个 coordinator。 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 ETAF registers one opaque participant for its immutable generation and Ebox
client state. Its publish is paired with rollback across TP final accept; the client state. Its publish is paired with rollback across TP final accept; the
@ -382,6 +390,19 @@ Report 的常用字段包括:
:scope-fallback、:property-conflicts、:rolled-back、:failure、 :scope-fallback、:property-conflicts、:rolled-back、:failure、
:observer-errors、:timing。 :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 ### 6.3 Host range 和 tp-watch
~~~elisp ~~~elisp
@ -610,7 +631,7 @@ 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-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-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-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-transaction.el | additive batch/entry、final-marker 与 tagged-outcome 内部合同 | | tp-transaction.el | structured batch/entry、final-marker 与 tagged-outcome 内部合同 |
| tp-reactive.el | signal、binding、transaction coordinator、variable adapter、counter 和 reset API | | 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-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-ops.el | tp-propertize、tp-apply、tp-set、tp-reset、tp-add、tp-remove、tp-clear、tp-get、tp-at、tp-member |

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)。 完整的公共符号、参数形状、返回值和示例见 [API reference](API-REFERENCE.md)。
@ -196,10 +196,11 @@ TP 为每个 interval 保存:
3. 运行 binding graph 与 producers 3. 运行 binding graph 与 producers
4. 校验 object、plan、capability、range、conflict 与 lifecycle 4. 校验 object、plan、capability、range、conflict 与 lifecycle
5. 为所有 surfaces 准备 text/property operations 与 inverse journals 5. 为所有 surfaces 准备 text/property operations 与 inverse journals
6. 按稳定 surface id publish 6. 默认从 publication batch 的 exact entry bindings 按稳定 surface id publish
7. 按声明顺序 stage participant再执行 declared precommit 7. 从 batch 绑定的同一 participant vector 按声明顺序 stage participant再执行
declared precommit
8. commit signal journal 8. commit signal journal
9. 在 single final accept 内按顺序 apply bounded opaque markers再 accept 9. 在 candidate 绑定的 single final accept 内按顺序 apply bounded opaque markers再 accept
change groupmarker 只能使用 closed `tp-vector-slots/v1` fixed-write change groupmarker 只能使用 closed `tp-vector-slots/v1` fixed-write
primitive不能注册 callbackpartial apply 或 accept failure 先逆序 primitive不能注册 callbackpartial apply 或 accept failure 先逆序
restore markers restore markers
@ -208,14 +209,21 @@ TP 为每个 interval 保存:
嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers任一 surface 失败时,已发布 surfaces 和 source/binding state 全部回滚。 嵌套 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 只记录,
不回滚已提交结果。
M1a 的 publication batch、structured participant、final marker 与 tagged publication batch、structured participant、final marker 与 tagged outcome 共享
outcome 都是现有 v1 dynamic transaction state 的内部结构化 view不复制第二份 现有 journal/change-group不复制第二份 live state。publication batch 是唯一
participant/journal/change-group也不切换 live writer。shadow proof 只比较 v1/v2 live writersurface 从 candidate entries 执行participant 从 candidate
artifact 与 outcome不双写 Buffer。`tp-with-transaction` 的返回值仍是 body 绑定的同一 identity vector 执行final accept 从 candidate binding 执行;任何
resultsuccess/failure outcome 只走内部 side channel。zero-surface 与 binding/order 漂移都会 fail-fast 并回滚。TP 2.0 不再提供 alternate writer、
output-equal operation 不创建 publication batch。 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 ETAF uses this API with one opaque participant for its immutable generation and
Ebox client state. The participant is published only after candidate 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)。 按功能查找公共入口和用法时,使用 [API reference](API-REFERENCE.md)。
@ -45,7 +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-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-style.el` | native property policies、direct declarations、explicit computed source、projection | selector、stylesheet、specificity、CSS winner |
| `tp-transaction.el` | additive batch/entry validators、one-shot states、opaque final-marker descriptors、tagged outcomes | live buffer writer、consumer semantics、parallel journals | | `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-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-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 | | `tp-layer.el` | `define-tp`/`define-tps` declaration recipes and registry | live layer stack、inline runtime metadata、watcher engine |
@ -182,11 +182,10 @@ 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 outer transaction owns candidate source values, dirty bindings, prepared surfaces, participants, inverse journals, view state, and final observer scheduling.
The additive v2 contract is a structured view over those exact owners. It does The v2 contract uses those exact owners. It does not copy participant,
not copy participant, scheduler, snapshot, journal, or change-group state. The scheduler, snapshot, journal, or change-group state. The publication batch is
public v1 participant façade and the v1 surface writer remain authoritative; the sole writer and validates its canonical entries against the committed
shadow mode constructs canonical entries and compares property-for-property and property and revision state after commit or rollback.
revision-for-revision after commit or rollback.
```text ```text
freeze candidate writes freeze candidate writes
@ -208,11 +207,11 @@ 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. 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.
The v1 participant record is also its structured v2 bridge: one stable key, Each structured participant has one stable key, registration order, stage,
registration order, stage, rollback, optional declared precommit, contained rollback, optional declared precommit, contained after-commit work, owner
after-commit work, owner journal, and one-shot state. Final markers are not journal, and one-shot state. Final markers are not
participants. TP treats their values as opaque and accepts only predeclared, participants. TP treats their values as opaque and accepts only predeclared,
fixed-bound operations. M1a's closed `tp-vector-slots/v1` primitive accepts fixed-bound operations. M1a's closed `tp-vector-slots/v1` primitive accepts
only prebuilt vector-slot expectations and writes; marker registration cannot only prebuilt vector-slot expectations and writes; marker registration cannot

View File

@ -399,20 +399,20 @@
(setq failure (setq failure
(condition-case condition (condition-case condition
(tp-with-transaction (tp-with-transaction
(tp-transaction-participate (tp-transaction-participate-v2
'first :key 'first
(lambda () :stage (lambda ()
(push 'publish-first (push 'publish-first
tp-binding-test-transaction-trace)) tp-binding-test-transaction-trace))
(lambda () :rollback (lambda ()
(push 'rollback-first (push 'rollback-first
tp-binding-test-transaction-trace))) tp-binding-test-transaction-trace)))
(tp-transaction-participate (tp-transaction-participate-v2
'second :key 'second
(lambda () :stage (lambda ()
(push 'publish-second (push 'publish-second
tp-binding-test-transaction-trace)) tp-binding-test-transaction-trace))
(lambda () :rollback (lambda ()
(push 'rollback-second (push 'rollback-second
tp-binding-test-transaction-trace))) tp-binding-test-transaction-trace)))
(tp-signal-set signal 2)) (tp-signal-set signal 2))
@ -689,7 +689,8 @@
(caller-vector (vector (copy-sequence "key"))) (caller-vector (vector (copy-sequence "key")))
(key (list 'test caller-string caller-vector))) (key (list 'test caller-string caller-vector)))
(tp-with-transaction (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 (let ((stored (tp--transaction-participant-key
(car tp--transaction-participants)))) (car tp--transaction-participants))))
(should-not (eq (nth 1 stored) caller-string)) (should-not (eq (nth 1 stored) caller-string))
@ -701,8 +702,9 @@
(should (equal (nth 1 stored) "participant")) (should (equal (nth 1 stored) "participant"))
(should (equal (nth 2 stored) ["key"])) (should (equal (nth 2 stored) ["key"]))
(should-error (should-error
(tp-transaction-participate (tp-transaction-participate-v2
(list 'test "participant" ["key"]) #'ignore #'ignore) :key (list 'test "participant" ["key"])
:stage #'ignore :rollback #'ignore)
:type 'tp-reactive-error)))))) :type 'tp-reactive-error))))))
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge () (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 0 copy) "value"))
(should (equal (nth 1 copy) ["nested"]))))) (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 () (ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
"Property copies keep list-shaped function values opaque." "Property copies keep list-shaped function values opaque."
(let ((function-value '(lambda () 1))) (let ((function-value '(lambda () 1)))

View File

@ -107,12 +107,12 @@
(tp-m0a-characterization--capture (tp-m0a-characterization--capture
(lambda () (lambda ()
(tp-with-transaction (tp-with-transaction
(tp-transaction-participate (tp-transaction-participate-v2
'm0a-participant :key 'm0a-participant
(lambda () :stage (lambda ()
(setq external 'candidate) (setq external 'candidate)
(signal (car injected) (cdr injected))) (signal (car injected) (cdr injected)))
(lambda () (setq external 'old))) :rollback (lambda () (setq external 'old)))
(tp-signal-set source 2)))))) (tp-signal-set source 2))))))
(should (equal failure injected))) (should (equal failure injected)))
(should (eq external 'old)) (should (eq external 'old))

View File

@ -14,6 +14,46 @@
(require 'tp-style) (require 'tp-style)
(require 'tp-layer) (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) (defmacro tp-style-test--isolated (&rest body)
"Run BODY with isolated TP property and named-style registries." "Run BODY with isolated TP property and named-style registries."
(declare (indent 0) (debug t)) (declare (indent 0) (debug t))

File diff suppressed because it is too large Load Diff

View File

@ -1,13 +1,13 @@
;;; tp-transaction-tests.el --- TP additive transaction contract -*- lexical-binding: t; -*- ;;; tp-transaction-tests.el --- TP structured transaction contract -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney ;; Copyright (C) 2026 Geekinney
;;; Commentary: ;;; Commentary:
;; Characterization and fault tests for the additive v1+v2 transaction ;; Characterization and fault tests for the v2 transaction protocol. These
;; protocol. These tests deliberately exercise the internal protocol: the ;; tests deliberately exercise
;; public contract remains `tp-with-transaction' body return and primary ;; the internal protocol: the public contract remains `tp-with-transaction'
;; condition preservation. ;; body return and primary condition preservation.
;;; Code: ;;; Code:
@ -17,13 +17,12 @@
(require 'tp-surface) (require 'tp-surface)
(declare-function tp--transaction-participate-v2 "tp-reactive" (&rest args)) (declare-function tp--transaction-participate-v2 "tp-reactive" (&rest args))
(declare-function tp-transaction-participate-v2 "tp-reactive" (&rest args))
(declare-function tp--transaction-participant-protocol "tp-reactive" (value)) (declare-function tp--transaction-participant-protocol "tp-reactive" (value))
(declare-function tp--transaction-participant-state "tp-reactive" (value)) (declare-function tp--transaction-participant-state "tp-reactive" (value))
(declare-function tp--transaction-participant-journal "tp-reactive" (value)) (declare-function tp--transaction-participant-journal "tp-reactive" (value))
(declare-function tp--transaction-register-final-marker (declare-function tp--transaction-register-final-marker
"tp-reactive" (&rest args)) "tp-reactive" (&rest args))
(defvar tp--transaction-artifact-mode)
(defvar tp--transaction-publication-batch) (defvar tp--transaction-publication-batch)
(defvar tp--transaction-outcome) (defvar tp--transaction-outcome)
(defvar tp--last-shadow-proof) (defvar tp--last-shadow-proof)
@ -100,6 +99,30 @@
:final-accept #'ignore :final-accept #'ignore
:diagnostics nil)) :diagnostics nil))
(ert-deftest tp-transaction-test-unique-identities-use-equal-semantics ()
"Distinct identity values stay distinct; equal values remain duplicates."
(dolist (items (list nil '(nil) '(1 1.0) '(nil mount-a "mount-a")
(number-sequence 1 2000)))
(let ((before (copy-tree items)))
(should (tp--proper-unique-list-p items))
(should (equal items before))))
(dolist (items (list '(nil nil) '(mount-a mount-a)
(list (copy-sequence "mount") (copy-sequence "mount"))
(list (list 'owner 1) (list 'owner 1))
(list (vector 'owner 1) (vector 'owner 1))))
(should-not (tp--proper-unique-list-p items))
(should-error (tp-transaction-test--entry :mount-ids items)
:type 'tp-publication-binding-error)))
(ert-deftest tp-transaction-test-unique-identities-reject-improper-lists ()
"Malformed identity sequences cannot enter publication authority bindings."
(let ((cycle (list 'mount-a 'mount-b)))
(setcdr (last cycle) cycle)
(dolist (items (list 'mount-a [mount-a] '(mount-a . mount-b) cycle))
(should-not (tp--proper-unique-list-p items))
(should-error (tp-transaction-test--entry :mount-ids items)
:type 'tp-publication-binding-error))))
(defun tp-transaction-test--slot-writes (target values) (defun tp-transaction-test--slot-writes (target values)
"Return fixed slot writes assigning VALUES into TARGET from index zero." "Return fixed slot writes assigning VALUES into TARGET from index zero."
(vconcat (vconcat
@ -234,8 +257,8 @@
(when (tp-signal-live-p ,source) (when (tp-signal-live-p ,source)
(tp-signal-dispose ,source))))) (tp-signal-dispose ,source)))))
(ert-deftest tp-transaction-test-v1-body-return-and-phase-order () (ert-deftest tp-transaction-test-v2-body-return-and-phase-order ()
"The v1 facade returns BODY and retains its established phase order." "The v2 facade returns BODY and retains its established phase order."
(let ((tp-transaction-test--trace nil) (let ((tp-transaction-test--trace nil)
(tp--transaction-precommit-functions (tp--transaction-precommit-functions
'(tp--transaction-test-precommit-inject)) '(tp--transaction-test-precommit-inject))
@ -244,10 +267,10 @@
(should (should
(equal (equal
(tp-with-transaction (tp-with-transaction
(tp-transaction-participate (tp-transaction-participate-v2
'v1 :key 'v2
(lambda () (push 'participant tp-transaction-test--trace)) :stage (lambda () (push 'participant tp-transaction-test--trace))
(lambda () (push 'rollback tp-transaction-test--trace))) :rollback (lambda () (push 'rollback tp-transaction-test--trace)))
(tp--enqueue-after-commit (tp--enqueue-after-commit
(lambda () (push 'after-commit tp-transaction-test--trace))) (lambda () (push 'after-commit tp-transaction-test--trace)))
(push 'body tp-transaction-test--trace) (push 'body tp-transaction-test--trace)
@ -256,8 +279,8 @@
(should (equal (nreverse tp-transaction-test--trace) (should (equal (nreverse tp-transaction-test--trace)
'(body participant precommit after-commit))))) '(body participant precommit after-commit)))))
(ert-deftest tp-transaction-test-v1-participant-and-precommit-fault-order () (ert-deftest tp-transaction-test-v2-participant-and-precommit-fault-order ()
"A late v1 fault rolls staged participants back in reverse order." "A late v2 fault rolls staged participants back in reverse order."
(let* ((injected '(tp-transaction-test-error :phase precommit :raw (1 2))) (let* ((injected '(tp-transaction-test-error :phase precommit :raw (1 2)))
(tp-transaction-test--trace nil) (tp-transaction-test--trace nil)
(tp-transaction-test--precommit-condition injected) (tp-transaction-test--precommit-condition injected)
@ -269,14 +292,14 @@
(tp-transaction-test--capture (tp-transaction-test--capture
(lambda () (lambda ()
(tp-with-transaction (tp-with-transaction
(tp-transaction-participate (tp-transaction-participate-v2
'first :key 'first
(lambda () (push 'stage-first tp-transaction-test--trace)) :stage (lambda () (push 'stage-first tp-transaction-test--trace))
(lambda () (push 'rollback-first tp-transaction-test--trace))) :rollback (lambda () (push 'rollback-first tp-transaction-test--trace)))
(tp-transaction-participate (tp-transaction-participate-v2
'second :key 'second
(lambda () (push 'stage-second tp-transaction-test--trace)) :stage (lambda () (push 'stage-second tp-transaction-test--trace))
(lambda () (push 'rollback-second tp-transaction-test--trace)))))))) :rollback (lambda () (push 'rollback-second tp-transaction-test--trace))))))))
(should (equal failure injected)) (should (equal failure injected))
(should (equal (nreverse tp-transaction-test--trace) (should (equal (nreverse tp-transaction-test--trace)
'(stage-first stage-second precommit '(stage-first stage-second precommit
@ -313,10 +336,17 @@
:type 'tp-publication-binding-error) :type 'tp-publication-binding-error)
(with-temp-buffer (with-temp-buffer
(let* ((mount-ids (list 'mount-a)) (let* ((mount-ids (list 'mount-a))
(entry (tp-transaction-test--entry :mount-ids mount-ids)) (diff (list :replace (list 1 2)))
(client-state (list :client (list 'candidate)))
(entry (tp-transaction-test--entry
:mount-ids mount-ids
:diff diff
:client-state client-state))
(entries (list entry)) (entries (list entry))
(batch (tp-transaction-test--batch entries))) (batch (tp-transaction-test--batch entries)))
(setcar mount-ids 'mutated-after-create) (setcar mount-ids 'mutated-after-create)
(setcar (plist-get diff :replace) 'mutated-after-create)
(setcar (plist-get client-state :client) 'mutated-after-create)
(setcar entries (tp-transaction-test--entry (setcar entries (tp-transaction-test--entry
:candidate-id 'replacement :candidate-id 'replacement
:surface-id 'replacement-surface :surface-id 'replacement-surface
@ -327,6 +357,10 @@
(should (equal (tp-publication-target-entry-mount-ids (should (equal (tp-publication-target-entry-mount-ids
(car (tp-publication-batch-candidate-entries batch))) (car (tp-publication-batch-candidate-entries batch)))
'(mount-a))) '(mount-a)))
(should (equal (tp-publication-target-entry-diff entry)
'(:replace (1 2))))
(should (equal (tp-publication-target-entry-client-state entry)
'(:client (candidate))))
(should (eq (car (tp-publication-batch-candidate-entries batch)) entry)) (should (eq (car (tp-publication-batch-candidate-entries batch)) entry))
(should-error (should-error
(tp-transaction-test--batch (list entry entry)) (tp-transaction-test--batch (list entry entry))
@ -353,14 +387,15 @@
(should-error (tp--publication-batch-transition discarded 'staged) (should-error (tp--publication-batch-transition discarded 'staged)
:type 'tp-publication-state-error)))) :type 'tp-publication-state-error))))
(ert-deftest tp-transaction-test-v1-bridge-is-the-structured-participant () (ert-deftest tp-transaction-test-v2-participant-is-single-structured-record ()
"The v1 facade installs one v2 record, not parallel participant state." "The v2 facade installs one structured record with no legacy bridge."
(let (saved) (let (saved)
(tp-with-transaction (tp-with-transaction
(tp-transaction-participate 'legacy #'ignore #'ignore) (tp-transaction-participate-v2 :key 'structured :stage #'ignore
:rollback #'ignore)
(setq saved (car tp--transaction-participants)) (setq saved (car tp--transaction-participants))
(should (= (length tp--transaction-participants) 1)) (should (= (length tp--transaction-participants) 1))
(should (eq (tp--transaction-participant-protocol saved) 'v1-bridge)) (should (eq (tp--transaction-participant-protocol saved) 'v2))
(should (eq (tp--transaction-participant-state saved) 'prepared))) (should (eq (tp--transaction-participant-state saved) 'prepared)))
(should (eq (tp--transaction-participant-state saved) 'committed)))) (should (eq (tp--transaction-participant-state saved) 'committed))))
@ -386,6 +421,30 @@
'(:owner old-state))) '(:owner old-state)))
(should (eq (tp--transaction-participant-state participant) 'committed)))) (should (eq (tp--transaction-participant-state participant) 'committed))))
(ert-deftest tp-transaction-test-public-v2-participant-api-registers-v2-record ()
"The public v2 API registers one v2 object on the sole live route."
(let ((tp-transaction-test--trace nil)
participant)
(should
(eq
(tp-with-transaction
(should
(eq
(tp-transaction-participate-v2
:key 'public-v2
:stage (lambda () (push 'stage tp-transaction-test--trace))
:rollback (lambda () (push 'rollback tp-transaction-test--trace))
:journal '(:owner public))
'public-v2))
(setq participant (car tp--transaction-participants))
'body-result)
'body-result))
(should (equal tp-transaction-test--trace '(stage)))
(should (eq (tp--transaction-participant-protocol participant) 'v2))
(should (equal (tp--transaction-participant-journal participant)
'(:owner public)))
(should (eq (tp--transaction-participant-state participant) 'committed))))
(ert-deftest tp-transaction-test-v2-participant-stage-fault-rolls-back-prior-only () (ert-deftest tp-transaction-test-v2-participant-stage-fault-rolls-back-prior-only ()
"A structured stage fault reverses only participants that entered staged." "A structured stage fault reverses only participants that entered staged."
(let ((tp-transaction-test--trace nil) (let ((tp-transaction-test--trace nil)
@ -452,6 +511,32 @@
:type 'tp-final-marker-error) :type 'tp-final-marker-error)
(should (eq (aref target 0) 'old)))))) (should (eq (aref target 0) 'old))))))
(ert-deftest tp-transaction-test-public-final-marker-wrappers-share-contract ()
"Public marker constructors and registration retain the bounded core rules."
(tp-transaction-test--with-surface (buffer _surface source)
(let ((target (vector 'detached 'token 0)))
(tp-with-transaction
(tp-signal-set source 2)
(tp-transaction-register-final-marker
:owner-key 'public-host
:expected-token
(tp-final-marker-expectation-create
:target target :index 1 :value 'token)
:expected-version
(tp-final-marker-expectation-create
:target target :index 2 :value 0)
:next-values
(vector
(tp-final-marker-slot-write-create
:target target :index 0 :value 'attached))
:inverse-values
(vector
(tp-final-marker-slot-write-create
:target target :index 0 :value 'detached))
:slot-write-count 1
:operation-key 'tp-vector-slots/v1))
(should (eq (aref target 0) 'attached)))))
(ert-deftest tp-transaction-test-marker-partial-apply-restores-in-reverse () (ert-deftest tp-transaction-test-marker-partial-apply-restores-in-reverse ()
"Partial marker apply restores applied owners before normal rollback." "Partial marker apply restores applied owners before normal rollback."
(tp-transaction-test--with-surface (buffer _surface source) (tp-transaction-test--with-surface (buffer _surface source)
@ -551,6 +636,10 @@
tp--last-transaction-outcome)) tp--last-transaction-outcome))
(tp-transaction-test--should-match-outcome-counts (tp-transaction-test--should-match-outcome-counts
tp--last-transaction-outcome (list surface)) tp--last-transaction-outcome (list surface))
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
(should (plist-get tp--last-shadow-proof :equivalent))
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (plist-get tp--last-shadow-proof :entry-count) 1))
(should (eq (plist-get (should (eq (plist-get
(tp--committed-success-outcome-snapshot (tp--committed-success-outcome-snapshot
tp--last-transaction-outcome) tp--last-transaction-outcome)
@ -736,8 +825,7 @@
(dolist (id before) (dolist (id before)
(should (memq id outcome-ids))) (should (memq id outcome-ids)))
(tp-transaction-test--should-match-outcome-counts (tp-transaction-test--should-match-outcome-counts
tp--last-transaction-outcome (list surface)) tp--last-transaction-outcome (list surface))))
(should (plist-get tp--last-shadow-proof :equivalent))))
(when (buffer-live-p buffer) (kill-buffer buffer))))) (when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest tp-transaction-test-candidates-remain-invisible-until-staged () (ert-deftest tp-transaction-test-candidates-remain-invisible-until-staged ()
@ -756,8 +844,8 @@
(with-current-buffer buffer (with-current-buffer buffer
(should (equal (buffer-string) text)))))) (should (equal (buffer-string) text))))))
(ert-deftest tp-transaction-test-shadow-is-multisurface-and-single-writer () (ert-deftest tp-transaction-test-v2-is-multisurface-and-single-writer ()
"Shadow artifacts cover all surfaces while each live writer runs once." "The v2 artifacts cover all surfaces while each live writer runs once."
(let* ((source (tp-signal-create 1)) (let* ((source (tp-signal-create 1))
(producer (tp-transaction-test--producer source)) (producer (tp-transaction-test--producer source))
(first-buffer (generate-new-buffer " *tp-transaction-first*")) (first-buffer (generate-new-buffer " *tp-transaction-first*"))
@ -773,16 +861,17 @@
(let ((surface (tp--prepared-surface-surface prepared))) (let ((surface (tp--prepared-surface-surface prepared)))
(puthash surface (1+ (gethash surface calls 0)) calls)) (puthash surface (1+ (gethash surface calls 0)) calls))
(funcall writer prepared)))) (funcall writer prepared))))
(let ((tp--transaction-artifact-mode 'shadow)) (tp-signal-set source 2)
(tp-signal-set source 2))
(should (= (gethash first calls 0) 1)) (should (= (gethash first calls 0) 1))
(should (= (gethash second calls 0) 1)) (should (= (gethash second calls 0) 1))
(should (tp-committed-success-outcome-p (should (tp-committed-success-outcome-p
tp--last-transaction-outcome)) tp--last-transaction-outcome))
(tp-transaction-test--should-match-outcome-counts (tp-transaction-test--should-match-outcome-counts
tp--last-transaction-outcome (list first second)) tp--last-transaction-outcome (list first second))
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
(should (plist-get tp--last-shadow-proof :equivalent)) (should (plist-get tp--last-shadow-proof :equivalent))
(should (plist-get tp--last-shadow-proof :outcome-equivalent)) (should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (plist-get tp--last-shadow-proof :entry-count) 2))
(should (integerp (should (integerp
(tp-committed-success-outcome-mapping-generation (tp-committed-success-outcome-mapping-generation
tp--last-transaction-outcome))) tp--last-transaction-outcome)))
@ -800,6 +889,31 @@
(when (buffer-live-p second-buffer) (kill-buffer second-buffer)) (when (buffer-live-p second-buffer) (kill-buffer second-buffer))
(when (tp-signal-live-p source) (tp-signal-dispose source))))) (when (tp-signal-live-p source) (tp-signal-dispose source)))))
(ert-deftest tp-transaction-test-canonical-artifact-mismatch-is-diagnostic ()
"A postcommit canonical artifact mismatch is detected and contained."
(tp-transaction-test--with-surface (buffer surface source)
(let ((current-artifact (symbol-function 'tp--shadow-current-artifact)))
(cl-letf (((symbol-function 'tp--shadow-current-artifact)
(lambda (target)
(let ((artifact (funcall current-artifact target)))
(plist-put artifact :revision
(1+ (plist-get artifact :revision)))))))
(tp-signal-set source 2))
(should (= (tp-signal-peek source) 2))
(should (= (tp-surface-revision surface) 2))
(with-current-buffer buffer
(should (equal (buffer-string) "2")))
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
(should-not (plist-get tp--last-shadow-proof :equivalent))
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (plist-get tp--last-shadow-proof :entry-count) 1))
(should
(cl-some
(lambda (entry)
(and (eq (car entry) 'shadow-proof)
(eq (cadr entry) 'commit)))
tp--last-transaction-diagnostics)))))
(ert-deftest tp-transaction-test-zero-surface-does-not-create-batch-or-outcome () (ert-deftest tp-transaction-test-zero-surface-does-not-create-batch-or-outcome ()
"Pure, semantic and external-only transactions stay outside batch API." "Pure, semantic and external-only transactions stay outside batch API."
(let ((tp--last-transaction-outcome 'sentinel) (let ((tp--last-transaction-outcome 'sentinel)
@ -813,7 +927,8 @@
(should-not captured-outcome) (should-not captured-outcome)
(should-not tp--last-transaction-outcome) (should-not tp--last-transaction-outcome)
(tp-with-transaction (tp-with-transaction
(tp-transaction-participate 'external-only #'ignore #'ignore)) (tp-transaction-participate-v2 :key 'external-only
:stage #'ignore :rollback #'ignore))
(should-not tp--last-transaction-outcome))) (should-not tp--last-transaction-outcome)))
(ert-deftest tp-transaction-test-unobserved-signal-excludes-publication-batch () (ert-deftest tp-transaction-test-unobserved-signal-excludes-publication-batch ()
@ -830,8 +945,7 @@
(should (= (tp-signal-peek signal) 2)) (should (= (tp-signal-peek signal) 2))
(should (= (tp-signal-revision signal) 1)) (should (= (tp-signal-revision signal) 1))
(should (= batch-calls 0)) (should (= batch-calls 0))
(should-not tp--last-transaction-outcome) (should-not tp--last-transaction-outcome))
(should-not tp--last-shadow-proof))
(when (tp-signal-live-p signal) (tp-signal-dispose signal))))) (when (tp-signal-live-p signal) (tp-signal-dispose signal)))))
(ert-deftest tp-transaction-test-surface-unmount-excludes-publication-batch () (ert-deftest tp-transaction-test-surface-unmount-excludes-publication-batch ()
@ -845,8 +959,7 @@
(batch-calls 0)) (batch-calls 0))
(unwind-protect (unwind-protect
(progn (progn
(setq tp--last-transaction-outcome nil (setq tp--last-transaction-outcome nil)
tp--last-shadow-proof nil)
(cl-letf (cl-letf
(((symbol-function 'tp--transaction-begin-publication-batch) (((symbol-function 'tp--transaction-begin-publication-batch)
(lambda (&rest arguments) (lambda (&rest arguments)
@ -855,7 +968,6 @@
(tp-surface-unmount surface)) (tp-surface-unmount surface))
(should (= batch-calls 0)) (should (= batch-calls 0))
(should-not tp--last-transaction-outcome) (should-not tp--last-transaction-outcome)
(should-not tp--last-shadow-proof)
(should-not (tp-surface-live-p surface)) (should-not (tp-surface-live-p surface))
(with-current-buffer buffer (with-current-buffer buffer
(should (equal (buffer-string) "")))) (should (equal (buffer-string) ""))))
@ -911,13 +1023,11 @@
(should (= (length outcome-cell) 1)) (should (= (length outcome-cell) 1))
(should (tp-committed-success-outcome-p (aref outcome-cell 0))) (should (tp-committed-success-outcome-p (aref outcome-cell 0)))
(should (eq (aref outcome-cell 0) tp--last-transaction-outcome)) (should (eq (aref outcome-cell 0) tp--last-transaction-outcome))
(should (plist-get tp--last-shadow-proof :equivalent))
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (tp-surface-revision surface) (1+ old-revision))) (should (= (tp-surface-revision surface) (1+ old-revision)))
(with-current-buffer buffer (with-current-buffer buffer
(should (equal (buffer-string) "2")))))) (should (equal (buffer-string) "2"))))))
(ert-deftest tp-transaction-test-scoped-content-shadow-equivalence () (ert-deftest tp-transaction-test-scoped-content-v2-publication ()
"Scoped content artifacts equal the single committed writer result." "Scoped content artifacts equal the single committed writer result."
(let ((buffer (generate-new-buffer " *tp-transaction-scoped*")) (let ((buffer (generate-new-buffer " *tp-transaction-scoped*"))
(middle "B") (middle "B")
@ -950,9 +1060,8 @@
(revision (tp-surface-revision surface))) (revision (tp-surface-revision surface)))
(setq middle "LONG" (setq middle "LONG"
middle-face 'italic) middle-face 'italic)
(let ((tp--transaction-artifact-mode 'shadow)) (tp-surface-update-scoped
(tp-surface-update-scoped surface (list middle-object) producer)
surface (list middle-object) producer))
(should (= (tp-surface-revision surface) (1+ revision))) (should (= (tp-surface-revision surface) (1+ revision)))
(with-current-buffer buffer (with-current-buffer buffer
(should (equal (buffer-string) "ALONGC")) (should (equal (buffer-string) "ALONGC"))
@ -960,14 +1069,10 @@
(should (tp-committed-success-outcome-p (should (tp-committed-success-outcome-p
tp--last-transaction-outcome)) tp--last-transaction-outcome))
(tp-transaction-test--should-match-outcome-counts (tp-transaction-test--should-match-outcome-counts
tp--last-transaction-outcome (list surface)) tp--last-transaction-outcome (list surface)))
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
(should (plist-get tp--last-shadow-proof :equivalent))
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (plist-get tp--last-shadow-proof :entry-count) 1)))
(when (buffer-live-p buffer) (kill-buffer buffer))))) (when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest tp-transaction-test-properties-only-shadow-equivalence () (ert-deftest tp-transaction-test-properties-only-v2-publication ()
"Properties-only artifacts equal live properties without replacing text." "Properties-only artifacts equal live properties without replacing text."
(let ((buffer (generate-new-buffer " *tp-transaction-properties*")) (let ((buffer (generate-new-buffer " *tp-transaction-properties*"))
(value 'bold)) (value 'bold))
@ -988,19 +1093,14 @@
buffer producer '(:capability properties))) buffer producer '(:capability properties)))
(revision (tp-surface-revision surface))) (revision (tp-surface-revision surface)))
(setq value 'italic) (setq value 'italic)
(let ((tp--transaction-artifact-mode 'shadow)) (tp-surface-update surface producer)
(tp-surface-update surface producer))
(should (equal (buffer-string) "host")) (should (equal (buffer-string) "host"))
(should (eq (get-text-property 2 'face) 'italic)) (should (eq (get-text-property 2 'face) 'italic))
(should (= (tp-surface-revision surface) (1+ revision))) (should (= (tp-surface-revision surface) (1+ revision)))
(should (tp-committed-success-outcome-p (should (tp-committed-success-outcome-p
tp--last-transaction-outcome)) tp--last-transaction-outcome))
(tp-transaction-test--should-match-outcome-counts (tp-transaction-test--should-match-outcome-counts
tp--last-transaction-outcome (list surface)) tp--last-transaction-outcome (list surface))))
(should (equal (plist-get tp--last-shadow-proof :phase) 'commit))
(should (plist-get tp--last-shadow-proof :equivalent))
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (plist-get tp--last-shadow-proof :entry-count) 1))))
(when (buffer-live-p buffer) (kill-buffer buffer))))) (when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest tp-transaction-test-property-surface-fault-matrix-restores-exact-state () (ert-deftest tp-transaction-test-property-surface-fault-matrix-restores-exact-state ()
@ -1071,11 +1171,11 @@
(lambda () (lambda ()
(tp-with-transaction (tp-with-transaction
(when (eq phase 'participant) (when (eq phase 'participant)
(tp-transaction-participate (tp-transaction-participate-v2
'property-fault-participant :key 'property-fault-participant
(lambda () :stage (lambda ()
(signal (car injected) (cdr injected))) (signal (car injected) (cdr injected)))
#'ignore)) :rollback #'ignore))
(tp-signal-set source 2))))) (tp-signal-set source 2)))))
injected))) injected)))
(should (= (tp-signal-peek source) 1)) (should (= (tp-signal-peek source) 1))
@ -1089,62 +1189,118 @@
(with-current-buffer second-buffer (with-current-buffer second-buffer
(should (eq (get-text-property 2 'face) 'bold))) (should (eq (get-text-property 2 'face) 'bold)))
(should (tp-publication-failure-outcome-p (should (tp-publication-failure-outcome-p
tp--last-transaction-outcome)) tp--last-transaction-outcome)))
(should (equal (plist-get tp--last-shadow-proof :phase)
'rollback))
(should (plist-get tp--last-shadow-proof :equivalent))
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (plist-get tp--last-shadow-proof :entry-count) 2)))
(when (buffer-live-p first-buffer) (kill-buffer first-buffer)) (when (buffer-live-p first-buffer) (kill-buffer first-buffer))
(when (buffer-live-p second-buffer) (kill-buffer second-buffer)) (when (buffer-live-p second-buffer) (kill-buffer second-buffer))
(when (tp-signal-live-p source) (tp-signal-dispose source)))))) (when (tp-signal-live-p source) (tp-signal-dispose source))))))
(ert-deftest tp-transaction-test-v1-and-shadow-artifact-modes-are-equivalent () (ert-deftest tp-transaction-test-final-accept-source-uses-v2-binding ()
"Independent v1 and shadow surfaces commit identical live artifacts." "V2 validates the candidate final accept binding before publication."
(let* ((v1-buffer (generate-new-buffer " *tp-transaction-v1*")) (let* ((structured-buffer (generate-new-buffer " *tp-final-structured*"))
(shadow-buffer (generate-new-buffer " *tp-transaction-shadow*")) (initial (tp-transaction-test--leaf "old"))
(initial (next (tp-transaction-test--leaf "new"))
(tp-surface-plan-create (structured (tp-surface-mount structured-buffer initial
:key 'root :kind 'text :text "old" :props '(face bold) '(:capability content)))
:capability 'content)) (sync (symbol-function 'tp--transaction-sync-publication-batch)))
(next
(tp-surface-plan-create
:key 'root :kind 'text :text "new" :props '(face italic)
:capability 'content))
(v1-surface
(tp-surface-mount v1-buffer initial '(:capability content)))
(shadow-surface
(tp-surface-mount shadow-buffer initial '(:capability content)))
(writer (symbol-function 'tp--publish-one-surface))
(shadow-writes 0))
(unwind-protect (unwind-protect
(progn (cl-letf (((symbol-function 'tp--transaction-sync-publication-batch)
(let ((tp--transaction-artifact-mode 'v1)) (lambda ()
(tp-surface-update v1-surface next)) (funcall sync)
(should-not tp--last-transaction-outcome) (when tp--transaction-publication-batch
(should-not tp--last-shadow-proof) (setf (tp-publication-batch-candidate-final-accept
(cl-letf (((symbol-function 'tp--publish-one-surface) tp--transaction-publication-batch)
(lambda (prepared) #'ignore)))))
(cl-incf shadow-writes) (should-error (tp-surface-update structured next)
(funcall writer prepared)))) :type 'tp-publication-binding-error)
(let ((tp--transaction-artifact-mode 'shadow)) (with-current-buffer structured-buffer
(tp-surface-update shadow-surface next))) (should (equal (buffer-string) "old")))
(should (= shadow-writes 1)) (should (tp-publication-failure-outcome-p
(should (tp-committed-success-outcome-p tp--last-transaction-outcome)))
tp--last-transaction-outcome)) (when (buffer-live-p structured-buffer) (kill-buffer structured-buffer))
(should (plist-get tp--last-shadow-proof :equivalent)) )))
(should (plist-get tp--last-shadow-proof :outcome-equivalent))
(should (= (tp-surface-revision v1-surface) (ert-deftest tp-transaction-test-structured-batch-owns-surface-stage-once ()
(tp-surface-revision shadow-surface))) "Structured execution enters the candidate seam and writes each entry once."
(should (let* ((source (tp-signal-create 1))
(equal-including-properties (producer (tp-transaction-test--producer source))
(with-current-buffer v1-buffer (buffer-string)) (first-buffer (generate-new-buffer " *tp-structured-first*"))
(with-current-buffer shadow-buffer (buffer-string)))) (second-buffer (generate-new-buffer " *tp-structured-second*"))
(with-current-buffer v1-buffer (first (tp-surface-mount first-buffer producer '(:capability content)))
(should (equal (buffer-string) "new")) (second (tp-surface-mount second-buffer producer '(:capability content)))
(should (eq (get-text-property 1 'face) 'italic)))) (execute (symbol-function 'tp--publication-batch-execute-stage))
(when (buffer-live-p v1-buffer) (kill-buffer v1-buffer)) (writer (symbol-function 'tp--publish-one-surface))
(when (buffer-live-p shadow-buffer) (kill-buffer shadow-buffer))))) (calls (make-hash-table :test #'eq))
(stage-calls 0))
(unwind-protect
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
(lambda (candidate)
(cl-incf stage-calls)
(funcall execute candidate)))
((symbol-function 'tp--publish-one-surface)
(lambda (prepared)
(let ((surface (tp--prepared-surface-surface prepared)))
(puthash surface (1+ (gethash surface calls 0)) calls))
(funcall writer prepared))))
(tp-signal-set source 2)
(should (= stage-calls 1))
(should (= (gethash first calls 0) 1))
(should (= (gethash second calls 0) 1))
(should (tp-committed-success-outcome-p tp--last-transaction-outcome)))
(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-transaction-test-public-v2-participant-stages-once-from-batch ()
"The public v2 participant is one structured participant in the batch vector."
(tp-transaction-test--with-surface (buffer _surface source)
(let ((stages 0) captured participant)
(tp-with-transaction
(tp-transaction-participate-v2
:key 'public-v2
:stage (lambda ()
(cl-incf stages)
(setq captured tp--transaction-publication-batch
participant
(aref (tp-publication-batch-candidate-participants
tp--transaction-publication-batch)
0)))
:rollback #'ignore)
(tp-signal-set source 2))
(should (= stages 1))
(should (tp-publication-batch-candidate-p captured))
(should (eq (tp--transaction-participant-protocol participant) 'v2))
(should (eq (tp--transaction-participant-state participant) 'committed)))))
(ert-deftest tp-transaction-test-batch-rejects-foreign-stage-capability ()
"A publication batch accepts only the closed package-owned stage seam."
(should-error
(tp--publication-batch-prepare
:transaction-id 'transaction-a
:batch-id 'batch-a
:entries (list (tp-transaction-test--entry))
:participants []
:journals nil
:stage-entries #'ignore
:final-accept #'ignore)
:type 'tp-publication-binding-error))
(ert-deftest tp-transaction-test-participant-vector-drift-rolls-back-surfaces ()
"Registration drift after batch binding fails fast and restores live state."
(tp-transaction-test--with-surface (buffer surface source)
(let ((revision (tp-surface-revision surface))
(stage (symbol-function 'tp--publication-batch-execute-stage)))
(cl-letf (((symbol-function 'tp--publication-batch-execute-stage)
(lambda (candidate)
(tp-transaction-participate-v2 :key 'late
:stage #'ignore
:rollback #'ignore)
(funcall stage candidate))))
(should-error (tp-signal-set source 2)
:type 'tp-publication-binding-error))
(should (= (tp-signal-peek source) 1))
(should (= (tp-surface-revision surface) revision))
(with-current-buffer buffer
(should (equal (buffer-string) "1"))))))
(ert-deftest tp-transaction-test-ordinary-update-success-has-zero-markers () (ert-deftest tp-transaction-test-ordinary-update-success-has-zero-markers ()
"An ordinary publication records zero final authority markers." "An ordinary publication records zero final authority markers."
@ -1220,7 +1376,7 @@
(should (eq (aref overflow-target 0) 'old))))) (should (eq (aref overflow-target 0) 'old)))))
(ert-deftest tp-transaction-test-marker-restore-faults-exhaust-all-markers () (ert-deftest tp-transaction-test-marker-restore-faults-exhaust-all-markers ()
"Restore error, quit, and throw cannot skip markers or v1 rollback." "Restore error, quit, and throw cannot skip markers or rollback."
(dolist (kind '(error quit throw)) (dolist (kind '(error quit throw))
(tp-transaction-test--with-surface (buffer surface source) (tp-transaction-test--with-surface (buffer surface source)
(let* ((targets (let* ((targets
@ -1303,7 +1459,7 @@
'(tp-transaction-test-error :phase after-commit)))) '(tp-transaction-test-error :phase after-commit))))
tp--last-transaction-diagnostics)))) tp--last-transaction-diagnostics))))
(ert-deftest tp-transaction-test-marker-nonlocal-throw-restores-v1-state () (ert-deftest tp-transaction-test-marker-nonlocal-throw-restores-state ()
"Marker apply and accept throws reverse authority and live publication." "Marker apply and accept throws reverse authority and live publication."
(dolist (phase '(apply accept)) (dolist (phase '(apply accept))
(tp-transaction-test--with-surface (buffer surface source) (tp-transaction-test--with-surface (buffer surface source)
@ -1340,23 +1496,31 @@
(with-current-buffer buffer (with-current-buffer buffer
(should (equal (buffer-string) "1"))))))) (should (equal (buffer-string) "1")))))))
(ert-deftest tp-transaction-test-manifest-advertises-v1-plus-v2 () (ert-deftest tp-transaction-test-manifest-advertises-v2-only-contract ()
"The TP manifest retains v1 while advertising the additive protocol." "The manifest advertises v2 without any legacy route capability."
(should (eq tp-transaction-protocol (should (eq tp-transaction-protocol 'tp-transaction-protocol-v2))
'tp-transaction-protocol-v1+v2))
(let ((manifest (tp-runtime-manifest))) (let ((manifest (tp-runtime-manifest)))
(should (equal (plist-get manifest :version) "1.0.0")) (should (equal (plist-get manifest :version) "2.0.0"))
(should (eq (plist-get manifest :transaction-protocol) (should (eq (plist-get manifest :transaction-protocol)
'tp-transaction-protocol-v1+v2)) 'tp-transaction-protocol-v2))
(should (eq (plist-get manifest :structured-participant-api)
'tp-transaction-participate-v2))
(should (plist-get manifest :batch-artifacts)) (should (plist-get manifest :batch-artifacts))
(should (eq (plist-get manifest :batch-execution) 'v1-bridge)) (should (plist-get manifest :batch-execute))
(should-not (plist-get manifest :batch-execute)) (should (plist-get manifest :single-live-writer))
(should (plist-get manifest :shadow-proof)) (dolist (property '(:execution-route :execution-default :execution-routes
(should (eq (plist-get manifest :final-marker-operation) :route-option :batch-execution :v1-adapter
'tp-vector-slots/v1)) :v1-rollback-route))
(setf (plist-get manifest :transaction-protocol) 'mutated) (should-not (plist-member manifest property)))))
(should (eq (plist-get (tp-runtime-manifest) :transaction-protocol)
'tp-transaction-protocol-v1+v2)))) (ert-deftest tp-transaction-test-v1-public-controls-are-absent ()
"TP 2.0 exposes no executable v1 facade or route switches."
(should-not (fboundp 'tp-transaction-participate))
(should-not (fboundp 'tp--publish-transaction-participants))
(should-not (fboundp 'tp--surface-stage-v1-prepared))
(should-not (fboundp 'tp--transaction-validate-execution-route))
(should-not (boundp 'tp-transaction-execution-route))
(should-not (boundp 'tp--transaction-artifact-mode)))
(provide 'tp-transaction-tests) (provide 'tp-transaction-tests)

View File

@ -279,6 +279,7 @@ Otherwise, START-OR-STRING and END define the range."
(and (not (functionp value)) (and (not (functionp value))
(or (consp value) (or (consp value)
(stringp value) (stringp value)
(char-table-p value)
(and (vectorp value) (not (recordp value)))))) (and (vectorp value) (not (recordp value))))))
(defun tp--copy-cons-spine (value cache) (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)) (if (and (not (functionp item))
(or (consp item) (or (consp item)
(stringp item) (stringp item)
(char-table-p item)
(and (vectorp item) (not (recordp item))))) (and (vectorp item) (not (recordp item)))))
(tp--copy-property-value item cache) (tp--copy-property-value item cache)
item))) item)))
@ -344,6 +346,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
(when (and (not (functionp item)) (when (and (not (functionp item))
(or (consp item) (or (consp item)
(stringp item) (stringp item)
(char-table-p item)
(and (vectorp item) (not (recordp item))))) (and (vectorp item) (not (recordp item)))))
(setcar target (tp--copy-property-value item cache)))) (setcar target (tp--copy-property-value item cache))))
(setq source (cdr source) (setq source (cdr source)
@ -406,7 +409,8 @@ values are recursively isolated."
(defun tp--copy-property-value (value &optional cache) (defun tp--copy-property-value (value &optional cache)
"Return a defensive copy of mutable containers in property VALUE. "Return a defensive copy of mutable containers in property VALUE.
Optional CACHE preserves sharing and cycles across recursive copies. Optional CACHE preserves sharing and cycles across recursive copies.
Cons cells, strings, and vectors are copied recursively. Functions, records, Cons cells, strings, vectors and character tables are copied recursively.
Functions, records,
and other opaque objects keep their identity; functions are never executed." and other opaque objects keep their identity; functions are never executed."
(if (not (tp--copy-mutable-property-value-p value)) (if (not (tp--copy-mutable-property-value-p value))
value value
@ -420,6 +424,29 @@ and other opaque objects keep their identity; functions are never executed."
(tp--copy-proper-cons-list value cache) (tp--copy-proper-cons-list value cache)
(tp--copy-cons-spine value cache))) (tp--copy-cons-spine value cache)))
((stringp value) (tp--copy-string-with-properties 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) ((vectorp value)
(let ((copy (copy-sequence value))) (let ((copy (copy-sequence value)))
(puthash value copy cache) (puthash value copy cache)
@ -431,7 +458,8 @@ and other opaque objects keep their identity; functions are never executed."
(defun tp-property-value-copy (value) (defun tp-property-value-copy (value)
"Return a defensive copy of mutable text-property VALUE. "Return a defensive copy of mutable text-property VALUE.
Functions, records, and other opaque identities are retained; mutable cons, 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))) (tp--copy-property-value value (make-hash-table :test #'eq)))
(defun tp--deep-merge-plist (base new) (defun tp--deep-merge-plist (base new)

View File

@ -11,7 +11,7 @@
;;; Commentary: ;;; 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. ;; scheduler, scoped variable adapters, and rollback state.
;;; Code: ;;; Code:
@ -44,8 +44,8 @@
(cl-defstruct (tp--transaction-participant (cl-defstruct (tp--transaction-participant
(:constructor tp--make-transaction-participant)) (:constructor tp--make-transaction-participant))
"One structured participant shared by the v1 and v2 transaction views." "One structured transaction participant."
key publish rollback protocol order stage precommit after-commit journal state) key rollback protocol order stage precommit after-commit journal state)
(cl-defstruct (tp--signal-commit-entry (cl-defstruct (tp--signal-commit-entry
(:constructor tp--make-signal-commit-entry)) (:constructor tp--make-signal-commit-entry))
@ -94,6 +94,7 @@
(defvar tp--transaction-phase-start nil) (defvar tp--transaction-phase-start nil)
(defvar tp--transaction-phase-timings nil) (defvar tp--transaction-phase-timings nil)
(defvar tp--transaction-publication-batch 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-registry nil)
(defvar tp--transaction-final-marker-owner-keys nil) (defvar tp--transaction-final-marker-owner-keys nil)
(defvar tp--transaction-final-marker-count 0) (defvar tp--transaction-final-marker-count 0)
@ -126,9 +127,6 @@
(defvar tp--transaction-rollback-final-functions nil) (defvar tp--transaction-rollback-final-functions nil)
(defvar tp--transaction-committed-functions nil) (defvar tp--transaction-committed-functions nil)
(defvar tp--transaction-artifact-mode 'shadow
"Internal artifact route; the live writer remains the v1 coordinator.")
(defvar tp--transaction-participant-precommit-allowed-functions nil (defvar tp--transaction-participant-precommit-allowed-functions nil
"Declared internal structured-participant precommit validators.") "Declared internal structured-participant precommit validators.")
@ -660,7 +658,7 @@ When CREATE is non-nil, install and return a fresh hash table when absent."
(fboundp function)))) (fboundp function))))
(defun tp--transaction-register-participant (participant) (defun tp--transaction-register-participant (participant)
"Register structured PARTICIPANT in the authoritative v1 participant list." "Register structured PARTICIPANT once in the active transaction."
(unless tp--transaction-active (unless tp--transaction-active
(signal 'tp-reactive-error (signal 'tp-reactive-error
(list :participant-outside-transaction (list :participant-outside-transaction
@ -675,12 +673,12 @@ When CREATE is non-nil, install and return a fresh hash table when absent."
participant)) participant))
(defun tp--transaction-make-participant (defun tp--transaction-make-participant
(key publish rollback protocol precommit after-commit journal) (key stage rollback protocol precommit after-commit journal)
"Build a participant from KEY, PUBLISH, ROLLBACK, and PROTOCOL. "Build a participant from KEY, STAGE, ROLLBACK, and PROTOCOL.
PRECOMMIT and AFTER-COMMIT are optional internal callbacks; JOURNAL is opaque PRECOMMIT and AFTER-COMMIT are optional internal callbacks; JOURNAL is opaque
owner-local rollback state." owner-local rollback state."
(unless (functionp publish) (unless (functionp stage)
(signal 'wrong-type-argument (list 'functionp publish))) (signal 'wrong-type-argument (list 'functionp stage)))
(unless (functionp rollback) (unless (functionp rollback)
(signal 'wrong-type-argument (list 'functionp rollback))) (signal 'wrong-type-argument (list 'functionp rollback)))
(unless (tp--transaction-participant-precommit-function-p precommit) (unless (tp--transaction-participant-precommit-function-p precommit)
@ -690,39 +688,19 @@ owner-local rollback state."
(signal 'wrong-type-argument (list 'functionp after-commit))) (signal 'wrong-type-argument (list 'functionp after-commit)))
(tp--make-transaction-participant (tp--make-transaction-participant
:key (tp--copy-property-value key) :key (tp--copy-property-value key)
:publish publish
:rollback rollback :rollback rollback
:protocol protocol :protocol protocol
:order (prog1 tp--transaction-participant-order :order (prog1 tp--transaction-participant-order
(cl-incf tp--transaction-participant-order)) (cl-incf tp--transaction-participant-order))
:stage publish :stage stage
:precommit precommit :precommit precommit
:after-commit after-commit :after-commit after-commit
:journal journal :journal journal
:state 'prepared)) :state 'prepared))
;;;###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. The public v1 route is retained and receives an internal v2
structured view over the same participant object."
(unless tp--transaction-active
(signal 'tp-reactive-error (list :participant-outside-transaction key)))
(unless key
(signal 'tp-reactive-error (list :participant-key key)))
(let ((participant
(tp--transaction-make-participant
key publish rollback 'v1-bridge nil nil nil)))
(tp--transaction-register-participant participant)
key))
(cl-defun tp--transaction-participate-v2 (cl-defun tp--transaction-participate-v2
(&key key stage rollback precommit after-commit journal) (&key key stage rollback precommit after-commit journal)
"Register internal KEY with STAGE and ROLLBACK through the v1 coordinator. "Register internal KEY with structured STAGE and ROLLBACK capabilities.
PRECOMMIT and AFTER-COMMIT are optional declared callbacks. JOURNAL is the PRECOMMIT and AFTER-COMMIT are optional declared callbacks. JOURNAL is the
participant's opaque owner-local state." participant's opaque owner-local state."
(unless tp--transaction-active (unless tp--transaction-active
@ -733,17 +711,55 @@ participant's opaque owner-local state."
(tp--transaction-make-participant (tp--transaction-make-participant
key stage rollback 'v2 precommit after-commit journal))) 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--transaction-participants-in-registration-order () (defun tp--transaction-participants-in-registration-order ()
"Return the authoritative participants in deterministic declaration order." "Return the authoritative participants in deterministic declaration order."
(reverse tp--transaction-participants)) (reverse tp--transaction-participants))
(defun tp--publish-transaction-participants () (defun tp--transaction-validate-structured-participants ()
"Publish registered transaction participants in declaration order." "Return the frozen participant vector after exact identity validation."
(dolist (participant (tp--transaction-participants-in-registration-order)) (let* ((participants tp--transaction-structured-participants)
(push participant tp--transaction-published-participants) (registered (tp--transaction-participants-in-registration-order))
;; Mark first so a stage that mutates and then signals remains rollbackable. (count (length registered)))
(setf (tp--transaction-participant-state participant) 'staged) (unless (and (vectorp participants) (= (length participants) count))
(funcall (tp--transaction-participant-publish participant)))) (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)
(setf (tp--transaction-participant-state participant) 'staged)
(funcall (tp--transaction-participant-stage participant))))))
(defun tp--rollback-transaction-participants () (defun tp--rollback-transaction-participants ()
"Rollback published participants and return any failures." "Rollback published participants and return any failures."
@ -763,23 +779,28 @@ participant's opaque owner-local state."
(setf (tp--transaction-participant-state participant) 'rolled-back))) (setf (tp--transaction-participant-state participant) 'rolled-back)))
(nreverse failures))) (nreverse failures)))
(defun tp--run-transaction-participant-precommits () (defun tp--run-structured-transaction-participant-precommits ()
"Run declared structured participant validators in registration order." "Run validators from the frozen structured participant vector."
(dolist (participant (tp--transaction-participants-in-registration-order)) (let ((participants (tp--transaction-validate-structured-participants)))
(when-let* ((function (tp--transaction-participant-precommit participant))) (dotimes (index (length participants))
(unless (tp--transaction-participant-precommit-function-p function)
(signal 'tp-reactive-error
(list :invalid-participant-precommit function)))
(funcall function))))
(defun tp--commit-transaction-participants ()
"Commit participant states and queue their contained after-commit work."
(dolist (participant (tp--transaction-participants-in-registration-order))
(when (eq (tp--transaction-participant-state participant) 'staged)
(setf (tp--transaction-participant-state participant) 'committed)
(when-let* ((function (when-let* ((function
(tp--transaction-participant-after-commit participant))) (tp--transaction-participant-precommit
(tp--enqueue-after-commit function))))) (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 () (defun tp--dequeue-dirty-binding ()
"Return and remove the next queued dirty binding." "Return and remove the next queued dirty binding."
@ -867,14 +888,6 @@ participant's opaque owner-local state."
tp--transaction-final-accept-function function))) tp--transaction-final-accept-function function)))
(setq tp--transaction-final-accept-function function)) (setq tp--transaction-final-accept-function function))
(defun tp--transaction-v2-artifacts-enabled-p ()
"Return non-nil when the additive v2 shadow artifacts are enabled."
(pcase tp--transaction-artifact-mode
('v1 nil)
((or 'shadow 'v1+v2-shadow) t)
(_ (signal 'tp-transaction-contract-error
(list :artifact-mode tp--transaction-artifact-mode)))))
(defun tp--transaction-current-outcome-cell () (defun tp--transaction-current-outcome-cell ()
"Return the active transaction's caller-retainable one-slot outcome cell." "Return the active transaction's caller-retainable one-slot outcome cell."
(unless tp--transaction-active (unless tp--transaction-active
@ -913,24 +926,24 @@ participant's opaque owner-local state."
surface-journals)) surface-journals))
(defun tp--transaction-begin-publication-batch (defun tp--transaction-begin-publication-batch
(batch-id entries surface-journals) (batch-id entries surface-journals stage-entries)
"Install BATCH-ID as the candidate for ENTRIES and SURFACE-JOURNALS." "Install BATCH-ID for ENTRIES, SURFACE-JOURNALS, and STAGE-ENTRIES."
(unless tp--transaction-active (unless tp--transaction-active
(signal 'tp-reactive-error (list :batch-outside-transaction batch-id))) (signal 'tp-reactive-error (list :batch-outside-transaction batch-id)))
(when tp--transaction-publication-batch (when tp--transaction-publication-batch
(signal 'tp-publication-state-error (signal 'tp-publication-state-error
(list :duplicate-transaction-batch batch-id))) (list :duplicate-transaction-batch batch-id)))
(when (tp--transaction-v2-artifacts-enabled-p) (setq tp--transaction-publication-batch
(setq tp--transaction-publication-batch (tp--publication-batch-prepare
(tp--publication-batch-prepare :transaction-id tp--transaction-id
:transaction-id tp--transaction-id :batch-id batch-id
:batch-id batch-id :entries entries
:entries entries :participants
:participants tp--transaction-structured-participants
(vconcat (tp--transaction-participants-in-registration-order)) :journals (tp--transaction-batch-journal-view surface-journals)
:journals (tp--transaction-batch-journal-view surface-journals) :stage-entries stage-entries
:final-accept tp--transaction-final-accept-function :final-accept tp--transaction-final-accept-function
:diagnostics nil))) :diagnostics nil))
tp--transaction-publication-batch) tp--transaction-publication-batch)
(defun tp--transaction-batch-transition (next) (defun tp--transaction-batch-transition (next)
@ -986,6 +999,23 @@ against the trusted OPERATION-KEY descriptor and the transaction bound."
(cl-incf tp--transaction-final-marker-slot-writes slot-write-count) (cl-incf tp--transaction-final-marker-slot-writes slot-write-count)
marker)) 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 () (defun tp--transaction-freeze-final-markers ()
"Validate and seal every marker before signal commit and final accept." "Validate and seal every marker before signal commit and final accept."
(when (and (> tp--transaction-final-marker-count 0) (when (and (> tp--transaction-final-marker-count 0)
@ -1129,7 +1159,17 @@ against the trusted OPERATION-KEY descriptor and the transaction bound."
(unwind-protect (unwind-protect
(progn (progn
(tp--transaction-apply-final-markers) (tp--transaction-apply-final-markers)
(funcall tp--transaction-final-accept-function) (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)) (setq accepted t))
(unless accepted (unless accepted
(setq tp--transaction-marker-restore-failures (setq tp--transaction-marker-restore-failures
@ -1151,9 +1191,8 @@ against the trusted OPERATION-KEY descriptor and the transaction bound."
(tp--transaction-publish-outcome outcome)))))) (tp--transaction-publish-outcome outcome))))))
(defun tp--transaction-run-shadow-proof (phase) (defun tp--transaction-run-shadow-proof (phase)
"Compare v2 artifacts with the single v1 live result for PHASE." "Compare structured artifacts with the selected single live result for PHASE."
(when (and tp--transaction-publication-batch (when tp--transaction-publication-batch
(tp--transaction-v2-artifacts-enabled-p))
(let ((ok t) results outcome-equivalent) (let ((ok t) results outcome-equivalent)
(dolist (entry (dolist (entry
(tp-publication-batch-candidate-entries (tp-publication-batch-candidate-entries
@ -1418,6 +1457,7 @@ the primary condition data."
(tp--transaction-published-participants nil) (tp--transaction-published-participants nil)
(tp--transaction-signal-commit-journal nil) (tp--transaction-signal-commit-journal nil)
(tp--transaction-publication-batch nil) (tp--transaction-publication-batch nil)
(tp--transaction-structured-participants nil)
(tp--transaction-final-marker-registry (tp--transaction-final-marker-registry
(make-vector tp--final-marker-max-count nil)) (make-vector tp--final-marker-max-count nil))
(tp--transaction-final-marker-owner-keys (tp--transaction-final-marker-owner-keys
@ -1443,13 +1483,16 @@ the primary condition data."
(tp--transaction-enter-phase 'recompute) (tp--transaction-enter-phase 'recompute)
(tp--flush-dirty-bindings) (tp--flush-dirty-bindings)
(tp--transaction-enter-phase 'publication) (tp--transaction-enter-phase 'publication)
(setq tp--transaction-structured-participants
(vconcat
(tp--transaction-participants-in-registration-order)))
(run-hooks 'tp--transaction-publish-functions) (run-hooks 'tp--transaction-publish-functions)
(tp--transaction-batch-transition 'participants) (tp--transaction-batch-transition 'participants)
(tp--transaction-enter-phase 'participants) (tp--transaction-enter-phase 'participants)
(tp--publish-transaction-participants) (tp--stage-structured-transaction-participants)
(tp--transaction-batch-transition 'precommit) (tp--transaction-batch-transition 'precommit)
(tp--transaction-enter-phase 'precommit) (tp--transaction-enter-phase 'precommit)
(tp--run-transaction-participant-precommits) (tp--run-structured-transaction-participant-precommits)
(tp--run-transaction-precommit-functions) (tp--run-transaction-precommit-functions)
(tp--transaction-freeze-final-markers) (tp--transaction-freeze-final-markers)
(tp--transaction-sync-publication-batch) (tp--transaction-sync-publication-batch)
@ -1474,7 +1517,7 @@ the primary condition data."
tp--transaction-final-accept-function))) tp--transaction-final-accept-function)))
(tp--transaction-run-final-accept) (tp--transaction-run-final-accept)
(setq success t) (setq success t)
(tp--commit-transaction-participants) (tp--commit-structured-transaction-participants)
(tp--transaction-run-shadow-proof 'commit) (tp--transaction-run-shadow-proof 'commit)
(when quit-flag (when quit-flag
(setq pending-quit t (setq pending-quit t

View File

@ -205,12 +205,51 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
#'tp--merge-face-values #'tp--merge-face-values
(lambda (_old new) new))) (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) (defun tp-register-text-property (property)
"Register and return a direct policy for Emacs PROPERTY." "Register and return a direct policy for Emacs PROPERTY."
(let ((id (tp-text-property-id property))) (let ((id (tp-text-property-id property)))
(or (tp-property-policy id) (or (tp-property-policy id)
(tp-define-property-policy (tp-define-property-policy
id :equality #'equal id :equality #'tp--native-property-value-equal-p
:merge (tp--text-property-merge-function property) :merge (tp--text-property-merge-function property)
:projector (lambda (value) (list property value)))))) :projector (lambda (value) (list property value))))))

File diff suppressed because it is too large Load Diff

View File

@ -1,4 +1,4 @@
;;; tp-transaction.el --- Additive publication transaction contracts -*- lexical-binding: t; -*- ;;; tp-transaction.el --- Structured publication transaction contracts -*- lexical-binding: t; -*-
;; Copyright (C) 2026 Geekinney ;; Copyright (C) 2026 Geekinney
@ -11,10 +11,11 @@
;;; Commentary: ;;; Commentary:
;; Internal immutable artifacts and one-shot state machines used to shadow TP's ;; Internal immutable artifacts and one-shot state machines for TP publication.
;; v1 publication coordinator. This module owns no live writer and never edits ;; The package-owned entry-stage capability stored in a batch candidate drives
;; a buffer. `tp-reactive' drives the state machine, while `tp-surface' supplies ;; publication. This module never edits a buffer itself: `tp-reactive' drives
;; exact target entries backed by the v1 prepare journals and snapshots. ;; the state machine and `tp-surface' supplies and stages exact target entries
;; backed by the shared prepare journals and snapshots.
;;; Code: ;;; Code:
@ -33,7 +34,7 @@
"Invalid TP final-accept marker" "Invalid TP final-accept marker"
'tp-transaction-contract-error) 'tp-transaction-contract-error)
(defconst tp-transaction-protocol 'tp-transaction-protocol-v1+v2 (defconst tp-transaction-protocol 'tp-transaction-protocol-v2
"Transaction protocol implemented by this TP package version.") "Transaction protocol implemented by this TP package version.")
(defconst tp--publication-batch-transitions (defconst tp--publication-batch-transitions
@ -48,6 +49,10 @@
'(committed rolled-back discarded) '(committed rolled-back discarded)
"Terminal publication batch candidate states.") "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 (defconst tp--final-marker-max-count 8
"Maximum number of opaque final markers in one transaction.") "Maximum number of opaque final markers in one transaction.")
@ -78,11 +83,12 @@
(defun tp--proper-unique-list-p (items) (defun tp--proper-unique-list-p (items)
"Return non-nil when ITEMS is a proper list with no equal duplicates." "Return non-nil when ITEMS is a proper list with no equal duplicates."
(and (proper-list-p items) (and (proper-list-p items)
(let (seen (unique t)) (let ((seen (make-hash-table :test #'equal))
(unique t))
(dolist (item items unique) (dolist (item items unique)
(if (member item seen) (if (gethash item seen)
(setq unique nil) (setq unique nil)
(push item seen)))))) (puthash item t seen))))))
(cl-defstruct (tp-publication-target-entry (cl-defstruct (tp-publication-target-entry
(:constructor tp--make-publication-target-entry) (:constructor tp--make-publication-target-entry)
@ -110,6 +116,20 @@
(shadow-validator nil :read-only t) (shadow-validator nil :read-only t)
rollback-result post-rollback-state shadow-actual shadow-proven-p) 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 (cl-defun tp--publication-target-entry-create
(&key transaction-id batch-id candidate-id surface-id mount-ids buffer (&key transaction-id batch-id candidate-id surface-id mount-ids buffer
old-revision new-revision plan diff ledger objects ranges client-state old-revision new-revision plan diff ledger objects ranges client-state
@ -119,15 +139,11 @@
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN, CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN,
DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
AUTHORITY-TOKEN describe the target. MAPPING-GENERATION is optional. AUTHORITY-TOKEN describe the target. MAPPING-GENERATION is optional.
OPERATION-COUNTS is filled from the v1 report. SHADOW-EXPECTED and OPERATION-COUNTS is filled from the live report. SHADOW-EXPECTED and
SHADOW-VALIDATOR are private comparison artifacts." SHADOW-VALIDATOR are private comparison artifacts."
(unless (and transaction-id batch-id candidate-id surface-id (unless (tp--publication-target-entry-arguments-valid-p
(bufferp buffer) (buffer-live-p buffer) transaction-id batch-id candidate-id surface-id mount-ids buffer
(integerp old-revision) (>= old-revision 0) old-revision new-revision authority-token shadow-validator)
(integerp new-revision) (= new-revision (1+ old-revision))
(tp--proper-unique-list-p mount-ids)
authority-token
(or (null shadow-validator) (functionp shadow-validator)))
(signal 'tp-publication-binding-error (signal 'tp-publication-binding-error
(list :target-entry transaction-id batch-id candidate-id surface-id (list :target-entry transaction-id batch-id candidate-id surface-id
buffer old-revision new-revision mount-ids authority-token))) buffer old-revision new-revision mount-ids authority-token)))
@ -222,7 +238,7 @@ SHADOW-VALIDATOR are private comparison artifacts."
(cl-defstruct (tp-publication-batch-candidate (cl-defstruct (tp-publication-batch-candidate
(:constructor tp--make-publication-batch-candidate) (:constructor tp--make-publication-batch-candidate)
(:copier nil)) (:copier nil))
"A one-shot structured view over the existing v1 transaction state." "A one-shot structured publication authority over shared rollback state."
(transaction-id nil :read-only t) (transaction-id nil :read-only t)
(id nil :read-only t) (id nil :read-only t)
state state
@ -230,6 +246,7 @@ SHADOW-VALIDATOR are private comparison artifacts."
(entries nil :read-only t) (entries nil :read-only t)
(participants nil :read-only t) (participants nil :read-only t)
(journals nil :read-only t) (journals nil :read-only t)
(stage-entries nil :read-only t)
final-accept final-accept
(final-accept-id nil :read-only t) (final-accept-id nil :read-only t)
diagnostics diagnostics
@ -271,16 +288,22 @@ SHADOW-VALIDATOR are private comparison artifacts."
entries)))) entries))))
(cl-defun tp--publication-batch-prepare (cl-defun tp--publication-batch-prepare
(&key transaction-id batch-id entries participants journals final-accept (&key transaction-id batch-id entries participants journals stage-entries
diagnostics) final-accept diagnostics)
"Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES. "Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES.
PARTICIPANTS is an ordered reference vector, JOURNALS is the existing v1 state PARTICIPANTS is an ordered reference vector, JOURNALS is the shared rollback
view, FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains view, STAGE-ENTRIES is an optional package-owned execution capability,
known preaccept observations." FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains known
preaccept observations."
(unless (and transaction-id batch-id (unless (and transaction-id batch-id
(tp--publication-batch-entries-valid-p (tp--publication-batch-entries-valid-p
entries transaction-id batch-id) entries transaction-id batch-id)
(vectorp participants) (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)) (functionp final-accept))
(signal 'tp-publication-binding-error (signal 'tp-publication-binding-error
(list :batch transaction-id batch-id entries participants))) (list :batch transaction-id batch-id entries participants)))
@ -291,10 +314,21 @@ known preaccept observations."
:entries (copy-sequence entries) :entries (copy-sequence entries)
:participants participants :participants participants
:journals journals :journals journals
:stage-entries stage-entries
:final-accept final-accept :final-accept final-accept
:final-accept-id (tp--next-final-accept-id) :final-accept-id (tp--next-final-accept-id)
:diagnostics (tp--copy-property-value diagnostics))) :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) (defun tp--publication-batch-terminal-p (candidate)
"Return non-nil when CANDIDATE has one terminal disposition." "Return non-nil when CANDIDATE has one terminal disposition."
(and (tp-publication-batch-candidate-p candidate) (and (tp-publication-batch-candidate-p candidate)
@ -588,12 +622,22 @@ ROLLBACK-FAILURES and DIAGNOSTICS are observational snapshots."
(tp--make-final-marker-expectation (tp--make-final-marker-expectation
:target target :index index :value value)) :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) (cl-defun tp--final-marker-slot-write-create (&key target index value)
"Create one prebuilt write of VALUE into TARGET slot INDEX." "Create one prebuilt write of VALUE into TARGET slot INDEX."
(unless (tp--final-marker-vector-index-p target index) (unless (tp--final-marker-vector-index-p target index)
(signal 'tp-final-marker-error (list :slot-write target index))) (signal 'tp-final-marker-error (list :slot-write target index)))
(tp--make-final-marker-slot-write :target target :index index :value value)) (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) (defun tp--final-marker-expectation-current-p (expectation)
"Return non-nil when EXPECTATION matches its current fixed slot." "Return non-nil when EXPECTATION matches its current fixed slot."
(and (tp-final-marker-expectation-p expectation) (and (tp-final-marker-expectation-p expectation)

12
tp.el
View File

@ -2,7 +2,7 @@
;; Copyright (C) 2024-2026 Geekinney ;; Copyright (C) 2024-2026 Geekinney
;; Version: 1.0.0 ;; Version: 2.0.0
;; Keywords: convenience text-properties ;; Keywords: convenience text-properties
;; Author: Geekinney (kinneyzhang666@gmail.com) ;; Author: Geekinney (kinneyzhang666@gmail.com)
;; Package-Requires: ((emacs "28.1")) ;; Package-Requires: ((emacs "28.1"))
@ -26,7 +26,7 @@
;; tp-style.el Native property policies, contribution composition, ;; tp-style.el Native property policies, contribution composition,
;; named declarations, and explicit computed values. ;; named declarations, and explicit computed values.
;; tp-transaction.el ;; tp-transaction.el
;; Additive publication batch, marker, and outcome contracts. ;; Structured publication batch, marker, and outcome contracts.
;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable ;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable
;; adapters. ;; adapters.
;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes, ;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes,
@ -66,12 +66,12 @@
(require 'tp-builtins) (require 'tp-builtins)
(defconst tp--runtime-manifest (defconst tp--runtime-manifest
`(:package tp :version "1.0.0" `(:package tp :version "2.0.0"
:transaction-protocol ,tp-transaction-protocol :transaction-protocol ,tp-transaction-protocol
:batch-artifacts t :batch-artifacts t
:batch-execution v1-bridge :batch-execute t
:batch-execute nil :structured-participant-api tp-transaction-participate-v2
:shadow-proof t :single-live-writer t
:final-marker-operation tp-vector-slots/v1) :final-marker-operation tp-vector-slots/v1)
"Immutable package capability facts for cross-package compatibility checks.") "Immutable package capability facts for cross-package compatibility checks.")