From 76be75f67447066d7ed8aba23b22978b1f79015b Mon Sep 17 00:00:00 2001 From: Kinneyzhang Date: Mon, 31 Aug 2026 19:35:02 +0800 Subject: [PATCH] feat: add TP v1+v2 transaction contract --- CHANGELOG.md | 2 + Makefile | 20 +- README.md | 11 +- README_CN.md | 10 +- docs/API-REFERENCE.md | 12 +- docs/API-SEMANTICS.md | 17 +- docs/ARCHITECTURE.md | 23 +- tests/tp-transaction-tests.el | 1363 +++++++++++++++++++++++++++++++++ tp-core.el | 3 + tp-reactive.el | 597 ++++++++++++++- tp-surface.el | 337 +++++++- tp-transaction.el | 778 +++++++++++++++++++ tp.el | 18 + 13 files changed, 3145 insertions(+), 46 deletions(-) create mode 100644 tests/tp-transaction-tests.el create mode 100644 tp-transaction.el diff --git a/CHANGELOG.md b/CHANGELOG.md index f55dd8a..c929162 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,8 @@ All notable changes to the tp library are documented here. - A standalone retained surface runtime with pure defensive plans, prepare-scoped stable objects, keyed/positional reconciliation, content and properties capabilities, marker-backed range anchors, object/mount indexes, scoped updates, opaque client state, generic reports, and lifecycle cleanup. - Exact signal-to-binding and binding-to-binding dependency tracking with conditional rewiring, equality cutoffs, batched transactions, nested-write stabilization, owner disposal, buffer-scoped sources, variable adapters, cycle paths, and public structural counters. - Atomic single- and multi-surface publication with candidate source values, prepare-all/publish-all ordering, explicit property journals, rollback-capable transaction participants, observer isolation, and authoritative kill-buffer cleanup. +- Additive transaction protocol v2 artifacts: transaction-scoped publication batches, structured v1 participant bridges, bounded opaque final-accept markers using the closed `tp-vector-slots/v1` primitive, immutable tagged outcomes, and property/revision shadow proofs over the unchanged v1 live writer. +- `tp-runtime-manifest`, advertising `tp-transaction-protocol-v1+v2` without removing the v1 participant route. - Native property policies and contribution composition with explicit nil/absence, normalization, validation, equality, merge, projection, named direct styles, and explicit `tp-computed` value sources. - `tp-propertize`, `tp-apply`, and `tp-watch` as the one-shot string, one-shot buffer-range, and reactive existing-text conveniences over the same direct property/surface core. - Retained logical objects with `tp-object-retain` and `tp-object-attach-fragment`, allowing one object to own multiple disjoint physical fragments without placing handles or positions in plans. diff --git a/Makefile b/Makefile index 2318810..0e671f8 100644 --- a/Makefile +++ b/Makefile @@ -4,6 +4,8 @@ # make test # run all ERT test suites # make test-shuffled # run the suite in a random order (SHUFFLE_SEED=n reproduces) # make test-m0a # run current TP completion characterization +# make test-m1a # run additive transaction contract + fault gates +# make test-v1 # run every legacy suite with v2 artifacts disabled # make doctest # execute README examples against the code # make benchmark # run reproducible correctness-first benchmarks # make compile # byte-compile the library modules @@ -22,14 +24,15 @@ WERROR ?= nil TEST_DIR = tests LOADPATH = -L . -L $(TEST_DIR) -L examples $(LOAD_EXTRA) -SRC = tp-core.el tp-style.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \ +SRC = tp-core.el tp-style.el tp-transaction.el tp-reactive.el tp-surface.el tp-layer.el tp-ops.el tp-search.el \ tp-query.el tp-palette.el tp-builtins.el tp.el TESTS = $(wildcard $(TEST_DIR)/*-tests.el) +V1_TESTS = $(filter-out $(TEST_DIR)/tp-transaction-tests.el,$(TESTS)) TEST_SUPPORT = $(TEST_DIR)/tp-doctest.el $(TEST_DIR)/tp-run-shuffled.el EXAMPLES = $(wildcard examples/*.el) DEV = $(TEST_SUPPORT) $(EXAMPLES) tp-benchmark.el -.PHONY: test test-m0a test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean +.PHONY: test test-m0a test-m1a test-v1 test-shuffled doctest benchmark compile compile-all checkdoc package-lint diff-check clean test: $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ @@ -42,6 +45,19 @@ test-m0a: -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-v1: + $(EMACS) -Q --batch $(LOADPATH) -l tp.el \ + --eval '(setq tp--transaction-artifact-mode (quote v1))' \ + $(patsubst %,-l %,$(V1_TESTS)) -f ert-run-tests-batch-and-exit + test-shuffled: $(EMACS) -Q --batch $(LOADPATH) -l tp.el $(patsubst %,-l %,$(TESTS)) \ -l tp-run-shuffled.el diff --git a/README.md b/README.md index 339fdd5..3a8582f 100644 --- a/README.md +++ b/README.md @@ -146,6 +146,15 @@ TP records the host baseline and each TP contribution per property interval. Ove Observers run only after a successful commit. Their failures are recorded and do not roll back an already committed transaction. A buffer killed during publication remains killed; rollback never recreates it. +TP also builds an internal transaction-scoped batch view over the same v1 +participants, journals, surface snapshots, and single final accept. Shadow +mode compares canonical target artifacts and tagged outcomes with the one v1 +writer; it never opens a second change group or writes a buffer twice. Generic +opaque authority markers are bounded and whitelist-validated before final +accept, then reverse-restored before ordinary rollback on partial apply or +accept failure. `tp-with-transaction` still returns its body value, and +internal outcomes remain observational side-channel evidence. + ETAF integration uses the same boundary through one opaque transaction participant. ETAF prepares its immutable generation and Ebox candidate before TP accepts the transaction; participant publish, TP final accept, and @@ -174,7 +183,7 @@ cycles instead of spinning. | Core inspection and debug | `tp-debug-*`, `tp-intervals`, `tp-intervals-map`, `tp-plist`, `tp-text-snapshot`, `tp-empty-p` | | Property policy and declarations | `tp-define-property-policy`, `tp-register-text-property`, `tp-text-declarations`, `tp-computed`, `tp-resolve-value`, `tp-merge-declarations`, `tp-define-style`, `tp-style-declarations` | | Static recipes | `define-tp`/`tp-define-layer`, `define-tps`/`define-tp-group`/`tp-define-group`, layer/group queries, undefine/reset/describe | -| Signals and bindings | signal create/read/peek/set/dispose, binding install/read/dispose, `tp-variable-signal`, `tp-with-transaction`, `tp-transaction-participate`, read-only `tp-transaction-active-p`, counters/reset | +| Signals and bindings | signal create/read/peek/set/dispose, binding install/read/dispose, `tp-variable-signal`, `tp-with-transaction`, `tp-transaction-participate`, read-only `tp-transaction-active-p`, `tp-runtime-manifest`, counters/reset | | Objects and plans | plan/result constructors, `tp-object-ensure`, retain/reuse, fragment/content-range attachment, resolve, mounted/mounts | | Host ranges | `tp-range-anchor-create`, `tp-range-anchor-live-p`, `tp-object-attach-range`, `tp-range-rebase` | | Surfaces | mount/update/scoped update, materialize, live/revision/client-state, at-point, report/report-summary/inspect, unmount | diff --git a/README_CN.md b/README_CN.md index e5a49dc..f19b94a 100644 --- a/README_CN.md +++ b/README_CN.md @@ -145,6 +145,14 @@ TP 为每个 property interval 保存 host baseline 和各个 TP contribution。 observer 只在成功提交之后运行，observer failure 只记录，不回滚已完成的 transaction。publication 过程中被 kill 的 buffer 保持死亡，rollback 不会把它重新创建。 +TP 还会在同一份 v1 participant、journal、surface snapshot 和 single final +accept 上建立内部 transaction-scoped batch view。shadow mode 只比较 canonical +target artifact 与 tagged outcome，仍由唯一 v1 writer 写入；不会建立第二个 +change group，也不会双写 Buffer。generic opaque authority marker 在 final +accept 前完成固定上界与 whitelist 校验；partial apply 或 accept failure 时先 +逆序恢复 marker，再执行普通 rollback。`tp-with-transaction` 仍返回 body +result，内部 outcome 仅作为只读 side-channel evidence。 + ETAF 集成复用同一事务边界，只注册一个 opaque transaction participant。ETAF 先准备 immutable generation 和 Ebox candidate，再由 TP 按固定顺序完成 participant publish、TP final accept 和 post-accept cleanup。participant failure @@ -171,7 +179,7 @@ effect 的 input/version tuple，重复或超过图规模上限时停止循环 | Core inspection 与 debug | `tp-debug-*`、`tp-intervals`、`tp-intervals-map`、`tp-plist`、`tp-text-snapshot`、`tp-empty-p` | | Property policy 与 declaration | `tp-define-property-policy`、`tp-register-text-property`、`tp-text-declarations`、`tp-computed`、`tp-resolve-value`、`tp-merge-declarations`、`tp-define-style`、`tp-style-declarations` | | 静态 recipe | `define-tp`/`tp-define-layer`、`define-tps`/`define-tp-group`/`tp-define-group`、layer/group 查询、undefine/reset/describe | -| Signal 与 binding | signal create/read/peek/set/dispose、binding install/read/dispose、`tp-variable-signal`、`tp-with-transaction`、`tp-transaction-participate`、只读 `tp-transaction-active-p`、counter/reset | +| Signal 与 binding | signal create/read/peek/set/dispose、binding install/read/dispose、`tp-variable-signal`、`tp-with-transaction`、`tp-transaction-participate`、只读 `tp-transaction-active-p`、`tp-runtime-manifest`、counter/reset | | Object 与 plan | plan/result constructor、`tp-object-ensure`、retain/reuse、fragment/content-range attach、resolve、mounted/mounts | | Host range | `tp-range-anchor-create`、`tp-range-anchor-live-p`、`tp-object-attach-range`、`tp-range-rebase` | | Surface | mount/update/scoped update、materialize、live/revision/client-state、at-point、report/report-summary/inspect、unmount | diff --git a/docs/API-REFERENCE.md b/docs/API-REFERENCE.md index 80a7e0f..a5ecaeb 100644 --- a/docs/API-REFERENCE.md +++ b/docs/API-REFERENCE.md @@ -233,6 +233,8 @@ tp-binding-dispose 释放单个 binding。 (tp-transaction-active-p) +(tp-runtime-manifest) + (tp-variable-signal 'my-variable) (tp-variable-signal 'my-buffer-variable some-buffer) (tp-reactive-counters) @@ -251,6 +253,13 @@ tp-transaction-active-p 是只读边界查询：只在当前 dynamic extent 已 对象、participant 或内部状态，调用方只能用它在 mutation 前拒绝不支持的 嵌套事务边界。 +tp-runtime-manifest 返回防御性 capability snapshot；本版本的 +`:transaction-protocol` 为 `tp-transaction-protocol-v1+v2`。该声明是 additive： +旧 `tp-transaction-participate` façade 与 live writer 都仍保留。 +`:batch-artifacts` 与 `:shadow-proof` 为 non-nil，`:batch-execution` 为 +`v1-bridge`，而 `:batch-execute` 明确为 nil；structured-core execute owner +保留给后续受控 cutover，不在 M1a 伪造第二个 coordinator。 + ETAF registers one opaque participant for its immutable generation and Ebox client state. Its publish is paired with rollback across TP final accept; the ETAF runtime separately records effect input/version tuples and reports a @@ -601,7 +610,8 @@ TP 1.0 已删除并且不应在新代码中使用： | tp-core.el | tp-debug-*、tp-with-current-buffer、tp-intervals、tp-intervals-map、tp-empty-p、tp-plist、tp-text-snapshot | | tp-style.el | tp-define-property-policy、tp-property-policy、tp-text-property-id、tp-register-text-property、tp-text-declarations、tp-computed、tp-resolve-value、tp-merge-declarations、tp-define-style、tp-style-declarations、tp-undefine-style | | tp-layer.el | define-tp/tp-define-layer、define-tps/define-tp-group/tp-define-group、layer/group query、tp-layer-reset、tp-undefine-*、tp-describe-layer | -| tp-reactive.el | signal、binding、transaction、variable adapter、counter 和 reset API | +| tp-transaction.el | additive batch/entry、final-marker 与 tagged-outcome 内部合同 | +| tp-reactive.el | signal、binding、transaction coordinator、variable adapter、counter 和 reset API | | tp-surface.el | plan/result、object、range anchor、surface lifecycle、scoped update、report、tp-watch | | tp-ops.el | tp-propertize、tp-apply、tp-set、tp-reset、tp-add、tp-remove、tp-clear、tp-get、tp-at、tp-member | | tp-search.el | tp-match-*、tp-regexp-*、tp-search、tp-search-map、tp-forward*、tp-backward*、tp-any-value | diff --git a/docs/API-SEMANTICS.md b/docs/API-SEMANTICS.md index 83effe4..bd6639e 100644 --- a/docs/API-SEMANTICS.md +++ b/docs/API-SEMANTICS.md @@ -197,13 +197,26 @@ TP 为每个 interval 保存： 4. 校验 object、plan、capability、range、conflict 与 lifecycle； 5. 为所有 surfaces 准备 text/property operations 与 inverse journals； 6. 按稳定 surface id publish； -7. 原子切换 signals、bindings、plans、mount/index、client state 和 revisions； -8. 全部成功后运行 observers。 +7. 按声明顺序 stage participant，再执行 declared precommit； +8. commit signal journal； +9. 在 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 全部回滚。 `tp-transaction-participate` 允许 client side state 在 surfaces 发布后、source commit 前加入同一 rollback boundary。participant key 在一个 outer transaction 中必须唯一。它不是 observer；失败会回滚 transaction。Observer failure 只记录，不回滚已提交结果。 +M1a 的 publication batch、structured participant、final marker 与 tagged +outcome 都是现有 v1 dynamic transaction state 的内部结构化 view，不复制第二份 +participant/journal/change-group，也不切换 live writer。shadow proof 只比较 v1/v2 +artifact 与 outcome，不双写 Buffer。`tp-with-transaction` 的返回值仍是 body +result；success/failure outcome 只走内部 side channel。zero-surface 与 +output-equal operation 不创建 publication batch。 + ETAF uses this API with one opaque participant for its immutable generation and Ebox client state. The participant is published only after candidate preparation, and its paired rollback is still required when TP final accept diff --git a/docs/ARCHITECTURE.md b/docs/ARCHITECTURE.md index 15e7f21..fe2904f 100644 --- a/docs/ARCHITECTURE.md +++ b/docs/ARCHITECTURE.md @@ -26,6 +26,7 @@ TP 不依赖 Ebox 或 ECSS，不包含 selector、stylesheet、CSS cascade、Box ```text tp-core ├─ tp-style + ├─ tp-transaction │ └─ tp-reactive │ └─ tp-surface ├─ tp-layer @@ -44,6 +45,7 @@ tp.el loads the public package surface | --- | --- | --- | | `tp-core.el` | canonical ranges/requests/results、interval traversal、plist/face merge、native property facts | runtime identity、reactivity、publication | | `tp-style.el` | native property policies、direct declarations、explicit computed source、projection | selector、stylesheet、specificity、CSS winner | +| `tp-transaction.el` | additive batch/entry validators、one-shot states、opaque final-marker descriptors、tagged outcomes | live buffer writer、consumer semantics、parallel journals | | `tp-reactive.el` | signals、bindings、dynamic dependency graph、scheduler、candidate source state、transaction participants | buffer scans、mount positions、layout impact | | `tp-surface.el` | prepare context、objects、plans、anchors、mount/index、contribution ledger、diff、publication、rollback、reports | stylesheet/cascade、consumer layout decisions | | `tp-layer.el` | `define-tp`/`define-tps` declaration recipes and registry | live layer stack、inline runtime metadata、watcher engine | @@ -180,6 +182,12 @@ An equal candidate produces no prepared publication. It preserves revision, repo The outer transaction owns candidate source values, dirty bindings, prepared surfaces, participants, inverse journals, view state, and final observer scheduling. +The additive v2 contract is a structured view over those exact owners. It does +not copy participant, scheduler, snapshot, journal, or change-group state. The +public v1 participant façade and the v1 surface writer remain authoritative; +shadow mode constructs canonical entries and compares property-for-property and +revision-for-revision after commit or rollback. + ```text freeze candidate writes → recompute exact dependency closure @@ -188,7 +196,11 @@ freeze candidate writes → capture inverse journals → publish surfaces in stable id order → publish transaction participants - → commit signals/bindings/surface state/revisions + → run precommit validators + → commit signals + → apply bounded opaque final markers + → invoke the single final accept + → finalize tagged success evidence → run observers ``` @@ -198,6 +210,15 @@ Rollback restores text, properties, marker/index state, plans, producer, client `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. +The v1 participant record is also its structured v2 bridge: one stable key, +registration order, stage, rollback, optional declared precommit, contained +after-commit work, owner journal, and one-shot state. Final markers are not +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. ### ETAF participant contract diff --git a/tests/tp-transaction-tests.el b/tests/tp-transaction-tests.el new file mode 100644 index 0000000..c60e16b --- /dev/null +++ b/tests/tp-transaction-tests.el @@ -0,0 +1,1363 @@ +;;; tp-transaction-tests.el --- TP additive transaction contract -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Geekinney + +;;; Commentary: + +;; Characterization and fault tests for the additive v1+v2 transaction +;; protocol. These tests deliberately exercise the internal protocol: the +;; public contract remains `tp-with-transaction' body return and primary +;; condition preservation. + +;;; Code: + +(require 'cl-lib) +(require 'ert) +(require 'tp-transaction) +(require 'tp-surface) + +(declare-function tp--transaction-participate-v2 "tp-reactive" (&rest args)) +(declare-function tp--transaction-participant-protocol "tp-reactive" (value)) +(declare-function tp--transaction-participant-state "tp-reactive" (value)) +(declare-function tp--transaction-participant-journal "tp-reactive" (value)) +(declare-function tp--transaction-register-final-marker + "tp-reactive" (&rest args)) + +(defvar tp--transaction-artifact-mode) +(defvar tp--transaction-publication-batch) +(defvar tp--transaction-outcome) +(defvar tp--last-shadow-proof) + +(define-error 'tp-transaction-test-error "Injected TP transaction failure") + +(defvar tp-transaction-test--precommit-condition nil) +(defvar tp-transaction-test--trace nil) + +(defun tp--transaction-test-precommit-inject () + "Record precommit and signal the configured test condition." + (push 'precommit tp-transaction-test--trace) + (when tp-transaction-test--precommit-condition + (signal (car tp-transaction-test--precommit-condition) + (cdr tp-transaction-test--precommit-condition)))) + +(defun tp--transaction-test-participant-precommit () + "Record one declared structured-participant precommit." + (push 'participant-precommit tp-transaction-test--trace)) + +(defun tp-transaction-test--leaf (text) + "Return a retained content leaf displaying TEXT." + (tp-surface-plan-create + :key 'root :kind 'text :text text :capability 'content)) + +(defun tp-transaction-test--producer (source) + "Return a retained producer reading SOURCE." + (lambda (context) + (tp-object-ensure context nil 'root 'text) + (tp-transaction-test--leaf + (number-to-string (tp-signal-read source))))) + +(defun tp-transaction-test--capture (function) + "Call FUNCTION and return its complete signaled condition." + (condition-case condition + (progn (funcall function) nil) + ((error quit) condition))) + +(defun tp-transaction-test--entry (&rest overrides) + "Return one valid publication target entry with OVERRIDES." + (let ((buffer (or (plist-get overrides :buffer) + (current-buffer)))) + (let ((arguments + (list :surface-id 'surface-a + :transaction-id 'transaction-a + :batch-id 'batch-a + :candidate-id 'candidate-a + :mount-ids '(mount-a) + :buffer buffer + :old-revision 7 + :new-revision 8 + :plan '(:plan old) + :diff '(:replace 1 2) + :ledger '(:ledger candidate) + :objects '(:object candidate) + :ranges '((1 . 2)) + :client-state '(:client candidate) + :rollback-snapshot '(:snapshot old) + :authority-token 'entry-authority-a + :mapping-generation 3))) + (while overrides + (setq arguments + (plist-put arguments (pop overrides) (pop overrides)))) + (apply #'tp--publication-target-entry-create arguments)))) + +(defun tp-transaction-test--batch (&optional entries) + "Return a prepared batch for ENTRIES or one default target." + (tp--publication-batch-prepare + :transaction-id 'transaction-a + :batch-id 'batch-a + :entries (or entries (list (tp-transaction-test--entry))) + :participants [] + :journals nil + :final-accept #'ignore + :diagnostics nil)) + +(defun tp-transaction-test--slot-writes (target values) + "Return fixed slot writes assigning VALUES into TARGET from index zero." + (vconcat + (cl-loop for value across values + for index from 0 + collect + (tp--final-marker-slot-write-create + :target target :index index :value value)))) + +(defun tp-transaction-test--marker-arguments + (target next-values inverse-values &rest overrides) + "Return TARGET marker args for NEXT-VALUES, INVERSE-VALUES, and OVERRIDES." + (let* ((token-index (- (length target) 2)) + (version-index (1- (length target))) + (arguments + (list + :owner-key 'owner-a + :expected-token + (tp--final-marker-expectation-create + :target target :index token-index :value (aref target token-index)) + :expected-version + (tp--final-marker-expectation-create + :target target :index version-index + :value (aref target version-index)) + :next-values (tp-transaction-test--slot-writes target next-values) + :inverse-values + (tp-transaction-test--slot-writes target inverse-values) + :slot-write-count (length next-values) + :operation-key 'tp-vector-slots/v1))) + (while overrides + (setq arguments + (plist-put arguments (pop overrides) (pop overrides)))) + arguments)) + +(defun tp-transaction-test--property-producer (source anchor) + "Return a properties-only producer reading SOURCE over ANCHOR." + (lambda (context) + (let ((object (tp-object-ensure context nil 'root 'range)) + (value (tp-signal-read source))) + (tp-object-attach-range context object anchor) + (tp-surface-result-create + (tp-surface-plan-create + :key 'root :kind 'range + :props (list 'face (if (= value 1) 'bold 'italic)) + :capability 'properties) + (list :value value))))) + +(defun tp-transaction-test--property-state (surface) + "Return exact rollback-sensitive observational state for SURFACE." + (let ((buffer (tp--surface-buffer surface))) + (with-current-buffer buffer + (list :point (point) + :mount-ids (copy-sequence (tp--live-mount-ids surface)) + :mounts (tp--copy-property-value + (tp--live-mount-signature surface)) + :ledger (tp--copy-property-value + (tp--shadow-live-ledger-signature + (tp--surface-ledger surface))) + :client-state + (tp--copy-property-value (tp--surface-client-state surface)) + :revision (tp-surface-revision surface) + :output (buffer-substring (point-min) (point-max)))))) + +(defun tp-transaction-test--should-match-property-state (surface expected) + "Assert that SURFACE exactly matches rollback EXPECTED." + (let ((actual (tp-transaction-test--property-state surface))) + (dolist (key '(:point :mount-ids :mounts :ledger + :client-state :revision)) + (should (equal (plist-get actual key) (plist-get expected key)))) + (should (equal-including-properties + (plist-get actual :output) (plist-get expected :output))))) + +(defun tp-transaction-test--set-batch-proof-fields (candidate) + "Install deterministic proof fields on low-level CANDIDATE." + (setf (tp-publication-batch-candidate-operation-counts candidate) + '(:text 1) + (tp-publication-batch-candidate-phase-timings candidate) + '(:total 0.1) + (tp-publication-batch-candidate-diagnostics candidate) nil) + candidate) + +(defun tp-transaction-test--should-match-outcome-counts (outcome surfaces) + "Assert OUTCOME mapping generation and counts match SURFACES' reports." + (let* ((entries (tp-committed-success-outcome-entries outcome)) + (aggregate (tp-committed-success-outcome-operation-counts outcome)) + (generation (tp-committed-success-outcome-mapping-generation outcome)) + (text 0) (properties 0) (touched 0)) + (should generation) + (should (= (length entries) (length surfaces))) + (dolist (surface surfaces) + (let* ((surface-id (tp--surface-id surface)) + (report (tp-surface-report surface)) + (entry + (cl-find surface-id entries + :key #'tp-publication-outcome-entry-surface-id + :test #'equal)) + (counts + (and entry + (tp-publication-outcome-entry-operation-counts entry)))) + (should entry) + (should (equal (tp-publication-outcome-entry-mapping-generation entry) + generation)) + (should (equal (plist-get counts :mapping-generation) generation)) + (dolist (key '(:old-revision :new-revision :text-operations + :property-operations + :touched-characters)) + (should (equal (plist-get counts key) (plist-get report key)))) + (cl-incf text (plist-get report :text-operations)) + (cl-incf properties (plist-get report :property-operations)) + (cl-incf touched (plist-get report :touched-characters)))) + (should (= (plist-get aggregate :targets) (length surfaces))) + (should (= (plist-get aggregate :text-operations) text)) + (should (= (plist-get aggregate :property-operations) properties)) + (should (= (plist-get aggregate :touched-characters) touched)) + (should (= (length (plist-get aggregate :target-counts)) + (length surfaces))))) + +(cl-defmacro tp-transaction-test--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-transaction-test*")) + (,source (tp-signal-create 1)) + (,surface + (tp-surface-mount + ,buffer (tp-transaction-test--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-transaction-test-v1-body-return-and-phase-order () + "The v1 facade returns BODY and retains its established phase order." + (let ((tp-transaction-test--trace nil) + (tp--transaction-precommit-functions + '(tp--transaction-test-precommit-inject)) + (tp--transaction-precommit-allowed-functions + '(tp--transaction-test-precommit-inject))) + (should + (equal + (tp-with-transaction + (tp-transaction-participate + 'v1 + (lambda () (push 'participant tp-transaction-test--trace)) + (lambda () (push 'rollback tp-transaction-test--trace))) + (tp--enqueue-after-commit + (lambda () (push 'after-commit tp-transaction-test--trace))) + (push 'body tp-transaction-test--trace) + 'body-value) + 'body-value)) + (should (equal (nreverse tp-transaction-test--trace) + '(body participant precommit after-commit))))) + +(ert-deftest tp-transaction-test-v1-participant-and-precommit-fault-order () + "A late v1 fault rolls staged participants back in reverse order." + (let* ((injected '(tp-transaction-test-error :phase precommit :raw (1 2))) + (tp-transaction-test--trace nil) + (tp-transaction-test--precommit-condition injected) + (tp--transaction-precommit-functions + '(tp--transaction-test-precommit-inject)) + (tp--transaction-precommit-allowed-functions + '(tp--transaction-test-precommit-inject)) + (failure + (tp-transaction-test--capture + (lambda () + (tp-with-transaction + (tp-transaction-participate + 'first + (lambda () (push 'stage-first tp-transaction-test--trace)) + (lambda () (push 'rollback-first tp-transaction-test--trace))) + (tp-transaction-participate + 'second + (lambda () (push 'stage-second tp-transaction-test--trace)) + (lambda () (push 'rollback-second tp-transaction-test--trace)))))))) + (should (equal failure injected)) + (should (equal (nreverse tp-transaction-test--trace) + '(stage-first stage-second precommit + rollback-second rollback-first))))) + +(ert-deftest tp-transaction-test-final-accept-fault-preserves-body-state () + "A final-accept fault restores source, surface revision and buffer." + (tp-transaction-test--with-surface (buffer surface source) + (let ((old-revision (tp-surface-revision surface)) + (injected '(tp-transaction-test-error :phase final-accept))) + (should + (equal + (cl-letf (((symbol-function 'accept-change-group) + (lambda (_group) + (signal (car injected) (cdr injected))))) + (tp-transaction-test--capture + (lambda () + (tp-with-transaction + (tp-signal-set source 2) + 'unobservable-body-value)))) + injected)) + (should (= (tp-signal-peek source) 1)) + (should (= (tp-signal-revision source) 0)) + (should (= (tp-surface-revision surface) old-revision)) + (with-current-buffer buffer + (should (equal (buffer-string) "1")))))) + +(ert-deftest tp-transaction-test-batch-validates-entries-and-owns-input () + "Batch preparation rejects invalid entries and owns mutable input." + (should-error + (tp--publication-batch-prepare + :transaction-id 'transaction-a :batch-id 'batch-a + :entries nil :participants [] :final-accept #'ignore) + :type 'tp-publication-binding-error) + (with-temp-buffer + (let* ((mount-ids (list 'mount-a)) + (entry (tp-transaction-test--entry :mount-ids mount-ids)) + (entries (list entry)) + (batch (tp-transaction-test--batch entries))) + (setcar mount-ids 'mutated-after-create) + (setcar entries (tp-transaction-test--entry + :candidate-id 'replacement + :surface-id 'replacement-surface + :authority-token 'replacement-authority)) + (should (tp-publication-target-entry-p entry)) + (should (tp-publication-batch-candidate-p batch)) + (should (eq (tp-publication-batch-candidate-state batch) 'prepared)) + (should (equal (tp-publication-target-entry-mount-ids + (car (tp-publication-batch-candidate-entries batch))) + '(mount-a))) + (should (eq (car (tp-publication-batch-candidate-entries batch)) entry)) + (should-error + (tp-transaction-test--batch (list entry entry)) + :type 'tp-publication-binding-error)))) + +(ert-deftest tp-transaction-test-batch-is-one-shot-and-discard-is-prestage-only () + "Batch state is monotonic and has exactly one terminal disposition." + (with-temp-buffer + (let ((batch (tp-transaction-test--batch))) + (should-error (tp--publication-batch-transition batch 'participants) + :type 'tp-publication-state-error) + (dolist (state '(staged participants precommit final-accepting committed)) + (should (eq (tp--publication-batch-transition batch state) batch)) + (should (eq (tp-publication-batch-candidate-state batch) state))) + (should-error (tp--publication-batch-transition batch 'committed) + :type 'tp-publication-state-error) + (should-error (tp--publication-batch-discard batch 'too-late) + :type 'tp-publication-state-error)) + (let ((discarded (tp-transaction-test--batch))) + (should-not (tp--publication-batch-discard discarded 'unused)) + (should (eq (tp-publication-batch-candidate-state discarded) 'discarded)) + (should-error (tp--publication-batch-discard discarded 'twice) + :type 'tp-publication-state-error) + (should-error (tp--publication-batch-transition discarded 'staged) + :type 'tp-publication-state-error)))) + +(ert-deftest tp-transaction-test-v1-bridge-is-the-structured-participant () + "The v1 facade installs one v2 record, not parallel participant state." + (let (saved) + (tp-with-transaction + (tp-transaction-participate 'legacy #'ignore #'ignore) + (setq saved (car tp--transaction-participants)) + (should (= (length tp--transaction-participants) 1)) + (should (eq (tp--transaction-participant-protocol saved) 'v1-bridge)) + (should (eq (tp--transaction-participant-state saved) 'prepared))) + (should (eq (tp--transaction-participant-state saved) 'committed)))) + +(ert-deftest tp-transaction-test-v2-participant-stage-precommit-and-after-commit () + "A structured participant owns its journal and advances exactly once." + (let ((tp-transaction-test--trace nil) + (tp--transaction-participant-precommit-allowed-functions + '(tp--transaction-test-participant-precommit)) + participant) + (tp-with-transaction + (tp--transaction-participate-v2 + :key 'structured + :stage (lambda () (push 'stage tp-transaction-test--trace)) + :rollback (lambda () (push 'rollback tp-transaction-test--trace)) + :precommit 'tp--transaction-test-participant-precommit + :after-commit (lambda () (push 'participant-after-commit + tp-transaction-test--trace)) + :journal '(:owner old-state)) + (setq participant (car tp--transaction-participants))) + (should (equal (nreverse tp-transaction-test--trace) + '(stage participant-precommit participant-after-commit))) + (should (equal (tp--transaction-participant-journal participant) + '(:owner old-state))) + (should (eq (tp--transaction-participant-state participant) 'committed)))) + +(ert-deftest tp-transaction-test-v2-participant-stage-fault-rolls-back-prior-only () + "A structured stage fault reverses only participants that entered staged." + (let ((tp-transaction-test--trace nil) + (injected '(tp-transaction-test-error :phase participant-stage))) + (should + (equal + (tp-transaction-test--capture + (lambda () + (tp-with-transaction + (tp--transaction-participate-v2 + :key 'first + :stage (lambda () (push 'stage-first tp-transaction-test--trace)) + :rollback (lambda () (push 'rollback-first + tp-transaction-test--trace))) + (tp--transaction-participate-v2 + :key 'second + :stage (lambda () + (push 'stage-second tp-transaction-test--trace) + (signal (car injected) (cdr injected))) + :rollback (lambda () (push 'rollback-second + tp-transaction-test--trace)))))) + injected)) + (should (equal (nreverse tp-transaction-test--trace) + '(stage-first stage-second rollback-second rollback-first))))) + +(ert-deftest tp-transaction-test-final-marker-validates-registry-contract () + "Built-in marker registration validates owner, expectation, and payload." + (tp-transaction-test--with-surface (buffer _surface source) + (let ((target (vector 'old 'token-a 4))) + (tp-with-transaction + (tp-signal-set source 2) + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + target [new] [old])) + (should-error + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + target [new] [old])) + :type 'tp-final-marker-error)) + (should (eq (aref target 0) 'new)) + (dolist (case '(operation expectation payload)) + (aset target 0 'old) + (should-error + (tp-with-transaction + (tp-signal-set source (1+ (tp-signal-peek source))) + (apply #'tp--transaction-register-final-marker + (pcase case + ('operation + (tp-transaction-test--marker-arguments + target [new] [old] + :owner-key 'bad-operation + :operation-key 'not-whitelisted)) + ('expectation + (tp-transaction-test--marker-arguments + target [new] [old] + :owner-key 'bad-expectation + :expected-version + (tp--final-marker-expectation-create + :target target :index 2 :value 3))) + ('payload + (tp-transaction-test--marker-arguments + target [new] [old] + :owner-key 'bad-payload :slot-write-count 2))))) + :type 'tp-final-marker-error) + (should (eq (aref target 0) 'old)))))) + +(ert-deftest tp-transaction-test-marker-partial-apply-restores-in-reverse () + "Partial marker apply restores applied owners before normal rollback." + (tp-transaction-test--with-surface (buffer _surface source) + (let* ((first (vector 'old 'token 1)) + (second (vector 'old 'token 1)) + (trace nil) + (apply-one (symbol-function + 'tp--transaction-apply-one-final-marker)) + (restore-one (symbol-function + 'tp--transaction-restore-one-final-marker))) + (cl-letf + (((symbol-function 'tp--transaction-apply-one-final-marker) + (lambda (marker) + (funcall apply-one marker) + (let ((owner (tp-final-accept-marker-owner-key marker))) + (push (list 'apply owner) trace) + (when (eq owner 'second-owner) + (signal 'tp-transaction-test-error + '(:phase marker-apply)))))) + ((symbol-function 'tp--transaction-restore-one-final-marker) + (lambda (marker) + (funcall restore-one marker) + (push (list 'restore + (tp-final-accept-marker-owner-key marker)) + trace)))) + (should-error + (tp-with-transaction + (tp-signal-set source 2) + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + first [new] [old] :owner-key 'first-owner)) + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + second [new] [old] :owner-key 'second-owner))) + :type 'tp-transaction-test-error)) + (should (eq (aref first 0) 'old)) + (should (eq (aref second 0) 'old)) + (should + (equal (nreverse trace) + '((apply first-owner) (apply second-owner) + (restore second-owner) (restore first-owner))))))) + +(ert-deftest tp-transaction-test-accept-fault-restores-all-markers-reverse () + "An accept fault reverses all applied markers before transaction rollback." + (tp-transaction-test--with-surface (buffer _surface source) + (let* ((first (vector 'old 'token 1)) + (second (vector 'old 'token 1)) + (trace nil) + (apply-one (symbol-function + 'tp--transaction-apply-one-final-marker)) + (restore-one (symbol-function + 'tp--transaction-restore-one-final-marker))) + (should-error + (cl-letf + (((symbol-function 'tp--transaction-apply-one-final-marker) + (lambda (marker) + (funcall apply-one marker) + (push (list 'apply + (tp-final-accept-marker-owner-key marker)) + trace))) + ((symbol-function 'tp--transaction-restore-one-final-marker) + (lambda (marker) + (funcall restore-one marker) + (push (list 'restore + (tp-final-accept-marker-owner-key marker)) + trace))) + ((symbol-function 'accept-change-group) + (lambda (_group) + (signal 'tp-transaction-test-error '(:phase accept))))) + (tp-with-transaction + (tp-signal-set source 2) + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + first [new] [old] :owner-key 'first-owner)) + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + second [new] [old] :owner-key 'second-owner)))) + :type 'tp-transaction-test-error) + (should (equal first [old token 1])) + (should (equal second [old token 1])) + (should + (equal (nreverse trace) + '((apply first-owner) (apply second-owner) + (restore second-owner) (restore first-owner))))))) + +(ert-deftest tp-transaction-test-success-outcome-is-side-channel-only () + "Committed evidence appears after accept without replacing BODY return." + (tp-transaction-test--with-surface (buffer surface source) + (let ((tp--last-transaction-outcome nil)) + (should (eq (tp-with-transaction + (tp-signal-set source 2) + 'body-value) + 'body-value)) + (should (tp-committed-success-outcome-p + tp--last-transaction-outcome)) + (should-not (tp-publication-failure-outcome-p + tp--last-transaction-outcome)) + (tp-transaction-test--should-match-outcome-counts + tp--last-transaction-outcome (list surface)) + (should (eq (plist-get + (tp--committed-success-outcome-snapshot + tp--last-transaction-outcome) + :tag) + 'committed-success)) + (should-not (fboundp 'tp-committed-success-outcome-promote)) + (should-not (fboundp 'tp-committed-success-outcome-mutate))))) + +(ert-deftest tp-transaction-test-failure-outcome-is-observational () + "Failure evidence preserves the primary condition and cannot pass success." + (tp-transaction-test--with-surface (buffer surface source) + (let ((tp--last-transaction-outcome nil) + (old-text (with-current-buffer buffer (buffer-string))) + (old-revision (tp-surface-revision surface)) + (injected '(tp-transaction-test-error :phase precommit)) + (tp-transaction-test--precommit-condition + '(tp-transaction-test-error :phase precommit)) + (tp--transaction-precommit-functions + '(tp--transaction-test-precommit-inject)) + (tp--transaction-precommit-allowed-functions + '(tp--transaction-test-precommit-inject))) + (should (equal (tp-transaction-test--capture + (lambda () (tp-signal-set source 2))) + injected)) + (should (tp-publication-failure-outcome-p + tp--last-transaction-outcome)) + (should-not (tp-committed-success-outcome-p + tp--last-transaction-outcome)) + (should-not (tp--committed-success-outcome-valid-for-p + tp--last-transaction-outcome 'any-batch)) + (should (equal (plist-get tp--last-shadow-proof :phase) 'rollback)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (should (plist-get tp--last-shadow-proof :outcome-equivalent)) + (should (= (plist-get tp--last-shadow-proof :entry-count) 1)) + (should (= (tp-surface-revision surface) old-revision)) + (with-current-buffer buffer + (should (equal (buffer-string) old-text)))))) + +(ert-deftest tp-transaction-test-success-outcome-binding-rejects-replay () + "Outcome validation rejects a different candidate at the same revision." + (with-temp-buffer + (let* ((entry (tp-transaction-test--entry)) + (candidate + (tp-transaction-test--set-batch-proof-fields + (tp-transaction-test--batch (list entry))))) + (dolist (state '(staged participants precommit final-accepting committed)) + (tp--publication-batch-transition candidate state)) + (let* ((outcome + (tp--committed-success-outcome-finalize + (tp--committed-success-outcome-draft + candidate '(:text 1) '(:total 0.1) nil 0))) + (replay-entry + (tp-transaction-test--entry + :candidate-id 'same-revision-different-candidate + :authority-token 'different-authority)) + (replay + (tp-transaction-test--set-batch-proof-fields + (tp-transaction-test--batch (list replay-entry))))) + (dolist (state + '(staged participants precommit final-accepting committed)) + (tp--publication-batch-transition replay state)) + (should (tp--committed-success-outcome-valid-for-p + outcome candidate 3)) + (should-not (tp--committed-success-outcome-valid-for-p + outcome replay 3)) + (should-not (tp--committed-success-outcome-valid-for-p + outcome candidate 4)) + (setcar (cdr (tp-committed-success-outcome-operation-counts outcome)) + 2) + (should-not (tp--committed-success-outcome-valid-for-p + outcome candidate 3)) + (should (equal (buffer-string) "")))))) + +(ert-deftest tp-transaction-test-outcome-rejects-cross-surface-and-mount-replay () + "Exact replay rejects cross-surface and different-mount candidates purely." + (let ((first-buffer (generate-new-buffer " *tp-replay-first*")) + (second-buffer (generate-new-buffer " *tp-replay-second*")) + (state (vector 'unchanged))) + (unwind-protect + (progn + (with-current-buffer first-buffer (insert "first")) + (with-current-buffer second-buffer (insert "second")) + (let* ((entry + (with-current-buffer first-buffer + (tp-transaction-test--entry :buffer first-buffer))) + (candidate + (tp-transaction-test--set-batch-proof-fields + (tp-transaction-test--batch (list entry))))) + (dolist (next + '(staged participants precommit final-accepting committed)) + (tp--publication-batch-transition candidate next)) + (let* ((outcome + (tp--committed-success-outcome-finalize + (tp--committed-success-outcome-draft + candidate '(:text 1) '(:total 0.1) nil 0))) + (cross-entry + (with-current-buffer second-buffer + (tp-transaction-test--entry + :surface-id 'surface-b :buffer second-buffer + :authority-token 'entry-authority-b))) + (mount-entry + (with-current-buffer first-buffer + (tp-transaction-test--entry + :mount-ids '(different-mount)))) + (cross + (tp-transaction-test--set-batch-proof-fields + (tp-transaction-test--batch (list cross-entry)))) + (mount + (tp-transaction-test--set-batch-proof-fields + (tp-transaction-test--batch (list mount-entry))))) + (dolist (replay (list cross mount)) + (dolist (next + '(staged participants precommit + final-accepting committed)) + (tp--publication-batch-transition replay next)) + (should-not + (tp--committed-success-outcome-valid-for-p + outcome replay 3))) + (should (equal state [unchanged])) + (with-current-buffer first-buffer + (should (equal (buffer-string) "first"))) + (with-current-buffer second-buffer + (should (equal (buffer-string) "second")))))) + (when (buffer-live-p first-buffer) (kill-buffer first-buffer)) + (when (buffer-live-p second-buffer) (kill-buffer second-buffer))))) + +(ert-deftest tp-transaction-test-multifragment-mount-ids-are-stable-in-outcome () + "One logical object's distinct fragment mounts retain exact outcome IDs." + (let ((buffer (generate-new-buffer " *tp-multifragment-outcome*")) + (left "A") (right "C") logical) + (unwind-protect + (let* ((producer + (lambda (context) + (let* ((root (tp-object-ensure context nil 'root 'group)) + (left-object + (tp-object-ensure context root 'left 'text)) + (gap-object + (tp-object-ensure context root 'gap 'text)) + (right-object + (tp-object-ensure context root 'right 'text))) + (setq logical + (tp-object-ensure context root 'logical 'item)) + (tp-object-retain context logical) + (tp-object-attach-fragment + context logical left-object '(:slot left)) + (tp-object-attach-fragment + context logical right-object '(:slot right)) + (ignore gap-object)) + (tp-surface-plan-create + :key 'root :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create + :key 'left :kind 'text :text left :capability 'content) + (tp-surface-plan-create + :key 'gap :kind 'text :text "|" :capability 'content) + (tp-surface-plan-create + :key 'right :kind 'text :text right + :capability 'content))))) + (surface + (tp-surface-mount buffer producer '(:capability content))) + (before + (mapcar #'tp--ensure-surface-mount-id + (cl-remove-if-not + (lambda (mount) + (eq (tp--surface-mount-object mount) logical)) + (tp--surface-mounts surface))))) + (should (= (length before) 2)) + (should-not (= (car before) (cadr before))) + (setq left "LEFT" right "RIGHT") + (tp-surface-update-scoped surface (list logical) producer) + (let* ((after + (mapcar #'tp--ensure-surface-mount-id + (cl-remove-if-not + (lambda (mount) + (eq (tp--surface-mount-object mount) logical)) + (tp--surface-mounts surface)))) + (entry (car (tp-committed-success-outcome-entries + tp--last-transaction-outcome))) + (outcome-ids + (tp-publication-outcome-entry-mount-ids entry))) + (should (equal after before)) + (dolist (id before) + (should (memq id outcome-ids))) + (tp-transaction-test--should-match-outcome-counts + tp--last-transaction-outcome (list surface)) + (should (plist-get tp--last-shadow-proof :equivalent)))) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest tp-transaction-test-candidates-remain-invisible-until-staged () + "Preparing a candidate does not mutate any live buffer or revision." + (tp-transaction-test--with-surface (buffer surface source) + (let ((text (with-current-buffer buffer (buffer-string))) + (revision (tp-surface-revision surface))) + (with-current-buffer buffer + (tp-transaction-test--batch + (list (tp-transaction-test--entry + :surface-id (tp--surface-id surface) + :buffer buffer + :old-revision revision + :new-revision (1+ revision))))) + (should (= (tp-surface-revision surface) revision)) + (with-current-buffer buffer + (should (equal (buffer-string) text)))))) + +(ert-deftest tp-transaction-test-shadow-is-multisurface-and-single-writer () + "Shadow artifacts cover all surfaces while each live writer runs once." + (let* ((source (tp-signal-create 1)) + (producer (tp-transaction-test--producer source)) + (first-buffer (generate-new-buffer " *tp-transaction-first*")) + (second-buffer (generate-new-buffer " *tp-transaction-second*")) + (first (tp-surface-mount first-buffer producer '(:capability content))) + (second (tp-surface-mount second-buffer producer '(:capability content))) + (calls (make-hash-table :test #'eq)) + (writer (symbol-function 'tp--publish-one-surface)) + (tp--last-transaction-outcome nil)) + (unwind-protect + (cl-letf (((symbol-function 'tp--publish-one-surface) + (lambda (prepared) + (let ((surface (tp--prepared-surface-surface prepared))) + (puthash surface (1+ (gethash surface calls 0)) calls)) + (funcall writer prepared)))) + (let ((tp--transaction-artifact-mode 'shadow)) + (tp-signal-set source 2)) + (should (= (gethash first calls 0) 1)) + (should (= (gethash second calls 0) 1)) + (should (tp-committed-success-outcome-p + tp--last-transaction-outcome)) + (tp-transaction-test--should-match-outcome-counts + tp--last-transaction-outcome (list first second)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (should (plist-get tp--last-shadow-proof :outcome-equivalent)) + (should (integerp + (tp-committed-success-outcome-mapping-generation + tp--last-transaction-outcome))) + (should (= (length (tp-committed-success-outcome-entries + tp--last-transaction-outcome)) + 2)) + (dolist (entry (tp-committed-success-outcome-entries + tp--last-transaction-outcome)) + (should (= (tp-publication-outcome-entry-new-revision entry) + (1+ (tp-publication-outcome-entry-old-revision entry)))) + (should (= (tp-publication-outcome-entry-mapping-generation entry) + (tp-committed-success-outcome-mapping-generation + tp--last-transaction-outcome))))) + (when (buffer-live-p first-buffer) (kill-buffer first-buffer)) + (when (buffer-live-p second-buffer) (kill-buffer second-buffer)) + (when (tp-signal-live-p source) (tp-signal-dispose source))))) + +(ert-deftest tp-transaction-test-zero-surface-does-not-create-batch-or-outcome () + "Pure, semantic and external-only transactions stay outside batch API." + (let ((tp--last-transaction-outcome 'sentinel) + captured-batch captured-outcome) + (should (eq (tp-with-transaction + (setq captured-batch tp--transaction-publication-batch + captured-outcome tp--transaction-outcome) + 'pure-result) + 'pure-result)) + (should-not captured-batch) + (should-not captured-outcome) + (should-not tp--last-transaction-outcome) + (tp-with-transaction + (tp-transaction-participate 'external-only #'ignore #'ignore)) + (should-not tp--last-transaction-outcome))) + +(ert-deftest tp-transaction-test-unobserved-signal-excludes-publication-batch () + "An unobserved semantic signal commit creates no publication evidence." + (let ((signal (tp-signal-create 1)) + (begin-batch (symbol-function 'tp--transaction-begin-publication-batch)) + (batch-calls 0)) + (unwind-protect + (cl-letf (((symbol-function 'tp--transaction-begin-publication-batch) + (lambda (&rest arguments) + (cl-incf batch-calls) + (apply begin-batch arguments)))) + (tp-signal-set signal 2) + (should (= (tp-signal-peek signal) 2)) + (should (= (tp-signal-revision signal) 1)) + (should (= batch-calls 0)) + (should-not tp--last-transaction-outcome) + (should-not tp--last-shadow-proof)) + (when (tp-signal-live-p signal) (tp-signal-dispose signal))))) + +(ert-deftest tp-transaction-test-surface-unmount-excludes-publication-batch () + "Surface teardown uses its external path without batch or outcome evidence." + (let* ((buffer (generate-new-buffer " *tp-unmount-exclusion*")) + (surface + (tp-surface-mount + buffer (tp-transaction-test--leaf "mounted") + '(:capability content))) + (begin-batch (symbol-function 'tp--transaction-begin-publication-batch)) + (batch-calls 0)) + (unwind-protect + (progn + (setq tp--last-transaction-outcome nil + tp--last-shadow-proof nil) + (cl-letf + (((symbol-function 'tp--transaction-begin-publication-batch) + (lambda (&rest arguments) + (cl-incf batch-calls) + (apply begin-batch arguments)))) + (tp-surface-unmount surface)) + (should (= batch-calls 0)) + (should-not tp--last-transaction-outcome) + (should-not tp--last-shadow-proof) + (should-not (tp-surface-live-p surface)) + (with-current-buffer buffer + (should (equal (buffer-string) "")))) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest tp-transaction-test-output-equal-does-not-create-batch-or-outcome () + "A recompute with no surface artifact change stays outside batch API." + (let* ((buffer (generate-new-buffer " *tp-transaction-output-equal*")) + (source (tp-signal-create 1)) + (surface + (tp-surface-mount + buffer + (lambda (context) + (tp-object-ensure context nil 'root 'text) + (tp-signal-read source) + (tp-transaction-test--leaf "constant")) + '(:capability content))) + (revision (tp-surface-revision surface)) + (tp--last-transaction-outcome 'sentinel) + captured-batch) + (unwind-protect + (progn + (tp-with-transaction + (tp-signal-set source 2) + (setq captured-batch tp--transaction-publication-batch)) + (should-not captured-batch) + (should-not tp--last-transaction-outcome) + (should (= (tp-surface-revision surface) revision)) + (with-current-buffer buffer + (should (equal (buffer-string) "constant")))) + (when (buffer-live-p buffer) (kill-buffer buffer)) + (when (tp-signal-live-p source) (tp-signal-dispose source))))) + +(ert-deftest tp-transaction-test-live-candidate-is-body-invisible-and-outcome-cell-separated () + "The body sees old live state while its retained cell receives evidence." + (tp-transaction-test--with-surface (buffer surface source) + (let ((old-revision (tp-surface-revision surface)) + outcome-cell body-batch body-text body-revision) + (should + (eq + (tp-with-transaction + (tp-signal-set source 2) + (setq outcome-cell (tp--transaction-current-outcome-cell) + body-batch tp--transaction-publication-batch + body-text (with-current-buffer buffer (buffer-string)) + body-revision (tp-surface-revision surface)) + 'body-result) + 'body-result)) + (should-not body-batch) + (should (equal body-text "1")) + (should (= body-revision old-revision)) + (should (vectorp outcome-cell)) + (should (= (length outcome-cell) 1)) + (should (tp-committed-success-outcome-p (aref outcome-cell 0))) + (should (eq (aref outcome-cell 0) tp--last-transaction-outcome)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (should (plist-get tp--last-shadow-proof :outcome-equivalent)) + (should (= (tp-surface-revision surface) (1+ old-revision))) + (with-current-buffer buffer + (should (equal (buffer-string) "2")))))) + +(ert-deftest tp-transaction-test-scoped-content-shadow-equivalence () + "Scoped content artifacts equal the single committed writer result." + (let ((buffer (generate-new-buffer " *tp-transaction-scoped*")) + (middle "B") + (middle-face 'bold) + middle-object) + (unwind-protect + (let* ((producer + (lambda (context) + (let ((root (tp-object-ensure context nil 'root 'group))) + (tp-object-ensure context root 'left 'text) + (setq middle-object + (tp-object-ensure context root 'middle 'text)) + (tp-object-ensure context root 'right 'text)) + (tp-surface-plan-create + :key 'root :kind 'group :capability 'content + :children + (list + (tp-surface-plan-create + :key 'left :kind 'text :text "A" + :capability 'content) + (tp-surface-plan-create + :key 'middle :kind 'text :text middle + :props (list 'face middle-face) + :capability 'content) + (tp-surface-plan-create + :key 'right :kind 'text :text "C" + :capability 'content))))) + (surface + (tp-surface-mount buffer producer '(:capability content))) + (revision (tp-surface-revision surface))) + (setq middle "LONG" + middle-face 'italic) + (let ((tp--transaction-artifact-mode 'shadow)) + (tp-surface-update-scoped + surface (list middle-object) producer)) + (should (= (tp-surface-revision surface) (1+ revision))) + (with-current-buffer buffer + (should (equal (buffer-string) "ALONGC")) + (should (eq (get-text-property 2 'face) 'italic))) + (should (tp-committed-success-outcome-p + tp--last-transaction-outcome)) + (tp-transaction-test--should-match-outcome-counts + tp--last-transaction-outcome (list surface)) + (should (equal (plist-get tp--last-shadow-proof :phase) 'commit)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (should (plist-get tp--last-shadow-proof :outcome-equivalent)) + (should (= (plist-get tp--last-shadow-proof :entry-count) 1))) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest tp-transaction-test-properties-only-shadow-equivalence () + "Properties-only artifacts equal live properties without replacing text." + (let ((buffer (generate-new-buffer " *tp-transaction-properties*")) + (value 'bold)) + (unwind-protect + (with-current-buffer buffer + (insert "host") + (let* ((anchor (tp-range-anchor-create buffer 1 5)) + (producer + (lambda (context) + (let ((object + (tp-object-ensure context nil 'root 'range))) + (tp-object-attach-range context object anchor)) + (tp-surface-plan-create + :key 'root :kind 'range :props (list 'face value) + :capability 'properties))) + (surface + (tp-surface-mount + buffer producer '(:capability properties))) + (revision (tp-surface-revision surface))) + (setq value 'italic) + (let ((tp--transaction-artifact-mode 'shadow)) + (tp-surface-update surface producer)) + (should (equal (buffer-string) "host")) + (should (eq (get-text-property 2 'face) 'italic)) + (should (= (tp-surface-revision surface) (1+ revision))) + (should (tp-committed-success-outcome-p + tp--last-transaction-outcome)) + (tp-transaction-test--should-match-outcome-counts + tp--last-transaction-outcome (list surface)) + (should (equal (plist-get tp--last-shadow-proof :phase) 'commit)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (should (plist-get tp--last-shadow-proof :outcome-equivalent)) + (should (= (plist-get tp--last-shadow-proof :entry-count) 1)))) + (when (buffer-live-p buffer) (kill-buffer buffer))))) + +(ert-deftest tp-transaction-test-property-surface-fault-matrix-restores-exact-state () + "Every late fault restores exact multi-surface property publication state." + (dolist (phase '(second-surface participant precommit final-accept)) + (let* ((source (tp-signal-create 1)) + (first-buffer (generate-new-buffer " *tp-property-fault-first*")) + (second-buffer + (generate-new-buffer " *tp-property-fault-second*")) + first-anchor second-anchor first second first-state second-state + (injected + (list 'tp-transaction-test-error :phase phase :payload '(raw)))) + (unwind-protect + (progn + (with-current-buffer first-buffer + (insert "first") + (goto-char 3) + (setq first-anchor + (tp-range-anchor-create first-buffer 1 (point-max)))) + (with-current-buffer second-buffer + (insert "second") + (goto-char 4) + (setq second-anchor + (tp-range-anchor-create second-buffer 1 (point-max)))) + (setq first + (with-current-buffer first-buffer + (tp-surface-mount + first-buffer + (tp-transaction-test--property-producer + source first-anchor) + '(:capability properties))) + second + (with-current-buffer second-buffer + (tp-surface-mount + second-buffer + (tp-transaction-test--property-producer + source second-anchor) + '(:capability properties))) + first-state (tp-transaction-test--property-state first) + second-state (tp-transaction-test--property-state second)) + (let ((tp--surface-publication-step-function + (and + (eq phase 'second-surface) + (lambda (step surface) + (when (and (eq step 'client-state) + (eq surface second)) + (signal (car injected) (cdr injected)))))) + (tp-transaction-test--precommit-condition + (and (eq phase 'precommit) injected)) + (tp--transaction-precommit-functions + (if (eq phase 'precommit) + '(tp--transaction-test-precommit-inject) + tp--transaction-precommit-functions)) + (tp--transaction-precommit-allowed-functions + (if (eq phase 'precommit) + '(tp--transaction-test-precommit-inject) + tp--transaction-precommit-allowed-functions))) + (should + (equal + (cl-letf + (((symbol-function 'accept-change-group) + (let ((accept (symbol-function 'accept-change-group))) + (lambda (group) + (if (eq phase 'final-accept) + (signal (car injected) (cdr injected)) + (funcall accept group)))))) + (tp-transaction-test--capture + (lambda () + (tp-with-transaction + (when (eq phase 'participant) + (tp-transaction-participate + 'property-fault-participant + (lambda () + (signal (car injected) (cdr injected))) + #'ignore)) + (tp-signal-set source 2))))) + injected))) + (should (= (tp-signal-peek source) 1)) + (should (= (tp-signal-revision source) 0)) + (tp-transaction-test--should-match-property-state + first first-state) + (tp-transaction-test--should-match-property-state + second second-state) + (with-current-buffer first-buffer + (should (eq (get-text-property 2 'face) 'bold))) + (with-current-buffer second-buffer + (should (eq (get-text-property 2 'face) 'bold))) + (should (tp-publication-failure-outcome-p + tp--last-transaction-outcome)) + (should (equal (plist-get tp--last-shadow-proof :phase) + 'rollback)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (should (plist-get tp--last-shadow-proof :outcome-equivalent)) + (should (= (plist-get tp--last-shadow-proof :entry-count) 2))) + (when (buffer-live-p first-buffer) (kill-buffer first-buffer)) + (when (buffer-live-p second-buffer) (kill-buffer second-buffer)) + (when (tp-signal-live-p source) (tp-signal-dispose source)))))) + +(ert-deftest tp-transaction-test-v1-and-shadow-artifact-modes-are-equivalent () + "Independent v1 and shadow surfaces commit identical live artifacts." + (let* ((v1-buffer (generate-new-buffer " *tp-transaction-v1*")) + (shadow-buffer (generate-new-buffer " *tp-transaction-shadow*")) + (initial + (tp-surface-plan-create + :key 'root :kind 'text :text "old" :props '(face bold) + :capability 'content)) + (next + (tp-surface-plan-create + :key 'root :kind 'text :text "new" :props '(face italic) + :capability 'content)) + (v1-surface + (tp-surface-mount v1-buffer initial '(:capability content))) + (shadow-surface + (tp-surface-mount shadow-buffer initial '(:capability content))) + (writer (symbol-function 'tp--publish-one-surface)) + (shadow-writes 0)) + (unwind-protect + (progn + (let ((tp--transaction-artifact-mode 'v1)) + (tp-surface-update v1-surface next)) + (should-not tp--last-transaction-outcome) + (should-not tp--last-shadow-proof) + (cl-letf (((symbol-function 'tp--publish-one-surface) + (lambda (prepared) + (cl-incf shadow-writes) + (funcall writer prepared)))) + (let ((tp--transaction-artifact-mode 'shadow)) + (tp-surface-update shadow-surface next))) + (should (= shadow-writes 1)) + (should (tp-committed-success-outcome-p + tp--last-transaction-outcome)) + (should (plist-get tp--last-shadow-proof :equivalent)) + (should (plist-get tp--last-shadow-proof :outcome-equivalent)) + (should (= (tp-surface-revision v1-surface) + (tp-surface-revision shadow-surface))) + (should + (equal-including-properties + (with-current-buffer v1-buffer (buffer-string)) + (with-current-buffer shadow-buffer (buffer-string)))) + (with-current-buffer v1-buffer + (should (equal (buffer-string) "new")) + (should (eq (get-text-property 1 'face) 'italic)))) + (when (buffer-live-p v1-buffer) (kill-buffer v1-buffer)) + (when (buffer-live-p shadow-buffer) (kill-buffer shadow-buffer))))) + +(ert-deftest tp-transaction-test-ordinary-update-success-has-zero-markers () + "An ordinary publication records zero final authority markers." + (tp-transaction-test--with-surface (buffer _surface source) + (tp-signal-set source 2) + (should (tp-committed-success-outcome-p tp--last-transaction-outcome)) + (should (= (tp-committed-success-outcome-marker-count + tp--last-transaction-outcome) + 0)) + (let ((timings + (tp-committed-success-outcome-phase-timings + tp--last-transaction-outcome))) + (dolist (phase '(body recompute publication participants + precommit signal-commit)) + (should (numberp (alist-get phase timings))) + (should (>= (alist-get phase timings) 0.0)))))) + +(ert-deftest tp-transaction-test-final-marker-global-count-bound () + "The fixed marker registry rejects one owner beyond its global bound." + (tp-transaction-test--with-surface (buffer _surface source) + (let (targets) + (dotimes (_ tp--final-marker-max-count) + (push (vector 'old 'token 1) targets)) + (setq targets (nreverse targets)) + (tp-with-transaction + (tp-signal-set source 2) + (cl-loop for target in targets + for index from 0 + do + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + target [new] [old] + :owner-key (intern (format "owner-%d" index))))) + (let ((extra (vector 'old 'token 1))) + (should-error + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + extra [new] [old] :owner-key 'owner-overflow)) + :type 'tp-final-marker-error) + (should (eq (aref extra 0) 'old)))) + (dolist (target targets) + (should (eq (aref target 0) 'new)))))) + +(ert-deftest tp-transaction-test-final-marker-aggregate-slot-write-bound () + "Real three-slot and one-slot payloads obey the aggregate write bound." + (tp-transaction-test--with-surface (buffer _surface source) + (let ((three-slot-targets + (cl-loop repeat 5 collect + (vector 'old 'old 'old 'token 1))) + (one-slot-target (vector 'old 'token 1)) + (overflow-target (vector 'old 'token 1))) + (tp-with-transaction + (tp-signal-set source 2) + (cl-loop for target in three-slot-targets + for index from 0 + do + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + target [new new new] [old old old] + :owner-key + (intern (format "three-slot-owner-%d" index))))) + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + one-slot-target [new] [old] :owner-key 'one-slot-owner)) + (should-error + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + overflow-target [new] [old] :owner-key 'slot-overflow)) + :type 'tp-final-marker-error)) + (dolist (target three-slot-targets) + (should (equal (seq-subseq target 0 3) [new new new]))) + (should (eq (aref one-slot-target 0) 'new)) + (should (eq (aref overflow-target 0) 'old))))) + +(ert-deftest tp-transaction-test-marker-restore-faults-exhaust-all-markers () + "Restore error, quit, and throw cannot skip markers or v1 rollback." + (dolist (kind '(error quit throw)) + (tp-transaction-test--with-surface (buffer surface source) + (let* ((targets + (list (vector 'old 'token 1) + (vector 'old 'token 1) + (vector 'old 'token 1))) + (revision (tp-surface-revision surface)) + (restore-one (symbol-function + 'tp--transaction-restore-one-final-marker)) + (injected '(tp-transaction-test-error :phase accept)) + result) + (cl-letf + (((symbol-function 'tp--transaction-restore-one-final-marker) + (lambda (marker) + (funcall restore-one marker) + (when (eq (tp-final-accept-marker-owner-key marker) + 'middle-owner) + (pcase kind + ('error + (signal 'tp-transaction-test-error + '(:phase marker-restore))) + ('quit (signal 'quit nil)) + ('throw + (throw 'tp-transaction-test-restore-throw kind)))))) + ((symbol-function 'accept-change-group) + (lambda (_group) (signal (car injected) (cdr injected))))) + (let ((transaction + (lambda () + (tp-with-transaction + (tp-signal-set source 2) + (cl-loop + for target in targets + for owner in '(first-owner middle-owner last-owner) + do + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + target [new] [old] :owner-key owner))))))) + (setq result + (if (eq kind 'throw) + (catch 'tp-transaction-test-restore-throw + (funcall transaction) + 'not-thrown) + (tp-transaction-test--capture transaction))))) + (if (eq kind 'throw) + (should (eq result 'throw)) + (should (equal (seq-take result 3) injected)) + (should (tp--transaction-condition-trailer + result :rollback-failures))) + (dolist (target targets) + (should (equal target [old token 1]))) + (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-transaction-test-participant-after-commit-fault-is-contained () + "After-commit participant failure is diagnostic and stays committed." + (let (participant) + (should + (eq + (tp-with-transaction + (tp--transaction-participate-v2 + :key 'contained-after-commit + :stage #'ignore + :rollback (lambda () + (error "Committed participant must not roll back")) + :after-commit + (lambda () + (signal 'tp-transaction-test-error '(:phase after-commit)))) + (setq participant (car tp--transaction-participants)) + 'body-result) + 'body-result)) + (should (eq (tp--transaction-participant-state participant) 'committed)) + (should + (cl-some + (lambda (entry) + (and (eq (car entry) 'after-commit) + (equal (caddr entry) + '(tp-transaction-test-error :phase after-commit)))) + tp--last-transaction-diagnostics)))) + +(ert-deftest tp-transaction-test-marker-nonlocal-throw-restores-v1-state () + "Marker apply and accept throws reverse authority and live publication." + (dolist (phase '(apply accept)) + (tp-transaction-test--with-surface (buffer surface source) + (let* ((target (vector 'old 'token 1)) + (revision (tp-surface-revision surface)) + (apply-one (symbol-function + 'tp--transaction-apply-one-final-marker)) + (accept (symbol-function 'accept-change-group))) + (should + (eq + (catch 'tp-transaction-test-nonlocal + (cl-letf (((symbol-function + 'tp--transaction-apply-one-final-marker) + (lambda (marker) + (funcall apply-one marker) + (when (eq phase 'apply) + (throw 'tp-transaction-test-nonlocal phase)))) + ((symbol-function 'accept-change-group) + (lambda (group) + (if (eq phase 'accept) + (throw 'tp-transaction-test-nonlocal phase) + (funcall accept group))))) + (tp-with-transaction + (tp-signal-set source 2) + (apply #'tp--transaction-register-final-marker + (tp-transaction-test--marker-arguments + target [new] [old] :owner-key phase)))) + 'not-thrown) + phase)) + (should (equal target [old token 1])) + (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-transaction-test-manifest-advertises-v1-plus-v2 () + "The TP manifest retains v1 while advertising the additive protocol." + (should (eq tp-transaction-protocol + 'tp-transaction-protocol-v1+v2)) + (let ((manifest (tp-runtime-manifest))) + (should (equal (plist-get manifest :version) "1.0.0")) + (should (eq (plist-get manifest :transaction-protocol) + 'tp-transaction-protocol-v1+v2)) + (should (plist-get manifest :batch-artifacts)) + (should (eq (plist-get manifest :batch-execution) 'v1-bridge)) + (should-not (plist-get manifest :batch-execute)) + (should (plist-get manifest :shadow-proof)) + (should (eq (plist-get manifest :final-marker-operation) + 'tp-vector-slots/v1)) + (setf (plist-get manifest :transaction-protocol) 'mutated) + (should (eq (plist-get (tp-runtime-manifest) :transaction-protocol) + 'tp-transaction-protocol-v1+v2)))) + +(provide 'tp-transaction-tests) + +;;; tp-transaction-tests.el ends here diff --git a/tp-core.el b/tp-core.el index ead0c0f..7b9d260 100644 --- a/tp-core.el +++ b/tp-core.el @@ -323,6 +323,7 @@ so dotted tails, shared suffixes, and cycles retain their source topology." (defun tp--copy-proper-cons-list (value cache) "Return a fast memoized copy of uncached proper-list VALUE. +CACHE preserves sharing and cycles across the copied value graph. The whole spine is registered before mutable cars are copied, preserving back-references from cars while `copy-sequence' supplies the spine cheaply." (let ((source value) @@ -352,6 +353,7 @@ back-references from cars while `copy-sequence' supplies the spine cheaply." (defun tp--copy-string-with-properties (value &optional cache reuse-property-p) "Return a copy of string VALUE with recursively copied property values. +CACHE preserves sharing across mutable property values. REUSE-PROPERTY-P, when non-nil, is called with PROPERTY and VALUE. A non-nil result transfers that exact candidate-owned VALUE into the returned string; the caller must ensure that VALUE is not mutated by another owner. Values not @@ -403,6 +405,7 @@ values are recursively isolated." (defun tp--copy-property-value (value &optional cache) "Return a defensive copy of mutable containers in property VALUE. +Optional CACHE preserves sharing and cycles across recursive copies. Cons cells, strings, and vectors are copied recursively. Functions, records, and other opaque objects keep their identity; functions are never executed." (if (not (tp--copy-mutable-property-value-p value)) diff --git a/tp-reactive.el b/tp-reactive.el index d29e2a5..bcd442b 100644 --- a/tp-reactive.el +++ b/tp-reactive.el @@ -18,6 +18,7 @@ (require 'cl-lib) (require 'tp-core) +(require 'tp-transaction) (define-error 'tp-reactive-error "TP reactive runtime error") (define-error 'tp-invalid-signal-scope "Invalid TP signal scope" @@ -43,8 +44,8 @@ (cl-defstruct (tp--transaction-participant (:constructor tp--make-transaction-participant)) - "One rollback-capable side-state participant in a TP transaction." - key publish rollback) + "One structured participant shared by the v1 and v2 transaction views." + key publish rollback protocol order stage precommit after-commit journal state) (cl-defstruct (tp--signal-commit-entry (:constructor tp--make-signal-commit-entry)) @@ -85,10 +86,27 @@ (defvar tp--transaction-after-commit-callbacks nil) (defvar tp--transaction-participants nil) (defvar tp--transaction-participant-keys nil) +(defvar tp--transaction-participant-order 0) (defvar tp--transaction-published-participants nil) (defvar tp--transaction-signal-commit-journal nil) +(defvar tp--transaction-id nil) +(defvar tp--transaction-phase nil) +(defvar tp--transaction-phase-start nil) +(defvar tp--transaction-phase-timings nil) +(defvar tp--transaction-publication-batch nil) +(defvar tp--transaction-final-marker-registry nil) +(defvar tp--transaction-final-marker-owner-keys nil) +(defvar tp--transaction-final-marker-count 0) +(defvar tp--transaction-final-marker-slot-writes 0) +(defvar tp--transaction-final-markers-frozen-p nil) +(defvar tp--transaction-applied-final-marker-count 0) +(defvar tp--transaction-marker-restore-failures nil) +(defvar tp--transaction-outcome nil) +(defvar tp--transaction-outcome-cell nil) (defvar tp--transaction-contained-failures nil) (defvar tp--last-transaction-diagnostics nil) +(defvar tp--last-transaction-outcome nil) +(defvar tp--last-shadow-proof nil) (defvar tp--current-binding nil) (defvar tp--binding-compute-stack nil) (defvar tp--collected-dependency-set nil) @@ -108,6 +126,12 @@ (defvar tp--transaction-rollback-final-functions nil) (defvar tp--transaction-committed-functions nil) +(defvar tp--transaction-artifact-mode 'shadow + "Internal artifact route; the live writer remains the v1 coordinator.") + +(defvar tp--transaction-participant-precommit-allowed-functions nil + "Declared internal structured-participant precommit validators.") + (defconst tp--transaction-condition-trailer-tag (make-symbol "tp--transaction-condition-trailer") "Unforgeable tag separating primary condition data from TP metadata.") @@ -497,7 +521,8 @@ or `retain'." (defun tp--bind-precomputed-in-transaction (owner key compute value dependencies equality lifecycle) - "Install one new initialized binding with explicit DEPENDENCIES." + "Install OWNER's KEY using COMPUTE, VALUE, and explicit DEPENDENCIES. +EQUALITY controls change detection and LIFECYCLE controls candidate omission." (let ((table (tp--owner-binding-table owner t))) (when (gethash key table) (signal 'tp-reactive-error (list :precomputed-binding-exists key))) @@ -526,6 +551,8 @@ or `retain'." (owner key compute value dependencies &key (equality #'equal) (lifecycle 'delete)) "Install a new binding with precomputed VALUE and explicit DEPENDENCIES. +OWNER and KEY identify the binding; EQUALITY and LIFECYCLE retain their normal +`tp-bind' meanings. COMPUTE remains the authoritative recomputation function after any dependency changes. This entry avoids evaluating COMPUTE merely to rediscover a value and graph edges already produced by a compiler or pure projection pass." @@ -624,6 +651,56 @@ When CREATE is non-nil, install and return a fresh hash table when absent." (signal 'tp-reactive-error (list :outside-transaction function))) (push function tp--transaction-after-commit-callbacks)) +(defun tp--transaction-participant-precommit-function-p (function) + "Return non-nil when FUNCTION is a declared internal participant validator." + (or (null function) + (and (symbolp function) + (memq function + tp--transaction-participant-precommit-allowed-functions) + (fboundp function)))) + +(defun tp--transaction-register-participant (participant) + "Register structured PARTICIPANT in the authoritative v1 participant list." + (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 publish rollback protocol precommit after-commit journal) + "Build a participant from KEY, PUBLISH, ROLLBACK, and PROTOCOL. +PRECOMMIT and AFTER-COMMIT are optional internal callbacks; JOURNAL is opaque +owner-local rollback state." + (unless (functionp publish) + (signal 'wrong-type-argument (list 'functionp publish))) + (unless (functionp 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) + :publish publish + :rollback rollback + :protocol protocol + :order (prog1 tp--transaction-participant-order + (cl-incf tp--transaction-participant-order)) + :stage publish + :precommit precommit + :after-commit after-commit + :journal journal + :state 'prepared)) + ;;;###autoload (defun tp-transaction-participate (key publish rollback) "Register rollback-capable PUBLISH work under transaction-local KEY. @@ -631,43 +708,79 @@ PUBLISH runs after every affected surface has published its candidate buffer and side state, but before the transaction commits its source values. If this or any later publication step fails, ROLLBACK runs in reverse publication order. Both functions take no arguments. KEY must be unique in the outer -transaction." +transaction. The public v1 route is retained and receives an internal v2 +structured view over the same participant object." (unless tp--transaction-active (signal 'tp-reactive-error (list :participant-outside-transaction key))) (unless key (signal 'tp-reactive-error (list :participant-key key))) - (unless (functionp publish) - (signal 'wrong-type-argument (list 'functionp publish))) - (unless (functionp rollback) - (signal 'wrong-type-argument (list 'functionp rollback))) - (when (member key tp--transaction-participant-keys) - (signal 'tp-reactive-error (list :duplicate-participant-key key))) - (push (tp--copy-property-value key) tp--transaction-participant-keys) - (push (tp--make-transaction-participant - :key (tp--copy-property-value key) - :publish publish :rollback rollback) - tp--transaction-participants) - key) + (let ((participant + (tp--transaction-make-participant + key publish rollback 'v1-bridge nil nil nil))) + (tp--transaction-register-participant participant) + key)) + +(cl-defun tp--transaction-participate-v2 + (&key key stage rollback precommit after-commit journal) + "Register internal KEY with STAGE and ROLLBACK through the v1 coordinator. +PRECOMMIT and AFTER-COMMIT are optional declared callbacks. JOURNAL is the +participant's opaque owner-local state." + (unless tp--transaction-active + (signal 'tp-reactive-error (list :participant-outside-transaction key))) + (unless key + (signal 'tp-reactive-error (list :participant-key key))) + (tp--transaction-register-participant + (tp--transaction-make-participant + key stage rollback 'v2 precommit after-commit journal))) + +(defun tp--transaction-participants-in-registration-order () + "Return the authoritative participants in deterministic declaration order." + (reverse tp--transaction-participants)) (defun tp--publish-transaction-participants () "Publish registered transaction participants in declaration order." - (dolist (participant (nreverse tp--transaction-participants)) + (dolist (participant (tp--transaction-participants-in-registration-order)) (push participant tp--transaction-published-participants) + ;; Mark first so a stage that mutates and then signals remains rollbackable. + (setf (tp--transaction-participant-state participant) 'staged) (funcall (tp--transaction-participant-publish participant)))) (defun tp--rollback-transaction-participants () "Rollback published participants and return any failures." (let (failures) (dolist (participant tp--transaction-published-participants) - (condition-case failure - (funcall (tp--transaction-participant-rollback participant)) - ((error quit) - (push (list 'participants - (tp--transaction-participant-key participant) - failure) - failures)))) + (unwind-protect + (condition-case failure + (funcall (tp--transaction-participant-rollback participant)) + ((error quit) + (push (list 'participants + (tp--transaction-participant-key participant) + failure) + failures))) + (setf (tp--transaction-participant-state participant) 'rolled-back))) + (dolist (participant tp--transaction-participants) + (when (eq (tp--transaction-participant-state participant) 'prepared) + (setf (tp--transaction-participant-state participant) 'rolled-back))) (nreverse failures))) +(defun tp--run-transaction-participant-precommits () + "Run declared structured participant validators in registration order." + (dolist (participant (tp--transaction-participants-in-registration-order)) + (when-let* ((function (tp--transaction-participant-precommit participant))) + (unless (tp--transaction-participant-precommit-function-p function) + (signal 'tp-reactive-error + (list :invalid-participant-precommit function))) + (funcall function)))) + +(defun tp--commit-transaction-participants () + "Commit participant states and queue their contained after-commit work." + (dolist (participant (tp--transaction-participants-in-registration-order)) + (when (eq (tp--transaction-participant-state participant) 'staged) + (setf (tp--transaction-participant-state participant) 'committed) + (when-let* ((function + (tp--transaction-participant-after-commit participant))) + (tp--enqueue-after-commit function))))) + (defun tp--dequeue-dirty-binding () "Return and remove the next queued dirty binding." (let (binding) @@ -754,6 +867,391 @@ transaction." tp--transaction-final-accept-function function))) (setq tp--transaction-final-accept-function function)) +(defun tp--transaction-v2-artifacts-enabled-p () + "Return non-nil when the additive v2 shadow artifacts are enabled." + (pcase tp--transaction-artifact-mode + ('v1 nil) + ((or 'shadow 'v1+v2-shadow) t) + (_ (signal 'tp-transaction-contract-error + (list :artifact-mode tp--transaction-artifact-mode))))) + +(defun tp--transaction-current-outcome-cell () + "Return the active transaction's caller-retainable one-slot outcome cell." + (unless tp--transaction-active + (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) + "Install BATCH-ID as the candidate for ENTRIES and SURFACE-JOURNALS." + (unless tp--transaction-active + (signal 'tp-reactive-error (list :batch-outside-transaction batch-id))) + (when tp--transaction-publication-batch + (signal 'tp-publication-state-error + (list :duplicate-transaction-batch batch-id))) + (when (tp--transaction-v2-artifacts-enabled-p) + (setq tp--transaction-publication-batch + (tp--publication-batch-prepare + :transaction-id tp--transaction-id + :batch-id batch-id + :entries entries + :participants + (vconcat (tp--transaction-participants-in-registration-order)) + :journals (tp--transaction-batch-journal-view surface-journals) + :final-accept tp--transaction-final-accept-function + :diagnostics nil))) + 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)) + +(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) + (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 v2 artifacts with the single v1 live result for PHASE." + (when (and tp--transaction-publication-batch + (tp--transaction-v2-artifacts-enabled-p)) + (let ((ok t) results outcome-equivalent) + (dolist (entry + (tp-publication-batch-candidate-entries + tp--transaction-publication-batch)) + (let ((validator (tp-publication-target-entry-shadow-validator entry))) + (condition-case failure + (let ((result (and validator (funcall validator entry phase)))) + (setf (tp-publication-target-entry-shadow-actual entry) result + (tp-publication-target-entry-shadow-proven-p entry) + (and result (plist-get result :equivalent))) + (unless (tp-publication-target-entry-shadow-proven-p entry) + (setq ok nil)) + (when (eq phase 'rollback) + (setf (tp-publication-target-entry-rollback-result entry) + (if (plist-get result :equivalent) 'restored 'mismatch) + (tp-publication-target-entry-post-rollback-state entry) + (plist-get result :actual))) + (push result results)) + ((error quit) + (setq ok nil) + (push (list :equivalent nil :failure failure) results))))) + (setq outcome-equivalent + (pcase phase + ('commit + (tp--committed-success-outcome-valid-for-p + tp--transaction-outcome tp--transaction-publication-batch)) + ('rollback + (and tp--transaction-outcome + (tp--publication-failure-outcome-valid-for-p + tp--transaction-outcome + tp--transaction-publication-batch))))) + (when (and (eq phase 'commit) (not outcome-equivalent)) + (setq ok nil)) + (let ((proof (list :phase phase :equivalent ok + :outcome-equivalent outcome-equivalent + :entries (nreverse results)))) + (setf (tp-publication-batch-candidate-shadow-proof + tp--transaction-publication-batch) + proof) + (setq tp--last-shadow-proof + (list :phase phase :equivalent ok + :outcome-equivalent outcome-equivalent + :entry-count + (length + (tp-publication-batch-candidate-entries + tp--transaction-publication-batch)))) + (unless ok + (push (list 'shadow-proof phase proof) + tp--transaction-contained-failures)) + proof)))) + +(defun tp--transaction-finalize-rollback-shadow-outcome () + "Correlate the failure outcome with the already compared rollback artifacts." + (when-let* ((candidate tp--transaction-publication-batch) + (proof (tp-publication-batch-candidate-shadow-proof candidate))) + (let* ((outcome-equivalent + (tp--publication-failure-outcome-valid-for-p + tp--transaction-outcome candidate)) + (equivalent + (and (plist-get proof :equivalent) outcome-equivalent))) + (setq proof (plist-put proof :outcome-equivalent outcome-equivalent) + proof (plist-put proof :equivalent equivalent)) + (setf (tp-publication-batch-candidate-shadow-proof candidate) proof) + (setq tp--last-shadow-proof + (list :phase 'rollback :equivalent equivalent + :outcome-equivalent outcome-equivalent + :entry-count + (length (tp-publication-batch-candidate-entries candidate)))) + (unless equivalent + (push (list 'shadow-proof 'rollback-outcome proof) + tp--transaction-contained-failures)) + proof))) + +(defun tp--transaction-finish-rollback (primary-condition rollback-failures) + "Finalize failure evidence for PRIMARY-CONDITION and ROLLBACK-FAILURES." + (dotimes (index tp--transaction-final-marker-count) + (let ((marker (aref tp--transaction-final-marker-registry index))) + (when (eq (tp-final-accept-marker-state marker) 'prepared) + (setf (tp-final-accept-marker-state marker) 'rolled-back)))) + (when tp--transaction-publication-batch + (let ((candidate tp--transaction-publication-batch)) + (unless (tp--publication-batch-terminal-p candidate) + (if (eq (tp-publication-batch-candidate-state candidate) 'prepared) + (progn + (setf (tp-publication-batch-candidate-state candidate) 'discarded + (tp-publication-batch-candidate-resolution candidate) + 'discarded)) + (tp--publication-batch-transition candidate 'rolled-back))) + (tp--transaction-run-shadow-proof 'rollback) + (when (and primary-condition + (eq (tp-publication-batch-candidate-state candidate) + 'rolled-back)) + (tp--transaction-publish-outcome + (tp--publication-failure-outcome-create + candidate tp--transaction-phase primary-condition rollback-failures + tp--transaction-contained-failures)) + (tp--transaction-finalize-rollback-shadow-outcome))))) + (defun tp--run-contained-transaction-functions (phase functions) "Run postaccept PHASE FUNCTIONS and record contained failures." (dolist (function (tp--transaction-hook-functions functions)) @@ -846,10 +1344,11 @@ transaction." (defun tp--rollback-transaction-state (counter-snapshot) "Restore COUNTER-SNAPSHOT through every rollback phase. Return contained failures in phase order." - (let ((failures (tp--rollback-transaction-participants))) + (let ((failures (copy-sequence tp--transaction-marker-restore-failures))) (setq failures (append failures + (tp--rollback-transaction-participants) (tp--rollback-hook-phase 'rollback-hooks tp--transaction-rollback-functions) (tp--rollback-signal-journal))) @@ -893,8 +1392,14 @@ the primary condition data." (funcall function) (let (after-commit result (tp--transaction-contained-failures nil)) + (setq tp--last-transaction-outcome nil + tp--last-shadow-proof nil) (setq result (let ((tp--transaction-active t) + (tp--transaction-id (tp--next-transaction-id)) + (tp--transaction-phase 'body) + (tp--transaction-phase-start (float-time)) + (tp--transaction-phase-timings nil) (tp--transaction-signal-values (make-hash-table :test #'eq)) (tp--transaction-signals nil) @@ -909,8 +1414,21 @@ the primary condition data." (tp--transaction-after-commit-callbacks nil) (tp--transaction-participants nil) (tp--transaction-participant-keys nil) + (tp--transaction-participant-order 0) (tp--transaction-published-participants nil) (tp--transaction-signal-commit-journal nil) + (tp--transaction-publication-batch nil) + (tp--transaction-final-marker-registry + (make-vector tp--final-marker-max-count nil)) + (tp--transaction-final-marker-owner-keys + (make-vector tp--final-marker-max-count nil)) + (tp--transaction-final-marker-count 0) + (tp--transaction-final-marker-slot-writes 0) + (tp--transaction-final-markers-frozen-p nil) + (tp--transaction-applied-final-marker-count 0) + (tp--transaction-marker-restore-failures nil) + (tp--transaction-outcome nil) + (tp--transaction-outcome-cell (vector nil)) (tp--transaction-final-accept-function #'tp--transaction-noop-final-accept) (counter-snapshot (copy-sequence tp--reactive-counters)) @@ -922,11 +1440,24 @@ the primary condition data." (condition-case condition (progn (setq transaction-result (funcall function)) + (tp--transaction-enter-phase 'recompute) (tp--flush-dirty-bindings) + (tp--transaction-enter-phase 'publication) (run-hooks 'tp--transaction-publish-functions) + (tp--transaction-batch-transition 'participants) + (tp--transaction-enter-phase 'participants) (tp--publish-transaction-participants) + (tp--transaction-batch-transition 'precommit) + (tp--transaction-enter-phase 'precommit) + (tp--run-transaction-participant-precommits) (tp--run-transaction-precommit-functions) + (tp--transaction-freeze-final-markers) + (tp--transaction-sync-publication-batch) + (tp--transaction-enter-phase 'signal-commit) (tp--commit-signal-values) + (tp--transaction-sync-publication-batch) + (tp--transaction-enter-phase 'final-accept) + (tp--transaction-prepare-success-outcome) (condition-case deferred-quit (progn (let ((inhibit-quit t) @@ -941,9 +1472,10 @@ the primary condition data." (list :invalid-final-accept-function tp--transaction-final-accept-function))) - (funcall - tp--transaction-final-accept-function) + (tp--transaction-run-final-accept) (setq success t) + (tp--commit-transaction-participants) + (tp--transaction-run-shadow-proof 'commit) (when quit-flag (setq pending-quit t quit-flag nil)) @@ -976,9 +1508,14 @@ the primary condition data." (let ((inhibit-quit t) (quit-flag nil)) (unwind-protect - (setq rollback-failures - (tp--rollback-transaction-state - counter-snapshot)) + (progn + (setq tp--transaction-phase + (or tp--transaction-phase 'rollback) + rollback-failures + (tp--rollback-transaction-state + counter-snapshot)) + (tp--transaction-finish-rollback + primary-condition rollback-failures)) (setq quit-flag nil))))) (when primary-condition (tp--resignal-transaction-primary diff --git a/tp-surface.el b/tp-surface.el index 7b38ff2..656f93f 100644 --- a/tp-surface.el +++ b/tp-surface.el @@ -121,7 +121,7 @@ producer result to the active prepare transaction." id buffer start end boundary-policy live stale surfaces candidate-context) (cl-defstruct (tp--surface-mount (:constructor tp--make-surface-mount)) - object start end tags capability anchor) + id object start end tags capability anchor) (defun tp--mount-position (position) "Return numeric POSITION for a marker or coordinate mount endpoint." @@ -144,6 +144,7 @@ producer result to the active prepare transaction." (defvar tp--surface-id-counter 0) (defvar tp--object-id-counter 0) +(defvar tp--mount-id-counter 0) (defvar tp--anchor-id-counter 0) (defvar tp--surface-transaction-id 0) (defvar tp--surfaces (make-hash-table :test #'eql :weakness 'value)) @@ -297,6 +298,7 @@ Use `tp-surface-result-create' for ordinary caller-owned plans." PLAN must preserve the committed TP object topology and contain the new text leaf. RENDERED is the final propertized text and RANGES are candidate-local content attachments already associated with PLAN's text leaf. +CLIENT-STATE is opaque owner state and FULL-SURFACE-P asserts complete scope. PROPERTY-CONTRIBUTIONS is an ordered list of relative `:start', `:end', and `:props' plists. TP composes them over RENDERED using registered property merge policy before diff and publication. This entry point is intentionally @@ -478,8 +480,8 @@ Each contribution contains `:start', `:end', and direct `:props'." object)) (defun tp-object-ensure-at (context parent key kind position) - "Return candidate identity at explicit sibling POSITION below PARENT. -KEYED objects retain their normal explicit-key identity; POSITION is used only + "Return CONTEXT identity at explicit sibling POSITION below PARENT. +KEY and KIND identify normal keyed objects; POSITION is used only for anonymous objects. This is the compiled-topology entry point and does not depend on replaying preceding siblings to discover the same slot." (tp--validate-prepare-context context) @@ -1283,7 +1285,7 @@ When RELATIVE is non-nil, return offsets from the surface start." (substring-no-properties text)))) (defun tp--scope-outside-separator-equivalent-p (left right) - "Return non-nil when scoped outside gaps differ only by line separators. + "Return non-nil when scoped outside gaps LEFT and RIGHT are separators. Logical Ebox owners may absorb a newline between two owned rendered runs when one candidate line grows or shrinks. Treating that delimiter as part of the owner preserves scoped publication while still rejecting every non-separator @@ -1375,7 +1377,8 @@ MOUNT-SPECS describe the candidate object ranges and OPTIONS controls mismatch." (defun tp--prepare-retained-content (surface candidate context scope-objects scope-options initial) - "Prepare CANDIDATE without traversing or rendering its unchanged plan. + "Prepare CANDIDATE for SURFACE in CONTEXT without traversing its plan. +SCOPE-OBJECTS and SCOPE-OPTIONS constrain publication; INITIAL must be nil. The candidate is valid only when its plan has the same three-level content surface topology as the committed plan. Its text and content attachments are still validated and published through the ordinary TP transaction phases." @@ -1524,6 +1527,7 @@ END-P selects the right boundary when POSITION lies inside a replacement." (defun tp--commit-batch-retained-mount-state (surface mount-specs context target-extent) "Return exact coordinate updates when SURFACE can retain MOUNT-SPECS. +CONTEXT authenticates candidate objects and TARGET-EXTENT bounds coordinates. The returned cons distinguishes an exact empty update set from a proof miss." (let ((base (marker-position (tp--surface-start surface))) (mounts (tp--surface-mounts surface)) @@ -1974,6 +1978,9 @@ MOUNT-SPECS and SURFACE provide ranges for PROPERTIES." (&key base-revision target-revision base-extent target-extent patches coordinate-patches client-state) "Create a validated precomputed content commit batch. +BASE-REVISION and TARGET-REVISION bind the transition; BASE-EXTENT and +TARGET-EXTENT bind its coordinates. COORDINATE-PATCHES project retained +mounts, and CLIENT-STATE is opaque owner state. PATCHES are ordered plists containing :old-start, :old-end, :new-start, :new-end, and a propertized :replacement string." (unless (and (integerp base-revision) (>= base-revision 0) @@ -2041,6 +2048,7 @@ PATCHES are ordered plists containing :old-start, :old-end, :new-start, (client-state nil client-state-p) reuse-mount-projection) "Return one authenticated producer result carrying precomputed BATCH. +CONTEXT must be the active prepare context. When MOUNT-SPECS is supplied, it is the complete target coordinate projection for the batch. Each spec contains `:object', `:start', `:end', and optional `:tags'. When CLIENT-STATE is supplied, it replaces BATCH's defensive state @@ -2497,6 +2505,60 @@ caller reads the scalar summary from the surface instead." (tp--surface-mount-tags mount))) (tp--surface-mounts surface)))) +(defun tp--ensure-surface-mount-id (mount) + "Return MOUNT's stable private id, allocating it before publication if absent." + (or (tp--surface-mount-id mount) + (setf (tp--surface-mount-id mount) (cl-incf tp--mount-id-counter)))) + +(defun tp--mount-spec-matches-live-p (spec mount capability) + "Return non-nil when SPEC denotes live MOUNT for CAPABILITY." + (and (eq (plist-get spec :object) (tp--surface-mount-object mount)) + (eq capability (tp--surface-mount-capability mount)) + (eq (plist-get spec :anchor) (tp--surface-mount-anchor mount)) + (equal (plist-get spec :tags) (tp--surface-mount-tags mount)))) + +(defun tp--assign-prepared-mount-ids (prepared) + "Bind PREPARED mount specs to stable live or fresh private mount ids." + (let* ((surface (tp--prepared-surface-surface prepared)) + (capability (tp--surface-capability surface)) + (live (tp--surface-mounts surface)) + (live-by-object (tp--surface-mount-index surface)) + (used (make-hash-table :test #'eq))) + (if (tp--prepared-surface-retained-mount-state-p prepared) + (dolist (mount live) (tp--ensure-surface-mount-id mount)) + (setf + (tp--prepared-surface-mount-specs prepared) + (mapcar + (lambda (spec) + (let ((match + (cl-find-if + (lambda (mount) + (and (not (gethash mount used)) + (tp--mount-spec-matches-live-p + spec mount capability))) + (gethash (plist-get spec :object) live-by-object)))) + (when match (puthash match t used)) + (plist-put + spec :mount-id + (if match + (tp--ensure-surface-mount-id match) + (cl-incf tp--mount-id-counter))))) + (tp--prepared-surface-mount-specs prepared)))) + prepared)) + +(defun tp--prepared-target-mount-ids (prepared) + "Return PREPARED's exact ordered target mount identities." + (if (tp--prepared-surface-retained-mount-state-p prepared) + (mapcar #'tp--ensure-surface-mount-id + (tp--surface-mounts + (tp--prepared-surface-surface prepared))) + (mapcar (lambda (spec) (plist-get spec :mount-id)) + (tp--prepared-surface-mount-specs prepared)))) + +(defun tp--live-mount-ids (surface) + "Return SURFACE's exact ordered private mount identities." + (mapcar #'tp--ensure-surface-mount-id (tp--surface-mounts surface))) + (defun tp--content-output-equal-p (prepared) "Return non-nil when PREPARED already matches its content mount." (let ((surface (tp--prepared-surface-surface prepared))) @@ -2691,6 +2753,8 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set." (mapcar (lambda (spec) (tp--make-surface-mount + :id (or (plist-get spec :mount-id) + (cl-incf tp--mount-id-counter)) :object (plist-get spec :object) :start (if coordinate-p (+ base (plist-get spec :start)) @@ -2709,6 +2773,8 @@ When SCOPED is non-nil, inspect only RANGES, including an empty set." (lambda (spec) (let ((anchor (plist-get spec :anchor))) (tp--make-surface-mount + :id (or (plist-get spec :mount-id) + (cl-incf tp--mount-id-counter)) :object (plist-get spec :object) :start (tp--anchor-start anchor) :end (tp--anchor-end anchor) :tags (plist-get spec :tags) :capability 'properties :anchor anchor))) @@ -2898,7 +2964,7 @@ Return the number of text operations." count)) (defun tp--publish-retained-content-text (prepared) - "Publish a full-surface retained content candidate in one text operation. + "Publish PREPARED retained content in one full-surface text operation. The candidate proof guarantees that the retained surface scope is exactly the surface range. RENDERED already carries its final text properties, so a delete/insert preserves the authoritative property runs without constructing @@ -3299,6 +3365,252 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (tp--prepared-surface-surface prepared)))) prepared-list)) +(defun tp--shadow-object-ids (objects) + "Return stable sorted ids from OBJECTS, a list or path-indexed table." + (let (ids) + (if (hash-table-p objects) + (maphash (lambda (_path object) + (push (tp--surface-object-id object) ids)) + objects) + (dolist (object objects) + (push (tp--surface-object-id object) ids))) + (sort ids #'<))) + +(defun tp--shadow-ledger-spec-signature (specs) + "Return the deterministic target signature for ledger SPECS." + (mapcar + (lambda (spec) + (list :start (plist-get spec :start) + :end (plist-get spec :end) + :property (plist-get spec :property) + :baseline-present (plist-get spec :baseline-present) + :baseline-value (plist-get spec :baseline-value) + :published-present (plist-get spec :published-present) + :published-value (plist-get spec :published-value) + :anchors (plist-get spec :anchors))) + specs)) + +(defun tp--shadow-live-ledger-signature (ledger) + "Return the deterministic committed signature for live LEDGER entries." + (mapcar + (lambda (entry) + (list :start (tp--ledger-position (tp--property-ledger-start entry)) + :end (tp--ledger-position (tp--property-ledger-end entry)) + :property (tp--property-ledger-property entry) + :baseline-present (tp--property-ledger-baseline-present entry) + :baseline-value (tp--property-ledger-baseline-value entry) + :published-present (tp--property-ledger-published-present entry) + :published-value (tp--property-ledger-published-value entry) + :anchors (tp--property-ledger-anchors entry))) + ledger)) + +(defun tp--shadow-apply-commit-batch-to-string (string batch) + "Return STRING with BATCH patches applied without touching a buffer." + (let ((result (copy-sequence string))) + (dolist (patch (reverse (tp-commit-batch-patches batch))) + (setq result + (concat (substring result 0 (plist-get patch :old-start)) + (plist-get patch :replacement) + (substring result (plist-get patch :old-end))))) + result)) + +(defun tp--shadow-apply-property-operations-to-string + (string base operations) + "Return STRING with absolute property OPERATIONS rebased from BASE." + (let ((result (copy-sequence string))) + (dolist (operation operations) + (let ((start (- (plist-get operation :start) base)) + (end (- (plist-get operation :end) base)) + (property (plist-get operation :property))) + (if (plist-get operation :present) + (put-text-property start end property + (plist-get operation :value) result) + (remove-list-of-text-properties start end (list property) result)))) + result)) + +(defun tp--shadow-surface-output (surface) + "Return SURFACE's current text and direct properties as one snapshot." + (pcase-let ((`(,start . ,end) (tp--surface-range surface))) + (with-current-buffer (tp--surface-buffer surface) + (buffer-substring start end)))) + +(defun tp--shadow-target-output (prepared old-output) + "Return PREPARED's expected publication output from OLD-OUTPUT." + (let ((surface (tp--prepared-surface-surface prepared))) + (if (eq (tp--surface-capability surface) 'content) + (if-let* ((batch (tp--prepared-surface-commit-batch prepared))) + (tp--shadow-apply-commit-batch-to-string old-output batch) + (copy-sequence (tp--prepared-surface-rendered prepared))) + (pcase-let ((`(,start . ,_end) (tp--surface-range surface))) + (tp--shadow-apply-property-operations-to-string + old-output start + (tp--prepared-surface-property-operations prepared)))))) + +(defun tp--shadow-view-point (views buffer) + "Return BUFFER's numeric point snapshot from transaction VIEWS." + (when-let* ((state (cl-find buffer views :key #'car :test #'eq))) + (marker-position (cadr state)))) + +(defun tp--shadow-prepared-diff (prepared) + "Return PREPARED's deterministic v2 diff artifact." + (cond + ((tp--prepared-surface-commit-batch prepared) + (let ((batch (tp--prepared-surface-commit-batch prepared))) + (list :kind 'commit-batch + :patches (tp-commit-batch-patches batch) + :coordinate-patches (tp-commit-batch-coordinate-patches batch)))) + ((and (tp--prepared-surface-scope-objects prepared) + (not (tp--prepared-surface-scope-fallback prepared))) + (list :kind 'scoped + :patches (tp--prepared-surface-scope-patches prepared))) + (t + (list :kind 'full + :target-extent + (and (tp--prepared-surface-rendered prepared) + (length (tp--prepared-surface-rendered prepared))))))) + +(defun tp--shadow-artifact-equal-p (expected actual) + "Return non-nil when EXPECTED and ACTUAL publication artifacts are equal." + (and (eq (plist-get expected :buffer) (plist-get actual :buffer)) + (= (plist-get expected :revision) (plist-get actual :revision)) + (eq (plist-get expected :plan) (plist-get actual :plan)) + (eq (plist-get expected :client-state) + (plist-get actual :client-state)) + (equal (plist-get expected :object-ids) + (plist-get actual :object-ids)) + (equal (plist-get expected :mount-ids) + (plist-get actual :mount-ids)) + (equal (plist-get expected :mounts) (plist-get actual :mounts)) + (equal (plist-get expected :ledger) (plist-get actual :ledger)) + (= (plist-get expected :point) (plist-get actual :point)) + (equal-including-properties + (plist-get expected :output) (plist-get actual :output)))) + +(defun tp--shadow-current-artifact (surface) + "Return a normalized read-only artifact for current SURFACE state." + (list :buffer (tp--surface-buffer surface) + :revision (tp--surface-revision surface) + :plan (tp--surface-plan surface) + :client-state (tp--surface-client-state surface) + :object-ids (tp--shadow-object-ids (tp--surface-objects surface)) + :mount-ids (tp--live-mount-ids surface) + :mounts (tp--live-mount-signature surface) + :ledger (tp--shadow-live-ledger-signature (tp--surface-ledger surface)) + :point (with-current-buffer (tp--surface-buffer surface) (point)) + :output (tp--shadow-surface-output surface))) + +(defun tp--surface-shadow-target-entry + (prepared snapshot journals views batch-id) + "Build a BATCH-ID target view over PREPARED and SNAPSHOT. +JOURNALS and VIEWS are exact references to the existing v1 rollback state." + (let* ((prepared (tp--assign-prepared-mount-ids prepared)) + (surface (tp--prepared-surface-surface prepared)) + (buffer (tp--surface-buffer surface)) + (old-output (tp--shadow-surface-output surface)) + (old-mounts (tp--live-mount-signature surface)) + (old-ledger + (tp--shadow-live-ledger-signature + (tp--surface-snapshot-ledger snapshot))) + (point (tp--shadow-view-point views buffer)) + (commit-expected + (list :buffer buffer + :revision (1+ (tp--surface-snapshot-revision snapshot)) + :plan (tp--prepared-surface-plan prepared) + :client-state (tp--prepared-surface-client-state prepared) + :object-ids + (tp--shadow-object-ids + (tp--prepared-surface-objects prepared)) + :mount-ids (tp--prepared-target-mount-ids prepared) + :mounts (tp--prepared-mount-signature prepared) + :ledger + (tp--shadow-ledger-spec-signature + (tp--prepared-surface-ledger-specs prepared)) + :point point + :output (tp--shadow-target-output prepared old-output))) + (rollback-expected + (list :buffer buffer + :revision (tp--surface-snapshot-revision snapshot) + :plan (tp--surface-snapshot-plan snapshot) + :client-state (tp--surface-snapshot-client-state snapshot) + :object-ids + (tp--shadow-object-ids + (tp--surface-snapshot-objects snapshot)) + :mount-ids + (mapcar #'tp--ensure-surface-mount-id + (tp--surface-snapshot-mounts snapshot)) + :mounts old-mounts + :ledger old-ledger + :point point + :output old-output)) + (expected (list :commit commit-expected + :rollback rollback-expected))) + (tp--publication-target-entry-create + :transaction-id tp--transaction-id + :batch-id batch-id + :candidate-id (tp--next-publication-candidate-id) + :surface-id (tp--surface-id surface) + :mount-ids (tp--prepared-target-mount-ids prepared) + :buffer buffer + :old-revision (tp--surface-snapshot-revision snapshot) + :new-revision (1+ (tp--surface-snapshot-revision snapshot)) + :plan (tp--prepared-surface-plan prepared) + :diff (tp--shadow-prepared-diff prepared) + :ledger (tp--prepared-surface-ledger-specs prepared) + :objects (tp--prepared-surface-objects prepared) + :ranges (tp--prepared-surface-mount-specs prepared) + :client-state (tp--prepared-surface-client-state prepared) + :rollback-snapshot (vector prepared snapshot journals views) + :authority-token (make-symbol "tp-publication-entry-authority") + :mapping-generation tp--surface-transaction-id + :shadow-expected expected + :shadow-validator + (lambda (_entry phase) + (let* ((target (plist-get expected + (if (eq phase 'commit) + :commit + :rollback))) + (actual (tp--shadow-current-artifact surface))) + (list :equivalent (tp--shadow-artifact-equal-p target actual) + :surface-id (tp--surface-id surface) + :expected target :actual actual)))))) + +(defun tp--surface-shadow-target-entries + (prepared snapshots journals views batch-id) + "Return BATCH-ID entries for PREPARED using SNAPSHOTS, JOURNALS, and VIEWS." + (mapcar + (lambda (candidate) + (let ((snapshot (cdr (assq candidate snapshots)))) + (unless snapshot + (signal 'tp-surface-error (list :missing-shadow-snapshot candidate))) + (tp--surface-shadow-target-entry + candidate snapshot journals views batch-id))) + prepared)) + +(defun tp--surface-record-publication-operation-counts (prepared) + "Record PREPARED's actual v1 report counts into its exact batch entry." + (when tp--transaction-publication-batch + (let* ((surface (tp--prepared-surface-surface prepared)) + (entry + (cl-find + (tp--surface-id surface) + (tp-publication-batch-candidate-entries + tp--transaction-publication-batch) + :key #'tp-publication-target-entry-surface-id :test #'equal)) + (report (tp--prepared-surface-report prepared))) + (unless (and entry report) + (signal 'tp-publication-binding-error + (list :missing-publication-report (tp--surface-id surface)))) + (setf + (tp-publication-target-entry-operation-counts entry) + (list :surface-id (tp--surface-id surface) + :old-revision (plist-get report :old-revision) + :new-revision (plist-get report :new-revision) + :mapping-generation tp--surface-transaction-id + :text-operations (or (plist-get report :text-operations) 0) + :property-operations + (or (plist-get report :property-operations) 0) + :touched-characters (or (plist-get report :touched-characters) 0)))))) + (defun tp--surface-publish-transaction () "Prepare journals and publish every queued changed surface atomically." (let* ((state (tp--surface-extension-state)) @@ -3319,9 +3631,18 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (puthash 'surface-transaction-id-before tp--surface-transaction-id state) (cl-incf tp--surface-transaction-id) + (when (tp--transaction-v2-artifacts-enabled-p) + (let* ((batch-id (tp--next-publication-batch-id)) + (entries + (tp--surface-shadow-target-entries + prepared snapshots journals views batch-id))) + (tp--transaction-begin-publication-batch + batch-id entries state) + (tp--transaction-batch-transition 'staged))) (let ((tp--surface-publishing t)) (dolist (candidate prepared) - (tp--publish-one-surface candidate))))))) + (tp--publish-one-surface candidate) + (tp--surface-record-publication-operation-counts candidate))))))) (defun tp--surface-precommit-step (step state) "Report precommit STEP for transaction STATE." @@ -3329,7 +3650,7 @@ When RETAIN-MARKERS is non-nil, keep snapshot markers for rollback." (funcall tp--surface-precommit-step-function step state))) (defun tp--validate-retained-batch-precommit (prepared snapshot) - "Validate PREPARED retained batch from constant-time committed identities." + "Validate PREPARED retained batch against committed SNAPSHOT identities." (let* ((surface (tp--prepared-surface-surface prepared)) (batch (tp--prepared-surface-commit-batch prepared)) (mounts (tp--surface-mounts surface)) diff --git a/tp-transaction.el b/tp-transaction.el new file mode 100644 index 0000000..7dc2937 --- /dev/null +++ b/tp-transaction.el @@ -0,0 +1,778 @@ +;;; tp-transaction.el --- Additive 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 used to shadow TP's +;; v1 publication coordinator. This module owns no live writer and never edits +;; a buffer. `tp-reactive' drives the state machine, while `tp-surface' supplies +;; exact target entries backed by the v1 prepare journals and snapshots. + +;;; 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-v1+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--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 (unique t)) + (dolist (item items unique) + (if (member item seen) + (setq unique nil) + (push item 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) + +(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 v1 report. SHADOW-EXPECTED and +SHADOW-VALIDATOR are private comparison artifacts." + (unless (and transaction-id batch-id candidate-id surface-id + (bufferp buffer) (buffer-live-p buffer) + (integerp old-revision) (>= old-revision 0) + (integerp new-revision) (= new-revision (1+ old-revision)) + (tp--proper-unique-list-p mount-ids) + authority-token + (or (null shadow-validator) (functionp shadow-validator))) + (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 view over the existing v1 transaction 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) + 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 final-accept + diagnostics) + "Prepare TRANSACTION-ID and BATCH-ID over exact ENTRIES. +PARTICIPANTS is an ordered reference vector, JOURNALS is the existing v1 state +view, FINAL-ACCEPT is the single coordinator function, and DIAGNOSTICS contains +known preaccept observations." + (unless (and transaction-id batch-id + (tp--publication-batch-entries-valid-p + entries transaction-id batch-id) + (vectorp participants) + (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 + :final-accept final-accept + :final-accept-id (tp--next-final-accept-id) + :diagnostics (tp--copy-property-value diagnostics))) + +(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-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)) + +(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 diff --git a/tp.el b/tp.el index 341e51a..3c9d288 100644 --- a/tp.el +++ b/tp.el @@ -25,6 +25,8 @@ ;; canonical requests/results, and debug logging. ;; tp-style.el Native property policies, contribution composition, ;; named declarations, and explicit computed values. +;; tp-transaction.el +;; Additive publication batch, marker, and outcome contracts. ;; tp-reactive.el Exact signals, bindings, transactions, and scoped variable ;; adapters. ;; tp-surface.el Retained plans, objects, range anchors, mounts, indexes, @@ -53,6 +55,7 @@ (require 'tp-core) (require 'tp-style) +(require 'tp-transaction) (require 'tp-reactive) (require 'tp-surface) (require 'tp-layer) @@ -62,5 +65,20 @@ (require 'tp-palette) (require 'tp-builtins) +(defconst tp--runtime-manifest + `(:package tp :version "1.0.0" + :transaction-protocol ,tp-transaction-protocol + :batch-artifacts t + :batch-execution v1-bridge + :batch-execute nil + :shadow-proof t + :final-marker-operation tp-vector-slots/v1) + "Immutable package capability facts for cross-package compatibility checks.") + +;;;###autoload +(defun tp-runtime-manifest () + "Return a defensive snapshot of TP's package capability manifest." + (tp--copy-property-value tp--runtime-manifest)) + (provide 'tp) ;;; tp.el ends here