Compare commits
15 Commits
perf-scrol
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
0a820bd0cb | ||
|
|
e28df6a5fb | ||
|
|
6ed8df3915 | ||
|
|
5bcc91d867 | ||
|
|
47e8d8c256 | ||
|
|
b2b9462269 | ||
|
|
c05174ff9d | ||
|
|
25cb66c040 | ||
|
|
469bdff17d | ||
|
|
2e2d9edc84 | ||
|
|
9ac8c7a133 | ||
|
|
76be75f674 | ||
|
|
7632a05bdf | ||
|
|
c2525a137b | ||
|
|
31304c1906 |
18
CHANGELOG.md
18
CHANGELOG.md
@ -2,13 +2,20 @@
|
|||||||
|
|
||||||
All notable changes to the tp library are documented here.
|
All notable changes to the tp library are documented here.
|
||||||
|
|
||||||
## 1.0.0 (Unreleased)
|
## 2.0.0 (Unreleased)
|
||||||
|
|
||||||
### Added
|
### Added
|
||||||
|
|
||||||
- A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup.
|
- A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup.
|
||||||
- Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters.
|
- Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters.
|
||||||
- Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup.
|
- Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup.
|
||||||
|
- 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.
|
- Native property policies and contribution composition with explicit nil/absence, normalization, validation, equality, merge, projection, named direct styles, and explicit `tp-computed` value sources.
|
||||||
- `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core.
|
- `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core.
|
||||||
- Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans.
|
- Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans.
|
||||||
@ -16,6 +23,9 @@ All notable changes to the tp library are documented here.
|
|||||||
|
|
||||||
### Changed
|
### Changed
|
||||||
|
|
||||||
|
- Structured publication batches own the single live surface-entry loop,
|
||||||
|
participant stage/precommit/commit vector, and candidate-bound final accept.
|
||||||
|
- Package metadata now identifies the v2-only breaking transaction contract.
|
||||||
- `define-tp` and `define-tps` now define static or parameterized direct declaration recipes. Applying a recipe produces ordinary properties and never publishes runtime identity metadata.
|
- `define-tp` and `define-tps` now define static or parameterized direct declaration recipes. Applying a recipe produces ordinary properties and never publishes runtime identity metadata.
|
||||||
- TP is no longer a CSS engine. Selector, stylesheet, specificity, origin/importance, cascade layer, CSS-wide value, custom property, winner, and provenance behavior belongs to the independent ECSS package.
|
- TP is no longer a CSS engine. Selector, stylesheet, specificity, origin/importance, cascade layer, CSS-wide value, custom property, winner, and provenance behavior belongs to the independent ECSS package.
|
||||||
- Function-valued properties are always literal. Only values wrapped by `tp-computed` execute and participate in dependency collection.
|
- Function-valued properties are always literal. Only values wrapped by `tp-computed` execute and participate in dependency collection.
|
||||||
@ -24,6 +34,12 @@ All notable changes to the tp library are documented here.
|
|||||||
|
|
||||||
### Removed
|
### Removed
|
||||||
|
|
||||||
|
- The public `tp-transaction-participate` v1 facade. Replace
|
||||||
|
`(tp-transaction-participate KEY PUBLISH ROLLBACK)` with
|
||||||
|
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`.
|
||||||
|
- The v1 publication writer, execution-route kill switch, artifact-mode switch,
|
||||||
|
and their runtime manifest claims.
|
||||||
|
|
||||||
- `tp-render.el`, `tp-stack.el`, the scan-driven renderer, layer-to-buffer registry, and duplicate managed transaction path.
|
- `tp-render.el`, `tp-stack.el`, the scan-driven renderer, layer-to-buffer registry, and duplicate managed transaction path.
|
||||||
- Managed stack mutation, attach/detach, diagnostics, and lifecycle APIs that depended on inline stack storage.
|
- Managed stack mutation, attach/detach, diagnostics, and lifecycle APIs that depended on inline stack storage.
|
||||||
- `tp-text`, `$variable` declaration syntax, automatic layer refresh, and character-level `tp-name`/`tp-layers`/`tp-meta` runtime storage.
|
- `tp-text`, `$variable` declaration syntax, automatic layer refresh, and character-level `tp-name`/`tp-layers`/`tp-meta` runtime storage.
|
||||||
|
|||||||
30
Makefile
30
Makefile
@ -3,6 +3,9 @@
|
|||||||
# Usage:
|
# Usage:
|
||||||
# make test # run all ERT test suites
|
# make test # run all ERT test suites
|
||||||
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
|
# make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces)
|
||||||
|
# make test-m0a # run current TP completion characterization
|
||||||
|
# make test-m1a # run additive transaction contract + fault gates
|
||||||
|
# make test-c1b # run the v2-only transaction regression gate
|
||||||
# make doctest # execute README examples against the code
|
# make doctest # execute README examples against the code
|
||||||
# make benchmark # run reproducible correctness-first benchmarks
|
# make benchmark # run reproducible correctness-first benchmarks
|
||||||
# make compile # byte-compile the library modules
|
# make compile # byte-compile the library modules
|
||||||
@ -21,19 +24,42 @@ WERROR ?= nil
|
|||||||
TEST_DIR = tests
|
TEST_DIR = tests
|
||||||
LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA)
|
LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA)
|
||||||
|
|
||||||
SRC = tp-core.el tp-style.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \
|
SRC = tp-core.el tp-style.el tp-transaction.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \
|
||||||
tp-query.el tp-palette.el tp-builtins.el tp.el
|
tp-query.el tp-palette.el tp-builtins.el tp.el
|
||||||
TESTS = $(wildcard $(TEST_DIR)/*-tests.el)
|
TESTS = $(wildcard $(TEST_DIR)/*-tests.el)
|
||||||
TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el
|
TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el
|
||||||
EXAMPLES = $(wildcard examples/*.el)
|
EXAMPLES = $(wildcard examples/*.el)
|
||||||
DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
|
DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el
|
||||||
|
|
||||||
.PHONY: test test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
|
.PHONY: test test-m0a test-m1a test-c1b test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean
|
||||||
|
|
||||||
test:
|
test:
|
||||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
||||||
-f ert-run-tests-batch-and-exit
|
-f ert-run-tests-batch-and-exit
|
||||||
|
|
||||||
|
test-m0a:
|
||||||
|
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
|
||||||
|
-l $(TEST_DIR)/tp-binding-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-surface-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
|
||||||
|
--eval '(ert-run-tests-batch-and-exit "tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
|
||||||
|
|
||||||
|
test-m1a:
|
||||||
|
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
|
||||||
|
-l $(TEST_DIR)/tp-binding-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-surface-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-transaction-tests.el \
|
||||||
|
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-\\|tp-binding-test-signal-commit-journal-rolls-back-every-write\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-global-signal-update-is-multi-surface-atomic\\|tp-surface-test-full-and-scoped-precommit-stages-roll-back\\|tp-surface-test-full-and-scoped-final-accept-roll-back")'
|
||||||
|
|
||||||
|
test-c1b:
|
||||||
|
$(EMACS) -Q --batch $(LOADPATH) -l tp.el \
|
||||||
|
-l $(TEST_DIR)/tp-binding-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-surface-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-m0a-characterization-tests.el \
|
||||||
|
-l $(TEST_DIR)/tp-transaction-tests.el \
|
||||||
|
--eval '(ert-run-tests-batch-and-exit "tp-transaction-test-\\|tp-m0a-characterization-test-participant-failure-preserves-condition\\|tp-binding-test-participant-key-is-owned-by-transaction\\|tp-binding-test-rollback-preserves-primary-and-runs-all-phases\\|tp-surface-test-transaction-participant\\|tp-surface-test-failing-participant")'
|
||||||
|
|
||||||
test-shuffled:
|
test-shuffled:
|
||||||
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
$(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \
|
||||||
-l tp-run-shuffled.el
|
-l tp-run-shuffled.el
|
||||||
|
|||||||
26
README.md
26
README.md
@ -1,13 +1,13 @@
|
|||||||
# TP
|
# TP
|
||||||
|
|
||||||
TP 1.0 is a standalone retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning text-property composition, exact dependency tracking, retained identity, marker-backed mounts, diffing, transactions, rollback, and final buffer publication.
|
TP 2.0 is a standalone retained/reactive text runtime for Emacs. It projects declarative properties, reactive data, and stable text objects onto strings and buffers while owning text-property composition, exact dependency tracking, retained identity, marker-backed mounts, diffing, transactions, rollback, and final buffer publication.
|
||||||
|
|
||||||
TP does not depend on Ebox or ECSS. It does not implement CSS selectors, stylesheets, specificity, cascade winners, Box, Flex, Grid, measurement, or layout. A CSS consumer may compute final declarations with ECSS and publish them through TP, but TP itself only understands Emacs text properties and generic retained text surfaces.
|
TP does not depend on Ebox or ECSS. It does not implement CSS selectors, stylesheets, specificity, cascade winners, Box, Flex, Grid, measurement, or layout. A CSS consumer may compute final declarations with ECSS and publish them through TP, but TP itself only understands Emacs text properties and generic retained text surfaces.
|
||||||
|
|
||||||
Chinese documentation: [README_CN.md](README_CN.md).
|
Chinese documentation: [README_CN.md](README_CN.md).
|
||||||
|
|
||||||
Complete public API reference: [API-REFERENCE.md](docs/API-REFERENCE.md) (中文).
|
Complete public API reference: [API-REFERENCE.md](docs/API-REFERENCE.md) (中文).
|
||||||
It is the symbol-level usage index for the current TP 1.0 implementation; this
|
It is the symbol-level usage index for the current TP 2.0 implementation; this
|
||||||
README remains the conceptual quick start.
|
README remains the conceptual quick start.
|
||||||
|
|
||||||
## Requirements
|
## Requirements
|
||||||
@ -146,6 +146,17 @@ TP records the host baseline and each TP contribution per property interval. Ove
|
|||||||
|
|
||||||
Observers run only after a successful commit. Their failures are recorded and do not roll back an already committed transaction. A buffer killed during publication remains killed; rollback never recreates it.
|
Observers run only after a successful commit. Their failures are recorded and do not roll back an already committed transaction. A buffer killed during publication remains killed; rollback never recreates it.
|
||||||
|
|
||||||
|
TP 2.0 drives the single live publication from exact transaction-scoped batch
|
||||||
|
entries, one frozen participant vector, and the candidate-bound final accept.
|
||||||
|
The same journals, surface snapshots, and change group are shared rather than
|
||||||
|
copied. Transaction participants register through
|
||||||
|
`tp-transaction-participate-v2`; TP has no alternate transaction writer or
|
||||||
|
runtime route switch.
|
||||||
|
Generic opaque authority markers are bounded and whitelist-validated before
|
||||||
|
final accept, then reverse-restored before ordinary rollback on partial apply or
|
||||||
|
accept failure. `tp-with-transaction` still returns its body value, and
|
||||||
|
internal outcomes remain observational side-channel evidence.
|
||||||
|
|
||||||
ETAF integration uses the same boundary through one opaque transaction
|
ETAF integration uses the same boundary through one opaque transaction
|
||||||
participant. ETAF prepares its immutable generation and Ebox candidate before
|
participant. ETAF prepares its immutable generation and Ebox candidate before
|
||||||
TP accepts the transaction; participant publish, TP final accept, and
|
TP accepts the transaction; participant publish, TP final accept, and
|
||||||
@ -174,7 +185,7 @@ cycles instead of spinning.
|
|||||||
| Core inspection and debug | `tp-debug-*`, `tp-intervals`, `tp-intervals-map`, `tp-plist`, `tp-text-snapshot`, `tp-empty-p` |
|
| Core inspection and debug | `tp-debug-*`, `tp-intervals`, `tp-intervals-map`, `tp-plist`, `tp-text-snapshot`, `tp-empty-p` |
|
||||||
| Property policy and declarations | `tp-define-property-policy`, `tp-register-text-property`, `tp-text-declarations`, `tp-computed`, `tp-resolve-value`, `tp-merge-declarations`, `tp-define-style`, `tp-style-declarations` |
|
| Property policy and declarations | `tp-define-property-policy`, `tp-register-text-property`, `tp-text-declarations`, `tp-computed`, `tp-resolve-value`, `tp-merge-declarations`, `tp-define-style`, `tp-style-declarations` |
|
||||||
| Static recipes | `define-tp`/`tp-define-layer`, `define-tps`/`define-tp-group`/`tp-define-group`, layer/group queries, undefine/reset/describe |
|
| Static recipes | `define-tp`/`tp-define-layer`, `define-tps`/`define-tp-group`/`tp-define-group`, layer/group queries, undefine/reset/describe |
|
||||||
| Signals and bindings | signal create/read/peek/set/dispose, binding install/read/dispose, `tp-variable-signal`, `tp-with-transaction`, `tp-transaction-participate`, counters/reset |
|
| Signals and bindings | signal create/read/peek/set/dispose, binding install/read/dispose, `tp-variable-signal`, `tp-with-transaction`, `tp-transaction-participate-v2`, read-only `tp-transaction-active-p`, `tp-runtime-manifest`, counters/reset |
|
||||||
| Objects and plans | plan/result constructors, `tp-object-ensure`, retain/reuse, fragment/content-range attachment, resolve, mounted/mounts |
|
| Objects and plans | plan/result constructors, `tp-object-ensure`, retain/reuse, fragment/content-range attachment, resolve, mounted/mounts |
|
||||||
| Host ranges | `tp-range-anchor-create`, `tp-range-anchor-live-p`, `tp-object-attach-range`, `tp-range-rebase` |
|
| Host ranges | `tp-range-anchor-create`, `tp-range-anchor-live-p`, `tp-object-attach-range`, `tp-range-rebase` |
|
||||||
| Surfaces | mount/update/scoped update, materialize, live/revision/client-state, at-point, report/report-summary/inspect, unmount |
|
| Surfaces | mount/update/scoped update, materialize, live/revision/client-state, at-point, report/report-summary/inspect, unmount |
|
||||||
@ -192,6 +203,15 @@ for module boundaries and transaction flow.
|
|||||||
|
|
||||||
TP 1.0 removes the 0.3 managed stack/renderer runtime instead of hiding it behind compatibility branches. Removed behavior includes `tp-render.el`, `tp-stack.el`, stack mutation APIs, `tp-text`, `$variable` declarations, layer-to-buffer registries, scan-driven refresh, managed attach/detach/diagnostics, and inline `tp-name`/`tp-layers`/`tp-meta` runtime storage.
|
TP 1.0 removes the 0.3 managed stack/renderer runtime instead of hiding it behind compatibility branches. Removed behavior includes `tp-render.el`, `tp-stack.el`, stack mutation APIs, `tp-text`, `$variable` declarations, layer-to-buffer registries, scan-driven refresh, managed attach/detach/diagnostics, and inline `tp-name`/`tp-layers`/`tp-meta` runtime storage.
|
||||||
|
|
||||||
|
## TP 2.0 transaction migration
|
||||||
|
|
||||||
|
TP 2.0 removes the v1 transaction participant facade and the legacy execution
|
||||||
|
route. Replace `(tp-transaction-participate KEY PUBLISH ROLLBACK)` exactly with
|
||||||
|
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`.
|
||||||
|
Callers that inspect `tp-runtime-manifest` must require
|
||||||
|
`tp-transaction-protocol-v2`; route-selection and v1-adapter fields are no
|
||||||
|
longer published.
|
||||||
|
|
||||||
Use direct recipes for reusable static declarations, `tp-watch` for reactive properties on existing text, and retained content surfaces for reactive text or structured UI. TP does not automatically scan historical propertized text to reconstruct runtime identity.
|
Use direct recipes for reusable static declarations, `tp-watch` for reactive properties on existing text, and retained content surfaces for reactive text or structured UI. TP does not automatically scan historical propertized text to reconstruct runtime identity.
|
||||||
|
|
||||||
## Examples
|
## Examples
|
||||||
|
|||||||
23
README_CN.md
23
README_CN.md
@ -1,13 +1,13 @@
|
|||||||
# TP
|
# TP
|
||||||
|
|
||||||
TP 1.0 是一个可独立使用的 Emacs retained/reactive text runtime。它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer,并拥有文本属性 contribution 合成、精确依赖追踪、保留式身份、marker-backed mount、diff、事务、回滚和最终 Buffer publication。
|
TP 2.0 是一个可独立使用的 Emacs retained/reactive text runtime。它把声明式属性、响应式数据和稳定文本对象投影到 string 与 buffer,并拥有文本属性 contribution 合成、精确依赖追踪、保留式身份、marker-backed mount、diff、事务、回滚和最终 Buffer publication。
|
||||||
|
|
||||||
TP 不依赖 Ebox 或 ECSS,也不实现 CSS selector、stylesheet、specificity、cascade winner、Box、Flex、Grid、测量或布局。需要 CSS 的调用者可以先用 ECSS 算出最终 declarations,再交给 TP 发布;TP 自身只理解 Emacs 文本属性和通用 retained text surface。
|
TP 不依赖 Ebox 或 ECSS,也不实现 CSS selector、stylesheet、specificity、cascade winner、Box、Flex、Grid、测量或布局。需要 CSS 的调用者可以先用 ECSS 算出最终 declarations,再交给 TP 发布;TP 自身只理解 Emacs 文本属性和通用 retained text surface。
|
||||||
|
|
||||||
英文文档:[README.md](README.md)。
|
英文文档:[README.md](README.md)。
|
||||||
|
|
||||||
完整公共 API 参考:[API-REFERENCE.md](docs/API-REFERENCE.md)。本文负责概念
|
完整公共 API 参考:[API-REFERENCE.md](docs/API-REFERENCE.md)。本文负责概念
|
||||||
和快速开始;API 参考按当前 TP 1.0 源码列出入口、参数语义、返回值和用法。
|
和快速开始;API 参考按当前 TP 2.0 源码列出入口、参数语义、返回值和用法。
|
||||||
|
|
||||||
## 运行要求
|
## 运行要求
|
||||||
|
|
||||||
@ -145,6 +145,15 @@ TP 为每个 property interval 保存 host baseline 和各个 TP contribution。
|
|||||||
|
|
||||||
observer 只在成功提交之后运行,observer failure 只记录,不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡,rollback 不会把它重新创建。
|
observer 只在成功提交之后运行,observer failure 只记录,不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡,rollback 不会把它重新创建。
|
||||||
|
|
||||||
|
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
|
ETAF 集成复用同一事务边界,只注册一个 opaque transaction participant。ETAF
|
||||||
先准备 immutable generation 和 Ebox candidate,再由 TP 按固定顺序完成
|
先准备 immutable generation 和 Ebox candidate,再由 TP 按固定顺序完成
|
||||||
participant publish、TP final accept 和 post-accept cleanup。participant failure
|
participant publish、TP final accept 和 post-accept cleanup。participant failure
|
||||||
@ -171,7 +180,7 @@ effect 的 input/version tuple,重复或超过图规模上限时停止循环
|
|||||||
| Core inspection 与 debug | `tp-debug-*`、`tp-intervals`、`tp-intervals-map`、`tp-plist`、`tp-text-snapshot`、`tp-empty-p` |
|
| Core inspection 与 debug | `tp-debug-*`、`tp-intervals`、`tp-intervals-map`、`tp-plist`、`tp-text-snapshot`、`tp-empty-p` |
|
||||||
| Property policy 与 declaration | `tp-define-property-policy`、`tp-register-text-property`、`tp-text-declarations`、`tp-computed`、`tp-resolve-value`、`tp-merge-declarations`、`tp-define-style`、`tp-style-declarations` |
|
| Property policy 与 declaration | `tp-define-property-policy`、`tp-register-text-property`、`tp-text-declarations`、`tp-computed`、`tp-resolve-value`、`tp-merge-declarations`、`tp-define-style`、`tp-style-declarations` |
|
||||||
| 静态 recipe | `define-tp`/`tp-define-layer`、`define-tps`/`define-tp-group`/`tp-define-group`、layer/group 查询、undefine/reset/describe |
|
| 静态 recipe | `define-tp`/`tp-define-layer`、`define-tps`/`define-tp-group`/`tp-define-group`、layer/group 查询、undefine/reset/describe |
|
||||||
| Signal 与 binding | signal create/read/peek/set/dispose、binding install/read/dispose、`tp-variable-signal`、`tp-with-transaction`、`tp-transaction-participate`、counter/reset |
|
| Signal 与 binding | signal create/read/peek/set/dispose、binding install/read/dispose、`tp-variable-signal`、`tp-with-transaction`、`tp-transaction-participate-v2`、只读 `tp-transaction-active-p`、`tp-runtime-manifest`、counter/reset |
|
||||||
| Object 与 plan | plan/result constructor、`tp-object-ensure`、retain/reuse、fragment/content-range attach、resolve、mounted/mounts |
|
| Object 与 plan | plan/result constructor、`tp-object-ensure`、retain/reuse、fragment/content-range attach、resolve、mounted/mounts |
|
||||||
| Host range | `tp-range-anchor-create`、`tp-range-anchor-live-p`、`tp-object-attach-range`、`tp-range-rebase` |
|
| Host range | `tp-range-anchor-create`、`tp-range-anchor-live-p`、`tp-object-attach-range`、`tp-range-rebase` |
|
||||||
| Surface | mount/update/scoped update、materialize、live/revision/client-state、at-point、report/report-summary/inspect、unmount |
|
| Surface | mount/update/scoped update、materialize、live/revision/client-state、at-point、report/report-summary/inspect、unmount |
|
||||||
@ -188,6 +197,14 @@ ownership、生命周期、错误和返回值合同见 [API semantics](docs/API-
|
|||||||
|
|
||||||
TP 1.0 直接删除 0.3 的 managed stack/renderer runtime,不使用隐藏兼容分支。删除的行为包括 `tp-render.el`、`tp-stack.el`、stack mutation APIs、`tp-text`、`$variable` declarations、layer-to-buffer registry、scan-driven refresh、managed attach/detach/diagnostics,以及以 `tp-name`/`tp-layers`/`tp-meta` 作为权威 runtime storage 的机制。
|
TP 1.0 直接删除 0.3 的 managed stack/renderer runtime,不使用隐藏兼容分支。删除的行为包括 `tp-render.el`、`tp-stack.el`、stack mutation APIs、`tp-text`、`$variable` declarations、layer-to-buffer registry、scan-driven refresh、managed attach/detach/diagnostics,以及以 `tp-name`/`tp-layers`/`tp-meta` 作为权威 runtime storage 的机制。
|
||||||
|
|
||||||
|
## TP 2.0 transaction 迁移
|
||||||
|
|
||||||
|
TP 2.0 删除 v1 transaction participant facade 和 legacy execution route。把
|
||||||
|
`(tp-transaction-participate KEY PUBLISH ROLLBACK)` 精确替换为
|
||||||
|
`(tp-transaction-participate-v2 :key KEY :stage PUBLISH :rollback ROLLBACK)`。
|
||||||
|
检查 `tp-runtime-manifest` 的调用方必须要求 `tp-transaction-protocol-v2`;manifest
|
||||||
|
不再发布 route-selection 和 v1-adapter 字段。
|
||||||
|
|
||||||
可复用静态声明使用 direct recipe;已有文本的响应式属性使用 `tp-watch`;响应式文字或结构化 UI 使用 retained content surface。TP 不会自动扫描历史 propertized text 来重建 runtime identity。
|
可复用静态声明使用 direct recipe;已有文本的响应式属性使用 `tp-watch`;响应式文字或结构化 UI 使用 retained content surface。TP 不会自动扫描历史 propertized text 来重建 runtime identity。
|
||||||
|
|
||||||
## 示例
|
## 示例
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
# TP 1.0 公共 API 与用法参考
|
# TP 2.0 公共 API 与用法参考
|
||||||
|
|
||||||
本文是 TP 当前实现的完整公共入口索引。它以 tp.el 加载的模块为准;带
|
本文是 TP 当前实现的完整公共入口索引。它以 tp.el 加载的模块为准;带
|
||||||
tp-- 前缀的函数、变量和结构体是内部实现,不属于本文的稳定 API。
|
tp-- 前缀的函数、变量和结构体是内部实现,不属于本文的稳定 API。
|
||||||
@ -226,10 +226,15 @@ tp-binding-dispose 释放单个 binding。
|
|||||||
(tp-signal-dispose left)
|
(tp-signal-dispose left)
|
||||||
(tp-signal-dispose right))
|
(tp-signal-dispose right))
|
||||||
|
|
||||||
(tp-transaction-participate
|
(tp-with-transaction
|
||||||
'my-external-state
|
(tp-transaction-participate-v2
|
||||||
(lambda () (my-publish))
|
:key 'my-structured-state
|
||||||
(lambda () (my-rollback)))
|
:stage (lambda () (my-stage))
|
||||||
|
:rollback (lambda () (my-rollback))))
|
||||||
|
|
||||||
|
(tp-transaction-active-p)
|
||||||
|
|
||||||
|
(tp-runtime-manifest)
|
||||||
|
|
||||||
(tp-variable-signal 'my-variable)
|
(tp-variable-signal 'my-variable)
|
||||||
(tp-variable-signal 'my-buffer-variable some-buffer)
|
(tp-variable-signal 'my-buffer-variable some-buffer)
|
||||||
@ -240,10 +245,29 @@ tp-binding-dispose 释放单个 binding。
|
|||||||
|
|
||||||
tp-with-transaction 将 signal、binding、surface 和注册的 transaction
|
tp-with-transaction 将 signal、binding、surface 和注册的 transaction
|
||||||
participant 一起原子处理。participant 必须在 active transaction 内注册;
|
participant 一起原子处理。participant 必须在 active transaction 内注册;
|
||||||
publish 在 surface publication 后、source commit 前运行,失败时按逆序
|
stage 在 surface publication 后、source commit 前运行,失败时按逆序
|
||||||
rollback。tp-variable-signal 用 Emacs variable watcher 适配全局或指定
|
rollback。consumer 使用 `tp-transaction-participate-v2`;它
|
||||||
|
返回 key,不暴露内部 participant 对象。tp-variable-signal 用 Emacs variable
|
||||||
|
watcher 适配全局或指定
|
||||||
Buffer 的变量,不是旧的 $variable API。
|
Buffer 的变量,不是旧的 $variable API。
|
||||||
|
|
||||||
|
tp-transaction-active-p 是只读边界查询:只在当前 dynamic extent 已进入
|
||||||
|
或加入 TP transaction 时返回严格的 t,否则返回 nil。它不暴露 transaction
|
||||||
|
对象、participant 或内部状态,调用方只能用它在 mutation 前拒绝不支持的
|
||||||
|
嵌套事务边界。
|
||||||
|
|
||||||
|
tp-runtime-manifest 返回防御性 capability snapshot;本版本的
|
||||||
|
`:transaction-protocol` 为 `tp-transaction-protocol-v2`,`:version` 为
|
||||||
|
`"2.0.0"`。`:structured-participant-api` 指向
|
||||||
|
`tp-transaction-participate-v2`;`:batch-execute`、`:batch-artifacts` 和
|
||||||
|
`:single-live-writer` 均为 non-nil。manifest 不再发布 execution route、
|
||||||
|
v1 adapter 或 v1 rollback route。
|
||||||
|
|
||||||
|
从 TP 1.x 迁移时,把 `(tp-transaction-participate KEY PUBLISH ROLLBACK)`
|
||||||
|
精确替换为 `(tp-transaction-participate-v2 :key KEY :stage PUBLISH
|
||||||
|
:rollback ROLLBACK)`。删除所有对 `tp-transaction-execution-route` 和
|
||||||
|
`tp--transaction-artifact-mode` 的设置。
|
||||||
|
|
||||||
ETAF registers one opaque participant for its immutable generation and Ebox
|
ETAF registers one opaque participant for its immutable generation and Ebox
|
||||||
client state. Its publish is paired with rollback across TP final accept; the
|
client state. Its publish is paired with rollback across TP final accept; the
|
||||||
ETAF runtime separately records effect input/version tuples and reports a
|
ETAF runtime separately records effect input/version tuples and reports a
|
||||||
@ -366,6 +390,19 @@ Report 的常用字段包括:
|
|||||||
:scope-fallback、:property-conflicts、:rolled-back、:failure、
|
:scope-fallback、:property-conflicts、:rolled-back、:failure、
|
||||||
:observer-errors、:timing。
|
:observer-errors、:timing。
|
||||||
|
|
||||||
|
已经精确计算出变更区间的 producer 可以使用 `tp-commit-batch-create` 构造
|
||||||
|
批次,再由 `tp-commit-batch-result-create` 绑定当前 prepare context;发布和
|
||||||
|
回滚仍使用相同 surface 事务。批次绑定前后 revision、extent 和坐标映射。
|
||||||
|
每个 patch 的 `:replacement` 是完整属性文本,也可以携带局部
|
||||||
|
`:property-contributions`:其中 `:start`/`:end` 相对于该 replacement,按列表
|
||||||
|
顺序使用已注册的 property merge policy 合成。策略在**构造批次时**求值;
|
||||||
|
批次只保留合成后的文本快照,不保留贡献列表,之后的调用方修改或策略替换
|
||||||
|
不会重新计算这份批次。函数、record 等 opaque 属性身份按既有 snapshot 规则保留。
|
||||||
|
|
||||||
|
producer 只有在证明整个挂载拓扑、tags 和坐标均与已提交版本相同时,才能向
|
||||||
|
`tp-commit-batch-result-create` 传 `:reuse-mount-projection t`。它不能与显式
|
||||||
|
`:mount-specs` 同时使用;数量相同或对象没有增删都不能替代完整的不变证明。
|
||||||
|
|
||||||
### 6.3 Host range 和 tp-watch
|
### 6.3 Host range 和 tp-watch
|
||||||
|
|
||||||
~~~elisp
|
~~~elisp
|
||||||
@ -594,7 +631,8 @@ TP 1.0 已删除并且不应在新代码中使用:
|
|||||||
| tp-core.el | tp-debug-*、tp-with-current-buffer、tp-intervals、tp-intervals-map、tp-empty-p、tp-plist、tp-text-snapshot |
|
| tp-core.el | tp-debug-*、tp-with-current-buffer、tp-intervals、tp-intervals-map、tp-empty-p、tp-plist、tp-text-snapshot |
|
||||||
| tp-style.el | tp-define-property-policy、tp-property-policy、tp-text-property-id、tp-register-text-property、tp-text-declarations、tp-computed、tp-resolve-value、tp-merge-declarations、tp-define-style、tp-style-declarations、tp-undefine-style |
|
| tp-style.el | tp-define-property-policy、tp-property-policy、tp-text-property-id、tp-register-text-property、tp-text-declarations、tp-computed、tp-resolve-value、tp-merge-declarations、tp-define-style、tp-style-declarations、tp-undefine-style |
|
||||||
| tp-layer.el | define-tp/tp-define-layer、define-tps/define-tp-group/tp-define-group、layer/group query、tp-layer-reset、tp-undefine-*、tp-describe-layer |
|
| tp-layer.el | define-tp/tp-define-layer、define-tps/define-tp-group/tp-define-group、layer/group query、tp-layer-reset、tp-undefine-*、tp-describe-layer |
|
||||||
| tp-reactive.el | signal、binding、transaction、variable adapter、counter 和 reset API |
|
| tp-transaction.el | structured batch/entry、final-marker 与 tagged-outcome 内部合同 |
|
||||||
|
| tp-reactive.el | signal、binding、transaction coordinator、variable adapter、counter 和 reset API |
|
||||||
| tp-surface.el | plan/result、object、range anchor、surface lifecycle、scoped update、report、tp-watch |
|
| tp-surface.el | plan/result、object、range anchor、surface lifecycle、scoped update、report、tp-watch |
|
||||||
| tp-ops.el | tp-propertize、tp-apply、tp-set、tp-reset、tp-add、tp-remove、tp-clear、tp-get、tp-at、tp-member |
|
| tp-ops.el | tp-propertize、tp-apply、tp-set、tp-reset、tp-add、tp-remove、tp-clear、tp-get、tp-at、tp-member |
|
||||||
| tp-search.el | tp-match-*、tp-regexp-*、tp-search、tp-search-map、tp-forward*、tp-backward*、tp-any-value |
|
| tp-search.el | tp-match-*、tp-regexp-*、tp-search、tp-search-map、tp-forward*、tp-backward*、tp-any-value |
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
# TP 1.0 API Semantics
|
# TP 2.0 API Semantics
|
||||||
|
|
||||||
本文记录 TP 1.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为;目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
|
本文记录 TP 2.0 当前公共 API 的 ownership、presence、响应式、retained surface、事务与失败合同。它描述已经实现的行为;目标背景与设计理由见 [retained runtime architecture](retained-runtime-target-architecture.md)。
|
||||||
|
|
||||||
完整的公共符号、参数形状、返回值和示例见 [API reference](API-REFERENCE.md)。
|
完整的公共符号、参数形状、返回值和示例见 [API reference](API-REFERENCE.md)。
|
||||||
|
|
||||||
@ -196,13 +196,34 @@ TP 为每个 interval 保存:
|
|||||||
3. 运行 binding graph 与 producers;
|
3. 运行 binding graph 与 producers;
|
||||||
4. 校验 object、plan、capability、range、conflict 与 lifecycle;
|
4. 校验 object、plan、capability、range、conflict 与 lifecycle;
|
||||||
5. 为所有 surfaces 准备 text/property operations 与 inverse journals;
|
5. 为所有 surfaces 准备 text/property operations 与 inverse journals;
|
||||||
6. 按稳定 surface id publish;
|
6. 默认从 publication batch 的 exact entry bindings 按稳定 surface id publish;
|
||||||
7. 原子切换 signals、bindings、plans、mount/index、client state 和 revisions;
|
7. 从 batch 绑定的同一 participant vector 按声明顺序 stage participant,再执行
|
||||||
8. 全部成功后运行 observers。
|
declared precommit;
|
||||||
|
8. commit signal journal;
|
||||||
|
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;
|
||||||
|
10. final accept 成功后固定写入 tagged success,再运行 contained
|
||||||
|
committed/observer work。
|
||||||
|
|
||||||
嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers;任一 surface 失败时,已发布 surfaces 和 source/binding state 全部回滚。
|
嵌套 transaction 加入最外层。一个 global signal 可以原子触达多个 buffers;任一 surface 失败时,已发布 surfaces 和 source/binding state 全部回滚。
|
||||||
|
|
||||||
`tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。participant key 在一个 outer transaction 中必须唯一。它不是 observer;失败会回滚 transaction。Observer failure 只记录,不回滚已提交结果。
|
`tp-transaction-participate-v2` 允许 client side state 在 surfaces 发布后、
|
||||||
|
source commit 前加入同一 rollback boundary。调用方通过 `:key`、`:stage` 和
|
||||||
|
`:rollback` 注册 structured participant;返回值仍是 key,内部 participant
|
||||||
|
identity、state 与 journal 不暴露。participant key 在一个 outer transaction
|
||||||
|
中必须唯一。它不是 observer;失败会回滚 transaction。Observer failure 只记录,
|
||||||
|
不回滚已提交结果。
|
||||||
|
|
||||||
|
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
|
ETAF uses this API with one opaque participant for its immutable generation and
|
||||||
Ebox client state. The participant is published only after candidate
|
Ebox client state. The participant is published only after candidate
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
# TP 1.0 Current Architecture
|
# TP 2.0 Current Architecture
|
||||||
|
|
||||||
本文描述 TP 1.0 当前实现的模块边界、权威状态、数据流和事务模型。公共行为合同见 [API semantics](API-SEMANTICS.md),设计背景见 [retained runtime architecture](retained-runtime-target-architecture.md)。
|
本文描述 TP 2.0 当前实现的模块边界、权威状态、数据流和事务模型。公共行为合同见 [API semantics](API-SEMANTICS.md),设计背景见 [retained runtime architecture](retained-runtime-target-architecture.md)。
|
||||||
|
|
||||||
按功能查找公共入口和用法时,使用 [API reference](API-REFERENCE.md)。
|
按功能查找公共入口和用法时,使用 [API reference](API-REFERENCE.md)。
|
||||||
|
|
||||||
@ -26,6 +26,7 @@ TP 不依赖 Ebox 或 ECSS,不包含 selector、stylesheet、CSS cascade、Box
|
|||||||
```text
|
```text
|
||||||
tp-core
|
tp-core
|
||||||
├─ tp-style
|
├─ tp-style
|
||||||
|
├─ tp-transaction
|
||||||
│ └─ tp-reactive
|
│ └─ tp-reactive
|
||||||
│ └─ tp-surface
|
│ └─ tp-surface
|
||||||
├─ tp-layer
|
├─ tp-layer
|
||||||
@ -44,6 +45,7 @@ tp.el loads the public package surface
|
|||||||
| --- | --- | --- |
|
| --- | --- | --- |
|
||||||
| `tp-core.el` | canonical ranges/requests/results、interval traversal、plist/face merge、native property facts | runtime identity、reactivity、publication |
|
| `tp-core.el` | canonical ranges/requests/results、interval traversal、plist/face merge、native property facts | runtime identity、reactivity、publication |
|
||||||
| `tp-style.el` | native property policies、direct declarations、explicit computed source、projection | selector、stylesheet、specificity、CSS winner |
|
| `tp-style.el` | native property policies、direct declarations、explicit computed source、projection | selector、stylesheet、specificity、CSS winner |
|
||||||
|
| `tp-transaction.el` | structured batch/entry validators、one-shot states、opaque final-marker descriptors、tagged outcomes | live buffer writer、consumer semantics、parallel journals |
|
||||||
| `tp-reactive.el` | signals、bindings、dynamic dependency graph、scheduler、candidate source state、transaction participants | buffer scans、mount positions、layout impact |
|
| `tp-reactive.el` | signals、bindings、dynamic dependency graph、scheduler、candidate source state、transaction participants | buffer scans、mount positions、layout impact |
|
||||||
| `tp-surface.el` | prepare context、objects、plans、anchors、mount/index、contribution ledger、diff、publication、rollback、reports | stylesheet/cascade、consumer layout decisions |
|
| `tp-surface.el` | prepare context、objects、plans、anchors、mount/index、contribution ledger、diff、publication、rollback、reports | stylesheet/cascade、consumer layout decisions |
|
||||||
| `tp-layer.el` | `define-tp`/`define-tps` declaration recipes and registry | live layer stack、inline runtime metadata、watcher engine |
|
| `tp-layer.el` | `define-tp`/`define-tps` declaration recipes and registry | live layer stack、inline runtime metadata、watcher engine |
|
||||||
@ -180,6 +182,11 @@ An equal candidate produces no prepared publication. It preserves revision, repo
|
|||||||
|
|
||||||
The outer transaction owns candidate source values, dirty bindings, prepared surfaces, participants, inverse journals, view state, and final observer scheduling.
|
The outer transaction owns candidate source values, dirty bindings, prepared surfaces, participants, inverse journals, view state, and final observer scheduling.
|
||||||
|
|
||||||
|
The v2 contract uses those exact owners. It does not copy participant,
|
||||||
|
scheduler, snapshot, journal, or change-group state. The publication batch is
|
||||||
|
the sole writer and validates its canonical entries against the committed
|
||||||
|
property and revision state after commit or rollback.
|
||||||
|
|
||||||
```text
|
```text
|
||||||
freeze candidate writes
|
freeze candidate writes
|
||||||
→ recompute exact dependency closure
|
→ recompute exact dependency closure
|
||||||
@ -188,7 +195,11 @@ freeze candidate writes
|
|||||||
→ capture inverse journals
|
→ capture inverse journals
|
||||||
→ publish surfaces in stable id order
|
→ publish surfaces in stable id order
|
||||||
→ publish transaction participants
|
→ publish transaction participants
|
||||||
→ commit signals/bindings/surface state/revisions
|
→ run precommit validators
|
||||||
|
→ commit signals
|
||||||
|
→ apply bounded opaque final markers
|
||||||
|
→ invoke the single final accept
|
||||||
|
→ finalize tagged success evidence
|
||||||
→ run observers
|
→ run observers
|
||||||
```
|
```
|
||||||
|
|
||||||
@ -196,7 +207,16 @@ Content publication edits the minimal text span and then exact property runs. Pr
|
|||||||
|
|
||||||
Rollback restores text, properties, marker/index state, plans, producer, client state, signal values, binding values/dependencies, dirty queues, revisions and reports. Property journals are explicit because `atomic-change-group` alone does not cover every silent property mutation path.
|
Rollback restores text, properties, marker/index state, plans, producer, client state, signal values, binding values/dependencies, dirty queues, revisions and reports. Property journals are explicit because `atomic-change-group` alone does not cover every silent property mutation path.
|
||||||
|
|
||||||
`tp-transaction-participate` lets a consumer promote rollback-capable opaque state inside this boundary. Observers are different: they run only after the transaction commits, and observer failure is recorded rather than rolled back.
|
`tp-transaction-participate-v2` lets a consumer promote rollback-capable opaque state inside this boundary. Observers are different: they run only after the transaction commits, and observer failure is recorded rather than rolled back.
|
||||||
|
|
||||||
|
Each structured participant has one stable key, registration order, stage,
|
||||||
|
rollback, optional declared precommit, contained after-commit work, owner
|
||||||
|
journal, and one-shot state. Final markers are not
|
||||||
|
participants. TP treats their values as opaque and accepts only predeclared,
|
||||||
|
fixed-bound operations. M1a's closed `tp-vector-slots/v1` primitive accepts
|
||||||
|
only prebuilt vector-slot expectations and writes; marker registration cannot
|
||||||
|
inject callbacks. Partial apply or final-accept failure restores markers in
|
||||||
|
reverse order before the existing participant/surface/signal rollback.
|
||||||
|
|
||||||
If publication kills a target buffer, kill teardown is authoritative. Other surfaces and source state roll back; TP never recreates the killed buffer.
|
If publication kills a target buffer, kill teardown is authoritative. Other surfaces and source state roll back; TP never recreates the killed buffer.
|
||||||
|
|
||||||
|
|||||||
@ -160,6 +160,15 @@
|
|||||||
(should (= calls 2))
|
(should (= calls 2))
|
||||||
(should (= (plist-get (tp-reactive-counters) :recomputed) 1)))))
|
(should (= (plist-get (tp-reactive-counters) :recomputed) 1)))))
|
||||||
|
|
||||||
|
(ert-deftest tp-binding-test-public-transaction-state-follows-dynamic-extent ()
|
||||||
|
"The public transaction predicate is true only inside joined transactions."
|
||||||
|
(should-not (tp-transaction-active-p))
|
||||||
|
(tp-with-transaction
|
||||||
|
(should (tp-transaction-active-p))
|
||||||
|
(tp-with-transaction
|
||||||
|
(should (tp-transaction-active-p))))
|
||||||
|
(should-not (tp-transaction-active-p)))
|
||||||
|
|
||||||
(ert-deftest tp-binding-test-transaction-commits-signals-in-first-touch-order ()
|
(ert-deftest tp-binding-test-transaction-commits-signals-in-first-touch-order ()
|
||||||
"Touched signals commit once in first-touch order, including net reverts."
|
"Touched signals commit once in first-touch order, including net reverts."
|
||||||
(tp-binding-test--isolated
|
(tp-binding-test--isolated
|
||||||
@ -390,20 +399,20 @@
|
|||||||
(setq failure
|
(setq failure
|
||||||
(condition-case condition
|
(condition-case condition
|
||||||
(tp-with-transaction
|
(tp-with-transaction
|
||||||
(tp-transaction-participate
|
(tp-transaction-participate-v2
|
||||||
'first
|
:key 'first
|
||||||
(lambda ()
|
:stage (lambda ()
|
||||||
(push 'publish-first
|
(push 'publish-first
|
||||||
tp-binding-test-transaction-trace))
|
tp-binding-test-transaction-trace))
|
||||||
(lambda ()
|
:rollback (lambda ()
|
||||||
(push 'rollback-first
|
(push 'rollback-first
|
||||||
tp-binding-test-transaction-trace)))
|
tp-binding-test-transaction-trace)))
|
||||||
(tp-transaction-participate
|
(tp-transaction-participate-v2
|
||||||
'second
|
:key 'second
|
||||||
(lambda ()
|
:stage (lambda ()
|
||||||
(push 'publish-second
|
(push 'publish-second
|
||||||
tp-binding-test-transaction-trace))
|
tp-binding-test-transaction-trace))
|
||||||
(lambda ()
|
:rollback (lambda ()
|
||||||
(push 'rollback-second
|
(push 'rollback-second
|
||||||
tp-binding-test-transaction-trace)))
|
tp-binding-test-transaction-trace)))
|
||||||
(tp-signal-set signal 2))
|
(tp-signal-set signal 2))
|
||||||
@ -680,7 +689,8 @@
|
|||||||
(caller-vector (vector (copy-sequence "key")))
|
(caller-vector (vector (copy-sequence "key")))
|
||||||
(key (list 'test caller-string caller-vector)))
|
(key (list 'test caller-string caller-vector)))
|
||||||
(tp-with-transaction
|
(tp-with-transaction
|
||||||
(tp-transaction-participate key #'ignore #'ignore)
|
(tp-transaction-participate-v2
|
||||||
|
:key key :stage #'ignore :rollback #'ignore)
|
||||||
(let ((stored (tp--transaction-participant-key
|
(let ((stored (tp--transaction-participant-key
|
||||||
(car tp--transaction-participants))))
|
(car tp--transaction-participants))))
|
||||||
(should-not (eq (nth 1 stored) caller-string))
|
(should-not (eq (nth 1 stored) caller-string))
|
||||||
@ -692,8 +702,9 @@
|
|||||||
(should (equal (nth 1 stored) "participant"))
|
(should (equal (nth 1 stored) "participant"))
|
||||||
(should (equal (nth 2 stored) ["key"]))
|
(should (equal (nth 2 stored) ["key"]))
|
||||||
(should-error
|
(should-error
|
||||||
(tp-transaction-participate
|
(tp-transaction-participate-v2
|
||||||
(list 'test "participant" ["key"]) #'ignore #'ignore)
|
:key (list 'test "participant" ["key"])
|
||||||
|
:stage #'ignore :rollback #'ignore)
|
||||||
:type 'tp-reactive-error))))))
|
:type 'tp-reactive-error))))))
|
||||||
|
|
||||||
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()
|
(ert-deftest tp-binding-test-dirty-target-can-break-an-old-cycle-edge ()
|
||||||
|
|||||||
@ -161,6 +161,49 @@
|
|||||||
(should (equal (nth 0 copy) "value"))
|
(should (equal (nth 0 copy) "value"))
|
||||||
(should (equal (nth 1 copy) ["nested"])))))
|
(should (equal (nth 1 copy) ["nested"])))))
|
||||||
|
|
||||||
|
(ert-deftest tp-core-test-property-value-copy-isolates-full-keymaps ()
|
||||||
|
"Full keymaps, parent maps and self-references retain an isolated graph."
|
||||||
|
(let* ((map (make-keymap))
|
||||||
|
(parent (make-keymap))
|
||||||
|
(callback (lambda () "callback")))
|
||||||
|
(define-key map (kbd "RET") callback)
|
||||||
|
(define-key parent (kbd "x") #'ignore)
|
||||||
|
(define-key map [prefix] map)
|
||||||
|
(set-keymap-parent map parent)
|
||||||
|
(let ((copy (tp-property-value-copy map)))
|
||||||
|
(should-not (eq copy map))
|
||||||
|
(should-not (eq (keymap-parent copy) parent))
|
||||||
|
(should (eq (lookup-key copy [prefix]) copy))
|
||||||
|
(should (eq (lookup-key copy (kbd "RET")) callback))
|
||||||
|
(define-key map (kbd "RET") #'forward-char)
|
||||||
|
(define-key parent (kbd "x") #'backward-char)
|
||||||
|
(should (eq (lookup-key copy (kbd "RET")) callback))
|
||||||
|
(should (eq (lookup-key copy (kbd "x")) #'ignore)))))
|
||||||
|
|
||||||
|
(ert-deftest tp-core-test-property-value-copy-preserves-character-table-structure ()
|
||||||
|
"Local ranges, defaults, parents, extra slots and cycles are copied faithfully."
|
||||||
|
(let ((purpose (make-symbol "tp-copy-table")))
|
||||||
|
(put purpose 'char-table-extra-slots 1)
|
||||||
|
(let* ((parent (make-char-table purpose))
|
||||||
|
(table (make-char-table purpose))
|
||||||
|
(value (list 'value)))
|
||||||
|
(set-char-table-range parent ?p value)
|
||||||
|
(set-char-table-range table ?x value)
|
||||||
|
(set-char-table-range table ?s table)
|
||||||
|
(set-char-table-extra-slot table 0 value)
|
||||||
|
(set-char-table-parent table parent)
|
||||||
|
(let ((copy (tp-property-value-copy table)))
|
||||||
|
(should (eq (char-table-range copy ?s) copy))
|
||||||
|
(should (eq (char-table-range copy ?x) (char-table-extra-slot copy 0)))
|
||||||
|
(should (eq (char-table-range copy ?x)
|
||||||
|
(char-table-range (char-table-parent copy) ?p)))
|
||||||
|
(set-char-table-range (char-table-parent copy) ?p 'new)
|
||||||
|
(should (eq (char-table-range copy ?p) 'new))
|
||||||
|
(set-char-table-range copy nil 'default)
|
||||||
|
(should (eq (char-table-range copy ?z) 'default))
|
||||||
|
(setcar value 'mutated)
|
||||||
|
(should (equal (char-table-range copy ?x) '(value)))))))
|
||||||
|
|
||||||
(ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
|
(ert-deftest tp-core-test-property-value-copy-keeps-list-functions-opaque ()
|
||||||
"Property copies keep list-shaped function values opaque."
|
"Property copies keep list-shaped function values opaque."
|
||||||
(let ((function-value '(lambda () 1)))
|
(let ((function-value '(lambda () 1)))
|
||||||
|
|||||||
188
tests/tp-m0a-characterization-tests.el
Normal file
188
tests/tp-m0a-characterization-tests.el
Normal file
@ -0,0 +1,188 @@
|
|||||||
|
;;; tp-m0a-characterization-tests.el --- Current TP completion semantics -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2026 Geekinney
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Focused M0a characterization tests for completion semantics that are
|
||||||
|
;; already implemented. Future structured batches and final markers do not
|
||||||
|
;; belong in this baseline.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
(require 'ert)
|
||||||
|
(require 'tp-surface)
|
||||||
|
|
||||||
|
(define-error 'tp-m0a-characterization-error
|
||||||
|
"Injected TP M0a characterization failure")
|
||||||
|
|
||||||
|
(defvar tp-m0a-characterization--precommit-condition nil
|
||||||
|
"Condition injected by the M0a precommit test hook.")
|
||||||
|
|
||||||
|
(defun tp--m0a-characterization-precommit-inject ()
|
||||||
|
"Signal `tp-m0a-characterization--precommit-condition'."
|
||||||
|
(when tp-m0a-characterization--precommit-condition
|
||||||
|
(signal (car tp-m0a-characterization--precommit-condition)
|
||||||
|
(cdr tp-m0a-characterization--precommit-condition))))
|
||||||
|
|
||||||
|
(defun tp-m0a-characterization--leaf (text)
|
||||||
|
"Return a retained content leaf displaying TEXT."
|
||||||
|
(tp-surface-plan-create
|
||||||
|
:key 'root :kind 'text :text text :capability 'content))
|
||||||
|
|
||||||
|
(defun tp-m0a-characterization--producer (source)
|
||||||
|
"Return a retained content producer reading SOURCE."
|
||||||
|
(lambda (context)
|
||||||
|
(tp-object-ensure context nil 'root 'text)
|
||||||
|
(tp-m0a-characterization--leaf
|
||||||
|
(number-to-string (tp-signal-read source)))))
|
||||||
|
|
||||||
|
(defun tp-m0a-characterization--capture (function)
|
||||||
|
"Call FUNCTION and return its signaled condition."
|
||||||
|
(condition-case condition
|
||||||
|
(progn (funcall function) nil)
|
||||||
|
(tp-m0a-characterization-error condition)))
|
||||||
|
|
||||||
|
(cl-defmacro tp-m0a-characterization--with-surface
|
||||||
|
((buffer surface source) &rest body)
|
||||||
|
"Create BUFFER, SOURCE, and SURFACE, then evaluate BODY."
|
||||||
|
(declare (indent 1) (debug ((symbolp symbolp symbolp) body)))
|
||||||
|
`(let* ((,buffer (generate-new-buffer " *tp-m0a-characterization*"))
|
||||||
|
(,source (tp-signal-create 1))
|
||||||
|
(,surface
|
||||||
|
(tp-surface-mount
|
||||||
|
,buffer (tp-m0a-characterization--producer ,source)
|
||||||
|
'(:capability content))))
|
||||||
|
(unwind-protect
|
||||||
|
(progn ,@body)
|
||||||
|
(when (buffer-live-p ,buffer)
|
||||||
|
(kill-buffer ,buffer))
|
||||||
|
(when (tp-signal-live-p ,source)
|
||||||
|
(tp-signal-dispose ,source)))))
|
||||||
|
|
||||||
|
(ert-deftest tp-m0a-characterization-test-first-surface-failure-rolls-back-batch ()
|
||||||
|
"A first-surface failure restores every surface and the source state."
|
||||||
|
(let* ((source (tp-signal-create 1))
|
||||||
|
(producer (tp-m0a-characterization--producer source))
|
||||||
|
(first-buffer (generate-new-buffer " *tp-m0a-first*"))
|
||||||
|
(second-buffer (generate-new-buffer " *tp-m0a-second*"))
|
||||||
|
(first (tp-surface-mount
|
||||||
|
first-buffer producer '(:capability content)))
|
||||||
|
(second (tp-surface-mount
|
||||||
|
second-buffer producer '(:capability content)))
|
||||||
|
(first-revision (tp-surface-revision first))
|
||||||
|
(second-revision (tp-surface-revision second))
|
||||||
|
(injected '(tp-m0a-characterization-error
|
||||||
|
:phase first-surface :payload (1 2 3)))
|
||||||
|
(tp--surface-publication-step-function
|
||||||
|
(lambda (step surface)
|
||||||
|
(when (and (eq step 'client-state) (eq surface first))
|
||||||
|
(signal (car injected) (cdr injected))))))
|
||||||
|
(unwind-protect
|
||||||
|
(let ((failure
|
||||||
|
(tp-m0a-characterization--capture
|
||||||
|
(lambda () (tp-signal-set source 2)))))
|
||||||
|
(should (equal failure injected))
|
||||||
|
(should (= (tp-signal-peek source) 1))
|
||||||
|
(should (= (tp-signal-revision source) 0))
|
||||||
|
(should (= (tp-surface-revision first) first-revision))
|
||||||
|
(should (= (tp-surface-revision second) second-revision))
|
||||||
|
(with-current-buffer first-buffer
|
||||||
|
(should (equal (buffer-string) "1")))
|
||||||
|
(with-current-buffer second-buffer
|
||||||
|
(should (equal (buffer-string) "1"))))
|
||||||
|
(when (buffer-live-p first-buffer) (kill-buffer first-buffer))
|
||||||
|
(when (buffer-live-p second-buffer) (kill-buffer second-buffer))
|
||||||
|
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
|
||||||
|
|
||||||
|
(ert-deftest tp-m0a-characterization-test-participant-failure-preserves-condition ()
|
||||||
|
"A participant failure preserves raw condition data and restores all owners."
|
||||||
|
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||||
|
(let ((external 'old)
|
||||||
|
(revision (tp-surface-revision surface))
|
||||||
|
(injected '(tp-m0a-characterization-error
|
||||||
|
:phase participant :payload [raw data])))
|
||||||
|
(let ((failure
|
||||||
|
(tp-m0a-characterization--capture
|
||||||
|
(lambda ()
|
||||||
|
(tp-with-transaction
|
||||||
|
(tp-transaction-participate-v2
|
||||||
|
:key 'm0a-participant
|
||||||
|
:stage (lambda ()
|
||||||
|
(setq external 'candidate)
|
||||||
|
(signal (car injected) (cdr injected)))
|
||||||
|
:rollback (lambda () (setq external 'old)))
|
||||||
|
(tp-signal-set source 2))))))
|
||||||
|
(should (equal failure injected)))
|
||||||
|
(should (eq external 'old))
|
||||||
|
(should (= (tp-signal-peek source) 1))
|
||||||
|
(should (= (tp-signal-revision source) 0))
|
||||||
|
(should (= (tp-surface-revision surface) revision))
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(should (equal (buffer-string) "1"))))))
|
||||||
|
|
||||||
|
(ert-deftest tp-m0a-characterization-test-precommit-failure-preserves-condition ()
|
||||||
|
"A precommit failure preserves raw condition data and restores publication."
|
||||||
|
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||||
|
(let* ((revision (tp-surface-revision surface))
|
||||||
|
(injected '(tp-m0a-characterization-error
|
||||||
|
:phase precommit :payload (raw data)))
|
||||||
|
(tp--transaction-precommit-functions
|
||||||
|
'(tp--m0a-characterization-precommit-inject))
|
||||||
|
(tp--transaction-precommit-allowed-functions
|
||||||
|
'(tp--m0a-characterization-precommit-inject))
|
||||||
|
(tp-m0a-characterization--precommit-condition injected)
|
||||||
|
(failure
|
||||||
|
(tp-m0a-characterization--capture
|
||||||
|
(lambda () (tp-signal-set source 2)))))
|
||||||
|
(should (equal failure injected))
|
||||||
|
(should (= (tp-signal-peek source) 1))
|
||||||
|
(should (= (tp-signal-revision source) 0))
|
||||||
|
(should (= (tp-surface-revision surface) revision))
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(should (equal (buffer-string) "1"))))))
|
||||||
|
|
||||||
|
(ert-deftest tp-m0a-characterization-test-signal-commit-failure-preserves-condition ()
|
||||||
|
"A signal commit failure preserves raw condition data and restores publication."
|
||||||
|
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||||
|
(let ((revision (tp-surface-revision surface))
|
||||||
|
(injected '(tp-m0a-characterization-error
|
||||||
|
:phase signal :payload (:raw data)))
|
||||||
|
(original (symbol-function 'tp--commit-signal-entry)))
|
||||||
|
(let ((failure
|
||||||
|
(cl-letf (((symbol-function 'tp--commit-signal-entry)
|
||||||
|
(lambda (entry)
|
||||||
|
(funcall original entry)
|
||||||
|
(signal (car injected) (cdr injected)))))
|
||||||
|
(tp-m0a-characterization--capture
|
||||||
|
(lambda () (tp-signal-set source 2))))))
|
||||||
|
(should (equal failure injected)))
|
||||||
|
(should (= (tp-signal-peek source) 1))
|
||||||
|
(should (= (tp-signal-revision source) 0))
|
||||||
|
(should (= (tp-surface-revision surface) revision))
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(should (equal (buffer-string) "1"))))))
|
||||||
|
|
||||||
|
(ert-deftest tp-m0a-characterization-test-final-accept-failure-preserves-condition ()
|
||||||
|
"A final-accept failure preserves raw condition data and restores publication."
|
||||||
|
(tp-m0a-characterization--with-surface (buffer surface source)
|
||||||
|
(let ((revision (tp-surface-revision surface))
|
||||||
|
(injected '(tp-m0a-characterization-error
|
||||||
|
:phase final-accept :payload ((raw . data)))))
|
||||||
|
(let ((failure
|
||||||
|
(cl-letf (((symbol-function 'accept-change-group)
|
||||||
|
(lambda (_group)
|
||||||
|
(signal (car injected) (cdr injected)))))
|
||||||
|
(tp-m0a-characterization--capture
|
||||||
|
(lambda () (tp-signal-set source 2))))))
|
||||||
|
(should (equal failure injected)))
|
||||||
|
(should (= (tp-signal-peek source) 1))
|
||||||
|
(should (= (tp-signal-revision source) 0))
|
||||||
|
(should (= (tp-surface-revision surface) revision))
|
||||||
|
(with-current-buffer buffer
|
||||||
|
(should (equal (buffer-string) "1"))))))
|
||||||
|
|
||||||
|
(provide 'tp-m0a-characterization-tests)
|
||||||
|
|
||||||
|
;;; tp-m0a-characterization-tests.el ends here
|
||||||
@ -14,6 +14,46 @@
|
|||||||
(require 'tp-style)
|
(require 'tp-style)
|
||||||
(require 'tp-layer)
|
(require 'tp-layer)
|
||||||
|
|
||||||
|
(ert-deftest tp-style-test-native-keymaps-preserve-all-binding-facts ()
|
||||||
|
"Snapshots compare by prompts, menu order, parents and literal commands."
|
||||||
|
(let* ((factory (eval '(lambda ()
|
||||||
|
(let ((n 0))
|
||||||
|
(lambda () (setq n (1+ n))))) t))
|
||||||
|
(first (funcall factory)) (second (funcall factory))
|
||||||
|
(map (make-keymap "Root"))
|
||||||
|
(prefix (make-sparse-keymap "Prefix"))
|
||||||
|
(parent (make-sparse-keymap "Parent")))
|
||||||
|
(define-key map (kbd "RET") first)
|
||||||
|
(define-key map [t] #'ignore)
|
||||||
|
(define-key prefix [self] prefix)
|
||||||
|
(define-key prefix [one] '(menu-item "One" ignore))
|
||||||
|
(define-key prefix [two] '(menu-item "Two" forward-char))
|
||||||
|
(define-key map [prefix] prefix)
|
||||||
|
(define-key parent [inherited] #'backward-char)
|
||||||
|
(set-keymap-parent map parent)
|
||||||
|
(should (equal first second))
|
||||||
|
(should (tp--native-property-value-equal-p map (tp-property-value-copy map)))
|
||||||
|
(dolist (kind '(root-prompt prefix-prompt parent-prompt menu-order
|
||||||
|
callback default inherited))
|
||||||
|
(let ((copy (tp-property-value-copy map)))
|
||||||
|
(pcase kind
|
||||||
|
((or 'root-prompt 'prefix-prompt 'parent-prompt)
|
||||||
|
(let* ((target (pcase kind
|
||||||
|
('root-prompt copy)
|
||||||
|
('prefix-prompt (lookup-key copy [prefix]))
|
||||||
|
('parent-prompt (keymap-parent copy))))
|
||||||
|
(cell (memq (keymap-prompt target) target)))
|
||||||
|
(setcar cell "Changed")))
|
||||||
|
('menu-order
|
||||||
|
(let* ((target (lookup-key copy [prefix]))
|
||||||
|
(one (lookup-key target [one])))
|
||||||
|
(define-key target [one] nil t)
|
||||||
|
(define-key target [one] one)))
|
||||||
|
('callback (define-key copy (kbd "RET") second))
|
||||||
|
('default (define-key copy [t] #'forward-char))
|
||||||
|
('inherited (define-key (keymap-parent copy) [inherited] #'ignore)))
|
||||||
|
(should-not (tp--native-property-value-equal-p map copy))))))
|
||||||
|
|
||||||
(defmacro tp-style-test--isolated (&rest body)
|
(defmacro tp-style-test--isolated (&rest body)
|
||||||
"Run BODY with isolated TP property and named-style registries."
|
"Run BODY with isolated TP property and named-style registries."
|
||||||
(declare (indent 0) (debug t))
|
(declare (indent 0) (debug t))
|
||||||
|
|||||||
File diff suppressed because it is too large
Load Diff
1527
tests/tp-transaction-tests.el
Normal file
1527
tests/tp-transaction-tests.el
Normal file
File diff suppressed because it is too large
Load Diff
35
tp-core.el
35
tp-core.el
@ -279,6 +279,7 @@ Otherwise, START-OR-STRING and END define the range."
|
|||||||
(and (not (functionp value))
|
(and (not (functionp value))
|
||||||
(or (consp value)
|
(or (consp value)
|
||||||
(stringp value)
|
(stringp value)
|
||||||
|
(char-table-p value)
|
||||||
(and (vectorp value) (not (recordp value))))))
|
(and (vectorp value) (not (recordp value))))))
|
||||||
|
|
||||||
(defun tp--copy-cons-spine (value cache)
|
(defun tp--copy-cons-spine (value cache)
|
||||||
@ -309,6 +310,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology."
|
|||||||
(if (and (not (functionp item))
|
(if (and (not (functionp item))
|
||||||
(or (consp item)
|
(or (consp item)
|
||||||
(stringp item)
|
(stringp item)
|
||||||
|
(char-table-p item)
|
||||||
(and (vectorp item) (not (recordp item)))))
|
(and (vectorp item) (not (recordp item)))))
|
||||||
(tp--copy-property-value item cache)
|
(tp--copy-property-value item cache)
|
||||||
item)))
|
item)))
|
||||||
@ -323,6 +325,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology."
|
|||||||
|
|
||||||
(defun tp--copy-proper-cons-list (value cache)
|
(defun tp--copy-proper-cons-list (value cache)
|
||||||
"Return a fast memoized copy of uncached proper-list VALUE.
|
"Return a fast memoized copy of uncached proper-list VALUE.
|
||||||
|
CACHE preserves sharing and cycles across the copied value graph.
|
||||||
The whole spine is registered before mutable cars are copied, preserving
|
The whole spine is registered before mutable cars are copied, preserving
|
||||||
back-references from cars while `copy-sequence' supplies the spine cheaply."
|
back-references from cars while `copy-sequence' supplies the spine cheaply."
|
||||||
(let ((source value)
|
(let ((source value)
|
||||||
@ -343,6 +346,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
|
|||||||
(when (and (not (functionp item))
|
(when (and (not (functionp item))
|
||||||
(or (consp item)
|
(or (consp item)
|
||||||
(stringp item)
|
(stringp item)
|
||||||
|
(char-table-p item)
|
||||||
(and (vectorp item) (not (recordp item)))))
|
(and (vectorp item) (not (recordp item)))))
|
||||||
(setcar target (tp--copy-property-value item cache))))
|
(setcar target (tp--copy-property-value item cache))))
|
||||||
(setq source (cdr source)
|
(setq source (cdr source)
|
||||||
@ -352,6 +356,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply."
|
|||||||
(defun tp--copy-string-with-properties
|
(defun tp--copy-string-with-properties
|
||||||
(value &optional cache reuse-property-p)
|
(value &optional cache reuse-property-p)
|
||||||
"Return a copy of string VALUE with recursively copied property values.
|
"Return a copy of string VALUE with recursively copied property values.
|
||||||
|
CACHE preserves sharing across mutable property values.
|
||||||
REUSE-PROPERTY-P, when non-nil, is called with PROPERTY and VALUE. A non-nil
|
REUSE-PROPERTY-P, when non-nil, is called with PROPERTY and VALUE. A non-nil
|
||||||
result transfers that exact candidate-owned VALUE into the returned string;
|
result transfers that exact candidate-owned VALUE into the returned string;
|
||||||
the caller must ensure that VALUE is not mutated by another owner. Values not
|
the caller must ensure that VALUE is not mutated by another owner. Values not
|
||||||
@ -403,7 +408,9 @@ values are recursively isolated."
|
|||||||
|
|
||||||
(defun tp--copy-property-value (value &optional cache)
|
(defun tp--copy-property-value (value &optional cache)
|
||||||
"Return a defensive copy of mutable containers in property VALUE.
|
"Return a defensive copy of mutable containers in property VALUE.
|
||||||
Cons cells, strings, and vectors are copied recursively. Functions, records,
|
Optional CACHE preserves sharing and cycles across recursive copies.
|
||||||
|
Cons cells, strings, vectors and character tables are copied recursively.
|
||||||
|
Functions, records,
|
||||||
and other opaque objects keep their identity; functions are never executed."
|
and other opaque objects keep their identity; functions are never executed."
|
||||||
(if (not (tp--copy-mutable-property-value-p value))
|
(if (not (tp--copy-mutable-property-value-p value))
|
||||||
value
|
value
|
||||||
@ -417,6 +424,29 @@ and other opaque objects keep their identity; functions are never executed."
|
|||||||
(tp--copy-proper-cons-list value cache)
|
(tp--copy-proper-cons-list value cache)
|
||||||
(tp--copy-cons-spine value cache)))
|
(tp--copy-cons-spine value cache)))
|
||||||
((stringp value) (tp--copy-string-with-properties value cache))
|
((stringp value) (tp--copy-string-with-properties value cache))
|
||||||
|
((char-table-p value)
|
||||||
|
(let ((copy (copy-sequence value))
|
||||||
|
(default (char-table-range value nil))
|
||||||
|
entries)
|
||||||
|
(puthash value copy cache)
|
||||||
|
;; Enumerate only local assignments, without inherited/default
|
||||||
|
;; ranges becoming explicit assignments in the copied table.
|
||||||
|
(set-char-table-parent copy nil)
|
||||||
|
(set-char-table-range copy nil nil)
|
||||||
|
(map-char-table (lambda (range item) (push (cons range item) entries))
|
||||||
|
copy)
|
||||||
|
(dolist (entry entries)
|
||||||
|
(set-char-table-range
|
||||||
|
copy (car entry) (tp--copy-property-value (cdr entry) cache)))
|
||||||
|
(set-char-table-range copy nil (tp--copy-property-value default cache))
|
||||||
|
(set-char-table-parent
|
||||||
|
copy (tp--copy-property-value (char-table-parent value) cache))
|
||||||
|
(dotimes (index (or (get (char-table-subtype value)
|
||||||
|
'char-table-extra-slots) 0))
|
||||||
|
(set-char-table-extra-slot
|
||||||
|
copy index (tp--copy-property-value
|
||||||
|
(char-table-extra-slot value index) cache)))
|
||||||
|
copy))
|
||||||
((vectorp value)
|
((vectorp value)
|
||||||
(let ((copy (copy-sequence value)))
|
(let ((copy (copy-sequence value)))
|
||||||
(puthash value copy cache)
|
(puthash value copy cache)
|
||||||
@ -428,7 +458,8 @@ and other opaque objects keep their identity; functions are never executed."
|
|||||||
(defun tp-property-value-copy (value)
|
(defun tp-property-value-copy (value)
|
||||||
"Return a defensive copy of mutable text-property VALUE.
|
"Return a defensive copy of mutable text-property VALUE.
|
||||||
Functions, records, and other opaque identities are retained; mutable cons,
|
Functions, records, and other opaque identities are retained; mutable cons,
|
||||||
string, and non-record vector graphs are copied with sharing and cycles intact."
|
string, character-table and non-record vector graphs are copied with sharing
|
||||||
|
and cycles intact."
|
||||||
(tp--copy-property-value value (make-hash-table :test #'eq)))
|
(tp--copy-property-value value (make-hash-table :test #'eq)))
|
||||||
|
|
||||||
(defun tp--deep-merge-plist (base new)
|
(defun tp--deep-merge-plist (base new)
|
||||||
|
|||||||
651
tp-reactive.el
651
tp-reactive.el
@ -11,13 +11,14 @@
|
|||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
|
|
||||||
;; TP 1.0's exact signal-to-binding dependency graph, transaction-local
|
;; TP 2.0's exact signal-to-binding dependency graph, transaction-local
|
||||||
;; scheduler, scoped variable adapters, and rollback state.
|
;; scheduler, scoped variable adapters, and rollback state.
|
||||||
|
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(require 'cl-lib)
|
(require 'cl-lib)
|
||||||
(require 'tp-core)
|
(require 'tp-core)
|
||||||
|
(require 'tp-transaction)
|
||||||
|
|
||||||
(define-error 'tp-reactive-error "TP reactive runtime error")
|
(define-error 'tp-reactive-error "TP reactive runtime error")
|
||||||
(define-error 'tp-invalid-signal-scope "Invalid TP signal scope"
|
(define-error 'tp-invalid-signal-scope "Invalid TP signal scope"
|
||||||
@ -43,8 +44,8 @@
|
|||||||
|
|
||||||
(cl-defstruct (tp--transaction-participant
|
(cl-defstruct (tp--transaction-participant
|
||||||
(:constructor tp--make-transaction-participant))
|
(:constructor tp--make-transaction-participant))
|
||||||
"One rollback-capable side-state participant in a TP transaction."
|
"One structured transaction participant."
|
||||||
key publish rollback)
|
key rollback protocol order stage precommit after-commit journal state)
|
||||||
|
|
||||||
(cl-defstruct (tp--signal-commit-entry
|
(cl-defstruct (tp--signal-commit-entry
|
||||||
(:constructor tp--make-signal-commit-entry))
|
(:constructor tp--make-signal-commit-entry))
|
||||||
@ -68,6 +69,11 @@
|
|||||||
:subscription-added 0 :subscription-removed 0))
|
:subscription-added 0 :subscription-removed 0))
|
||||||
|
|
||||||
(defvar tp--transaction-active nil)
|
(defvar tp--transaction-active nil)
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun tp-transaction-active-p ()
|
||||||
|
"Return non-nil while the current dynamic extent is in a TP transaction."
|
||||||
|
(and tp--transaction-active t))
|
||||||
(defvar tp--transaction-signal-values nil)
|
(defvar tp--transaction-signal-values nil)
|
||||||
(defvar tp--transaction-signals nil)
|
(defvar tp--transaction-signals nil)
|
||||||
(defvar tp--transaction-dirty-set nil)
|
(defvar tp--transaction-dirty-set nil)
|
||||||
@ -80,10 +86,28 @@
|
|||||||
(defvar tp--transaction-after-commit-callbacks nil)
|
(defvar tp--transaction-after-commit-callbacks nil)
|
||||||
(defvar tp--transaction-participants nil)
|
(defvar tp--transaction-participants nil)
|
||||||
(defvar tp--transaction-participant-keys nil)
|
(defvar tp--transaction-participant-keys nil)
|
||||||
|
(defvar tp--transaction-participant-order 0)
|
||||||
(defvar tp--transaction-published-participants nil)
|
(defvar tp--transaction-published-participants nil)
|
||||||
(defvar tp--transaction-signal-commit-journal nil)
|
(defvar tp--transaction-signal-commit-journal nil)
|
||||||
|
(defvar tp--transaction-id nil)
|
||||||
|
(defvar tp--transaction-phase nil)
|
||||||
|
(defvar tp--transaction-phase-start nil)
|
||||||
|
(defvar tp--transaction-phase-timings nil)
|
||||||
|
(defvar tp--transaction-publication-batch nil)
|
||||||
|
(defvar tp--transaction-structured-participants nil)
|
||||||
|
(defvar tp--transaction-final-marker-registry nil)
|
||||||
|
(defvar tp--transaction-final-marker-owner-keys nil)
|
||||||
|
(defvar tp--transaction-final-marker-count 0)
|
||||||
|
(defvar tp--transaction-final-marker-slot-writes 0)
|
||||||
|
(defvar tp--transaction-final-markers-frozen-p nil)
|
||||||
|
(defvar tp--transaction-applied-final-marker-count 0)
|
||||||
|
(defvar tp--transaction-marker-restore-failures nil)
|
||||||
|
(defvar tp--transaction-outcome nil)
|
||||||
|
(defvar tp--transaction-outcome-cell nil)
|
||||||
(defvar tp--transaction-contained-failures nil)
|
(defvar tp--transaction-contained-failures nil)
|
||||||
(defvar tp--last-transaction-diagnostics nil)
|
(defvar tp--last-transaction-diagnostics nil)
|
||||||
|
(defvar tp--last-transaction-outcome nil)
|
||||||
|
(defvar tp--last-shadow-proof nil)
|
||||||
(defvar tp--current-binding nil)
|
(defvar tp--current-binding nil)
|
||||||
(defvar tp--binding-compute-stack nil)
|
(defvar tp--binding-compute-stack nil)
|
||||||
(defvar tp--collected-dependency-set nil)
|
(defvar tp--collected-dependency-set nil)
|
||||||
@ -103,6 +127,9 @@
|
|||||||
(defvar tp--transaction-rollback-final-functions nil)
|
(defvar tp--transaction-rollback-final-functions nil)
|
||||||
(defvar tp--transaction-committed-functions nil)
|
(defvar tp--transaction-committed-functions nil)
|
||||||
|
|
||||||
|
(defvar tp--transaction-participant-precommit-allowed-functions nil
|
||||||
|
"Declared internal structured-participant precommit validators.")
|
||||||
|
|
||||||
(defconst tp--transaction-condition-trailer-tag
|
(defconst tp--transaction-condition-trailer-tag
|
||||||
(make-symbol "tp--transaction-condition-trailer")
|
(make-symbol "tp--transaction-condition-trailer")
|
||||||
"Unforgeable tag separating primary condition data from TP metadata.")
|
"Unforgeable tag separating primary condition data from TP metadata.")
|
||||||
@ -492,7 +519,8 @@ or `retain'."
|
|||||||
|
|
||||||
(defun tp--bind-precomputed-in-transaction
|
(defun tp--bind-precomputed-in-transaction
|
||||||
(owner key compute value dependencies equality lifecycle)
|
(owner key compute value dependencies equality lifecycle)
|
||||||
"Install one new initialized binding with explicit DEPENDENCIES."
|
"Install OWNER's KEY using COMPUTE, VALUE, and explicit DEPENDENCIES.
|
||||||
|
EQUALITY controls change detection and LIFECYCLE controls candidate omission."
|
||||||
(let ((table (tp--owner-binding-table owner t)))
|
(let ((table (tp--owner-binding-table owner t)))
|
||||||
(when (gethash key table)
|
(when (gethash key table)
|
||||||
(signal 'tp-reactive-error (list :precomputed-binding-exists key)))
|
(signal 'tp-reactive-error (list :precomputed-binding-exists key)))
|
||||||
@ -521,6 +549,8 @@ or `retain'."
|
|||||||
(owner key compute value dependencies
|
(owner key compute value dependencies
|
||||||
&key (equality #'equal) (lifecycle 'delete))
|
&key (equality #'equal) (lifecycle 'delete))
|
||||||
"Install a new binding with precomputed VALUE and explicit DEPENDENCIES.
|
"Install a new binding with precomputed VALUE and explicit DEPENDENCIES.
|
||||||
|
OWNER and KEY identify the binding; EQUALITY and LIFECYCLE retain their normal
|
||||||
|
`tp-bind' meanings.
|
||||||
COMPUTE remains the authoritative recomputation function after any dependency
|
COMPUTE remains the authoritative recomputation function after any dependency
|
||||||
changes. This entry avoids evaluating COMPUTE merely to rediscover a value
|
changes. This entry avoids evaluating COMPUTE merely to rediscover a value
|
||||||
and graph edges already produced by a compiler or pure projection pass."
|
and graph edges already produced by a compiler or pure projection pass."
|
||||||
@ -619,50 +649,159 @@ When CREATE is non-nil, install and return a fresh hash table when absent."
|
|||||||
(signal 'tp-reactive-error (list :outside-transaction function)))
|
(signal 'tp-reactive-error (list :outside-transaction function)))
|
||||||
(push function tp--transaction-after-commit-callbacks))
|
(push function tp--transaction-after-commit-callbacks))
|
||||||
|
|
||||||
;;;###autoload
|
(defun tp--transaction-participant-precommit-function-p (function)
|
||||||
(defun tp-transaction-participate (key publish rollback)
|
"Return non-nil when FUNCTION is a declared internal participant validator."
|
||||||
"Register rollback-capable PUBLISH work under transaction-local KEY.
|
(or (null function)
|
||||||
PUBLISH runs after every affected surface has published its candidate buffer
|
(and (symbolp function)
|
||||||
and side state, but before the transaction commits its source values. If this
|
(memq function
|
||||||
or any later publication step fails, ROLLBACK runs in reverse publication
|
tp--transaction-participant-precommit-allowed-functions)
|
||||||
order. Both functions take no arguments. KEY must be unique in the outer
|
(fboundp function))))
|
||||||
transaction."
|
|
||||||
|
(defun tp--transaction-register-participant (participant)
|
||||||
|
"Register structured PARTICIPANT once in the active transaction."
|
||||||
|
(unless tp--transaction-active
|
||||||
|
(signal 'tp-reactive-error
|
||||||
|
(list :participant-outside-transaction
|
||||||
|
(tp--transaction-participant-key participant))))
|
||||||
|
(let ((key (tp--transaction-participant-key participant)))
|
||||||
|
(unless key
|
||||||
|
(signal 'tp-reactive-error (list :participant-key key)))
|
||||||
|
(when (member key tp--transaction-participant-keys)
|
||||||
|
(signal 'tp-reactive-error (list :duplicate-participant-key key)))
|
||||||
|
(push (tp--copy-property-value key) tp--transaction-participant-keys)
|
||||||
|
(push participant tp--transaction-participants)
|
||||||
|
participant))
|
||||||
|
|
||||||
|
(defun tp--transaction-make-participant
|
||||||
|
(key stage rollback protocol precommit after-commit journal)
|
||||||
|
"Build a participant from KEY, STAGE, ROLLBACK, and PROTOCOL.
|
||||||
|
PRECOMMIT and AFTER-COMMIT are optional internal callbacks; JOURNAL is opaque
|
||||||
|
owner-local rollback state."
|
||||||
|
(unless (functionp stage)
|
||||||
|
(signal 'wrong-type-argument (list 'functionp stage)))
|
||||||
|
(unless (functionp rollback)
|
||||||
|
(signal 'wrong-type-argument (list 'functionp rollback)))
|
||||||
|
(unless (tp--transaction-participant-precommit-function-p precommit)
|
||||||
|
(signal 'tp-reactive-error
|
||||||
|
(list :invalid-participant-precommit precommit)))
|
||||||
|
(unless (or (null after-commit) (functionp after-commit))
|
||||||
|
(signal 'wrong-type-argument (list 'functionp after-commit)))
|
||||||
|
(tp--make-transaction-participant
|
||||||
|
:key (tp--copy-property-value key)
|
||||||
|
:rollback rollback
|
||||||
|
:protocol protocol
|
||||||
|
:order (prog1 tp--transaction-participant-order
|
||||||
|
(cl-incf tp--transaction-participant-order))
|
||||||
|
:stage stage
|
||||||
|
:precommit precommit
|
||||||
|
:after-commit after-commit
|
||||||
|
:journal journal
|
||||||
|
:state 'prepared))
|
||||||
|
|
||||||
|
(cl-defun tp--transaction-participate-v2
|
||||||
|
(&key key stage rollback precommit after-commit journal)
|
||||||
|
"Register internal KEY with structured STAGE and ROLLBACK capabilities.
|
||||||
|
PRECOMMIT and AFTER-COMMIT are optional declared callbacks. JOURNAL is the
|
||||||
|
participant's opaque owner-local state."
|
||||||
(unless tp--transaction-active
|
(unless tp--transaction-active
|
||||||
(signal 'tp-reactive-error (list :participant-outside-transaction key)))
|
(signal 'tp-reactive-error (list :participant-outside-transaction key)))
|
||||||
(unless key
|
(unless key
|
||||||
(signal 'tp-reactive-error (list :participant-key key)))
|
(signal 'tp-reactive-error (list :participant-key key)))
|
||||||
(unless (functionp publish)
|
(tp--transaction-register-participant
|
||||||
(signal 'wrong-type-argument (list 'functionp publish)))
|
(tp--transaction-make-participant
|
||||||
(unless (functionp rollback)
|
key stage rollback 'v2 precommit after-commit journal)))
|
||||||
(signal 'wrong-type-argument (list 'functionp rollback)))
|
|
||||||
(when (member key tp--transaction-participant-keys)
|
;;;###autoload
|
||||||
(signal 'tp-reactive-error (list :duplicate-participant-key key)))
|
(cl-defun tp-transaction-participate-v2
|
||||||
(push (tp--copy-property-value key) tp--transaction-participant-keys)
|
(&key key stage rollback precommit after-commit journal)
|
||||||
(push (tp--make-transaction-participant
|
"Register a structured rollback-capable participant under KEY.
|
||||||
:key (tp--copy-property-value key)
|
STAGE and ROLLBACK are required no-argument functions. PRECOMMIT may be one
|
||||||
:publish publish :rollback rollback)
|
declared package-owned validator; AFTER-COMMIT is contained work queued only
|
||||||
tp--transaction-participants)
|
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)
|
key)
|
||||||
|
|
||||||
(defun tp--publish-transaction-participants ()
|
(defun tp--transaction-participants-in-registration-order ()
|
||||||
"Publish registered transaction participants in declaration order."
|
"Return the authoritative participants in deterministic declaration order."
|
||||||
(dolist (participant (nreverse tp--transaction-participants))
|
(reverse tp--transaction-participants))
|
||||||
|
|
||||||
|
(defun tp--transaction-validate-structured-participants ()
|
||||||
|
"Return the frozen participant vector after exact identity validation."
|
||||||
|
(let* ((participants tp--transaction-structured-participants)
|
||||||
|
(registered (tp--transaction-participants-in-registration-order))
|
||||||
|
(count (length registered)))
|
||||||
|
(unless (and (vectorp participants) (= (length participants) count))
|
||||||
|
(signal 'tp-publication-binding-error
|
||||||
|
(list :participant-count participants registered)))
|
||||||
|
(cl-loop for participant in registered
|
||||||
|
for index from 0
|
||||||
|
unless (eq participant (aref participants index))
|
||||||
|
do (signal 'tp-publication-binding-error
|
||||||
|
(list :participant-order index participant
|
||||||
|
(aref participants index))))
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(let ((candidate-participants
|
||||||
|
(tp-publication-batch-candidate-participants
|
||||||
|
tp--transaction-publication-batch)))
|
||||||
|
(unless (eq candidate-participants participants)
|
||||||
|
(signal 'tp-publication-binding-error
|
||||||
|
(list :participant-vector candidate-participants
|
||||||
|
participants)))))
|
||||||
|
participants))
|
||||||
|
|
||||||
|
(defun tp--stage-structured-transaction-participants ()
|
||||||
|
"Stage the frozen structured participant vector in declaration order."
|
||||||
|
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||||
|
(dotimes (index (length participants))
|
||||||
|
(let ((participant (aref participants index)))
|
||||||
(push participant tp--transaction-published-participants)
|
(push participant tp--transaction-published-participants)
|
||||||
(funcall (tp--transaction-participant-publish participant))))
|
(setf (tp--transaction-participant-state participant) 'staged)
|
||||||
|
(funcall (tp--transaction-participant-stage participant))))))
|
||||||
|
|
||||||
(defun tp--rollback-transaction-participants ()
|
(defun tp--rollback-transaction-participants ()
|
||||||
"Rollback published participants and return any failures."
|
"Rollback published participants and return any failures."
|
||||||
(let (failures)
|
(let (failures)
|
||||||
(dolist (participant tp--transaction-published-participants)
|
(dolist (participant tp--transaction-published-participants)
|
||||||
|
(unwind-protect
|
||||||
(condition-case failure
|
(condition-case failure
|
||||||
(funcall (tp--transaction-participant-rollback participant))
|
(funcall (tp--transaction-participant-rollback participant))
|
||||||
((error quit)
|
((error quit)
|
||||||
(push (list 'participants
|
(push (list 'participants
|
||||||
(tp--transaction-participant-key participant)
|
(tp--transaction-participant-key participant)
|
||||||
failure)
|
failure)
|
||||||
failures))))
|
failures)))
|
||||||
|
(setf (tp--transaction-participant-state participant) 'rolled-back)))
|
||||||
|
(dolist (participant tp--transaction-participants)
|
||||||
|
(when (eq (tp--transaction-participant-state participant) 'prepared)
|
||||||
|
(setf (tp--transaction-participant-state participant) 'rolled-back)))
|
||||||
(nreverse failures)))
|
(nreverse failures)))
|
||||||
|
|
||||||
|
(defun tp--run-structured-transaction-participant-precommits ()
|
||||||
|
"Run validators from the frozen structured participant vector."
|
||||||
|
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||||
|
(dotimes (index (length participants))
|
||||||
|
(when-let* ((function
|
||||||
|
(tp--transaction-participant-precommit
|
||||||
|
(aref participants index))))
|
||||||
|
(unless (tp--transaction-participant-precommit-function-p function)
|
||||||
|
(signal 'tp-reactive-error
|
||||||
|
(list :invalid-participant-precommit function)))
|
||||||
|
(funcall function)))))
|
||||||
|
|
||||||
|
(defun tp--commit-structured-transaction-participants ()
|
||||||
|
"Commit states from the frozen structured participant vector."
|
||||||
|
(let ((participants (tp--transaction-validate-structured-participants)))
|
||||||
|
(dotimes (index (length participants))
|
||||||
|
(let ((participant (aref participants index)))
|
||||||
|
(when (eq (tp--transaction-participant-state participant) 'staged)
|
||||||
|
(setf (tp--transaction-participant-state participant) 'committed)
|
||||||
|
(when-let* ((function
|
||||||
|
(tp--transaction-participant-after-commit participant)))
|
||||||
|
(tp--enqueue-after-commit function)))))))
|
||||||
|
|
||||||
(defun tp--dequeue-dirty-binding ()
|
(defun tp--dequeue-dirty-binding ()
|
||||||
"Return and remove the next queued dirty binding."
|
"Return and remove the next queued dirty binding."
|
||||||
(let (binding)
|
(let (binding)
|
||||||
@ -749,6 +888,409 @@ transaction."
|
|||||||
tp--transaction-final-accept-function function)))
|
tp--transaction-final-accept-function function)))
|
||||||
(setq tp--transaction-final-accept-function function))
|
(setq tp--transaction-final-accept-function function))
|
||||||
|
|
||||||
|
(defun tp--transaction-current-outcome-cell ()
|
||||||
|
"Return the active transaction's caller-retainable one-slot outcome cell."
|
||||||
|
(unless tp--transaction-active
|
||||||
|
(signal 'tp-reactive-error (list :outcome-cell-outside-transaction)))
|
||||||
|
tp--transaction-outcome-cell)
|
||||||
|
|
||||||
|
(defun tp--transaction-enter-phase (phase)
|
||||||
|
"Record the completed phase duration and enter PHASE."
|
||||||
|
(let ((now (float-time)))
|
||||||
|
(when (and tp--transaction-phase tp--transaction-phase-start)
|
||||||
|
(push (cons tp--transaction-phase
|
||||||
|
(- now tp--transaction-phase-start))
|
||||||
|
tp--transaction-phase-timings))
|
||||||
|
(setq tp--transaction-phase phase
|
||||||
|
tp--transaction-phase-start now)))
|
||||||
|
|
||||||
|
(defun tp--transaction-publish-outcome (outcome)
|
||||||
|
"Publish internal OUTCOME without changing the public transaction return."
|
||||||
|
(setq tp--transaction-outcome outcome
|
||||||
|
tp--last-transaction-outcome outcome)
|
||||||
|
(when (vectorp tp--transaction-outcome-cell)
|
||||||
|
(aset tp--transaction-outcome-cell 0 outcome))
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(setf (tp-publication-batch-candidate-outcome
|
||||||
|
tp--transaction-publication-batch)
|
||||||
|
outcome))
|
||||||
|
outcome)
|
||||||
|
|
||||||
|
(defun tp--transaction-batch-journal-view (surface-journals)
|
||||||
|
"Return a fixed view vector over current journals and SURFACE-JOURNALS."
|
||||||
|
(vector tp--transaction-extensions
|
||||||
|
tp--transaction-signal-values
|
||||||
|
tp--transaction-binding-snapshots
|
||||||
|
tp--transaction-counter-start
|
||||||
|
tp--transaction-signal-commit-journal
|
||||||
|
surface-journals))
|
||||||
|
|
||||||
|
(defun tp--transaction-begin-publication-batch
|
||||||
|
(batch-id entries surface-journals stage-entries)
|
||||||
|
"Install BATCH-ID for ENTRIES, SURFACE-JOURNALS, and STAGE-ENTRIES."
|
||||||
|
(unless tp--transaction-active
|
||||||
|
(signal 'tp-reactive-error (list :batch-outside-transaction batch-id)))
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(signal 'tp-publication-state-error
|
||||||
|
(list :duplicate-transaction-batch batch-id)))
|
||||||
|
(setq tp--transaction-publication-batch
|
||||||
|
(tp--publication-batch-prepare
|
||||||
|
:transaction-id tp--transaction-id
|
||||||
|
:batch-id batch-id
|
||||||
|
:entries entries
|
||||||
|
:participants
|
||||||
|
tp--transaction-structured-participants
|
||||||
|
:journals (tp--transaction-batch-journal-view surface-journals)
|
||||||
|
:stage-entries stage-entries
|
||||||
|
:final-accept tp--transaction-final-accept-function
|
||||||
|
:diagnostics nil))
|
||||||
|
tp--transaction-publication-batch)
|
||||||
|
|
||||||
|
(defun tp--transaction-batch-transition (next)
|
||||||
|
"Move the active publication candidate to NEXT when one exists."
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(tp--publication-batch-transition
|
||||||
|
tp--transaction-publication-batch next)))
|
||||||
|
|
||||||
|
(cl-defun tp--transaction-register-final-marker
|
||||||
|
(&key owner-key expected-token expected-version next-values inverse-values
|
||||||
|
slot-write-count operation-key)
|
||||||
|
"Register a bounded opaque marker for OWNER-KEY before precommit.
|
||||||
|
EXPECTED-TOKEN and EXPECTED-VERSION bind owner state. NEXT-VALUES and
|
||||||
|
INVERSE-VALUES are prebuilt opaque payloads. SLOT-WRITE-COUNT is checked
|
||||||
|
against the trusted OPERATION-KEY descriptor and the transaction bound."
|
||||||
|
(unless (and tp--transaction-active
|
||||||
|
(memq tp--transaction-phase
|
||||||
|
'(body recompute publication participants))
|
||||||
|
(not tp--transaction-final-markers-frozen-p))
|
||||||
|
(signal 'tp-final-marker-error
|
||||||
|
(list :registration-phase tp--transaction-phase)))
|
||||||
|
(when (>= tp--transaction-final-marker-count tp--final-marker-max-count)
|
||||||
|
(signal 'tp-final-marker-error
|
||||||
|
(list :marker-count tp--transaction-final-marker-count)))
|
||||||
|
(let ((duplicate nil))
|
||||||
|
(dotimes (index tp--transaction-final-marker-count)
|
||||||
|
(when (equal owner-key
|
||||||
|
(aref tp--transaction-final-marker-owner-keys index))
|
||||||
|
(setq duplicate t)))
|
||||||
|
(when duplicate
|
||||||
|
(signal 'tp-final-marker-error (list :duplicate-owner-key owner-key))))
|
||||||
|
(let ((marker
|
||||||
|
(tp--final-accept-marker-create
|
||||||
|
:owner-key owner-key
|
||||||
|
:expected-token expected-token
|
||||||
|
:expected-version expected-version
|
||||||
|
:next-values next-values
|
||||||
|
:inverse-values inverse-values
|
||||||
|
:slot-write-count slot-write-count
|
||||||
|
:operation-key operation-key)))
|
||||||
|
(when (> (+ tp--transaction-final-marker-slot-writes slot-write-count)
|
||||||
|
tp--final-marker-max-slot-writes)
|
||||||
|
(signal 'tp-final-marker-error
|
||||||
|
(list :slot-write-bound
|
||||||
|
tp--transaction-final-marker-slot-writes
|
||||||
|
slot-write-count)))
|
||||||
|
(aset tp--transaction-final-marker-registry
|
||||||
|
tp--transaction-final-marker-count marker)
|
||||||
|
(aset tp--transaction-final-marker-owner-keys
|
||||||
|
tp--transaction-final-marker-count
|
||||||
|
(tp--copy-property-value owner-key))
|
||||||
|
(cl-incf tp--transaction-final-marker-count)
|
||||||
|
(cl-incf tp--transaction-final-marker-slot-writes slot-write-count)
|
||||||
|
marker))
|
||||||
|
|
||||||
|
(cl-defun tp-transaction-register-final-marker
|
||||||
|
(&key owner-key expected-token expected-version next-values inverse-values
|
||||||
|
slot-write-count operation-key)
|
||||||
|
"Register one bounded final-accept authority marker.
|
||||||
|
OWNER-KEY must be unique in the active transaction. EXPECTED-TOKEN and
|
||||||
|
EXPECTED-VERSION bind owner state; NEXT-VALUES and INVERSE-VALUES are prebuilt
|
||||||
|
slot-write vectors with fixed SLOT-WRITE-COUNT. OPERATION-KEY must resolve
|
||||||
|
through TP's closed marker-operation whitelist."
|
||||||
|
(tp--transaction-register-final-marker
|
||||||
|
:owner-key owner-key
|
||||||
|
:expected-token expected-token
|
||||||
|
:expected-version expected-version
|
||||||
|
:next-values next-values
|
||||||
|
:inverse-values inverse-values
|
||||||
|
:slot-write-count slot-write-count
|
||||||
|
:operation-key operation-key))
|
||||||
|
|
||||||
|
(defun tp--transaction-freeze-final-markers ()
|
||||||
|
"Validate and seal every marker before signal commit and final accept."
|
||||||
|
(when (and (> tp--transaction-final-marker-count 0)
|
||||||
|
(null tp--transaction-publication-batch))
|
||||||
|
(signal 'tp-final-marker-error (list :marker-without-publication-batch)))
|
||||||
|
(dotimes (index tp--transaction-final-marker-count)
|
||||||
|
(tp--final-accept-marker-validate
|
||||||
|
(aref tp--transaction-final-marker-registry index)))
|
||||||
|
(setq tp--transaction-final-markers-frozen-p t)
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(setf (tp-publication-batch-candidate-markers
|
||||||
|
tp--transaction-publication-batch)
|
||||||
|
(cons tp--transaction-final-marker-registry
|
||||||
|
tp--transaction-final-marker-count)))
|
||||||
|
tp--transaction-final-marker-count)
|
||||||
|
|
||||||
|
(defun tp--transaction-sync-publication-batch ()
|
||||||
|
"Refresh fixed batch view slots after precommit and signal journaling."
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(setf (tp-publication-batch-candidate-final-accept
|
||||||
|
tp--transaction-publication-batch)
|
||||||
|
tp--transaction-final-accept-function)
|
||||||
|
(let ((journals
|
||||||
|
(tp-publication-batch-candidate-journals
|
||||||
|
tp--transaction-publication-batch)))
|
||||||
|
(when (vectorp journals)
|
||||||
|
(aset journals 4 tp--transaction-signal-commit-journal)))))
|
||||||
|
|
||||||
|
(defun tp--transaction-prepare-success-outcome ()
|
||||||
|
"Preallocate the active batch's success evidence before final accept."
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(let ((candidate tp--transaction-publication-batch)
|
||||||
|
(text-operations 0)
|
||||||
|
(property-operations 0)
|
||||||
|
(touched-characters 0)
|
||||||
|
target-counts)
|
||||||
|
(dolist (entry (tp-publication-batch-candidate-entries candidate))
|
||||||
|
(let ((counts (tp-publication-target-entry-operation-counts entry)))
|
||||||
|
(unless counts
|
||||||
|
(signal 'tp-publication-binding-error
|
||||||
|
(list :missing-operation-counts
|
||||||
|
(tp-publication-target-entry-surface-id entry))))
|
||||||
|
(cl-incf text-operations (or (plist-get counts :text-operations) 0))
|
||||||
|
(cl-incf property-operations
|
||||||
|
(or (plist-get counts :property-operations) 0))
|
||||||
|
(cl-incf touched-characters
|
||||||
|
(or (plist-get counts :touched-characters) 0))
|
||||||
|
(push (tp--copy-property-value counts) target-counts)))
|
||||||
|
(setf
|
||||||
|
(tp-publication-batch-candidate-operation-counts candidate)
|
||||||
|
(list :targets
|
||||||
|
(length (tp-publication-batch-candidate-entries candidate))
|
||||||
|
:participants (length tp--transaction-participants)
|
||||||
|
:signals (length tp--transaction-signals)
|
||||||
|
:markers tp--transaction-final-marker-count
|
||||||
|
:text-operations text-operations
|
||||||
|
:property-operations property-operations
|
||||||
|
:touched-characters touched-characters
|
||||||
|
:target-counts (nreverse target-counts))
|
||||||
|
(tp-publication-batch-candidate-phase-timings candidate)
|
||||||
|
(nreverse (copy-sequence tp--transaction-phase-timings))
|
||||||
|
(tp-publication-batch-candidate-diagnostics candidate)
|
||||||
|
(tp--copy-property-value tp--transaction-contained-failures))
|
||||||
|
(setf (tp-publication-batch-candidate-success-outcome-draft candidate)
|
||||||
|
(tp--committed-success-outcome-draft
|
||||||
|
candidate
|
||||||
|
(tp-publication-batch-candidate-operation-counts candidate)
|
||||||
|
(tp-publication-batch-candidate-phase-timings candidate)
|
||||||
|
(tp-publication-batch-candidate-diagnostics candidate)
|
||||||
|
tp--transaction-final-marker-count)))))
|
||||||
|
|
||||||
|
(defun tp--transaction-apply-one-final-marker (marker)
|
||||||
|
"Apply one prevalidated MARKER through its closed package primitive."
|
||||||
|
(funcall
|
||||||
|
(tp--final-marker-operation-apply
|
||||||
|
(tp-final-accept-marker-operation marker))
|
||||||
|
marker))
|
||||||
|
|
||||||
|
(defun tp--transaction-restore-one-final-marker (marker)
|
||||||
|
"Restore one prevalidated MARKER through its closed package primitive."
|
||||||
|
(funcall
|
||||||
|
(tp--final-marker-operation-restore
|
||||||
|
(tp-final-accept-marker-operation marker))
|
||||||
|
marker))
|
||||||
|
|
||||||
|
(defun tp--transaction-restore-final-marker-at (index failures-cell)
|
||||||
|
"Restore marker INDEX, then exhaustively continue using FAILURES-CELL."
|
||||||
|
(when (>= index 0)
|
||||||
|
(let ((marker (aref tp--transaction-final-marker-registry index)))
|
||||||
|
(unwind-protect
|
||||||
|
(when (memq (tp-final-accept-marker-state marker)
|
||||||
|
'(applying applied))
|
||||||
|
(setf (tp-final-accept-marker-state marker) 'restoring)
|
||||||
|
(condition-case failure
|
||||||
|
(progn
|
||||||
|
(tp--transaction-restore-one-final-marker marker)
|
||||||
|
(setf (tp-final-accept-marker-state marker) 'restored))
|
||||||
|
((error quit)
|
||||||
|
(setf (tp-final-accept-marker-state marker) 'restore-failed)
|
||||||
|
(aset
|
||||||
|
failures-cell 0
|
||||||
|
(cons (list 'final-markers
|
||||||
|
(tp-final-accept-marker-owner-key marker)
|
||||||
|
failure)
|
||||||
|
(aref failures-cell 0))))))
|
||||||
|
;; This cleanup runs even when a test or corrupted primitive exits by
|
||||||
|
;; an arbitrary nonlocal throw, so no earlier applied marker is skipped.
|
||||||
|
(tp--transaction-restore-final-marker-at
|
||||||
|
(1- index) failures-cell)))))
|
||||||
|
|
||||||
|
(defun tp--transaction-restore-applied-final-markers ()
|
||||||
|
"Reverse every applied marker and return contained restore failures."
|
||||||
|
(let ((index (1- tp--transaction-applied-final-marker-count))
|
||||||
|
(failures-cell (vector nil)))
|
||||||
|
(setq tp--transaction-applied-final-marker-count 0)
|
||||||
|
(tp--transaction-restore-final-marker-at index failures-cell)
|
||||||
|
(nreverse (aref failures-cell 0))))
|
||||||
|
|
||||||
|
(defun tp--transaction-apply-final-markers ()
|
||||||
|
"Apply every sealed marker in registration order."
|
||||||
|
(dotimes (index tp--transaction-final-marker-count)
|
||||||
|
(let ((marker (aref tp--transaction-final-marker-registry index)))
|
||||||
|
;; Count and mark first so mutate-then-signal is still reverse-restored.
|
||||||
|
(setq tp--transaction-applied-final-marker-count (1+ index))
|
||||||
|
(setf (tp-final-accept-marker-state marker) 'applying)
|
||||||
|
(tp--transaction-apply-one-final-marker marker)
|
||||||
|
(setf (tp-final-accept-marker-state marker) 'applied))))
|
||||||
|
|
||||||
|
(defun tp--transaction-commit-final-markers ()
|
||||||
|
"Finalize marker state through fixed writes after successful accept."
|
||||||
|
(dotimes (index tp--transaction-final-marker-count)
|
||||||
|
(setf (tp-final-accept-marker-state
|
||||||
|
(aref tp--transaction-final-marker-registry index))
|
||||||
|
'committed))
|
||||||
|
(setq tp--transaction-applied-final-marker-count 0))
|
||||||
|
|
||||||
|
(defun tp--transaction-run-final-accept ()
|
||||||
|
"Apply markers, invoke the existing single final accept, and finalize tags."
|
||||||
|
(tp--transaction-batch-transition 'final-accepting)
|
||||||
|
(let (accepted)
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(tp--transaction-apply-final-markers)
|
||||||
|
(if tp--transaction-publication-batch
|
||||||
|
(let ((candidate-function
|
||||||
|
(tp-publication-batch-candidate-final-accept
|
||||||
|
tp--transaction-publication-batch)))
|
||||||
|
(unless (eq candidate-function
|
||||||
|
tp--transaction-final-accept-function)
|
||||||
|
(signal 'tp-publication-binding-error
|
||||||
|
(list :final-accept candidate-function
|
||||||
|
tp--transaction-final-accept-function)))
|
||||||
|
(funcall candidate-function))
|
||||||
|
(funcall tp--transaction-final-accept-function))
|
||||||
|
(setq accepted t))
|
||||||
|
(unless accepted
|
||||||
|
(setq tp--transaction-marker-restore-failures
|
||||||
|
(tp--transaction-restore-applied-final-markers))))
|
||||||
|
(when accepted
|
||||||
|
(tp--transaction-commit-final-markers)
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(let* ((candidate tp--transaction-publication-batch)
|
||||||
|
(outcome
|
||||||
|
(tp-publication-batch-candidate-success-outcome-draft
|
||||||
|
candidate)))
|
||||||
|
;; Every fallible validation and allocation happened before accept.
|
||||||
|
(setf (tp-publication-batch-candidate-state candidate) 'committed
|
||||||
|
(tp-publication-batch-candidate-resolution candidate) 'committed)
|
||||||
|
;; The success tag is a read-only slot with one coordinator-owned
|
||||||
|
;; fixed write after the existing final accept has returned.
|
||||||
|
(aset outcome tp--committed-success-outcome-tag-slot
|
||||||
|
'committed-success)
|
||||||
|
(tp--transaction-publish-outcome outcome))))))
|
||||||
|
|
||||||
|
(defun tp--transaction-run-shadow-proof (phase)
|
||||||
|
"Compare structured artifacts with the selected single live result for PHASE."
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(let ((ok t) results outcome-equivalent)
|
||||||
|
(dolist (entry
|
||||||
|
(tp-publication-batch-candidate-entries
|
||||||
|
tp--transaction-publication-batch))
|
||||||
|
(let ((validator (tp-publication-target-entry-shadow-validator entry)))
|
||||||
|
(condition-case failure
|
||||||
|
(let ((result (and validator (funcall validator entry phase))))
|
||||||
|
(setf (tp-publication-target-entry-shadow-actual entry) result
|
||||||
|
(tp-publication-target-entry-shadow-proven-p entry)
|
||||||
|
(and result (plist-get result :equivalent)))
|
||||||
|
(unless (tp-publication-target-entry-shadow-proven-p entry)
|
||||||
|
(setq ok nil))
|
||||||
|
(when (eq phase 'rollback)
|
||||||
|
(setf (tp-publication-target-entry-rollback-result entry)
|
||||||
|
(if (plist-get result :equivalent) 'restored 'mismatch)
|
||||||
|
(tp-publication-target-entry-post-rollback-state entry)
|
||||||
|
(plist-get result :actual)))
|
||||||
|
(push result results))
|
||||||
|
((error quit)
|
||||||
|
(setq ok nil)
|
||||||
|
(push (list :equivalent nil :failure failure) results)))))
|
||||||
|
(setq outcome-equivalent
|
||||||
|
(pcase phase
|
||||||
|
('commit
|
||||||
|
(tp--committed-success-outcome-valid-for-p
|
||||||
|
tp--transaction-outcome tp--transaction-publication-batch))
|
||||||
|
('rollback
|
||||||
|
(and tp--transaction-outcome
|
||||||
|
(tp--publication-failure-outcome-valid-for-p
|
||||||
|
tp--transaction-outcome
|
||||||
|
tp--transaction-publication-batch)))))
|
||||||
|
(when (and (eq phase 'commit) (not outcome-equivalent))
|
||||||
|
(setq ok nil))
|
||||||
|
(let ((proof (list :phase phase :equivalent ok
|
||||||
|
:outcome-equivalent outcome-equivalent
|
||||||
|
:entries (nreverse results))))
|
||||||
|
(setf (tp-publication-batch-candidate-shadow-proof
|
||||||
|
tp--transaction-publication-batch)
|
||||||
|
proof)
|
||||||
|
(setq tp--last-shadow-proof
|
||||||
|
(list :phase phase :equivalent ok
|
||||||
|
:outcome-equivalent outcome-equivalent
|
||||||
|
:entry-count
|
||||||
|
(length
|
||||||
|
(tp-publication-batch-candidate-entries
|
||||||
|
tp--transaction-publication-batch))))
|
||||||
|
(unless ok
|
||||||
|
(push (list 'shadow-proof phase proof)
|
||||||
|
tp--transaction-contained-failures))
|
||||||
|
proof))))
|
||||||
|
|
||||||
|
(defun tp--transaction-finalize-rollback-shadow-outcome ()
|
||||||
|
"Correlate the failure outcome with the already compared rollback artifacts."
|
||||||
|
(when-let* ((candidate tp--transaction-publication-batch)
|
||||||
|
(proof (tp-publication-batch-candidate-shadow-proof candidate)))
|
||||||
|
(let* ((outcome-equivalent
|
||||||
|
(tp--publication-failure-outcome-valid-for-p
|
||||||
|
tp--transaction-outcome candidate))
|
||||||
|
(equivalent
|
||||||
|
(and (plist-get proof :equivalent) outcome-equivalent)))
|
||||||
|
(setq proof (plist-put proof :outcome-equivalent outcome-equivalent)
|
||||||
|
proof (plist-put proof :equivalent equivalent))
|
||||||
|
(setf (tp-publication-batch-candidate-shadow-proof candidate) proof)
|
||||||
|
(setq tp--last-shadow-proof
|
||||||
|
(list :phase 'rollback :equivalent equivalent
|
||||||
|
:outcome-equivalent outcome-equivalent
|
||||||
|
:entry-count
|
||||||
|
(length (tp-publication-batch-candidate-entries candidate))))
|
||||||
|
(unless equivalent
|
||||||
|
(push (list 'shadow-proof 'rollback-outcome proof)
|
||||||
|
tp--transaction-contained-failures))
|
||||||
|
proof)))
|
||||||
|
|
||||||
|
(defun tp--transaction-finish-rollback (primary-condition rollback-failures)
|
||||||
|
"Finalize failure evidence for PRIMARY-CONDITION and ROLLBACK-FAILURES."
|
||||||
|
(dotimes (index tp--transaction-final-marker-count)
|
||||||
|
(let ((marker (aref tp--transaction-final-marker-registry index)))
|
||||||
|
(when (eq (tp-final-accept-marker-state marker) 'prepared)
|
||||||
|
(setf (tp-final-accept-marker-state marker) 'rolled-back))))
|
||||||
|
(when tp--transaction-publication-batch
|
||||||
|
(let ((candidate tp--transaction-publication-batch))
|
||||||
|
(unless (tp--publication-batch-terminal-p candidate)
|
||||||
|
(if (eq (tp-publication-batch-candidate-state candidate) 'prepared)
|
||||||
|
(progn
|
||||||
|
(setf (tp-publication-batch-candidate-state candidate) 'discarded
|
||||||
|
(tp-publication-batch-candidate-resolution candidate)
|
||||||
|
'discarded))
|
||||||
|
(tp--publication-batch-transition candidate 'rolled-back)))
|
||||||
|
(tp--transaction-run-shadow-proof 'rollback)
|
||||||
|
(when (and primary-condition
|
||||||
|
(eq (tp-publication-batch-candidate-state candidate)
|
||||||
|
'rolled-back))
|
||||||
|
(tp--transaction-publish-outcome
|
||||||
|
(tp--publication-failure-outcome-create
|
||||||
|
candidate tp--transaction-phase primary-condition rollback-failures
|
||||||
|
tp--transaction-contained-failures))
|
||||||
|
(tp--transaction-finalize-rollback-shadow-outcome)))))
|
||||||
|
|
||||||
(defun tp--run-contained-transaction-functions (phase functions)
|
(defun tp--run-contained-transaction-functions (phase functions)
|
||||||
"Run postaccept PHASE FUNCTIONS and record contained failures."
|
"Run postaccept PHASE FUNCTIONS and record contained failures."
|
||||||
(dolist (function (tp--transaction-hook-functions functions))
|
(dolist (function (tp--transaction-hook-functions functions))
|
||||||
@ -841,10 +1383,11 @@ transaction."
|
|||||||
(defun tp--rollback-transaction-state (counter-snapshot)
|
(defun tp--rollback-transaction-state (counter-snapshot)
|
||||||
"Restore COUNTER-SNAPSHOT through every rollback phase.
|
"Restore COUNTER-SNAPSHOT through every rollback phase.
|
||||||
Return contained failures in phase order."
|
Return contained failures in phase order."
|
||||||
(let ((failures (tp--rollback-transaction-participants)))
|
(let ((failures (copy-sequence tp--transaction-marker-restore-failures)))
|
||||||
(setq failures
|
(setq failures
|
||||||
(append
|
(append
|
||||||
failures
|
failures
|
||||||
|
(tp--rollback-transaction-participants)
|
||||||
(tp--rollback-hook-phase
|
(tp--rollback-hook-phase
|
||||||
'rollback-hooks tp--transaction-rollback-functions)
|
'rollback-hooks tp--transaction-rollback-functions)
|
||||||
(tp--rollback-signal-journal)))
|
(tp--rollback-signal-journal)))
|
||||||
@ -888,8 +1431,14 @@ the primary condition data."
|
|||||||
(funcall function)
|
(funcall function)
|
||||||
(let (after-commit result
|
(let (after-commit result
|
||||||
(tp--transaction-contained-failures nil))
|
(tp--transaction-contained-failures nil))
|
||||||
|
(setq tp--last-transaction-outcome nil
|
||||||
|
tp--last-shadow-proof nil)
|
||||||
(setq result
|
(setq result
|
||||||
(let ((tp--transaction-active t)
|
(let ((tp--transaction-active t)
|
||||||
|
(tp--transaction-id (tp--next-transaction-id))
|
||||||
|
(tp--transaction-phase 'body)
|
||||||
|
(tp--transaction-phase-start (float-time))
|
||||||
|
(tp--transaction-phase-timings nil)
|
||||||
(tp--transaction-signal-values
|
(tp--transaction-signal-values
|
||||||
(make-hash-table :test #'eq))
|
(make-hash-table :test #'eq))
|
||||||
(tp--transaction-signals nil)
|
(tp--transaction-signals nil)
|
||||||
@ -904,8 +1453,22 @@ the primary condition data."
|
|||||||
(tp--transaction-after-commit-callbacks nil)
|
(tp--transaction-after-commit-callbacks nil)
|
||||||
(tp--transaction-participants nil)
|
(tp--transaction-participants nil)
|
||||||
(tp--transaction-participant-keys nil)
|
(tp--transaction-participant-keys nil)
|
||||||
|
(tp--transaction-participant-order 0)
|
||||||
(tp--transaction-published-participants nil)
|
(tp--transaction-published-participants nil)
|
||||||
(tp--transaction-signal-commit-journal nil)
|
(tp--transaction-signal-commit-journal nil)
|
||||||
|
(tp--transaction-publication-batch nil)
|
||||||
|
(tp--transaction-structured-participants nil)
|
||||||
|
(tp--transaction-final-marker-registry
|
||||||
|
(make-vector tp--final-marker-max-count nil))
|
||||||
|
(tp--transaction-final-marker-owner-keys
|
||||||
|
(make-vector tp--final-marker-max-count nil))
|
||||||
|
(tp--transaction-final-marker-count 0)
|
||||||
|
(tp--transaction-final-marker-slot-writes 0)
|
||||||
|
(tp--transaction-final-markers-frozen-p nil)
|
||||||
|
(tp--transaction-applied-final-marker-count 0)
|
||||||
|
(tp--transaction-marker-restore-failures nil)
|
||||||
|
(tp--transaction-outcome nil)
|
||||||
|
(tp--transaction-outcome-cell (vector nil))
|
||||||
(tp--transaction-final-accept-function
|
(tp--transaction-final-accept-function
|
||||||
#'tp--transaction-noop-final-accept)
|
#'tp--transaction-noop-final-accept)
|
||||||
(counter-snapshot (copy-sequence tp--reactive-counters))
|
(counter-snapshot (copy-sequence tp--reactive-counters))
|
||||||
@ -917,11 +1480,27 @@ the primary condition data."
|
|||||||
(condition-case condition
|
(condition-case condition
|
||||||
(progn
|
(progn
|
||||||
(setq transaction-result (funcall function))
|
(setq transaction-result (funcall function))
|
||||||
|
(tp--transaction-enter-phase 'recompute)
|
||||||
(tp--flush-dirty-bindings)
|
(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)
|
(run-hooks 'tp--transaction-publish-functions)
|
||||||
(tp--publish-transaction-participants)
|
(tp--transaction-batch-transition 'participants)
|
||||||
|
(tp--transaction-enter-phase 'participants)
|
||||||
|
(tp--stage-structured-transaction-participants)
|
||||||
|
(tp--transaction-batch-transition 'precommit)
|
||||||
|
(tp--transaction-enter-phase 'precommit)
|
||||||
|
(tp--run-structured-transaction-participant-precommits)
|
||||||
(tp--run-transaction-precommit-functions)
|
(tp--run-transaction-precommit-functions)
|
||||||
|
(tp--transaction-freeze-final-markers)
|
||||||
|
(tp--transaction-sync-publication-batch)
|
||||||
|
(tp--transaction-enter-phase 'signal-commit)
|
||||||
(tp--commit-signal-values)
|
(tp--commit-signal-values)
|
||||||
|
(tp--transaction-sync-publication-batch)
|
||||||
|
(tp--transaction-enter-phase 'final-accept)
|
||||||
|
(tp--transaction-prepare-success-outcome)
|
||||||
(condition-case deferred-quit
|
(condition-case deferred-quit
|
||||||
(progn
|
(progn
|
||||||
(let ((inhibit-quit t)
|
(let ((inhibit-quit t)
|
||||||
@ -936,9 +1515,10 @@ the primary condition data."
|
|||||||
(list
|
(list
|
||||||
:invalid-final-accept-function
|
:invalid-final-accept-function
|
||||||
tp--transaction-final-accept-function)))
|
tp--transaction-final-accept-function)))
|
||||||
(funcall
|
(tp--transaction-run-final-accept)
|
||||||
tp--transaction-final-accept-function)
|
|
||||||
(setq success t)
|
(setq success t)
|
||||||
|
(tp--commit-structured-transaction-participants)
|
||||||
|
(tp--transaction-run-shadow-proof 'commit)
|
||||||
(when quit-flag
|
(when quit-flag
|
||||||
(setq pending-quit t
|
(setq pending-quit t
|
||||||
quit-flag nil))
|
quit-flag nil))
|
||||||
@ -971,9 +1551,14 @@ the primary condition data."
|
|||||||
(let ((inhibit-quit t)
|
(let ((inhibit-quit t)
|
||||||
(quit-flag nil))
|
(quit-flag nil))
|
||||||
(unwind-protect
|
(unwind-protect
|
||||||
(setq rollback-failures
|
(progn
|
||||||
|
(setq tp--transaction-phase
|
||||||
|
(or tp--transaction-phase 'rollback)
|
||||||
|
rollback-failures
|
||||||
(tp--rollback-transaction-state
|
(tp--rollback-transaction-state
|
||||||
counter-snapshot))
|
counter-snapshot))
|
||||||
|
(tp--transaction-finish-rollback
|
||||||
|
primary-condition rollback-failures))
|
||||||
(setq quit-flag nil)))))
|
(setq quit-flag nil)))))
|
||||||
(when primary-condition
|
(when primary-condition
|
||||||
(tp--resignal-transaction-primary
|
(tp--resignal-transaction-primary
|
||||||
|
|||||||
41
tp-style.el
41
tp-style.el
@ -205,12 +205,51 @@ OPTIONS support :normalizer, :validator, :equality, :merge, and :projector."
|
|||||||
#'tp--merge-face-values
|
#'tp--merge-face-values
|
||||||
(lambda (_old new) new)))
|
(lambda (_old new) new)))
|
||||||
|
|
||||||
|
(defun tp--native-keymap-equal-p (left right)
|
||||||
|
"Compare native snapshots LEFT and RIGHT, retaining commands and menu order."
|
||||||
|
(let ((seen (make-hash-table :test #'eq)))
|
||||||
|
(cl-labels
|
||||||
|
((bindings (map)
|
||||||
|
(let ((local (copy-sequence (if (symbolp map)
|
||||||
|
(indirect-function map) map)))
|
||||||
|
entries)
|
||||||
|
(set-keymap-parent local nil)
|
||||||
|
(map-keymap (lambda (key value) (push (cons key value) entries)) local)
|
||||||
|
entries))
|
||||||
|
(same (old new)
|
||||||
|
(cond
|
||||||
|
((eq old new) t)
|
||||||
|
((memq new (gethash old seen)) t)
|
||||||
|
((and (keymapp old) (keymapp new))
|
||||||
|
(puthash old (cons new (gethash old seen)) seen)
|
||||||
|
(and (equal-including-properties (keymap-prompt old)
|
||||||
|
(keymap-prompt new))
|
||||||
|
(same (bindings old) (bindings new))
|
||||||
|
(same (keymap-parent old) (keymap-parent new))))
|
||||||
|
((or (functionp old) (functionp new)) nil)
|
||||||
|
((and (consp old) (consp new))
|
||||||
|
(puthash old (cons new (gethash old seen)) seen)
|
||||||
|
(and (same (car old) (car new)) (same (cdr old) (cdr new))))
|
||||||
|
((and (vectorp old) (vectorp new) (= (length old) (length new)))
|
||||||
|
(puthash old (cons new (gethash old seen)) seen)
|
||||||
|
(cl-loop for index below (length old)
|
||||||
|
always (same (aref old index) (aref new index))))
|
||||||
|
(t (equal old new)))))
|
||||||
|
(same left right))))
|
||||||
|
|
||||||
|
(defun tp--native-property-value-equal-p (left right)
|
||||||
|
"Compare native values LEFT and RIGHT while preserving callable identity."
|
||||||
|
(cond
|
||||||
|
((and (keymapp left) (keymapp right)) (tp--native-keymap-equal-p left right))
|
||||||
|
((or (functionp left) (functionp right)) (eq left right))
|
||||||
|
(t (equal left right))))
|
||||||
|
|
||||||
(defun tp-register-text-property (property)
|
(defun tp-register-text-property (property)
|
||||||
"Register and return a direct policy for Emacs PROPERTY."
|
"Register and return a direct policy for Emacs PROPERTY."
|
||||||
(let ((id (tp-text-property-id property)))
|
(let ((id (tp-text-property-id property)))
|
||||||
(or (tp-property-policy id)
|
(or (tp-property-policy id)
|
||||||
(tp-define-property-policy
|
(tp-define-property-policy
|
||||||
id :equality #'equal
|
id :equality #'tp--native-property-value-equal-p
|
||||||
:merge (tp--text-property-merge-function property)
|
:merge (tp--text-property-merge-function property)
|
||||||
:projector (lambda (value) (list property value))))))
|
:projector (lambda (value) (list property value))))))
|
||||||
|
|
||||||
|
|||||||
1007
tp-surface.el
1007
tp-surface.el
File diff suppressed because it is too large
Load Diff
822
tp-transaction.el
Normal file
822
tp-transaction.el
Normal file
@ -0,0 +1,822 @@
|
|||||||
|
;;; tp-transaction.el --- Structured publication transaction contracts -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Copyright (C) 2026 Geekinney
|
||||||
|
|
||||||
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||||
|
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 3 of
|
||||||
|
;; the License, or (at your option) any later version.
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
|
||||||
|
;; Internal immutable artifacts and one-shot state machines for TP publication.
|
||||||
|
;; The package-owned entry-stage capability stored in a batch candidate drives
|
||||||
|
;; publication. This module never edits a buffer itself: `tp-reactive' drives
|
||||||
|
;; the state machine and `tp-surface' supplies and stages exact target entries
|
||||||
|
;; backed by the shared prepare journals and snapshots.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'cl-lib)
|
||||||
|
(require 'tp-core)
|
||||||
|
|
||||||
|
(define-error 'tp-transaction-contract-error
|
||||||
|
"Invalid TP publication transaction contract")
|
||||||
|
(define-error 'tp-publication-binding-error
|
||||||
|
"TP publication artifact binding mismatch"
|
||||||
|
'tp-transaction-contract-error)
|
||||||
|
(define-error 'tp-publication-state-error
|
||||||
|
"Invalid TP publication artifact state transition"
|
||||||
|
'tp-transaction-contract-error)
|
||||||
|
(define-error 'tp-final-marker-error
|
||||||
|
"Invalid TP final-accept marker"
|
||||||
|
'tp-transaction-contract-error)
|
||||||
|
|
||||||
|
(defconst tp-transaction-protocol 'tp-transaction-protocol-v2
|
||||||
|
"Transaction protocol implemented by this TP package version.")
|
||||||
|
|
||||||
|
(defconst tp--publication-batch-transitions
|
||||||
|
'((prepared staged rolled-back discarded)
|
||||||
|
(staged participants rolled-back)
|
||||||
|
(participants precommit rolled-back)
|
||||||
|
(precommit final-accepting rolled-back)
|
||||||
|
(final-accepting committed rolled-back))
|
||||||
|
"Allowed one-way state transitions for publication batch candidates.")
|
||||||
|
|
||||||
|
(defconst tp--publication-batch-terminal-states
|
||||||
|
'(committed rolled-back discarded)
|
||||||
|
"Terminal publication batch candidate states.")
|
||||||
|
|
||||||
|
(defconst tp--publication-batch-stage-entry-functions
|
||||||
|
'(tp--surface-stage-publication-entries)
|
||||||
|
"Closed package-owned publication entry stage capabilities.")
|
||||||
|
|
||||||
|
(defconst tp--final-marker-max-count 8
|
||||||
|
"Maximum number of opaque final markers in one transaction.")
|
||||||
|
|
||||||
|
(defconst tp--final-marker-max-slot-writes 16
|
||||||
|
"Maximum total fixed marker slot writes in one transaction.")
|
||||||
|
|
||||||
|
(defvar tp--transaction-id-counter 0)
|
||||||
|
(defvar tp--publication-batch-id-counter 0)
|
||||||
|
(defvar tp--publication-candidate-id-counter 0)
|
||||||
|
(defvar tp--final-accept-id-counter 0)
|
||||||
|
|
||||||
|
(defun tp--next-transaction-id ()
|
||||||
|
"Return a fresh monotonic internal transaction identifier."
|
||||||
|
(cl-incf tp--transaction-id-counter))
|
||||||
|
|
||||||
|
(defun tp--next-publication-batch-id ()
|
||||||
|
"Return a fresh monotonic publication batch identifier."
|
||||||
|
(cl-incf tp--publication-batch-id-counter))
|
||||||
|
|
||||||
|
(defun tp--next-publication-candidate-id ()
|
||||||
|
"Return a fresh monotonic target candidate identifier."
|
||||||
|
(cl-incf tp--publication-candidate-id-counter))
|
||||||
|
|
||||||
|
(defun tp--next-final-accept-id ()
|
||||||
|
"Return a fresh monotonic final-accept identifier."
|
||||||
|
(cl-incf tp--final-accept-id-counter))
|
||||||
|
|
||||||
|
(defun tp--proper-unique-list-p (items)
|
||||||
|
"Return non-nil when ITEMS is a proper list with no equal duplicates."
|
||||||
|
(and (proper-list-p items)
|
||||||
|
(let ((seen (make-hash-table :test #'equal))
|
||||||
|
(unique t))
|
||||||
|
(dolist (item items unique)
|
||||||
|
(if (gethash item seen)
|
||||||
|
(setq unique nil)
|
||||||
|
(puthash item t seen))))))
|
||||||
|
|
||||||
|
(cl-defstruct (tp-publication-target-entry
|
||||||
|
(:constructor tp--make-publication-target-entry)
|
||||||
|
(:copier nil))
|
||||||
|
"One exact, immutable target binding in a publication candidate."
|
||||||
|
(transaction-id nil :read-only t)
|
||||||
|
(batch-id nil :read-only t)
|
||||||
|
(candidate-id nil :read-only t)
|
||||||
|
(surface-id nil :read-only t)
|
||||||
|
(mount-ids nil :read-only t)
|
||||||
|
(buffer nil :read-only t)
|
||||||
|
(old-revision nil :read-only t)
|
||||||
|
(new-revision nil :read-only t)
|
||||||
|
(plan nil :read-only t)
|
||||||
|
(diff nil :read-only t)
|
||||||
|
(ledger nil :read-only t)
|
||||||
|
(objects nil :read-only t)
|
||||||
|
(ranges nil :read-only t)
|
||||||
|
(client-state nil :read-only t)
|
||||||
|
(rollback-snapshot nil :read-only t)
|
||||||
|
(authority-token nil :read-only t)
|
||||||
|
(mapping-generation nil :read-only t)
|
||||||
|
operation-counts
|
||||||
|
(shadow-expected nil :read-only t)
|
||||||
|
(shadow-validator nil :read-only t)
|
||||||
|
rollback-result post-rollback-state shadow-actual shadow-proven-p)
|
||||||
|
|
||||||
|
(defun tp--publication-target-entry-arguments-valid-p
|
||||||
|
(transaction-id batch-id candidate-id surface-id mount-ids buffer
|
||||||
|
old-revision new-revision authority-token shadow-validator)
|
||||||
|
"Return non-nil when target arguments bind TRANSACTION-ID and BATCH-ID.
|
||||||
|
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION,
|
||||||
|
AUTHORITY-TOKEN, and SHADOW-VALIDATOR must have valid publication shapes."
|
||||||
|
(and transaction-id batch-id candidate-id surface-id
|
||||||
|
(bufferp buffer) (buffer-live-p buffer)
|
||||||
|
(integerp old-revision) (>= old-revision 0)
|
||||||
|
(integerp new-revision) (= new-revision (1+ old-revision))
|
||||||
|
(tp--proper-unique-list-p mount-ids)
|
||||||
|
authority-token
|
||||||
|
(or (null shadow-validator) (functionp shadow-validator))))
|
||||||
|
|
||||||
|
(cl-defun tp--publication-target-entry-create
|
||||||
|
(&key transaction-id batch-id candidate-id surface-id mount-ids buffer
|
||||||
|
old-revision new-revision plan diff ledger objects ranges client-state
|
||||||
|
rollback-snapshot authority-token mapping-generation shadow-expected
|
||||||
|
shadow-validator operation-counts)
|
||||||
|
"Create an exact TRANSACTION-ID and BATCH-ID target binding.
|
||||||
|
CANDIDATE-ID, SURFACE-ID, MOUNT-IDS, BUFFER, OLD-REVISION, NEW-REVISION, PLAN,
|
||||||
|
DIFF, LEDGER, OBJECTS, RANGES, CLIENT-STATE, ROLLBACK-SNAPSHOT, and
|
||||||
|
AUTHORITY-TOKEN describe the target. MAPPING-GENERATION is optional.
|
||||||
|
OPERATION-COUNTS is filled from the live report. SHADOW-EXPECTED and
|
||||||
|
SHADOW-VALIDATOR are private comparison artifacts."
|
||||||
|
(unless (tp--publication-target-entry-arguments-valid-p
|
||||||
|
transaction-id batch-id candidate-id surface-id mount-ids buffer
|
||||||
|
old-revision new-revision authority-token shadow-validator)
|
||||||
|
(signal 'tp-publication-binding-error
|
||||||
|
(list :target-entry transaction-id batch-id candidate-id surface-id
|
||||||
|
buffer old-revision new-revision mount-ids authority-token)))
|
||||||
|
(tp--make-publication-target-entry
|
||||||
|
:transaction-id transaction-id
|
||||||
|
:batch-id batch-id
|
||||||
|
:candidate-id candidate-id
|
||||||
|
:surface-id (tp--copy-property-value surface-id)
|
||||||
|
:mount-ids (tp--copy-property-value mount-ids)
|
||||||
|
:buffer buffer
|
||||||
|
:old-revision old-revision
|
||||||
|
:new-revision new-revision
|
||||||
|
:plan plan
|
||||||
|
:diff (tp--copy-property-value diff)
|
||||||
|
:ledger ledger
|
||||||
|
:objects objects
|
||||||
|
:ranges ranges
|
||||||
|
:client-state (tp--copy-property-value client-state)
|
||||||
|
:rollback-snapshot rollback-snapshot
|
||||||
|
:authority-token authority-token
|
||||||
|
:mapping-generation mapping-generation
|
||||||
|
:operation-counts (tp--copy-property-value operation-counts)
|
||||||
|
:shadow-expected shadow-expected
|
||||||
|
:shadow-validator shadow-validator))
|
||||||
|
|
||||||
|
(cl-defstruct (tp-publication-outcome-entry
|
||||||
|
(:constructor tp--make-publication-outcome-entry)
|
||||||
|
(:copier nil))
|
||||||
|
"Frozen observational binding copied from one target entry."
|
||||||
|
(batch-id nil :read-only t)
|
||||||
|
(candidate-id nil :read-only t)
|
||||||
|
(surface-id nil :read-only t)
|
||||||
|
(mount-ids nil :read-only t)
|
||||||
|
(buffer nil :read-only t)
|
||||||
|
(authority-token nil :read-only t)
|
||||||
|
(old-revision nil :read-only t)
|
||||||
|
(new-revision nil :read-only t)
|
||||||
|
(mapping-generation nil :read-only t)
|
||||||
|
(operation-counts nil :read-only t))
|
||||||
|
|
||||||
|
(defun tp--publication-outcome-entry-from-target (entry)
|
||||||
|
"Return an observational outcome entry frozen from target ENTRY."
|
||||||
|
(tp--make-publication-outcome-entry
|
||||||
|
:batch-id (tp-publication-target-entry-batch-id entry)
|
||||||
|
:candidate-id (tp-publication-target-entry-candidate-id entry)
|
||||||
|
:surface-id
|
||||||
|
(tp--copy-property-value (tp-publication-target-entry-surface-id entry))
|
||||||
|
:mount-ids
|
||||||
|
(tp--copy-property-value (tp-publication-target-entry-mount-ids entry))
|
||||||
|
:buffer (tp-publication-target-entry-buffer entry)
|
||||||
|
:authority-token (tp-publication-target-entry-authority-token entry)
|
||||||
|
:old-revision (tp-publication-target-entry-old-revision entry)
|
||||||
|
:new-revision (tp-publication-target-entry-new-revision entry)
|
||||||
|
:mapping-generation
|
||||||
|
(tp-publication-target-entry-mapping-generation entry)
|
||||||
|
:operation-counts
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-target-entry-operation-counts entry))))
|
||||||
|
|
||||||
|
(cl-defstruct (tp-committed-success-outcome
|
||||||
|
(:constructor tp--make-committed-success-outcome)
|
||||||
|
(:copier nil))
|
||||||
|
"Preallocated immutable evidence finalized only after final accept."
|
||||||
|
(tag nil :read-only t)
|
||||||
|
(transaction-id nil :read-only t)
|
||||||
|
(final-accept-id nil :read-only t)
|
||||||
|
(batch-id nil :read-only t)
|
||||||
|
(entries nil :read-only t)
|
||||||
|
(mapping-generation nil :read-only t)
|
||||||
|
(operation-counts nil :read-only t)
|
||||||
|
(phase-timings nil :read-only t)
|
||||||
|
(diagnostics nil :read-only t)
|
||||||
|
(marker-count nil :read-only t))
|
||||||
|
|
||||||
|
(defconst tp--committed-success-outcome-tag-slot 1
|
||||||
|
"Private record offset for the sole postaccept success-tag write.")
|
||||||
|
|
||||||
|
(cl-defstruct (tp-publication-failure-outcome
|
||||||
|
(:constructor tp--make-publication-failure-outcome)
|
||||||
|
(:copier nil))
|
||||||
|
"Immutable observational evidence built after publication rollback."
|
||||||
|
(tag 'publication-failure :read-only t)
|
||||||
|
(transaction-id nil :read-only t)
|
||||||
|
(batch-id nil :read-only t)
|
||||||
|
(failure-stage nil :read-only t)
|
||||||
|
(primary-condition nil :read-only t)
|
||||||
|
(target-results nil :read-only t)
|
||||||
|
(rollback-failures nil :read-only t)
|
||||||
|
(post-rollback-state nil :read-only t)
|
||||||
|
(diagnostics nil :read-only t))
|
||||||
|
|
||||||
|
(cl-defstruct (tp-publication-batch-candidate
|
||||||
|
(:constructor tp--make-publication-batch-candidate)
|
||||||
|
(:copier nil))
|
||||||
|
"A one-shot structured publication authority over shared rollback state."
|
||||||
|
(transaction-id nil :read-only t)
|
||||||
|
(id nil :read-only t)
|
||||||
|
state
|
||||||
|
resolution
|
||||||
|
(entries nil :read-only t)
|
||||||
|
(participants nil :read-only t)
|
||||||
|
(journals nil :read-only t)
|
||||||
|
(stage-entries nil :read-only t)
|
||||||
|
final-accept
|
||||||
|
(final-accept-id nil :read-only t)
|
||||||
|
diagnostics
|
||||||
|
operation-counts
|
||||||
|
phase-timings
|
||||||
|
markers
|
||||||
|
success-outcome-draft
|
||||||
|
outcome
|
||||||
|
shadow-proof)
|
||||||
|
|
||||||
|
(defun tp--publication-target-entry-bound-p (entry transaction-id batch-id)
|
||||||
|
"Return non-nil when ENTRY is exactly bound to TRANSACTION-ID and BATCH-ID."
|
||||||
|
(and (tp-publication-target-entry-p entry)
|
||||||
|
(equal transaction-id
|
||||||
|
(tp-publication-target-entry-transaction-id entry))
|
||||||
|
(equal batch-id (tp-publication-target-entry-batch-id entry))))
|
||||||
|
|
||||||
|
(defun tp--publication-batch-entries-valid-p
|
||||||
|
(entries transaction-id batch-id)
|
||||||
|
"Return non-nil when ENTRIES bind TRANSACTION-ID and BATCH-ID exactly."
|
||||||
|
(and (proper-list-p entries)
|
||||||
|
entries
|
||||||
|
(cl-every (lambda (entry)
|
||||||
|
(tp--publication-target-entry-bound-p
|
||||||
|
entry transaction-id batch-id))
|
||||||
|
entries)
|
||||||
|
(tp--proper-unique-list-p
|
||||||
|
(mapcar #'tp-publication-target-entry-candidate-id entries))
|
||||||
|
(tp--proper-unique-list-p
|
||||||
|
(mapcar #'tp-publication-target-entry-surface-id entries))
|
||||||
|
(tp--proper-unique-list-p
|
||||||
|
(mapcar #'tp-publication-target-entry-authority-token entries))
|
||||||
|
(let ((generation
|
||||||
|
(tp-publication-target-entry-mapping-generation (car entries))))
|
||||||
|
(cl-every
|
||||||
|
(lambda (entry)
|
||||||
|
(equal generation
|
||||||
|
(tp-publication-target-entry-mapping-generation entry)))
|
||||||
|
entries))))
|
||||||
|
|
||||||
|
(cl-defun tp--publication-batch-prepare
|
||||||
|
(&key transaction-id batch-id entries participants journals stage-entries
|
||||||
|
final-accept diagnostics)
|
||||||
|
"Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES.
|
||||||
|
PARTICIPANTS is an ordered reference vector, JOURNALS is the shared rollback
|
||||||
|
view, STAGE-ENTRIES is an optional package-owned execution capability,
|
||||||
|
FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains known
|
||||||
|
preaccept observations."
|
||||||
|
(unless (and transaction-id batch-id
|
||||||
|
(tp--publication-batch-entries-valid-p
|
||||||
|
entries transaction-id batch-id)
|
||||||
|
(vectorp participants)
|
||||||
|
(or (null stage-entries)
|
||||||
|
(and (symbolp stage-entries)
|
||||||
|
(memq stage-entries
|
||||||
|
tp--publication-batch-stage-entry-functions)
|
||||||
|
(fboundp stage-entries)))
|
||||||
|
(functionp final-accept))
|
||||||
|
(signal 'tp-publication-binding-error
|
||||||
|
(list :batch transaction-id batch-id entries participants)))
|
||||||
|
(tp--make-publication-batch-candidate
|
||||||
|
:transaction-id transaction-id
|
||||||
|
:id batch-id
|
||||||
|
:state 'prepared
|
||||||
|
:entries (copy-sequence entries)
|
||||||
|
:participants participants
|
||||||
|
:journals journals
|
||||||
|
:stage-entries stage-entries
|
||||||
|
:final-accept final-accept
|
||||||
|
:final-accept-id (tp--next-final-accept-id)
|
||||||
|
:diagnostics (tp--copy-property-value diagnostics)))
|
||||||
|
|
||||||
|
(defun tp--publication-batch-execute-stage (candidate)
|
||||||
|
"Execute CANDIDATE's package-owned entry stage capability exactly once."
|
||||||
|
(unless (and (tp-publication-batch-candidate-p candidate)
|
||||||
|
(eq (tp-publication-batch-candidate-state candidate) 'staged)
|
||||||
|
(memq (tp-publication-batch-candidate-stage-entries candidate)
|
||||||
|
tp--publication-batch-stage-entry-functions))
|
||||||
|
(signal 'tp-publication-state-error
|
||||||
|
(list :batch-stage candidate)))
|
||||||
|
(funcall (tp-publication-batch-candidate-stage-entries candidate) candidate))
|
||||||
|
|
||||||
|
(defun tp--publication-batch-terminal-p (candidate)
|
||||||
|
"Return non-nil when CANDIDATE has one terminal disposition."
|
||||||
|
(and (tp-publication-batch-candidate-p candidate)
|
||||||
|
(memq (tp-publication-batch-candidate-state candidate)
|
||||||
|
tp--publication-batch-terminal-states)))
|
||||||
|
|
||||||
|
(defun tp--publication-batch-transition (candidate next)
|
||||||
|
"Move CANDIDATE to NEXT through its one-way state machine."
|
||||||
|
(unless (tp-publication-batch-candidate-p candidate)
|
||||||
|
(signal 'wrong-type-argument
|
||||||
|
(list 'tp-publication-batch-candidate-p candidate)))
|
||||||
|
(let* ((current (tp-publication-batch-candidate-state candidate))
|
||||||
|
(allowed (cdr (assq current tp--publication-batch-transitions))))
|
||||||
|
(unless (memq next allowed)
|
||||||
|
(signal 'tp-publication-state-error
|
||||||
|
(list :batch-state current next
|
||||||
|
(tp-publication-batch-candidate-id candidate))))
|
||||||
|
(setf (tp-publication-batch-candidate-state candidate) next)
|
||||||
|
(when (memq next tp--publication-batch-terminal-states)
|
||||||
|
(setf (tp-publication-batch-candidate-resolution candidate) next))
|
||||||
|
candidate))
|
||||||
|
|
||||||
|
(defun tp--publication-batch-discard (candidate reason)
|
||||||
|
"Discard prepared CANDIDATE for REASON and return nil."
|
||||||
|
(unless (and (tp-publication-batch-candidate-p candidate)
|
||||||
|
(eq (tp-publication-batch-candidate-state candidate) 'prepared))
|
||||||
|
(signal 'tp-publication-state-error
|
||||||
|
(list :discard
|
||||||
|
(and (tp-publication-batch-candidate-p candidate)
|
||||||
|
(tp-publication-batch-candidate-state candidate)))))
|
||||||
|
(setf (tp-publication-batch-candidate-diagnostics candidate)
|
||||||
|
(append (tp-publication-batch-candidate-diagnostics candidate)
|
||||||
|
(list (list :discard reason))))
|
||||||
|
(tp--publication-batch-transition candidate 'discarded)
|
||||||
|
nil)
|
||||||
|
|
||||||
|
(defun tp--committed-success-outcome-draft
|
||||||
|
(candidate operation-counts phase-timings diagnostics marker-count)
|
||||||
|
"Preallocate CANDIDATE evidence using OPERATION-COUNTS and PHASE-TIMINGS.
|
||||||
|
DIAGNOSTICS contains known preaccept failures and MARKER-COUNT is fixed."
|
||||||
|
(unless (tp-publication-batch-candidate-p candidate)
|
||||||
|
(signal 'wrong-type-argument
|
||||||
|
(list 'tp-publication-batch-candidate-p candidate)))
|
||||||
|
(setf (tp-publication-batch-candidate-operation-counts candidate)
|
||||||
|
(tp--copy-property-value operation-counts)
|
||||||
|
(tp-publication-batch-candidate-phase-timings candidate)
|
||||||
|
(tp--copy-property-value phase-timings)
|
||||||
|
(tp-publication-batch-candidate-diagnostics candidate)
|
||||||
|
(tp--copy-property-value diagnostics))
|
||||||
|
(tp--make-committed-success-outcome
|
||||||
|
:transaction-id
|
||||||
|
(tp-publication-batch-candidate-transaction-id candidate)
|
||||||
|
:final-accept-id
|
||||||
|
(tp-publication-batch-candidate-final-accept-id candidate)
|
||||||
|
:batch-id (tp-publication-batch-candidate-id candidate)
|
||||||
|
:entries
|
||||||
|
(mapcar #'tp--publication-outcome-entry-from-target
|
||||||
|
(tp-publication-batch-candidate-entries candidate))
|
||||||
|
:mapping-generation
|
||||||
|
(let ((entries (tp-publication-batch-candidate-entries candidate)))
|
||||||
|
(and entries
|
||||||
|
(tp-publication-target-entry-mapping-generation (car entries))))
|
||||||
|
:operation-counts
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-batch-candidate-operation-counts candidate))
|
||||||
|
:phase-timings
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-batch-candidate-phase-timings candidate))
|
||||||
|
:diagnostics
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-batch-candidate-diagnostics candidate))
|
||||||
|
:marker-count marker-count))
|
||||||
|
|
||||||
|
(defun tp--committed-success-outcome-finalize (outcome)
|
||||||
|
"Finalize preallocated OUTCOME exactly once after final accept."
|
||||||
|
(unless (and (tp-committed-success-outcome-p outcome)
|
||||||
|
(null (tp-committed-success-outcome-tag outcome)))
|
||||||
|
(signal 'tp-publication-state-error (list :success-outcome outcome)))
|
||||||
|
;; The slot is read-only to every accessor. This single fixed vector write is
|
||||||
|
;; the coordinator's postaccept tag finalization primitive.
|
||||||
|
(aset outcome tp--committed-success-outcome-tag-slot 'committed-success)
|
||||||
|
outcome)
|
||||||
|
|
||||||
|
(defun tp--publication-outcome-entry-matches-target-p (outcome-entry target)
|
||||||
|
"Return non-nil when OUTCOME-ENTRY is exactly bound to TARGET."
|
||||||
|
(and (tp-publication-outcome-entry-p outcome-entry)
|
||||||
|
(tp-publication-target-entry-p target)
|
||||||
|
(equal (tp-publication-outcome-entry-batch-id outcome-entry)
|
||||||
|
(tp-publication-target-entry-batch-id target))
|
||||||
|
(equal (tp-publication-outcome-entry-candidate-id outcome-entry)
|
||||||
|
(tp-publication-target-entry-candidate-id target))
|
||||||
|
(equal (tp-publication-outcome-entry-surface-id outcome-entry)
|
||||||
|
(tp-publication-target-entry-surface-id target))
|
||||||
|
(equal (tp-publication-outcome-entry-mount-ids outcome-entry)
|
||||||
|
(tp-publication-target-entry-mount-ids target))
|
||||||
|
(eq (tp-publication-outcome-entry-buffer outcome-entry)
|
||||||
|
(tp-publication-target-entry-buffer target))
|
||||||
|
(eq (tp-publication-outcome-entry-authority-token outcome-entry)
|
||||||
|
(tp-publication-target-entry-authority-token target))
|
||||||
|
(= (tp-publication-outcome-entry-old-revision outcome-entry)
|
||||||
|
(tp-publication-target-entry-old-revision target))
|
||||||
|
(= (tp-publication-outcome-entry-new-revision outcome-entry)
|
||||||
|
(tp-publication-target-entry-new-revision target))
|
||||||
|
(equal (tp-publication-outcome-entry-mapping-generation outcome-entry)
|
||||||
|
(tp-publication-target-entry-mapping-generation target))
|
||||||
|
(equal (tp-publication-outcome-entry-operation-counts outcome-entry)
|
||||||
|
(tp-publication-target-entry-operation-counts target))))
|
||||||
|
|
||||||
|
(defun tp--committed-success-outcome-valid-for-p
|
||||||
|
(outcome candidate &optional mapping-generation)
|
||||||
|
"Purely validate OUTCOME against exact CANDIDATE and MAPPING-GENERATION."
|
||||||
|
(and (tp-committed-success-outcome-p outcome)
|
||||||
|
(eq (tp-committed-success-outcome-tag outcome) 'committed-success)
|
||||||
|
(tp-publication-batch-candidate-p candidate)
|
||||||
|
(eq (tp-publication-batch-candidate-state candidate) 'committed)
|
||||||
|
(equal (tp-committed-success-outcome-transaction-id outcome)
|
||||||
|
(tp-publication-batch-candidate-transaction-id candidate))
|
||||||
|
(equal (tp-committed-success-outcome-batch-id outcome)
|
||||||
|
(tp-publication-batch-candidate-id candidate))
|
||||||
|
(equal (tp-committed-success-outcome-operation-counts outcome)
|
||||||
|
(tp-publication-batch-candidate-operation-counts candidate))
|
||||||
|
(equal (tp-committed-success-outcome-phase-timings outcome)
|
||||||
|
(tp-publication-batch-candidate-phase-timings candidate))
|
||||||
|
(equal (tp-committed-success-outcome-diagnostics outcome)
|
||||||
|
(tp-publication-batch-candidate-diagnostics candidate))
|
||||||
|
(= (tp-committed-success-outcome-marker-count outcome)
|
||||||
|
(if (consp (tp-publication-batch-candidate-markers candidate))
|
||||||
|
(cdr (tp-publication-batch-candidate-markers candidate))
|
||||||
|
0))
|
||||||
|
(or (null mapping-generation)
|
||||||
|
(equal mapping-generation
|
||||||
|
(tp-committed-success-outcome-mapping-generation outcome)))
|
||||||
|
(let ((outcome-entries
|
||||||
|
(append (tp-committed-success-outcome-entries outcome) nil))
|
||||||
|
(targets (tp-publication-batch-candidate-entries candidate)))
|
||||||
|
(and (= (length outcome-entries) (length targets))
|
||||||
|
(cl-every #'identity
|
||||||
|
(cl-mapcar
|
||||||
|
#'tp--publication-outcome-entry-matches-target-p
|
||||||
|
outcome-entries targets))))))
|
||||||
|
|
||||||
|
(defun tp--committed-success-outcome-snapshot (outcome)
|
||||||
|
"Return a defensive observational plist for committed OUTCOME."
|
||||||
|
(unless (and (tp-committed-success-outcome-p outcome)
|
||||||
|
(eq (tp-committed-success-outcome-tag outcome)
|
||||||
|
'committed-success))
|
||||||
|
(signal 'tp-publication-binding-error (list :outcome outcome)))
|
||||||
|
(list
|
||||||
|
:tag 'committed-success
|
||||||
|
:transaction-id (tp-committed-success-outcome-transaction-id outcome)
|
||||||
|
:final-accept-id (tp-committed-success-outcome-final-accept-id outcome)
|
||||||
|
:batch-id (tp-committed-success-outcome-batch-id outcome)
|
||||||
|
:entries
|
||||||
|
(mapcar
|
||||||
|
(lambda (entry)
|
||||||
|
(list :batch-id (tp-publication-outcome-entry-batch-id entry)
|
||||||
|
:candidate-id (tp-publication-outcome-entry-candidate-id entry)
|
||||||
|
:surface-id
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-outcome-entry-surface-id entry))
|
||||||
|
:mount-ids
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-outcome-entry-mount-ids entry))
|
||||||
|
:buffer (tp-publication-outcome-entry-buffer entry)
|
||||||
|
:authority-token
|
||||||
|
(tp-publication-outcome-entry-authority-token entry)
|
||||||
|
:old-revision
|
||||||
|
(tp-publication-outcome-entry-old-revision entry)
|
||||||
|
:new-revision
|
||||||
|
(tp-publication-outcome-entry-new-revision entry)
|
||||||
|
:mapping-generation
|
||||||
|
(tp-publication-outcome-entry-mapping-generation entry)
|
||||||
|
:operation-counts
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-outcome-entry-operation-counts entry))))
|
||||||
|
(append (tp-committed-success-outcome-entries outcome) nil))
|
||||||
|
:mapping-generation
|
||||||
|
(tp-committed-success-outcome-mapping-generation outcome)
|
||||||
|
:operation-counts
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-committed-success-outcome-operation-counts outcome))
|
||||||
|
:phase-timings
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-committed-success-outcome-phase-timings outcome))
|
||||||
|
:diagnostics
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-committed-success-outcome-diagnostics outcome))
|
||||||
|
:marker-count (tp-committed-success-outcome-marker-count outcome)))
|
||||||
|
|
||||||
|
(defun tp--publication-failure-outcome-valid-for-p (outcome candidate)
|
||||||
|
"Purely validate failure OUTCOME against rolled-back CANDIDATE."
|
||||||
|
(and (tp-publication-failure-outcome-p outcome)
|
||||||
|
(eq (tp-publication-failure-outcome-tag outcome)
|
||||||
|
'publication-failure)
|
||||||
|
(tp-publication-batch-candidate-p candidate)
|
||||||
|
(eq (tp-publication-batch-candidate-state candidate) 'rolled-back)
|
||||||
|
(equal (tp-publication-failure-outcome-transaction-id outcome)
|
||||||
|
(tp-publication-batch-candidate-transaction-id candidate))
|
||||||
|
(equal (tp-publication-failure-outcome-batch-id outcome)
|
||||||
|
(tp-publication-batch-candidate-id candidate))
|
||||||
|
(let ((results (tp-publication-failure-outcome-target-results outcome))
|
||||||
|
(entries (tp-publication-batch-candidate-entries candidate)))
|
||||||
|
(and (= (length results) (length entries))
|
||||||
|
(cl-every
|
||||||
|
#'identity
|
||||||
|
(cl-mapcar
|
||||||
|
(lambda (result entry)
|
||||||
|
(and
|
||||||
|
(equal (plist-get result :candidate-id)
|
||||||
|
(tp-publication-target-entry-candidate-id entry))
|
||||||
|
(equal (plist-get result :surface-id)
|
||||||
|
(tp-publication-target-entry-surface-id entry))))
|
||||||
|
results entries))))))
|
||||||
|
|
||||||
|
(defun tp--publication-failure-outcome-create
|
||||||
|
(candidate stage primary-condition rollback-failures diagnostics)
|
||||||
|
"Build rolled-back CANDIDATE evidence for STAGE and PRIMARY-CONDITION.
|
||||||
|
ROLLBACK-FAILURES and DIAGNOSTICS are observational snapshots."
|
||||||
|
(unless (and (tp-publication-batch-candidate-p candidate)
|
||||||
|
(eq (tp-publication-batch-candidate-state candidate)
|
||||||
|
'rolled-back))
|
||||||
|
(signal 'tp-publication-state-error (list :failure-outcome candidate)))
|
||||||
|
(let ((entries (tp-publication-batch-candidate-entries candidate)))
|
||||||
|
(tp--make-publication-failure-outcome
|
||||||
|
:transaction-id
|
||||||
|
(tp-publication-batch-candidate-transaction-id candidate)
|
||||||
|
:batch-id (tp-publication-batch-candidate-id candidate)
|
||||||
|
:failure-stage stage
|
||||||
|
:primary-condition (tp--copy-property-value primary-condition)
|
||||||
|
:target-results
|
||||||
|
(mapcar
|
||||||
|
(lambda (entry)
|
||||||
|
(list :candidate-id
|
||||||
|
(tp-publication-target-entry-candidate-id entry)
|
||||||
|
:surface-id
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-target-entry-surface-id entry))
|
||||||
|
:result
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-target-entry-rollback-result entry))))
|
||||||
|
entries)
|
||||||
|
:rollback-failures (tp--copy-property-value rollback-failures)
|
||||||
|
:post-rollback-state
|
||||||
|
(mapcar
|
||||||
|
(lambda (entry)
|
||||||
|
(list :candidate-id
|
||||||
|
(tp-publication-target-entry-candidate-id entry)
|
||||||
|
:surface-id
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-target-entry-surface-id entry))
|
||||||
|
:state
|
||||||
|
(tp--copy-property-value
|
||||||
|
(tp-publication-target-entry-post-rollback-state entry))))
|
||||||
|
entries)
|
||||||
|
:diagnostics (tp--copy-property-value diagnostics))))
|
||||||
|
|
||||||
|
(cl-defstruct (tp--final-marker-operation
|
||||||
|
(:constructor tp--make-final-marker-operation)
|
||||||
|
(:copier nil))
|
||||||
|
"One trusted operation descriptor resolved before final accept."
|
||||||
|
(key nil :read-only t)
|
||||||
|
(validate nil :read-only t)
|
||||||
|
(apply nil :read-only t)
|
||||||
|
(restore nil :read-only t)
|
||||||
|
(max-slot-writes nil :read-only t))
|
||||||
|
|
||||||
|
(cl-defstruct (tp-final-marker-expectation
|
||||||
|
(:constructor tp--make-final-marker-expectation)
|
||||||
|
(:copier nil))
|
||||||
|
"One prebuilt expected scalar stored in a fixed vector slot."
|
||||||
|
(target nil :read-only t)
|
||||||
|
(index nil :read-only t)
|
||||||
|
(value nil :read-only t))
|
||||||
|
|
||||||
|
(cl-defstruct (tp-final-marker-slot-write
|
||||||
|
(:constructor tp--make-final-marker-slot-write)
|
||||||
|
(:copier nil))
|
||||||
|
"One prebuilt fixed vector slot write."
|
||||||
|
(target nil :read-only t)
|
||||||
|
(index nil :read-only t)
|
||||||
|
(value nil :read-only t))
|
||||||
|
|
||||||
|
(defun tp--final-marker-vector-index-p (target index)
|
||||||
|
"Return non-nil when INDEX denotes a writable slot in TARGET."
|
||||||
|
(and (vectorp target) (integerp index) (<= 0 index) (< index (length target))))
|
||||||
|
|
||||||
|
(cl-defun tp--final-marker-expectation-create (&key target index value)
|
||||||
|
"Create an expectation that TARGET slot INDEX currently equals VALUE."
|
||||||
|
(unless (tp--final-marker-vector-index-p target index)
|
||||||
|
(signal 'tp-final-marker-error (list :expectation target index)))
|
||||||
|
(tp--make-final-marker-expectation
|
||||||
|
:target target :index index :value value))
|
||||||
|
|
||||||
|
(cl-defun tp-final-marker-expectation-create (&key target index value)
|
||||||
|
"Create a final-marker expectation for TARGET slot INDEX and VALUE."
|
||||||
|
(tp--final-marker-expectation-create
|
||||||
|
:target target :index index :value value))
|
||||||
|
|
||||||
|
(cl-defun tp--final-marker-slot-write-create (&key target index value)
|
||||||
|
"Create one prebuilt write of VALUE into TARGET slot INDEX."
|
||||||
|
(unless (tp--final-marker-vector-index-p target index)
|
||||||
|
(signal 'tp-final-marker-error (list :slot-write target index)))
|
||||||
|
(tp--make-final-marker-slot-write :target target :index index :value value))
|
||||||
|
|
||||||
|
(cl-defun tp-final-marker-slot-write-create (&key target index value)
|
||||||
|
"Create one bounded final-marker write to TARGET slot INDEX with VALUE."
|
||||||
|
(tp--final-marker-slot-write-create
|
||||||
|
:target target :index index :value value))
|
||||||
|
|
||||||
|
(defun tp--final-marker-expectation-current-p (expectation)
|
||||||
|
"Return non-nil when EXPECTATION matches its current fixed slot."
|
||||||
|
(and (tp-final-marker-expectation-p expectation)
|
||||||
|
(equal
|
||||||
|
(aref (tp-final-marker-expectation-target expectation)
|
||||||
|
(tp-final-marker-expectation-index expectation))
|
||||||
|
(tp-final-marker-expectation-value expectation))))
|
||||||
|
|
||||||
|
(defun tp--final-marker-slot-write-shape-p (write)
|
||||||
|
"Return non-nil when WRITE still denotes one valid fixed vector slot."
|
||||||
|
(and (tp-final-marker-slot-write-p write)
|
||||||
|
(tp--final-marker-vector-index-p
|
||||||
|
(tp-final-marker-slot-write-target write)
|
||||||
|
(tp-final-marker-slot-write-index write))))
|
||||||
|
|
||||||
|
(defun tp--final-marker-vector-payload-shape-p (marker)
|
||||||
|
"Return non-nil when MARKER has exact paired fixed vector slot payloads."
|
||||||
|
(let ((next (tp-final-accept-marker-next-values marker))
|
||||||
|
(inverse (tp-final-accept-marker-inverse-values marker))
|
||||||
|
(count (tp-final-accept-marker-slot-write-count marker))
|
||||||
|
seen valid)
|
||||||
|
(setq valid
|
||||||
|
(and (vectorp next) (vectorp inverse)
|
||||||
|
(= (length next) count) (= (length inverse) count)))
|
||||||
|
(let ((index 0))
|
||||||
|
(while (and valid (< index count))
|
||||||
|
(let ((next-write (aref next index))
|
||||||
|
(inverse-write (aref inverse index)))
|
||||||
|
(setq valid
|
||||||
|
(and
|
||||||
|
(tp--final-marker-slot-write-shape-p next-write)
|
||||||
|
(tp--final-marker-slot-write-shape-p inverse-write)
|
||||||
|
(eq (tp-final-marker-slot-write-target next-write)
|
||||||
|
(tp-final-marker-slot-write-target inverse-write))
|
||||||
|
(= (tp-final-marker-slot-write-index next-write)
|
||||||
|
(tp-final-marker-slot-write-index inverse-write))
|
||||||
|
(not
|
||||||
|
(cl-find-if
|
||||||
|
(lambda (entry)
|
||||||
|
(and
|
||||||
|
(eq (car entry)
|
||||||
|
(tp-final-marker-slot-write-target next-write))
|
||||||
|
(= (cdr entry)
|
||||||
|
(tp-final-marker-slot-write-index next-write))))
|
||||||
|
seen))))
|
||||||
|
(when valid
|
||||||
|
(push (cons (tp-final-marker-slot-write-target next-write)
|
||||||
|
(tp-final-marker-slot-write-index next-write))
|
||||||
|
seen)))
|
||||||
|
(setq index (1+ index))))
|
||||||
|
valid))
|
||||||
|
|
||||||
|
(defun tp--final-marker-vector-slots-validate (marker)
|
||||||
|
"Validate MARKER expectations and inverse values without changing state."
|
||||||
|
(and
|
||||||
|
(tp--final-marker-vector-payload-shape-p marker)
|
||||||
|
(tp--final-marker-expectation-current-p
|
||||||
|
(tp-final-accept-marker-expected-token marker))
|
||||||
|
(tp--final-marker-expectation-current-p
|
||||||
|
(tp-final-accept-marker-expected-version marker))
|
||||||
|
(let* ((inverse (tp-final-accept-marker-inverse-values marker))
|
||||||
|
(count (length inverse))
|
||||||
|
(index 0)
|
||||||
|
(valid t))
|
||||||
|
(while (and valid (< index count))
|
||||||
|
(let ((write (aref inverse index)))
|
||||||
|
(setq valid
|
||||||
|
(equal
|
||||||
|
(aref (tp-final-marker-slot-write-target write)
|
||||||
|
(tp-final-marker-slot-write-index write))
|
||||||
|
(tp-final-marker-slot-write-value write))))
|
||||||
|
(setq index (1+ index)))
|
||||||
|
valid)))
|
||||||
|
|
||||||
|
(defun tp--final-marker-vector-slots-apply (marker)
|
||||||
|
"Apply MARKER's fixed next-value vector slots in order."
|
||||||
|
(let* ((writes (tp-final-accept-marker-next-values marker))
|
||||||
|
(count (length writes))
|
||||||
|
(index 0))
|
||||||
|
(while (< index count)
|
||||||
|
(let ((write (aref writes index)))
|
||||||
|
(aset (tp-final-marker-slot-write-target write)
|
||||||
|
(tp-final-marker-slot-write-index write)
|
||||||
|
(tp-final-marker-slot-write-value write)))
|
||||||
|
(setq index (1+ index)))))
|
||||||
|
|
||||||
|
(defun tp--final-marker-vector-slots-restore (marker)
|
||||||
|
"Restore MARKER's fixed inverse-value vector slots in reverse order."
|
||||||
|
(let* ((writes (tp-final-accept-marker-inverse-values marker))
|
||||||
|
(index (1- (length writes))))
|
||||||
|
(while (>= index 0)
|
||||||
|
(let ((write (aref writes index)))
|
||||||
|
(aset (tp-final-marker-slot-write-target write)
|
||||||
|
(tp-final-marker-slot-write-index write)
|
||||||
|
(tp-final-marker-slot-write-value write)))
|
||||||
|
(setq index (1- index)))))
|
||||||
|
|
||||||
|
(defconst tp--final-marker-operation-whitelist
|
||||||
|
(list
|
||||||
|
(tp--make-final-marker-operation
|
||||||
|
:key 'tp-vector-slots/v1
|
||||||
|
:validate (symbol-function 'tp--final-marker-vector-slots-validate)
|
||||||
|
:apply (symbol-function 'tp--final-marker-vector-slots-apply)
|
||||||
|
:restore (symbol-function 'tp--final-marker-vector-slots-restore)
|
||||||
|
:max-slot-writes tp--final-marker-max-slot-writes))
|
||||||
|
"Closed package-owned final-marker primitive whitelist.")
|
||||||
|
|
||||||
|
(defun tp--final-marker-operation-resolve (key)
|
||||||
|
"Return the trusted final marker operation registered for KEY."
|
||||||
|
(let ((operation
|
||||||
|
(cl-find key tp--final-marker-operation-whitelist
|
||||||
|
:key #'tp--final-marker-operation-key :test #'eq)))
|
||||||
|
(or operation
|
||||||
|
(signal 'tp-final-marker-error (list :operation-not-whitelisted key)))))
|
||||||
|
|
||||||
|
(cl-defstruct (tp-final-accept-marker
|
||||||
|
(:constructor tp--make-final-accept-marker)
|
||||||
|
(:copier nil))
|
||||||
|
"One opaque, bounded, one-shot final-accept authority marker."
|
||||||
|
(owner-key nil :read-only t)
|
||||||
|
(expected-token nil :read-only t)
|
||||||
|
(expected-version nil :read-only t)
|
||||||
|
(next-values nil :read-only t)
|
||||||
|
(inverse-values nil :read-only t)
|
||||||
|
(slot-write-count nil :read-only t)
|
||||||
|
(operation-key nil :read-only t)
|
||||||
|
(operation nil :read-only t)
|
||||||
|
state)
|
||||||
|
|
||||||
|
(cl-defun tp--final-accept-marker-create
|
||||||
|
(&key owner-key expected-token expected-version next-values inverse-values
|
||||||
|
slot-write-count operation-key)
|
||||||
|
"Create an OWNER-KEY marker after resolving OPERATION-KEY.
|
||||||
|
EXPECTED-TOKEN and EXPECTED-VERSION bind owner state. NEXT-VALUES and
|
||||||
|
INVERSE-VALUES are opaque prebuilt payloads with fixed SLOT-WRITE-COUNT."
|
||||||
|
(let ((operation (tp--final-marker-operation-resolve operation-key)))
|
||||||
|
(unless (and owner-key
|
||||||
|
(tp-final-marker-expectation-p expected-token)
|
||||||
|
(tp-final-marker-expectation-p expected-version)
|
||||||
|
(integerp
|
||||||
|
(tp-final-marker-expectation-value expected-version))
|
||||||
|
(>= (tp-final-marker-expectation-value expected-version) 0)
|
||||||
|
(integerp slot-write-count) (> slot-write-count 0)
|
||||||
|
(<= slot-write-count
|
||||||
|
(tp--final-marker-operation-max-slot-writes operation)))
|
||||||
|
(signal 'tp-final-marker-error
|
||||||
|
(list :marker owner-key expected-token expected-version
|
||||||
|
slot-write-count operation-key)))
|
||||||
|
(let ((marker
|
||||||
|
(tp--make-final-accept-marker
|
||||||
|
:owner-key (tp--copy-property-value owner-key)
|
||||||
|
:expected-token expected-token
|
||||||
|
:expected-version expected-version
|
||||||
|
:next-values (and (vectorp next-values)
|
||||||
|
(copy-sequence next-values))
|
||||||
|
:inverse-values (and (vectorp inverse-values)
|
||||||
|
(copy-sequence inverse-values))
|
||||||
|
:slot-write-count slot-write-count
|
||||||
|
:operation-key operation-key
|
||||||
|
:operation operation
|
||||||
|
:state 'prepared)))
|
||||||
|
(unless (tp--final-marker-vector-payload-shape-p marker)
|
||||||
|
(signal 'tp-final-marker-error
|
||||||
|
(list :marker-payload owner-key slot-write-count)))
|
||||||
|
marker)))
|
||||||
|
|
||||||
|
(defun tp--final-accept-marker-validate (marker)
|
||||||
|
"Validate MARKER's expected owner state before the critical section."
|
||||||
|
(unless (and (tp-final-accept-marker-p marker)
|
||||||
|
(eq (tp-final-accept-marker-state marker) 'prepared)
|
||||||
|
(funcall
|
||||||
|
(tp--final-marker-operation-validate
|
||||||
|
(tp-final-accept-marker-operation marker))
|
||||||
|
marker))
|
||||||
|
(signal 'tp-final-marker-error
|
||||||
|
(list :expected-state
|
||||||
|
(and (tp-final-accept-marker-p marker)
|
||||||
|
(tp-final-accept-marker-owner-key marker)))))
|
||||||
|
marker)
|
||||||
|
|
||||||
|
(provide 'tp-transaction)
|
||||||
|
;;; tp-transaction.el ends here
|
||||||
20
tp.el
20
tp.el
@ -2,7 +2,7 @@
|
|||||||
|
|
||||||
;; Copyright (C) 2024-2026 Geekinney
|
;; Copyright (C) 2024-2026 Geekinney
|
||||||
|
|
||||||
;; Version: 1.0.0
|
;; Version: 2.0.0
|
||||||
;; Keywords: convenience text-properties
|
;; Keywords: convenience text-properties
|
||||||
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
;; Author: Geekinney (kinneyzhang666@gmail.com)
|
||||||
;; Package-Requires: ((emacs "28.1"))
|
;; Package-Requires: ((emacs "28.1"))
|
||||||
@ -25,6 +25,8 @@
|
|||||||
;; canonical requests/results, and debug logging.
|
;; canonical requests/results, and debug logging.
|
||||||
;; tp-style.el Native property policies, contribution composition,
|
;; tp-style.el Native property policies, contribution composition,
|
||||||
;; named declarations, and explicit computed values.
|
;; named declarations, and explicit computed values.
|
||||||
|
;; tp-transaction.el
|
||||||
|
;; Structured publication batch, marker, and outcome contracts.
|
||||||
;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable
|
;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable
|
||||||
;; adapters.
|
;; adapters.
|
||||||
;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes,
|
;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes,
|
||||||
@ -53,6 +55,7 @@
|
|||||||
|
|
||||||
(require 'tp-core)
|
(require 'tp-core)
|
||||||
(require 'tp-style)
|
(require 'tp-style)
|
||||||
|
(require 'tp-transaction)
|
||||||
(require 'tp-reactive)
|
(require 'tp-reactive)
|
||||||
(require 'tp-surface)
|
(require 'tp-surface)
|
||||||
(require 'tp-layer)
|
(require 'tp-layer)
|
||||||
@ -62,5 +65,20 @@
|
|||||||
(require 'tp-palette)
|
(require 'tp-palette)
|
||||||
(require 'tp-builtins)
|
(require 'tp-builtins)
|
||||||
|
|
||||||
|
(defconst tp--runtime-manifest
|
||||||
|
`(:package tp :version "2.0.0"
|
||||||
|
:transaction-protocol ,tp-transaction-protocol
|
||||||
|
:batch-artifacts t
|
||||||
|
:batch-execute t
|
||||||
|
:structured-participant-api tp-transaction-participate-v2
|
||||||
|
:single-live-writer t
|
||||||
|
:final-marker-operation tp-vector-slots/v1)
|
||||||
|
"Immutable package capability facts for cross-package compatibility checks.")
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun tp-runtime-manifest ()
|
||||||
|
"Return a defensive snapshot of TP's package capability manifest."
|
||||||
|
(tp--copy-property-value tp--runtime-manifest))
|
||||||
|
|
||||||
(provide 'tp)
|
(provide 'tp)
|
||||||
;;; tp.el ends here
|
;;; tp.el ends here
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user