Compare commits
9 Commits
rollback-c
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
0a820bd0cb | ||
|
|
e28df6a5fb | ||
|
|
6ed8df3915 | ||
|
|
5bcc91d867 | ||
|
|
47e8d8c256 | ||
|
|
b2b9462269 | ||
|
|
c05174ff9d | ||
|
|
25cb66c040 | ||
|
|
469bdff17d |
23
CHANGELOG.md
23
CHANGELOG.md
@ -2,15 +2,20 @@
|
||||
|
||||
All notable changes to the tp library are documented here.
|
||||
|
||||
## 1.0.1 (Unreleased)
|
||||
## 2.0.0 (Unreleased)
|
||||
|
||||
### Added
|
||||
|
||||
- A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup.
|
||||
- Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters.
|
||||
- Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup.
|
||||
- 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.
|
||||
- `tp-runtime-manifest`, advertising `tp-transaction-protocol-v1+v2` without removing the v1 participant route.
|
||||
- Transaction protocol v2: transaction-scoped publication batches, structured
|
||||
participants, bounded opaque final-accept markers using the closed
|
||||
`tp-vector-slots/v1` primitive, immutable tagged outcomes, and one live writer.
|
||||
- `tp-runtime-manifest`, advertising `tp-transaction-protocol-v2` and package
|
||||
version 2.0.0.
|
||||
- Public `tp-transaction-participate-v2` registration for cross-package
|
||||
structured participants.
|
||||
- Native property policies and contribution composition with explicit nil/absence, normalization, validation, equality, merge, projection, named direct styles, and explicit `tp-computed` value sources.
|
||||
- `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core.
|
||||
- Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans.
|
||||
@ -18,9 +23,9 @@ All notable changes to the tp library are documented here.
|
||||
|
||||
### Changed
|
||||
|
||||
- Package metadata now distinguishes builds that include
|
||||
`tp-transaction.el`; consumers can require TP 1.0.1 without an older 1.0.0
|
||||
development snapshot being accepted as a complete transaction runtime.
|
||||
- Structured publication batches own the single live surface-entry loop,
|
||||
participant stage/precommit/commit vector, and candidate-bound final accept.
|
||||
- Package metadata now identifies the v2-only breaking transaction contract.
|
||||
- `define-tp` and `define-tps` now define static or parameterized direct declaration recipes. Applying a recipe produces ordinary properties and never publishes runtime identity metadata.
|
||||
- TP is no longer a CSS engine. Selector, stylesheet, specificity, origin/importance, cascade layer, CSS-wide value, custom property, winner, and provenance behavior belongs to the independent ECSS package.
|
||||
- Function-valued properties are always literal. Only values wrapped by `tp-computed` execute and participate in dependency collection.
|
||||
@ -29,6 +34,12 @@ All notable changes to the tp library are documented here.
|
||||
|
||||
### Removed
|
||||
|
||||
- The public `tp-transaction-participate` v1 facade. Replace
|
||||
`(tp-transaction-participate KEY PUBLISH ROLLBACK)` with
|
||||
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`.
|
||||
- The v1 publication writer, execution-route kill switch, artifact-mode switch,
|
||||
and their runtime manifest claims.
|
||||
|
||||
- `tp-render.el`, `tp-stack.el`, the scan-driven renderer, layer-to-buffer registry, and duplicate managed transaction path.
|
||||
- Managed stack mutation, attach/detach, diagnostics, and lifecycle APIs that depended on inline stack storage.
|
||||
- `tp-text`, `$variable` declaration syntax, automatic layer refresh, and character-level `tp-name`/`tp-layers`/`tp-meta` runtime storage.
|
||||
|
||||
14
Makefile
14
Makefile
@ -5,7 +5,7 @@
|
||||
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
|
||||
# make test-m0a # run current TP completion characterization
|
||||
# make test-m1a # run additive transaction contract + fault gates
|
||||
# make test-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 benchmark # run reproducible correctness-first benchmarks
|
||||
# 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 \
|
||||
tp-query.el tp-palette.el tp-builtins.el tp.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
|
||||
EXAMPLES = $(wildcard examples/*.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:
|
||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
||||
@ -53,10 +52,13 @@ test-m1a:
|
||||
-l $(TEST_DIR)/tp-transaction-tests.el \
|
||||
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
|
||||
|
||||
test-v1:
|
||||
test-c1b:
|
||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
|
||||
--eval '(setq tp--transaction-artifact-mode (quote v1))' \
|
||||
$(patsubst %,-l %,$(V1_TESTS)) -f ert-run-tests-batch-and-exit
|
||||
-l $(TEST_DIR)/tp-binding-tests.el \
|
||||
-l $(TEST_DIR)/tp-surface-tests.el \
|
||||
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
|
||||
-l $(TEST_DIR)/tp-transaction-tests.el \
|
||||
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-participant-failure-preserves-condition\\|tp-binding-test-participant-key-is-owned-by-transaction\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-transaction-participant\\|tp-surface-test-failing-participant")'
|
||||
|
||||
test-shuffled:
|
||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
||||
|
||||
29
README.md
29
README.md
@ -1,13 +1,13 @@
|
||||
# TP
|
||||
|
||||
TP 1.0 is a standalone retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning text-property composition, exact dependency tracking, retained identity, marker-backed mounts, diffing, transactions, rollback, and final buffer publication.
|
||||
TP 2.0 is a standalone retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning text-property composition, exact dependency tracking, retained identity, marker-backed mounts, diffing, transactions, rollback, and final buffer publication.
|
||||
|
||||
TP does not depend on Ebox or ECSS. It does not implement CSS selectors, stylesheets, specificity, cascade winners, Box, Flex, Grid, measurement, or layout. A CSS consumer may compute final declarations with ECSS and publish them through TP, but TP itself only understands Emacs text properties and generic retained text surfaces.
|
||||
|
||||
Chinese documentation: [README_CN.md](README_CN.md).
|
||||
|
||||
Complete public API reference: [API-REFERENCE.md](docs/API-REFERENCE.md) (中文).
|
||||
It is the symbol-level usage index for the current TP 1.0 implementation; this
|
||||
It is the symbol-level usage index for the current TP 2.0 implementation; this
|
||||
README remains the conceptual quick start.
|
||||
|
||||
## Requirements
|
||||
@ -146,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.
|
||||
|
||||
TP also builds an internal transaction-scoped batch view over the same v1
|
||||
participants, journals, surface snapshots, and single final accept. Shadow
|
||||
mode compares canonical target artifacts and tagged outcomes with the one v1
|
||||
writer; it never opens a second change group or writes a buffer twice. Generic
|
||||
opaque authority markers are bounded and whitelist-validated before final
|
||||
accept, then reverse-restored before ordinary rollback on partial apply or
|
||||
TP 2.0 drives the single live publication from exact transaction-scoped batch
|
||||
entries, one frozen participant vector, and the candidate-bound final accept.
|
||||
The same journals, surface snapshots, and change group are shared rather than
|
||||
copied. Transaction participants register through
|
||||
`tp-transaction-participate-v2`; TP has no alternate transaction writer or
|
||||
runtime route switch.
|
||||
Generic opaque authority markers are bounded and whitelist-validated before
|
||||
final accept, then reverse-restored before ordinary rollback on partial apply or
|
||||
accept failure. `tp-with-transaction` still returns its body value, and
|
||||
internal outcomes remain observational side-channel evidence.
|
||||
|
||||
@ -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` |
|
||||
| Property policy and declarations | `tp-define-property-policy`, `tp-register-text-property`, `tp-text-declarations`, `tp-computed`, `tp-resolve-value`, `tp-merge-declarations`, `tp-define-style`, `tp-style-declarations` |
|
||||
| Static recipes | `define-tp`/`tp-define-layer`, `define-tps`/`define-tp-group`/`tp-define-group`, layer/group queries, undefine/reset/describe |
|
||||
| Signals and bindings | signal create/read/peek/set/dispose, binding install/read/dispose, `tp-variable-signal`, `tp-with-transaction`, `tp-transaction-participate`, 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 |
|
||||
| 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 |
|
||||
@ -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 2.0 transaction migration
|
||||
|
||||
TP 2.0 removes the v1 transaction participant facade and the legacy execution
|
||||
route. Replace `(tp-transaction-participate KEY PUBLISH ROLLBACK)` exactly with
|
||||
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`.
|
||||
Callers that inspect `tp-runtime-manifest` must require
|
||||
`tp-transaction-protocol-v2`; route-selection and v1-adapter fields are no
|
||||
longer published.
|
||||
|
||||
Use direct recipes for reusable static declarations, `tp-watch` for reactive properties on existing text, and retained content surfaces for reactive text or structured UI. TP does not automatically scan historical propertized text to reconstruct runtime identity.
|
||||
|
||||
## Examples
|
||||
|
||||
29
README_CN.md
29
README_CN.md
@ -1,13 +1,13 @@
|
||||
# TP
|
||||
|
||||
TP 1.0 是一个可独立使用的 Emacs retained/reactive text runtime。它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer,并拥有文本属性 contribution 合成、精确依赖追踪、保留式身份、marker-backed mount、diff、事务、回滚和最终 Buffer publication。
|
||||
TP 2.0 是一个可独立使用的 Emacs retained/reactive text runtime。它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer,并拥有文本属性 contribution 合成、精确依赖追踪、保留式身份、marker-backed mount、diff、事务、回滚和最终 Buffer publication。
|
||||
|
||||
TP 不依赖 Ebox 或 ECSS,也不实现 CSS selector、stylesheet、specificity、cascade winner、Box、Flex、Grid、测量或布局。需要 CSS 的调用者可以先用 ECSS 算出最终 declarations,再交给 TP 发布;TP 自身只理解 Emacs 文本属性和通用 retained text surface。
|
||||
|
||||
英文文档:[README.md](README.md)。
|
||||
|
||||
完整公共 API 参考:[API-REFERENCE.md](docs/API-REFERENCE.md)。本文负责概念
|
||||
和快速开始;API 参考按当前 TP 1.0 源码列出入口、参数语义、返回值和用法。
|
||||
和快速开始;API 参考按当前 TP 2.0 源码列出入口、参数语义、返回值和用法。
|
||||
|
||||
## 运行要求
|
||||
|
||||
@ -145,13 +145,14 @@ TP 为每个 property interval 保存 host baseline 和各个 TP contribution。
|
||||
|
||||
observer 只在成功提交之后运行,observer failure 只记录,不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡,rollback 不会把它重新创建。
|
||||
|
||||
TP 还会在同一份 v1 participant、journal、surface snapshot 和 single final
|
||||
accept 上建立内部 transaction-scoped batch view。shadow mode 只比较 canonical
|
||||
target artifact 与 tagged outcome,仍由唯一 v1 writer 写入;不会建立第二个
|
||||
change group,也不会双写 Buffer。generic opaque authority marker 在 final
|
||||
accept 前完成固定上界与 whitelist 校验;partial apply 或 accept failure 时先
|
||||
逆序恢复 marker,再执行普通 rollback。`tp-with-transaction` 仍返回 body
|
||||
result,内部 outcome 仅作为只读 side-channel evidence。
|
||||
TP 2.0 从 transaction-scoped batch 的 exact entries、同一个冻结 participant
|
||||
vector 和 candidate-bound final accept 驱动唯一 live publication;journal、
|
||||
surface snapshot 与 change group 仍只保留一份。transaction participant 统一通过
|
||||
`tp-transaction-participate-v2` 注册,不再提供备用 transaction writer 或 runtime
|
||||
route switch。generic opaque authority marker 在 final accept 前
|
||||
完成固定上界与 whitelist 校验;partial apply 或 accept failure 时先逆序恢复
|
||||
marker,再执行普通 rollback。`tp-with-transaction` 仍返回 body result,内部
|
||||
outcome 仅作为只读 side-channel evidence。
|
||||
|
||||
ETAF 集成复用同一事务边界,只注册一个 opaque transaction participant。ETAF
|
||||
先准备 immutable generation 和 Ebox candidate,再由 TP 按固定顺序完成
|
||||
@ -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` |
|
||||
| Property policy 与 declaration | `tp-define-property-policy`、`tp-register-text-property`、`tp-text-declarations`、`tp-computed`、`tp-resolve-value`、`tp-merge-declarations`、`tp-define-style`、`tp-style-declarations` |
|
||||
| 静态 recipe | `define-tp`/`tp-define-layer`、`define-tps`/`define-tp-group`/`tp-define-group`、layer/group 查询、undefine/reset/describe |
|
||||
| Signal 与 binding | signal create/read/peek/set/dispose、binding install/read/dispose、`tp-variable-signal`、`tp-with-transaction`、`tp-transaction-participate`、只读 `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 |
|
||||
| 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 |
|
||||
@ -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 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。
|
||||
|
||||
## 示例
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
# TP 1.0 公共 API 与用法参考
|
||||
# TP 2.0 公共 API 与用法参考
|
||||
|
||||
本文是 TP 当前实现的完整公共入口索引。它以 tp.el 加载的模块为准;带
|
||||
tp-- 前缀的函数、变量和结构体是内部实现,不属于本文的稳定 API。
|
||||
@ -226,10 +226,11 @@ tp-binding-dispose 释放单个 binding。
|
||||
(tp-signal-dispose left)
|
||||
(tp-signal-dispose right))
|
||||
|
||||
(tp-transaction-participate
|
||||
'my-external-state
|
||||
(lambda () (my-publish))
|
||||
(lambda () (my-rollback)))
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate-v2
|
||||
:key 'my-structured-state
|
||||
:stage (lambda () (my-stage))
|
||||
:rollback (lambda () (my-rollback))))
|
||||
|
||||
(tp-transaction-active-p)
|
||||
|
||||
@ -244,8 +245,10 @@ tp-binding-dispose 释放单个 binding。
|
||||
|
||||
tp-with-transaction 将 signal、binding、surface 和注册的 transaction
|
||||
participant 一起原子处理。participant 必须在 active transaction 内注册;
|
||||
publish 在 surface publication 后、source commit 前运行,失败时按逆序
|
||||
rollback。tp-variable-signal 用 Emacs variable watcher 适配全局或指定
|
||||
stage 在 surface publication 后、source commit 前运行,失败时按逆序
|
||||
rollback。consumer 使用 `tp-transaction-participate-v2`;它
|
||||
返回 key,不暴露内部 participant 对象。tp-variable-signal 用 Emacs variable
|
||||
watcher 适配全局或指定
|
||||
Buffer 的变量,不是旧的 $variable API。
|
||||
|
||||
tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已进入
|
||||
@ -254,11 +257,16 @@ tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已
|
||||
嵌套事务边界。
|
||||
|
||||
tp-runtime-manifest 返回防御性 capability snapshot;本版本的
|
||||
`:transaction-protocol` 为 `tp-transaction-protocol-v1+v2`。该声明是 additive:
|
||||
旧 `tp-transaction-participate` façade 与 live writer 都仍保留。
|
||||
`:batch-artifacts` 与 `:shadow-proof` 为 non-nil,`:batch-execution` 为
|
||||
`v1-bridge`,而 `:batch-execute` 明确为 nil;structured-core execute owner
|
||||
保留给后续受控 cutover,不在 M1a 伪造第二个 coordinator。
|
||||
`:transaction-protocol` 为 `tp-transaction-protocol-v2`,`:version` 为
|
||||
`"2.0.0"`。`:structured-participant-api` 指向
|
||||
`tp-transaction-participate-v2`;`:batch-execute`、`:batch-artifacts` 和
|
||||
`:single-live-writer` 均为 non-nil。manifest 不再发布 execution route、
|
||||
v1 adapter 或 v1 rollback route。
|
||||
|
||||
从 TP 1.x 迁移时,把 `(tp-transaction-participate KEY PUBLISH ROLLBACK)`
|
||||
精确替换为 `(tp-transaction-participate-v2 :key KEY :stage PUBLISH
|
||||
:rollback ROLLBACK)`。删除所有对 `tp-transaction-execution-route` 和
|
||||
`tp--transaction-artifact-mode` 的设置。
|
||||
|
||||
ETAF registers one opaque participant for its immutable generation and Ebox
|
||||
client state. Its publish is paired with rollback across TP final accept; the
|
||||
@ -382,6 +390,19 @@ Report 的常用字段包括:
|
||||
:scope-fallback、:property-conflicts、:rolled-back、:failure、
|
||||
:observer-errors、:timing。
|
||||
|
||||
已经精确计算出变更区间的 producer 可以使用 `tp-commit-batch-create` 构造
|
||||
批次,再由 `tp-commit-batch-result-create` 绑定当前 prepare context;发布和
|
||||
回滚仍使用相同 surface 事务。批次绑定前后 revision、extent 和坐标映射。
|
||||
每个 patch 的 `:replacement` 是完整属性文本,也可以携带局部
|
||||
`:property-contributions`:其中 `:start`/`:end` 相对于该 replacement,按列表
|
||||
顺序使用已注册的 property merge policy 合成。策略在**构造批次时**求值;
|
||||
批次只保留合成后的文本快照,不保留贡献列表,之后的调用方修改或策略替换
|
||||
不会重新计算这份批次。函数、record 等 opaque 属性身份按既有 snapshot 规则保留。
|
||||
|
||||
producer 只有在证明整个挂载拓扑、tags 和坐标均与已提交版本相同时,才能向
|
||||
`tp-commit-batch-result-create` 传 `:reuse-mount-projection t`。它不能与显式
|
||||
`:mount-specs` 同时使用;数量相同或对象没有增删都不能替代完整的不变证明。
|
||||
|
||||
### 6.3 Host range 和 tp-watch
|
||||
|
||||
~~~elisp
|
||||
@ -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-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-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-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 |
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
# TP 1.0 API Semantics
|
||||
# TP 2.0 API Semantics
|
||||
|
||||
本文记录 TP 1.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为;目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
|
||||
本文记录 TP 2.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为;目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
|
||||
|
||||
完整的公共符号、参数形状、返回值和示例见 [API reference](API-REFERENCE.md)。
|
||||
|
||||
@ -196,10 +196,11 @@ TP 为每个 interval 保存:
|
||||
3. 运行 binding graph 与 producers;
|
||||
4. 校验 object、plan、capability、range、conflict 与 lifecycle;
|
||||
5. 为所有 surfaces 准备 text/property operations 与 inverse journals;
|
||||
6. 按稳定 surface id publish;
|
||||
7. 按声明顺序 stage participant,再执行 declared precommit;
|
||||
6. 默认从 publication batch 的 exact entry bindings 按稳定 surface id publish;
|
||||
7. 从 batch 绑定的同一 participant vector 按声明顺序 stage participant,再执行
|
||||
declared precommit;
|
||||
8. commit signal journal;
|
||||
9. 在 single final accept 内按顺序 apply bounded opaque markers,再 accept
|
||||
9. 在 candidate 绑定的 single final accept 内按顺序 apply bounded opaque markers,再 accept
|
||||
change group;marker 只能使用 closed `tp-vector-slots/v1` fixed-write
|
||||
primitive,不能注册 callback;partial apply 或 accept failure 先逆序
|
||||
restore markers;
|
||||
@ -208,14 +209,21 @@ TP 为每个 interval 保存:
|
||||
|
||||
嵌套 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
|
||||
outcome 都是现有 v1 dynamic transaction state 的内部结构化 view,不复制第二份
|
||||
participant/journal/change-group,也不切换 live writer。shadow proof 只比较 v1/v2
|
||||
artifact 与 outcome,不双写 Buffer。`tp-with-transaction` 的返回值仍是 body
|
||||
result;success/failure outcome 只走内部 side channel。zero-surface 与
|
||||
output-equal operation 不创建 publication batch。
|
||||
publication batch、structured participant、final marker 与 tagged outcome 共享
|
||||
现有 journal/change-group,不复制第二份 live state。publication batch 是唯一
|
||||
live writer:surface 从 candidate entries 执行,participant 从 candidate
|
||||
绑定的同一 identity vector 执行,final accept 从 candidate binding 执行;任何
|
||||
binding/order 漂移都会 fail-fast 并回滚。TP 2.0 不再提供 alternate writer、
|
||||
execution route 或 artifact-mode switch。`tp-with-transaction` 的返回值仍是 body result;
|
||||
success/failure outcome 只走内部 side channel。zero-surface 与 output-equal
|
||||
operation 不创建 publication batch。
|
||||
|
||||
ETAF uses this API with one opaque participant for its immutable generation and
|
||||
Ebox client state. The participant is published only after candidate
|
||||
|
||||
@ -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)。
|
||||
|
||||
@ -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-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-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 |
|
||||
@ -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 additive v2 contract is a structured view over those exact owners. It does
|
||||
not copy participant, scheduler, snapshot, journal, or change-group state. The
|
||||
public v1 participant façade and the v1 surface writer remain authoritative;
|
||||
shadow mode constructs canonical entries and compares property-for-property and
|
||||
revision-for-revision after commit or rollback.
|
||||
The v2 contract uses those exact owners. It does not copy participant,
|
||||
scheduler, snapshot, journal, or change-group state. The publication batch is
|
||||
the sole writer and validates its canonical entries against the committed
|
||||
property and revision state after commit or rollback.
|
||||
|
||||
```text
|
||||
freeze candidate writes
|
||||
@ -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.
|
||||
|
||||
`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,
|
||||
registration order, stage, rollback, optional declared precommit, contained
|
||||
after-commit work, owner journal, and one-shot state. Final markers are not
|
||||
Each structured participant has one stable key, registration order, stage,
|
||||
rollback, optional declared precommit, contained after-commit work, owner
|
||||
journal, and one-shot state. Final markers are not
|
||||
participants. TP treats their values as opaque and accepts only predeclared,
|
||||
fixed-bound operations. M1a's closed `tp-vector-slots/v1` primitive accepts
|
||||
only prebuilt vector-slot expectations and writes; marker registration cannot
|
||||
|
||||
@ -399,20 +399,20 @@
|
||||
(setq failure
|
||||
(condition-case condition
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'first
|
||||
(lambda ()
|
||||
(tp-transaction-participate-v2
|
||||
:key 'first
|
||||
:stage (lambda ()
|
||||
(push 'publish-first
|
||||
tp-binding-test-transaction-trace))
|
||||
(lambda ()
|
||||
:rollback (lambda ()
|
||||
(push 'rollback-first
|
||||
tp-binding-test-transaction-trace)))
|
||||
(tp-transaction-participate
|
||||
'second
|
||||
(lambda ()
|
||||
(tp-transaction-participate-v2
|
||||
:key 'second
|
||||
:stage (lambda ()
|
||||
(push 'publish-second
|
||||
tp-binding-test-transaction-trace))
|
||||
(lambda ()
|
||||
:rollback (lambda ()
|
||||
(push 'rollback-second
|
||||
tp-binding-test-transaction-trace)))
|
||||
(tp-signal-set signal 2))
|
||||
@ -689,7 +689,8 @@
|
||||
(caller-vector (vector (copy-sequence "key")))
|
||||
(key (list 'test caller-string caller-vector)))
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate key #'ignore #'ignore)
|
||||
(tp-transaction-participate-v2
|
||||
:key key :stage #'ignore :rollback #'ignore)
|
||||
(let ((stored (tp--transaction-participant-key
|
||||
(car tp--transaction-participants))))
|
||||
(should-not (eq (nth 1 stored) caller-string))
|
||||
@ -701,8 +702,9 @@
|
||||
(should (equal (nth 1 stored) "participant"))
|
||||
(should (equal (nth 2 stored) ["key"]))
|
||||
(should-error
|
||||
(tp-transaction-participate
|
||||
(list 'test "participant" ["key"]) #'ignore #'ignore)
|
||||
(tp-transaction-participate-v2
|
||||
:key (list 'test "participant" ["key"])
|
||||
:stage #'ignore :rollback #'ignore)
|
||||
:type 'tp-reactive-error))))))
|
||||
|
||||
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()
|
||||
|
||||
@ -161,6 +161,49 @@
|
||||
(should (equal (nth 0 copy) "value"))
|
||||
(should (equal (nth 1 copy) ["nested"])))))
|
||||
|
||||
(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps ()
|
||||
"Full keymaps, parent maps and self-references retain an isolated graph."
|
||||
(let* ((map (make-keymap))
|
||||
(parent (make-keymap))
|
||||
(callback (lambda () "callback")))
|
||||
(define-key map (kbd "RET") callback)
|
||||
(define-key parent (kbd "x") #'ignore)
|
||||
(define-key map [prefix] map)
|
||||
(set-keymap-parent map parent)
|
||||
(let ((copy (tp-property-value-copy map)))
|
||||
(should-not (eq copy map))
|
||||
(should-not (eq (keymap-parent copy) parent))
|
||||
(should (eq (lookup-key copy [prefix]) copy))
|
||||
(should (eq (lookup-key copy (kbd "RET")) callback))
|
||||
(define-key map (kbd "RET") #'forward-char)
|
||||
(define-key parent (kbd "x") #'backward-char)
|
||||
(should (eq (lookup-key copy (kbd "RET")) callback))
|
||||
(should (eq (lookup-key copy (kbd "x")) #'ignore)))))
|
||||
|
||||
(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure ()
|
||||
"Local ranges, defaults, parents, extra slots and cycles are copied faithfully."
|
||||
(let ((purpose (make-symbol "tp-copy-table")))
|
||||
(put purpose 'char-table-extra-slots 1)
|
||||
(let* ((parent (make-char-table purpose))
|
||||
(table (make-char-table purpose))
|
||||
(value (list 'value)))
|
||||
(set-char-table-range parent ?p value)
|
||||
(set-char-table-range table ?x value)
|
||||
(set-char-table-range table ?s table)
|
||||
(set-char-table-extra-slot table 0 value)
|
||||
(set-char-table-parent table parent)
|
||||
(let ((copy (tp-property-value-copy table)))
|
||||
(should (eq (char-table-range copy ?s) copy))
|
||||
(should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0)))
|
||||
(should (eq (char-table-range copy ?x)
|
||||
(char-table-range (char-table-parent copy) ?p)))
|
||||
(set-char-table-range (char-table-parent copy) ?p 'new)
|
||||
(should (eq (char-table-range copy ?p) 'new))
|
||||
(set-char-table-range copy nil 'default)
|
||||
(should (eq (char-table-range copy ?z) 'default))
|
||||
(setcar value 'mutated)
|
||||
(should (equal (char-table-range copy ?x) '(value)))))))
|
||||
|
||||
(ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
|
||||
"Property copies keep list-shaped function values opaque."
|
||||
(let ((function-value '(lambda () 1)))
|
||||
|
||||
@ -107,12 +107,12 @@
|
||||
(tp-m0a-characterization--capture
|
||||
(lambda ()
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'm0a-participant
|
||||
(lambda ()
|
||||
(tp-transaction-participate-v2
|
||||
:key 'm0a-participant
|
||||
:stage (lambda ()
|
||||
(setq external 'candidate)
|
||||
(signal (car injected) (cdr injected)))
|
||||
(lambda () (setq external 'old)))
|
||||
:rollback (lambda () (setq external 'old)))
|
||||
(tp-signal-set source 2))))))
|
||||
(should (equal failure injected)))
|
||||
(should (eq external 'old))
|
||||
|
||||
@ -14,6 +14,46 @@
|
||||
(require 'tp-style)
|
||||
(require 'tp-layer)
|
||||
|
||||
(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts ()
|
||||
"Snapshots compare by prompts, menu order, parents and literal commands."
|
||||
(let* ((factory (eval '(lambda ()
|
||||
(let ((n 0))
|
||||
(lambda () (setq n (1+ n))))) t))
|
||||
(first (funcall factory)) (second (funcall factory))
|
||||
(map (make-keymap "Root"))
|
||||
(prefix (make-sparse-keymap "Prefix"))
|
||||
(parent (make-sparse-keymap "Parent")))
|
||||
(define-key map (kbd "RET") first)
|
||||
(define-key map [t] #'ignore)
|
||||
(define-key prefix [self] prefix)
|
||||
(define-key prefix [one] '(menu-item "One" ignore))
|
||||
(define-key prefix [two] '(menu-item "Two" forward-char))
|
||||
(define-key map [prefix] prefix)
|
||||
(define-key parent [inherited] #'backward-char)
|
||||
(set-keymap-parent map parent)
|
||||
(should (equal first second))
|
||||
(should (tp--native-property-value-equal-p map (tp-property-value-copy map)))
|
||||
(dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order
|
||||
callback default inherited))
|
||||
(let ((copy (tp-property-value-copy map)))
|
||||
(pcase kind
|
||||
((or 'root-prompt 'prefix-prompt 'parent-prompt)
|
||||
(let* ((target (pcase kind
|
||||
('root-prompt copy)
|
||||
('prefix-prompt (lookup-key copy [prefix]))
|
||||
('parent-prompt (keymap-parent copy))))
|
||||
(cell (memq (keymap-prompt target) target)))
|
||||
(setcar cell "Changed")))
|
||||
('menu-order
|
||||
(let* ((target (lookup-key copy [prefix]))
|
||||
(one (lookup-key target [one])))
|
||||
(define-key target [one] nil t)
|
||||
(define-key target [one] one)))
|
||||
('callback (define-key copy (kbd "RET") second))
|
||||
('default (define-key copy [t] #'forward-char))
|
||||
('inherited (define-key (keymap-parent copy) [inherited] #'ignore)))
|
||||
(should-not (tp--native-property-value-equal-p map copy))))))
|
||||
|
||||
(defmacro tp-style-test--isolated (&rest body)
|
||||
"Run BODY with isolated TP property and named-style registries."
|
||||
(declare (indent 0) (debug t))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Characterization and fault tests for the additive v1+v2 transaction
|
||||
;; protocol. These tests deliberately exercise the internal protocol: the
|
||||
;; public contract remains `tp-with-transaction' body return and primary
|
||||
;; condition preservation.
|
||||
;; Characterization and fault tests for the v2 transaction protocol. These
|
||||
;; tests deliberately exercise
|
||||
;; the internal protocol: the public contract remains `tp-with-transaction'
|
||||
;; body return and primary condition preservation.
|
||||
|
||||
;;; Code:
|
||||
|
||||
@ -17,13 +17,12 @@
|
||||
(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-participant-protocol "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-register-final-marker
|
||||
"tp-reactive" (&rest args))
|
||||
|
||||
(defvar tp--transaction-artifact-mode)
|
||||
(defvar tp--transaction-publication-batch)
|
||||
(defvar tp--transaction-outcome)
|
||||
(defvar tp--last-shadow-proof)
|
||||
@ -100,6 +99,30 @@
|
||||
:final-accept #'ignore
|
||||
: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)
|
||||
"Return fixed slot writes assigning VALUES into TARGET from index zero."
|
||||
(vconcat
|
||||
@ -234,8 +257,8 @@
|
||||
(when (tp-signal-live-p ,source)
|
||||
(tp-signal-dispose ,source)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-v1-body-return-and-phase-order ()
|
||||
"The v1 facade returns BODY and retains its established phase order."
|
||||
(ert-deftest tp-transaction-test-v2-body-return-and-phase-order ()
|
||||
"The v2 facade returns BODY and retains its established phase order."
|
||||
(let ((tp-transaction-test--trace nil)
|
||||
(tp--transaction-precommit-functions
|
||||
'(tp--transaction-test-precommit-inject))
|
||||
@ -244,10 +267,10 @@
|
||||
(should
|
||||
(equal
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'v1
|
||||
(lambda () (push 'participant tp-transaction-test--trace))
|
||||
(lambda () (push 'rollback tp-transaction-test--trace)))
|
||||
(tp-transaction-participate-v2
|
||||
:key 'v2
|
||||
:stage (lambda () (push 'participant tp-transaction-test--trace))
|
||||
:rollback (lambda () (push 'rollback tp-transaction-test--trace)))
|
||||
(tp--enqueue-after-commit
|
||||
(lambda () (push 'after-commit tp-transaction-test--trace)))
|
||||
(push 'body tp-transaction-test--trace)
|
||||
@ -256,8 +279,8 @@
|
||||
(should (equal (nreverse tp-transaction-test--trace)
|
||||
'(body participant precommit after-commit)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-v1-participant-and-precommit-fault-order ()
|
||||
"A late v1 fault rolls staged participants back in reverse order."
|
||||
(ert-deftest tp-transaction-test-v2-participant-and-precommit-fault-order ()
|
||||
"A late v2 fault rolls staged participants back in reverse order."
|
||||
(let* ((injected '(tp-transaction-test-error :phase precommit :raw (1 2)))
|
||||
(tp-transaction-test--trace nil)
|
||||
(tp-transaction-test--precommit-condition injected)
|
||||
@ -269,14 +292,14 @@
|
||||
(tp-transaction-test--capture
|
||||
(lambda ()
|
||||
(tp-with-transaction
|
||||
(tp-transaction-participate
|
||||
'first
|
||||
(lambda () (push 'stage-first tp-transaction-test--trace))
|
||||
(lambda () (push 'rollback-first tp-transaction-test--trace)))
|
||||
(tp-transaction-participate
|
||||
'second
|
||||
(lambda () (push 'stage-second tp-transaction-test--trace))
|
||||
(lambda () (push 'rollback-second tp-transaction-test--trace))))))))
|
||||
(tp-transaction-participate-v2
|
||||
:key 'first
|
||||
:stage (lambda () (push 'stage-first tp-transaction-test--trace))
|
||||
:rollback (lambda () (push 'rollback-first tp-transaction-test--trace)))
|
||||
(tp-transaction-participate-v2
|
||||
:key 'second
|
||||
:stage (lambda () (push 'stage-second tp-transaction-test--trace))
|
||||
:rollback (lambda () (push 'rollback-second tp-transaction-test--trace))))))))
|
||||
(should (equal failure injected))
|
||||
(should (equal (nreverse tp-transaction-test--trace)
|
||||
'(stage-first stage-second precommit
|
||||
@ -313,10 +336,17 @@
|
||||
:type 'tp-publication-binding-error)
|
||||
(with-temp-buffer
|
||||
(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))
|
||||
(batch (tp-transaction-test--batch entries)))
|
||||
(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
|
||||
:candidate-id 'replacement
|
||||
:surface-id 'replacement-surface
|
||||
@ -327,6 +357,10 @@
|
||||
(should (equal (tp-publication-target-entry-mount-ids
|
||||
(car (tp-publication-batch-candidate-entries batch)))
|
||||
'(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-error
|
||||
(tp-transaction-test--batch (list entry entry))
|
||||
@ -353,14 +387,15 @@
|
||||
(should-error (tp--publication-batch-transition discarded 'staged)
|
||||
:type 'tp-publication-state-error))))
|
||||
|
||||
(ert-deftest tp-transaction-test-v1-bridge-is-the-structured-participant ()
|
||||
"The v1 facade installs one v2 record, not parallel participant state."
|
||||
(ert-deftest tp-transaction-test-v2-participant-is-single-structured-record ()
|
||||
"The v2 facade installs one structured record with no legacy bridge."
|
||||
(let (saved)
|
||||
(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))
|
||||
(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) 'committed))))
|
||||
|
||||
@ -386,6 +421,30 @@
|
||||
'(:owner old-state)))
|
||||
(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 ()
|
||||
"A structured stage fault reverses only participants that entered staged."
|
||||
(let ((tp-transaction-test--trace nil)
|
||||
@ -454,7 +513,7 @@
|
||||
|
||||
(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)
|
||||
(tp-transaction-test--with-surface (buffer _surface source)
|
||||
(let ((target (vector 'detached 'token 0)))
|
||||
(tp-with-transaction
|
||||
(tp-signal-set source 2)
|
||||
@ -577,6 +636,10 @@
|
||||
tp--last-transaction-outcome))
|
||||
(tp-transaction-test--should-match-outcome-counts
|
||||
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
|
||||
(tp--committed-success-outcome-snapshot
|
||||
tp--last-transaction-outcome)
|
||||
@ -762,8 +825,7 @@
|
||||
(dolist (id before)
|
||||
(should (memq id outcome-ids)))
|
||||
(tp-transaction-test--should-match-outcome-counts
|
||||
tp--last-transaction-outcome (list surface))
|
||||
(should (plist-get tp--last-shadow-proof :equivalent))))
|
||||
tp--last-transaction-outcome (list surface))))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-candidates-remain-invisible-until-staged ()
|
||||
@ -782,8 +844,8 @@
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) text))))))
|
||||
|
||||
(ert-deftest tp-transaction-test-shadow-is-multisurface-and-single-writer ()
|
||||
"Shadow artifacts cover all surfaces while each live writer runs once."
|
||||
(ert-deftest tp-transaction-test-v2-is-multisurface-and-single-writer ()
|
||||
"The v2 artifacts cover all surfaces while each live writer runs once."
|
||||
(let* ((source (tp-signal-create 1))
|
||||
(producer (tp-transaction-test--producer source))
|
||||
(first-buffer (generate-new-buffer " *tp-transaction-first*"))
|
||||
@ -799,16 +861,17 @@
|
||||
(let ((surface (tp--prepared-surface-surface prepared)))
|
||||
(puthash surface (1+ (gethash surface calls 0)) calls))
|
||||
(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 second calls 0) 1))
|
||||
(should (tp-committed-success-outcome-p
|
||||
tp--last-transaction-outcome))
|
||||
(tp-transaction-test--should-match-outcome-counts
|
||||
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 :outcome-equivalent))
|
||||
(should (= (plist-get tp--last-shadow-proof :entry-count) 2))
|
||||
(should (integerp
|
||||
(tp-committed-success-outcome-mapping-generation
|
||||
tp--last-transaction-outcome)))
|
||||
@ -826,6 +889,31 @@
|
||||
(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-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 ()
|
||||
"Pure, semantic and external-only transactions stay outside batch API."
|
||||
(let ((tp--last-transaction-outcome 'sentinel)
|
||||
@ -839,7 +927,8 @@
|
||||
(should-not captured-outcome)
|
||||
(should-not tp--last-transaction-outcome)
|
||||
(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)))
|
||||
|
||||
(ert-deftest tp-transaction-test-unobserved-signal-excludes-publication-batch ()
|
||||
@ -856,8 +945,7 @@
|
||||
(should (= (tp-signal-peek signal) 2))
|
||||
(should (= (tp-signal-revision signal) 1))
|
||||
(should (= batch-calls 0))
|
||||
(should-not tp--last-transaction-outcome)
|
||||
(should-not tp--last-shadow-proof))
|
||||
(should-not tp--last-transaction-outcome))
|
||||
(when (tp-signal-live-p signal) (tp-signal-dispose signal)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-surface-unmount-excludes-publication-batch ()
|
||||
@ -871,8 +959,7 @@
|
||||
(batch-calls 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setq tp--last-transaction-outcome nil
|
||||
tp--last-shadow-proof nil)
|
||||
(setq tp--last-transaction-outcome nil)
|
||||
(cl-letf
|
||||
(((symbol-function 'tp--transaction-begin-publication-batch)
|
||||
(lambda (&rest arguments)
|
||||
@ -881,7 +968,6 @@
|
||||
(tp-surface-unmount surface))
|
||||
(should (= batch-calls 0))
|
||||
(should-not tp--last-transaction-outcome)
|
||||
(should-not tp--last-shadow-proof)
|
||||
(should-not (tp-surface-live-p surface))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) ""))))
|
||||
@ -937,13 +1023,11 @@
|
||||
(should (= (length outcome-cell) 1))
|
||||
(should (tp-committed-success-outcome-p (aref outcome-cell 0)))
|
||||
(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)))
|
||||
(with-current-buffer buffer
|
||||
(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."
|
||||
(let ((buffer (generate-new-buffer " *tp-transaction-scoped*"))
|
||||
(middle "B")
|
||||
@ -976,9 +1060,8 @@
|
||||
(revision (tp-surface-revision surface)))
|
||||
(setq middle "LONG"
|
||||
middle-face 'italic)
|
||||
(let ((tp--transaction-artifact-mode 'shadow))
|
||||
(tp-surface-update-scoped
|
||||
surface (list middle-object) producer))
|
||||
(tp-surface-update-scoped
|
||||
surface (list middle-object) producer)
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "ALONGC"))
|
||||
@ -986,14 +1069,10 @@
|
||||
(should (tp-committed-success-outcome-p
|
||||
tp--last-transaction-outcome))
|
||||
(tp-transaction-test--should-match-outcome-counts
|
||||
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)))
|
||||
tp--last-transaction-outcome (list surface)))
|
||||
(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."
|
||||
(let ((buffer (generate-new-buffer " *tp-transaction-properties*"))
|
||||
(value 'bold))
|
||||
@ -1014,19 +1093,14 @@
|
||||
buffer producer '(:capability properties)))
|
||||
(revision (tp-surface-revision surface)))
|
||||
(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 (eq (get-text-property 2 'face) 'italic))
|
||||
(should (= (tp-surface-revision surface) (1+ revision)))
|
||||
(should (tp-committed-success-outcome-p
|
||||
tp--last-transaction-outcome))
|
||||
(tp-transaction-test--should-match-outcome-counts
|
||||
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))))
|
||||
tp--last-transaction-outcome (list surface))))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest tp-transaction-test-property-surface-fault-matrix-restores-exact-state ()
|
||||
@ -1097,11 +1171,11 @@
|
||||
(lambda ()
|
||||
(tp-with-transaction
|
||||
(when (eq phase 'participant)
|
||||
(tp-transaction-participate
|
||||
'property-fault-participant
|
||||
(lambda ()
|
||||
(signal (car injected) (cdr injected)))
|
||||
#'ignore))
|
||||
(tp-transaction-participate-v2
|
||||
:key 'property-fault-participant
|
||||
:stage (lambda ()
|
||||
(signal (car injected) (cdr injected)))
|
||||
:rollback #'ignore))
|
||||
(tp-signal-set source 2)))))
|
||||
injected)))
|
||||
(should (= (tp-signal-peek source) 1))
|
||||
@ -1115,62 +1189,118 @@
|
||||
(with-current-buffer second-buffer
|
||||
(should (eq (get-text-property 2 'face) 'bold)))
|
||||
(should (tp-publication-failure-outcome-p
|
||||
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)))
|
||||
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-v1-and-shadow-artifact-modes-are-equivalent ()
|
||||
"Independent v1 and shadow surfaces commit identical live artifacts."
|
||||
(let* ((v1-buffer (generate-new-buffer " *tp-transaction-v1*"))
|
||||
(shadow-buffer (generate-new-buffer " *tp-transaction-shadow*"))
|
||||
(initial
|
||||
(tp-surface-plan-create
|
||||
:key 'root :kind 'text :text "old" :props '(face bold)
|
||||
:capability 'content))
|
||||
(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))
|
||||
(ert-deftest tp-transaction-test-final-accept-source-uses-v2-binding ()
|
||||
"V2 validates the candidate final accept binding before publication."
|
||||
(let* ((structured-buffer (generate-new-buffer " *tp-final-structured*"))
|
||||
(initial (tp-transaction-test--leaf "old"))
|
||||
(next (tp-transaction-test--leaf "new"))
|
||||
(structured (tp-surface-mount structured-buffer initial
|
||||
'(:capability content)))
|
||||
(sync (symbol-function 'tp--transaction-sync-publication-batch)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(let ((tp--transaction-artifact-mode 'v1))
|
||||
(tp-surface-update v1-surface next))
|
||||
(should-not tp--last-transaction-outcome)
|
||||
(should-not tp--last-shadow-proof)
|
||||
(cl-letf (((symbol-function 'tp--publish-one-surface)
|
||||
(lambda (prepared)
|
||||
(cl-incf shadow-writes)
|
||||
(funcall writer prepared))))
|
||||
(let ((tp--transaction-artifact-mode 'shadow))
|
||||
(tp-surface-update shadow-surface next)))
|
||||
(should (= shadow-writes 1))
|
||||
(should (tp-committed-success-outcome-p
|
||||
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 v1-surface)
|
||||
(tp-surface-revision shadow-surface)))
|
||||
(should
|
||||
(equal-including-properties
|
||||
(with-current-buffer v1-buffer (buffer-string))
|
||||
(with-current-buffer shadow-buffer (buffer-string))))
|
||||
(with-current-buffer v1-buffer
|
||||
(should (equal (buffer-string) "new"))
|
||||
(should (eq (get-text-property 1 'face) 'italic))))
|
||||
(when (buffer-live-p v1-buffer) (kill-buffer v1-buffer))
|
||||
(when (buffer-live-p shadow-buffer) (kill-buffer shadow-buffer)))))
|
||||
(cl-letf (((symbol-function 'tp--transaction-sync-publication-batch)
|
||||
(lambda ()
|
||||
(funcall sync)
|
||||
(when tp--transaction-publication-batch
|
||||
(setf (tp-publication-batch-candidate-final-accept
|
||||
tp--transaction-publication-batch)
|
||||
#'ignore)))))
|
||||
(should-error (tp-surface-update structured next)
|
||||
:type 'tp-publication-binding-error)
|
||||
(with-current-buffer structured-buffer
|
||||
(should (equal (buffer-string) "old")))
|
||||
(should (tp-publication-failure-outcome-p
|
||||
tp--last-transaction-outcome)))
|
||||
(when (buffer-live-p structured-buffer) (kill-buffer structured-buffer))
|
||||
)))
|
||||
|
||||
(ert-deftest tp-transaction-test-structured-batch-owns-surface-stage-once ()
|
||||
"Structured execution enters the candidate seam and writes each entry once."
|
||||
(let* ((source (tp-signal-create 1))
|
||||
(producer (tp-transaction-test--producer source))
|
||||
(first-buffer (generate-new-buffer " *tp-structured-first*"))
|
||||
(second-buffer (generate-new-buffer " *tp-structured-second*"))
|
||||
(first (tp-surface-mount first-buffer producer '(:capability content)))
|
||||
(second (tp-surface-mount second-buffer producer '(:capability content)))
|
||||
(execute (symbol-function 'tp--publication-batch-execute-stage))
|
||||
(writer (symbol-function 'tp--publish-one-surface))
|
||||
(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 ()
|
||||
"An ordinary publication records zero final authority markers."
|
||||
@ -1246,7 +1376,7 @@
|
||||
(should (eq (aref overflow-target 0) 'old)))))
|
||||
|
||||
(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))
|
||||
(tp-transaction-test--with-surface (buffer surface source)
|
||||
(let* ((targets
|
||||
@ -1329,7 +1459,7 @@
|
||||
'(tp-transaction-test-error :phase after-commit))))
|
||||
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."
|
||||
(dolist (phase '(apply accept))
|
||||
(tp-transaction-test--with-surface (buffer surface source)
|
||||
@ -1366,23 +1496,31 @@
|
||||
(with-current-buffer buffer
|
||||
(should (equal (buffer-string) "1")))))))
|
||||
|
||||
(ert-deftest tp-transaction-test-manifest-advertises-v1-plus-v2 ()
|
||||
"The TP manifest retains v1 while advertising the additive protocol."
|
||||
(should (eq tp-transaction-protocol
|
||||
'tp-transaction-protocol-v1+v2))
|
||||
(ert-deftest tp-transaction-test-manifest-advertises-v2-only-contract ()
|
||||
"The manifest advertises v2 without any legacy route capability."
|
||||
(should (eq tp-transaction-protocol 'tp-transaction-protocol-v2))
|
||||
(let ((manifest (tp-runtime-manifest)))
|
||||
(should (equal (plist-get manifest :version) "1.0.1"))
|
||||
(should (equal (plist-get manifest :version) "2.0.0"))
|
||||
(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 (eq (plist-get manifest :batch-execution) 'v1-bridge))
|
||||
(should-not (plist-get manifest :batch-execute))
|
||||
(should (plist-get manifest :shadow-proof))
|
||||
(should (eq (plist-get manifest :final-marker-operation)
|
||||
'tp-vector-slots/v1))
|
||||
(setf (plist-get manifest :transaction-protocol) 'mutated)
|
||||
(should (eq (plist-get (tp-runtime-manifest) :transaction-protocol)
|
||||
'tp-transaction-protocol-v1+v2))))
|
||||
(should (plist-get manifest :batch-execute))
|
||||
(should (plist-get manifest :single-live-writer))
|
||||
(dolist (property '(:execution-route :execution-default :execution-routes
|
||||
:route-option :batch-execution :v1-adapter
|
||||
:v1-rollback-route))
|
||||
(should-not (plist-member manifest property)))))
|
||||
|
||||
(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)
|
||||
|
||||
|
||||
32
tp-core.el
32
tp-core.el
@ -279,6 +279,7 @@ Otherwise, START-OR-STRING and END define the range."
|
||||
(and (not (functionp value))
|
||||
(or (consp value)
|
||||
(stringp value)
|
||||
(char-table-p value)
|
||||
(and (vectorp value) (not (recordp value))))))
|
||||
|
||||
(defun tp--copy-cons-spine (value cache)
|
||||
@ -309,6 +310,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology."
|
||||
(if (and (not (functionp item))
|
||||
(or (consp item)
|
||||
(stringp item)
|
||||
(char-table-p item)
|
||||
(and (vectorp item) (not (recordp item)))))
|
||||
(tp--copy-property-value item cache)
|
||||
item)))
|
||||
@ -344,6 +346,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
|
||||
(when (and (not (functionp item))
|
||||
(or (consp item)
|
||||
(stringp item)
|
||||
(char-table-p item)
|
||||
(and (vectorp item) (not (recordp item)))))
|
||||
(setcar target (tp--copy-property-value item cache))))
|
||||
(setq source (cdr source)
|
||||
@ -406,7 +409,8 @@ values are recursively isolated."
|
||||
(defun tp--copy-property-value (value &optional cache)
|
||||
"Return a defensive copy of mutable containers in property VALUE.
|
||||
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."
|
||||
(if (not (tp--copy-mutable-property-value-p 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-cons-spine value cache)))
|
||||
((stringp value) (tp--copy-string-with-properties value cache))
|
||||
((char-table-p value)
|
||||
(let ((copy (copy-sequence value))
|
||||
(default (char-table-range value nil))
|
||||
entries)
|
||||
(puthash value copy cache)
|
||||
;; Enumerate only local assignments, without inherited/default
|
||||
;; ranges becoming explicit assignments in the copied table.
|
||||
(set-char-table-parent copy nil)
|
||||
(set-char-table-range copy nil nil)
|
||||
(map-char-table (lambda (range item) (push (cons range item) entries))
|
||||
copy)
|
||||
(dolist (entry entries)
|
||||
(set-char-table-range
|
||||
copy (car entry) (tp--copy-property-value (cdr entry) cache)))
|
||||
(set-char-table-range copy nil (tp--copy-property-value default cache))
|
||||
(set-char-table-parent
|
||||
copy (tp--copy-property-value (char-table-parent value) cache))
|
||||
(dotimes (index (or (get (char-table-subtype value)
|
||||
'char-table-extra-slots) 0))
|
||||
(set-char-table-extra-slot
|
||||
copy index (tp--copy-property-value
|
||||
(char-table-extra-slot value index) cache)))
|
||||
copy))
|
||||
((vectorp value)
|
||||
(let ((copy (copy-sequence value)))
|
||||
(puthash value copy cache)
|
||||
@ -431,7 +458,8 @@ and other opaque objects keep their identity; functions are never executed."
|
||||
(defun tp-property-value-copy (value)
|
||||
"Return a defensive copy of mutable text-property VALUE.
|
||||
Functions, records, and other opaque identities are retained; mutable cons,
|
||||
string, and non-record vector graphs are copied with sharing and cycles intact."
|
||||
string, character-table and non-record vector graphs are copied with sharing
|
||||
and cycles intact."
|
||||
(tp--copy-property-value value (make-hash-table :test #'eq)))
|
||||
|
||||
(defun tp--deep-merge-plist (base new)
|
||||
|
||||
194
tp-reactive.el
194
tp-reactive.el
@ -11,7 +11,7 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; TP 1.0's exact signal-to-binding dependency graph, transaction-local
|
||||
;; TP 2.0's exact signal-to-binding dependency graph, transaction-local
|
||||
;; scheduler, scoped variable adapters, and rollback state.
|
||||
|
||||
;;; Code:
|
||||
@ -44,8 +44,8 @@
|
||||
|
||||
(cl-defstruct (tp--transaction-participant
|
||||
(:constructor tp--make-transaction-participant))
|
||||
"One structured participant shared by the v1 and v2 transaction views."
|
||||
key publish rollback protocol order stage precommit after-commit journal state)
|
||||
"One structured transaction participant."
|
||||
key rollback protocol order stage precommit after-commit journal state)
|
||||
|
||||
(cl-defstruct (tp--signal-commit-entry
|
||||
(:constructor tp--make-signal-commit-entry))
|
||||
@ -94,6 +94,7 @@
|
||||
(defvar tp--transaction-phase-start nil)
|
||||
(defvar tp--transaction-phase-timings nil)
|
||||
(defvar tp--transaction-publication-batch nil)
|
||||
(defvar tp--transaction-structured-participants nil)
|
||||
(defvar tp--transaction-final-marker-registry nil)
|
||||
(defvar tp--transaction-final-marker-owner-keys nil)
|
||||
(defvar tp--transaction-final-marker-count 0)
|
||||
@ -126,9 +127,6 @@
|
||||
(defvar tp--transaction-rollback-final-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
|
||||
"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))))
|
||||
|
||||
(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
|
||||
(signal 'tp-reactive-error
|
||||
(list :participant-outside-transaction
|
||||
@ -675,12 +673,12 @@ When CREATE is non-nil, install and return a fresh hash table when absent."
|
||||
participant))
|
||||
|
||||
(defun tp--transaction-make-participant
|
||||
(key publish rollback protocol precommit after-commit journal)
|
||||
"Build a participant from KEY, PUBLISH, ROLLBACK, and PROTOCOL.
|
||||
(key stage rollback protocol precommit after-commit journal)
|
||||
"Build a participant from KEY, STAGE, ROLLBACK, and PROTOCOL.
|
||||
PRECOMMIT and AFTER-COMMIT are optional internal callbacks; JOURNAL is opaque
|
||||
owner-local rollback state."
|
||||
(unless (functionp publish)
|
||||
(signal 'wrong-type-argument (list 'functionp publish)))
|
||||
(unless (functionp stage)
|
||||
(signal 'wrong-type-argument (list 'functionp stage)))
|
||||
(unless (functionp rollback)
|
||||
(signal 'wrong-type-argument (list 'functionp rollback)))
|
||||
(unless (tp--transaction-participant-precommit-function-p precommit)
|
||||
@ -690,39 +688,19 @@ owner-local rollback state."
|
||||
(signal 'wrong-type-argument (list 'functionp after-commit)))
|
||||
(tp--make-transaction-participant
|
||||
:key (tp--copy-property-value key)
|
||||
:publish publish
|
||||
:rollback rollback
|
||||
:protocol protocol
|
||||
:order (prog1 tp--transaction-participant-order
|
||||
(cl-incf tp--transaction-participant-order))
|
||||
:stage publish
|
||||
:stage stage
|
||||
:precommit precommit
|
||||
:after-commit after-commit
|
||||
:journal journal
|
||||
: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
|
||||
(&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
|
||||
participant's opaque owner-local state."
|
||||
(unless tp--transaction-active
|
||||
@ -733,17 +711,55 @@ participant's opaque owner-local state."
|
||||
(tp--transaction-make-participant
|
||||
key stage rollback 'v2 precommit after-commit journal)))
|
||||
|
||||
;;;###autoload
|
||||
(cl-defun tp-transaction-participate-v2
|
||||
(&key key stage rollback precommit after-commit journal)
|
||||
"Register a structured rollback-capable participant under KEY.
|
||||
STAGE and ROLLBACK are required no-argument functions. PRECOMMIT may be one
|
||||
declared package-owned validator; AFTER-COMMIT is contained work queued only
|
||||
after final accept. JOURNAL is opaque owner-local rollback state. Return KEY
|
||||
without exposing TP's internal participant object."
|
||||
(tp--transaction-participate-v2
|
||||
:key key :stage stage :rollback rollback :precommit precommit
|
||||
:after-commit after-commit :journal journal)
|
||||
key)
|
||||
|
||||
(defun tp--transaction-participants-in-registration-order ()
|
||||
"Return the authoritative participants in deterministic declaration order."
|
||||
(reverse tp--transaction-participants))
|
||||
|
||||
(defun tp--publish-transaction-participants ()
|
||||
"Publish registered transaction participants in declaration order."
|
||||
(dolist (participant (tp--transaction-participants-in-registration-order))
|
||||
(push participant tp--transaction-published-participants)
|
||||
;; Mark first so a stage that mutates and then signals remains rollbackable.
|
||||
(setf (tp--transaction-participant-state participant) 'staged)
|
||||
(funcall (tp--transaction-participant-publish participant))))
|
||||
(defun tp--transaction-validate-structured-participants ()
|
||||
"Return the frozen participant vector after exact identity validation."
|
||||
(let* ((participants tp--transaction-structured-participants)
|
||||
(registered (tp--transaction-participants-in-registration-order))
|
||||
(count (length registered)))
|
||||
(unless (and (vectorp participants) (= (length participants) count))
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :participant-count participants registered)))
|
||||
(cl-loop for participant in registered
|
||||
for index from 0
|
||||
unless (eq participant (aref participants index))
|
||||
do (signal 'tp-publication-binding-error
|
||||
(list :participant-order index participant
|
||||
(aref participants index))))
|
||||
(when tp--transaction-publication-batch
|
||||
(let ((candidate-participants
|
||||
(tp-publication-batch-candidate-participants
|
||||
tp--transaction-publication-batch)))
|
||||
(unless (eq candidate-participants participants)
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :participant-vector candidate-participants
|
||||
participants)))))
|
||||
participants))
|
||||
|
||||
(defun tp--stage-structured-transaction-participants ()
|
||||
"Stage the frozen structured participant vector in declaration order."
|
||||
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||
(dotimes (index (length participants))
|
||||
(let ((participant (aref participants index)))
|
||||
(push participant tp--transaction-published-participants)
|
||||
(setf (tp--transaction-participant-state participant) 'staged)
|
||||
(funcall (tp--transaction-participant-stage participant))))))
|
||||
|
||||
(defun tp--rollback-transaction-participants ()
|
||||
"Rollback published participants and return any failures."
|
||||
@ -763,23 +779,28 @@ participant's opaque owner-local state."
|
||||
(setf (tp--transaction-participant-state participant) 'rolled-back)))
|
||||
(nreverse failures)))
|
||||
|
||||
(defun tp--run-transaction-participant-precommits ()
|
||||
"Run declared structured participant validators in registration order."
|
||||
(dolist (participant (tp--transaction-participants-in-registration-order))
|
||||
(when-let* ((function (tp--transaction-participant-precommit participant)))
|
||||
(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)
|
||||
(defun tp--run-structured-transaction-participant-precommits ()
|
||||
"Run validators from the frozen structured participant vector."
|
||||
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||
(dotimes (index (length participants))
|
||||
(when-let* ((function
|
||||
(tp--transaction-participant-after-commit participant)))
|
||||
(tp--enqueue-after-commit function)))))
|
||||
(tp--transaction-participant-precommit
|
||||
(aref participants index))))
|
||||
(unless (tp--transaction-participant-precommit-function-p function)
|
||||
(signal 'tp-reactive-error
|
||||
(list :invalid-participant-precommit function)))
|
||||
(funcall function)))))
|
||||
|
||||
(defun tp--commit-structured-transaction-participants ()
|
||||
"Commit states from the frozen structured participant vector."
|
||||
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||
(dotimes (index (length participants))
|
||||
(let ((participant (aref participants index)))
|
||||
(when (eq (tp--transaction-participant-state participant) 'staged)
|
||||
(setf (tp--transaction-participant-state participant) 'committed)
|
||||
(when-let* ((function
|
||||
(tp--transaction-participant-after-commit participant)))
|
||||
(tp--enqueue-after-commit function)))))))
|
||||
|
||||
(defun tp--dequeue-dirty-binding ()
|
||||
"Return and remove the next queued dirty binding."
|
||||
@ -867,14 +888,6 @@ participant's opaque owner-local state."
|
||||
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 ()
|
||||
"Return the active transaction's caller-retainable one-slot outcome cell."
|
||||
(unless tp--transaction-active
|
||||
@ -913,24 +926,24 @@ participant's opaque owner-local state."
|
||||
surface-journals))
|
||||
|
||||
(defun tp--transaction-begin-publication-batch
|
||||
(batch-id entries surface-journals)
|
||||
"Install BATCH-ID as the candidate for ENTRIES and SURFACE-JOURNALS."
|
||||
(batch-id entries surface-journals stage-entries)
|
||||
"Install BATCH-ID for ENTRIES, SURFACE-JOURNALS, and STAGE-ENTRIES."
|
||||
(unless tp--transaction-active
|
||||
(signal 'tp-reactive-error (list :batch-outside-transaction batch-id)))
|
||||
(when tp--transaction-publication-batch
|
||||
(signal 'tp-publication-state-error
|
||||
(list :duplicate-transaction-batch batch-id)))
|
||||
(when (tp--transaction-v2-artifacts-enabled-p)
|
||||
(setq tp--transaction-publication-batch
|
||||
(tp--publication-batch-prepare
|
||||
:transaction-id tp--transaction-id
|
||||
:batch-id batch-id
|
||||
:entries entries
|
||||
:participants
|
||||
(vconcat (tp--transaction-participants-in-registration-order))
|
||||
:journals (tp--transaction-batch-journal-view surface-journals)
|
||||
:final-accept tp--transaction-final-accept-function
|
||||
:diagnostics nil)))
|
||||
(setq tp--transaction-publication-batch
|
||||
(tp--publication-batch-prepare
|
||||
:transaction-id tp--transaction-id
|
||||
:batch-id batch-id
|
||||
:entries entries
|
||||
:participants
|
||||
tp--transaction-structured-participants
|
||||
:journals (tp--transaction-batch-journal-view surface-journals)
|
||||
:stage-entries stage-entries
|
||||
:final-accept tp--transaction-final-accept-function
|
||||
:diagnostics nil))
|
||||
tp--transaction-publication-batch)
|
||||
|
||||
(defun tp--transaction-batch-transition (next)
|
||||
@ -1146,7 +1159,17 @@ through TP's closed marker-operation whitelist."
|
||||
(unwind-protect
|
||||
(progn
|
||||
(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))
|
||||
(unless accepted
|
||||
(setq tp--transaction-marker-restore-failures
|
||||
@ -1168,9 +1191,8 @@ through TP's closed marker-operation whitelist."
|
||||
(tp--transaction-publish-outcome outcome))))))
|
||||
|
||||
(defun tp--transaction-run-shadow-proof (phase)
|
||||
"Compare v2 artifacts with the single v1 live result for PHASE."
|
||||
(when (and tp--transaction-publication-batch
|
||||
(tp--transaction-v2-artifacts-enabled-p))
|
||||
"Compare structured artifacts with the selected single live result for PHASE."
|
||||
(when tp--transaction-publication-batch
|
||||
(let ((ok t) results outcome-equivalent)
|
||||
(dolist (entry
|
||||
(tp-publication-batch-candidate-entries
|
||||
@ -1435,6 +1457,7 @@ the primary condition data."
|
||||
(tp--transaction-published-participants nil)
|
||||
(tp--transaction-signal-commit-journal nil)
|
||||
(tp--transaction-publication-batch nil)
|
||||
(tp--transaction-structured-participants nil)
|
||||
(tp--transaction-final-marker-registry
|
||||
(make-vector tp--final-marker-max-count nil))
|
||||
(tp--transaction-final-marker-owner-keys
|
||||
@ -1460,13 +1483,16 @@ the primary condition data."
|
||||
(tp--transaction-enter-phase 'recompute)
|
||||
(tp--flush-dirty-bindings)
|
||||
(tp--transaction-enter-phase 'publication)
|
||||
(setq tp--transaction-structured-participants
|
||||
(vconcat
|
||||
(tp--transaction-participants-in-registration-order)))
|
||||
(run-hooks 'tp--transaction-publish-functions)
|
||||
(tp--transaction-batch-transition 'participants)
|
||||
(tp--transaction-enter-phase 'participants)
|
||||
(tp--publish-transaction-participants)
|
||||
(tp--stage-structured-transaction-participants)
|
||||
(tp--transaction-batch-transition 'precommit)
|
||||
(tp--transaction-enter-phase 'precommit)
|
||||
(tp--run-transaction-participant-precommits)
|
||||
(tp--run-structured-transaction-participant-precommits)
|
||||
(tp--run-transaction-precommit-functions)
|
||||
(tp--transaction-freeze-final-markers)
|
||||
(tp--transaction-sync-publication-batch)
|
||||
@ -1491,7 +1517,7 @@ the primary condition data."
|
||||
tp--transaction-final-accept-function)))
|
||||
(tp--transaction-run-final-accept)
|
||||
(setq success t)
|
||||
(tp--commit-transaction-participants)
|
||||
(tp--commit-structured-transaction-participants)
|
||||
(tp--transaction-run-shadow-proof 'commit)
|
||||
(when quit-flag
|
||||
(setq pending-quit t
|
||||
|
||||
41
tp-style.el
41
tp-style.el
@ -205,12 +205,51 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
|
||||
#'tp--merge-face-values
|
||||
(lambda (_old new) new)))
|
||||
|
||||
(defun tp--native-keymap-equal-p (left right)
|
||||
"Compare native snapshots LEFT and RIGHT, retaining commands and menu order."
|
||||
(let ((seen (make-hash-table :test #'eq)))
|
||||
(cl-labels
|
||||
((bindings (map)
|
||||
(let ((local (copy-sequence (if (symbolp map)
|
||||
(indirect-function map) map)))
|
||||
entries)
|
||||
(set-keymap-parent local nil)
|
||||
(map-keymap (lambda (key value) (push (cons key value) entries)) local)
|
||||
entries))
|
||||
(same (old new)
|
||||
(cond
|
||||
((eq old new) t)
|
||||
((memq new (gethash old seen)) t)
|
||||
((and (keymapp old) (keymapp new))
|
||||
(puthash old (cons new (gethash old seen)) seen)
|
||||
(and (equal-including-properties (keymap-prompt old)
|
||||
(keymap-prompt new))
|
||||
(same (bindings old) (bindings new))
|
||||
(same (keymap-parent old) (keymap-parent new))))
|
||||
((or (functionp old) (functionp new)) nil)
|
||||
((and (consp old) (consp new))
|
||||
(puthash old (cons new (gethash old seen)) seen)
|
||||
(and (same (car old) (car new)) (same (cdr old) (cdr new))))
|
||||
((and (vectorp old) (vectorp new) (= (length old) (length new)))
|
||||
(puthash old (cons new (gethash old seen)) seen)
|
||||
(cl-loop for index below (length old)
|
||||
always (same (aref old index) (aref new index))))
|
||||
(t (equal old new)))))
|
||||
(same left right))))
|
||||
|
||||
(defun tp--native-property-value-equal-p (left right)
|
||||
"Compare native values LEFT and RIGHT while preserving callable identity."
|
||||
(cond
|
||||
((and (keymapp left) (keymapp right)) (tp--native-keymap-equal-p left right))
|
||||
((or (functionp left) (functionp right)) (eq left right))
|
||||
(t (equal left right))))
|
||||
|
||||
(defun tp-register-text-property (property)
|
||||
"Register and return a direct policy for Emacs PROPERTY."
|
||||
(let ((id (tp-text-property-id property)))
|
||||
(or (tp-property-policy id)
|
||||
(tp-define-property-policy
|
||||
id :equality #'equal
|
||||
id :equality #'tp--native-property-value-equal-p
|
||||
:merge (tp--text-property-merge-function property)
|
||||
:projector (lambda (value) (list property value))))))
|
||||
|
||||
|
||||
808
tp-surface.el
808
tp-surface.el
File diff suppressed because it is too large
Load Diff
@ -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
|
||||
|
||||
@ -11,10 +11,11 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Internal immutable artifacts and one-shot state machines used to shadow TP's
|
||||
;; v1 publication coordinator. This module owns no live writer and never edits
|
||||
;; a buffer. `tp-reactive' drives the state machine, while `tp-surface' supplies
|
||||
;; exact target entries backed by the v1 prepare journals and snapshots.
|
||||
;; Internal immutable artifacts and one-shot state machines for TP publication.
|
||||
;; The package-owned entry-stage capability stored in a batch candidate drives
|
||||
;; publication. This module never edits a buffer itself: `tp-reactive' drives
|
||||
;; the state machine and `tp-surface' supplies and stages exact target entries
|
||||
;; backed by the shared prepare journals and snapshots.
|
||||
|
||||
;;; Code:
|
||||
|
||||
@ -33,7 +34,7 @@
|
||||
"Invalid TP final-accept marker"
|
||||
'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.")
|
||||
|
||||
(defconst tp--publication-batch-transitions
|
||||
@ -48,6 +49,10 @@
|
||||
'(committed rolled-back discarded)
|
||||
"Terminal publication batch candidate states.")
|
||||
|
||||
(defconst tp--publication-batch-stage-entry-functions
|
||||
'(tp--surface-stage-publication-entries)
|
||||
"Closed package-owned publication entry stage capabilities.")
|
||||
|
||||
(defconst tp--final-marker-max-count 8
|
||||
"Maximum number of opaque final markers in one transaction.")
|
||||
|
||||
@ -78,11 +83,12 @@
|
||||
(defun tp--proper-unique-list-p (items)
|
||||
"Return non-nil when ITEMS is a proper list with no equal duplicates."
|
||||
(and (proper-list-p items)
|
||||
(let (seen (unique t))
|
||||
(let ((seen (make-hash-table :test #'equal))
|
||||
(unique t))
|
||||
(dolist (item items unique)
|
||||
(if (member item seen)
|
||||
(if (gethash item seen)
|
||||
(setq unique nil)
|
||||
(push item seen))))))
|
||||
(puthash item t seen))))))
|
||||
|
||||
(cl-defstruct (tp-publication-target-entry
|
||||
(:constructor tp--make-publication-target-entry)
|
||||
@ -110,6 +116,20 @@
|
||||
(shadow-validator nil :read-only t)
|
||||
rollback-result post-rollback-state shadow-actual shadow-proven-p)
|
||||
|
||||
(defun tp--publication-target-entry-arguments-valid-p
|
||||
(transaction-id batch-id candidate-id surface-id mount-ids buffer
|
||||
old-revision new-revision authority-token shadow-validator)
|
||||
"Return non-nil when target arguments bind TRANSACTION-ID and BATCH-ID.
|
||||
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION,
|
||||
AUTHORITY-TOKEN, and SHADOW-VALIDATOR must have valid publication shapes."
|
||||
(and transaction-id batch-id candidate-id surface-id
|
||||
(bufferp buffer) (buffer-live-p buffer)
|
||||
(integerp old-revision) (>= old-revision 0)
|
||||
(integerp new-revision) (= new-revision (1+ old-revision))
|
||||
(tp--proper-unique-list-p mount-ids)
|
||||
authority-token
|
||||
(or (null shadow-validator) (functionp shadow-validator))))
|
||||
|
||||
(cl-defun tp--publication-target-entry-create
|
||||
(&key transaction-id batch-id candidate-id surface-id mount-ids buffer
|
||||
old-revision new-revision plan diff ledger objects ranges client-state
|
||||
@ -119,15 +139,11 @@
|
||||
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN,
|
||||
DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
|
||||
AUTHORITY-TOKEN describe the target. MAPPING-GENERATION is optional.
|
||||
OPERATION-COUNTS is filled from the v1 report. SHADOW-EXPECTED and
|
||||
OPERATION-COUNTS is filled from the live report. SHADOW-EXPECTED and
|
||||
SHADOW-VALIDATOR are private comparison artifacts."
|
||||
(unless (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)))
|
||||
(unless (tp--publication-target-entry-arguments-valid-p
|
||||
transaction-id batch-id candidate-id surface-id mount-ids buffer
|
||||
old-revision new-revision authority-token shadow-validator)
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :target-entry transaction-id batch-id candidate-id surface-id
|
||||
buffer old-revision new-revision mount-ids authority-token)))
|
||||
@ -222,7 +238,7 @@ SHADOW-VALIDATOR are private comparison artifacts."
|
||||
(cl-defstruct (tp-publication-batch-candidate
|
||||
(:constructor tp--make-publication-batch-candidate)
|
||||
(: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)
|
||||
(id nil :read-only t)
|
||||
state
|
||||
@ -230,6 +246,7 @@ SHADOW-VALIDATOR are private comparison artifacts."
|
||||
(entries nil :read-only t)
|
||||
(participants nil :read-only t)
|
||||
(journals nil :read-only t)
|
||||
(stage-entries nil :read-only t)
|
||||
final-accept
|
||||
(final-accept-id nil :read-only t)
|
||||
diagnostics
|
||||
@ -271,16 +288,22 @@ SHADOW-VALIDATOR are private comparison artifacts."
|
||||
entries))))
|
||||
|
||||
(cl-defun tp--publication-batch-prepare
|
||||
(&key transaction-id batch-id entries participants journals final-accept
|
||||
diagnostics)
|
||||
(&key transaction-id batch-id entries participants journals stage-entries
|
||||
final-accept diagnostics)
|
||||
"Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES.
|
||||
PARTICIPANTS is an ordered reference vector, JOURNALS is the existing v1 state
|
||||
view, FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains
|
||||
known preaccept observations."
|
||||
PARTICIPANTS is an ordered reference vector, JOURNALS is the shared rollback
|
||||
view, STAGE-ENTRIES is an optional package-owned execution capability,
|
||||
FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains known
|
||||
preaccept observations."
|
||||
(unless (and transaction-id batch-id
|
||||
(tp--publication-batch-entries-valid-p
|
||||
entries transaction-id batch-id)
|
||||
(vectorp participants)
|
||||
(or (null stage-entries)
|
||||
(and (symbolp stage-entries)
|
||||
(memq stage-entries
|
||||
tp--publication-batch-stage-entry-functions)
|
||||
(fboundp stage-entries)))
|
||||
(functionp final-accept))
|
||||
(signal 'tp-publication-binding-error
|
||||
(list :batch transaction-id batch-id entries participants)))
|
||||
@ -291,10 +314,21 @@ known preaccept observations."
|
||||
:entries (copy-sequence entries)
|
||||
:participants participants
|
||||
:journals journals
|
||||
:stage-entries stage-entries
|
||||
:final-accept final-accept
|
||||
:final-accept-id (tp--next-final-accept-id)
|
||||
:diagnostics (tp--copy-property-value diagnostics)))
|
||||
|
||||
(defun tp--publication-batch-execute-stage (candidate)
|
||||
"Execute CANDIDATE's package-owned entry stage capability exactly once."
|
||||
(unless (and (tp-publication-batch-candidate-p candidate)
|
||||
(eq (tp-publication-batch-candidate-state candidate) 'staged)
|
||||
(memq (tp-publication-batch-candidate-stage-entries candidate)
|
||||
tp--publication-batch-stage-entry-functions))
|
||||
(signal 'tp-publication-state-error
|
||||
(list :batch-stage candidate)))
|
||||
(funcall (tp-publication-batch-candidate-stage-entries candidate) candidate))
|
||||
|
||||
(defun tp--publication-batch-terminal-p (candidate)
|
||||
"Return non-nil when CANDIDATE has one terminal disposition."
|
||||
(and (tp-publication-batch-candidate-p candidate)
|
||||
|
||||
12
tp.el
12
tp.el
@ -2,7 +2,7 @@
|
||||
|
||||
;; Copyright (C) 2024-2026 Geekinney
|
||||
|
||||
;; Version: 1.0.1
|
||||
;; Version: 2.0.0
|
||||
;; Keywords: convenience text-properties
|
||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||
;; Package-Requires: ((emacs "28.1"))
|
||||
@ -26,7 +26,7 @@
|
||||
;; tp-style.el Native property policies, contribution composition,
|
||||
;; named declarations, and explicit computed values.
|
||||
;; 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
|
||||
;; adapters.
|
||||
;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes,
|
||||
@ -66,12 +66,12 @@
|
||||
(require 'tp-builtins)
|
||||
|
||||
(defconst tp--runtime-manifest
|
||||
`(:package tp :version "1.0.1"
|
||||
`(:package tp :version "2.0.0"
|
||||
:transaction-protocol ,tp-transaction-protocol
|
||||
:batch-artifacts t
|
||||
:batch-execution v1-bridge
|
||||
:batch-execute nil
|
||||
:shadow-proof t
|
||||
:batch-execute t
|
||||
:structured-participant-api tp-transaction-participate-v2
|
||||
:single-live-writer t
|
||||
:final-marker-operation tp-vector-slots/v1)
|
||||
"Immutable package capability facts for cross-package compatibility checks.")
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user