Compare commits

...

55 Commits

Author SHA1 Message Date
Kinneyzhang
9169ae383b merge: reconcile forwarded metadata documentation with current policy
Integrate the historical a206cfd documentation-only attempt. Resolve its conflict in favor of the current property-specific Host contract: owned role and ARIA semantics remain protected while ordinary caller metadata is forwarded. The final source tree is unchanged from the first parent.
2026-09-08 21:38:07 +08:00
Kinneyzhang
04a16eeb18 merge: reconcile retained-root metadata and unmount coverage
Integrate 127aa7a with the newer property-specific Host contract from 805323a. Preserve owned role and ARIA checks, callback and Behavior composition, and caller overrides for ordinary metadata. Carry the historical live-buffer unmount assertions into the current render-port revision test. Regression execution was waived; syntax and diff checks passed.
2026-09-08 21:37:53 +08:00
Kinneyzhang
0344735839 fix: isolate performance records and qualify GUI callback measurements 2026-09-07 01:28:26 +08:00
Kinneyzhang
b89cec0001 fix: preserve focus during GUI verification 2026-09-06 22:11:05 +08:00
Kinneyzhang
b1847b3278 docs: require follow-through on related root-cause paths 2026-09-06 21:04:44 +08:00
Kinneyzhang
d5cf6c62f5 docs: preserve application focus during Emacs capture 2026-09-06 20:50:02 +08:00
Kinneyzhang
c06f9ef2dc test: provide reusable existing-frame Ebox resize benchmark 2026-09-06 19:29:51 +08:00
Kinneyzhang
2328e05b45 docs: require reusable project automation entry points 2026-09-06 18:08:11 +08:00
Kinneyzhang
630567da8f fix: validate owned-window capture and recorder geometry 2026-09-06 13:53:45 +08:00
Kinneyzhang
805323a7f2 feat: unify component views and public render boundaries 2026-09-06 13:53:07 +08:00
Kinneyzhang
41b259f772 build: require the v2-only renderer dependency closure 2026-09-05 05:25:30 +08:00
Kinneyzhang
b5f314edff refactor: require SPI v2 for runtime mounts and Host attachment 2026-09-05 05:25:29 +08:00
Kinneyzhang
01b1deb178 chore: freeze verified etaf baseline before C1b 2026-09-05 05:07:38 +08:00
Kinneyzhang
a206cfd725 fix(view): forwarded Host metadata overrides Component root metadata 2026-09-05 01:48:57 +08:00
Kinneyzhang
127aa7a697 fix(view): retain component root metadata 2026-09-05 01:40:42 +08:00
Kinneyzhang
b82f09aa79 fix(runtime): preserve scheduler work and selected publication 2026-09-01 08:11:51 +08:00
Kinneyzhang
de622c263f fix(runtime): preserve rollback custody and scheduler tails 2026-09-01 07:26:34 +08:00
Kinneyzhang
003799e1d6 test(compat): cover missing v1 revision evidence 2026-09-01 06:28:51 +08:00
Kinneyzhang
49bfe162ef fix(compat): close package and v1 revision gaps 2026-09-01 05:57:29 +08:00
Kinneyzhang
35b309a1a9 fix(render-port): close compatibility rollback gaps 2026-09-01 05:00:10 +08:00
Kinneyzhang
b631ffa9f1 fix(runtime): close postcommit fault gaps 2026-09-01 03:56:37 +08:00
Kinneyzhang
4e75aaf0d3 fix(runtime): restore overlay retry queue 2026-09-01 03:16:22 +08:00
Kinneyzhang
aeb1b0f7c7 feat(reactive): isolate dispatcher contexts 2026-09-01 02:17:13 +08:00
Kinneyzhang
01f072e4fd feat(runtime): add postcommit retirement journal 2026-09-01 01:25:34 +08:00
Kinneyzhang
96df9e2858 feat: make Host attach and detach authoritative 2026-09-01 01:07:39 +08:00
Kinneyzhang
86dd00cf6d feat: commit semantic generations with versioned CAS 2026-09-01 00:46:09 +08:00
Kinneyzhang
0cde865d3a refactor: make semantic generation authoritative 2026-09-01 00:33:54 +08:00
Kinneyzhang
d5ccb30125 feat: select versioned Ebox renderer port 2026-09-01 00:27:13 +08:00
Kinneyzhang
24ca887ae4 docs: clear final M0 checkdoc warnings 2026-08-31 16:27:31 +08:00
Kinneyzhang
525e6b38b7 feat: close M0 core interaction contracts 2026-08-31 15:18:26 +08:00
Kinneyzhang
8d685b75e3 docs: bind bilingual module proposal vocabulary 2026-08-31 13:44:41 +08:00
Kinneyzhang
46ffc69c5f docs: close M0b public contract drift 2026-08-31 13:43:23 +08:00
Kinneyzhang
162f4b83fd docs: make GUI evidence the feedback authority 2026-08-29 01:41:24 +08:00
Kinneyzhang
e4afe7f138 docs: require verifiable feedback loops 2026-08-29 01:33:51 +08:00
Kinneyzhang
c54e32529d fix: scope Component attrs to retained roots 2026-08-29 01:11:42 +08:00
Kinneyzhang
68e0dd0676 feat: forward Host attrs through Components 2026-08-29 01:02:49 +08:00
Kinneyzhang
7e8700113f feat: establish unified Component authoring core 2026-08-28 23:21:27 +08:00
Kinneyzhang
8e305b172e refactor: lower hosts through canonical Ebox properties 2026-08-28 22:06:44 +08:00
Kinneyzhang
0923925f1e refactor: retain canonical Ebox inputs across Runtime commits 2026-08-28 16:48:24 +08:00
Kinneyzhang
0b254c1ff2 test: add fail-closed Emacs GUI scenario engine 2026-08-28 13:43:50 +08:00
Kinneyzhang
e9323ef700 fix: close observation lifecycle and snapshot ownership 2026-08-28 01:49:43 +08:00
Kinneyzhang
7e5f55c286 docs: clear core checkdoc warnings 2026-08-28 01:27:47 +08:00
Kinneyzhang
d63cf1a813 refactor: consume public performance reports without advice 2026-08-28 01:12:00 +08:00
Kinneyzhang
bcb7254350 perf: expose scoped ETAF operation observation 2026-08-28 00:50:58 +08:00
Kinneyzhang
e91956b422 docs: mark component target design reviewed 2026-08-28 00:39:58 +08:00
Kinneyzhang
b82e94a86d docs: define dual component authoring frontends 2026-08-27 23:41:36 +08:00
Kinneyzhang
1b6f5871a1 test: use semantic generation adjacency 2026-08-27 20:30:53 +08:00
Kinneyzhang
5921dcb8a2 fix: scope keyed Range hosts by stable item identity 2026-08-27 13:38:14 +08:00
Kinneyzhang
1f29a73a88 refactor: lower Views into canonical Ebox nodes 2026-08-27 12:14:51 +08:00
Kinneyzhang
4ba86642d6 docs: define atomic canonical author boundary migration 2026-08-26 21:33:39 +08:00
Kinneyzhang
2973dd3021 docs: define layered property schemas and projections 2026-08-26 18:21:43 +08:00
Kinneyzhang
30ac302d47 docs: freeze typed Text and Box architecture contract 2026-08-26 17:12:02 +08:00
Kinneyzhang
44f70a6f61 refactor: express examples with canonical Box layouts 2026-08-26 16:23:53 +08:00
Kinneyzhang
0aee417282 feat: normalize static strings as Text views 2026-08-26 16:21:55 +08:00
Kinneyzhang
c831ca11ca feat: lower canonical Box through ETAF runtime 2026-08-26 16:16:57 +08:00
73 changed files with 26584 additions and 5200 deletions

View File

@ -4,6 +4,24 @@
`etaf-sqlite`、`etaf-playground`。实现与性能优化必须从最终产品目标倒推,
不得用局部完成、容易通过的替代目标缩小原始范围。
## 项目自动化入口
- GUI 与性能自动化先查 `scripts/README.md`、`scripts/emacs-gui-verifier.el`
及既有 Makefile 入口;公共机制归 `scripts/`,具体业务场景归示例仓库。
- 现有 Emacs 的截图与录像默认保留用户当前应用焦点,使用已登记的窗口捕获
入口;后台视觉证据须检查内容更新,后台耗时与前台输入到显示延迟分别报告。
- 交互回调测量使用 `etaf-gui-verifier-measure-action`,按 scripts/README.md
固定场景、计时边界与前后台条件;保留全部样本,阶段记录按 observer runtime ID
隔离,不能用可复用的 buffer 名隔离。该入口不证明 compositor 已呈现。
- 连续 resize 使用 `scripts/benchmark-ebox-resize.el`
`ebox-resize-benchmark-start`,适用于现有 ETAF 或独立 Ebox buffer。
按 README 选择范围、轮数和新证据文件;先验证前台与已加载版本,保留全部样本,
检查 `:valid``:within-limit`,同时比较内容规模,不能只比较 p95。
- 遇到重复的渲染、交互、resize 或验证需求,优先扩展已登记入口。稳定的通用
操作应主动固化为带参数、验证和说明的仓库工具,随后更新工具索引及本节路由。
- `.omx/` 中的临时诊断是历史调查材料,不是日常运行入口。不要从中复制新的
示例专用脚本,也不要把项目逻辑放进通用 Emacs 技能。
## 最终目标驱动
开始工作前先明确最终可观察结果、硬性指标、不可牺牲的功能、权威验证方式
@ -66,6 +84,34 @@ ETAF 当前性能工作的最终结果是:通用性能工具能解释每次操
最小验证不能偷换最终目标。微基准只能证明局部机制;真实跨包场景和完整门禁
仍是最终证据。
## 可验证的小赌注与反馈控制环
不要把一次无法控制、无法快速证伪的“大赌注”当作工程推进方式。任何跨包、
跨阶段或“国民级应用”尺度的大 gap都必须拆成一组彼此有清晰因果关系、能够
独立验证和独立回退的小 gap。每个小 gap 只承载一个主要假设,并在扩大范围前
得到新鲜证据。
这不是三条孤立技巧,而是一条完整的反馈控制环:
- **拆解**缩短因果距离:一次只改变一个可命名机制,使失败能直接指向假设,
不让多个变量同时变化后再靠猜测定位;
- **验证**限制错误传播定向测试、静态编译、CI、事务回滚和真实 GUI 门禁必须
放在对应边界上,不能等到最终集成时才第一次发现问题;
- **迭代**提高反馈频率:小步实现、立即运行最小有判定力的检查,通过后才扩大
一个维度,并在完整子目标证明后及时提交 Git 基线。
工程目标不是假装“零错误”,而是让错误出现得早、扩散得不远、定位有证据、
回退代价低。一个实验若不能快速回答“假设是否成立”,就说明切片仍然过大;
一个门禁若失败后不能指出责任边界,就说明验证粒度仍然过粗。不得用继续堆代码、
增加兼容分支或推迟集成来掩盖反馈环已经失效。
凡目标涉及用户可观察的 Emacs 界面、文本属性、交互或性能,只有在目标版本的
真实 GUI Emacs 中实际渲染并执行对应操作所得的视觉结果、动态过程和耗时数据,
才称为反馈。batch ERT、静态编译、CI、mock、结构检查和微基准只是进入 GUI 前的
预检或定位工具,不能替代 GUI 反馈,也不能据此宣称功能正确、视觉合格或性能收敛。
GUI 反馈失败时,以 GUI 为当前事实,回到最小假设重新定位;不得用逻辑测试绿色
反驳用户实测。
## 控制变更规模
- 避免一次编写大段跨层代码后才首次运行测试。
@ -95,6 +141,8 @@ ETAF 当前性能工作的最终结果是:通用性能工具能解释每次操
- 先用通用记录面板确认真实热区,再选择架构或算法改动。
- 一次优化只绑定一个主要瓶颈和一个预期收益,记录优化前后的相同口径数据。
- 根因确认后按全局 Root-cause follow-through 规则检查同类路径;在当前证据记录中
列出各路径的触发场景、正确性边界、实测影响与修复状态,不能用候选清单代替闭环。
- 不用示例名称或业务概念污染通用工具、编译器和底层包协议。
- 不以关闭校验、减少功能、弱化文本属性、破坏身份或回滚语义换取数字。
- 缓存和预编译提示不能自行授权快速路径;运行时仍负责验证和精确回退。

View File

@ -1,10 +1,10 @@
EMACS ?= emacs
LOAD_PATH = -L . -L examples -L ../ebox -L ../tp -L ../ecss
SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el
LOAD_PATH = -L . -L examples -L scripts -L ../ebox -L ../tp -L ../ecss
SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-scheduler.el etaf-reactive.el etaf-observer.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-generation.el etaf-host.el etaf-retirement.el etaf-render-port.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el scripts/emacs-gui-verifier.el scripts/benchmark-scheduler-context.el scripts/benchmark-ebox-resize.el
EXAMPLES = examples/etaf-counter-example.el examples/etaf-data-example.el examples/etaf-resource-example.el
TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-performance-tests.el
TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-component-frontends-tests.el tests/etaf-render-view-tests.el tests/etaf-dynamic-components-tests.el tests/etaf-event-forwarding-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-observer-tests.el tests/etaf-performance-tests.el tests/etaf-gui-verifier-tests.el tests/etaf-m0a-current-characterization-tests.el tests/etaf-interaction-contract-tests.el tests/etaf-m0b-component-manifest-tests.el tests/etaf-render-port-tests.el tests/etaf-generation-tests.el tests/etaf-host-tests.el tests/etaf-retirement-tests.el tests/etaf-scheduler-tests.el tests/etaf-g1-cross-layer-tests.el tests/etaf-resize-benchmark-tests.el
.PHONY: test compile load checkdoc docs-check check clean
.PHONY: test compile load checkdoc docs-check metadata-check scheduler-benchmark resize-benchmark-tests check clean
test: compile
$(EMACS) -Q --batch $(LOAD_PATH) --eval "(setq load-prefer-newer t)" \
@ -13,9 +13,9 @@ test: compile
compile: clean
$(EMACS) -Q --batch $(LOAD_PATH) \
--eval "(setq load-prefer-newer t)" \
--eval "(setq load-prefer-newer t byte-compile-error-on-warn t byte-compile-warnings '(not obsolete))" \
--eval "(load-file \"etaf.el\")" \
--eval "(dolist (file '($(foreach file,$(SOURCES) $(EXAMPLES),\"$(file)\"))) (byte-compile-file file))"
--eval "(dolist (file '($(foreach file,$(SOURCES) $(EXAMPLES),\"$(file)\"))) (unless (byte-compile-file file) (error \"Compilation failed: %s\" file)))"
load: compile
$(EMACS) -Q --batch $(LOAD_PATH) --eval "(setq load-prefer-newer t)" --eval "(require 'etaf)" --eval "(princ \"ETAF load OK\\n\")"
@ -24,10 +24,22 @@ docs-check:
$(EMACS) -Q --batch $(LOAD_PATH) --eval "(setq load-prefer-newer t)" -l tests/etaf-docs-tests.el \
-f ert-run-tests-batch-and-exit
checkdoc:
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (directory (list "." "examples")) (dolist (file (directory-files directory t)) (when (string-suffix-p ".el" file) (checkdoc-file file)))))'
metadata-check:
$(EMACS) -Q --batch --eval "(progn (require 'package) (with-temp-buffer (insert-file-contents \"etaf.el\") (let ((desc (package-buffer-info))) (unless (and (equal (package-desc-version desc) '(0 2 1)) (equal (package-desc-reqs desc) '((emacs (29 1)) (ebox (3 0 0)) (tp (2 0 0))))) (error \"Unexpected ETAF package metadata: %S\" desc)))))"
check: checkdoc compile test docs-check
scheduler-benchmark:
$(EMACS) -Q --batch $(LOAD_PATH) --eval "(setq load-prefer-newer t)" \
-l scripts/benchmark-scheduler-context.el \
-f etaf-scheduler-benchmark-run
resize-benchmark-tests:
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
-l tests/etaf-resize-benchmark-tests.el -f ert-run-tests-batch-and-exit
checkdoc:
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (directory (list "." "examples" "scripts")) (dolist (file (directory-files directory t)) (when (string-suffix-p ".el" file) (checkdoc-file file)))))'
check: checkdoc metadata-check compile test docs-check scheduler-benchmark
clean:
rm -f *.elc examples/*.elc tests/*.elc
rm -f *.elc examples/*.elc scripts/*.elc tests/*.elc

170
README.md
View File

@ -1,53 +1,97 @@
# ETAF
ETAF is a small text-application framework built above the independent [Ebox](../ebox) layout and rendering engine.
ETAF builds text applications from reusable Components above the independent
[Ebox](../ebox) layout and rendering engine.
Its complete public model is:
```text
Component(props, Scope) → View → Renderer → Ebox Node → Emacs buffer
```
Every visible structure uses one form:
Start with `etaf-view` and `etaf-mount`. Properties precede children in
`(name :property value ... child ...)`; property values are ordinary Elisp.
Evaluate the complete example, switch to `*etaf-hello*`, and activate “Say hello”:
<!-- etaf-example: hello -->
```elisp
(name :property value ... child ...)
```
The only child computation bridge is `expr :value`; attribute values are ordinary Elisp expressions.
```elisp
(etaf-view
(column
(text :face 'bold "Hello")
(text
:color "#687386"
(expr :value (if ready "Ready" "Waiting")))))
```
Define a Component:
```elisp
(etaf-define-component status-label (&key label)
"Render a status label."
:view
(text :face 'bold (expr :value label)))
;;; -*- lexical-binding: t; -*-
(require 'etaf)
(etaf-mount
"*etaf-demo*"
(etaf-view (status-label :label "Connected")))
"*etaf-hello*"
(etaf-view
(column
(text :font-weight 'bold "Hello")
(box :ref 'hello :role 'button :tab-index 0
:on-press (lambda () (message "Hello ETAF"))
"Say hello"))))
```
`etaf-view` is the single public View constructor. Structural forms do not use quote; quote remains ordinary Elisp data syntax, such as `'bold`. A View returned from ordinary Elisp is explicitly constructed with `(etaf-view ...)` inside `expr`.
A Component receives declared props and optional content through slots. Use the
exact name passed to `etaf-define-component`; the registry creates no aliases.
`(expr FORM)` evaluates one child expression. In a structural child position it
may return nil, text, a typed Host or Component View, or a proper sequence of
those values. Inside `text`, an expression must return a string.
<!-- etaf-example: card -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf)
(etaf-define-component demo-card (&key title)
:view
(column
(text :font-weight 'bold (expr title))
(slot)
(slot :name 'footer)))
(etaf-mount
"*etaf-card*"
(etaf-view
(demo-card :title "Account"
(text "Connected")
(slot :name 'footer (text "Footer")))))
```
Add `:setup` when a Component owns state. It runs once per retained instance;
`:render` uses ordinary Elisp to capture handles before returning `etaf-view`.
The shorter `:view` form compiles the same View model.
<!-- etaf-example: counter -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf)
(etaf-define-component demo-counter ()
:setup (etaf-ref 0)
:render
(let ((count (etaf-state)))
(etaf-view
(column
(text (expr (format "Count: %d" (etaf-value count))))
(box :ref 'increment :role 'button :tab-index 0
:on-press (lambda () (cl-incf (etaf-value count)))
"Increment")))))
(etaf-mount "*etaf-counter*" (etaf-view (demo-counter)))
```
Keep `etaf-value` reads inside the property or `expr` that should update. Event
callbacks capture ordinary lexical locals; call `etaf-state` during rendering.
Use a lexical-binding `.el` file for reusable application code. `etaf-node` is
available for programmatic View builders. Context, Data, Behavior, and named
Actions are optional capabilities; simple callbacks need no Action registration.
Use exact catalog names such as `etaf-button` after `(require 'etaf-ui)`.
Core does not load `.etaf` files: Playground treats them as inert structure,
with its explicit companion registration handling executable Elisp.
## Performance records
ETAF includes an opt-in, application-neutral timing recorder. It recognizes
public Event, Action, mount, flush, focus, Data, Resource, and viewport
operations, then correlates coarse ETAF, Ebox, TP, and SQLite stages when those
packages are loaded.
ETAF provides an independent, opt-in, application-neutral timing recorder. It
consumes public Runtime observer reports without advice or private cross-package
probes. Runtime operations such as Event, Action, mount, flush, and unmount are
recorded automatically; Ebox, TP, Data, Resource, and SQLite provider stages
inside the same operation are correlated by sequence.
```elisp
(require 'etaf-performance)
;; In a buffer with a mounted ETAF Runtime:
(etaf-performance-mode 1)
;; Use any mounted ETAF application normally.
(etaf-performance-show)
@ -58,30 +102,32 @@ reproducing the operations, press `c` in the panel (or run
`M-x etaf-performance-copy-report`) to copy a complete report. Press `w` (or
run `M-x etaf-performance-export`) to save the same report as an `.eld` file.
The portable report includes the Emacs/display environment, power source,
low-power mode, system load, grouped p50/p95/max, individual operations, GC
deltas, and nested stages. The panel header exposes the same environment
context so a machine-wide slowdown is not mistaken for one package hotspot.
low-power mode, native-JIT state, system load, grouped p50/p95/max, individual
operations, GC deltas, and ordered provider stages. The panel header exposes
the same environment context so a machine-wide slowdown is not mistaken for
one package hotspot.
The `*ETAF Performance*` panel shows operation IDs and parent operations,
generation changes, total latency, GC deltas, and nested stage inclusive/self
time. Records are bounded by `etaf-performance-max-records`; disabling the
mode removes all recorder advice. `etaf-performance-summary` computes
operation p50/p95/max statistics on demand, while
`etaf-performance-operation-stage-summary` ranks one operation's package
categories by exclusive time.
The default registry deliberately uses coarse package boundaries to keep the
measured application representative. A package or application can add a
temporary detail probe without coupling itself to an example:
```elisp
(etaf-performance-register-stage
'my-package-expensive-step 'application 'expensive-step)
```
The `*ETAF Performance*` panel shows operation IDs, generation changes, total
latency, GC deltas, and each flat provider stage in sequence. Provider stages
may overlap, so they are not presented as exclusive/self time. Records are
bounded by `etaf-performance-max-records`; disabling the mode only detaches the
Runtime observer and never rewrites functions. `etaf-performance-summary`
computes operation p50/p95/max statistics on demand, while
`etaf-performance-operation-stage-summary` groups one operation's flat stages
by provider category. `etaf-performance-records` returns defensive operation
and stage snapshots; caller mutation cannot rewrite retained history.
Pass a numeric observer runtime ID to `etaf-performance-records` to select one
mount's history even when a buffer name is reused. Summary and report functions
use all retained records when called without an argument; an explicit `nil`
means an empty selection. The exported environment describes report generation,
not each historical operation. These synchronous operation durations do not
measure physical input-to-presentation latency; use the GUI measurement entry
in [scripts/README.md](scripts/README.md) for per-action condition checks.
Use `etaf-performance-call-operation` or
`etaf-performance-with-operation` to trace an arbitrary operation that has no
built-in public boundary.
built-in public boundary. Both delegate to the same Runtime operation boundary;
they do not create a second timer.
## Executable examples
@ -114,11 +160,21 @@ There is no separate `etaf-data` install: Data is a core ETAF capability. There
## Load and verify
ECSS 0.1.0 and TP 1.0.0 are independent packages and may be installed in either order. Install both before Ebox 2.0.0, then install ETAF. ETAF consumes only the Ebox 2.0 public rendering contract.
Install ECSS 0.1.0 and TP 2.0.0 before Ebox 3.0.0, then install ETAF 0.2.1.
ETAF declares TP directly because Host final-accept authority uses the TP
transaction contract. Rendering requires Ebox framework SPI v2; a missing,
malformed, or incompatible provider fails during ETAF bootstrap.
ETAF snapshots one immutable v2 render port for the Emacs process. During an
ordered upgrade it also accepts Ebox's transitional dual-capability TP manifest
because that manifest contains the required v2 protocol. ETAF never dispatches
through the retired v1 capability.
During development, load the sibling Ebox checkout before ETAF:
```elisp
(add-to-list 'load-path "/path/to/github/ecss")
(add-to-list 'load-path "/path/to/github/tp")
(add-to-list 'load-path "/path/to/github/ebox")
(add-to-list 'load-path "/path/to/github/etaf")
(require 'etaf)

View File

@ -1,53 +1,93 @@
# ETAF
ETAF 是构建在独立 [Ebox](../ebox) 布局与渲染引擎之上的小型文本应用框架
ETAF 在独立 [Ebox](../ebox) 布局与渲染引擎上,使用可复用的 Component 构建文本应用
完整的公共模型是:
```text
Component(props, Scope) → View → Renderer → Ebox Node → Emacs buffer
```
所有可见结构都使用一种形式:
`etaf-view``etaf-mount` 开始。`(name :property value ... child ...)`
中属性在前、子节点在后,属性值是普通 Elisp。求值下面完整例子切换到
`*etaf-hello*`,即可激活 “Say hello”
<!-- etaf-example: hello -->
```elisp
(name :property value ... child ...)
```
子节点中唯一的计算桥接是 `expr :value`;属性值则是普通 Elisp 表达式。
```elisp
(etaf-view
(column
(text :face 'bold "Hello")
(text
:color "#687386"
(expr :value (if ready "Ready" "Waiting")))))
```
定义 Component
```elisp
(etaf-define-component status-label (&key label)
"Render a status label."
:view
(text :face 'bold (expr :value label)))
;;; -*- lexical-binding: t; -*-
(require 'etaf)
(etaf-mount
"*etaf-demo*"
(etaf-view (status-label :label "Connected")))
"*etaf-hello*"
(etaf-view
(column
(text :font-weight 'bold "Hello")
(box :ref 'hello :role 'button :tab-index 0
:on-press (lambda () (message "Hello ETAF"))
"Say hello"))))
```
`etaf-view` 是唯一的公共 View 构造入口。结构 form 不使用 quotequote 仍然是普通 Elisp 数据语法,例如 `'bold`。普通 Elisp 返回 View 时,必须在 `expr` 中显式使用 `(etaf-view ...)` 构造它。
Component 通过声明的 props 接收业务输入,通过 slot 接收内容。调用时使用
`etaf-define-component` 中的准确名称,注册表不会自动生成 alias。
`(expr FORM)` 执行一个子节点表达式:结构位置可以返回 nil、字符串、typed
Host 或 Component View或这些值组成的 proper sequence`text` 内的表达式必须返回字符串。
<!-- etaf-example: card -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf)
(etaf-define-component demo-card (&key title)
:view
(column
(text :font-weight 'bold (expr title))
(slot)
(slot :name 'footer)))
(etaf-mount
"*etaf-card*"
(etaf-view
(demo-card :title "Account"
(text "Connected")
(slot :name 'footer (text "Footer")))))
```
组件拥有状态时才增加 `:setup`,它对每个保留的实例执行一次。
`:render` 使用普通 Elisp 捕获句柄,再返回 `etaf-view`;更短的 `:view`
形式编译为同一种 View 模型。
<!-- etaf-example: counter -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf)
(etaf-define-component demo-counter ()
:setup (etaf-ref 0)
:render
(let ((count (etaf-state)))
(etaf-view
(column
(text (expr (format "Count: %d" (etaf-value count))))
(box :ref 'increment :role 'button :tab-index 0
:on-press (lambda () (cl-incf (etaf-value count)))
"Increment")))))
(etaf-mount "*etaf-counter*" (etaf-view (demo-counter)))
```
`etaf-value` 放在需要更新的属性或 `expr` 内,保留局部更新边界。
事件回调捕获普通词法变量,`etaf-state` 在 render 时读取。可复用应用代码放进
启用 lexical-binding 的 `.el` 文件。程序化构造 View 时也可使用 `etaf-node`
Context、Data、Behavior 和命名 Action 按需学习,简单回调不需要注册 Action。
加载 `(require 'etaf-ui)` 后,使用 `etaf-button` 等准确目录名称。
Core 不加载 `.etaf` 文件Playground 将它们作为 inert 结构,由其显式的 companion
注册入口管理可执行 Elisp。
## 性能记录面板
ETAF 内置了一个按需启用、与具体应用无关的性能记录器。它自动识别公共
Event、Action、mount、flush、focus、Data、Resource 和 viewport 操作;当
Ebox、TP、SQLite 等包已加载时,还会把这些包的粗粒度阶段关联到同一个
operation。
ETAF 提供一个独立、按需加载、与具体应用无关的性能记录器。它消费 Runtime
公共 observer 报告,不使用 advice 或私有跨包探针。Event、Action、mount、flush
和 unmount 等 Runtime operation 会自动记录;同一 operation 内的 Ebox、TP、Data、
Resource 和 SQLite 等 provider 阶段按 sequence 关联到同一条记录
```elisp
(require 'etaf-performance)
;; 在已挂载 ETAF Runtime 的 buffer 中:
(etaf-performance-mode 1)
;; 正常操作任意已挂载的 ETAF 应用。
(etaf-performance-show)
@ -56,28 +96,27 @@ operation。
交互采集时先执行 `M-x etaf-performance-clear`,复现一组操作后,在面板按
`c`(或执行 `M-x etaf-performance-copy-report`)即可把完整报告复制到剪贴板;
`w`(或执行 `M-x etaf-performance-export`)可保存为 `.eld` 文件。报告包含
Emacs/显示环境、电源来源、低功耗模式、系统负载、分组 p50/p95/max、每次
operation、GC 增量和嵌套阶段;面板 header 也显示同一环境信息,避免把整机降频
误判成某个包的热点。
Emacs/显示环境、电源来源、低功耗模式、native JIT 状态、系统负载、分组
p50/p95/max、每次 operation、GC 增量和有序 provider 阶段;面板 header 也显示
同一环境信息,避免把整机降频误判成某个包的热点。
`*ETAF Performance*` 面板会显示 operation ID 与父 operation、generation
变化、总耗时、GC 增量,以及嵌套阶段的 inclusive/self 耗时。记录数量由
`etaf-performance-max-records` 限制;关闭 mode 会移除全部记录 advice。
`*ETAF Performance*` 面板会显示 operation ID、generation 变化、总耗时、GC
增量,以及 flat provider 阶段的顺序和各自耗时。provider 阶段可能重叠,因此
不会伪装成 exclusive/self 时间。记录数量由 `etaf-performance-max-records`
限制;关闭 mode 只会解除当前 Runtime 的 observer不修改任何函数。
`etaf-performance-summary` 会按需计算 operation 的 p50/p95/max
`etaf-performance-operation-stage-summary` 则按 exclusive 耗时排列单次
operation 的包级阶段。
默认注册表刻意只记录包级粗边界,避免分析工具明显改变被测应用。任意包或
应用可以临时增加更细的探针,不需要绑定某个示例:
```elisp
(etaf-performance-register-stage
'my-package-expensive-step 'application 'expensive-step)
```
`etaf-performance-operation-stage-summary` 则按 provider category 汇总单次
operation 的 flat 阶段。`etaf-performance-records` 返回 operation/stage 的防御性
快照,调用方修改返回值不会改写已保留的历史。
`etaf-performance-records` 传入 observer 报告中的数字 runtime ID可以隔离
同名 buffer 重建前后的记录。summary/report 函数省略参数时读取全部历史,
显式传入 `nil` 时保持空结果。导出的环境是生成报告时的状态,不是每次历史操作
的状态;同步 operation 耗时也不等于物理输入到画面呈现的延迟。逐次 GUI 条件
检查使用 [scripts/README.md](scripts/README.md) 中的测量入口。
没有内置公共边界的任意操作,可以使用
`etaf-performance-call-operation``etaf-performance-with-operation`
包裹。
包裹;它们直接委托同一个 Runtime operation 边界,不建立第二套计时器
## 可执行示例
@ -110,11 +149,20 @@ operation 的包级阶段。
## 加载与验证
ECSS 0.1.0 与 TP 1.0.0 是互相独立的包,安装顺序任意;两者都安装后再安装 Ebox 2.0.0,最后安装 ETAF。ETAF 只使用 Ebox 2.0 的公共渲染契约。
先安装 ECSS 0.1.0 与 TP 2.0.0,再安装 Ebox 3.0.0,最后安装 ETAF 0.2.1。
ETAF 会直接声明 TP 依赖,因为 Host final-accept authority 使用 TP transaction
contract。渲染要求 Ebox framework SPI v2provider 缺失、格式错误或不兼容时,
ETAF 会在 bootstrap 阶段 fail closed。
ETAF 为当前 Emacs 进程 snapshot 一个不可变的 v2 render port。按依赖顺序升级时
也接受 Ebox 过渡期的 TP 双能力 manifest因为其中包含所需的 v2 协议ETAF
不会调用已经退役的 v1 capability。
开发时先把同级 Ebox 检出目录加入 `load-path`
```elisp
(add-to-list 'load-path "/path/to/github/ecss")
(add-to-list 'load-path "/path/to/github/tp")
(add-to-list 'load-path "/path/to/github/ebox")
(add-to-list 'load-path "/path/to/github/etaf")
(require 'etaf)

View File

@ -45,7 +45,6 @@ These are mechanisms rather than additional visual node types:
- `watch` observes reactive state.
- `Context` provides inherited dependencies.
- `Data` owns application-data state and source requests.
- `raw-ebox` is the explicit low-level escape at the ETAF/Ebox boundary.
## 3. The unified View grammar
@ -62,10 +61,10 @@ Properties must be complete before the first child. A child can be a string, a n
(etaf-view
(column
:class "welcome"
(text :face 'bold "Hello")
(text :font-weight 'bold "Hello")
(text
:color "#687386"
(expr :value (if ready "Ready" "Waiting")))))
(expr (if ready "Ready" "Waiting")))))
```
An attribute appearing after a child is invalid because the two regions may
@ -78,21 +77,20 @@ not be interleaved.
The rule is simple:
1. Structural View positions are not quoted. This includes `etaf-view`, Hosts, Component calls, children, slot forms, and static Component styles.
2. Elisp expression positions follow normal Elisp evaluation. This includes attribute values, `:key`, `:on-*`, `:use`, `expr :value`, `:setup`, Context values, Behavior constructors, Actions, and `raw-ebox :value`.
2. Elisp expression positions follow normal Elisp evaluation. This includes attribute values, `:key`, `:on-*`, `:use`, `expr`, `:setup`, Context values, Behavior constructors, and Actions.
```elisp
(etaf-view
(text
:face (if dark 'light 'dark)
(expr :value label)))
:color (if dark "#F4F6FB" "#1F2328")
(expr label)))
(etaf-view
(column
(expr
:value
(when open
(etaf-view
(text :face 'bold "Details"))))))
(text :font-weight 'bold "Details"))))))
```
`'bold` is an ordinary Elisp literal symbol. `'(text "Details")` is ordinary data, not a View; use `(etaf-view (text "Details"))` when an Elisp expression must construct a View. ETAF does not run `eval` on quoted View data and does not add separate literal/eval nodes.
@ -104,30 +102,40 @@ Attribute values do not need an `expr` wrapper. `expr` exists only because the c
`expr` accepts exactly one property and no children:
```elisp
(expr :value ELISP-EXPRESSION)
(expr ELISP-EXPRESSION)
```
It evaluates the expression, then accepts a string, View, sequence, or `nil`. It creates no Ebox wrapper, identity, lifecycle, watcher, or effect. `if`, `when`, `cond`, `let`, `mapcar`, `cl-loop`, and other Elisp forms remain ordinary Elisp inside `:value`.
It evaluates the expression, then accepts a string, typed View, proper typed
View sequence, or `nil`. It creates no Ebox wrapper, identity, lifecycle,
watcher, or effect. `if`, `when`, `cond`, `let`, `mapcar`, `cl-loop`, and other
Elisp forms remain ordinary Elisp inside the form.
The current core has no file-facing `.etaf` pair loader. `etaf-define-component` is the structure/style/behavior unit: its View defines structure, `:styles` owns presentation rules, and `:setup` owns retained state, events, and lifecycle behavior. A future `.etaf` single-file component format belongs in a compiler layer that lowers into this same public View and Component contract; it is not a second runtime grammar.
## 4. Components
The public definition macro has exactly three keywords:
The public definition macro has four keywords. Choose exactly one frontend;
the other two clauses are optional:
```elisp
```text
(etaf-define-component NAME (&key PROPS)
DOCSTRING?
:setup OPAQUE-STATE-FORM
:view VIEW
:styles (styles RULE...))
(etaf-define-component NAME (&key PROPS)
DOCSTRING?
:setup SETUP
:setup OPAQUE-STATE-FORM
:render ORDINARY-ELISP
:styles (styles RULE...))
```
`:view` and `:setup` are mutually exclusive. `:styles` is optional and may appear once. Props are the only declared business inputs; ordinary trailing children and named slots are normalized separately into the Component's slot collection.
`:view` and `:render` are mutually exclusive and exactly one is required.
`:render` is ordinary Elisp and may return `etaf-view` or a programmatically
built `etaf-node`. Both share View compilation, prop validation, and slot
projection; `:render` adds no second representation or state model.
`:setup` and `:styles` are optional and may each appear once. Props are the only declared business inputs; ordinary trailing children and named slots are normalized separately into the Component's slot collection.
The Component definition is the current structure/style/behavior boundary. Keep dynamic state, Action callbacks, and lifecycle work in `:setup`; keep static presentation in `:styles`. A future `.etaf` SFC compiler may produce these definitions, but the Runtime does not load `.etaf` files directly.
@ -138,36 +146,39 @@ The Component definition is the current structure/style/behavior boundary. Keep
"Render a status label."
:view
(text
:face 'bold
(expr :value label)))
:font-weight 'bold
(expr label)))
```
```elisp
(etaf-define-component disclosure (&key title)
"Render a retained disclosure."
:setup
(let ((open (etaf-ref nil)))
(lambda ()
(etaf-view
(column
(text
:role 'button
:on-press
(lambda ()
(setf (etaf-value open)
(not (etaf-value open))))
(expr :value (if (etaf-value open) "Hide" "Show")))
(expr
:value
(when (etaf-value open)
(etaf-view (text (expr :value title))))))))))
(etaf-ref nil)
:view
(column
(text
:role 'button
:on-press
(let ((open (etaf-state)))
(lambda ()
(setf (etaf-value open)
(not (etaf-value open)))))
(expr (if (etaf-value (etaf-state)) "Hide" "Show")))
(expr
(when (etaf-value (etaf-state))
(etaf-view (text (expr title)))))))
```
`:setup` runs once for a retained Component instance and must return a zero-argument render function. Re-render reads current props and refs without rerunning setup. Setup is the owner for local refs, computed values, watches, Effects, and cleanup registration.
`:setup` runs once for a retained Component instance and returns one opaque state
value. `etaf-state` returns that exact value during `:view` or `:render`.
Re-render reads current props and state without rerunning setup. Setup is the
owner for local refs, computed values, watches, Effects, and cleanup
registration; it never returns a render function.
`:key` is stable identity metadata, not a business prop. On a Component call it selects the retained Component instance within the sibling scope; on a Host or `raw-ebox` it is forwarded as the Ebox node key. If a render candidate fails, the Runtime restores the previous instance, handlers, behaviors, and buffer.
`:key` is stable identity metadata, not a business prop. On a Component call it selects the retained Component instance within the sibling scope; on a Host it is forwarded as the Ebox node key. If a render candidate fails, the Runtime restores the previous instance, handlers, behaviors, and buffer.
In View syntax, canonical Component names may omit the `etaf-` prefix. If the short name would collide with an Elisp function, special form, or Host, the registry assigns a semantic `-view` alias. Ordinary Elisp APIs such as `etaf-value`, `etaf-ref`, and `etaf-mount` always keep their prefix.
Component calls use the exact registered definition name. The registry creates no automatic prefix or `-view` aliases. Official catalog Components use names such as `etaf-button`; an application may explicitly define its own Component under any valid unoccupied name.
## 5. Children and slots
@ -193,7 +204,7 @@ Named content uses the same structural shape:
```elisp
(card
:title "Account"
(slot :name 'header (text :face 'bold "Account settings"))
(slot :name 'header (text :font-weight 'bold "Account settings"))
(text "Card body"))
```
@ -201,19 +212,26 @@ Inside a Component View, the default outlet and its fallback are:
```elisp
(slot)
(slot (text :face 'shadow "No content"))
(slot (text :color "#687386" "No content"))
```
The explicit normalized spelling is:
```elisp
(slot :name 'default (text :face 'shadow "No content"))
(slot :name 'default (text :color "#687386" "No content"))
```
Named slot names are stable non-keyword symbols. Strings, numbers, variables, and runtime expressions are rejected because a slot name is part of retained structure. A named input may appear only once. An explicitly empty input `(slot :name 'header)` suppresses the outlet fallback. Slot forms do not create Ebox wrappers.
Inside a Component, `slot` projects content. In a Component call's child region, `slot :name` contributes content. The compiler uses the same normalized slot representation for both roles.
Authored slot expressions retain their author's props, state, and Context across
the entire projected subtree. A Component created in that subtree owns its own
props, state, styles, and Scope, inheriting Context from the slot author. The
receiver's own fallback, ordinary children, and View-producing callbacks use
the receiver environment instead. Table/Grid cell callbacks keep the same
ordinary rule: their Context is the consuming Table/Grid location.
## 6. Core Hosts and Ebox
ETAF core intentionally provides only minimal, unstyled Hosts:
@ -238,18 +256,9 @@ Strings are the smallest text View and lower to Ebox content. Nested `text` View
`grid` reuses Ebox's public two-dimensional layout contract. Its properties include track templates, `auto`/fractional/`minmax` tracks, gaps, row/column placement, spans, auto-flow, and item alignment. Ebox owns track measurement and placement; ETAF only maps the `grid` Host into that node. Ebox's optional native reflow backend is not required for correctness; a Grid tree uses the ordinary Ebox renderer when that backend does not support the node.
ETAF's Renderer is the only framework module that calls Ebox. It uses Ebox public constructors, property readers, host-reference queries, and publication APIs. Ebox does not know about Components, slots, Actions, Context, Behaviors, or Data.
ETAF's Renderer is the only framework module that lowers View semantics into Ebox nodes, properties, and Host queries; `etaf-render-port.el` is the only module that probes the versioned Ebox framework SPI and selects a publication route. Both use only public Ebox APIs, while Runtime reads the already-selected immutable port instead of guessing the Ebox version. Ebox does not know about Components, slots, Actions, Context, Behaviors, or Data.
`raw-ebox` is the one deliberate escape:
```elisp
(etaf-view
(raw-ebox
:key 'backend-row
:value (ebox-create :content "Low-level")))
```
It accepts only `:value` and optional `:key`. The returned Ebox Node remains opaque and does not receive Component props, slots, events, or Behaviors. Using it transfers measurement, identity, rollback, and backend responsibility to the caller.
The public View grammar does not accept raw Ebox Nodes. Framework integrations construct canonical TextNode and BoxNode values through Ebox's typed integration port, while ordinary ETAF applications stay on Hosts and Components. This keeps measurement, identity, and rollback ownership inside one lowering path.
## 7. Runtime and reactive state
@ -306,6 +315,19 @@ Use `etaf-action-define` and `etaf-dispatch` when the mutation is named and shar
`etaf-behavior-create` accepts the reserved `:install` attribute for an optional zero-argument installer. The installer may return a cleanup function; `etaf-current-behavior-context` exposes the current Runtime, structural path, and Host props while it runs. Installer state is disposed when the Behavior is replaced or its owner is unmounted.
Interaction composition is deterministic. An explicit Host `:on-*` callback
runs first, followed by Behavior callbacks in declaration order; an error
short-circuits the remaining callbacks. For non-event attributes the explicit
Host value wins, otherwise the first declaring Behavior wins. Behavior names
must be unique on one Host before any installer runs. Stable installer identity
is reused, and every installed cleanup runs exactly once. Events dispatch only
to the exact Host reference: ETAF has no capture or bubble phase.
Action names should be application- or feature-prefixed symbols. Duplicate
registration is an error by default. `etaf-action-redefine-run` is the explicit
authoring/reload boundary; replacement affects future name-based dispatch and
does not flush a mounted Runtime.
Runtime events are dispatched through `etaf-dispatch-event`, and focus/hit testing use public Ebox Host-reference queries through `etaf-activate`, `etaf-focus`, `etaf-focus-next`, `etaf-host-ref-bounds`, and `etaf-host-ref-position`.
## 9. Context, Theme, Data, and Resource
@ -314,34 +336,50 @@ Runtime events are dispatched through `etaf-dispatch-event`, and focus/hit testi
Context is an inherited Component Scope environment:
<!-- etaf-example: context -->
```elisp
(etaf-define-component service-provider ()
"Provide a reactive service to descendants."
:setup
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
(lambda () (etaf-view (slot)))))
(require 'etaf)
(etaf-define-component service-consumer ()
"Read the inherited service."
:setup
(let ((service (etaf-inject 'service nil t)))
(lambda ()
(etaf-view (text (expr :value (etaf-value service)))))))
:setup (etaf-inject 'service nil t)
:view (text (expr (format "Service: %s" (etaf-value (etaf-state))))))
(etaf-view (service-provider (service-consumer)))
(etaf-define-component service-provider ()
"Provide a reactive service to its own child Component."
:setup
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
service)
:view (service-consumer))
(etaf-mount "*etaf-context*" (etaf-view (service-provider)))
```
Keys are stable ordinary symbols. The nearest ancestor wins; a missing required key signals `etaf-context-error`. Theme is a Context value containing a property plist:
Keys are stable ordinary symbols. The nearest ancestor wins; a missing required
key signals `etaf-context-error`. Root-authored slots retain the root's empty
Context throughout their subtree. Migration from the former accidental receiver
inheritance requires declaring consumers in the provider's own View or calling
an ordinary View-producing callback there. Projected slots continue to use their
author's environment. Theme follows this same Context ancestry and contains a
property plist:
<!-- etaf-example: theme -->
```elisp
(require 'etaf)
(etaf-define-component themed-shell ()
"Provide default text colors to a subtree."
"Provide semantic colors to its own View."
:setup
(progn
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
(lambda () (etaf-view (slot)))))
(etaf-theme-provide
'(:text-color "#F4F6FB" :surface-color "#202634"))
:view
(text :ref 'themed-content
:color (etaf-theme-token :text-color)
:background-color (etaf-theme-token :surface-color)
"Themed content"))
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
```
Palette resolution remains a Theme concern, not a UI catalog concern. Core
@ -440,6 +478,90 @@ through one outer reactive dispatch. A local owner evaluates into a candidate
generation and Ebox logical replacement; disjoint owners are coalesced into
one TP/Ebox publication. The Root owner is the only complete-root adapter.
The sole mutable pointer to the committed semantic generation belongs to
`etaf-generation-authority`. Public handler and Host-property queries read that
generation directly. Same-named Runtime hash tables are one-way compatibility
mirrors rebuilt from the generation; they neither authorize queries nor write
back into it. The migration-only `legacy`, `project`, and `shadow` routes prove
projection equivalence and rollback safety without introducing a second
committed truth.
At process bootstrap, `etaf-render-port` requires Ebox framework SPI v2 and
snapshots exactly one immutable port. A missing, malformed, or incompatible
provider fails closed before any Runtime is mounted. The ordered dependency
upgrade may expose either a transitional TP v1+v2 manifest or the final v2-only
manifest; both prove the required v2 capability, and ETAF never calls a v1
operation. A mounted or in-flight Runtime never switches ports.
Each semantic candidate captures the expected generation, semantic token, and
instance/resource/artifact/route store versions. The render path stages one CAS
inside the Ebox framework callback and restores it through the same inverse
journal on failure. A semantic-only change runs that CAS under ETAF ownership
without creating an Ebox commit or TP revision. Mirror projection and obsolete
route cleanup after CAS are postcommit work and cannot reverse the committed
token if they fail. Such failures are retained in the retirement diagnostic
journal and re-signaled with the same committed trailer used by lifecycle
failures; they never re-enter semantic rollback.
Each mounted Runtime also owns a distinct Host authority containing `state /
opaque token / version`. The initial v2 framework stage enters only a
provisional state and registers a fixed-slot TP final marker; the Host becomes
attached only when buffer final accept succeeds. Public lookup, events, and
source routes validate both attached state and token. Detach invalidates the
token at one O(1) boundary before removing registries, routes, Component scopes,
or Behaviors, so cleanup volume or failure cannot revive the old Host.
Lifecycle callbacks and structural cleanup run after that commit boundary in
an `etaf-retirement-journal`. Every entry has a stable identity, ordering key,
attempt count, policy, and terminal state. Public mounted, updated, and
unmounted callbacks are run once; the first public failure abandons later
public callbacks while structural cleanup continues. Idempotent framework
cleanup has a bounded retry count, and contained cleanup records diagnostics
without changing the committed generation, Ebox revision, or Host authority.
Completed journals are retained separately from committed outcomes on the
Runtime, with a bounded history.
When an explicit operation must expose a postcommit callback failure, ETAF
re-signals the original condition symbol and preserves its original data as a
prefix. It appends one fixed `:etaf-condition-trailer/v1` datum containing the
operation, outcome, generation, Ebox revision, and diagnostic-journal IDs.
`etaf-condition-postcommit-info` validates and reads that trailer, so callers
can distinguish “committed, then callback failed” from a rollback failure.
The buffer-kill path drains or contains retirement work but never throws a
retirement condition from the kill hook.
Reactive publication is coordinated by an explicit `etaf-scheduler-context`.
The context owns the source and Runtime FIFOs, their dedupe sets, effect claims,
turn and projection epochs, nesting/busy state, fault diagnostics, and cost
counters; it does not own Component, resource, or generation state. Existing
callers use `etaf-scheduler-default-context`, while a mount may supply
`:scheduler-context` to isolate its dispatch authority. Scopes, Effects, and
opaque Runtime routes inherit and retain that context.
One logical projection groups every changed source by its live subscriber
contexts in one subscriber-table scan before draining. Source propagation
settles across all touched contexts before any Runtime callback publishes.
Within a context, each source and Effect is delivered once per scheduler turn,
and multiple changed sources enqueue a Runtime once. A reentrant write to an
already delivered source is deferred to the next turn; a per-context turn
budget contains cross-context cycles with reusable fault diagnostics. A source
wave snapshots the current FIFO, so newly discovered distinct sources consume
another budgeted turn and cannot monopolize one drain. Dedupe in one context
never suppresses another, and registry/token/Host validation filters stale
Runtime routes before fan-out.
Runtime callbacks are detached as a turn, so a lifecycle write enters the
following turn. One failing callback is retained as the context fault only
after every later callback in that detached turn has run. Data success/error
multi-ref publication and event/action callbacks use this same projection
boundary, while the legacy facade continues through the default context. Data
source failures update the Controller error state; a later projection/render
failure propagates unchanged and cannot be reclassified as a source failure.
Runtime operation reports include both the local context deltas and full
cross-context projection summaries for source
delivery, subscriber visits, effect work, Runtime work, stale drops, turns,
and faults.
Each Runtime flush records a candidate-aware effect tuple containing the
generation id, effect-to-source edges and source versions, plus an immutable
semantic-node stamp for candidate input/context/output facts. A repeated tuple
@ -470,6 +592,5 @@ Before adding a new concept, choose the smallest existing owner:
| Cross-depth dependency | Context |
| Request or mutation state | Data / Resource |
| Geometry or layout algorithm | Ebox |
| Low-level backend escape | `raw-ebox` |
Add a new public concept only when an existing owner cannot express the behavior, the new owner can state identity/lifecycle/error/rollback rules, and a public-path test can prove it. This keeps the model small while retaining full Elisp expressiveness.

View File

@ -45,7 +45,6 @@ ETAF 是面向文本应用的统一 View 与 Component 层。Elisp 仍然是完
- `watch` 观察响应式状态。
- `Context` 提供继承的依赖。
- `Data` 管理应用数据状态和数据源请求。
- `raw-ebox` 是 ETAF/Ebox 边界上的明确底层出口。
## 3. 统一 View 语法
@ -62,10 +61,10 @@ ATTRIBUTE = :KEY VALUE
(etaf-view
(column
:class "welcome"
(text :face 'bold "Hello")
(text :font-weight 'bold "Hello")
(text
:color "#687386"
(expr :value (if ready "Ready" "Waiting")))))
(expr (if ready "Ready" "Waiting")))))
```
属性出现在子节点之后时,属性区和子节点区被交错,属于非法结构。
@ -77,21 +76,20 @@ ATTRIBUTE = :KEY VALUE
规则只有两条:
1. 结构性 View 位置不需要 quote包括 `etaf-view`、Host、Component 调用、子节点、slot 和静态 Component styles。
2. Elisp 表达式位置遵循普通 Elisp 求值,包括属性值、`:key`、`:on-*`、`:use`、`expr :value`、`:setup`、Context 值、Behavior 构造器、Action 以及 `raw-ebox :value`
2. Elisp 表达式位置遵循普通 Elisp 求值,包括属性值、`:key`、`:on-*`、`:use`、`expr`、`:setup`、Context 值、Behavior 构造器和 Action
```elisp
(etaf-view
(text
:face (if dark 'light 'dark)
(expr :value label)))
:color (if dark "#F4F6FB" "#1F2328")
(expr label)))
(etaf-view
(column
(expr
:value
(when open
(etaf-view
(text :face 'bold "Details"))))))
(text :font-weight 'bold "Details"))))))
```
`'bold` 是普通 Elisp 字面量 symbol。`'(text "Details")` 只是普通数据,不是 View当 Elisp 表达式需要构造 View 时,使用 `(etaf-view (text "Details"))`。ETAF 不会对被 quote 的 View 数据再次 `eval`,也不增加单独的 literal/eval 节点。
@ -103,30 +101,36 @@ ATTRIBUTE = :KEY VALUE
`expr` 只接受一个属性且不能有子节点:
```elisp
(expr :value ELISP-EXPRESSION)
(expr ELISP-EXPRESSION)
```
它执行表达式然后接受字符串、View、View 序列或 `nil`。它不创建 Ebox wrapper、identity、生命周期、watch 或 effect。`if`、`when`、`cond`、`let`、`mapcar`、`cl-loop` 等 Elisp 形式仍然只是 `:value` 中的普通 Elisp。
它执行表达式然后接受字符串、typed View、typed View proper sequence 或 `nil`
它不创建 Ebox wrapper、identity、生命周期、watch 或 effect。`if`、`when`、`cond`、
`let`、`mapcar`、`cl-loop` 等仍是 form 中的普通 Elisp。
当前 core 没有面向文件的 `.etaf` pair loader。`etaf-define-component` 才是结构/样式/行为单元View 定义结构,`:styles` 负责 presentation`:setup` 负责 retained state、事件和生命周期行为。未来的 `.etaf` SFC 属于把结果 lowering 到同一套公共 View/Component 契约的 compiler layer而不是第二套 Runtime 语法。
## 4. Component
公共定义宏只有三个关键字
公共定义宏有四个关键字。两个 frontend 必须二选一,另外两个 clause 可选
```elisp
```text
(etaf-define-component NAME (&key PROPS)
DOCSTRING?
:setup OPAQUE-STATE-FORM
:view VIEW
:styles (styles RULE...))
(etaf-define-component NAME (&key PROPS)
DOCSTRING?
:setup SETUP
:setup OPAQUE-STATE-FORM
:render ORDINARY-ELISP
:styles (styles RULE...))
```
`:view``:setup` 互斥;`:styles` 可选且最多出现一次。Props 是唯一需要声明的业务输入;普通尾部子节点和命名 slot 会被规范化为 Component 的 slot 集合。
`:view``:render` 互斥且必须恰好出现一个。`:render` 是普通 Elisp可以返回
`etaf-view` 或程序化构造的 `etaf-node`;两者共用 View 编译、prop 校验与 slot
投影,不增加另一套表示或状态模型。`:setup` 与 `:styles` 可选且各最多出现一次。Props 是唯一需要声明的业务输入;普通尾部子节点和命名 slot 会被规范化为 Component 的 slot 集合。
Component definition 是当前结构/样式/行为边界动态状态、Action callback 和生命周期工作放进 `:setup`,静态 presentation 放进 `:styles`。未来 `.etaf` SFC compiler 可以生成这些 definition但 Runtime 不会直接加载 `.etaf` 文件。
@ -137,36 +141,38 @@ Component definition 是当前结构/样式/行为边界动态状态、Action
"Render a status label."
:view
(text
:face 'bold
(expr :value label)))
:font-weight 'bold
(expr label)))
```
```elisp
(etaf-define-component disclosure (&key title)
"Render a retained disclosure."
:setup
(let ((open (etaf-ref nil)))
(lambda ()
(etaf-view
(column
(text
:role 'button
:on-press
(lambda ()
(setf (etaf-value open)
(not (etaf-value open))))
(expr :value (if (etaf-value open) "Hide" "Show")))
(expr
:value
(when (etaf-value open)
(etaf-view (text (expr :value title))))))))))
(etaf-ref nil)
:view
(column
(text
:role 'button
:on-press
(let ((open (etaf-state)))
(lambda ()
(setf (etaf-value open)
(not (etaf-value open)))))
(expr (if (etaf-value (etaf-state)) "Hide" "Show")))
(expr
(when (etaf-value (etaf-state))
(etaf-view (text (expr title)))))))
```
`:setup` 对一个 retained Component instance 只运行一次,并且必须返回零参数 render 函数。重新渲染读取当前 props 和 ref不重新运行 setup。setup 负责局部 ref、computed、watch、Effect 和 cleanup 的创建。
`:setup` 对一个 retained Component instance 只运行一次,返回一个 opaque 状态值。
`:view``:render` 中用 `etaf-state` 取得这个准确值。重新渲染读取当前 props 和
state不重新运行 setup。setup 负责局部 ref、computed、watch、Effect 和 cleanup
不返回 render 函数。
`:key` 是稳定的 identity metadata不是业务 prop。放在 Component 调用上时,它选择同级作用域内要保留的 Component instance放在 Host 或 `raw-ebox` 上时,它会作为 Ebox node key 向下传递。候选渲染失败时Runtime 恢复旧 instance、handlers、Behaviors 和 buffer。
`:key` 是稳定的 identity metadata不是业务 prop。放在 Component 调用上时,它选择同级作用域内要保留的 Component instance放在 Host 上时,它会作为 Ebox node key 向下传递。候选渲染失败时Runtime 恢复旧 instance、handlers、Behaviors 和 buffer。
在 View 语法中Component 的规范名称可以省略 `etaf-` 前缀。如果短名称会与 Elisp 函数、special form 或 Host 冲突,注册表会分配语义明确的 `-view` alias。普通 Elisp API例如 `etaf-value`、`etaf-ref` 和 `etaf-mount`,始终保留前缀
Component 调用使用定义时准确注册的名称,注册表不会自动生成省略前缀或 `-view` alias。官方目录组件使用 `etaf-button` 等名称;应用可以显式使用任何合法且尚未占用的名称定义自己的组件
## 5. children 与 slot
@ -192,7 +198,7 @@ children 只是匿名/默认 slot 的便捷写法,不是第二套内容模型
```elisp
(card
:title "Account"
(slot :name 'header (text :face 'bold "Account settings"))
(slot :name 'header (text :font-weight 'bold "Account settings"))
(text "Card body"))
```
@ -200,19 +206,25 @@ children 只是匿名/默认 slot 的便捷写法,不是第二套内容模型
```elisp
(slot)
(slot (text :face 'shadow "No content"))
(slot (text :color "#687386" "No content"))
```
完整的内部规范写法是:
```elisp
(slot :name 'default (text :face 'shadow "No content"))
(slot :name 'default (text :color "#687386" "No content"))
```
对用户来说,优先使用前两个简写;只有需要明确名字时才写 `:name`。Slot 名称必须是稳定的、非 keyword 的 symbol。字符串、数字、变量和运行时表达式都会被拒绝因为 slot 名称属于 retained 结构。同名输入只能出现一次。显式空输入 `(slot :name 'header)` 会抑制 outlet fallback。Slot form 不创建 Ebox wrapper。
在 Component 内,`slot` 表示投影;在 Component 调用的子节点区,带 `:name``slot` 表示贡献内容。编译器对两种位置使用同一个规范化 slot 表示。
Slot 中作者写下的表达式在整个投影子树中保留作者的 props、state 和 Context。
其中创建的 Component 拥有自己的 props、state、styles 和 Scope但其 Context
从 slot 作者环境继承。接收方自己定义的 fallback、普通子节点和产生 View 的
callback 使用接收方环境。Table/Grid 的 cell callback 遵循相同的普通规则:
Context 来自消费它的 Table/Grid 所在位置。
## 6. Core Host 与 Ebox
ETAF core 只提供最小且无样式的 Host
@ -237,18 +249,9 @@ text · fragment · container · row · column · stack · flex · grid · space
`grid` 复用 Ebox 的公共二维布局契约,支持轨道模板、`auto`/分数/`minmax` 轨道、间距、行列放置、跨度、自动流向和 item 对齐。轨道测量和放置由 Ebox 负责ETAF 只把 `grid` Host 映射到这个节点。Ebox 的可选 native reflow 后端不参与正确性保证;如果该后端不支持 GridGrid 树会使用普通 Ebox 渲染器。
ETAF 的 Renderer 是唯一调用 Ebox 的框架模块,并且只使用 Ebox 公共构造器、属性读取器、Host 引用查询和发布 API。Ebox 不理解 Component、slot、Action、Context、Behavior 或 Data。
ETAF 的 Renderer 是唯一把 View 语义 lower 为 Ebox 节点、属性与 Host 查询的框架模块;`etaf-render-port.el` 是唯一探测 versioned Ebox framework SPI 并选择发布路径的模块。两者都只使用 Ebox 公共 APIRuntime 只读取已经选定的 immutable port不再自行猜测 Ebox 版本。Ebox 不理解 Component、slot、Action、Context、Behavior 或 Data。
`raw-ebox` 是唯一明确的底层出口:
```elisp
(etaf-view
(raw-ebox
:key 'backend-row
:value (ebox-create :content "Low-level")))
```
它只接受 `:value` 和可选的 `:key`。返回的 Ebox Node 保持 opaque不获得 Component props、slot、事件或 Behavior 语义。使用它意味着调用方承担 measurement、identity、rollback 和 backend 契约。
公共 View 语法不接受裸 Ebox Node。框架集成层通过 Ebox 的 typed integration port 构造规范的 TextNode 和 BoxNode普通 ETAF 应用只使用 Host 与 Component。这样 measurement、identity 和 rollback 始终由同一条 lowering 路径负责。
## 7. Runtime 与响应式状态
@ -305,6 +308,16 @@ Behavior = 安装多个非视觉能力的可复用 bundle
`etaf-behavior-create` 接受保留的 `:install` 属性,用于可选的零参数 installer。Installer 可以返回 cleanup运行期间可通过 `etaf-current-behavior-context` 读取当前 Runtime、结构路径和 Host props。Behavior 被替换或 owner 卸载时installer 状态会被释放。
交互组合是确定的:显式 Host `:on-*` callback 先运行,然后按声明顺序运行 Behavior
callback任一错误会 short-circuit 后续 callback。非事件属性由显式 Host 值优先,
否则第一个声明该属性的 Behavior 获胜first-wins。同一 Host 的 Behavior name 必须在任何
installer 运行前保持唯一。稳定 installer identity 会复用,每个已安装 cleanup
exactly-once。事件只 dispatch 给准确 Host refETAF 没有 capture 或 bubble 阶段。
Action name 应使用 application/feature-prefixed symbol。重复注册默认报错。
`etaf-action-redefine-run` 是显式 authoring/reload 边界;替换只影响未来按 name 的
dispatch不会 flush 已挂载 Runtime。
Runtime 事件通过 `etaf-dispatch-event` 进入;命中测试和 focus 通过 Ebox Host 引用查询,并由 `etaf-activate`、`etaf-focus`、`etaf-focus-next`、`etaf-host-ref-bounds` 和 `etaf-host-ref-position` 提供公共入口。
## 9. Context、Theme、Data 与 Resource
@ -313,34 +326,48 @@ Runtime 事件通过 `etaf-dispatch-event` 进入;命中测试和 focus 通过
Context 是继承的 Component Scope 环境:
<!-- etaf-example: context -->
```elisp
(etaf-define-component service-provider ()
"Provide a reactive service to descendants."
:setup
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
(lambda () (etaf-view (slot)))))
(require 'etaf)
(etaf-define-component service-consumer ()
"Read the inherited service."
:setup
(let ((service (etaf-inject 'service nil t)))
(lambda ()
(etaf-view (text (expr :value (etaf-value service)))))))
:setup (etaf-inject 'service nil t)
:view (text (expr (format "Service: %s" (etaf-value (etaf-state))))))
(etaf-view (service-provider (service-consumer)))
(etaf-define-component service-provider ()
"Provide a reactive service to its own child Component."
:setup
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
service)
:view (service-consumer))
(etaf-mount "*etaf-context*" (etaf-view (service-provider)))
```
key 使用稳定的普通 symbol。最近的祖先优先缺失的 required key 触发 `etaf-context-error`。Theme 是一个 Context value内容是属性 plist
key 使用稳定的普通 symbol。最近的祖先优先缺失的 required key 触发
`etaf-context-error`。在根位置编写的 slot 内容及其子树保留根的空 Context。
迁移旧版本中意外继承接收方 Context 的用法时,应把消费者写进 provider 自己的
View或在那里调用普通的 View-producing callback。投影的 slot 继续使用作者
环境。Theme 遵循同一套 Context 继承关系,内容是属性 plist
<!-- etaf-example: theme -->
```elisp
(require 'etaf)
(etaf-define-component themed-shell ()
"Provide default text colors to a subtree."
"Provide semantic colors to its own View."
:setup
(progn
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
(lambda () (etaf-view (slot)))))
(etaf-theme-provide
'(:text-color "#F4F6FB" :surface-color "#202634"))
:view
(text :ref 'themed-content
:color (etaf-theme-token :text-color)
:background-color (etaf-theme-token :surface-color)
"Themed content"))
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
```
Palette 解析属于 Theme而不是 UI 目录。core 提供
@ -437,6 +464,78 @@ mounted Component、expr、slot、fragment、raw、inline 和 Root owner 都经
replacement不相交 owner 会合并为一次 TP/Ebox publication。只有 Root owner
可以进入 complete-root adapter。
已提交 semantic generation 的唯一 mutable pointer 由
`etaf-generation-authority` 持有。handler 与 Host-prop 等公共查询直接读取该
generationRuntime 中同名 hash table 只是由 generation 单向重建的兼容 mirror
既不能独立授权查询,也不能反向改写 generation。迁移期的
`legacy`/`project`/`shadow` 路由只用于证明投影等价与安全回退,不增加第二份
committed truth。
进程 bootstrap 时,`etaf-render-port` 要求 Ebox framework SPI v2并 snapshot
唯一的不可变 port。provider 缺失、格式错误或不兼容都会在 Runtime mount 前 fail
closed。按依赖顺序升级时Ebox 可暂时报告 TP v1+v2 双能力 manifest也可报告最终
的 v2-only manifest两者都证明所需的 v2 capabilityETAF 不会调用 v1 operation。
mounted 或 in-flight Runtime 绝不会切换 port。
每个 semantic candidate 同时捕获 expected generation、semantic token以及
instance/resource/artifact/route store versions。render 路径在 Ebox framework
stage 中暂存一次 CAS失败时由同一个 inverse journal 恢复;没有可见 Ebox
变化的 semantic-only 路径由 ETAF 自己执行同一 CAS不创建 Ebox commit 或 TP
revision。CAS 后的 mirror 与旧 route 清理属于 postcommit失败不能反向恢复已提交
token这类失败会写入 retirement diagnostic journal并用与 lifecycle failure
相同的 committed trailer 重新 signal绝不会重新进入 semantic rollback。
每个 mounted Runtime 还拥有独立的 Host authority`state / opaque token /
version`。initial v2 framework stage 只进入 provisional state并向 TP 注册固定
slot final marker只有 buffer final accept 成功时 Host 才成为 attached。公开
lookup、event 和 source route 同时校验 attached state 与 token。detach 先在 O(1)
边界让 token 失效,再清理 registry、routes、Component scopes 和 Behaviors因此
cleanup 数量或错误不能让旧 Host 重新获得 authority。
lifecycle callback 与结构 cleanup 在该 commit boundary 之后进入
`etaf-retirement-journal`。每个 entry 都有稳定 identity、ordering key、attempt
count、policy 与 terminal state。mounted、updated、unmounted 等公开 callback
只运行一次;第一个公开 callback 失败后,后续公开 callback 标记为 abandoned
但结构 cleanup 继续。可幂等的框架 cleanup 只做有上限的重试contained cleanup
只写 diagnostics不改变已提交 generation、Ebox revision 或 Host authority。
Runtime 以有界历史保存已完成 journal且它们与 committed outcome 分离。
当显式操作需要向调用者暴露 postcommit callback 错误时ETAF 会用原 condition
symbol 重新 signal并逐项保留原 condition data 前缀;末尾只追加一个固定
`:etaf-condition-trailer/v1` datum其中包含 operation、outcome、generation、
Ebox revision 与 diagnostic-journal ID。`etaf-condition-postcommit-info` 会校验并
读取该 trailer让调用者机械区分“已经提交、随后 callback 失败”和 rollback
failure。buffer-kill 路径会 drain 或 contain retirement 工作,但绝不会从 kill
hook 抛 retirement condition。
Reactive publication 由显式 `etaf-scheduler-context` 协调。context 拥有 source
与 Runtime FIFO、对应 dedupe set、effect claim、turn/projection epoch、
nesting/busy 状态、fault diagnostics 与成本计数器;它不拥有 Component、
resource 或 generation state。既有调用者继续使用
`etaf-scheduler-default-context`mount 也可以传入 `:scheduler-context` 隔离
dispatch authority。Scope、Effect 与 opaque Runtime route 会继承并保留该
context。
一次 logical projection 会先按 live subscriber context 对所有 changed source
在一次 subscriber-table scan 中分组;所有已触及 context 的 source propagation
都稳定后Runtime callback 才能 publish。在同一 context 中,每个 source 与
Effect 每个 scheduler turn 只 delivery 一次,多个 changed source 也只 enqueue
同一 Runtime 一次。已经 delivery 的 source 若重入写入,会延后到下一个 turn
per-context turn budget 会包含跨 context cycle并留下可复用的 fault diagnostics。
每个 source wave 都会 snapshot 当前 FIFO因此 wave 中发现的不同 source 必须在
下一个受预算约束的 turn 执行,不能垄断一次 drain。context A 的 dedupe 不会压制
context Bregistry/token/Host 校验会在 fan-out 前过滤 stale Runtime route。
Runtime callback 先作为一个完整 turn detach因此 lifecycle write 会进入下一个
turn某个 callback 失败时scheduler 会先执行该 detached turn 中剩余 callback
再把首个 condition 记录为 context fault。Data success/error 的 multi-ref
publication 与 event/action callback 都复用同一个 projection boundarylegacy
façade 则继续走 default context。Data source failure 会更新 Controller error state
之后发生的 projection/render failure 保持原 condition不能被重新归类为 source
failure。Runtime operation report 同时携带本 context delta 与完整 cross-context
projection summary覆盖 source delivery、
subscriber visit、effect work、Runtime work、stale drop、turn 与 fault。
每次 Runtime flush 都记录 candidate-aware effect tuple其中包含 generation id、
effect→source 边和 source version以及 candidate input/context/output facts 的
immutable semantic-node stamp。重复 tuple 会报告有序的 effect/edge pathstep
@ -464,6 +563,5 @@ registry 决定当前 authority。失败 candidate 只移除 staged Behavior res
| 跨层级依赖 | Context |
| 请求或变更状态 | Data / Resource |
| 几何或布局算法 | Ebox |
| 低层 backend 出口 | `raw-ebox` |
只有在现有 owner 无法表达、能够明确 identity/lifecycle/error/rollback 规则,并且可以用公共路径测试证明时,才增加新的公共概念。这样既保留完整的 Elisp 表达能力,又让用户模型保持干净。

View File

@ -18,7 +18,7 @@ The repository is complete for the agreed unified architecture when the mandator
| Milestone | Delivered responsibility | Evidence |
| --- | --- | --- |
| P0 grammar | Unified View shape, property-first parsing, `etaf-view`, `expr :value`, core Hosts, aliases | `tests/etaf-tests.el` structural and syntax tests |
| P0 grammar | Unified View shape, property-first parsing, `etaf-view`, `(expr FORM)`, core Hosts, exact registered Component names | `tests/etaf-tests.el` structural and syntax tests |
| P1 Components | `:view`, `:setup`, props, default/named slots, retained instances, lifecycle, `:key`, raw Ebox escape | Component, slot, mount, prop-update, raw-node, and rollback tests |
| P2 Runtime | refs, computed, effects, watches, Scope cleanup, Context, Theme, Behaviors, events, focus, Actions | Mounted event/focus tests, reactive failure rollback, cleanup tests |
| P3 presentation | scoped styles, selector matching, Theme precedence, inline text runs, Resource and error boundary | Style, Theme, text-surface, Resource, and error tests |
@ -55,21 +55,26 @@ Do not split a file merely to create a shorter name. Split only when a stable re
- The only structural form is `(NAME :PROPERTY VALUE ... CHILD ...)`.
- All properties precede children.
- Attribute values are ordinary Elisp expressions.
- The only child computation bridge is `(expr :value ELISP-EXPRESSION)`.
- The only child computation bridge is `(expr ELISP-EXPRESSION)`; its result
may be text, a typed View/proper typed View sequence, or `nil`.
- A dynamic View returned by Elisp is constructed with `(etaf-view ...)` inside `expr`; quoted structural data is never executed.
- Core Hosts are `text`, `fragment`, `container`, `row`, `column`, `stack`, `flex`, `grid`, and `spacer`.
- `raw-ebox` accepts only `:value` and optional `:key` and remains opaque to ETAF semantics.
- The six visible Host forms are `text`, `box`, `row`, `column`, `flex`, and `grid`; `fragment`, `slot`, and `expr` are transparent framework structure.
- There is no raw Ebox View escape hatch. Framework integrations use Ebox's evaluated typed-constructor port outside the author DSL.
### 4.2 Component and slots
- `etaf-define-component` accepts only `:view`, `:setup`, and optional `:styles`.
- `:view` and `:setup` are mutually exclusive.
- `:setup` runs once per retained identity and returns a zero-argument render function.
- `etaf-define-component` chooses exactly one of `:view` or `:render`; `:setup`
and `:styles` are optional.
- `:view` and `:render` are mutually exclusive frontends for one View model;
ordinary `:render` may return `etaf-view`, preserving lexical scope and the
same compiler prop/slot rules.
- `:setup` runs once per retained identity and returns opaque state read with
`etaf-state` during either frontend.
- Props update render without rerunning setup.
- Trailing children are `slots.default`; named slot input uses `(slot :name 'NAME CHILD...)`.
- Default outlet shorthand is `(slot)` or `(slot FALLBACK...)`.
- Slot names are stable, non-keyword symbols only.
- `:key` is identity metadata, not a business prop: Component calls use it for retained identity, while Hosts and `raw-ebox` forward it as an Ebox node key.
- `:key` is identity metadata, not a business prop: Component calls use it for retained identity, while Hosts project the same parsed fact into the Ebox source index.
### 4.3 Runtime and non-visual capabilities

View File

@ -18,7 +18,7 @@
| 里程碑 | 已交付职责 | 证据 |
| --- | --- | --- |
| P0 grammar | 统一 View 形状、属性优先解析、`etaf-view`、`expr :value`、核心 Host、alias | `tests/etaf-tests.el` 结构和语法测试 |
| P0 grammar | 统一 View 形状、属性优先解析、`etaf-view`、`(expr FORM)`、核心 Host、准确注册的 Component 名称 | `tests/etaf-tests.el` 结构和语法测试 |
| P1 Component | `:view`、`:setup`、props、默认/命名 slot、retained instance、生命周期、`:key`、raw Ebox 出口 | Component、slot、mount、prop 更新、raw node、rollback 测试 |
| P2 Runtime | ref、computed、effect、watch、Scope cleanup、Context、Theme、Behavior、事件、focus、Action | 挂载事件/focus、响应式失败回滚和 cleanup 测试 |
| P3 presentation | 作用域样式、selector、Theme 优先级、inline text runs、Resource 和 error boundary | 样式、Theme、文本 surface、Resource、error 测试 |
@ -55,21 +55,25 @@
- 唯一结构形式是 `(NAME :PROPERTY VALUE ... CHILD ...)`
- 所有属性必须先于所有子节点。
- 属性值是普通 Elisp 表达式。
- 唯一的子节点计算桥接是 `(expr :value ELISP-EXPRESSION)`
- 唯一的子节点计算桥接是 `(expr ELISP-EXPRESSION)`结果可以是文本、typed View、
typed View proper sequence 或 `nil`
- Elisp 返回动态 View 时,在 `expr` 中用 `(etaf-view ...)` 构造;被 quote 的结构数据永远不会被执行。
- Core Host 是 `text`、`fragment`、`container`、`row`、`column`、`stack`、`flex`、`grid` 和 `spacer`
- `raw-ebox` 只接受 `:value` 和可选 `:key`,并且对 ETAF 语义保持 opaque
- 六个可见 Host form 是 `text`、`box`、`row`、`column`、`flex`、`grid``fragment`、`slot`、`expr` 是透明的框架结构
- View 作者 DSL 不提供 raw Ebox 逃生口;框架集成在作者 DSL 之外使用 Ebox evaluated typed-constructor 端口
### 4.2 Component 与 slot
- `etaf-define-component` 只接受 `:view`、`:setup` 和可选 `:styles`
- `:view``:setup` 互斥。
- `:setup` 对每个 retained identity 只运行一次,返回零参数 render 函数。
- `etaf-define-component` 必须在 `:view``:render` 中恰好选择一个;`:setup` 与
`:styles` 可选。
- `:view``:render` 是同一 View 模型的互斥 frontend普通 `:render` 可返回
`etaf-view`,保留词法作用域与相同的 compiler prop/slot 规则。
- `:setup` 对每个 retained identity 只运行一次,返回 opaque 状态,并由两个 frontend
中的 `etaf-state` 读取。
- Props 更新只重新 render不重新运行 setup。
- 尾部 children 是 `slots.default`;命名 slot 输入使用 `(slot :name 'NAME CHILD...)`
- 默认 outlet 简写是 `(slot)``(slot FALLBACK...)`
- Slot name 只能是稳定的、非 keyword 的 symbol。
- `:key` 是 identity metadata不是业务 propComponent 调用用它选择 retained identityHost `raw-ebox` 则把它作为 Ebox node key 向下传递
- `:key` 是 identity metadata不是业务 propComponent 调用用它选择 retained identityHost 则把同一个解析后的事实投影到 Ebox source index
### 4.3 Runtime 与非视觉能力

16
docs/migration-0.2.en.md Normal file
View File

@ -0,0 +1,16 @@
# Migrating to ETAF 0.2
ETAF 0.2.1 requires Ebox 3.0.0 and TP 2.0.0. Install TP, then Ebox, then ETAF.
The renderer bootstrap now requires Ebox framework SPI v2 and fails closed when
the provider is absent, malformed, or incompatible.
Remove any configuration of `etaf-render-port-selection-policy`. The v1 render
port and its manual initial-publication cleanup path have been retired. Runtime
mounts and updates always use the immutable SPI v2 port, including its paired
framework stage and rollback, same-object report, observation replay, revision,
and Host final-marker contracts.
During an ordered source upgrade, ETAF accepts Ebox providers that report either
`tp-transaction-protocol-v1+v2` or `tp-transaction-protocol-v2`. The former is a
temporary capability declaration that still contains the required v2 protocol;
ETAF never invokes a v1 transaction operation.

14
docs/migration-0.2.zh.md Normal file
View File

@ -0,0 +1,14 @@
# 迁移到 ETAF 0.2
ETAF 0.2.1 要求 Ebox 3.0.0 与 TP 2.0.0。安装顺序为 TP、Ebox、ETAF。
renderer bootstrap 现在强制要求 Ebox framework SPI v2provider 缺失、格式错误
或不兼容时会 fail closed。
请删除所有 `etaf-render-port-selection-policy` 配置。v1 render port 及其 initial
publication 手工清理路径已经退役。Runtime mount 与 update 始终使用不可变的 SPI
v2 port并保留配对 framework stage/rollback、同对象 report、observation replay、
revision 与 Host final marker 契约。
按依赖顺序从源码升级时ETAF 接受 Ebox 报告
`tp-transaction-protocol-v1+v2``tp-transaction-protocol-v2`。前者只是包含所需
v2 协议的过渡期能力声明ETAF 不会调用 v1 transaction operation。

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -7,6 +7,8 @@ ETAF builds text applications from one small vocabulary: `View`, `Component`, pr
ETAF depends on the independent Ebox package. During development, put the core checkouts on `load-path` and load the one public ETAF entry:
```elisp
(add-to-list 'load-path "/path/to/github/ecss")
(add-to-list 'load-path "/path/to/github/tp")
(add-to-list 'load-path "/path/to/github/ebox")
(add-to-list 'load-path "/path/to/github/etaf")
(require 'etaf)
@ -27,7 +29,7 @@ Properties come first and children come last. `etaf-view` receives an unquoted s
```elisp
(etaf-view
(column
(text :face 'bold "Hello")
(text :font-weight 'bold "Hello")
(text :color "#687386" "Welcome to ETAF")))
```
@ -38,7 +40,7 @@ Mount it into an Emacs buffer:
"*etaf-hello*"
(etaf-view
(column
(text :face 'bold "Hello")
(text :font-weight 'bold "Hello")
(text "This is a text application."))))
```
@ -62,11 +64,43 @@ that viewport directly instead of immediately rerendering:
```elisp
(ebox-render
(etaf-render
(etaf-view (text :face 'bold "Pure View"))))
(etaf-view (text :font-weight 'bold "Pure View"))))
```
Use `etaf-mount` whenever a View contains a stateful Component, reactive data, events, or lifecycle.
To request pending work explicitly, call `(etaf-runtime-flush runtime)`.
Its return value is now the **integer committed Ebox revision**, replacing the
previous Ebox-node return type. Busy or batched work may remain pending; the
returned revision identifies the publication currently visible to readers.
Calls inside an active Ebox/TP transaction fail before requesting work, since
that transaction's revision may still be provisional. Ordinary flushes do not
export a tree or force a Root rebuild.
For a current tree and its matching source facts, request an explicit snapshot:
```elisp
(let* ((runtime (etaf-runtime-for-buffer "*etaf-hello*"))
(snapshot (etaf-runtime-snapshot runtime)))
(list (plist-get snapshot :revision)
(plist-get snapshot :mount-id)
(ebox-render (plist-get snapshot :input))))
```
The snapshot contains `:input` (a canonical Ebox input), `:revision`, and
`:mount-id` (the identity of this mount). Exporting costs O(N) and detaches
ordinary mutable node payload; it does not drain pending work, evaluate
Components, publish, or increment the revision. The input remains usable after
later commits or unmount. Opaque capabilities such as callbacks keep their
identity; the query does not freeze external capabilities or the display
environment. Unmounted Runtime and active Ebox/TP transaction queries fail.
The obsolete `etaf-runtime-root-node` getter remains read-compatible through
this O(N) query and returns the current single root. Runtime no longer stores a
root mirror. Migrate consumers to `etaf-runtime-snapshot` so the canonical input
retains the root's matching source facts; do not treat the obsolete getter as a
cheap field read or use it as a mutation target.
The current core has no direct `.etaf` loader. `etaf-define-component` is the structure/style/behavior unit: use its View for structure, `:styles` for static presentation, and `:setup` for retained state, Actions, and lifecycle. A future `.etaf` SFC belongs to a compiler layer that emits this same Component contract; it is not a second Runtime entry point.
## 3. Properties and children
@ -78,9 +112,9 @@ Attribute values are ordinary Elisp expressions. They do not need an extra `expr
(label "Theme"))
(etaf-view
(text
:face (if dark 'light 'dark)
:color "#F4F6FB"
(expr :value label))))
:color (if dark "#F4F6FB" "#1F2328")
:background-color "#20242B"
(expr label))))
```
The child region is structural. `expr` is the one explicit bridge for ordinary Elisp computation:
@ -88,14 +122,17 @@ The child region is structural. `expr` is the one explicit bridge for ordinary E
```elisp
(etaf-view
(column
(expr :value (if loading "Loading..." "Ready"))
(expr (if loading "Loading..." "Ready"))
(expr
:value
(when open
(etaf-view (text :face 'italic "Details"))))))
(etaf-view (text :font-style 'italic "Details"))))))
```
`expr` accepts exactly `:value` and no children. Its result can be a string, View, sequence, or `nil`. `if`, `when`, `cond`, `let`, `mapcar`, and `cl-loop` remain normal Elisp inside the value.
`expr` accepts exactly one ordinary Elisp form and no structural children. Its
result in structural child positions can be a string, typed Host or Component
View, a proper sequence of these values, or `nil`. Inside a `text` Host an
expression must return a string.
`if`, `when`, `cond`, `let`, `mapcar`, and `cl-loop` remain normal Elisp.
Quote has one ordinary Elisp meaning:
@ -103,7 +140,12 @@ Quote has one ordinary Elisp meaning:
- Quote literal symbols and data lists when Elisp requires data.
- Use `(etaf-view ...)` inside an expression when the expression must construct a View.
For example, `'bold` is the face symbol, while `'(text "data")` is only data and will not render. A dynamic View must be written as `(etaf-view (text "data"))`.
For example, `'bold` is the `:font-weight` symbol, while `'(text "data")` is only data and will not render. A dynamic View must be written as `(etaf-view (text "data"))`.
Spacing follows the layout Host: `row` and `column` use `:item-gap`, for
example `(row :item-gap 1 ...)`; `flex` and `grid` use `:gap`. Changing the Host
also changes which spacing property to use; these are not interchangeable
aliases. For example, migrate `(row :gap 1 ...)` to `(row :item-gap 1 ...)`.
The core `grid` Host is the two-dimensional layout choice:
@ -113,16 +155,16 @@ The core `grid` Host is the two-dimensional layout choice:
(etaf-view
(grid
:width '(640)
:grid-template-columns '((200) 1fr)
:grid-template-columns '((200) (fr 1))
:grid-template-rows '(1 1)
:gap '(1 (12))
(text :face 'bold "Name")
(text :font-weight 'bold "Name")
(text "Value")
(text "Ada")
(text "Lovelace"))))
```
Use `auto`, `(fr FACTOR)`, symbols such as `1fr`, `(minmax MIN MAX)`, and `(repeat COUNT TRACK)` in track templates. `:grid-auto-columns` and `:grid-auto-rows` size implicit tracks; `:grid-auto-flow` accepts `row` or `column`. Children may use `:grid-column`, `:grid-row`, `:grid-column-span`, and `:grid-row-span`; Ebox performs measurement, placement, and item/content alignment. The optional native backend falls back to the Elisp Ebox renderer for Grid trees.
Use `auto`, `min-content`, `max-content`, `(fr FACTOR)`, `(minmax MIN MAX)`, and `(repeat COUNT TRACK-LIST)` in track templates. `:grid-auto-columns` and `:grid-auto-rows` size implicit tracks; `:grid-auto-flow` accepts `row` or `column`. Children may use `:grid-column`, `:grid-row`, `:grid-column-span`, and `:grid-row-span`; Ebox performs measurement, placement, and item/content alignment. The optional native backend falls back to the Elisp Ebox renderer for Grid trees.
## 4. Define a Component
@ -133,8 +175,8 @@ The beginner form is a stateless `:view` Component:
"Render a status label."
:view
(text
:face 'bold
(expr :value label)))
:font-weight 'bold
(expr label)))
(etaf-mount
"*etaf-status*"
@ -142,20 +184,21 @@ The beginner form is a stateless `:view` Component:
(status-label :label "Connected")))
```
The canonical Component name may include the `etaf-` prefix:
Use the exact name supplied to `etaf-define-component`:
```elisp
(etaf-view (etaf-status-label :label "Connected"))
(etaf-view (status-label :label "Connected"))
```
In a View position, ETAF also registers the short alias `status-label`. If a short name conflicts with Elisp, the registry uses a semantic alias ending in `-view`. This alias rule applies only to View names; ordinary functions remain prefixed.
The registry creates no automatic aliases. A Component defined as `etaf-status-label` must be called by that exact name; the `status-label` above is the name explicitly defined in this guide. Official catalog names are `etaf-button`, `etaf-checkbox`, and so on, after requiring `etaf-ui`.
The definition macro accepts only these keywords:
| Keyword | Meaning |
| --- | --- |
| `:view` | The stateless View producer; mutually exclusive with `:setup` |
| `:setup` | One-time Component initialization returning a zero-argument render function |
| `:view` | Declarative View frontend; mutually exclusive with `:render` |
| `:render` | Ordinary Elisp returning one typed View, usually with `etaf-view`; programmatic builders may use `etaf-node` |
| `:setup` | Optional one-time initialization returning opaque state read with `etaf-state` |
| `:styles` | Optional static scoped style declaration |
There is no separate declaration block for children, slots, events, state, or variants. Props are declared with `(&key ...)`; children and slots are implicit content.
@ -168,23 +211,38 @@ Use `:setup` when the Component owns local state:
(etaf-define-component counter (&key title)
"Render a retained counter."
:setup
(let ((count (etaf-ref 0)))
(let ((count (etaf-ref 0))
(initial-title title))
(etaf-on-mounted
(lambda () (message "%s mounted" title)))
(lambda () (message "%s mounted" initial-title)))
(etaf-on-unmounted
(lambda () (message "%s unmounted" title)))
(lambda ()
(etaf-view
(column
(text :face 'bold (expr :value title))
(text (expr :value (format "Count: %d" (etaf-value count))))
(text
:role 'button
:on-press (lambda () (cl-incf (etaf-value count)))
"Increment"))))))
(lambda () (message "%s unmounted" initial-title)))
count)
:render
(let ((count (etaf-state))
(caption title))
(etaf-view
(column
(text :font-weight 'bold (expr caption))
(text (expr (format "Count: %d" (etaf-value count))))
(text :role 'button :tab-index 0
:on-press (lambda () (cl-incf (etaf-value count)))
"Increment")))))
```
Setup runs once for the retained instance. Its returned render function runs on each update. `etaf-on-mounted`, `etaf-on-updated`, and `etaf-on-unmounted` register lifecycle callbacks for that Component instance. Scope disposal automatically stops reactive effects and cleanup.
Setup runs once for the retained instance and returns one opaque state value.
The selected `:view` or `:render` frontend runs on each update and reads that
exact value with `etaf-state`. `etaf-on-mounted`, `etaf-on-updated`, and
`etaf-on-unmounted` register lifecycle callbacks for that Component instance.
Scope disposal automatically stops reactive effects and cleanup.
`:view` and `:render` share compilation, slot projection, and prop validation.
Use ordinary `let`/`let*` to capture state handles or current prop values for
callbacks. `etaf-state` is a render-time accessor, not an event-time accessor.
Keep reactive `etaf-value` reads inside the property or `expr` that needs the
update; extracting a handle does not require reading its value early. Component
code with retained closures belongs in an `.el` file with lexical binding.
Simple local callbacks need no Action definition.
The small reactive API is:
@ -219,8 +277,8 @@ Trailing children are the anonymous/default slot:
"Render a titled panel."
:view
(column
(text :face 'bold (expr :value title))
(slot (text :face 'shadow "No content"))))
(text :font-weight 'bold (expr title))
(slot (text :color "#687386" "No content"))))
(etaf-view
(panel
@ -236,8 +294,8 @@ Named slots use `:name` and must use a stable non-keyword symbol:
:view
(column
(slot :name 'header
(text :face 'bold (expr :value title)))
(slot (text :face 'shadow "No body"))))
(text :font-weight 'bold (expr title)))
(slot (text :color "#687386" "No body"))))
(etaf-view
(card
@ -248,6 +306,30 @@ Named slots use `:name` and must use a stable non-keyword symbol:
The two default-slot shorthands are `(slot)` and `(slot FALLBACK...)`. The normalized spelling is `(slot :name 'default FALLBACK...)`. At a call site, ordinary children fill `default`; a named input uses `(slot :name 'header CHILD...)`. An explicit empty `(slot :name 'header)` suppresses the fallback. Strings, numbers, variables, and runtime expressions are not valid slot names.
Slot expressions keep their author's props, state, and Context throughout the
projected subtree. Components created inside that subtree still own their own
props, state, styles, and Scope; they inherit Context from the slot author's
environment. A receiving Component does not inject its own Context into caller
content. Its fallback, ordinary children, and View-producing callbacks use its
own environment. A Table/Grid cell callback likewise runs in the consuming
Table/Grid's Context.
`expr` may return a typed View or a proper sequence of typed Views at a
structural boundary. It never exposes or accepts ETAF's private structs. The
same Component can combine a keyed `:for`, a structural expression, and a
named footer slot:
```elisp
(etaf-define-component etaf-docs-collection-card (&key items footer-view)
"Render keyed rows, one dynamic typed View, and a footer slot."
:view
(column
(row :for (item items) :key (car item)
(text (expr (cdr item))))
(expr footer-view)
(slot :name 'footer (text "No footer"))))
```
## 7. Styles and themes
Static Component styles use one declaration form:
@ -259,8 +341,8 @@ Static Component styles use one declaration form:
(styles
("&"
:padding (1 2)
:border ((1) solid "#687386"))
(".title" :face bold)
:border (1 solid "#687386"))
(".title" :font-weight bold)
(".danger" :color "#FF6B6B"))
:view
(column
@ -287,14 +369,22 @@ Styles are scoped to the Component that authored a View node. A parent rule does
Theme is a Context convenience, not another runtime object:
<!-- etaf-example: theme -->
```elisp
(require 'etaf)
(etaf-define-component themed-shell ()
"Provide default text colors to a subtree."
"Provide semantic colors to its own View."
:setup
(progn
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
(lambda () (etaf-view (slot)))))
(etaf-theme-provide
'(:text-color "#F4F6FB" :surface-color "#202634"))
:view
(text :ref 'themed-content
:color (etaf-theme-token :text-color)
:background-color (etaf-theme-token :surface-color)
"Themed content"))
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
```
For a light/dark application palette, keep the semantic roles in one palette
@ -372,6 +462,42 @@ For a reusable installer, reserve `:install` for the cleanup-producing part of t
The installer can call `etaf-current-behavior-context` when it needs the current Runtime or Host path. Replacing the Behavior runs the old cleanup before the new state becomes current. Behavior equality keeps function and reactive-value identity with `eq`; a newly-created installer closure is therefore a deliberate replacement, not an accidental reuse. The replacement is staged under the mounted resource registry and becomes authoritative only when its generation commits.
<a id="interaction-migration"></a>
Root event forwarding is additive: the internal business handler runs first,
then extra wrapper callbacks from inner to outer, then Behaviors in declaration
order. Each declaration runs once. For a Checkbox, `:on-change` still receives
the next boolean before an added `:on-press` observer. A callback error
short-circuits the remaining callbacks; UI rollback does not undo external
business writes. Dispatch targets one exact Host, with no capture or bubble.
Wrapper `:use` lists concatenate; duplicate Behavior names fail before any
installer runs. Non-event Behavior defaults retain first-wins order after Host
attributes, except `:disabled`, which combines with OR. Inner and outer disabled
inputs are recomputed on every update: callers can further disable a control,
and clearing the outer input enables it only when its inner input is also nil.
Disabled Hosts reject `etaf-dispatch-event` and `etaf-focus` with
`etaf-event-error`. Their input Behaviors are not installed; a committed disable
cleans up installed resources, and re-enabling installs them again.
Hit testing selects the deepest interaction boundary before checking whether
it is enabled. Clicking a disabled cell button does not activate its parent
row, including when their bounds coincide. Ordinary non-interactive row text
can still select the row; explicitly focusing the row can activate its action.
Migration: an extra root `:on-*` callback now appends instead of replacing the
existing action. To define a different business action, use the Component's
explicit business callback prop or define a Component with that behavior.
Fallthrough cannot change an existing `:role` or owned aria state such as
`:aria-checked` to a conflicting value; that signals a Component input error.
Expose an intentional semantic variation as a business prop. Caller-provided
`:aria-label` and `:aria-description` can still override accessible text.
Use application- or feature-prefixed Action names. Duplicate Action
registration is an error. During deliberate reload, wrap the replacement in
`etaf-action-redefine-run`; it changes future name-based dispatch without
flushing the mounted Runtime.
Focus and hit testing are Runtime operations:
```elisp
@ -388,29 +514,38 @@ Mounted buffers enable `etaf-input-mode` automatically. `TAB` focuses the next H
Use Context for a dependency shared across component depth, not for ordinary props:
<!-- etaf-example: context -->
```elisp
(etaf-define-component application-shell ()
"Provide a service to descendants."
:setup
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
(lambda () (etaf-view (slot)))))
(require 'etaf)
(etaf-define-component service-label ()
"Read the inherited service."
:setup (etaf-inject 'service nil t)
:view
(text (expr (format "Service: %s" (etaf-value (etaf-state))))))
(etaf-define-component application-shell ()
"Provide a service to its own child Component."
:setup
(let ((service (etaf-inject 'service nil t)))
(lambda ()
(etaf-view
(text (expr :value (format "Service: %s" (etaf-value service)))))))
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
service)
:view (service-label))
(etaf-mount
"*etaf-context*"
(etaf-view (application-shell (service-label))))
(etaf-view (application-shell)))
```
Context keys are ordinary stable symbols. The nearest ancestor wins. `etaf-inject` returns its default for an optional dependency and signals `etaf-context-error` for a required missing dependency. A provided ref or computed value keeps its reactive identity.
Migration: root-authored slot content retains the root's empty Context, including
nested Components. It no longer accidentally receives the slot receiver's
providers or Theme. Put a consumer in the provider's own View, as above, or
accept an ordinary View-producing callback and call it there when the consumer
must use the provider's Context. Use slots when content should retain its
author's Context.
## 10. Data Controllers and DataGrid
Data is included in ETAF core. A source implements the small source contract:
@ -469,8 +604,9 @@ updates only when that identity enters or leaves the main selection, including
when application code writes `etaf-data-selection` directly. The default
DataGrid path uses these refs with keyed retained row owners, so a single-select
change invalidates the old and new rows rather than the complete visible page.
Custom `:row-selected-p` and `:selected-key` contracts remain available when
selection is owned outside the Controller.
Custom `:row-selected-p` remains available when selection is owned outside the
Controller. Stable identity still comes from the required `:row-key`; there is
no second selection-key DataGrid prop.
`etaf-data-controller` accepts `:item-key` for stable selected-row lookup. When
created inside a Component setup, its internal effect Scope is owned by the
@ -559,16 +695,7 @@ Loader errors are stored in `etaf-resource-error`; cleanup/type errors remain vi
nil))
```
The only low-level escape is `raw-ebox`:
```elisp
(etaf-view
(raw-ebox
:key 'manual-node
:value (ebox-create :content "Backend node")))
```
Use it only when the normal Host and Component lowering path cannot express a real Ebox requirement. The returned Node is opaque to ETAF semantics.
The public View grammar accepts Hosts and Components, not raw Ebox Nodes. Framework integrations that need the lower-level port use Ebox's typed TextNode and BoxNode constructors directly; application Views remain on the normal Host and Component lowering path.
## 12. Playgrounds
@ -612,6 +739,8 @@ Enable the generic recorder around any application workload, then open its
ordinary `tabulated-list-mode` panel:
```elisp
(require 'etaf-performance)
;; In a buffer with a mounted ETAF Runtime:
(etaf-performance-mode 1)
(etaf-performance-show)
```
@ -620,29 +749,42 @@ Run `M-x etaf-performance-clear` before the measured reproduction. Afterwards,
press `c` in the panel, or run `M-x etaf-performance-copy-report`, to copy the
environment, summary, operation, GC, and stage data. Press `w`, or run
`M-x etaf-performance-export`, to save the same portable report as an `.eld`
file. The report and panel header include power source, low-power mode, and
system load alongside the ordinary Emacs/display environment.
file. The report and panel header include power source, low-power mode,
native-JIT state, and system load alongside the ordinary Emacs/display
environment.
The recorder creates bounded operation records for public interaction,
lifecycle, Data, Resource, and viewport boundaries. Loaded Ebox, TP, and
SQLite functions contribute nested coarse stages without depending on ETAF.
Each stage reports inclusive and exclusive milliseconds; failures and quits
are recorded and then re-signaled unchanged.
The recorder only consumes public Runtime observer reports and installs no
advice. Runtime Event, Action, mount, flush, and unmount boundaries create
bounded operation records. Ebox, TP, Data, Resource, and SQLite may contribute
flat provider stages, ordered by sequence, inside the same operation. Stages
may overlap and are therefore not reported as exclusive/self time; failures and
quits are recorded and then re-signaled unchanged.
`etaf-performance-summary` calculates grouped p50/p95/max statistics only when
requested. `etaf-performance-operation-stage-summary` ranks the package
categories of one recorded operation by exclusive time.
requested. `etaf-performance-operation-stage-summary` groups the flat stages
of one recorded operation by provider category. `etaf-performance-records`
returns defensive operation and stage snapshots; caller mutation cannot alter
retained history.
Its optional numeric runtime ID selects the identity from observer reports,
including history from a retired mount whose buffer name has since been reused.
Summary and report functions read all retained records when their argument is
omitted; explicit `nil` keeps an empty selection empty. The report's environment
is observed at export time, not at every recorded operation. Runtime durations
end at synchronous return and do not certify input-to-presentation latency;
use [the GUI action measurement entry](../scripts/README.md#measuring-an-existing-gui-action)
to record per-action foreground/target conditions and callback wall/CPU/GC time.
Use `etaf-performance-register-stage` for a temporary package-specific detail
probe. Use `etaf-performance-with-operation` for application work that does
not enter through a built-in public boundary. Disable the mode when the
capture is complete; all installed advice is removed.
Use `etaf-performance-call-operation` or `etaf-performance-with-operation` for
application work that does not enter through a built-in public boundary. Both
delegate to the same Runtime operation boundary. Disable the mode when the
capture is complete; this only detaches the Runtime observer and does not
rewrite any function.
## 14. Public API map
| API family | Main entry points | Use it when |
| --- | --- | --- |
| View and Runtime | `etaf-view`, `etaf-render`, `etaf-mount`, `etaf-unmount`, `etaf-runtime-flush` | Build, render, mount, or explicitly flush an application |
| View and Runtime | `etaf-view`, `etaf-render`, `etaf-mount`, `etaf-unmount`, `etaf-runtime-flush`, `etaf-runtime-snapshot` | Build, render, mount, flush, or explicitly export the committed application |
| Components | `etaf-define-component`, `etaf-current-prop`, `etaf-current-slots`, `etaf-component-set-styles`, `etaf-component-redefine-run` | Share a View, retain local state, style an authoring surface, or deliberately reload code |
| Reactive state | `etaf-ref`, `etaf-value`, `etaf-set-value`, `etaf-computed` | Store or derive state |
| Reactive effects | `etaf-watch`, `etaf-watch-effect`, `etaf-effect-scope`, `etaf-scope-run` | Observe state or synchronize external resources |
@ -655,23 +797,23 @@ capture is complete; all installed advice is removed.
| Resource | `etaf-resource`, `etaf-resource-result`, `etaf-error-boundary-run` | Own loader state and cleanup |
| Official UI | `require 'etaf-ui`, `etaf-button`, `etaf-checkbox`, `etaf-number-input`, `etaf-label`, `etaf-panel`, `etaf-data-grid` | Use ready-made Components |
| Playground | `etaf-playground-open`, `etaf-playground-open-ui`, `etaf-playground-close`, `ebox-playground-open`, `ebox-playground-close` | Explore the corresponding layer interactively |
| Performance | `etaf-performance-mode`, `etaf-performance-show`, `etaf-performance-copy-report`, `etaf-performance-export`, `etaf-performance-environment-data`, `etaf-performance-records`, `etaf-performance-summary`, `etaf-performance-operation-stage-summary`, `etaf-performance-with-operation`, `etaf-performance-register-stage` | Attribute generic operation latency across loaded packages and share reports |
| Performance | `etaf-performance-start`, `etaf-performance-stop`, `etaf-performance-mode`, `etaf-performance-show`, `etaf-performance-copy-report`, `etaf-performance-export`, `etaf-performance-environment-data`, `etaf-performance-records`, `etaf-performance-summary`, `etaf-performance-operation-stage-summary`, `etaf-performance-call-operation`, `etaf-performance-with-operation` | Attribute generic operation latency through public observers and share reports |
Most applications need only `etaf-view`, `etaf-mount`, `etaf-define-component`, `etaf-ref`, and event callbacks at first. The remaining APIs are additive capabilities, not prerequisites for understanding the core grammar.
## 15. Common mistakes
- Put every property before the first child.
- Use `:face 'bold`, not `:face :bold`; a face is an Elisp symbol value, not a property keyword.
- Use `:font-weight 'bold`, not `:font-weight :bold`; the weight is an Elisp symbol value, not a property keyword.
- Do not quote a structural View form.
- Use `expr :value` for `if`, `when`, `let`, `mapcar`, or a View returned by ordinary Elisp.
- Use `(expr FORM)` for `if`, `when`, `let`, `mapcar`, or a typed View returned by ordinary Elisp.
- Use `(slot)` or `(slot FALLBACK...)` for the default outlet; use `:name 'header` for named slot content.
- Keep writes out of rendering; use an event, Action, watch callback, or Effect.
- Use `etaf-ui` Components for product controls; core Hosts are the structural foundation.
- Stop a Data Controller and unmount a Runtime when their owner is no longer needed.
For retained updates, keep the application pair declarative: `.etaf` contains
the static shell and the same-basename `.el` companion owns state, Components,
and actions. Reactive writes are batched into one generation publication;
failed publication is retryable, and a non-converging effect is reported rather
than allowed to keep the UI busy.
Ordinary applications define and mount Components from lexical-binding `.el`
files. The optional Playground uses inert `.etaf` structure plus an explicitly
registered `.el` companion; core does not discover or execute that pair.
Reactive writes within a batch publish one generation. Failed publication is
retryable, and a non-converging effect is reported instead of keeping the UI busy.

View File

@ -7,6 +7,8 @@ ETAF 使用一套很小的词汇构建文本应用:`View`、`Component`、prop
ETAF 依赖独立的 Ebox 包。开发时把核心检出目录放入 `load-path`,然后只加载 ETAF 的公共入口:
```elisp
(add-to-list 'load-path "/path/to/github/ecss")
(add-to-list 'load-path "/path/to/github/tp")
(add-to-list 'load-path "/path/to/github/ebox")
(add-to-list 'load-path "/path/to/github/etaf")
(require 'etaf)
@ -27,7 +29,7 @@ ETAF 依赖独立的 Ebox 包。开发时把核心检出目录放入 `load-path`
```elisp
(etaf-view
(column
(text :face 'bold "Hello")
(text :font-weight 'bold "Hello")
(text :color "#687386" "Welcome to ETAF")))
```
@ -38,7 +40,7 @@ ETAF 依赖独立的 Ebox 包。开发时把核心检出目录放入 `load-path`
"*etaf-hello*"
(etaf-view
(column
(text :face 'bold "Hello")
(text :font-weight 'bold "Hello")
(text "This is a text application."))))
```
@ -62,11 +64,38 @@ Headless host 或已经知道最终布局上下文的调用方,可以通过可
```elisp
(ebox-render
(etaf-render
(etaf-view (text :face 'bold "Pure View"))))
(etaf-view (text :font-weight 'bold "Pure View"))))
```
View 含有状态型 Component、响应式数据、事件或生命周期时使用 `etaf-mount`
需要显式请求处理待办更新时,调用 `(etaf-runtime-flush runtime)`
它现在返回 **Ebox 已提交 revision 整数**,不再返回旧版的 Ebox 节点。
Runtime 忙碌或仍处于批处理时,更新可能继续等待;返回值标识此刻读者可见的
发布版本。活动 Ebox/TP 事务内的调用会在请求更新之前报错,因为事务中的
revision 可能尚未提交。普通 flush 不导出整棵树,也不强制重建 Root。
需要当前树及其配套 source facts 时,显式获取快照:
```elisp
(let* ((runtime (etaf-runtime-for-buffer "*etaf-hello*"))
(snapshot (etaf-runtime-snapshot runtime)))
(list (plist-get snapshot :revision)
(plist-get snapshot :mount-id)
(ebox-render (plist-get snapshot :input))))
```
快照包含 `:input`canonical Ebox input、`:revision` 和 `:mount-id`
(本次挂载的身份)。导出成本为 O(N),会分离节点的普通可变数据;它不处理
待办更新,不求值 Component不发布也不增加 revision。input 在后续提交或
卸载后仍可使用。callback 等不透明能力保持身份,查询不会冻结这些外部能力或
显示环境。对未挂载 Runtime 或在活动 Ebox/TP 事务内查询会报错。
已废弃的 `etaf-runtime-root-node` getter 通过上述 O(N) 查询保留读取兼容性,
返回当前唯一根节点Runtime 不再保存根节点镜像。请迁移到
`etaf-runtime-snapshot`,保留 canonical input 中与根节点配套的 source facts
不要再把旧 getter 当作低成本字段读取或写入目标。
当前 core 不直接加载 `.etaf`。`etaf-define-component` 是结构/样式/行为单元:用 View 定义结构,用 `:styles` 放静态 presentation`:setup` 管理 retained state、Action 和生命周期。未来 `.etaf` SFC 属于把结果编译成同一套 Component 契约的 compiler layer而不是第二个 Runtime 入口。
## 3. 属性与子节点
@ -78,9 +107,9 @@ View 含有状态型 Component、响应式数据、事件或生命周期时
(label "Theme"))
(etaf-view
(text
:face (if dark 'light 'dark)
:color "#F4F6FB"
(expr :value label))))
:color (if dark "#F4F6FB" "#1F2328")
:background-color "#20242B"
(expr label))))
```
子节点区是结构语法。`expr` 是执行普通 Elisp 的唯一明确桥接:
@ -88,14 +117,16 @@ View 含有状态型 Component、响应式数据、事件或生命周期时
```elisp
(etaf-view
(column
(expr :value (if loading "Loading..." "Ready"))
(expr (if loading "Loading..." "Ready"))
(expr
:value
(when open
(etaf-view (text :face 'italic "Details"))))))
(etaf-view (text :font-style 'italic "Details"))))))
```
`expr` 只接受 `:value`不能有子节点。返回值可以是字符串、View、序列或 `nil`。`if`、`when`、`cond`、`let`、`mapcar` 和 `cl-loop` 仍然是 value 中的普通 Elisp。
`expr` 只接受一个普通 Elisp form不能有结构子节点。在结构子节点位置返回值
可以是字符串、typed Host 或 Component View、这些值组成的 proper sequence 或 `nil`
`text` Host 内,表达式必须返回字符串。`if`、`when`、`cond`、`let`、`mapcar` 和
`cl-loop` 仍是普通 Elisp。
quote 只有普通 Elisp 的含义:
@ -103,7 +134,12 @@ quote 只有普通 Elisp 的含义:
- 字面量 symbol 和数据列表在 Elisp 需要时才 quote。
- Elisp 表达式需要构造 View 时,在其中使用 `(etaf-view ...)`
例如 `'bold` 是 face symbol`'(text "data")` 只是数据,不会渲染。动态 View 必须写成 `(etaf-view (text "data"))`
例如 `'bold``:font-weight` 的 symbol 值,而 `'(text "data")` 只是数据,不会渲染。动态 View 必须写成 `(etaf-view (text "data"))`
间距由布局 Host 决定:`row` 与 `column` 使用 `:item-gap`,例如
`(row :item-gap 1 ...)``flex` 与 `grid` 使用 `:gap`。切换 Host 时也要选择
对应的间距属性,两者不是可互换的 alias。例如将 `(row :gap 1 ...)` 改为
`(row :item-gap 1 ...)`
核心 `grid` Host 用于二维布局:
@ -113,16 +149,16 @@ quote 只有普通 Elisp 的含义:
(etaf-view
(grid
:width '(640)
:grid-template-columns '((200) 1fr)
:grid-template-columns '((200) (fr 1))
:grid-template-rows '(1 1)
:gap '(1 (12))
(text :face 'bold "Name")
(text :font-weight 'bold "Name")
(text "Value")
(text "Ada")
(text "Lovelace"))))
```
轨道模板支持 `auto`、`(fr FACTOR)`、`1fr` 等符号、`(minmax MIN MAX)` 和 `(repeat COUNT TRACK)`。`:grid-auto-columns` 与 `:grid-auto-rows` 负责隐式轨道尺寸;`:grid-auto-flow` 支持 `row``column`。子节点可以使用 `:grid-column`、`:grid-row`、`:grid-column-span` 和 `:grid-row-span`;测量、放置以及 item/content 对齐由 Ebox 完成。可选 native backend 不支持 Grid 时会回退到 Elisp Ebox renderer。
轨道模板支持 `auto`、`min-content`、`max-content`、`(fr FACTOR)`、`(minmax MIN MAX)` 和 `(repeat COUNT TRACK-LIST)`。`:grid-auto-columns` 与 `:grid-auto-rows` 负责隐式轨道尺寸;`:grid-auto-flow` 支持 `row``column`。子节点可以使用 `:grid-column`、`:grid-row`、`:grid-column-span` 和 `:grid-row-span`;测量、放置以及 item/content 对齐由 Ebox 完成。可选 native backend 不支持 Grid 时会回退到 Elisp Ebox renderer。
## 4. 定义 Component
@ -133,8 +169,8 @@ quote 只有普通 Elisp 的含义:
"Render a status label."
:view
(text
:face 'bold
(expr :value label)))
:font-weight 'bold
(expr label)))
(etaf-mount
"*etaf-status*"
@ -142,20 +178,21 @@ quote 只有普通 Elisp 的含义:
(status-label :label "Connected")))
```
Component 的规范名称可以带 `etaf-` 前缀
调用时使用传给 `etaf-define-component` 的准确名称
```elisp
(etaf-view (etaf-status-label :label "Connected"))
(etaf-view (status-label :label "Connected"))
```
在 View 位置ETAF 也会注册短 alias `status-label`。如果短名称会与 Elisp 冲突,注册表会使用以 `-view` 结尾的语义 alias。这个规则只作用于 View 名称;普通函数仍然保留前缀
注册表不会自动生成 alias。定义为 `etaf-status-label` 的组件必须使用这个准确名称;上面的 `status-label` 是本节自己显式定义的名称。加载 `etaf-ui` 后,官方目录使用 `etaf-button`、`etaf-checkbox` 等准确名称
定义宏只接受这些关键字:
| 关键字 | 作用 |
| --- | --- |
| `:view` | 无状态 Component 的 View 生产者,与 `:setup` 互斥 |
| `:setup` | 一次性初始化,返回零参数 render 函数 |
| `:view` | 声明式 View frontend`:render` 互斥 |
| `:render` | 普通 Elisp 返回一个 typed View通常使用 `etaf-view`;程序化构造也可使用 `etaf-node` |
| `:setup` | 可选的一次性初始化,返回由 `etaf-state` 读取的 opaque 状态 |
| `:styles` | 可选的静态作用域样式声明 |
没有单独的 children、slot、event、state 或 variant 声明块。业务 props 通过 `(&key ...)` 声明children 和 slot 是隐式内容。
@ -168,23 +205,35 @@ Component 自己拥有状态时使用 `:setup`
(etaf-define-component counter (&key title)
"Render a retained counter."
:setup
(let ((count (etaf-ref 0)))
(let ((count (etaf-ref 0))
(initial-title title))
(etaf-on-mounted
(lambda () (message "%s mounted" title)))
(lambda () (message "%s mounted" initial-title)))
(etaf-on-unmounted
(lambda () (message "%s unmounted" title)))
(lambda ()
(etaf-view
(column
(text :face 'bold (expr :value title))
(text (expr :value (format "Count: %d" (etaf-value count))))
(text
:role 'button
:on-press (lambda () (cl-incf (etaf-value count)))
"Increment"))))))
(lambda () (message "%s unmounted" initial-title)))
count)
:render
(let ((count (etaf-state))
(caption title))
(etaf-view
(column
(text :font-weight 'bold (expr caption))
(text (expr (format "Count: %d" (etaf-value count))))
(text :role 'button :tab-index 0
:on-press (lambda () (cl-incf (etaf-value count)))
"Increment")))))
```
Setup 对 retained instance 只执行一次,返回的 render 函数在更新时重复运行。`etaf-on-mounted`、`etaf-on-updated` 和 `etaf-on-unmounted` 注册该 Component 的生命周期 callback。Scope 释放时会自动停止响应式 effect 并运行 cleanup。
Setup 对 retained instance 只执行一次,返回一个 opaque 状态值。选定的 `:view`
`:render` frontend 在更新时运行,并通过 `etaf-state` 读取这个准确值。
`etaf-on-mounted`、`etaf-on-updated` 和 `etaf-on-unmounted` 注册该 Component 的生命周期
callback。Scope 释放时会自动停止响应式 effect 并运行 cleanup。
`:view``:render` 共用编译、slot 投影与 prop 校验。用普通 `let`/`let*`
为回调捕获 state 句柄或当前 prop 值;`etaf-state` 只在 render 时读取,不留到
事件触发时调用。把 `etaf-value` 保留在需要更新的属性或 `expr` 内;提取句柄
不需要提前读取它的值。含有持久闭包的组件代码放在启用 lexical-binding 的 `.el`
文件中。简单本地回调不需要定义 Action。
响应式 API 只有一套模型:
@ -219,8 +268,8 @@ Setup 对 retained instance 只执行一次,返回的 render 函数在更新
"Render a titled panel."
:view
(column
(text :face 'bold (expr :value title))
(slot (text :face 'shadow "No content"))))
(text :font-weight 'bold (expr title))
(slot (text :color "#687386" "No content"))))
(etaf-view
(panel
@ -236,8 +285,8 @@ Setup 对 retained instance 只执行一次,返回的 render 函数在更新
:view
(column
(slot :name 'header
(text :face 'bold (expr :value title)))
(slot (text :face 'shadow "No body"))))
(text :font-weight 'bold (expr title)))
(slot (text :color "#687386" "No body"))))
(etaf-view
(card
@ -248,6 +297,27 @@ Setup 对 retained instance 只执行一次,返回的 render 函数在更新
默认 slot 的两个用户简写是 `(slot)``(slot FALLBACK...)`。内部统一形式是 `(slot :name 'default FALLBACK...)`。调用处的普通子节点填充 `default`;命名内容写成 `(slot :name 'header CHILD...)`。显式空的 `(slot :name 'header)` 会抑制 fallback。字符串、数字、变量和运行时表达式都不是合法 slot name。
Slot 中作者写下的表达式在整个投影子树中保留作者的 props、state 和 Context。
其中创建的 Component 仍有自己的 props、state、styles 和 Scope其 Context 从
slot 作者环境继承。接收 slot 的 Component 不会把自己的 Context 注入调用者内容。
它自己定义的 fallback、普通子节点以及产生 View 的 callback 使用接收方环境。
Table/Grid 的 cell callback 同样使用消费它的 Table/Grid 所在位置的 Context。
在结构边界,`expr` 可以返回 typed View 或 typed View 的 proper sequence但它不暴露、
也不接受 ETAF 私有 struct。同一个 Component 可以组合 keyed `:for`、结构表达式和
命名 footer slot
```elisp
(etaf-define-component etaf-docs-collection-card (&key items footer-view)
"Render keyed rows, one dynamic typed View, and a footer slot."
:view
(column
(row :for (item items) :key (car item)
(text (expr (cdr item))))
(expr footer-view)
(slot :name 'footer (text "No footer"))))
```
## 7. 样式与 Theme
静态 Component 样式只有一种声明形式:
@ -259,8 +329,8 @@ Setup 对 retained instance 只执行一次,返回的 render 函数在更新
(styles
("&"
:padding (1 2)
:border ((1) solid "#687386"))
(".title" :face bold)
:border (1 solid "#687386"))
(".title" :font-weight bold)
(".danger" :color "#FF6B6B"))
:view
(column
@ -286,14 +356,22 @@ variant 需要明确覆盖,应使用显式 Host 属性或不同的属性键。
Theme 是 Context 的便捷形式,不是另一个 Runtime 对象:
<!-- etaf-example: theme -->
```elisp
(require 'etaf)
(etaf-define-component themed-shell ()
"Provide default text colors to a subtree."
"Provide semantic colors to its own View."
:setup
(progn
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
(lambda () (etaf-view (slot)))))
(etaf-theme-provide
'(:text-color "#F4F6FB" :surface-color "#202634"))
:view
(text :ref 'themed-content
:color (etaf-theme-token :text-color)
:background-color (etaf-theme-token :surface-color)
"Themed content"))
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
```
如果应用有亮/暗两套 palette应把语义 role 集中放在一份 palette plist 中,
@ -369,6 +447,35 @@ Behavior 用来打包可复用的非视觉属性和 cleanup
Installer 需要 Runtime 或 Host path 时,可以调用 `etaf-current-behavior-context`。Behavior 被替换时,旧 cleanup 会在新状态成为当前状态前运行。Behavior equality 对 function 和 reactive value 使用 `eq`;因此新建的 installer closure 会被视为有意替换,而不是错误复用。替换状态先以 mounted resource registry 的 staged resource 保存generation commit 后才成为 authority。
<a id="interaction-migration"></a>
根事件透传采用追加规则:内部业务 handler 最先运行first然后是由内到外
wrapper 附加的 callback最后是按声明顺序运行的 Behavior。每个声明位置执行
一次。Checkbox 的 `:on-change` 仍先收到下一个布尔值,附加的 `:on-press`
观察回调随后运行。callback 报错会 short-circuit 剩余回调UI 回滚不会撤销外部
业务写入。dispatch 只命中准确 Host不存在 capture 或 bubble。
wrapper 的 `:use` 列表顺序连接,重复 Behavior name 在任何 installer 运行前报错。
非事件 Behavior 默认值仍由 Host 优先、其余 first-wins`:disabled` 则取 OR。
每次更新都重新计算内外禁用输入:调用方可进一步禁用控件;解除外层禁用时,只有
内部也为 nil 才能启用。禁用 Host 的 `etaf-dispatch-event``etaf-focus` 会抛出
`etaf-event-error`。禁用时不安装输入 Behavior提交禁用时清理已安装资源重新启用
时再安装。
命中测试先选择最深的交互边界,再检查是否启用。点击禁用 cell 按钮不会激活父行,
即使按钮与行的 bounds 相同。普通非交互行文本仍可选择该行;显式聚焦行后也可触发
行动作。
迁移时注意:附加的根 `:on-*` 现在追加执行,不再覆盖原动作。需要不同业务动作时,
使用组件显式公开的业务 callback prop或定义具有该行为的组件。透传属性不能把
已有的 `:role``:aria-checked` 等归组件所有的 aria 状态改成冲突值,否则报
Component 输入错误;有意提供语义变体时应公开业务 prop。调用方仍可覆盖
`:aria-label``:aria-description` 的可访问性文字。
Action name 使用 application/feature-prefixed symbol重复 Action 注册默认报错。显式
reload 用 `etaf-action-redefine-run` 包住替换,它只改变未来按 name 的 dispatch不会
flush 已挂载 Runtime。
Focus 和 hit testing 是 Runtime 操作:
```elisp
@ -385,29 +492,37 @@ Focus 和 hit testing 是 Runtime 操作:
Context 适合跨多层共享依赖,不适合普通 label
<!-- etaf-example: context -->
```elisp
(etaf-define-component application-shell ()
"Provide a service to descendants."
:setup
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
(lambda () (etaf-view (slot)))))
(require 'etaf)
(etaf-define-component service-label ()
"Read the inherited service."
:setup (etaf-inject 'service nil t)
:view
(text (expr (format "Service: %s" (etaf-value (etaf-state))))))
(etaf-define-component application-shell ()
"Provide a service to its own child Component."
:setup
(let ((service (etaf-inject 'service nil t)))
(lambda ()
(etaf-view
(text (expr :value (format "Service: %s" (etaf-value service)))))))
(let ((service (etaf-ref "demo-service")))
(etaf-provide 'service service)
service)
:view (service-label))
(etaf-mount
"*etaf-context*"
(etaf-view (application-shell (service-label))))
(etaf-view (application-shell)))
```
Context key 是稳定的普通 symbol最近的祖先优先。`etaf-inject` 对可选依赖返回 default对必需但缺失的依赖触发 `etaf-context-error`。注入的 ref 或 computed 保留自身响应式 identity。
迁移:在根位置编写的 slot 内容保留根的空 Context其中的嵌套 Component 也
不会意外接收 slot 接收方的 provider 或 Theme。若消费者需要 provider 的
Context应像上例一样写在 provider 自己的 View 中;需要外部定制时,可接收
普通的 View-producing callback 并在该位置调用。内容需要保留作者 Context 时
使用 slot。
## 10. Data Controller 与 DataGrid
Data 已经是 ETAF core 能力。Data Source 实现一个小的 source 契约:
@ -465,8 +580,8 @@ Controller 通过 `etaf-data-items`、`etaf-data-status`、`etaf-data-error`、`
identity 进入或离开主 selection 时它才会变化,应用直接写
`etaf-data-selection` 时也一样。DataGrid 默认把这些 ref 与 keyed retained row
owner 配合使用,因此单选变化只会使旧行和新行失效,而不是整个可见页。
selection 由 Controller 外部拥有时,仍可使用自定义 `:row-selected-p`
`:selected-key` 契约
selection 由 Controller 外部拥有时,仍可使用自定义 `:row-selected-p`。稳定 identity
继续来自必选的 `:row-key`DataGrid 没有第二个 selection-key prop
`etaf-data-controller` 支持用于稳定选中行查找的 `:item-key`。在 Component
setup 中创建时,它的内部 effect Scope 会自动归当前 Component Scope 所有;如果
@ -553,16 +668,7 @@ Loader 错误会保存在 `etaf-resource-error`cleanup/type 错误保持可
nil))
```
唯一的低层出口是 `raw-ebox`
```elisp
(etaf-view
(raw-ebox
:key 'manual-node
:value (ebox-create :content "Backend node")))
```
只有普通 Host 和 Component lowering 无法表达真实 Ebox 需求时才使用它;返回的 Node 对 ETAF 语义保持 opaque。
公共 View 语法只接受 Host 和 Component不接受裸 Ebox Node。需要更低层端口的框架集成直接使用 Ebox typed TextNode 和 BoxNode constructor应用 View 始终走普通 Host/Component lowering 路径。
## 12. Playgrounds
@ -605,6 +711,8 @@ Loader 错误会保存在 `etaf-resource-error`cleanup/type 错误保持可
对任意应用负载启用通用记录器,然后打开普通的 `tabulated-list-mode` 面板:
```elisp
(require 'etaf-performance)
;; 在已挂载 ETAF Runtime 的 buffer 中:
(etaf-performance-mode 1)
(etaf-performance-show)
```
@ -612,27 +720,35 @@ Loader 错误会保存在 `etaf-resource-error`cleanup/type 错误保持可
正式复现前执行 `M-x etaf-performance-clear`。复现后在面板按 `c`,或者执行
`M-x etaf-performance-copy-report`可把环境、汇总、operation、GC 和阶段数据
完整复制到剪贴板;按 `w` 或执行 `M-x etaf-performance-export` 可导出 `.eld`
文件。报告和面板 header 还会显示电源来源、低功耗模式与系统负载。这两种报告
都可以直接发送给分析者。
文件。报告和面板 header 还会显示电源来源、低功耗模式、native JIT 状态与系统
负载。这两种报告都可以直接发送给分析者。
记录器会为公共交互、lifecycle、Data、Resource 和 viewport 边界创建有界的
operation 记录。已加载的 Ebox、TP 与 SQLite 可以贡献嵌套的粗粒度阶段,
但不需要反向依赖 ETAF。每个阶段同时报告 inclusive 与 exclusive 毫秒;
error 和 quit 会先被记录,再保持原条件继续抛出。
记录器只消费 Runtime 的公共 observer 报告,不安装 advice。Runtime 的 Event、
Action、mount、flush 和 unmount 会创建有界 operation 记录;同一 operation 内,
Ebox、TP、Data、Resource 与 SQLite 可以贡献按 sequence 排列的 flat provider
阶段。阶段可能重叠,因此不声称 exclusive/self 时间error 和 quit 会先被记录,
再保持原条件继续抛出。
`etaf-performance-summary` 只在请求时计算分组后的 p50/p95/max
`etaf-performance-operation-stage-summary` 会按 exclusive 时间排列某条记录
中的包级阶段。
`etaf-performance-operation-stage-summary` 会按 provider category 汇总某条记录
中的 flat 阶段。`etaf-performance-records` 返回 operation/stage 的防御性快照,
调用方修改返回值不会影响保留的历史。
该函数可选的数字 runtime ID 来自 observer 报告,可隔离 buffer 同名重建前后的
记录。summary/report 函数省略参数时读取全部历史,显式传入 `nil` 时保持空结果。
报告中的环境是导出时观测的状态不是每次历史操作的状态。Runtime 耗时截至
同步调用返回,不能证明输入到画面呈现的延迟;逐次前后台、目标与回调 wall/CPU/GC
检查使用[GUI action 测量入口](../scripts/README.md#measuring-an-existing-gui-action)。
使用 `etaf-performance-register-stage` 临时加入包级细节探针。没有经过内置
公共边界的应用操作可以使用 `etaf-performance-with-operation`。采集结束后
关闭 mode所有已安装 advice 都会被移除。
没有经过内置公共边界的应用操作可以使用
`etaf-performance-call-operation`/`etaf-performance-with-operation`;它们直接委托
同一个 Runtime operation 边界。采集结束后关闭 mode只解除当前 Runtime 的
observer不修改任何函数。
## 14. 公共 API 速查
| API 家族 | 主要入口 | 何时使用 |
| --- | --- | --- |
| View 与 Runtime | `etaf-view`、`etaf-render`、`etaf-mount`、`etaf-unmount`、`etaf-runtime-flush` | 构建、渲染、挂载或显式 flush 应用 |
| View 与 Runtime | `etaf-view`、`etaf-render`、`etaf-mount`、`etaf-unmount`、`etaf-runtime-flush`、`etaf-runtime-snapshot` | 构建、渲染、挂载、flush 或显式导出已提交应用 |
| Component | `etaf-define-component`、`etaf-current-prop`、`etaf-current-slots`、`etaf-component-set-styles`、`etaf-component-redefine-run` | 复用 View、保留局部状态、设置 authoring 样式或显式重载代码 |
| 响应式状态 | `etaf-ref`、`etaf-value`、`etaf-set-value`、`etaf-computed` | 保存或派生状态 |
| 响应式 effect | `etaf-watch`、`etaf-watch-effect`、`etaf-effect-scope`、`etaf-scope-run` | 观察状态或同步外部资源 |
@ -645,22 +761,22 @@ error 和 quit 会先被记录,再保持原条件继续抛出。
| Resource | `etaf-resource`、`etaf-resource-result`、`etaf-error-boundary-run` | 管理 loader 状态和 cleanup |
| 官方 UI | `require 'etaf-ui`、`etaf-button`、`etaf-checkbox`、`etaf-number-input`、`etaf-label`、`etaf-panel`、`etaf-data-grid` | 使用现成 Component |
| Playground | `etaf-playground-open`、`etaf-playground-open-ui`、`etaf-playground-close`、`ebox-playground-open`、`ebox-playground-close` | 探索对应层 |
| 性能分析 | `etaf-performance-mode`、`etaf-performance-show`、`etaf-performance-copy-report`、`etaf-performance-export`、`etaf-performance-environment-data`、`etaf-performance-records`、`etaf-performance-summary`、`etaf-performance-operation-stage-summary`、`etaf-performance-with-operation`、`etaf-performance-register-stage` | 跨已加载包定位通用 operation 的耗时并分享报告 |
| 性能分析 | `etaf-performance-start`、`etaf-performance-stop`、`etaf-performance-mode`、`etaf-performance-show`、`etaf-performance-copy-report`、`etaf-performance-export`、`etaf-performance-environment-data`、`etaf-performance-records`、`etaf-performance-summary`、`etaf-performance-operation-stage-summary`、`etaf-performance-call-operation`、`etaf-performance-with-operation` | 通过公共 observer 定位通用 operation 的耗时并分享报告 |
大多数应用一开始只需要 `etaf-view`、`etaf-mount`、`etaf-define-component`、`etaf-ref` 和事件 callback。其余 API 都是可选能力,不是理解核心语法的前置条件。
## 15. 常见错误
- 所有属性必须放在第一个子节点之前。
- 使用 `:face 'bold`,不要使用 `:face :bold`face 是 Elisp symbol 值,不是属性 keyword。
- 使用 `:font-weight 'bold`,不要使用 `:font-weight :bold`weight 是 Elisp symbol 值,不是属性 keyword。
- 结构性 View form 不要 quote。
- `if`、`when`、`let`、`mapcar` 或 Elisp 返回 View 时,使用 `expr :value`。
- `if`、`when`、`let`、`mapcar` 或 Elisp 返回 typed View 时,使用 `(expr FORM)`。
- 默认 outlet 使用 `(slot)``(slot FALLBACK...)`;命名内容使用 `:name 'header`
- 不要在 render 中写状态使用事件、Action、watch callback 或 Effect。
- 产品级控件使用 `etaf-ui` Componentcore Host 只是结构基础。
- owner 不再需要时,停止 Data Controller 并卸载 Runtime。
对于保留式更新,建议保持 pair 结构:`.etaf` 只放静态 shell同名 `.el` companion
负责 state、Component 和 action。响应式写入会合并为一次 generation publication
布失败可以在同一旧状态上重试non-converging effect 会报告错误,不会让界面
持续占用事件循环。
普通应用在启用 lexical-binding 的 `.el` 文件中定义并挂载 Component。可选的
Playground 使用 inert `.etaf` 结构与显式注册的 `.el` companioncore 不会自动
现或执行这组文件。同一 batch 内的响应式写入合并为一次 generation publication
发布失败可以重试non-converging effect 会报告错误,不会持续占用事件循环。

View File

@ -11,9 +11,16 @@
;;; Code:
(require 'cl-lib)
(require 'etaf-scheduler)
(require 'etaf-reactive)
(require 'etaf-runtime)
(defvar etaf--current-runtime)
(defvar etaf--observer-context)
(declare-function etaf-runtime-observer "etaf-runtime" (runtime))
(declare-function etaf-runtime-call-operation
"etaf-runtime" (runtime kind label function))
(define-error 'etaf-action-error "Invalid ETAF Action")
@ -26,11 +33,23 @@
(defvar etaf--action-registry (make-hash-table :test #'eq)
"Action name -> `etaf-action-spec' table.")
(defvar etaf--allow-action-redefinition nil
"Non-nil only inside `etaf-action-redefine-run'.")
(defun etaf--action-assert-definition-available (name)
"Signal when Action NAME cannot be defined in the current boundary."
(when (and (gethash name etaf--action-registry)
(not etaf--allow-action-redefinition))
(signal 'etaf-action-error
(list (format "Duplicate ETAF Action: %S" name)))))
(defun etaf-action-register (name function)
"Register FUNCTION as named Action NAME and return NAME."
(etaf--assert-not-rendering 'register-action)
(unless (and (symbolp name) (not (keywordp name)) (functionp function))
(signal 'etaf-action-error
(list (format "Invalid Action registration: %S" name))))
(etaf--action-assert-definition-available name)
(puthash name (etaf--action-spec-create :name name :function function)
etaf--action-registry)
name)
@ -46,18 +65,32 @@ through `etaf-dispatch'."
(let ((docstring (when (stringp (car body)) (pop body)))
(function-symbol (intern (format "%s--etaf-action" name))))
`(progn
(etaf--action-assert-definition-available ',name)
(defun ,function-symbol ,arguments
,(or docstring (format "Run ETAF Action `%s'." name))
,@body)
(etaf-action-register ',name #',function-symbol)
',name)))
;;;###autoload
(defun etaf-action-redefine-run (function)
"Run FUNCTION while allowing intentional Action redefinition.
Normal duplicate registrations remain errors. This dynamic authoring
boundary replaces only the process-global name binding used by future
`etaf-dispatch' calls; it does not flush or rerender mounted Runtimes."
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(let ((etaf--allow-action-redefinition t))
(funcall function)))
;;;###autoload
(defun etaf-dispatch (action &rest arguments)
"Dispatch named ACTION through the active Runtime with ARGUMENTS.
An explicit Runtime may be supplied as the first argument: `(etaf-dispatch
RUNTIME ACTION ...)'. Action functions receive Runtime first."
(etaf--assert-not-rendering 'dispatch-action)
(let* ((explicit-runtime (etaf-runtime-p action))
(runtime (if explicit-runtime
action
@ -77,12 +110,25 @@ RUNTIME ACTION ...)'. Action functions receive Runtime first."
(unless spec
(signal 'etaf-action-error
(list (format "Unknown ETAF Action: %S" action))))
(let ((etaf--current-runtime runtime))
(apply (etaf-action-spec-function spec) runtime arguments))))
(let ((run
(lambda ()
(etaf-scheduler-call-with-context
(etaf-runtime-scheduler-context runtime)
(lambda ()
(etaf-reactive-call-with-batch
(lambda ()
(let ((etaf--current-runtime runtime))
(apply (etaf-action-spec-function spec)
runtime arguments)))))))))
(if (or etaf--observer-context (etaf-runtime-observer runtime))
(etaf-runtime-call-operation
runtime 'action (format "%S" action) run)
(funcall run)))))
;;;###autoload
(defun etaf-action-undefine (name)
"Remove named Action NAME and return NAME."
(etaf--assert-not-rendering 'undefine-action)
(remhash name etaf--action-registry)
name)

View File

@ -15,12 +15,12 @@
(require 'cl-lib)
(require 'etaf-view)
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/1")
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/2")
(defvar etaf-compiler--static-cache (make-hash-table :test #'equal))
(defvar etaf-compiler--site-token-cache (make-hash-table :test #'equal))
(defvar etaf-compiler--registry-epoch 0)
(defvar etaf-compiler--instantiate-count 0)
(defvar etaf-compiler--fallback-count 0)
(defvar etaf-compiler--last-blueprint nil)
(defun etaf-compiler-note-registry-change ()
@ -31,13 +31,27 @@
(defun etaf-compiler-clear-cache ()
"Clear all process-local compiled View materializations."
(interactive)
(clrhash etaf-compiler--static-cache))
(clrhash etaf-compiler--static-cache)
(clrhash etaf-compiler--site-token-cache))
(defun etaf-compiler--site-token (blueprint block)
"Return the stable opaque token for compiled BLOCK in BLUEPRINT."
(let* ((key (list (plist-get blueprint :id)
(plist-get block :path)))
(missing (make-symbol "etaf-compiled-site-token-missing"))
(token (gethash key etaf-compiler--site-token-cache missing)))
(if (not (eq token missing))
token
(setq token (list 'etaf-compiled-site
(plist-get blueprint :id)
(plist-get block :path)))
(puthash key token etaf-compiler--site-token-cache)
token)))
(defun etaf-compiler-statistics ()
"Return a read-only snapshot of compiler runtime statistics."
(list :abi etaf-compiler-blueprint-abi
:instantiations etaf-compiler--instantiate-count
:fallbacks etaf-compiler--fallback-count
:static-cache-entries (hash-table-count etaf-compiler--static-cache)
:last-blueprint
(and etaf-compiler--last-blueprint
@ -68,29 +82,95 @@
(cons (list :kind 'hole :index index)
(append programs (list `(lambda () ,form)))))))
(defun etaf-compiler--compile-block (form path programs)
"Compile View FORM at PATH, returning `(BLOCK PROGRAMS)' or nil."
(defun etaf-compiler--form-directives (form)
"Return validated compiler directives from raw View FORM, or nil."
(when (and (consp form) (symbolp (car form))
(not (memq (car form) '(expr slot))))
(let ((props
(car (etaf--parse-attributes-and-children (cdr form)))))
(etaf--validate-directive-set
(etaf--view-directive-properties props)))))
(defun etaf-compiler--compile-program-block (kind code path programs)
"Compile structural KIND from executable CODE at PATH using PROGRAMS."
(let ((index (length programs)))
(list (list :kind kind :path path :hole index :static-p nil)
(append programs (list `(lambda () ,code))))))
(defun etaf-compiler--compile-children
(children path programs slot-mode)
"Compile sibling CHILDREN below PATH, extending PROGRAMS.
SLOT-MODE selects ordinary projection or slot compilation."
(let ((child-index 0)
blocks)
(while children
(let* ((form (car children))
(directives (etaf-compiler--form-directives form))
compiled
consumed)
(cond
((and directives (plist-member directives :if))
(pcase-let ((`(,code . ,remaining)
(etaf--compile-branch-children
form (cdr children) slot-mode)))
(setq compiled
(etaf-compiler--compile-program-block
'branch code (append path (list child-index)) programs)
consumed (- (length children) (length remaining))
children remaining)))
((and directives (plist-member directives :for))
(setq compiled
(etaf-compiler--compile-program-block
'keyed-list
(etaf--compile-for-child form slot-mode)
(append path (list child-index)) programs)
consumed 1
children (cdr children)))
((and directives
(or (plist-member directives :else-if)
(plist-member directives :else)))
(etaf--syntax-error "Orphan branch arm: %S" form))
(t
(setq compiled
(etaf-compiler--compile-block
form (append path (list child-index)) programs slot-mode)
consumed 1
children (cdr children))))
(setq programs (cadr compiled)
blocks (append blocks (list (car compiled))))
(cl-incf child-index consumed)))
(list blocks programs)))
(defun etaf-compiler--compile-block (form path programs slot-mode)
"Compile View FORM at PATH using PROGRAMS and SLOT-MODE.
Return `(BLOCK PROGRAMS)' or nil."
(cond
((or (null form) (stringp form))
(list (list :kind 'literal :value form :path path :static-p t) programs))
((not (and (consp form) (symbolp (car form)))) nil)
((not (and (consp form) (symbolp (car form))))
(etaf--syntax-error "View form must start with a tag symbol: %S" form))
((eq (car form) 'expr)
(let ((index (length programs)))
(list (list :kind 'expr :path path :hole index :static-p nil)
(append programs
(list `(lambda () ,(etaf--parse-expr-form (cdr form))))))))
((memq (car form) '(slot raw-ebox)) nil)
((etaf--ordinary-expression-head-p (car form)) nil)
((eq (car form) 'slot)
(etaf-compiler--compile-program-block
'slot (etaf--compile-slot-form (cdr form) slot-mode) path programs))
((and (null (gethash (car form) etaf--view-registry))
(etaf--ordinary-expression-head-p (car form)))
(etaf--syntax-error
"Elisp expression %S must be inside (expr FORM)" (car form)))
(t
(let* ((parts (etaf--parse-attributes-and-children (cdr form)))
(props (car parts))
(children (cdr parts))
(host-view-p
(eq (gethash (car form) etaf--view-registry) etaf--host-marker))
(child-slot-mode (if host-view-p slot-mode :input))
(compiled-props nil)
(compiled-children nil)
(all-static t)
(tail props)
(child-index 0)
result)
(tail props))
(while tail
(let* ((key (pop tail))
(value (pop tail))
@ -101,22 +181,15 @@
(setq all-static nil))
(setq compiled-props
(append compiled-props (list key descriptor)))))
(while (and children (not (eq result 'unsupported)))
(let ((compiled
(etaf-compiler--compile-block
(pop children) (append path (list child-index)) programs)))
(if (not compiled)
(setq result 'unsupported)
(let ((block (car compiled)))
(setq programs (cadr compiled)
compiled-children (append compiled-children (list block)))
(unless (plist-get block :static-p) (setq all-static nil)))))
(cl-incf child-index))
(unless (eq result 'unsupported)
(pcase-let* ((`(,compiled-children ,next-programs)
(etaf-compiler--compile-children
children path programs child-slot-mode)))
(dolist (block compiled-children)
(unless (plist-get block :static-p) (setq all-static nil)))
(list (list :kind 'node :name (car form) :path path
:props compiled-props :children compiled-children
:static-p all-static)
programs))))))
next-programs))))))
(defun etaf-compiler--block-counts (block)
"Return `(STATIC . DYNAMIC)' node counts below BLOCK."
@ -131,15 +204,16 @@
(cl-incf dynamic child-dynamic)))
(cons static dynamic))))
(defun etaf-compiler--beneficial-blueprint-p (blueprint)
"Return non-nil when BLUEPRINT can reuse at least one static node."
(> (or (plist-get blueprint :static-nodes) 0) 0))
(defun etaf-compiler--compile (form)
"Compile FORM into `(BLUEPRINT PROGRAM-CODE...)', or return nil."
(when-let* ((compiled (etaf-compiler--compile-block form '(0) nil)))
(let* ((root (car compiled))
(programs (cadr compiled))
(defun etaf-compiler--compile (form &optional slot-mode)
"Compile FORM under optional SLOT-MODE into a View blueprint.
Return `(BLUEPRINT PROGRAM-CODE...)', or nil."
(pcase-let* ((`(,roots ,programs)
(etaf-compiler--compile-children
(list form) nil nil (or slot-mode :projection)))
(root (car roots)))
(unless (and root (null (cdr roots)))
(etaf--syntax-error "A View blueprint requires exactly one root"))
(let* ((programs programs)
(id (secure-hash 'sha256 (prin1-to-string form)))
(counts (etaf-compiler--block-counts root)))
(cons (list :kind 'etaf/view-blueprint
@ -150,6 +224,100 @@
:hole-count (length programs))
programs))))
(defun etaf-compiler--closed-plist-p (value allowed)
"Return non-nil when VALUE is a duplicate-free plist using ALLOWED keys."
(and (proper-list-p value)
(zerop (% (length value) 2))
(let ((tail value)
seen
valid)
(setq valid t)
(while (and valid tail)
(let ((key (pop tail)))
(pop tail)
(if (or (not (memq key allowed)) (memq key seen))
(setq valid nil)
(push key seen))))
valid)))
(defun etaf-compiler--valid-property-descriptor-p (descriptor hole-count)
"Return non-nil for one bounded property DESCRIPTOR using HOLE-COUNT."
(and (proper-list-p descriptor)
(pcase (plist-get descriptor :kind)
('static
(and (etaf-compiler--closed-plist-p descriptor '(:kind :value))
(plist-member descriptor :value)))
('hole
(and (etaf-compiler--closed-plist-p descriptor '(:kind :index))
(natnump (plist-get descriptor :index))
(< (plist-get descriptor :index) hole-count)))
(_ nil))))
(defun etaf-compiler--valid-property-block-p (props hole-count)
"Return non-nil for a canonical property block PROPS using HOLE-COUNT."
(and (proper-list-p props)
(zerop (% (length props) 2))
(let ((tail props)
seen
valid)
(setq valid t)
(while (and valid tail)
(let ((key (pop tail))
(descriptor (pop tail)))
(if (or (not (keywordp key))
(memq key seen)
(not (etaf-compiler--valid-property-descriptor-p
descriptor hole-count)))
(setq valid nil)
(push key seen))))
valid)))
(defun etaf-compiler--valid-block-p (block hole-count)
"Return non-nil when BLOCK is valid for current View IR HOLE-COUNT."
(and (proper-list-p block)
(proper-list-p (plist-get block :path))
(booleanp (plist-get block :static-p))
(pcase (plist-get block :kind)
('literal
(and (etaf-compiler--closed-plist-p
block '(:kind :value :path :static-p))
(plist-member block :value)
(or (null (plist-get block :value))
(stringp (plist-get block :value)))
(plist-get block :static-p)))
((or 'expr 'branch 'keyed-list 'slot)
(and (etaf-compiler--closed-plist-p
block '(:kind :path :hole :static-p))
(natnump (plist-get block :hole))
(< (plist-get block :hole) hole-count)
(not (plist-get block :static-p))))
('node
(and (etaf-compiler--closed-plist-p
block '(:kind :name :path :props :children :static-p))
(symbolp (plist-get block :name))
(etaf-compiler--valid-property-block-p
(plist-get block :props) hole-count)
(proper-list-p (plist-get block :children))
(cl-every (lambda (child)
(etaf-compiler--valid-block-p child hole-count))
(plist-get block :children))))
(_ nil))))
(defun etaf-compiler--valid-blueprint-p (blueprint program-count)
"Return non-nil when BLUEPRINT is closed and matches PROGRAM-COUNT."
(and (etaf-compiler--closed-plist-p
blueprint
'(:kind :abi :id :root :static-nodes :dynamic-nodes :hole-count))
(eq (plist-get blueprint :kind) 'etaf/view-blueprint)
(equal (plist-get blueprint :abi) etaf-compiler-blueprint-abi)
(stringp (plist-get blueprint :id))
(natnump (plist-get blueprint :static-nodes))
(natnump (plist-get blueprint :dynamic-nodes))
(natnump (plist-get blueprint :hole-count))
(= program-count (plist-get blueprint :hole-count))
(etaf-compiler--valid-block-p
(plist-get blueprint :root) program-count)))
(defun etaf-compiler--materialize (blueprint block programs)
"Materialize BLOCK from BLUEPRINT using PROGRAMS."
(let* ((static-p (plist-get block :static-p))
@ -164,13 +332,36 @@
cached
(let ((value
(pcase (plist-get block :kind)
('literal (plist-get block :value))
;; The compiler's literal block is also used for a root string.
;; Keep the same canonicalization as the non-compiled View path:
;; a bare string is a Text View, while nil remains an empty
;; structural value.
('literal
(let ((literal (plist-get block :value)))
(if (and (stringp literal)
(= (length (plist-get block :path)) 1))
(etaf--text-view-from-string literal)
literal)))
('expr
(etaf--expr-create
:token (list 'etaf-compiled-site
(plist-get blueprint :id)
(plist-get block :path))
:token (etaf-compiler--site-token blueprint block)
:thunk (aref programs (plist-get block :hole))))
((or 'branch 'keyed-list)
(let ((program
(funcall (aref programs (plist-get block :hole)))))
(unless (and (etaf--expr-p program)
(eq (etaf--expr-kind program)
(plist-get block :kind)))
(error "Invalid ETAF structural program for %S"
(plist-get block :kind)))
program))
('slot
(let ((slot
(funcall (aref programs (plist-get block :hole)))))
(unless (or (etaf--slot-projection-p slot)
(etaf--slot-input-p slot))
(error "Invalid ETAF slot program"))
slot))
('node
(let ((props nil))
(cl-loop for (key descriptor) on (plist-get block :props)
@ -205,12 +396,9 @@
;;;###autoload
(defun etaf-compiler-instantiate (blueprint programs)
"Instantiate automatically lowered View BLUEPRINT with dynamic PROGRAMS."
(unless (and (eq (plist-get blueprint :kind) 'etaf/view-blueprint)
(equal (plist-get blueprint :abi)
etaf-compiler-blueprint-abi)
(stringp (plist-get blueprint :id))
(vectorp programs)
(= (length programs) (plist-get blueprint :hole-count)))
(unless (and (vectorp programs)
(etaf-compiler--valid-blueprint-p
blueprint (length programs)))
(error "Invalid or incompatible ETAF View blueprint"))
(cl-incf etaf-compiler--instantiate-count)
(setq etaf-compiler--last-blueprint blueprint)
@ -219,14 +407,12 @@
(defun etaf-compiler-expand-view (form &optional slot-mode)
"Return compiler expansion for View FORM.
SLOT-MODE is forwarded to the legacy compiler."
(let* ((compiled (etaf-compiler--compile form))
(blueprint (car compiled))
(legacy (etaf--compile-view-form form (or slot-mode :projection))))
(if (and compiled (etaf-compiler--beneficial-blueprint-p blueprint))
`(etaf-compiler-instantiate
',blueprint (vector ,@(cdr compiled)))
`(progn (cl-incf etaf-compiler--fallback-count) ,legacy))))
SLOT-MODE distinguishes Component projections from call-site slot inputs."
(let* ((compiled (etaf-compiler--compile
form (or slot-mode :projection)))
(blueprint (car compiled)))
`(etaf-compiler-instantiate
',blueprint (vector ,@(cdr compiled)))))
(provide 'etaf-compiler)
;;; etaf-compiler.el ends here

View File

@ -4,15 +4,16 @@
;;; Commentary:
;; Components have one public definition boundary. A stateless Component
;; declares `:view'; a stateful Component declares `:setup' which runs once
;; per retained instance and returns a render function. Both forms produce
;; the same normalized View tree and share props, slots, styles, and Context.
;; Components have one public definition boundary with two authoring
;; frontends: compiled `:view' DSL and ordinary Elisp `:render'. Optional
;; `:setup' runs once and returns opaque state read through `etaf-state'.
;;; Code:
(require 'cl-lib)
(require 'macroexp)
(require 'etaf-view)
(require 'etaf-compiler)
(define-error 'etaf-component-definition-error
"Invalid ETAF Component definition"
@ -25,6 +26,22 @@
(defvar etaf--raw-slot-read-p nil
"Set while a Component render uses public raw slot accessors.")
(defvar etaf--component-phase nil
"Dynamic Component phase, either `setup', `render', or nil.")
(defvar etaf--current-component-state nil
"Opaque setup result supplied by the current Runtime Component context.")
(defvar etaf--current-component-setup-defined-p nil
"Whether the current Component definition declares setup.")
(defvar etaf--current-component-setup-complete-p nil
"Whether the current Component instance completed setup.")
(defconst etaf--component-reserved-props
'(key if else-if else for)
"Framework names forbidden in Component business prop declarations.")
(defun etaf--component-definition-error (format-string &rest arguments)
"Signal a Component definition error from FORMAT-STRING and ARGUMENTS."
(signal 'etaf-component-definition-error
@ -51,6 +68,9 @@
(when (memq entry prop-names)
(etaf--component-definition-error
"Duplicate Component prop: %S" entry))
(when (memq entry etaf--component-reserved-props)
(etaf--component-definition-error
"Component prop %S is reserved by the View grammar" entry))
(push entry prop-names))
(nreverse prop-names)))
@ -68,6 +88,23 @@ The function is also useful to code that deliberately avoids that shorthand."
(plist-get etaf--current-component-props
(etaf--component-prop-key name)))
;;;###autoload
(defun etaf-state ()
"Return the current Component instance's exact setup result.
The accessor is valid only while rendering a Component that declares setup.
A defined setup may return nil; setup presence is tracked independently."
(unless (and (eq etaf--component-phase 'render)
etaf--current-component-instance)
(etaf--component-definition-error
"ETAF state is available only during Component view/render"))
(unless etaf--current-component-setup-defined-p
(etaf--component-definition-error
"Current Component does not declare :setup"))
(unless etaf--current-component-setup-complete-p
(etaf--component-definition-error
"Current Component setup has not completed"))
etaf--current-component-state)
;;;###autoload
(defun etaf-component-set-styles (name styles)
"Replace the static style form for Component NAME with STYLES.
@ -110,6 +147,9 @@ does not depend on ETAF's private registry flag."
(defun etaf-current-slots ()
"Return the current Component's normalized slot alist."
(unless (eq etaf--component-phase 'render)
(etaf--component-definition-error
"Slots are available only during Component view/render"))
(setq etaf--raw-slot-read-p t)
(mapcar (lambda (entry)
(cons (car entry)
@ -120,6 +160,9 @@ does not depend on ETAF's private registry flag."
(defun etaf-current-slot (name &optional fallback)
"Return the child list for slot NAME, or FALLBACK when it is absent."
(unless (eq etaf--component-phase 'render)
(etaf--component-definition-error
"Slots are available only during Component view/render"))
(setq etaf--raw-slot-read-p t)
(let ((entry (assq name etaf--current-component-slots)))
(if entry
@ -158,34 +201,51 @@ does not depend on ETAF's private registry flag."
name key)))))))
form)
(defun etaf--component-form-contains-head-p (form heads)
"Return non-nil when executable FORM contains a call headed by HEADS."
(cond
((atom form) nil)
((memq (car form) '(quote function)) nil)
((memq (car form) heads) t)
(t (cl-some (lambda (part)
(etaf--component-form-contains-head-p part heads))
form))))
;;;###autoload
(defmacro etaf-define-component (name arguments &rest clauses)
"Define Component NAME from prop ARGUMENTS and CLAUSES.
The definition boundary is intentionally small:
Choose exactly one authoring frontend:
(etaf-define-component NAME (&key PROPS)
[:setup SETUP]
:view VIEW
:styles (styles (SELECTOR ATTR ...)))
or:
(etaf-define-component NAME (&key PROPS)
:setup SETUP
[:setup SETUP]
:render ORDINARY-ELISP
:styles (styles (SELECTOR ATTR ...)))
`:view' is rendered for every update. `:setup' runs once per retained
Component instance and must return a zero-argument render function. View
forms do not use quote; ordinary Elisp belongs in `expr :value'."
`:setup' runs once per retained identity and returns opaque state. `:view'
is unquoted DSL; `:render' is ordinary Elisp returning the same typed View,
usually through `etaf-view'. `etaf-node' also constructs Views
programmatically. Both frontends use the same prop and slot rules. Bind state
handles and prop snapshots to lexical locals for later event callbacks; keep
reactive value reads inside the View properties or expressions they update."
(declare (indent 2) (debug defun))
(unless (symbolp name)
(etaf--component-definition-error
"Component name must be a symbol: %S" name))
(let ((docstring (when (stringp (car clauses)) (pop clauses)))
view-form
render-form
setup-form
styles-form
saw-view
saw-render
saw-setup
saw-styles)
(while clauses
@ -202,6 +262,11 @@ forms do not use quote; ordinary Elisp belongs in `expr :value'."
(etaf--component-definition-error
"Component %S has duplicate :view" name))
(setq view-form (pop clauses) saw-view t))
(:render
(when saw-render
(etaf--component-definition-error
"Component %S has duplicate :render" name))
(setq render-form (pop clauses) saw-render t))
(:setup
(when saw-setup
(etaf--component-definition-error
@ -215,31 +280,49 @@ forms do not use quote; ordinary Elisp belongs in `expr :value'."
(_
(etaf--component-definition-error
"Unknown Component definition keyword %S" keyword)))))
(when (and saw-view saw-setup)
(when (and saw-view saw-render)
(etaf--component-definition-error
"Component %S must choose :view or :setup, not both" name))
(unless (or saw-view saw-setup)
"Component %S must choose :view or :render, not both" name))
(unless (or saw-view saw-render)
(etaf--component-definition-error
"Component %S requires exactly one of :view or :setup" name))
"Component %S requires exactly one of :view or :render" name))
(when (and saw-setup
(etaf--component-form-contains-head-p
setup-form '(etaf-view etaf-node)))
(etaf--component-definition-error
"Component %S :setup cannot construct View structure" name))
(when (and saw-setup
(consp setup-form)
(memq (car setup-form) '(lambda function)))
(etaf--component-definition-error
"Component %S :setup cannot return a render function" name))
(let* ((props (etaf--parse-component-props arguments))
(styles-form (etaf--validate-styles-form styles-form name))
(definition-symbol
(intern (format "%s--etaf-component-definition" name)))
(render-lambda
(when saw-view
`(lambda (etaf--component-props etaf--component-slots)
(let ((etaf--current-component-props etaf--component-props)
(etaf--current-component-slots etaf--component-slots)
(etaf--current-component-instance
etaf--current-component-instance))
(cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props)
,(etaf--compile-view-form view-form :projection))))))
`(lambda (etaf--component-props etaf--component-slots)
(let ((etaf--current-component-props etaf--component-props)
(etaf--current-component-slots etaf--component-slots)
(etaf--component-phase 'render))
,(let ((etaf--compiling-component-props props))
;; Expand every embedded View inside its Component prop
;; grammar, including Views produced by lexical macros.
;; Include the prop bindings so they shadow outer symbol
;; macros while ordinary let/lambda shadowing is preserved.
(macroexpand-all
`(cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props)
,(if saw-view
(etaf-compiler-expand-view view-form :projection)
render-form))
macroexpand-all-environment)))))
(setup-lambda
(when saw-setup
`(lambda (etaf--component-props etaf--component-slots)
`(lambda (etaf--component-props _etaf--component-slots)
(let ((etaf--current-component-props etaf--component-props)
(etaf--current-component-slots etaf--component-slots))
(etaf--current-component-slots nil)
(etaf--component-phase 'setup))
(cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props)
,setup-form))))))

View File

@ -73,6 +73,7 @@ unchanged.")
;;;###autoload
(defun etaf-provide (key value)
"Provide VALUE under stable Context KEY to the current subtree."
(etaf--assert-not-rendering 'provide-context)
(unless (etaf-context-p etaf--current-context)
(error "ETAF provide requires Component setup or render context"))
(puthash (etaf--context-key key) value
@ -177,7 +178,8 @@ also accepted and remains tracked by the current render effect."
validated))))
(defun etaf--theme-source (&optional default)
"Return the inherited Theme source without reading its reactive value."
"Return the inherited Theme source, using DEFAULT when none is provided.
This does not read the source's reactive value."
(etaf-inject 'theme default))
(defun etaf--theme-source-value (source &optional default tracked-p)

File diff suppressed because it is too large Load Diff

View File

@ -12,9 +12,12 @@
(require 'cl-lib)
(require 'ebox)
(require 'etaf-scheduler)
(require 'etaf-reactive)
(require 'etaf-runtime)
(defvar etaf--current-runtime)
(defvar etaf--observer-context)
(declare-function etaf-runtime-require-mounted "etaf-runtime" (&optional runtime))
(declare-function etaf-runtime-p "etaf-runtime" (value))
@ -24,10 +27,14 @@
(declare-function etaf-runtime-handler-entries "etaf-runtime" (runtime))
(declare-function etaf-runtime-host-props-for "etaf-runtime" (runtime host-ref))
(declare-function etaf-runtime-host-props-entries "etaf-runtime" (runtime))
(declare-function etaf-runtime-host-ancestries "etaf-runtime" (runtime host-refs))
(declare-function etaf-runtime-focus-ref "etaf-runtime" (runtime))
(declare-function etaf-runtime-set-focus-ref "etaf-runtime" (runtime host-ref))
(declare-function etaf-runtime-event-begin "etaf-runtime" (runtime))
(declare-function etaf-runtime-event-end "etaf-runtime" (runtime))
(declare-function etaf-runtime-observer "etaf-runtime" (runtime))
(declare-function etaf-runtime-call-operation
"etaf-runtime" (runtime kind label function))
(declare-function ebox-call-with-render-burst
"ebox-buffer-backend" (function &rest arguments))
@ -61,9 +68,15 @@
When PAYLOAD-P is non-nil, pass PAYLOAD as the callback's only argument;
otherwise call the local callback with no arguments."
(let ((dispatch
(etaf--assert-not-rendering 'dispatch-event)
(setq runtime (etaf-runtime-require-mounted runtime))
(let* ((dispatch
(lambda ()
(setq runtime (etaf-runtime-require-mounted runtime))
(when (plist-get (etaf-runtime-host-props-for runtime host-ref)
:disabled)
(signal 'etaf-event-error
(list (format "Cannot dispatch to disabled Host reference: %S"
host-ref))))
(let ((callback (etaf--event-handler runtime host-ref kind)))
(unless callback
(signal 'etaf-event-error
@ -78,8 +91,19 @@ otherwise call the local callback with no arguments."
(if payload-p
(funcall callback payload)
(funcall callback))
(etaf-runtime-event-end runtime)))))))
(ebox-call-with-render-burst dispatch)))
(etaf-runtime-event-end runtime))))))
(run
(lambda ()
(etaf-scheduler-call-with-context
(etaf-runtime-scheduler-context runtime)
(lambda ()
(etaf-reactive-call-with-batch dispatch))))))
(if (or etaf--observer-context (etaf-runtime-observer runtime))
(etaf-runtime-call-operation
runtime 'event
(format "%s %S" (etaf-event-kind kind) host-ref)
(lambda () (ebox-call-with-render-burst run)))
(ebox-call-with-render-burst run))))
;;;###autoload
(defun etaf-host-ref-bounds (runtime host-ref)
@ -101,51 +125,81 @@ otherwise call the local callback with no arguments."
(t nil)))
(defun etaf--activation-candidate-before-p (left right)
"Return non-nil when activation candidate LEFT precedes RIGHT."
"Return non-nil when hit candidate LEFT is inside or smaller than RIGHT."
(let ((left-length (nth 2 left))
(right-length (nth 2 right))
(left-start (nth 1 left))
(right-start (nth 1 right)))
(or (< left-length right-length)
(and (= left-length right-length)
(or (< left-start right-start)
(and (= left-start right-start)
(string< (prin1-to-string (car left))
(prin1-to-string (car right)))))))))
(right-start (nth 1 right))
(left-lineage (nth 3 left))
(right-lineage (nth 3 right)))
(cond
((and right-lineage (memq (car right-lineage) left-lineage)) t)
((and left-lineage (memq (car left-lineage) right-lineage)) nil)
(t (or (< left-length right-length)
(and (= left-length right-length)
(< left-start right-start)))))))
(defun etaf--interaction-boundary-p (props)
"Return non-nil when committed PROPS describe an interaction boundary.
Disabled and callbackless controls still own their hit area. Ordinary text
with only a reference or accessibility label remains part of its parent."
(or (functionp (plist-get props :on-press))
(plist-get props :disabled)
(numberp (plist-get props :tab-index))
(member (let ((role (plist-get props :role)))
(if (symbolp role) (symbol-name role) role))
'("button" "checkbox" "combobox" "link" "menuitem" "option"
"radio" "slider" "spinbutton" "switch" "tab" "textbox"
"treeitem"))))
(defun etaf--activation-at-position (runtime position &optional quiet)
"Activate the smallest enabled Host at POSITION in RUNTIME.
"Activate the deepest interaction boundary at POSITION in RUNTIME.
When QUIET is non-nil, return nil instead of signaling when no callback owns
the position."
(let (candidates)
(dolist (entry (etaf-runtime-handler-entries runtime))
(let ((host-ref (car entry)) (handlers (cdr entry)))
(let* ((press (assq 'press handlers))
(props (etaf-runtime-host-props-for runtime host-ref))
(bounds (ebox-host-ref-bounds
(etaf-runtime-buffer runtime) host-ref))
(start (and bounds (car bounds)))
(end (and bounds (cdr bounds))))
(when (and press (not (plist-get props :disabled))
start end (<= start position) (< position end))
(push (list host-ref start (- end start)) candidates)))))
(setq candidates (sort candidates #'etaf--activation-candidate-before-p))
(if-let* ((candidate (car candidates)))
(etaf-dispatch-event runtime (car candidate) 'press)
(dolist (entry (etaf-runtime-host-props-entries runtime))
(let ((host-ref (car entry)) (props (cdr entry)))
(when (etaf--interaction-boundary-p props)
(let* ((bounds (ebox-host-ref-bounds
(etaf-runtime-buffer runtime) host-ref))
(start (and bounds (car bounds)))
(end (and bounds (cdr bounds))))
(when (and start end (<= start position) (< position end))
(push (list host-ref start (- end start)) candidates))))))
(when (cdr candidates)
(let ((ancestries
(etaf-runtime-host-ancestries runtime (mapcar #'car candidates))))
(dolist (candidate candidates)
(setcdr (last candidate) (list (gethash (car candidate) ancestries)))))
(setq candidates (cl-stable-sort
candidates #'etaf--activation-candidate-before-p)))
(if-let* ((candidate (car candidates))
(ref (car candidate))
((not (plist-get (etaf-runtime-host-props-for runtime ref)
:disabled)))
((etaf--event-handler runtime ref 'press)))
(etaf-dispatch-event runtime ref 'press)
(unless quiet
(user-error "No interactive ETAF Host at point")))))
;;;###autoload
(defun etaf-activate (&optional runtime)
"Dispatch `press' for the smallest enabled Host containing point.
"Dispatch `press' for the focused Host, or the interaction boundary at point.
RUNTIME is the mounted Runtime to activate, or nil for the current buffer."
(interactive)
(setq runtime (etaf-runtime-require-mounted runtime))
(let ((position (with-current-buffer (etaf-runtime-buffer runtime)
(point))))
(etaf--activation-at-position runtime position)))
(let ((position (with-current-buffer (etaf-runtime-buffer runtime) (point)))
(focus-ref (etaf-runtime-focus-ref runtime)))
(if (and focus-ref
(equal position (etaf-host-ref-position runtime focus-ref)))
(if (and (not (plist-get
(etaf-runtime-host-props-for runtime focus-ref) :disabled))
(etaf--event-handler runtime focus-ref 'press))
(etaf-dispatch-event runtime focus-ref 'press)
(user-error "No interactive ETAF Host at point"))
(etaf--activation-at-position runtime position))))
(defun etaf--focus-candidate-before-p (left right)
"Return non-nil when focus candidate LEFT precedes RIGHT."
@ -163,15 +217,40 @@ RUNTIME is the mounted Runtime to activate, or nil for the current buffer."
(let (candidates)
(dolist (entry (etaf-runtime-host-props-entries runtime))
(let ((host-ref (car entry)) (props (cdr entry)))
(let ((tab-index (plist-get props :tab-index))
(bounds (ebox-host-ref-bounds
(etaf-runtime-buffer runtime) host-ref)))
(when (and (numberp tab-index) (>= tab-index 0)
(not (plist-get props :disabled)) bounds)
(push (list tab-index (car bounds) (cdr bounds) host-ref)
candidates)))))
(let ((tab-index (plist-get props :tab-index)))
(when (and (numberp tab-index) (>= tab-index 0)
(not (plist-get props :disabled)))
(when-let* ((bounds
(ebox-host-ref-bounds
(etaf-runtime-buffer runtime) host-ref)))
(push (list tab-index (car bounds) (cdr bounds) host-ref)
candidates))))))
(sort candidates #'etaf--focus-candidate-before-p)))
(defun etaf-events-call-with-preserved-focus (runtime function)
"Call FUNCTION while retaining RUNTIME's active focus through publication.
Follow a Host's new position only when point started at that focused Host,
the same focus survives, and a new generation actually committed. Manual
point movement and failed candidate publication keep their existing behavior."
(let* ((buffer (etaf-runtime-buffer runtime))
(focus-ref (etaf-runtime-focus-ref runtime))
(follow-p
(and focus-ref (buffer-live-p buffer)
(equal (with-current-buffer buffer (point))
(ebox-host-ref-position buffer focus-ref)))))
(if (not follow-p)
(funcall function)
(let ((generation (etaf-runtime-current-generation runtime)))
(unwind-protect
(funcall function)
(when (and (etaf-runtime-mounted-p runtime)
(buffer-live-p buffer)
(equal focus-ref (etaf-runtime-focus-ref runtime))
(not (eq generation
(etaf-runtime-current-generation runtime))))
(when-let* ((position (ebox-host-ref-position buffer focus-ref)))
(with-current-buffer buffer (goto-char position)))))))))
;;;###autoload
(defun etaf-focus (&optional runtime host-ref)
"Move focus to HOST-REF in mounted RUNTIME and move point to its position.
@ -183,6 +262,9 @@ When called interactively without arguments, focus the first visible Host."
(setq host-ref (nth 3 (car (etaf--focus-candidates runtime))))
(unless host-ref
(user-error "No focusable ETAF Host")))
(when (plist-get (etaf-runtime-host-props-for runtime host-ref) :disabled)
(signal 'etaf-event-error
(list (format "Cannot focus disabled Host reference: %S" host-ref))))
(let ((position (etaf-host-ref-position runtime host-ref)))
(unless position
(signal 'etaf-event-error

328
etaf-generation.el Normal file
View File

@ -0,0 +1,328 @@
;;; etaf-generation.el --- ETAF committed generation authority -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Owns the single mutable pointer to ETAF's committed semantic generation and
;; pure construction/comparison of compatibility mirrors. Runtime mirrors are
;; projections only; they never authorize semantic queries or publication.
;;; Code:
(require 'cl-lib)
(require 'subr-x)
(define-error 'etaf-generation-error "Invalid ETAF generation authority")
(define-error 'etaf-generation-conflict
"Stale ETAF semantic generation candidate"
'etaf-generation-error)
(cl-defstruct
(etaf-generation-store-versions
(:constructor etaf-generation-store-versions--create))
"Committed versions for ETAF's independently journaled stores."
(instances 0 :read-only t)
(resources 0 :read-only t)
(artifacts 0 :read-only t)
(routes 0 :read-only t))
(defun etaf-generation-store-versions-create ()
"Return an immutable zeroed ETAF store-version snapshot."
(etaf-generation-store-versions--create))
(defun etaf-generation-store-versions-next (versions)
"Return the immutable successor of store VERSIONS snapshot."
(unless (etaf-generation-store-versions-p versions)
(signal 'wrong-type-argument
(list 'etaf-generation-store-versions-p versions)))
(etaf-generation-store-versions--create
:instances (1+ (etaf-generation-store-versions-instances versions))
:resources (1+ (etaf-generation-store-versions-resources versions))
:artifacts (1+ (etaf-generation-store-versions-artifacts versions))
:routes (1+ (etaf-generation-store-versions-routes versions))))
(cl-defstruct
(etaf-generation-authority
(:constructor etaf-generation-authority--create))
"Mutable authority for one Runtime's committed generation."
generation
(token 0)
(store-versions (etaf-generation-store-versions-create)))
(defun etaf-generation-authority-create (&optional generation)
"Return fresh authority initially pointing at GENERATION."
(etaf-generation-authority--create
:generation generation
:token 0
:store-versions (etaf-generation-store-versions-create)))
(defun etaf-generation-authority-current (authority)
"Return AUTHORITY's current committed generation."
(unless (etaf-generation-authority-p authority)
(signal 'wrong-type-argument
(list 'etaf-generation-authority-p authority)))
(etaf-generation-authority-generation authority))
(defun etaf-generation-authority-set-current (authority generation)
"Set AUTHORITY's current committed GENERATION and return GENERATION.
This compatibility mutation does not advance the semantic commit token; the
versioned compare-and-swap boundary owns token changes."
(unless (etaf-generation-authority-p authority)
(signal 'wrong-type-argument
(list 'etaf-generation-authority-p authority)))
(setf (etaf-generation-authority-generation authority) generation)
generation)
(defun etaf-generation-authority-snapshot (authority)
"Return AUTHORITY's immutable generation/token/version snapshot."
(unless (etaf-generation-authority-p authority)
(signal 'wrong-type-argument
(list 'etaf-generation-authority-p authority)))
(list :generation (etaf-generation-authority-generation authority)
:token (etaf-generation-authority-token authority)
:store-versions
(etaf-generation-authority-store-versions authority)))
(defun etaf-generation-authority-validate
(authority expected-generation expected-token expected-store-versions)
"Validate AUTHORITY against EXPECTED-GENERATION and EXPECTED-TOKEN.
EXPECTED-STORE-VERSIONS must also equal the committed version snapshot."
(unless (and (eq (etaf-generation-authority-generation authority)
expected-generation)
(eql (etaf-generation-authority-token authority)
expected-token)
(equal (etaf-generation-authority-store-versions authority)
expected-store-versions))
(signal 'etaf-generation-conflict
(list
:expected-generation expected-generation
:actual-generation
(etaf-generation-authority-generation authority)
:expected-token expected-token
:actual-token (etaf-generation-authority-token authority)
:expected-store-versions expected-store-versions
:actual-store-versions
(etaf-generation-authority-store-versions authority))))
t)
(defun etaf-generation-authority-compare-and-swap
(authority expected-generation expected-token expected-store-versions
next-generation next-token next-store-versions)
"Atomically swap AUTHORITY from EXPECTED-GENERATION to NEXT-GENERATION.
EXPECTED-TOKEN and EXPECTED-STORE-VERSIONS guard the old authority;
NEXT-TOKEN and NEXT-STORE-VERSIONS become committed together."
(etaf-generation-authority-validate
authority expected-generation expected-token expected-store-versions)
(unless (and (integerp next-token) (> next-token expected-token))
(signal 'etaf-generation-error
(list :invalid-next-token next-token)))
(unless (etaf-generation-store-versions-p next-store-versions)
(signal 'wrong-type-argument
(list 'etaf-generation-store-versions-p next-store-versions)))
(let ((inhibit-quit t))
(setf (etaf-generation-authority-generation authority) next-generation
(etaf-generation-authority-token authority) next-token
(etaf-generation-authority-store-versions authority)
next-store-versions))
next-generation)
(defun etaf-generation-authority-rollback-swap
(authority expected-generation expected-token expected-store-versions
candidate-generation candidate-token candidate-store-versions)
"Restore EXPECTED-GENERATION and EXPECTED-TOKEN in AUTHORITY.
EXPECTED-STORE-VERSIONS are restored only while CANDIDATE-GENERATION,
CANDIDATE-TOKEN, and CANDIDATE-STORE-VERSIONS still match exactly."
(when (and (eq (etaf-generation-authority-generation authority)
candidate-generation)
(eql (etaf-generation-authority-token authority) candidate-token)
(equal (etaf-generation-authority-store-versions authority)
candidate-store-versions))
(let ((inhibit-quit t))
(setf (etaf-generation-authority-generation authority)
expected-generation
(etaf-generation-authority-token authority) expected-token
(etaf-generation-authority-store-versions authority)
expected-store-versions))
t))
(defcustom etaf-semantic-commit-route 'cas
"Semantic generation commit route.
`legacy' changes only the compatibility generation pointer, `cas' performs the
versioned token/store compare-and-swap, and `shadow' validates the same expected
facts before using the CAS route."
:type '(choice (const legacy) (const cas) (const shadow))
:group 'etaf)
(cl-defstruct
(etaf-semantic-candidate
(:constructor etaf-semantic-candidate--create))
"One-shot ETAF semantic authority candidate."
operation-id
candidate-id
runtime-id
mount-epoch
authority
expected-generation
candidate-generation
expected-store-versions
candidate-store-versions
expected-token
candidate-token
inverse-journal
route
(state 'prepared))
(defun etaf-semantic-candidate-create
(authority candidate-generation operation-id candidate-id runtime-id
mount-epoch)
"Prepare a semantic candidate for AUTHORITY and CANDIDATE-GENERATION.
OPERATION-ID, CANDIDATE-ID, RUNTIME-ID, and MOUNT-EPOCH provide immutable
correlation and authority identity."
(unless (etaf-generation-authority-p authority)
(signal 'wrong-type-argument
(list 'etaf-generation-authority-p authority)))
(let* ((snapshot (etaf-generation-authority-snapshot authority))
(expected-token (plist-get snapshot :token))
(expected-versions (plist-get snapshot :store-versions)))
(etaf-semantic-candidate--create
:operation-id operation-id
:candidate-id candidate-id
:runtime-id runtime-id
:mount-epoch mount-epoch
:authority authority
:expected-generation (plist-get snapshot :generation)
:candidate-generation candidate-generation
:expected-store-versions expected-versions
:candidate-store-versions
(etaf-generation-store-versions-next expected-versions)
:expected-token expected-token
:candidate-token (1+ expected-token))))
(defun etaf-semantic-candidate-stage (candidate)
"Install CANDIDATE provisionally through its selected authority route."
(unless (eq (etaf-semantic-candidate-state candidate) 'prepared)
(signal 'etaf-generation-error
(list :candidate-not-prepared
(etaf-semantic-candidate-state candidate))))
(let ((authority (etaf-semantic-candidate-authority candidate))
(route etaf-semantic-commit-route))
(pcase route
('legacy
(etaf-generation-authority-validate
authority
(etaf-semantic-candidate-expected-generation candidate)
(etaf-semantic-candidate-expected-token candidate)
(etaf-semantic-candidate-expected-store-versions candidate))
(etaf-generation-authority-set-current
authority (etaf-semantic-candidate-candidate-generation candidate)))
((or 'cas 'shadow)
(etaf-generation-authority-compare-and-swap
authority
(etaf-semantic-candidate-expected-generation candidate)
(etaf-semantic-candidate-expected-token candidate)
(etaf-semantic-candidate-expected-store-versions candidate)
(etaf-semantic-candidate-candidate-generation candidate)
(etaf-semantic-candidate-candidate-token candidate)
(etaf-semantic-candidate-candidate-store-versions candidate)))
(_
(signal 'etaf-generation-error
(list :unknown-semantic-commit-route route))))
(setf (etaf-semantic-candidate-route candidate) route
(etaf-semantic-candidate-state candidate) 'staged)
candidate))
(defun etaf-semantic-candidate-commit (candidate)
"Mark provisionally installed CANDIDATE committed exactly once."
(unless (eq (etaf-semantic-candidate-state candidate) 'staged)
(signal 'etaf-generation-error
(list :candidate-not-staged
(etaf-semantic-candidate-state candidate))))
(let ((authority (etaf-semantic-candidate-authority candidate)))
(unless (eq (etaf-generation-authority-generation authority)
(etaf-semantic-candidate-candidate-generation candidate))
(signal 'etaf-generation-conflict
(list :candidate-generation-lost
(etaf-semantic-candidate-candidate-id candidate))))
(unless (or (eq (etaf-semantic-candidate-route candidate) 'legacy)
(eql (etaf-generation-authority-token authority)
(etaf-semantic-candidate-candidate-token candidate)))
(signal 'etaf-generation-conflict
(list :candidate-token-lost
(etaf-semantic-candidate-candidate-id candidate))))
(setf (etaf-semantic-candidate-state candidate) 'committed)
candidate))
(defun etaf-semantic-candidate-rollback (candidate)
"Rollback staged CANDIDATE exactly once and return CANDIDATE."
(pcase (etaf-semantic-candidate-state candidate)
('prepared
(setf (etaf-semantic-candidate-state candidate) 'rolled-back))
('staged
(let ((authority (etaf-semantic-candidate-authority candidate)))
(if (eq (etaf-semantic-candidate-route candidate) 'legacy)
(when (eq (etaf-generation-authority-generation authority)
(etaf-semantic-candidate-candidate-generation candidate))
(etaf-generation-authority-set-current
authority
(etaf-semantic-candidate-expected-generation candidate)))
(etaf-generation-authority-rollback-swap
authority
(etaf-semantic-candidate-expected-generation candidate)
(etaf-semantic-candidate-expected-token candidate)
(etaf-semantic-candidate-expected-store-versions candidate)
(etaf-semantic-candidate-candidate-generation candidate)
(etaf-semantic-candidate-candidate-token candidate)
(etaf-semantic-candidate-candidate-store-versions candidate)))
(setf (etaf-semantic-candidate-state candidate) 'rolled-back)))
('rolled-back nil)
(_
(signal 'etaf-generation-error
(list :candidate-not-rollback-capable
(etaf-semantic-candidate-state candidate)))))
candidate)
(defun etaf-generation-project-mirror (entries &optional test)
"Project immutable contribution ENTRIES into a fresh hash table.
TEST defaults to `equal'. Duplicate keys are rejected so a compatibility
mirror cannot silently choose a second semantic truth."
(unless (proper-list-p entries)
(signal 'wrong-type-argument (list 'proper-list-p entries)))
(let ((table (make-hash-table :test (or test #'equal)))
(missing (make-symbol "etaf-generation-mirror-missing")))
(dolist (entry entries)
(unless (consp entry)
(signal 'etaf-generation-error
(list :malformed-mirror-entry entry)))
(let ((key (car entry)))
(unless (eq (gethash key table missing) missing)
(signal 'etaf-generation-error
(list :duplicate-mirror-key key)))
(puthash (copy-tree key) (copy-tree (cdr entry)) table)))
table))
(defun etaf-generation-project-mirrors (handler-entries host-prop-entries)
"Return fresh mirrors from HANDLER-ENTRIES and HOST-PROP-ENTRIES."
(list :handlers
(etaf-generation-project-mirror handler-entries #'equal)
:host-props
(etaf-generation-project-mirror host-prop-entries #'equal)))
(defun etaf-generation-mirror-equal-p (left right)
"Return non-nil when hash tables LEFT and RIGHT contain equal facts."
(and (hash-table-p left)
(hash-table-p right)
(= (hash-table-count left) (hash-table-count right))
(let ((missing (make-symbol "etaf-generation-mirror-missing"))
equal-p)
(setq equal-p t)
(maphash
(lambda (key value)
(unless (equal value (gethash key right missing))
(setq equal-p nil)))
left)
equal-p)))
(provide 'etaf-generation)
;;; etaf-generation.el ends here

172
etaf-host.el Normal file
View File

@ -0,0 +1,172 @@
;;; etaf-host.el --- ETAF Host attach/detach authority -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Owns one mounted Runtime's fixed Host authority token and state machine.
;; Initial attachment registers a bounded TP final marker so attached
;; authority and buffer publication share one final-accept boundary. Detach
;; invalidates authority in O(1) before any unbounded retirement work.
;;; Code:
(require 'cl-lib)
(require 'tp-transaction)
(require 'tp-reactive)
(define-error 'etaf-host-authority-error "Invalid ETAF Host authority state")
(defconst etaf-host--state-slot 0)
(defconst etaf-host--token-slot 1)
(defconst etaf-host--version-slot 2)
(cl-defstruct
(etaf-host-authority
(:constructor etaf-host-authority--create))
"Fixed identity and mutable authority slots for one Runtime Host."
host-id
mount-epoch
buffer
slots)
(defun etaf-host-authority-create (host-id mount-epoch buffer)
"Return detached authority for HOST-ID, MOUNT-EPOCH, and BUFFER."
(unless (and host-id (integerp mount-epoch) (> mount-epoch 0)
(bufferp buffer))
(signal 'etaf-host-authority-error
(list :invalid-host host-id mount-epoch buffer)))
(etaf-host-authority--create
:host-id host-id
:mount-epoch mount-epoch
:buffer buffer
:slots (vector 'detached
(list 'etaf-host-token mount-epoch (make-symbol "token"))
0)))
(defun etaf-host-authority-state (authority)
"Return AUTHORITY's current Host state."
(aref (etaf-host-authority-slots authority) etaf-host--state-slot))
(defun etaf-host-authority-token (authority)
"Return AUTHORITY's current opaque token, or nil after detach."
(aref (etaf-host-authority-slots authority) etaf-host--token-slot))
(defun etaf-host-authority-version (authority)
"Return AUTHORITY's monotonic registration version."
(aref (etaf-host-authority-slots authority) etaf-host--version-slot))
(defun etaf-host-authority-attached-p (authority)
"Return non-nil when AUTHORITY is publicly attached."
(and (etaf-host-authority-p authority)
(eq (etaf-host-authority-state authority) 'attached)
(etaf-host-authority-token authority)))
(defun etaf-host-authority-accepts-token-p (authority token)
"Return non-nil when attached AUTHORITY accepts opaque TOKEN."
(and (etaf-host-authority-attached-p authority)
(eq token (etaf-host-authority-token authority))))
(defun etaf-host-authority-begin-attach (authority)
"Move detached AUTHORITY into its private attaching state."
(unless (eq (etaf-host-authority-state authority) 'detached)
(signal 'etaf-host-authority-error
(list :begin-attach (etaf-host-authority-state authority))))
(aset (etaf-host-authority-slots authority)
etaf-host--state-slot 'attaching)
authority)
(defun etaf-host--slot-write (authority index value)
"Return one prebuilt TP marker write for AUTHORITY slot INDEX and VALUE."
(tp-final-marker-slot-write-create
:target (etaf-host-authority-slots authority)
:index index
:value value))
(defun etaf-host-authority-stage-attach (authority)
"Stage AUTHORITY attachment and register its final marker."
(unless (eq (etaf-host-authority-state authority) 'attaching)
(signal 'etaf-host-authority-error
(list :stage-attach (etaf-host-authority-state authority))))
(let* ((slots (etaf-host-authority-slots authority))
(token (etaf-host-authority-token authority))
(version (etaf-host-authority-version authority)))
(aset slots etaf-host--state-slot 'provisionally-attached)
(tp-transaction-register-final-marker
:owner-key
(list 'etaf-host
(etaf-host-authority-host-id authority)
(etaf-host-authority-mount-epoch authority))
:expected-token
(tp-final-marker-expectation-create
:target slots :index etaf-host--token-slot :value token)
:expected-version
(tp-final-marker-expectation-create
:target slots :index etaf-host--version-slot :value version)
:next-values
(vector
(etaf-host--slot-write authority etaf-host--state-slot 'attached)
(etaf-host--slot-write authority etaf-host--version-slot (1+ version)))
:inverse-values
(vector
(etaf-host--slot-write
authority etaf-host--state-slot 'provisionally-attached)
(etaf-host--slot-write authority etaf-host--version-slot version))
:slot-write-count 2
:operation-key 'tp-vector-slots/v1)
authority))
(defun etaf-host-authority-rollback-attach (authority)
"Restore failed attaching AUTHORITY to detached, idempotently."
(pcase (etaf-host-authority-state authority)
((or 'attaching 'provisionally-attached 'attached)
(aset (etaf-host-authority-slots authority)
etaf-host--state-slot 'detached))
((or 'detached 'terminal) nil)
(state
(signal 'etaf-host-authority-error (list :rollback-attach state))))
authority)
(defun etaf-host-authority-finish-attach (authority)
"Validate and return final-accept attached AUTHORITY."
(unless (etaf-host-authority-attached-p authority)
(signal 'etaf-host-authority-error
(list :finish-attach (etaf-host-authority-state authority))))
authority)
(defun etaf-host-authority-begin-detach (authority)
"Move attached AUTHORITY into pre-boundary detaching state."
(unless (etaf-host-authority-attached-p authority)
(signal 'etaf-host-authority-error
(list :begin-detach (etaf-host-authority-state authority))))
(aset (etaf-host-authority-slots authority)
etaf-host--state-slot 'detaching)
authority)
(defun etaf-host-authority-invalidate (authority)
"Invalidate AUTHORITY token in O(1) and enter detached retirement."
(unless (memq (etaf-host-authority-state authority)
'(detaching attaching provisionally-attached detached))
(signal 'etaf-host-authority-error
(list :invalidate (etaf-host-authority-state authority))))
(let* ((slots (etaf-host-authority-slots authority))
(version (etaf-host-authority-version authority))
(inhibit-quit t))
(aset slots etaf-host--state-slot 'detached-retiring)
(aset slots etaf-host--token-slot nil)
(aset slots etaf-host--version-slot (1+ version)))
authority)
(defun etaf-host-authority-finish-detach (authority)
"Move detached-retiring AUTHORITY to terminal."
(unless (memq (etaf-host-authority-state authority)
'(detached-retiring terminal))
(signal 'etaf-host-authority-error
(list :finish-detach (etaf-host-authority-state authority))))
(aset (etaf-host-authority-slots authority)
etaf-host--state-slot 'terminal)
authority)
(provide 'etaf-host)
;;; etaf-host.el ends here

202
etaf-observer.el Normal file
View File

@ -0,0 +1,202 @@
;;; etaf-observer.el --- Scoped ETAF Runtime observation -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; This file defines the deliberately small observation port used by the ETAF
;; Runtime. Observation is scoped to one dynamic operation; it is neither a
;; global subscription service nor publication authority. When no context is
;; active, instrumented stages execute their original body directly.
;;; Code:
(require 'cl-lib)
(define-error 'etaf-observer-error "Invalid ETAF observer operation")
(defconst etaf-observer-report-format-version 1
"Format version of flat ETAF observation reports.")
(defconst etaf--observer-context-keys
'(:format-version :operation-id :sequence :runtime-id :buffer-name)
"Report fields owned exclusively by the active operation context.")
(cl-defstruct (etaf--observer-context
(:constructor etaf--observer-context--make))
"Dynamic observation state for one ETAF Runtime operation."
sink
operation-id
runtime-id
buffer-name
(sequence 0)
diagnostic)
(defvar etaf--observer-context nil
"Dynamically active ETAF observation context, or nil.")
(defun etaf--observer-provider-report-valid-p (report)
"Return non-nil when REPORT is a valid provider report."
(and (proper-list-p report)
(zerop (% (length report) 2))
(let ((tail report)
keys
valid)
(setq valid t)
(while (and tail valid)
(let ((key (pop tail)))
(pop tail)
(setq valid
(and (keywordp key)
(not (memq key keys))
(not (memq key etaf--observer-context-keys))))
(push key keys)))
(and valid
(plist-member report :provider)
(let ((provider (plist-get report :provider)))
(and provider (symbolp provider) (not (keywordp provider))))
(plist-member report :stage)
(let ((stage (plist-get report :stage)))
(and stage (symbolp stage) (not (keywordp stage))))
(or (not (plist-member report :status))
(memq (plist-get report :status) '(success error quit)))
(plist-member report :duration-ms)
(numberp (plist-get report :duration-ms))
(>= (plist-get report :duration-ms) 0)))))
(defun etaf--observer-copy-value (value)
"Return a defensive observation copy of VALUE."
(cond
((stringp value) (copy-sequence value))
((consp value)
(cons (etaf--observer-copy-value (car value))
(etaf--observer-copy-value (cdr value))))
((vectorp value)
(apply #'vector
(mapcar #'etaf--observer-copy-value (append value nil))))
(t value)))
(defun etaf--observer-report-copy (report)
"Return an isolated snapshot of validated provider REPORT."
(etaf--observer-copy-value report))
(defun etaf--observer-diagnose (kind condition)
"Contain KIND and CONDITION with the active context diagnostic sink."
(when-let* ((context etaf--observer-context)
(diagnostic (etaf--observer-context-diagnostic context)))
(let ((inhibit-quit t)
(quit-flag nil))
(condition-case nil
(funcall diagnostic
(list :kind kind :condition (copy-tree condition)))
((error quit) nil))))
nil)
(cl-defun etaf--observer-context-create
(&key sink operation-id runtime-id buffer-name diagnostic)
"Create scoped observer state for one Runtime operation.
SINK receives one defensive report snapshot. OPERATION-ID and RUNTIME-ID are
stable scalar identities, BUFFER-NAME is a string or nil, and DIAGNOSTIC
receives contained observer-port failures. This internal constructor is the
only Runtime entry point that allocates observation state."
(unless (functionp sink)
(signal 'etaf-observer-error '(Observer sink must be a function)))
(unless (integerp operation-id)
(signal 'etaf-observer-error '(Operation identity must be an integer)))
(unless (integerp runtime-id)
(signal 'etaf-observer-error '(Runtime identity must be an integer)))
(unless (or (null buffer-name) (stringp buffer-name))
(signal 'etaf-observer-error '(Buffer name must be a string or nil)))
(unless (functionp diagnostic)
(signal 'etaf-observer-error '(Diagnostic sink must be a function)))
(etaf--observer-context--make
:sink sink
:operation-id operation-id
:runtime-id runtime-id
:buffer-name (and buffer-name (copy-sequence buffer-name))
:diagnostic diagnostic))
(defun etaf--observer-call-with-context (context function)
"Call FUNCTION with internal observer CONTEXT dynamically active."
(unless (etaf--observer-context-p context)
(signal 'etaf-observer-error '(Invalid observer context)))
(unless (functionp function)
(signal 'etaf-observer-error '(Observed operation must be a function)))
(let ((etaf--observer-context context))
(funcall function)))
(defun etaf-observer-emit (report)
"Decorate and deliver immutable provider REPORT in the active context.
The observer receives a defensive copy. Observer errors, quits, and invalid
reports are contained by the context diagnostic sink and never affect product
execution. The dynamic context is cleared during delivery so an observer can
reenter ETAF without recursively observing itself."
(when etaf--observer-context
(if (not (etaf--observer-provider-report-valid-p report))
(etaf--observer-diagnose 'invalid-report report)
(let* ((context etaf--observer-context)
(sequence (1+ (etaf--observer-context-sequence context)))
(sink (etaf--observer-context-sink context))
(provider-report (etaf--observer-report-copy report))
(snapshot
(append
(list :format-version etaf-observer-report-format-version
:operation-id
(etaf--observer-context-operation-id context)
:sequence sequence
:runtime-id (etaf--observer-context-runtime-id context)
:buffer-name
(etaf--observer-copy-value
(etaf--observer-context-buffer-name context)))
provider-report
(unless (plist-member provider-report :status)
(list :status 'success))))
(inhibit-quit t)
(quit-flag nil))
(setf (etaf--observer-context-sequence context) sequence)
(condition-case condition
(let ((etaf--observer-context nil))
(funcall sink snapshot))
((error quit)
(etaf--observer-diagnose 'observer-failure condition))))))
nil)
(defun etaf--observer-finish-stage (provider stage metadata status started)
"Emit PROVIDER STAGE with METADATA, STATUS, and STARTED timestamp."
(let ((duration-ms (max 0.0 (* 1000.0 (- (float-time) started)))))
(etaf-observer-emit
(append (list :provider provider :stage stage :status status
:duration-ms duration-ms)
metadata))))
(defun etaf--observer-call-stage (provider stage metadata function)
"Call observed PROVIDER STAGE FUNCTION with METADATA."
(let ((started (float-time)))
(condition-case condition
(prog1 (funcall function)
(etaf--observer-finish-stage
provider stage metadata 'success started))
(quit
(etaf--observer-finish-stage provider stage metadata 'quit started)
(signal (car condition) (cdr condition)))
(error
(etaf--observer-finish-stage provider stage metadata 'error started)
(signal (car condition) (cdr condition))))))
(cl-defmacro etaf-observer-with-stage
((provider stage &rest metadata) &rest body)
"Execute BODY as PROVIDER STAGE with optional METADATA.
The nil path is a single branch directly to BODY: it takes no timestamp,
allocates no closure or report, and reads no garbage-collection state."
(declare (indent 1) (debug ((form form &rest form) body)))
`(if (null etaf--observer-context)
(progn ,@body)
(etaf--observer-call-stage
,provider ,stage (list ,@metadata) (lambda () ,@body))))
(provide 'etaf-observer)
;;; etaf-observer.el ends here

File diff suppressed because it is too large Load Diff

View File

@ -12,11 +12,15 @@
(require 'cl-lib)
(require 'gv)
(require 'etaf-scheduler)
(define-error 'etaf-reactive-error "Invalid ETAF reactive operation")
(define-error 'etaf-render-side-effect-error
"ETAF render must be side-effect free"
'etaf-reactive-error)
(define-error 'etaf-render-write-error
"ETAF state cannot be written while rendering"
'etaf-reactive-error)
'etaf-render-side-effect-error)
(cl-defstruct (etaf-ref
(:constructor etaf--ref-create))
@ -50,6 +54,7 @@
scheduler
deps
owner-scope
scheduler-context
on-stop
name
(active-p t)
@ -62,13 +67,16 @@
effects
children
cleanups
scheduler-context
name
(active-p t))
(cl-defstruct (etaf-runtime-route
(:constructor etaf-runtime-route-create))
"Opaque Runtime route stored by reactive sources."
runtime-id mount-epoch scheduler)
runtime-id mount-epoch authority-token scheduler scheduler-context
accepts-p
(active-p t))
(defvar etaf--active-effect nil
"The effect currently collecting dependencies.")
@ -93,78 +101,71 @@
(defvar etaf--render-phase-p nil
"Whether the current call is producing a View tree.")
(defun etaf--assert-not-rendering (operation)
"Reject detectable side-effect OPERATION during pure render."
(when etaf--render-phase-p
(signal 'etaf-render-side-effect-error (list operation))))
(defvar etaf--watch-scheduler nil
"Scheduler for watchers created in the current Scope.
The function receives a zero-argument job and a phase symbol. Outside a
Runtime, watchers run synchronously.")
(defvar etaf--dispatch-depth 0)
(defvar etaf--dispatch-source-queue nil)
(defvar etaf--dispatch-source-queue-tail nil)
(defvar etaf--dispatch-source-set (make-hash-table :test #'eq))
(defvar etaf--dispatch-runtime-queue nil)
(defvar etaf--dispatch-runtime-queue-tail nil)
(defvar etaf--dispatch-runtime-set (make-hash-table :test #'eq))
(defvar etaf--dispatch-effect-set (make-hash-table :test #'eq))
(defun etaf--subscriber-scheduler-context (subscriber)
"Return SUBSCRIBER's scheduler context or the default context."
(or (cond
((etaf-runtime-route-p subscriber)
(etaf-runtime-route-scheduler-context subscriber))
((etaf-effect-p subscriber)
(etaf-effect-scheduler-context subscriber)))
etaf-scheduler-default-context))
(defun etaf--dispatch-append-source (source)
"Append SOURCE to the reactive FIFO in constant time."
(let ((cell (list source)))
(if etaf--dispatch-source-queue-tail
(setcdr etaf--dispatch-source-queue-tail cell)
(setq etaf--dispatch-source-queue cell))
(setq etaf--dispatch-source-queue-tail cell)))
(defun etaf-runtime-route-live-p (route)
"Return non-nil when opaque Runtime ROUTE still owns dispatch authority."
(and (etaf-runtime-route-p route)
(etaf-runtime-route-active-p route)
(let ((predicate (etaf-runtime-route-accepts-p route)))
(or (null predicate)
(condition-case condition
(funcall predicate route)
((error quit)
(etaf-scheduler-record-route-authority-fault
(etaf--subscriber-scheduler-context route) condition)
nil))))))
(defun etaf--dispatch-append-runtime (runtime)
"Append RUNTIME to the reactive publication FIFO in constant time."
(let ((cell (list runtime)))
(if etaf--dispatch-runtime-queue-tail
(setcdr etaf--dispatch-runtime-queue-tail cell)
(setq etaf--dispatch-runtime-queue cell))
(setq etaf--dispatch-runtime-queue-tail cell)))
(defun etaf-reactive-enqueue-runtime-flush
(runtime function &optional scheduler-context)
"Queue FUNCTION once for RUNTIME in SCHEDULER-CONTEXT.
The default context preserves the legacy two-argument facade."
(etaf-scheduler-enqueue-runtime
(or scheduler-context (etaf-scheduler-current-context))
runtime function))
(defun etaf-reactive-enqueue-runtime-flush (runtime function)
"Queue FUNCTION once for RUNTIME after the outer reactive dispatch settles."
(unless (gethash runtime etaf--dispatch-runtime-set)
(puthash runtime function etaf--dispatch-runtime-set)
(etaf--dispatch-append-runtime runtime)))
(defun etaf--dispatch-source-now (source)
"Notify SOURCE subscribers without opening another dispatch boundary."
(let ((subscribers (copy-hash-table (etaf--source-subscribers source))))
(maphash
(lambda (subscriber _)
(cond
((etaf-runtime-route-p subscriber)
(funcall (etaf-runtime-route-scheduler subscriber)
subscriber source))
((etaf-effect-active-p subscriber)
(unless (gethash subscriber etaf--dispatch-effect-set)
(puthash subscriber t etaf--dispatch-effect-set)
(if-let* ((scheduler (etaf-effect-scheduler subscriber)))
(funcall scheduler subscriber)
(etaf-reactive-effect-run subscriber))))))
subscribers)))
(defun etaf--drain-dispatch ()
"Drain reactive sources and Runtime work to a stable outer fixed point."
(while (or etaf--dispatch-source-queue etaf--dispatch-runtime-queue)
(while etaf--dispatch-source-queue
(let ((source (pop etaf--dispatch-source-queue)))
(unless etaf--dispatch-source-queue
(setq etaf--dispatch-source-queue-tail nil))
(remhash source etaf--dispatch-source-set)
(etaf--dispatch-source-now source)))
;; Detach this turn. A lifecycle write may enqueue a source and the same
;; Runtime again for the following turn without merging it into this one.
(let ((turn etaf--dispatch-runtime-queue))
(setq etaf--dispatch-runtime-queue nil
etaf--dispatch-runtime-queue-tail nil)
(dolist (runtime turn)
(let ((function (gethash runtime etaf--dispatch-runtime-set)))
(remhash runtime etaf--dispatch-runtime-set)
(funcall function))))))
(defun etaf--dispatch-subscriber-group
(context source _projection-epoch subscribers)
"Notify SOURCE SUBSCRIBERS already grouped for scheduler CONTEXT."
(let (first-condition)
(dolist (subscriber subscribers)
(etaf-scheduler-record-subscriber-visit context)
(condition-case condition
(cond
((etaf-runtime-route-p subscriber)
(if (etaf-runtime-route-live-p subscriber)
(funcall (etaf-runtime-route-scheduler subscriber)
subscriber source)
(etaf-scheduler-record-stale-route-drop context)))
((and (etaf-effect-p subscriber)
(etaf-effect-active-p subscriber)
(etaf-scheduler-claim-effect context subscriber))
(if-let* ((scheduler (etaf-effect-scheduler subscriber)))
(funcall scheduler subscriber)
(etaf-reactive-effect-run subscriber))))
((error quit)
(unless first-condition
(setq first-condition condition)))))
(when first-condition
(signal (car first-condition) (cdr first-condition)))))
(defun etaf--reactive-same-p (left right)
"Return whether LEFT and RIGHT are equal under ETAF's shallow rule."
@ -222,13 +223,18 @@ Runtime, watchers run synchronously.")
SCHEDULER receives the effect when a dependency changes. SCOPE defaults to
the current Scope. NAME optionally labels the effect. ON-STOP runs once
when the effect is disposed."
(etaf--assert-not-rendering 'create-effect)
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(let* ((owner (or scope etaf--active-scope))
(scheduler-context
(or (and owner (etaf-effect-scope-scheduler-context owner))
(etaf-scheduler-current-context)))
(effect (etaf--effect-create
:function function
:scheduler scheduler
:owner-scope owner
:scheduler-context scheduler-context
:on-stop on-stop
:name name)))
(when owner
@ -244,7 +250,12 @@ When RENDERING is non-nil, `etaf-value' writes are rejected for the duration
of the run."
(unless (etaf-effect-p effect)
(signal 'wrong-type-argument (list 'etaf-effect-p effect)))
(cond
(let* ((scheduler-context
(or (etaf-effect-scheduler-context effect)
(etaf-scheduler-current-context)))
(etaf--scheduler-context scheduler-context))
(etaf-scheduler-record-effect-evaluation scheduler-context)
(cond
((etaf-effect-running-p effect)
(error "Recursive ETAF effect execution: %S"
(or (etaf-effect-name effect) effect)))
@ -271,29 +282,61 @@ of the run."
(etaf--clear-effect-deps effect)
(dolist (source old-deps)
(puthash effect t (etaf--source-subscribers source)))
(setf (etaf-effect-deps effect) old-deps))))))))
(setf (etaf-effect-deps effect) old-deps)))))))))
(defun etaf--dispatch-source (source)
"Notify every current subscriber of SOURCE once."
(unless (gethash source etaf--dispatch-source-set)
(puthash source t etaf--dispatch-source-set)
(etaf--dispatch-append-source source))
(when (zerop etaf--dispatch-depth)
(let ((etaf--dispatch-depth 1))
(unwind-protect (etaf--drain-dispatch)
(setq etaf--dispatch-source-queue nil
etaf--dispatch-source-queue-tail nil
etaf--dispatch-runtime-queue nil
etaf--dispatch-runtime-queue-tail nil)
(clrhash etaf--dispatch-source-set)
(clrhash etaf--dispatch-runtime-set)
(clrhash etaf--dispatch-effect-set)))))
(defun etaf--dispatch-source (source &optional context-filter)
"Notify current subscribers of SOURCE once.
When CONTEXT-FILTER is non-nil, it is called with each subscriber's scheduler
context and only subscribers for which it returns non-nil are included. The
filter is an internal reconciliation hook: the ordinary source publication
path leaves it nil, while a retry can target only contexts that did not finish
an earlier projection epoch."
(etaf-scheduler-call-with-projection
(lambda ()
(let ((groups (make-hash-table :test #'eq)))
(maphash
(lambda (subscriber _)
(let ((context (etaf--subscriber-scheduler-context subscriber)))
(when (or (null context-filter)
(funcall context-filter context))
(cond
((etaf-runtime-route-p subscriber)
(if (etaf-runtime-route-live-p subscriber)
(puthash context
(cons subscriber (gethash context groups)) groups)
(etaf-scheduler-record-stale-route-drop context)))
((and (etaf-effect-p subscriber)
(etaf-effect-active-p subscriber))
(puthash context
(cons subscriber (gethash context groups)) groups)))))
)
(etaf--source-subscribers source))
(let (contexts)
(maphash (lambda (context _) (push context contexts)) groups)
(dolist (context
(sort contexts
(lambda (left right)
(< (etaf-scheduler-context-id left)
(etaf-scheduler-context-id right)))))
(let ((subscribers (nreverse (gethash context groups))))
(etaf-scheduler-enqueue-source
context source
(lambda (delivery-context delivery-source projection-epoch)
(etaf--dispatch-subscriber-group
delivery-context delivery-source projection-epoch
subscribers))))))))))
(defun etaf-reactive-call-with-batch (function)
"Call FUNCTION inside one cross-context reactive projection."
(etaf-scheduler-call-with-projection function))
;;;###autoload
(cl-defun etaf-ref (initial-value &key test name)
"Create a writable shallow reactive cell containing INITIAL-VALUE.
TEST optionally compares old and new values. NAME is used in diagnostics."
(etaf--assert-not-rendering 'create-ref)
(when (and test (not (functionp test)))
(signal 'wrong-type-argument (list 'functionp test)))
(etaf--ref-create :value initial-value
@ -330,6 +373,7 @@ TEST optionally compares old and new values. NAME is used in diagnostics."
TEST optionally compares old and new values. NAME optionally labels the
computed value."
(etaf--assert-not-rendering 'create-computed)
(unless (functionp getter)
(signal 'wrong-type-argument (list 'functionp getter)))
(when (and test (not (functionp test)))
@ -398,6 +442,7 @@ computed value."
IMMEDIATE calls CALLBACK for the initial value. FLUSH is passed to the
current Runtime scheduler. TEST and NAME customize comparison and
diagnostics. Return a stop function."
(etaf--assert-not-rendering 'watch)
(unless (functionp callback)
(signal 'wrong-type-argument (list 'functionp callback)))
(let* ((getter (etaf--watch-getter source))
@ -444,6 +489,7 @@ diagnostics. Return a stop function."
FLUSH selects the Runtime scheduler boundary. NAME optionally labels the
effect. If FUNCTION returns a function, it cleans up the previous run."
(etaf--assert-not-rendering 'watch-effect)
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(let (cleanup effect job)
@ -464,10 +510,20 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
(lambda () (etaf--stop-effect effect))))
;;;###autoload
(cl-defun etaf-effect-scope (&key detached name)
"Create a Scope named NAME, owned by the current Scope unless DETACHED."
(cl-defun etaf-effect-scope (&key detached name scheduler-context)
"Create a Scope named NAME, owned by the current Scope unless DETACHED.
SCHEDULER-CONTEXT defaults to the parent or dynamically active context."
(etaf--assert-not-rendering 'create-scope)
(let* ((parent (and (not detached) etaf--active-scope))
(scope (etaf--effect-scope-create :parent parent :name name)))
(scheduler-context
(or scheduler-context
(and parent (etaf-effect-scope-scheduler-context parent))
(etaf-scheduler-current-context)))
(scope (etaf--effect-scope-create
:parent parent
:scheduler-context
(etaf-scheduler-context-resolve scheduler-context)
:name name)))
(when parent
(push scope (etaf-effect-scope-children parent)))
scope))
@ -485,6 +541,8 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
(etaf-effect-scope-active-p scope))
(error "Cannot enter an inactive ETAF Scope"))
(let ((etaf--active-scope scope)
(etaf--scheduler-context
(etaf-effect-scope-scheduler-context scope))
(etaf--watch-scheduler
(if watch-scheduler-p watch-scheduler etaf--watch-scheduler)))
(funcall function)))
@ -492,6 +550,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload
(defun etaf-on-scope-dispose (function)
"Register FUNCTION to run when the current Scope is disposed."
(etaf--assert-not-rendering 'register-scope-cleanup)
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(unless etaf--active-scope
@ -502,6 +561,7 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
;;;###autoload
(defun etaf-scope-stop (scope)
"Dispose SCOPE and return cleanup errors collected during teardown."
(etaf--assert-not-rendering 'stop-scope)
(when (and (etaf-effect-scope-p scope)
(etaf-effect-scope-active-p scope))
(setf (etaf-effect-scope-active-p scope) nil)

384
etaf-render-port.el Normal file
View File

@ -0,0 +1,384 @@
;;; etaf-render-port.el --- Versioned Ebox renderer port -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; This file is ETAF's only Ebox framework-SPI bootstrap owner. It requires
;; one compatible Ebox v2 provider, snapshots it once, and exposes one immutable
;; port to downstream ETAF code without repeated protocol guesses.
;;; Code:
(require 'cl-lib)
(require 'subr-x)
(require 'ebox)
(define-error 'etaf-spi-bootstrap-error
"Malformed Ebox framework SPI provider")
(define-error 'etaf-spi-incompatible-error
"Incompatible Ebox framework SPI provider"
'etaf-spi-bootstrap-error)
(defconst etaf-render-port--required-spi-version 2
"Ebox framework SPI version consumed by this ETAF build.")
(defconst etaf-render-port--required-schema-version
'ebox-framework-spi-schema/v2
"Ebox provider schema consumed by this ETAF build.")
(defconst etaf-render-port--required-capabilities
'(initial-paired-stage-rollback
update-paired-stage-rollback
combined-participant-ordering
same-object-legacy-report
initial-observation-replay)
"Capabilities required from an Ebox framework SPI v2 provider.")
(defconst etaf-render-port--accepted-tp-protocols
'(tp-transaction-protocol-v1+v2 tp-transaction-protocol-v2)
"TP protocols accepted from an Ebox SPI v2 provider.
The dual-capability manifest is accepted during dependency-order migration
because it contains v2; ETAF never dispatches through its v1 capability.")
(defconst etaf-render-port--required-stage-order
'(ebox-mirror/native framework-stage)
"Required stage order inside the combined Ebox participant.")
(defconst etaf-render-port--required-rollback-order
'(framework-rollback ebox-mirror/native tp)
"Required rollback order inside the combined Ebox participant.")
(cl-defstruct
(etaf-render-port
(:constructor etaf-render-port--create)
(:conc-name etaf-render-port--))
"Immutable selected Ebox rendering capability."
(route nil :read-only t)
(spi-version nil :read-only t)
(schema-version nil :read-only t)
(capabilities nil :read-only t)
(tp-protocol nil :read-only t)
(initial-function nil :read-only t)
(update-function nil :read-only t)
(revision-function nil :read-only t)
(bootstrap-outcome nil :read-only t)
(provider nil :read-only t)
(snapshot-function nil :read-only t))
(defun etaf-render-port-route (port)
"Return selected PORT route, always `v2'."
(etaf-render-port--route port))
(defun etaf-render-port-spi-version (port)
"Return PORT's selected framework SPI version."
(etaf-render-port--spi-version port))
(defun etaf-render-port-schema-version (port)
"Return PORT's selected provider schema version."
(etaf-render-port--schema-version port))
(defun etaf-render-port-capabilities (port)
"Return a defensive copy of PORT's capabilities."
(copy-sequence (etaf-render-port--capabilities port)))
(defun etaf-render-port-tp-protocol (port)
"Return PORT's selected TP transaction protocol."
(etaf-render-port--tp-protocol port))
(defun etaf-render-port-initial-function (port)
"Return PORT's initial mount function symbol."
(etaf-render-port--initial-function port))
(defun etaf-render-port-update-function (port)
"Return PORT's update function symbol."
(etaf-render-port--update-function port))
(defun etaf-render-port-revision-function (port)
"Return PORT's current-revision query function symbol."
(etaf-render-port--revision-function port))
(defun etaf-render-port-snapshot-function (port)
"Return PORT's explicit committed-snapshot query function symbol."
(etaf-render-port--snapshot-function port))
(defun etaf-render-port-bootstrap-outcome (port)
"Return PORT's immutable bootstrap outcome tag."
(etaf-render-port--bootstrap-outcome port))
(defun etaf-render-port--bootstrap-error (reason &optional detail)
"Signal a fail-closed bootstrap error for REASON and DETAIL."
(signal 'etaf-spi-bootstrap-error
(list :reason reason :detail detail)))
(defun etaf-render-port--ensure-accessors ()
"Require Ebox's public v2 accessors and explicit snapshot query."
(dolist
(function
'(ebox-framework-spi-provider-p
ebox-framework-spi-provider-spi-version
ebox-framework-spi-provider-schema-version
ebox-framework-spi-provider-capabilities
ebox-framework-spi-provider-tp-protocol
ebox-framework-spi-provider-stage-order
ebox-framework-spi-provider-rollback-order
ebox-framework-spi-provider-report-semantics
ebox-framework-spi-provider-initial-operation
ebox-framework-spi-provider-update-operation
ebox-framework-spi-operation-p
ebox-framework-spi-operation-kind
ebox-framework-spi-operation-function
ebox-framework-spi-operation-argument-schema
ebox-framework-spi-operation-result-schema
ebox-framework-spi-operation-paired-stage-rollback-p
ebox-framework-spi-initial-observation-reports
ebox-surface-buffer-snapshot))
(unless (fboundp function)
(etaf-render-port--bootstrap-error
'missing-provider-accessor function))))
(defun etaf-render-port--operation-snapshot (operation label)
"Return validated immutable field snapshot for OPERATION named LABEL."
(unless (ebox-framework-spi-operation-p operation)
(etaf-render-port--bootstrap-error
'malformed-operation (list :label label :value operation)))
(let ((kind (ebox-framework-spi-operation-kind operation))
(function (ebox-framework-spi-operation-function operation))
(arguments
(ebox-framework-spi-operation-argument-schema operation))
(result (ebox-framework-spi-operation-result-schema operation))
(paired
(ebox-framework-spi-operation-paired-stage-rollback-p operation)))
(unless (and (symbolp kind)
(symbolp function)
(fboundp function)
(proper-list-p arguments)
(cl-every #'symbolp arguments)
(symbolp result)
(memq paired '(nil t)))
(etaf-render-port--bootstrap-error
'malformed-operation-fields
(list :label label :kind kind :function function
:arguments arguments :result result :paired paired)))
(list :kind kind :function function
:arguments (copy-sequence arguments)
:result result :paired paired)))
(defun etaf-render-port--provider-snapshot (provider)
"Return a validated field snapshot of Ebox v2 PROVIDER."
(etaf-render-port--ensure-accessors)
(unless (ebox-framework-spi-provider-p provider)
(etaf-render-port--bootstrap-error 'non-provider-record provider))
(let ((spi-version (ebox-framework-spi-provider-spi-version provider))
(schema-version
(ebox-framework-spi-provider-schema-version provider))
(capabilities
(ebox-framework-spi-provider-capabilities provider))
(tp-protocol (ebox-framework-spi-provider-tp-protocol provider))
(stage-order (ebox-framework-spi-provider-stage-order provider))
(rollback-order
(ebox-framework-spi-provider-rollback-order provider))
(report-semantics
(ebox-framework-spi-provider-report-semantics provider)))
(unless (and (integerp spi-version)
(> spi-version 0)
(symbolp schema-version)
(proper-list-p capabilities)
(cl-every #'symbolp capabilities)
(symbolp tp-protocol)
(proper-list-p stage-order)
(cl-every #'symbolp stage-order)
(proper-list-p rollback-order)
(cl-every #'symbolp rollback-order)
(symbolp report-semantics))
(etaf-render-port--bootstrap-error
'malformed-provider-fields
(list :spi-version spi-version :schema-version schema-version
:capabilities capabilities :tp-protocol tp-protocol
:stage-order stage-order :rollback-order rollback-order
:report-semantics report-semantics)))
(list
:provider provider
:spi-version spi-version
:schema-version schema-version
:capabilities (copy-sequence capabilities)
:tp-protocol tp-protocol
:stage-order (copy-sequence stage-order)
:rollback-order (copy-sequence rollback-order)
:report-semantics report-semantics
:initial
(etaf-render-port--operation-snapshot
(ebox-framework-spi-provider-initial-operation provider) 'initial)
:update
(etaf-render-port--operation-snapshot
(ebox-framework-spi-provider-update-operation provider) 'update))))
(defun etaf-render-port--incompatibilities (snapshot)
"Return deterministic compatibility failures in provider SNAPSHOT."
(let (failures)
(unless (eql (plist-get snapshot :spi-version)
etaf-render-port--required-spi-version)
(push (list :spi-version (plist-get snapshot :spi-version)) failures))
(unless (eq (plist-get snapshot :schema-version)
etaf-render-port--required-schema-version)
(push (list :schema-version (plist-get snapshot :schema-version))
failures))
(let ((capabilities (plist-get snapshot :capabilities)))
(dolist (capability etaf-render-port--required-capabilities)
(unless (memq capability capabilities)
(push (list :missing-capability capability) failures))))
(unless (memq (plist-get snapshot :tp-protocol)
etaf-render-port--accepted-tp-protocols)
(push (list :tp-protocol (plist-get snapshot :tp-protocol)) failures))
(unless (equal (plist-get snapshot :stage-order)
etaf-render-port--required-stage-order)
(push (list :stage-order (plist-get snapshot :stage-order)) failures))
(unless (equal (plist-get snapshot :rollback-order)
etaf-render-port--required-rollback-order)
(push (list :rollback-order (plist-get snapshot :rollback-order))
failures))
(unless (eq (plist-get snapshot :report-semantics)
'same-object-legacy-report)
(push (list :report-semantics
(plist-get snapshot :report-semantics))
failures))
(dolist
(expectation
`((:initial initial ebox-framework-spi-initial
(buffer canonical-input framework-stage framework-rollback))
(:update update ebox-framework-spi-update
(buffer canonical-input-or-candidate
framework-stage framework-rollback))))
(let* ((slot (nth 0 expectation))
(operation (plist-get snapshot slot)))
(unless (and (eq (plist-get operation :kind) (nth 1 expectation))
(eq (plist-get operation :function) (nth 2 expectation))
(equal (plist-get operation :arguments)
(nth 3 expectation))
(eq (plist-get operation :result)
'ebox-legacy-report/same-object)
(eq (plist-get operation :paired) t))
(push (list slot operation) failures))))
(nreverse failures)))
(defun etaf-render-port--v2-port (snapshot)
"Return an immutable selected v2 port from compatible SNAPSHOT."
(let ((failures (etaf-render-port--incompatibilities snapshot)))
(when failures
(signal 'etaf-spi-incompatible-error
(list :incompatibilities failures)))
(etaf-render-port--create
:route 'v2
:spi-version (plist-get snapshot :spi-version)
:schema-version (plist-get snapshot :schema-version)
:capabilities (copy-sequence (plist-get snapshot :capabilities))
:tp-protocol (plist-get snapshot :tp-protocol)
:initial-function
(plist-get (plist-get snapshot :initial) :function)
:update-function
(plist-get (plist-get snapshot :update) :function)
:revision-function 'ebox-surface-buffer-revision
:snapshot-function 'ebox-surface-buffer-snapshot
:bootstrap-outcome 'valid-v2-selected
:provider (plist-get snapshot :provider))))
(defun etaf-render-port--bootstrap ()
"Probe Ebox exactly once and return one immutable selected render port."
(let ((feature-present-p (featurep 'ebox-framework-spi-v2))
(predicate-present-p (fboundp 'ebox-framework-spi-capabilities)))
(cond
((and (not feature-present-p) (not predicate-present-p))
(etaf-render-port--bootstrap-error 'v2-provider-missing))
((not feature-present-p)
(etaf-render-port--bootstrap-error 'predicate-without-v2-feature))
((not predicate-present-p)
(etaf-render-port--bootstrap-error 'v2-feature-without-predicate))
(t
(condition-case condition
(etaf-render-port--v2-port
(etaf-render-port--provider-snapshot
(ebox-framework-spi-capabilities)))
((etaf-spi-incompatible-error etaf-spi-bootstrap-error)
(signal (car condition) (cdr condition)))
((error quit)
(etaf-render-port--bootstrap-error
'provider-predicate-failure condition)))))))
(defconst etaf-render-port--selected-port
(etaf-render-port--bootstrap)
"Process-wide immutable Ebox render port selected during ETAF bootstrap.")
(defun etaf-render-port-selected ()
"Return the process-wide immutable Ebox render port."
etaf-render-port--selected-port)
(defun etaf-render-port-initial
(buffer input framework-stage framework-rollback &optional observer)
"Run selected initial operation for BUFFER and canonical INPUT.
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair.
OBSERVER, when non-nil, receives TP and Ebox snapshots measured during the
initial v2 publication and replayed only after successful final accept."
(let ((report
(funcall
(etaf-render-port-initial-function etaf-render-port--selected-port)
buffer input framework-stage framework-rollback)))
(when observer
(dolist (provider-report
(ebox-framework-spi-initial-observation-reports report))
(funcall observer buffer provider-report)))
report))
(defun etaf-render-port-update
(buffer input framework-stage framework-rollback)
"Run selected update operation for BUFFER and INPUT.
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair."
(funcall (etaf-render-port-update-function
etaf-render-port--selected-port)
buffer input framework-stage framework-rollback))
(defun etaf-render-port-unmount (buffer)
"Release the retained Ebox surface owned by mounted BUFFER."
(ebox-unmount-buffer (get-buffer buffer)))
(defun etaf-render-port-mounted-p (buffer)
"Return non-nil when BUFFER owns a live retained Ebox surface."
(ebox-surface-buffer-mounted-p buffer))
(defun etaf-render-port-revision (buffer)
"Return BUFFER's current Ebox revision, or zero when it is unmounted.
During an active TP transaction this can be a provisional revision for the
paired publication stage. Public committed queries must exclude that extent."
(let ((buffer (get-buffer buffer)))
(if (not (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer)))
0
(let ((revision
(funcall
(etaf-render-port-revision-function
etaf-render-port--selected-port)
buffer)))
(unless (and (integerp revision) (> revision 0))
(error "Mounted Ebox surface has no committed revision: %S"
revision))
revision))))
(defun etaf-render-port-snapshot (buffer)
"Export BUFFER's committed canonical input, revision, and mount identity.
Ebox owns this explicit O(N) detached export and rejects unavailable or
transactional reads. The port validates only its envelope and never copies,
publishes, or queries private renderer state."
(let ((snapshot
(funcall
(etaf-render-port-snapshot-function etaf-render-port--selected-port)
buffer)))
(unless (and (proper-list-p snapshot)
(ebox-canonical-input-p (plist-get snapshot :input))
(integerp (plist-get snapshot :revision))
(> (plist-get snapshot :revision) 0)
(integerp (plist-get snapshot :mount-id)))
(error "Malformed Ebox committed snapshot"))
snapshot))
(provide 'etaf-render-port)
;;; etaf-render-port.el ends here

View File

@ -12,10 +12,13 @@
;;; Code:
(require 'cl-lib)
(require 'subr-x)
(require 'ebox)
(require 'etaf-view)
(require 'etaf-component)
(require 'etaf-context)
(require 'etaf-behavior)
(require 'etaf-render-port)
(declare-function etaf--runtime-render-component "etaf-runtime" (runtime call path))
@ -24,8 +27,6 @@
(declare-function etaf--runtime-render-child-range "etaf-runtime" (runtime expr path))
(declare-function etaf--runtime-render-fragment-range
"etaf-runtime" (runtime fragment path))
(declare-function etaf--runtime-render-raw-range
"etaf-runtime" (runtime raw path))
(declare-function etaf--runtime-render-slot-range
"etaf-runtime" (runtime projection path))
(declare-function etaf--runtime-register-semantic-host
@ -53,11 +54,53 @@
(define-error 'etaf-renderer-error "ETAF rendering error")
(defconst etaf--semantic-props
'(:class :id :role :disabled :tab-index :ref :use :aria-label
:aria-description :on-press :on-key-down :on-mouse-down :on-mouse-drag
:on-wheel :on-input :on-focus :on-blur)
"ETAF semantic properties that are not Ebox box properties.")
(defun etaf--behavior-source-p (value)
"Return non-nil when VALUE has the public `:use' source grammar."
(or (null value)
(symbolp value)
(etaf-behavior-spec-p value)
(and (proper-list-p value)
(cl-every (lambda (entry)
(or (symbolp entry) (etaf-behavior-spec-p entry)))
value))))
(defun etaf--validate-semantic-properties (props)
"Return PROPS after validating ETAF Runtime-owned metadata values."
(cl-loop for (property value) on props by #'cddr
do
(cond
((eq property :ref)
(unless (or (null value) (symbolp value) (functionp value))
(signal 'etaf-renderer-error
(list ":ref must be a symbol, function, or nil"))))
((eq property :role)
(unless (or (null value) (symbolp value) (stringp value))
(signal 'etaf-renderer-error
(list ":role must be a symbol, string, or nil"))))
((etaf--aria-property-p property)
(unless (or (null value) (stringp value) (numberp value)
(symbolp value))
(signal 'etaf-renderer-error
(list (format "%S has an invalid semantic value"
property)))))
((etaf--event-property-p property)
(unless (or (null value) (functionp value))
(signal 'etaf-renderer-error
(list (format "%S must be a function or nil"
property)))))
((eq property :disabled)
(unless (memq value '(nil t))
(signal 'etaf-renderer-error
(list ":disabled must be boolean"))))
((eq property :tab-index)
(unless (or (null value) (integerp value))
(signal 'etaf-renderer-error
(list ":tab-index must be an integer or nil"))))
((eq property :use)
(unless (etaf--behavior-source-p value)
(signal 'etaf-renderer-error
(list ":use must be a Behavior symbol, spec, or proper list"))))))
props)
(defvar etaf--render-runtime nil
"Runtime currently lowering a View tree, or nil for a pure render.")
@ -74,15 +117,54 @@
(defvar etaf--rendering-range-p nil
"Non-nil while eagerly lowering descendants of one Range item Host.")
(defun etaf--event-property-p (property)
"Return non-nil when PROPERTY is an ETAF event callback property."
(and (keywordp property)
(string-prefix-p "on-" (substring (symbol-name property) 1))))
(defvar etaf--render-parent-path nil
"Structural path of the current retained semantic parent.")
(defvar etaf--render-site-counts nil
"Occurrence counts distinguishing reused compiled sites under each parent.")
(defun etaf--render-site-token (token)
"Qualify repeated TOKEN occurrences within their mounted semantic parent."
(if (or (null token) (null etaf--render-site-counts))
token
(let* ((key (list etaf--current-semantic-parent-id token))
(index (gethash key etaf--render-site-counts 0)))
(puthash key (1+ index) etaf--render-site-counts)
(if (zerop index) token (list :site token :occurrence index)))))
(defvar etaf--ebox-source-builder nil
"Source builder owned by the current ETAF lowering boundary.")
(defun etaf--ebox-import-input (input)
"Import canonical INPUT into the current lowering and return its nodes."
(unless etaf--ebox-source-builder
(signal 'etaf-renderer-error
(list "Canonical Ebox input escaped its lowering boundary")))
(ebox-canonical-input-import-roots
input (ebox-canonical-input-roots input) etaf--ebox-source-builder))
(defun etaf--ebox-input-for-nodes (nodes)
"Snapshot current source facts for canonical forest NODES."
(unless etaf--ebox-source-builder
(signal 'etaf-renderer-error
(list "Canonical Ebox nodes have no lowering source builder")))
(ebox-canonical-input-create
nodes
(ebox-tree-source-builder-snapshot etaf--ebox-source-builder nodes)))
(defun etaf--generated-host-ref (props path &optional site-token)
"Return the explicit or generated opaque Host reference."
"Return PROPS' explicit Host reference or one generated for PATH.
SITE-TOKEN replaces PATH as the generated call-site identity when non-nil."
(or (plist-get props :ref)
(list 'etaf-host (or site-token (copy-sequence path)))))
(let ((site (or (and (plist-get props :key)
(list :key (plist-get props :key)))
site-token (copy-sequence path))))
(list 'etaf-host
(cond
(etaf--render-runtime
(list :parent etaf--current-semantic-parent-id :site site))
(t
(list :path (copy-sequence path) :site site)))))))
(defun etaf--merge-property (props key value)
"Return PROPS with KEY set to VALUE, preserving the original order."
@ -158,6 +240,33 @@ not create another visual node category."
:props props
:children (etaf--view-node-children node)))))
(defvar etaf--theme-host-default-cache
(make-hash-table :test #'eq :weakness 'key)
"Theme-value keyed accepted Host default templates.")
(defun etaf--theme-host-defaults (defaults name)
"Return immutable DEFAULTS accepted by View node NAME."
(let* ((by-name
(or (gethash defaults etaf--theme-host-default-cache)
(let ((table (make-hash-table :test #'eq)))
(puthash defaults table etaf--theme-host-default-cache)
table)))
(missing (make-symbol "etaf-theme-host-defaults-missing"))
(cached (gethash name by-name missing)))
(if (not (eq cached missing))
cached
(let ((tail defaults) result)
(while tail
(let ((key (pop tail))
(value (pop tail)))
(when (and (etaf--theme-ebox-property-p key)
(ebox-style-property-accepted-p name key))
(setq result
(append result
(list key (etaf-theme-token key value)))))))
(puthash name result by-name)
result))))
(defun etaf--apply-theme-defaults (node)
"Apply known inherited Theme defaults to NODE without overriding props.
Unknown Theme keys remain readable through `etaf-theme-value' but are design
@ -166,19 +275,24 @@ tokens, not Ebox Host properties, and therefore are not materialized here."
(defaults (etaf--theme-source-value source nil nil)))
(if (null defaults)
node
(let ((props (copy-sequence
(etaf--resolve-property-plist
(etaf--view-node-props node)))))
(while defaults
(let ((key (pop defaults))
(value (pop defaults)))
(when (and (etaf--theme-ebox-property-p key)
(not (plist-get props key)))
(setq props
(etaf--merge-property
props key (etaf-theme-token key value))))))
(let* ((name (etaf--view-node-name node))
(props (copy-sequence
(etaf--resolve-property-plist
(etaf--view-node-props node))))
(template (etaf--theme-host-defaults defaults name))
(present (make-hash-table :test #'eq)))
(cl-loop for (key value) on props by #'cddr
when value do
(puthash (etaf--property-domain-key key) t present))
(while template
(let ((key (pop template))
(value (pop template)))
(unless (gethash (etaf--property-domain-key key) present)
(setq props (etaf--merge-property props key value))
(when value
(puthash (etaf--property-domain-key key) t present)))))
(etaf--view-node-create
:name (etaf--view-node-name node)
:name name
:token (etaf--view-node-token node)
:props props
:children (etaf--view-node-children node))))))
@ -211,63 +325,23 @@ tokens, not Ebox Host properties, and therefore are not materialized here."
(defun etaf--theme-ebox-property-p (key)
"Return non-nil when Theme KEY is a known Ebox property.
The public `ebox-property-rules' table is the shared property vocabulary;
The immutable Ebox schema registry is the sole shared property vocabulary;
custom Theme tokens remain Context data and are never copied onto Hosts."
(and (keywordp key)
(boundp 'ebox-property-rules)
(assq key ebox-property-rules)))
(defun etaf--inline-text-surface-properties (props)
"Return text properties represented by inline text PROPS."
(let ((surface (copy-sequence (or (plist-get props :surface-properties) nil))))
(when (plist-member props :face)
(setq surface (append surface (list 'face (plist-get props :face)))))
(when (plist-member props :color)
(setq surface (append surface
(list 'foreground (plist-get props :color)))))
(when (plist-member props :bgcolor)
(setq surface (append surface
(list 'background (plist-get props :bgcolor)))))
surface))
(defun etaf--apply-inline-surface-properties (content surface)
"Return CONTENT with resolved inline SURFACE properties applied."
(let ((result (copy-sequence content)))
(when (and surface (not (zerop (length result))))
(add-text-properties 0 (length result) surface result))
result))
(ebox-style-schema-id key)))
(defun etaf--inline-text-content (value)
"Return `(SUCCESS . STRING)' for inline-compatible text VALUE.
Nested `text' Hosts become propertized runs in one Ebox content surface.
Other View Hosts and Components return a failed result so the caller can use
the ordinary layout lowering path instead."
Only strings and `expr' values that resolve to strings are compatible. View
structure must use the ordinary typed lowering path."
(cond
((stringp value) (cons t value))
((etaf--expr-p value)
(etaf--inline-text-content (funcall (etaf--expr-thunk value))))
((etaf--view-node-p value)
(if (eq (etaf--view-node-name value) 'text)
(let ((children (etaf--view-node-children value))
(result "")
(valid-p t))
(dolist (child children)
(pcase (etaf--inline-text-content child)
(`(t . ,content) (setq result (concat result content)))
(_ (setq valid-p nil))))
(if valid-p
(let ((surface
(etaf--inline-text-surface-properties
(etaf--resolve-property-plist
(etaf--view-node-props value)))))
(when surface
(setq result (copy-sequence result))
(unless (zerop (length result))
(add-text-properties 0 (length result) surface result)))
(cons t result))
(cons nil nil)))
(cons nil nil)))
((and (etaf--expr-p value)
(eq (etaf--expr-kind value) 'interpolation))
(let ((result (funcall (etaf--expr-thunk value))))
(if (stringp result) (cons t result) (cons nil nil))))
((etaf--view-node-p value) (cons nil nil))
((proper-list-p value)
(let ((result "")
(valid-p t))
@ -281,64 +355,209 @@ the ordinary layout lowering path instead."
(defun etaf--inline-text-structural-p (value)
"Return non-nil when VALUE can be owned by mounted inline effects."
(cond
((or (null value) (stringp value) (etaf--expr-p value)) t)
((or (null value) (stringp value)
(and (etaf--expr-p value)
(eq (etaf--expr-kind value) 'interpolation))) t)
((etaf--view-node-p value) nil)
((proper-list-p value)
(cl-every #'etaf--inline-text-structural-p value))
(t nil)))
(defun etaf--inline-text-dynamic-p (value)
"Return non-nil when VALUE contains an inline `expr' update site."
(cond
((and (etaf--expr-p value)
(eq (etaf--expr-kind value) 'interpolation)) t)
((etaf--view-node-p value)
(and (eq (etaf--view-node-name value) 'text)
(cl-every #'etaf--inline-text-structural-p
(etaf--view-node-children value))))
(cl-some #'etaf--inline-text-dynamic-p
(etaf--view-node-children value)))
((proper-list-p value)
(cl-every #'etaf--inline-text-structural-p value))
(cl-some #'etaf--inline-text-dynamic-p value))
(t nil)))
(defun etaf--ebox-properties (props path &optional site-token)
"Translate ETAF PROPS at PATH into Ebox's public property list."
"Project ETAF PROPS at PATH to canonical Ebox author facts.
SITE-TOKEN supplies the stable generated Host identity when non-nil."
(let* ((source-props (etaf--resolve-property-plist props))
(_validated (etaf--validate-semantic-properties source-props))
(props (copy-sequence source-props))
ebox-props surface-properties)
ebox-props)
(while props
(let ((key (pop props))
(value (pop props)))
(cond
((eq key :face)
(push 'face surface-properties)
(push value surface-properties))
((eq key :surface-properties)
(let ((tail value))
(while tail
(push (pop tail) surface-properties)
(push (pop tail) surface-properties))))
((memq key '(:face :surface-properties))
(signal 'etaf-renderer-error
(list (format
"%S is not a canonical ETAF property" key))))
((eq key :content)
(signal 'etaf-renderer-error
(list "Use View children for content, not :content")))
((or (memq key etaf--semantic-props)
(etaf--event-property-p key)
((or (and (etaf--semantic-property-p key)
(not (memq key '(:class :id))))
(eq key :styles))
nil)
(t
(push key ebox-props)
(push value ebox-props)))))
(setq ebox-props (nreverse ebox-props)
surface-properties (nreverse surface-properties))
;; Component APIs pass optional properties as nil. At the resolved
;; author boundary nil means "unspecified"; canonical Ebox defaults
;; own the initial value and never receive a synthetic declaration.
(when value
(push key ebox-props)
(push value ebox-props))))))
(setq ebox-props (nreverse ebox-props))
(setq ebox-props
(etaf--merge-property
ebox-props :host-ref
ebox-props :source-identity
(etaf--generated-host-ref source-props path site-token)))
(when surface-properties
(setq ebox-props
(append ebox-props
(list :surface-properties surface-properties))))
ebox-props))
(defconst etaf--ebox-source-fields
'(:source-identity :key :class :id)
"ETAF source facts compiled into one opaque Ebox source handle.")
(defvar etaf--ebox-declaration-cache (make-hash-table :test #'equal)
"Bounded canonical declaration cache for normalized ETAF author props.")
(defconst etaf--ebox-declaration-cache-limit 512
"Maximum canonical ETAF declaration entries retained across renders.")
(defvar etaf--ebox-layout-config-cache (make-hash-table :test #'equal)
"Bounded typed LayoutConfig cache for normalized ETAF Box forms.")
(defconst etaf--ebox-layout-config-cache-limit 128
"Maximum typed LayoutConfig entries retained across renders.")
(defun etaf--ebox-remove-properties (props names)
"Return PROPS without keys in NAMES."
(cl-loop for (key value) on props by #'cddr
unless (memq key names)
append (list key value)))
(defun etaf--ebox-declarations (tag props)
"Compile TAG style declarations from canonical ETAF PROPS once."
(let* ((style-props
(etaf--ebox-remove-properties
props
etaf--ebox-source-fields))
(key (cons tag style-props))
(missing (make-symbol "etaf-ebox-declarations-missing"))
(cached (gethash key etaf--ebox-declaration-cache missing)))
(if (not (eq cached missing))
cached
(let ((compiled (ebox-style-compile-form tag style-props)))
(when (>= (hash-table-count etaf--ebox-declaration-cache)
etaf--ebox-declaration-cache-limit)
(clrhash etaf--ebox-declaration-cache))
(puthash (copy-tree key) compiled etaf--ebox-declaration-cache)
compiled))))
(defun etaf--ebox-layout-config (tag declarations)
"Return TAG LayoutConfig from normalized DECLARATIONS."
(let* ((layout-props
(ebox-style-declaration-properties
declarations
(lambda (property)
(memq (plist-get property :name)
(ebox-layout-config-property-names tag)))))
(key (cons tag layout-props))
(config (gethash key etaf--ebox-layout-config-cache)))
(or config
(let ((created (ebox-layout-config-for-form tag layout-props)))
(when (>= (hash-table-count etaf--ebox-layout-config-cache)
etaf--ebox-layout-config-cache-limit)
(clrhash etaf--ebox-layout-config-cache))
(puthash (copy-tree key) created etaf--ebox-layout-config-cache)
created))))
(defun etaf--ebox-text-node (value props)
"Return one typed Ebox TextNode for string VALUE and canonical PROPS."
(unless (stringp value)
(signal 'etaf-renderer-error
(list (format "Text payload must resolve to a string: %S" value))))
(unless (ebox-source-builder-p etaf--ebox-source-builder)
(signal 'etaf-renderer-error
(list "ETAF Text lowering requires one source builder")))
(let* ((declarations (etaf--ebox-declarations 'text props))
(source-handle
(ebox-source-builder-bind
etaf--ebox-source-builder
:identity (plist-get props :source-identity)
:key (plist-get props :key)
:id (plist-get props :id)
:class (plist-get props :class)
:declarations declarations
:provenance '(:adapter etaf-renderer :tag text))))
(ebox-text-create
:value value
:owned-facts
(ebox-canonical-facts-from-declarations 'text declarations)
:source-handle source-handle)))
(defun etaf--ebox-box-node (tag props children)
"Return one typed Ebox BoxNode TAG with PROPS over canonical CHILDREN."
(unless (ebox-source-builder-p etaf--ebox-source-builder)
(signal 'etaf-renderer-error
(list "ETAF Box lowering requires one source builder")))
(let* ((declarations (etaf--ebox-declarations tag props))
(layout (etaf--ebox-layout-config tag declarations))
(outer (if (plist-member props :outer)
(plist-get props :outer)
'block))
(source-handle
(ebox-source-builder-bind
etaf--ebox-source-builder
:identity (plist-get props :source-identity)
:key (plist-get props :key)
:id (plist-get props :id)
:class (plist-get props :class)
:declarations declarations
:provenance (list :adapter 'etaf-renderer :tag tag))))
(ebox-box-create
:layout layout :outer outer :children children
:source-builder etaf--ebox-source-builder
:owned-facts (ebox-canonical-facts-from-declarations tag declarations)
:source-handle source-handle)))
(defun etaf--ebox-forest-root (nodes source-identity)
"Return one canonical backend root for ordered forest NODES.
SOURCE-IDENTITY belongs only to a backend root introduced for an empty or
multi-root forest; a single material root is returned unchanged."
(cond
((null nodes)
(etaf--ebox-box-node
'box (list :source-identity source-identity) nil))
((null (cdr nodes))
(car nodes))
(t
(etaf--ebox-box-node
'column (list :source-identity source-identity) nodes))))
(defun etaf--flatten-view-value (value)
"Flatten VALUE through transparent `expr' and sequence values."
(cond
((null value) nil)
((or (stringp value) (etaf--view-node-p value)
(etaf--component-call-p value) (etaf--slot-projection-p value)
(etaf--raw-ebox-p value))
(etaf--component-call-p value) (etaf--slot-projection-p value))
(list value))
((etaf--expr-p value)
(etaf--flatten-view-value (funcall (etaf--expr-thunk value))))
(pcase (etaf--expr-kind value)
('interpolation
(let ((resolved (funcall (etaf--expr-thunk value))))
(cond ((null resolved) nil)
((stringp resolved) (list resolved))
;; Text Hosts validate interpolation through
;; `etaf--inline-text-content'. At a structural boundary the
;; same evaluated value may be a dynamically produced View
;; forest (notably a transparent Component's fragment).
(t (etaf--flatten-view-value resolved)))))
('branch
(etaf--flatten-view-value (funcall (etaf--expr-thunk value))))
('keyed-list
(let ((snapshot (etaf--keyed-program-snapshot value)))
(etaf--flatten-view-value
(etaf--keyed-program-outputs value snapshot))))
(_ (signal 'etaf-renderer-error
(list (format "Unknown View program: %S" value))))))
((proper-list-p value)
(cl-mapcan #'etaf--flatten-view-value value))
(t
@ -395,34 +614,55 @@ the ordinary layout lowering path instead."
(defun etaf--render-component-call-pure (call path)
"Render stateless CALL at PATH without a retained Runtime."
(let* ((spec (etaf--component-call-spec call))
(render (etaf--component-spec-render spec)))
(render (etaf--component-spec-render spec))
(props (etaf--resolve-property-plist
(etaf--component-business-props call)))
(attrs (etaf--resolve-property-plist
(etaf--component-call-attrs call))))
(when (etaf--component-spec-setup spec)
(signal 'etaf-renderer-error
(list "Stateful Component requires `etaf-mount'")))
(let ((etaf--current-component-props
(etaf--component-call-props call))
(let ((etaf--current-component-props props)
(etaf--current-component-slots
(etaf--component-call-slots call)))
(etaf--component-call-slots call))
(etaf--component-phase 'render))
(let ((etaf--render-parent-style-stack etaf--render-style-stack)
(etaf--render-style-stack
(list (cons (etaf--component-spec-styles spec)
(append path (list :component
(etaf--component-spec-name spec)))))))
(etaf--render-value-list
(funcall render
(etaf--component-call-props call)
(etaf--component-call-slots call))
(etaf--apply-component-attrs
(etaf--validate-component-render-result
(funcall render props (etaf--component-call-slots call))
(etaf--component-spec-name spec))
attrs (etaf--component-spec-name spec))
(append path (list :component (etaf--component-spec-name spec))))))))
(defun etaf--render-value-list (value path)
"Render VALUE at structural PATH into a list of Ebox nodes."
(let* ((items (etaf--flatten-view-value value))
(multiple-p (> (length items) 1)))
(multiple-p (or (proper-list-p value) (> (length items) 1)))
(etaf--render-site-counts
(or etaf--render-site-counts (make-hash-table :test #'equal)))
(keys (make-hash-table :test #'equal)))
;; Validate the entire sibling set before any Component setup runs.
(dolist (item items)
(let* ((props (cond ((etaf--view-node-p item)
(etaf--view-node-props item))
((etaf--component-call-p item)
(etaf--component-call-props item))))
(key (etaf--resolve-property-value (plist-get props :key))))
(when key
(when (gethash key keys)
(signal (if etaf--render-runtime
'etaf-runtime-error 'etaf-renderer-error)
(list (format "View at %S has duplicate sibling key: %S"
path key))))
(puthash key t keys))))
(cl-loop for item in items
for index from 0
for item-path = (if multiple-p
(append path (list index))
path)
for item-path = (if multiple-p (append path (list index)) path)
append
(cond
((stringp item)
@ -432,42 +672,42 @@ the ordinary layout lowering path instead."
etaf--render-runtime 'text nil nil item-path)))
(etaf--runtime-finish-semantic-host
etaf--render-runtime semantic-id item)))
(list (ebox-create :content item)))
(list
(etaf--ebox-text-node
item (etaf--ebox-properties nil item-path))))
((etaf--view-node-p item)
(etaf--render-node item item-path))
((etaf--component-call-p item)
(if etaf--render-runtime
(let ((result (etaf--runtime-render-component
etaf--render-runtime item item-path)))
(if (and (consp result)
(eq (car result) 'component-output-range))
(cdr result)
(list result)))
(cond
((eq (car-safe result) 'component-output-material)
(etaf--ebox-import-input (cdr result)))
((eq (car-safe result) 'component-output-range)
(etaf--ebox-import-input (cdr result)))
((eq (car-safe result) 'component-output-anchor)
(list
(apply #'ebox-child-range
(nth 1 result)
(etaf--ebox-import-input (nth 2 result)))))
(t
(signal 'etaf-renderer-error
(list "Runtime returned invalid Component output")))))
(etaf--render-component-call-pure item item-path)))
((etaf--slot-projection-p item)
(etaf--render-slot-projection item item-path))
((etaf--raw-ebox-p item)
(let ((node (funcall (etaf--raw-ebox-thunk item)))
(key (and (etaf--raw-ebox-key-thunk item)
(funcall (etaf--raw-ebox-key-thunk item)))))
(unless node
(signal 'etaf-renderer-error
(list "raw-ebox :value returned nil")))
(unless (listp node)
(signal 'etaf-renderer-error
(list "raw-ebox :value must return an Ebox node")))
(when key
(etaf--validate-key key)
(setq node (copy-sequence node))
(plist-put node :key key))
(list node)))
(t
(signal 'etaf-renderer-error
(list (format "Unresolved View item: %S" item))))))))
(defun etaf--render-node (node path)
"Render normalized Host NODE at structural PATH."
(let* ((node (if (and etaf--render-runtime
(let* ((node (let ((copy (copy-sequence node)))
(setf (etaf--view-node-token copy)
(etaf--render-site-token (etaf--view-node-token node)))
copy))
(node (if (and etaf--render-runtime
(fboundp 'etaf--runtime-behavior-node))
(etaf--runtime-behavior-node
etaf--render-runtime node path)
@ -489,7 +729,7 @@ the ordinary layout lowering path instead."
(node (if (fboundp 'etaf--runtime-style-node)
(etaf--runtime-style-node node path)
node))
(node (etaf--apply-theme-defaults node))
(node (etaf--apply-theme-defaults node))
(name (etaf--view-node-name node))
(theme-result
(etaf--resolve-theme-property-plist
@ -500,10 +740,6 @@ the ordinary layout lowering path instead."
(props (etaf--ebox-properties
raw-props path (etaf--view-node-token node)))
(children (etaf--view-node-children node)))
(when (and etaf--render-runtime
(fboundp 'etaf--runtime-register-host))
(etaf--runtime-register-host
etaf--render-runtime raw-props path (etaf--view-node-token node)))
(pcase name
('text
(let* ((semantic-id
@ -516,44 +752,28 @@ the ordinary layout lowering path instead."
(child-path (append path (list :text)))
(runtime-inline
(and semantic-id
(etaf--inline-text-dynamic-p children)
(etaf--inline-text-structural-p children)
(etaf--runtime-render-inline-content
etaf--render-runtime semantic-id children child-path)))
(flat (unless runtime-inline
(cl-mapcan #'etaf--flatten-view-value children)))
(flat (unless runtime-inline children))
(inline (if runtime-inline
(cons t (car runtime-inline))
(etaf--inline-text-content flat)))
(rendered (unless (car inline)
(let ((etaf--current-semantic-parent-id
(or semantic-id
etaf--current-semantic-parent-id)))
(etaf--render-value-list flat child-path)))))
(etaf--inline-text-content flat))))
(when semantic-id
(etaf--runtime-finish-semantic-host
etaf--render-runtime semantic-id
(and (car inline) (cdr inline))
(and runtime-inline (cadr runtime-inline))))
(if (car inline)
(list (apply #'ebox-create :content (cdr inline) props))
(list (ebox-build (append (list 'row) props rendered))))))
('spacer
(when children
(signal 'etaf-renderer-error
(list "spacer cannot have children")))
(when etaf--render-runtime
(let ((semantic-id (etaf--runtime-register-semantic-host
etaf--render-runtime name raw-props props path
theme-bindings theme-deps property-bindings
property-deps property-context-deps base-props
(etaf--view-node-token node))))
(etaf--runtime-finish-semantic-host
etaf--render-runtime semantic-id)))
(list (apply #'ebox-spacer props)))
(list (etaf--ebox-text-node (cdr inline) props))
(signal 'etaf-renderer-error
(list "Text payload must resolve to one string")))))
('fragment
(etaf--render-value-list children (append path (list :fragment))))
((or 'row 'column 'container 'stack 'flex 'grid)
((or 'box 'row 'column 'flex 'grid)
(let ((nodes nil)
(etaf--render-parent-path path)
(index 0)
(range-child-p nil)
(semantic-id
@ -569,8 +789,13 @@ the ordinary layout lowering path instead."
(let ((etaf--current-semantic-parent-id
(or semantic-id
etaf--current-semantic-parent-id)))
(if (and semantic-id (etaf--expr-p child)
(not etaf--rendering-range-p))
(if (and semantic-id
;; Code-mode may carry a retained
;; structural Expr through `etaf-node'.
;; Both compiler-owned programs and these
;; validated Expr values use the same
;; direct Range lowering boundary.
(etaf--expr-p child))
(let ((result
(etaf--runtime-render-child-range
etaf--render-runtime child
@ -580,8 +805,7 @@ the ordinary layout lowering path instead."
(cdr result))
(if (and semantic-id
(etaf--view-node-p child)
(eq (etaf--view-node-name child) 'fragment)
(not etaf--rendering-range-p))
(eq (etaf--view-node-name child) 'fragment))
(let ((result
(etaf--runtime-render-fragment-range
etaf--render-runtime child
@ -589,19 +813,9 @@ the ordinary layout lowering path instead."
(setq range-child-p t)
(cdr result))
(if (and semantic-id
(etaf--raw-ebox-p child)
(not etaf--rendering-range-p))
(let ((result
(etaf--runtime-render-raw-range
etaf--render-runtime child
(append path (list index)))))
(setq range-child-p t)
(cdr result))
(if (and semantic-id
(etaf--slot-projection-p child)
(etaf--slot-projection-range-compatible-p
child)
(not etaf--rendering-range-p))
child))
(let ((result
(etaf--runtime-render-slot-range
etaf--render-runtime child
@ -609,7 +823,7 @@ the ordinary layout lowering path instead."
(setq range-child-p t)
(cdr result))
(etaf--render-value-list
child (append path (list index))))))))))
child (append path (list index)))))))))
(cl-incf index))
(when semantic-id
(etaf--runtime-finish-semantic-host
@ -622,23 +836,10 @@ the ordinary layout lowering path instead."
(defun etaf--layout-node (name props nodes &optional range-child-p)
"Build layout NAME with Ebox PROPS around child NODES.
RANGE-CHILD-P records that NODES include nonvisual Range segments."
(let ((node
(cond
((eq name 'row)
(if (null props)
(apply #'ebox-row nodes)
(ebox-build (append (list 'row) props nodes))))
((memq name '(column container stack))
(if (null props)
(apply #'ebox-column nodes)
(ebox-build (append (list 'column) props nodes))))
((eq name 'flex)
(apply #'ebox-flex (append props nodes)))
((eq name 'grid)
(apply #'ebox-grid (append props nodes)))
(t
(signal 'etaf-renderer-error
(list (format "Not a layout Host: %S" name)))))))
(unless (memq name '(box row column flex grid))
(signal 'etaf-renderer-error
(list (format "Not a Box form: %S" name))))
(let ((node (etaf--ebox-box-node name props nodes)))
(when range-child-p
(push node etaf--rendered-range-container-nodes))
node))
@ -649,27 +850,29 @@ RANGE-CHILD-P records that NODES include nonvisual Range segments."
RANGE-CHILD-P preserves the direct material Range parent."
(pcase name
('text
(if children
(etaf--layout-node 'row props children range-child-p)
(apply #'ebox-create :content content props)))
('spacer (apply #'ebox-spacer props))
((or 'row 'column 'container 'stack 'flex 'grid)
(when children
(signal 'etaf-renderer-error
(list "Text cannot contain material child nodes")))
(etaf--ebox-text-node content props))
((or 'box 'row 'column 'flex 'grid)
(etaf--layout-node name props children range-child-p))
(_ (signal 'etaf-renderer-error
(list (format "Semantic Host requires Step4b lowering: %S"
(list (format "Expected text, box, row, column, flex, or grid Host; received %S"
name))))))
;;;###autoload
(defun etaf-render (view)
"Lower normalized VIEW to one Ebox node.
"Lower normalized VIEW to one atomic canonical Ebox input.
This pure entry supports stateless Components. Stateful Components require a
Runtime because their setup Scope must have a lifecycle owner."
(let ((nodes (etaf--render-value-list view '(root))))
(cond
((null nodes) (ebox-spacer))
((null (cdr nodes)) (car nodes))
(t (apply #'ebox-column nodes)))))
Runtime because their setup Scope must have a lifecycle owner."
(let ((builder (ebox-source-builder-create)))
(let* ((etaf--ebox-source-builder builder)
(root
(etaf--ebox-forest-root
(etaf--render-value-list view '(root)) '(etaf-root pure))))
(ebox-canonical-input-create
(list root) (ebox-source-builder-finish builder)))))
;;;###autoload
(defun etaf-mount (buffer-or-name view &optional options)
@ -679,7 +882,10 @@ OPTIONS is forwarded to `etaf-runtime-mount' when the Runtime is loaded."
(etaf-runtime-mount buffer-or-name view options)
(let ((ebox-viewport-width (plist-get options :viewport-width))
(ebox-viewport-height (plist-get options :viewport-height)))
(ebox-render-to-buffer buffer-or-name (etaf-render view)))))
(let ((input (etaf-render view))
(buffer (get-buffer-create buffer-or-name)))
(etaf-render-port-initial buffer input #'ignore #'ignore)
buffer))))
(provide 'etaf-renderer)

View File

@ -12,6 +12,7 @@
;;; Code:
(require 'cl-lib)
(require 'etaf-observer)
(require 'etaf-reactive)
(define-error 'etaf-resource-error "Invalid ETAF Resource operation"
@ -92,6 +93,7 @@ disposed."
The Resource owns a child Scope under SCOPE, or under the current active Scope
when SCOPE is nil. Without any parent Scope it creates a detached Scope.
When IMMEDIATE is non-nil, load the Resource before returning it."
(etaf--assert-not-rendering 'create-resource)
(unless (functionp loader)
(signal 'wrong-type-argument (list 'functionp loader)))
(let* ((parent (etaf--resource-parent-scope scope))
@ -136,15 +138,17 @@ When IMMEDIATE is non-nil, load the Resource before returning it."
Only LOADER errors are captured into Resource state. Cleanup failures and
wrong Resource usage continue to signal normally."
(etaf--assert-not-rendering 'load-resource)
(etaf--resource-require-active resource)
(etaf--resource-run-cleanup resource)
(etaf--resource-set-state resource 'loading nil nil)
(let (result error-data)
(condition-case err
(setq result
(etaf-scope-run
(etaf-resource-scope resource)
(etaf-resource-loader resource)))
(etaf-observer-with-stage ('resource 'load)
(etaf-scope-run
(etaf-resource-scope resource)
(etaf-resource-loader resource))))
(error (setq error-data err)))
(if error-data
(etaf--resource-set-state resource 'error nil error-data)
@ -159,6 +163,7 @@ wrong Resource usage continue to signal normally."
;;;###autoload
(defun etaf-resource-dispose (resource)
"Dispose RESOURCE and return cleanup errors collected by its Scope."
(etaf--assert-not-rendering 'dispose-resource)
(unless (etaf-resource-p resource)
(signal 'wrong-type-argument (list 'etaf-resource-p resource)))
(when (etaf-resource-active-p resource)

348
etaf-retirement.el Normal file
View File

@ -0,0 +1,348 @@
;;; etaf-retirement.el --- ETAF postcommit retirement journal -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Defines run-once public lifecycle entries, bounded idempotent structural
;; cleanup, append-only diagnostics, and cause-compatible postcommit condition
;; trailers. Retirement never owns or rolls back committed generation/surface
;; authority.
;;; Code:
(require 'cl-lib)
(require 'subr-x)
(define-error 'etaf-retirement-error "Invalid ETAF retirement journal")
(defvar etaf-retirement--journal-id-counter 0)
(defvar etaf-retirement--entry-id-counter 0)
(defconst etaf-retirement--condition-payload-keys
'(:kind :committed-p :operation-id :outcome-id :generation-id :revision
:diagnostic-journal-id)
"Canonical ordered keys in a v1 postcommit condition payload.")
(defconst etaf-retirement--projection-payload-keys
'(:kind :committed-p :external-commit-certainty :reconciliation-token
:projection-token :result :operation-id :outcome-id :generation-id
:revision :diagnostic-journal-id)
"Canonical ordered keys in a v1 data projection condition payload.")
(cl-defstruct
(etaf-retirement-entry
(:constructor etaf-retirement-entry--create))
"One stable postcommit retirement action."
id owner kind payload ordering-key
(attempt-count 0)
(max-attempts 1)
policy
(state 'pending)
condition)
(cl-defstruct
(etaf-retirement-journal
(:constructor etaf-retirement-journal--create))
"Append-only postcommit retirement and diagnostic journal."
id operation-id outcome-id generation-id revision
entries diagnostics
(state 'open))
(cl-defun etaf-retirement-journal-create
(&key operation-id outcome-id generation-id revision)
"Create a journal bound to OPERATION-ID and OUTCOME-ID.
GENERATION-ID and REVISION identify already committed facts."
(unless (and (integerp operation-id) (>= operation-id 0)
outcome-id
(integerp generation-id) (>= generation-id 0)
(integerp revision) (>= revision 0))
(signal 'etaf-retirement-error
(list :invalid-journal-metadata
operation-id outcome-id generation-id revision)))
(etaf-retirement-journal--create
:id (cl-incf etaf-retirement--journal-id-counter)
:operation-id operation-id
:outcome-id outcome-id
:generation-id generation-id
:revision revision
:entries nil
:diagnostics nil))
(cl-defun etaf-retirement-enqueue
(journal &key owner kind payload ordering-key policy max-attempts)
"Append one retirement entry to JOURNAL.
OWNER, KIND, PAYLOAD, ORDERING-KEY, POLICY, and MAX-ATTEMPTS describe the
action."
(unless (and (etaf-retirement-journal-p journal)
(eq (etaf-retirement-journal-state journal) 'open)
owner kind (functionp payload)
(memq policy '(run-once-public retryable-idempotent
contained-once))
(integerp max-attempts) (> max-attempts 0))
(signal 'etaf-retirement-error
(list :invalid-entry owner kind policy max-attempts)))
(let ((entry
(etaf-retirement-entry--create
:id (cl-incf etaf-retirement--entry-id-counter)
:owner owner
:kind kind
:payload payload
:ordering-key ordering-key
:policy policy
:max-attempts max-attempts)))
(push entry (etaf-retirement-journal-entries journal))
entry))
(defun etaf-retirement--ordering-value-rank (value)
"Return a stable type rank for retirement ordering VALUE."
(cond
((null value) 0)
((numberp value) 1)
((symbolp value) 2)
((stringp value) 3)
((consp value) 4)
(t 5)))
(defun etaf-retirement--compare-ordering-values (left right)
"Compare retirement ordering values LEFT and RIGHT.
Return a negative integer when LEFT precedes RIGHT, zero when their ordering
forms are equal, and a positive integer otherwise."
(cond
((equal left right) 0)
((and (numberp left) (numberp right))
(cond ((= left right) 0) ((< left right) -1) (t 1)))
((and (symbolp left) (symbolp right))
(if (string< (symbol-name left) (symbol-name right)) -1 1))
((and (stringp left) (stringp right))
(if (string< left right) -1 1))
((and (consp left) (consp right))
(let ((left-tail left) (right-tail right) (result 0))
(while (and (consp left-tail) (consp right-tail) (= result 0))
(setq result
(etaf-retirement--compare-ordering-values
(car left-tail) (car right-tail))
left-tail (cdr left-tail)
right-tail (cdr right-tail)))
(if (= result 0)
(etaf-retirement--compare-ordering-values left-tail right-tail)
result)))
(t
(let ((left-rank (etaf-retirement--ordering-value-rank left))
(right-rank (etaf-retirement--ordering-value-rank right)))
(cond
((< left-rank right-rank) -1)
((> left-rank right-rank) 1)
((string< (prin1-to-string left) (prin1-to-string right)) -1)
(t 1))))))
(defun etaf-retirement--entry-less-p (left right)
"Return non-nil when LEFT sorts before RIGHT deterministically."
(let ((order
(etaf-retirement--compare-ordering-values
(etaf-retirement-entry-ordering-key left)
(etaf-retirement-entry-ordering-key right))))
(if (= order 0)
(< (etaf-retirement-entry-id left)
(etaf-retirement-entry-id right))
(< order 0))))
(defun etaf-retirement--record-failure (journal entry condition terminal-state)
"Record ENTRY CONDITION in JOURNAL and assign TERMINAL-STATE."
(setf (etaf-retirement-entry-condition entry) condition
(etaf-retirement-entry-state entry) terminal-state)
(push (list :entry-id (etaf-retirement-entry-id entry)
:owner (copy-tree (etaf-retirement-entry-owner entry))
:kind (etaf-retirement-entry-kind entry)
:policy (etaf-retirement-entry-policy entry)
:attempt-count (etaf-retirement-entry-attempt-count entry)
:state terminal-state
:condition (copy-tree condition))
(etaf-retirement-journal-diagnostics journal)))
(defun etaf-retirement--run-entry (journal entry)
"Run JOURNAL ENTRY according to its bounded policy and return a condition."
(let (condition done)
(while (and (not done)
(< (etaf-retirement-entry-attempt-count entry)
(etaf-retirement-entry-max-attempts entry)))
(cl-incf (etaf-retirement-entry-attempt-count entry))
(setf (etaf-retirement-entry-state entry) 'running)
(setq condition
(condition-case failure
(progn
(funcall (etaf-retirement-entry-payload entry))
nil)
((error quit) failure)))
(if (null condition)
(setq done t)
(unless (eq (etaf-retirement-entry-policy entry)
'retryable-idempotent)
(setq done t))))
(if (null condition)
(setf (etaf-retirement-entry-state entry) 'completed)
(etaf-retirement--record-failure
journal entry condition 'failed-contained))
condition))
(defun etaf-retirement-drain (journal)
"Drain JOURNAL once and return the first public lifecycle condition."
(unless (and (etaf-retirement-journal-p journal)
(eq (etaf-retirement-journal-state journal) 'open))
(signal 'etaf-retirement-error
(list :journal-not-open
(and (etaf-retirement-journal-p journal)
(etaf-retirement-journal-state journal)))))
(let ((entries
(sort (copy-sequence (etaf-retirement-journal-entries journal))
#'etaf-retirement--entry-less-p))
public-condition public-failed-p)
(dolist (entry entries)
(cond
((and public-failed-p
(eq (etaf-retirement-entry-policy entry) 'run-once-public))
(setf (etaf-retirement-entry-state entry) 'abandoned-contained)
(push (list :entry-id (etaf-retirement-entry-id entry)
:owner (copy-tree (etaf-retirement-entry-owner entry))
:kind (etaf-retirement-entry-kind entry)
:policy 'run-once-public
:attempt-count 0
:state 'abandoned-contained)
(etaf-retirement-journal-diagnostics journal)))
(t
(when-let* ((condition (etaf-retirement--run-entry journal entry)))
(when (and (eq (etaf-retirement-entry-policy entry)
'run-once-public)
(null public-condition))
(setq public-condition condition
public-failed-p t))))))
(setf (etaf-retirement-journal-entries journal) entries
(etaf-retirement-journal-diagnostics journal)
(nreverse (etaf-retirement-journal-diagnostics journal))
(etaf-retirement-journal-state journal) 'completed)
public-condition))
(defun etaf-retirement-record-contained-failure
(journal owner kind condition)
"Append contained postcommit CONDITION metadata to JOURNAL.
OWNER and KIND identify the failed postcommit step. This records evidence
without rerunning the failed operation or changing committed authority."
(unless (and (etaf-retirement-journal-p journal)
(eq (etaf-retirement-journal-state journal) 'open)
owner kind
(consp condition) (symbolp (car condition)))
(signal 'etaf-retirement-error
(list :invalid-contained-failure owner kind condition)))
(push (list :entry-id (cl-incf etaf-retirement--entry-id-counter)
:owner (copy-tree owner)
:kind kind
:policy 'contained-once
:attempt-count 1
:state 'failed-contained
:condition (copy-tree condition))
(etaf-retirement-journal-diagnostics journal))
condition)
(cl-defun etaf-retirement-condition-trailer
(journal &optional kind &rest options)
"Return the canonical v1 trailer for JOURNAL and KIND.
The legacy POSTCOMMIT form is unchanged. KIND `projection' additionally
requires the certainty and both reconciliation/projection tokens, which are
encoded in the same versioned sentinel wire format."
;; Accept both the historical positional KIND and a keyword-style KIND.
(when (keywordp kind)
(setq options (cons kind options)
kind (plist-get options :kind)))
(let ((external-commit-certainty
(plist-get options :external-commit-certainty))
(reconciliation-token (plist-get options :reconciliation-token))
(projection-token (plist-get options :projection-token))
(result (plist-get options :result)))
(if (eq (or kind 'postcommit) 'projection)
(list :etaf-condition-trailer/v1
(list :kind 'projection
:committed-p t
:external-commit-certainty external-commit-certainty
:reconciliation-token reconciliation-token
:projection-token projection-token
:result result
:operation-id (etaf-retirement-journal-operation-id journal)
:outcome-id (etaf-retirement-journal-outcome-id journal)
:generation-id (etaf-retirement-journal-generation-id journal)
:revision (etaf-retirement-journal-revision journal)
:diagnostic-journal-id (etaf-retirement-journal-id journal)))
(list :etaf-condition-trailer/v1
(list :kind (or kind 'postcommit)
:committed-p t
:operation-id (etaf-retirement-journal-operation-id journal)
:outcome-id (etaf-retirement-journal-outcome-id journal)
:generation-id (etaf-retirement-journal-generation-id journal)
:revision (etaf-retirement-journal-revision journal)
:diagnostic-journal-id (etaf-retirement-journal-id journal))))))
(defun etaf-retirement--condition-trailer-payload (condition)
"Return the final validated-looking trailer payload in CONDITION, or nil.
Validation of kind-specific fields is performed by the public readers."
(when (and (consp condition) (symbolp (car condition))
(proper-list-p (cdr condition)) (cdr condition))
(let ((trailer (car (last (cdr condition)))))
(when (and (proper-list-p trailer)
(= (length trailer) 2)
(eq (car trailer) :etaf-condition-trailer/v1)
(proper-list-p (cadr trailer)))
(cadr trailer)))))
(defun etaf-retirement--valid-payload-p (payload keys kind)
"Return non-nil when PAYLOAD exactly matches KEYS and has KIND metadata."
(and (= (length payload) (* 2 (length keys)))
(equal (cl-loop for (key _value) on payload by #'cddr collect key)
keys)
(eq (plist-get payload :kind) kind)
(eq (plist-get payload :committed-p) t)
(integerp (plist-get payload :operation-id))
(>= (plist-get payload :operation-id) 0)
(plist-get payload :outcome-id)
(integerp (plist-get payload :generation-id))
(>= (plist-get payload :generation-id) 0)
(integerp (plist-get payload :revision))
(>= (plist-get payload :revision) 0)
(integerp (plist-get payload :diagnostic-journal-id))
(> (plist-get payload :diagnostic-journal-id) 0)))
(defun etaf-condition-postcommit-info (condition)
"Return validated postcommit payload from CONDITION, or nil."
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
(when (and payload
(etaf-retirement--valid-payload-p
payload etaf-retirement--condition-payload-keys 'postcommit))
(copy-tree payload))))
(defun etaf-data-condition-projection-info (condition)
"Return validated v1 Data projection payload from CONDITION, or nil.
The reader only recognizes the final datum, preserving arbitrary business
data and earlier lookalike sentinels."
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
(when (and payload
(etaf-retirement--valid-payload-p
payload etaf-retirement--projection-payload-keys 'projection)
(memq (plist-get payload :external-commit-certainty)
'(committed external-unknown rolled-back))
(plist-get payload :reconciliation-token)
(plist-get payload :projection-token))
(copy-tree payload))))
(defun etaf-retirement-resignal (condition journal)
"Re-signal original CONDITION with JOURNAL's committed trailer appended."
(unless (and (consp condition) (symbolp (car condition)))
(signal 'wrong-type-argument (list 'error-condition condition)))
(if (etaf-condition-postcommit-info condition)
(signal (car condition) (cdr condition))
(signal (car condition)
(append (copy-tree (cdr condition))
(list (etaf-retirement-condition-trailer journal))))))
(provide 'etaf-retirement)
;;; etaf-retirement.el ends here

File diff suppressed because it is too large Load Diff

767
etaf-scheduler.el Normal file
View File

@ -0,0 +1,767 @@
;;; etaf-scheduler.el --- Explicit reactive dispatcher contexts -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Owns ETAF's cross-source dispatch queues. Contexts isolate FIFO and dedupe
;; authority, while a short-lived projection coordinates fan-out across every
;; context touched by one logical reactive publication.
;;; Code:
(require 'cl-lib)
(define-error 'etaf-scheduler-error "Invalid ETAF scheduler operation")
(defgroup etaf-scheduler nil
"Explicit ETAF reactive dispatcher contexts."
:group 'applications
:prefix "etaf-scheduler-")
(defcustom etaf-scheduler-default-step-budget 128
"Maximum dispatcher turns one context may run in one projection."
:type 'positive-integer
:group 'etaf-scheduler)
(defvar etaf-scheduler--context-id-counter 0)
(defvar etaf-scheduler--projection-id-counter 0)
(cl-defstruct
(etaf-scheduler-context
(:constructor etaf-scheduler-context--create))
"Mutable queues and diagnostics for one isolated dispatcher."
id name
source-queue source-queue-tail source-set
deferred-source-queue deferred-source-queue-tail deferred-source-set
delivered-source-set
runtime-queue runtime-queue-tail runtime-set
effect-set
(active-turn-id 0)
(projection-epoch 0)
(completed-projection-epoch 0)
(depth 0)
(event-depth 0)
(busy-depth 0)
phase
fixed-point-step-budget
fault-state diagnostics
(source-enqueue-count 0)
(source-dedupe-count 0)
(source-delivery-count 0)
(subscriber-visit-count 0)
(effect-claim-count 0)
(effect-evaluation-count 0)
(runtime-enqueue-count 0)
(runtime-dedupe-count 0)
(runtime-execution-count 0)
(stale-route-drop-count 0)
(projection-fault-count 0)
(turn-count 0))
(cl-defstruct
(etaf-scheduler--projection
(:constructor etaf-scheduler--projection-create))
"One cross-context reactive projection."
id all-contexts all-context-set context-before finalizers
completion-observers)
(cl-defun etaf-scheduler-context-create (&key name fixed-point-step-budget)
"Create an isolated scheduler context named NAME.
FIXED-POINT-STEP-BUDGET is optional diagnostic metadata for its owner."
(when (and fixed-point-step-budget
(not (and (integerp fixed-point-step-budget)
(> fixed-point-step-budget 0))))
(signal 'etaf-scheduler-error
(list :invalid-fixed-point-step-budget fixed-point-step-budget)))
(etaf-scheduler-context--create
:id (cl-incf etaf-scheduler--context-id-counter)
:name name
:source-set (make-hash-table :test #'eq)
:deferred-source-set (make-hash-table :test #'eq)
:delivered-source-set (make-hash-table :test #'eq)
:runtime-set (make-hash-table :test #'eq)
:effect-set (make-hash-table :test #'eq)
:fixed-point-step-budget
(or fixed-point-step-budget etaf-scheduler-default-step-budget)))
(defvar etaf-scheduler-default-context
(etaf-scheduler-context-create :name 'default)
"Default scheduler context used by the compatibility facade.")
(defvar etaf--scheduler-context nil
"Dynamically active scheduler context, or nil for the default context.")
(defvar etaf-scheduler--active-projection nil
"Dynamically active cross-context projection.")
(defvar etaf-scheduler-projection-observer nil
"Optional function receiving each completed projection summary.")
(defun etaf-scheduler-current-context ()
"Return the dynamically active scheduler context or the default context."
(or etaf--scheduler-context etaf-scheduler-default-context))
(defun etaf-scheduler-context-resolve (context)
"Return validated CONTEXT, defaulting nil to the current context."
(setq context (or context (etaf-scheduler-current-context)))
(unless (etaf-scheduler-context-p context)
(signal 'wrong-type-argument
(list 'etaf-scheduler-context-p context)))
context)
(defun etaf-scheduler-call-with-context (context function)
"Call FUNCTION with CONTEXT as the active scheduler context."
(setq context (etaf-scheduler-context-resolve context))
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(cl-incf (etaf-scheduler-context-depth context))
(let ((etaf--scheduler-context context))
(unwind-protect
(funcall function)
(setf (etaf-scheduler-context-depth context)
(max 0 (1- (etaf-scheduler-context-depth context)))))))
(defun etaf-scheduler-context-event-begin (context)
"Increment CONTEXT's logical event nesting depth."
(setq context (etaf-scheduler-context-resolve context))
(cl-incf (etaf-scheduler-context-event-depth context))
context)
(defun etaf-scheduler-context-event-end (context)
"Decrement CONTEXT's logical event nesting depth."
(setq context (etaf-scheduler-context-resolve context))
(setf (etaf-scheduler-context-event-depth context)
(max 0 (1- (etaf-scheduler-context-event-depth context))))
context)
(defun etaf-scheduler--append-context (projection context)
"Register CONTEXT with PROJECTION once."
(unless (gethash context
(etaf-scheduler--projection-all-context-set projection))
(puthash context t
(etaf-scheduler--projection-all-context-set projection))
(puthash context (etaf-scheduler-context-metrics context)
(etaf-scheduler--projection-context-before projection))
(push context (etaf-scheduler--projection-all-contexts projection))))
(defun etaf-scheduler--append-source (context source)
"Append SOURCE to CONTEXT's FIFO in constant time."
(let ((cell (list source)))
(if (etaf-scheduler-context-source-queue-tail context)
(setcdr (etaf-scheduler-context-source-queue-tail context) cell)
(setf (etaf-scheduler-context-source-queue context) cell))
(setf (etaf-scheduler-context-source-queue-tail context) cell)))
(defun etaf-scheduler--append-runtime (context runtime)
"Append RUNTIME to CONTEXT's FIFO in constant time."
(let ((cell (list runtime)))
(if (etaf-scheduler-context-runtime-queue-tail context)
(setcdr (etaf-scheduler-context-runtime-queue-tail context) cell)
(setf (etaf-scheduler-context-runtime-queue context) cell))
(setf (etaf-scheduler-context-runtime-queue-tail context) cell)))
(defun etaf-scheduler--append-deferred-source (context source)
"Append SOURCE to CONTEXT's following-turn FIFO."
(let ((cell (list source)))
(if (etaf-scheduler-context-deferred-source-queue-tail context)
(setcdr
(etaf-scheduler-context-deferred-source-queue-tail context) cell)
(setf (etaf-scheduler-context-deferred-source-queue context) cell))
(setf (etaf-scheduler-context-deferred-source-queue-tail context) cell)))
(defun etaf-scheduler--enqueue-source-now
(projection context source delivery)
"Enqueue SOURCE and DELIVERY in CONTEXT under PROJECTION."
(etaf-scheduler--append-context projection context)
(let ((set (etaf-scheduler-context-source-set context))
(deferred-set
(etaf-scheduler-context-deferred-source-set context)))
(cond
((or (gethash source set) (gethash source deferred-set))
(cl-incf (etaf-scheduler-context-source-dedupe-count context)))
((and (eq (etaf-scheduler-context-phase context) 'source)
(gethash source
(etaf-scheduler-context-delivered-source-set context)))
(puthash source delivery deferred-set)
(etaf-scheduler--append-deferred-source context source)
(cl-incf (etaf-scheduler-context-source-enqueue-count context)))
(t
(puthash source delivery set)
(etaf-scheduler--append-source context source)
(cl-incf (etaf-scheduler-context-source-enqueue-count context))))))
(defun etaf-scheduler--enqueue-runtime-now
(projection context runtime function)
"Enqueue RUNTIME and FUNCTION in CONTEXT under PROJECTION."
(etaf-scheduler--append-context projection context)
(let ((set (etaf-scheduler-context-runtime-set context)))
(if (gethash runtime set)
(cl-incf (etaf-scheduler-context-runtime-dedupe-count context))
(puthash runtime function set)
(etaf-scheduler--append-runtime context runtime)
(cl-incf (etaf-scheduler-context-runtime-enqueue-count context)))))
(defun etaf-scheduler-enqueue-source (context source delivery)
"Queue DELIVERY of SOURCE once in CONTEXT for the active projection.
DELIVERY receives CONTEXT, SOURCE, and the projection epoch."
(setq context (etaf-scheduler-context-resolve context))
(unless (functionp delivery)
(signal 'wrong-type-argument (list 'functionp delivery)))
(if etaf-scheduler--active-projection
(etaf-scheduler--enqueue-source-now
etaf-scheduler--active-projection context source delivery)
(etaf-scheduler-call-with-projection
(lambda ()
(etaf-scheduler--enqueue-source-now
etaf-scheduler--active-projection context source delivery))))
source)
(defun etaf-scheduler-enqueue-runtime (context runtime function)
"Queue FUNCTION once for RUNTIME in CONTEXT after source delivery."
(setq context (etaf-scheduler-context-resolve context))
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(if etaf-scheduler--active-projection
(etaf-scheduler--enqueue-runtime-now
etaf-scheduler--active-projection context runtime function)
(etaf-scheduler-call-with-projection
(lambda ()
(etaf-scheduler--enqueue-runtime-now
etaf-scheduler--active-projection context runtime function))))
runtime)
(defun etaf-scheduler-claim-effect (context effect)
"Return non-nil after claiming EFFECT once in CONTEXT's projection."
(setq context (etaf-scheduler-context-resolve context))
(unless (gethash effect (etaf-scheduler-context-effect-set context))
(puthash effect t (etaf-scheduler-context-effect-set context))
(cl-incf (etaf-scheduler-context-effect-claim-count context))
t))
(defun etaf-scheduler-record-subscriber-visit (context)
"Record one subscriber visit in scheduler CONTEXT."
(setq context (etaf-scheduler-context-resolve context))
(when etaf-scheduler--active-projection
(etaf-scheduler--append-context
etaf-scheduler--active-projection context))
(cl-incf (etaf-scheduler-context-subscriber-visit-count context)))
(defun etaf-scheduler-record-effect-evaluation (context)
"Record one reactive effect evaluation in scheduler CONTEXT."
(setq context (etaf-scheduler-context-resolve context))
(when etaf-scheduler--active-projection
(etaf-scheduler--append-context
etaf-scheduler--active-projection context))
(cl-incf (etaf-scheduler-context-effect-evaluation-count context)))
(defun etaf-scheduler-record-stale-route-drop (context)
"Record one stale route filtered before fan-out in CONTEXT."
(setq context (etaf-scheduler-context-resolve context))
(when etaf-scheduler--active-projection
(etaf-scheduler--append-context
etaf-scheduler--active-projection context))
(cl-incf (etaf-scheduler-context-stale-route-drop-count context)))
(defun etaf-scheduler-defer-finalizer (function)
"Run FUNCTION after the active projection drains, or immediately if idle."
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(if etaf-scheduler--active-projection
(push function
(etaf-scheduler--projection-finalizers
etaf-scheduler--active-projection))
(funcall function))
function)
(defun etaf-scheduler-projection-active-p ()
"Return non-nil while a scheduler projection is active."
(not (null etaf-scheduler--active-projection)))
(defun etaf-scheduler-on-projection-complete (function)
"Call FUNCTION with the active projection summary when it completes."
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(if etaf-scheduler--active-projection
(push function
(etaf-scheduler--projection-completion-observers
etaf-scheduler--active-projection))
(funcall function nil))
function)
(defun etaf-scheduler--reset-pending (context)
"Discard CONTEXT's pending queues and dedupe membership."
(setf (etaf-scheduler-context-source-queue context) nil
(etaf-scheduler-context-source-queue-tail context) nil
(etaf-scheduler-context-deferred-source-queue context) nil
(etaf-scheduler-context-deferred-source-queue-tail context) nil
(etaf-scheduler-context-runtime-queue context) nil
(etaf-scheduler-context-runtime-queue-tail context) nil
(etaf-scheduler-context-phase context) nil)
(clrhash (etaf-scheduler-context-source-set context))
(clrhash (etaf-scheduler-context-deferred-source-set context))
(clrhash (etaf-scheduler-context-delivered-source-set context))
(clrhash (etaf-scheduler-context-runtime-set context))
context)
(defun etaf-scheduler--promote-deferred-sources (context)
"Move CONTEXT's deferred sources into its following-turn FIFO."
(let ((deferred (etaf-scheduler-context-deferred-source-queue context))
(deferred-set
(etaf-scheduler-context-deferred-source-set context))
(source-set (etaf-scheduler-context-source-set context)))
(setf (etaf-scheduler-context-deferred-source-queue context) nil
(etaf-scheduler-context-deferred-source-queue-tail context) nil)
(dolist (source deferred)
(let ((delivery (gethash source deferred-set)))
(remhash source deferred-set)
(unless (gethash source source-set)
(puthash source delivery source-set)
(etaf-scheduler--append-source context source)))))
context)
(defun etaf-scheduler--projection-contexts (projection)
"Return PROJECTION contexts in first-touch order."
(nreverse
(copy-sequence (etaf-scheduler--projection-all-contexts projection))))
(defun etaf-scheduler--projection-source-work-p (projection)
"Return non-nil when PROJECTION has pending source work."
(cl-some #'etaf-scheduler-context-source-queue
(etaf-scheduler--projection-contexts projection)))
(defun etaf-scheduler--projection-work-p (projection)
"Return non-nil when PROJECTION has pending source or Runtime work."
(cl-some
(lambda (context)
(or (etaf-scheduler-context-source-queue context)
(etaf-scheduler-context-runtime-queue context)))
(etaf-scheduler--projection-contexts projection)))
(defun etaf-scheduler--mark-turn
(context projection-id marked-contexts context-steps)
"Mark CONTEXT for PROJECTION-ID in MARKED-CONTEXTS and CONTEXT-STEPS."
(unless (gethash context marked-contexts)
(let* ((steps (1+ (gethash context context-steps 0)))
(budget (etaf-scheduler-context-fixed-point-step-budget context)))
(when (> steps budget)
(signal 'etaf-scheduler-error
(list :kind 'fixed-point-step-budget
:context-id (etaf-scheduler-context-id context)
:projection-id projection-id
:steps steps :budget budget)))
(puthash context steps context-steps))
(puthash context t marked-contexts)
(setf (etaf-scheduler-context-projection-epoch context) projection-id)
(clrhash (etaf-scheduler-context-delivered-source-set context))
(clrhash (etaf-scheduler-context-effect-set context))
(cl-incf (etaf-scheduler-context-active-turn-id context))
(cl-incf (etaf-scheduler-context-turn-count context))))
(defun etaf-scheduler--call-context-work (context function)
"Call FUNCTION as busy work owned by scheduler CONTEXT."
(cl-incf (etaf-scheduler-context-busy-depth context))
(unwind-protect
(etaf-scheduler-call-with-context context function)
(setf (etaf-scheduler-context-busy-depth context)
(max 0 (1- (etaf-scheduler-context-busy-depth context))))))
(defun etaf-scheduler--drain-context-sources (context projection-id)
"Drain one CONTEXT source turn and return its first condition.
PROJECTION-ID identifies the bounded projection owning the detached turn."
(let ((turn (etaf-scheduler-context-source-queue context)) first-condition)
;; New sources discovered by TURN belong to the next bounded scheduler
;; turn. Detaching the current FIFO prevents a chain of distinct source
;; identities from monopolizing one unbudgeted drain.
(setf (etaf-scheduler-context-source-queue context) nil
(etaf-scheduler-context-source-queue-tail context) nil
(etaf-scheduler-context-phase context) 'source)
(etaf-scheduler--call-context-work
context
(lambda ()
(dolist (source turn)
(let ((delivery
(gethash source
(etaf-scheduler-context-source-set context))))
(remhash source (etaf-scheduler-context-source-set context))
(puthash source t
(etaf-scheduler-context-delivered-source-set context))
(cl-incf (etaf-scheduler-context-source-delivery-count context))
(when delivery
(condition-case condition
(funcall delivery context source projection-id)
((error quit)
(unless first-condition
(setq first-condition condition)))))))))
first-condition))
(defun etaf-scheduler--detach-runtime-turns (projection)
"Detach and return PROJECTION's Runtime queues in context order."
(let (turns)
(dolist (context (etaf-scheduler--projection-contexts projection))
(when-let* ((turn (etaf-scheduler-context-runtime-queue context)))
(setf (etaf-scheduler-context-runtime-queue context) nil
(etaf-scheduler-context-runtime-queue-tail context) nil)
(push (cons context turn) turns)))
(nreverse turns)))
(defun etaf-scheduler--run-runtime-turn (context turn)
"Run detached Runtime TURN in CONTEXT and return its first condition."
(let (first-condition)
(setf (etaf-scheduler-context-phase context) 'runtime)
(etaf-scheduler--call-context-work
context
(lambda ()
(dolist (runtime turn)
(let ((function
(gethash runtime
(etaf-scheduler-context-runtime-set context))))
(remhash runtime (etaf-scheduler-context-runtime-set context))
(when function
(cl-incf (etaf-scheduler-context-runtime-execution-count context))
(condition-case condition
(funcall function)
((error quit)
(unless first-condition
(setq first-condition condition)))))))))
first-condition))
(defun etaf-scheduler--record-fault
(context projection-id condition &optional phase turn-id)
"Record CONTEXT failure CONDITION for PROJECTION-ID.
PHASE is optional diagnostic metadata. TURN-ID, when non-nil, preserves the
turn where a contained condition originated before delayed quarantine."
(setf (etaf-scheduler-context-fault-state context) (copy-tree condition))
(cl-incf (etaf-scheduler-context-projection-fault-count context))
(push (append (list :projection-epoch projection-id
:turn-id
(or turn-id
(etaf-scheduler-context-active-turn-id context)))
(and phase (list :phase phase))
(list :condition (copy-tree condition)))
(etaf-scheduler-context-diagnostics context))
(when (> (length (etaf-scheduler-context-diagnostics context)) 64)
(setcdr (nthcdr 63 (etaf-scheduler-context-diagnostics context)) nil))
condition)
(defun etaf-scheduler-record-route-authority-fault (context condition)
"Record contained Host route authority CONDITION in scheduler CONTEXT."
(setq context (etaf-scheduler-context-resolve context))
(unless (consp condition)
(signal 'wrong-type-argument (list 'consp condition)))
(when etaf-scheduler--active-projection
(etaf-scheduler--append-context etaf-scheduler--active-projection context))
(etaf-scheduler--record-fault
context
(if etaf-scheduler--active-projection
(etaf-scheduler--projection-id etaf-scheduler--active-projection)
(etaf-scheduler-context-projection-epoch context))
condition 'route-authority))
(defun etaf-scheduler--drain-projection (projection)
"Drain PROJECTION source-first and re-signal its first context fault."
(let ((projection-id (etaf-scheduler--projection-id projection))
(failed-contexts (make-hash-table :test #'eq))
(contained-context-conditions (make-hash-table :test #'eq))
(context-steps (make-hash-table :test #'eq))
first-condition fatal-condition)
(while (etaf-scheduler--projection-work-p projection)
(let ((marked-contexts (make-hash-table :test #'eq)))
;; All source propagation across every context settles before any
;; Runtime can observe and publish the resulting reactive state.
(while (etaf-scheduler--projection-source-work-p projection)
;; Each source wave is one bounded turn. A wave snapshots every
;; context's current FIFO, so newly discovered distinct sources
;; consume another step and peers get an opportunity to run.
(setq marked-contexts (make-hash-table :test #'eq))
(dolist (context (etaf-scheduler--projection-contexts projection))
(cond
((gethash context failed-contexts)
(etaf-scheduler--reset-pending context))
((etaf-scheduler-context-source-queue context)
(condition-case condition
(progn
(etaf-scheduler--mark-turn
context projection-id marked-contexts context-steps)
(when-let* ((source-condition
(etaf-scheduler--drain-context-sources
context projection-id)))
(unless (gethash context contained-context-conditions)
(puthash context
(list
:condition source-condition
:turn-id
(etaf-scheduler-context-active-turn-id
context))
contained-context-conditions))
(unless first-condition
(setq first-condition source-condition))))
((error quit)
(puthash context t failed-contexts)
(unless fatal-condition (setq fatal-condition condition))
(etaf-scheduler--record-fault
context projection-id condition)
(etaf-scheduler--reset-pending context)))))))
;; Detach every context's Runtime queue before callbacks run. A write
;; from one callback therefore belongs to the following scheduler turn.
(dolist (entry (etaf-scheduler--detach-runtime-turns projection))
(let ((context (car entry)) (turn (cdr entry)))
(unless (gethash context failed-contexts)
(condition-case condition
(progn
(etaf-scheduler--mark-turn
context projection-id marked-contexts context-steps)
(when-let* ((runtime-condition
(etaf-scheduler--run-runtime-turn
context turn)))
(unless (gethash context contained-context-conditions)
(puthash context
(list
:condition runtime-condition
:turn-id
(etaf-scheduler-context-active-turn-id
context))
contained-context-conditions))
(unless first-condition
(setq first-condition runtime-condition))))
((error quit)
(puthash context t failed-contexts)
(unless fatal-condition (setq fatal-condition condition))
(etaf-scheduler--record-fault
context projection-id condition)
(etaf-scheduler--reset-pending context))))))
;; Item-level source/subscriber/Runtime faults are reported only after
;; the detached Runtime turn has consumed work enqueued by successful
;; tail callbacks. Scheduler-control faults above still reset at once.
(dolist (context (etaf-scheduler--projection-contexts projection))
(when-let* ((contained
(gethash context contained-context-conditions))
(condition (plist-get contained :condition)))
(unless (gethash context failed-contexts)
(puthash context t failed-contexts)
(etaf-scheduler--record-fault
context projection-id condition nil
(plist-get contained :turn-id))
(etaf-scheduler--reset-pending context))))
(dolist (context (etaf-scheduler--projection-contexts projection))
(setf (etaf-scheduler-context-phase context) nil)
(unless (gethash context failed-contexts)
(etaf-scheduler--promote-deferred-sources context)))))
(dolist (context (etaf-scheduler--projection-contexts projection))
(unless (gethash context failed-contexts)
(setf (etaf-scheduler-context-completed-projection-epoch context)
projection-id
(etaf-scheduler-context-fault-state context) nil)))
(when-let* ((condition (or fatal-condition first-condition)))
(signal (car condition) (cdr condition)))))
(defun etaf-scheduler--finish-projection (projection)
"Restore PROJECTION invariants and return contained finalizer errors."
(let (errors)
(dolist (context (etaf-scheduler--projection-all-contexts projection))
(when (or (etaf-scheduler-context-source-queue context)
(etaf-scheduler-context-deferred-source-queue context)
(etaf-scheduler-context-runtime-queue context))
(etaf-scheduler--reset-pending context))
(setf (etaf-scheduler-context-phase context) nil)
(clrhash (etaf-scheduler-context-delivered-source-set context))
(clrhash (etaf-scheduler-context-effect-set context)))
(let ((etaf-scheduler--active-projection nil))
(dolist (finalizer
(nreverse (etaf-scheduler--projection-finalizers projection)))
(condition-case condition
(funcall finalizer)
((error quit) (push condition errors)))))
(setf (etaf-scheduler--projection-finalizers projection) nil)
(nreverse errors)))
(defun etaf-scheduler--notify-projection-complete (projection summary)
"Notify PROJECTION observers with detached SUMMARY, containing failures."
(let ((etaf-scheduler--active-projection nil)
errors)
(when (functionp etaf-scheduler-projection-observer)
(condition-case condition
(funcall etaf-scheduler-projection-observer (copy-tree summary))
((error quit) (push condition errors))))
(dolist
(observer
(nreverse
(etaf-scheduler--projection-completion-observers projection)))
(condition-case condition
(funcall observer (copy-tree summary))
((error quit) (push condition errors))))
(setf (etaf-scheduler--projection-completion-observers projection) nil)
(nreverse errors)))
(defun etaf-scheduler--metric-delta (before after key)
"Return non-negative KEY delta between BEFORE and AFTER metric plists."
(max 0 (- (or (plist-get after key) 0)
(or (plist-get before key) 0))))
(defun etaf-scheduler--projection-summary (projection condition)
"Return detached PROJECTION metrics with optional failure CONDITION."
(let ((before-table
(etaf-scheduler--projection-context-before projection))
context-summaries
(source-enqueues 0) (source-dedupes 0) (source-deliveries 0)
(subscriber-visits 0) (effect-claims 0) (effect-evaluations 0)
(runtime-enqueues 0) (runtime-dedupes 0) (runtime-executions 0)
(stale-route-drops 0) (turns 0) (faults 0))
(dolist (context (etaf-scheduler--projection-contexts projection))
(let* ((before (gethash context before-table))
(after (etaf-scheduler-context-metrics context))
(entry
(list
:context-id (etaf-scheduler-context-id context)
:source-enqueues
(etaf-scheduler--metric-delta
before after :source-enqueues)
:source-dedupes
(etaf-scheduler--metric-delta before after :source-dedupes)
:source-deliveries
(etaf-scheduler--metric-delta
before after :source-deliveries)
:subscriber-visits
(etaf-scheduler--metric-delta
before after :subscriber-visits)
:effect-claims
(etaf-scheduler--metric-delta before after :effect-claims)
:effect-evaluations
(etaf-scheduler--metric-delta
before after :effect-evaluations)
:runtime-enqueues
(etaf-scheduler--metric-delta before after :runtime-enqueues)
:runtime-dedupes
(etaf-scheduler--metric-delta before after :runtime-dedupes)
:runtime-executions
(etaf-scheduler--metric-delta
before after :runtime-executions)
:stale-route-drops
(etaf-scheduler--metric-delta
before after :stale-route-drops)
:turns (etaf-scheduler--metric-delta before after :turn-count)
:faults
(etaf-scheduler--metric-delta before after :fault-count))))
(cl-incf source-enqueues (plist-get entry :source-enqueues))
(cl-incf source-dedupes (plist-get entry :source-dedupes))
(cl-incf source-deliveries (plist-get entry :source-deliveries))
(cl-incf subscriber-visits (plist-get entry :subscriber-visits))
(cl-incf effect-claims (plist-get entry :effect-claims))
(cl-incf effect-evaluations (plist-get entry :effect-evaluations))
(cl-incf runtime-enqueues (plist-get entry :runtime-enqueues))
(cl-incf runtime-dedupes (plist-get entry :runtime-dedupes))
(cl-incf runtime-executions (plist-get entry :runtime-executions))
(cl-incf stale-route-drops (plist-get entry :stale-route-drops))
(cl-incf turns (plist-get entry :turns))
(cl-incf faults (plist-get entry :faults))
(push entry context-summaries)))
(list :projection-id (etaf-scheduler--projection-id projection)
:completed-p (null condition)
:context-count (length context-summaries)
:source-enqueues source-enqueues
:source-dedupes source-dedupes
:source-deliveries source-deliveries
:subscriber-visits subscriber-visits
:effect-claims effect-claims
:effect-evaluations effect-evaluations
:runtime-enqueues runtime-enqueues
:runtime-dedupes runtime-dedupes
:runtime-executions runtime-executions
:stale-route-drops stale-route-drops
:turns turns :faults faults
:condition (and condition (copy-tree condition))
:contexts (nreverse context-summaries))))
(defun etaf-scheduler-call-with-projection (function)
"Call FUNCTION and drain all contexts touched by its reactive writes.
Nested calls join the active projection. If FUNCTION signals after changing
state, queued notifications still drain before the original condition is
re-signaled."
(unless (functionp function)
(signal 'wrong-type-argument (list 'functionp function)))
(if etaf-scheduler--active-projection
(funcall function)
(let* ((projection
(etaf-scheduler--projection-create
:id (cl-incf etaf-scheduler--projection-id-counter)
:all-context-set (make-hash-table :test #'eq)
:context-before (make-hash-table :test #'eq)))
result primary-condition drain-condition summary finalizer-errors)
(let ((etaf-scheduler--active-projection projection))
(unwind-protect
(progn
(condition-case condition
(setq result (funcall function))
((error quit) (setq primary-condition condition)))
(condition-case condition
(etaf-scheduler--drain-projection projection)
((error quit) (setq drain-condition condition)))
(setq summary
(etaf-scheduler--projection-summary
projection drain-condition)))
(setq finalizer-errors
(etaf-scheduler--finish-projection projection))
(when finalizer-errors
(setq summary
(plist-put summary :completed-p nil)
summary
(plist-put summary :finalizer-errors
(copy-tree finalizer-errors))))
(etaf-scheduler--notify-projection-complete
projection summary)))
(cond
(primary-condition
(signal (car primary-condition) (cdr primary-condition)))
(drain-condition
(signal (car drain-condition) (cdr drain-condition)))
(t result)))))
(defun etaf-scheduler-context-idle-p (context)
"Return non-nil when CONTEXT has no queued or running dispatcher work."
(setq context (etaf-scheduler-context-resolve context))
(and (null (etaf-scheduler-context-source-queue context))
(null (etaf-scheduler-context-deferred-source-queue context))
(null (etaf-scheduler-context-runtime-queue context))
(zerop (hash-table-count
(etaf-scheduler-context-source-set context)))
(zerop (hash-table-count
(etaf-scheduler-context-runtime-set context)))
(zerop (etaf-scheduler-context-busy-depth context))))
(defun etaf-scheduler-context-metrics (context)
"Return a detached metrics plist for scheduler CONTEXT."
(setq context (etaf-scheduler-context-resolve context))
(list :context-id (etaf-scheduler-context-id context)
:projection-epoch (etaf-scheduler-context-projection-epoch context)
:completed-projection-epoch
(etaf-scheduler-context-completed-projection-epoch context)
:active-turn-id (etaf-scheduler-context-active-turn-id context)
:turn-count (etaf-scheduler-context-turn-count context)
:source-enqueues
(etaf-scheduler-context-source-enqueue-count context)
:source-dedupes
(etaf-scheduler-context-source-dedupe-count context)
:source-deliveries
(etaf-scheduler-context-source-delivery-count context)
:subscriber-visits
(etaf-scheduler-context-subscriber-visit-count context)
:effect-claims
(etaf-scheduler-context-effect-claim-count context)
:effect-evaluations
(etaf-scheduler-context-effect-evaluation-count context)
:runtime-enqueues
(etaf-scheduler-context-runtime-enqueue-count context)
:runtime-dedupes
(etaf-scheduler-context-runtime-dedupe-count context)
:runtime-executions
(etaf-scheduler-context-runtime-execution-count context)
:stale-route-drops
(etaf-scheduler-context-stale-route-drop-count context)
:fault-count
(etaf-scheduler-context-projection-fault-count context)
:fault-state
(copy-tree (etaf-scheduler-context-fault-state context))))
(provide 'etaf-scheduler)
;;; etaf-scheduler.el ends here

View File

@ -12,6 +12,7 @@
;;; Code:
(require 'cl-lib)
(require 'ebox-style)
(define-error 'etaf-view-error "Invalid ETAF View")
(define-error 'etaf-view-syntax-error "Invalid ETAF View syntax"
@ -29,7 +30,8 @@
(cl-defstruct (etaf--expr
(:constructor etaf--expr-create))
"Internal executable child expression."
"Internal executable interpolation or compiler-owned structural program."
(kind 'interpolation)
token
thunk
range-snapshot
@ -50,6 +52,7 @@
"Internal Component invocation retained until rendering."
spec
props
attrs
slots)
(cl-defstruct (etaf--slot-input
@ -65,15 +68,8 @@
token
fallback)
(cl-defstruct (etaf--raw-ebox
(:constructor etaf--raw-ebox-create))
"Explicit escape carrying an already-built public Ebox node."
token
thunk
key-thunk)
(defconst etaf--host-names
'(text fragment container row column stack flex grid spacer)
'(text box fragment row column flex grid)
"Minimal unstyled Hosts implemented by ETAF core.
Product Components such as Button belong to `etaf-ui'; they are not added to
@ -82,6 +78,34 @@ this list merely to make a demo convenient.")
(defconst etaf--host-marker 'etaf--host
"Value stored in the View registry for a built-in Host.")
(defconst etaf--directive-properties '(:if :else-if :else :for)
"Compiler-owned DSL properties rejected by ordinary node construction.")
(defconst etaf--semantic-props
'(:class :id :role :disabled :tab-index :ref :use)
"ETAF Host metadata outside the Ebox style schema.")
(defun etaf--aria-property-p (property)
"Return non-nil when PROPERTY is in the ETAF aria namespace."
(and (keywordp property)
(string-prefix-p ":aria-" (symbol-name property))))
(defun etaf--event-property-p (property)
"Return non-nil when PROPERTY is an ETAF event callback property."
(and (keywordp property)
(string-prefix-p ":on-" (symbol-name property))))
(defun etaf--semantic-property-p (property)
"Return non-nil when PROPERTY belongs to ETAF Runtime metadata."
(or (memq property etaf--semantic-props)
(etaf--aria-property-p property)
(etaf--event-property-p property)))
(defun etaf--host-attribute-p (property)
"Return non-nil when PROPERTY belongs to the shared Host attribute domain."
(or (ebox-style-schema-id property)
(etaf--semantic-property-p property)))
(defconst etaf--ordinary-elisp-heads
'(and or not if when unless cond case pcase
let let* letrec letrec* prog prog1 prog2 progn
@ -112,6 +136,9 @@ disposing the old Runtime.")
(defvar etaf--current-component-instance nil
"Dynamic Component instance currently being evaluated.")
(defvar etaf--compiling-component-props nil
"Component prop names visible to the current DSL macro expansion.")
(defun etaf--syntax-error (format-string &rest arguments)
"Signal a View syntax error formatted from FORMAT-STRING and ARGUMENTS."
(signal 'etaf-view-syntax-error
@ -126,25 +153,8 @@ disposing the old Runtime.")
"Return the property keyword corresponding to symbol NAME."
(intern (concat ":" (symbol-name name))))
(defun etaf--component-alias (name)
"Return the public View alias for canonical Component NAME, or nil.
Canonical names may carry the `etaf-' package prefix. The prefix is omitted
in View syntax unless doing so would collide with an Elisp function, special
form, or core Host. A collision receives a semantic `-view' alias."
(when (and (symbolp name)
(string-prefix-p "etaf-" (symbol-name name)))
(let* ((suffix (substring (symbol-name name) (length "etaf-")))
(candidate (intern suffix)))
(cond
((or (memq candidate etaf--host-names)
(special-form-p candidate)
(fboundp candidate))
(intern (concat suffix "-view")))
(t candidate)))))
(defun etaf--register-component (name spec)
"Register Component SPEC under canonical NAME and its public alias."
"Register Component SPEC under exact registry NAME."
(unless (and (symbolp name) (etaf--component-spec-p spec))
(signal 'wrong-type-argument (list 'etaf--component-spec-p spec)))
(let ((existing (gethash name etaf--view-registry)))
@ -157,34 +167,14 @@ form, or core Host. A collision receives a semantic `-view' alias."
(etaf--component-error
"Component %S is already registered" name)))
(puthash name spec etaf--view-registry)
(when-let* ((alias (etaf--component-alias name)))
(let ((existing (gethash alias etaf--view-registry)))
(when (and existing (not (eq existing spec))
(not etaf--allow-component-redefinition))
(etaf--component-error
"Component alias %S is already registered" alias)))
(puthash alias spec etaf--view-registry))
(when (fboundp 'etaf-compiler-note-registry-change)
(etaf-compiler-note-registry-change))
spec)
(defun etaf--register-core-hosts ()
"Register the core Host names and explicit prefixed spellings."
"Register the exact core Host names."
(dolist (name etaf--host-names)
(puthash name etaf--host-marker etaf--view-registry)
(puthash (intern (concat "etaf-" (symbol-name name)))
etaf--host-marker
etaf--view-registry)))
(defun etaf--canonical-host-name (name)
"Return the unprefixed renderer name for Host NAME."
(if (and (symbolp name)
(string-prefix-p "etaf-" (symbol-name name)))
(let ((short-name (intern (substring (symbol-name name) 5))))
(if (memq short-name etaf--host-names)
short-name
name))
name))
(puthash name etaf--host-marker etaf--view-registry)))
(etaf--register-core-hosts)
@ -224,6 +214,191 @@ form, or core Host. A collision receives a semantic `-view' alias."
(push (etaf--resolve-property-value (pop tail)) copy))
(nreverse copy)))
(defun etaf--property-domain-key (property)
"Return PROPERTY's canonical Host-domain key."
(or (ebox-style-canonical-name property) property))
(defun etaf--plist-set (props key value)
"Return PROPS with KEY set to VALUE while preserving source order."
(if (plist-member props key)
(let ((copy (copy-sequence props)))
(plist-put copy key value)
copy)
(append props (list key value))))
(defun etaf--plist-remove-domain (props property)
"Return PROPS without any alias in PROPERTY's canonical domain."
(let ((domain (etaf--property-domain-key property)))
(cl-loop for (key value) on props by #'cddr
unless (eq (etaf--property-domain-key key) domain)
append (list key value))))
(defun etaf--class-tokens (value)
"Return normalized class tokens from resolved VALUE."
(cond
((null value) nil)
((stringp value) (split-string value "[[:space:]]+" t))
((symbolp value) (list (symbol-name value)))
((proper-list-p value)
(cl-mapcan #'etaf--class-tokens value))
(t
(etaf--component-error "Invalid class value: %S" value))))
(defun etaf--merge-class-values (root-value caller-value)
"Return stable union of ROOT-VALUE and CALLER-VALUE class tokens."
(let (seen result)
(dolist (token (append (etaf--class-tokens root-value)
(etaf--class-tokens caller-value)))
(unless (member token seen)
(push token seen)
(push token result)))
(nreverse result)))
(defun etaf--merge-class-input (root-value caller-value)
"Return a class value merging possibly lazy ROOT-VALUE and CALLER-VALUE."
(etaf--merge-class-values
(etaf--resolve-property-value root-value)
(etaf--resolve-property-value caller-value)))
(defun etaf--compose-event-callbacks (primary secondary)
"Compose PRIMARY then SECONDARY, preserving the primary return value.
An error stops the chain. This shared value operation lives with View
composition so pure render and Runtime Behavior use the same contract."
(dolist (callback (list primary secondary))
(unless (or (null callback) (functionp callback))
(etaf--component-error "Event callback must be a function or nil: %S"
callback)))
(cond
((null primary) secondary)
((null secondary) primary)
(t
(lambda (&rest arguments)
(prog1 (apply primary arguments)
(apply secondary arguments))))))
(defun etaf--owned-semantic-property-p (property)
"Return non-nil when fallthrough PROPERTY must preserve root semantics."
(or (eq property :role)
(and (etaf--aria-property-p property)
(not (memq property '(:aria-label :aria-description))))))
(defun etaf--merge-use-input (root-value caller-value)
"Concatenate possibly lazy ROOT-VALUE and CALLER-VALUE Behavior sources.
Runtime validates all names before installing any resources."
(let ((root (etaf--resolve-property-value root-value))
(caller (etaf--resolve-property-value caller-value)))
(append (if (proper-list-p root) root (list root))
(if (proper-list-p caller) caller (list caller)))))
(defun etaf--merge-host-attrs (props attrs &optional tag component-name)
"Merge caller ATTRS into root Host PROPS for TAG.
Non-nil visual attributes override defaults; class and Behavior sources merge.
Callbacks append, disabled combines with OR, and owned semantic conflicts
are rejected. COMPONENT-NAME labels diagnostics."
(let ((result (copy-sequence props))
(tail attrs))
(while tail
(let* ((key (pop tail))
(value (pop tail))
(style-p (not (null (ebox-style-schema-id key)))))
(when (and tag style-p
(not (ebox-style-property-accepted-p tag key)))
(etaf--component-error
"Component %S root Host %S rejects attribute %S"
component-name tag key))
(cond
((eq key :class)
(setq result
(etaf--plist-set
result :class
(etaf--merge-class-input (plist-get result :class) value))))
((etaf--event-property-p key)
(setq result
(etaf--plist-set
result key
(etaf--compose-event-callbacks
(etaf--resolve-property-value (plist-get result key))
(etaf--resolve-property-value value)))))
((eq key :use)
(setq result
(etaf--plist-set
result key (etaf--merge-use-input (plist-get result key) value))))
((eq key :disabled)
(let ((inner (etaf--resolve-property-value (plist-get result key)))
(outer (etaf--resolve-property-value value)))
(unless (and (memq inner '(nil t)) (memq outer '(nil t)))
(etaf--component-error "Component %S :disabled must be boolean"
component-name))
(setq result (etaf--plist-set result key (or inner outer)))))
(style-p
(when (etaf--resolve-property-value value)
(setq result
(append (etaf--plist-remove-domain result key)
(list key value)))))
((and (etaf--owned-semantic-property-p key)
(plist-member result key)
(not (equal (etaf--resolve-property-value (plist-get result key))
(etaf--resolve-property-value value))))
(etaf--component-error
"Component %S root Host %S owns %S; conflicting fallthrough value %S"
component-name tag key value))
((plist-member result key)
(setq result (etaf--plist-set result key value)))
(t
(setq result (append result (list key value)))))))
result))
(defun etaf--forward-component-attrs (call attrs component-name)
"Return copied root Component CALL receiving caller ATTRS.
COMPONENT-NAME identifies the forwarding owner for diagnostics."
(let* ((copy (copy-sequence call))
(spec (etaf--component-call-spec call))
(declared (mapcar #'etaf--component-prop-key
(etaf--component-spec-props spec)))
(props (copy-sequence (etaf--component-call-props call)))
(forwarded (copy-sequence (etaf--component-call-attrs call)))
(tail attrs))
(while tail
(let ((key (pop tail))
(value (pop tail)))
(if (memq key declared)
;; Consuming a declared prop must retain the inner declaration
;; and the outer subscription, and must not forward either twice.
(setq props
(etaf--merge-host-attrs props (list key value)
nil component-name))
(setq forwarded
(etaf--merge-host-attrs
forwarded (list key value) nil component-name)))))
(setf (etaf--component-call-props copy) props
(etaf--component-call-attrs copy) forwarded)
copy))
(defun etaf--apply-component-attrs (value attrs component-name)
"Apply resolved fallthrough ATTRS to COMPONENT-NAME root VALUE."
(if (null attrs)
value
(cond
((stringp value)
(etaf--view-node-create
:name 'text :props (copy-sequence attrs) :children (list value)))
((etaf--view-node-p value)
(when (eq (etaf--view-node-name value) 'fragment)
(etaf--component-error
"Component %S has multiple roots; Host attrs have no target"
component-name))
(let ((copy (copy-sequence value)))
(setf (etaf--view-node-props copy)
(etaf--merge-host-attrs
(etaf--view-node-props value) attrs
(etaf--view-node-name value) component-name))
copy))
((etaf--component-call-p value)
(etaf--forward-component-attrs value attrs component-name))
(t
(etaf--component-error
"Component %S cannot apply Host attrs to %S" component-name value)))))
(defun etaf--compile-property-value (form)
"Compile property FORM as a constant or a render-time thunk."
(if (or (null form) (numberp form) (stringp form) (characterp form)
@ -244,12 +419,11 @@ form, or core Host. A collision receives a semantic `-view' alias."
compiled))
(defun etaf--validate-key (key)
"Validate a Host identity KEY and return it."
(unless (or (null key) (symbolp key) (stringp key)
(integerp key) (floatp key))
"Validate identity KEY and return its immutable boundary value."
(unless (and key (or (symbolp key) (stringp key) (integerp key)))
(etaf--component-error
"View keys must be immutable scalar values: %S" key))
key)
"View keys must be non-nil symbols, integers, or strings: %S" key))
(if (stringp key) (copy-sequence key) key))
(defun etaf--parse-attributes-and-children (items)
"Split structural ITEMS into `(PROPS . CHILDREN)'.
@ -280,18 +454,10 @@ the generated code."
(cons (nreverse props) (nreverse children))))
(defun etaf--parse-expr-form (items)
"Return the value form from an `expr' child with ITEMS.
`expr' intentionally has one property, `:value', and no children."
(let ((parts (etaf--parse-attributes-and-children items)))
(when (cdr parts)
(etaf--syntax-error "Expr accepts :value and no children"))
(let ((props (car parts)))
(unless (and (= (length props) 2)
(eq (car props) :value))
(etaf--syntax-error
"Expr accepts exactly one attribute: :value"))
(cadr props))))
"Return the sole ordinary Elisp form from interpolation ITEMS."
(unless (= (length items) 1)
(etaf--syntax-error "Expr accepts exactly one form: (expr FORM)"))
(car items))
(defun etaf--constant-slot-name (form)
"Return the static slot symbol represented by FORM, or signal an error."
@ -350,9 +516,231 @@ belong to the anonymous `default' slot."
"Compile an `expr' form with ITEMS into an executable View value."
(let ((token (gensym "etaf-expr-site-")))
`(etaf--expr-create
:kind 'interpolation
:token ',token
:thunk (lambda () ,(etaf--parse-expr-form items)))))
(defun etaf--structural-program-p (value)
"Return non-nil when VALUE is a compiler-owned structural program."
(and (etaf--expr-p value)
(memq (etaf--expr-kind value) '(branch keyed-list))))
(defun etaf--keyed-program-snapshot (program)
"Evaluate and validate one compiler-owned keyed-list PROGRAM snapshot."
(unless (and (etaf--expr-p program)
(eq (etaf--expr-kind program) 'keyed-list)
(functionp (etaf--expr-range-snapshot program))
(functionp (etaf--expr-range-item program)))
(etaf--component-error "Invalid keyed-list program: %S" program))
(let* ((snapshot (funcall (etaf--expr-range-snapshot program)))
(items (and (proper-list-p snapshot) (plist-get snapshot :items)))
(keys (and (proper-list-p snapshot) (plist-get snapshot :keys))))
(unless (and (proper-list-p items) (proper-list-p keys)
(= (length items) (length keys)))
(etaf--component-error "Invalid keyed-list snapshot: %S" snapshot))
(let ((seen (make-hash-table :test #'equal))
validated)
(dolist (key keys)
(setq key (etaf--validate-key key))
(when (gethash key seen)
(etaf--component-error "Duplicate keyed-list key: %S" key))
(puthash key t seen)
(push key validated))
(let ((copy (copy-sequence snapshot)))
(plist-put copy :items (copy-sequence items))
(plist-put copy :keys (nreverse validated))
copy))))
(defun etaf--keyed-program-outputs (program snapshot)
"Return PROGRAM outputs for already validated keyed SNAPSHOT."
(let ((renderer (etaf--expr-range-item program))
(context (plist-get snapshot :context)))
(mapcar (lambda (item) (funcall renderer item context))
(plist-get snapshot :items))))
(defun etaf--view-form-parts (form)
"Return parsed `(TAG PROPS CHILDREN)' for directive-capable FORM."
(unless (and (consp form) (symbolp (car form))
(not (memq (car form) '(expr slot))))
(etaf--syntax-error "Directive requires a View node: %S" form))
(let ((parts (etaf--parse-attributes-and-children (cdr form))))
(list (car form) (car parts) (cdr parts))))
(defun etaf--view-directive-properties (props)
"Return directive entries present in raw PROPS."
(cl-loop for (key value) on props by #'cddr
when (memq key etaf--directive-properties)
append (list key value)))
(defun etaf--validate-directive-set (directives)
"Validate one node's raw DIRECTIVES and return them."
(let ((branch-count
(cl-count-if (lambda (key) (plist-member directives key))
'(:if :else-if :else))))
(when (> branch-count 1)
(etaf--syntax-error "A View node accepts one branch directive"))
(when (and (> branch-count 0) (plist-member directives :for))
(etaf--syntax-error "Branch directives cannot share a node with :for"))
(when (and (plist-member directives :else)
(not (eq (plist-get directives :else) t)))
(etaf--syntax-error ":else requires literal t")))
directives)
(defun etaf--view-without-directives (form)
"Return raw View FORM without compiler directive properties."
(pcase-let ((`(,tag ,props ,children) (etaf--view-form-parts form)))
(cons tag
(append
(cl-loop for (key value) on props by #'cddr
unless (memq key etaf--directive-properties)
append (list key value))
children))))
(defun etaf--compile-branch-children (first rest slot-mode)
"Compile branch FIRST and adjacent arms from REST under SLOT-MODE.
Return `(COMPILED . REMAINING)' for one compiler-owned Range program."
(let ((arms nil)
(remaining rest)
(saw-else nil)
done)
(cl-labels
((add-arm
(form kind condition)
(let ((parts (etaf--view-form-parts form)))
(etaf--validate-directive-set
(etaf--view-directive-properties (nth 1 parts)))
(push (list kind condition
(etaf--compile-view-form
(etaf--view-without-directives form) slot-mode))
arms))))
(let* ((directives
(etaf--view-directive-properties
(nth 1 (etaf--view-form-parts first)))))
(add-arm first :if (plist-get directives :if)))
(while (and remaining (not done))
(let* ((candidate (car remaining))
(parts (and (consp candidate) (symbolp (car candidate))
(not (memq (car candidate) '(expr slot)))
(etaf--view-form-parts candidate)))
(directives (and parts
(etaf--view-directive-properties
(nth 1 parts)))))
(cond
((and directives (plist-member directives :else-if))
(when saw-else
(etaf--syntax-error ":else-if cannot follow :else"))
(add-arm candidate :else-if (plist-get directives :else-if))
(setq remaining (cdr remaining)))
((and directives (plist-member directives :else))
(when saw-else
(etaf--syntax-error "A branch chain accepts one :else"))
(setq saw-else t)
(add-arm candidate :else (plist-get directives :else))
(setq remaining (cdr remaining)))
(t (setq done t))))))
(let ((token (gensym "etaf-branch-site-"))
(ordered (nreverse arms)))
(cons
`(etaf--expr-create
:kind 'branch
:token ',token
:thunk
(lambda ()
(cond
,@(mapcar
(lambda (arm)
(pcase (car arm)
(:else `(t ,(nth 2 arm)))
(_ `(,(nth 1 arm) ,(nth 2 arm)))))
ordered))))
remaining))))
(defun etaf--compile-for-child (form slot-mode)
"Compile one keyed `:for' View FORM for SLOT-MODE."
(pcase-let* ((`(,_tag ,props ,_children) (etaf--view-form-parts form))
(directives
(etaf--validate-directive-set
(etaf--view-directive-properties props)))
(for-form (plist-get directives :for)))
(when (cl-some (lambda (key) (plist-member directives key))
'(:if :else-if :else))
(etaf--syntax-error "Branch directives cannot share a node with :for"))
(unless (and (proper-list-p for-form) (= (length for-form) 2)
(symbolp (car for-form))
(not (keywordp (car for-form)))
(not (memq (car for-form) '(nil t))))
(etaf--syntax-error ":for must be (ITEM ITEMS): %S" for-form))
(when (memq (car for-form) etaf--compiling-component-props)
(etaf--syntax-error ":for item %S conflicts with a Component prop"
(car for-form)))
(unless (plist-member props :key)
(etaf--syntax-error ":for requires an explicit :key"))
(let* ((item (car for-form))
(items-form (cadr for-form))
(key-form (plist-get props :key))
(compiled (etaf--compile-view-form
(etaf--view-without-directives form) slot-mode))
(token (gensym "etaf-keyed-list-site-"))
(snapshot (gensym "etaf-keyed-snapshot-"))
(item-renderer (gensym "etaf-keyed-item-")))
`(let ((,snapshot
(lambda ()
(let ((items ,items-form))
(unless (proper-list-p items)
(etaf--component-error
":for collection must be a proper list: %S" items))
(list :items (copy-sequence items)
:keys
(mapcar
(lambda (,item) (etaf--validate-key ,key-form))
items)
:context nil))))
(,item-renderer
(lambda (,item _etaf-keyed-context) ,compiled)))
(etaf--expr-create
:kind 'keyed-list
:token ',token
:thunk
(lambda ()
(let* ((program (funcall ,snapshot))
(items (plist-get program :items)))
(mapcar (lambda (,item)
(funcall ,item-renderer ,item nil))
items)))
:range-snapshot ,snapshot
:range-item ,item-renderer)))))
(defun etaf--compile-child-sequence (children slot-mode)
"Compile sibling CHILDREN with branch and keyed-list SLOT-MODE structure."
(let (compiled)
(while children
(let* ((form (car children))
(parts (and (consp form) (symbolp (car form))
(not (memq (car form) '(expr slot)))
(etaf--view-form-parts form)))
(directives
(and parts
(etaf--validate-directive-set
(etaf--view-directive-properties (nth 1 parts))))))
(cond
((and directives (plist-member directives :if))
(pcase-let ((`(,value . ,remaining)
(etaf--compile-branch-children
form (cdr children) slot-mode)))
(push value compiled)
(setq children remaining)))
((and directives (plist-member directives :for))
(push (etaf--compile-for-child form slot-mode) compiled)
(setq children (cdr children)))
((and directives
(or (plist-member directives :else-if)
(plist-member directives :else)))
(etaf--syntax-error "Orphan branch arm: %S" form))
(t
(push (etaf--compile-child-form form slot-mode) compiled)
(setq children (cdr children))))))
(nreverse compiled)))
(defun etaf--compile-child-form (form &optional slot-mode)
"Compile structural child FORM into code returning a View value.
@ -364,12 +752,11 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
(etaf--compile-expr-form (cdr form)))
((and (consp form) (eq (car form) 'slot))
(etaf--compile-slot-form (cdr form) slot-mode))
((and (consp form) (eq (car form) 'raw-ebox))
(etaf--compile-view-form form slot-mode))
((and (consp form) (symbolp (car form)))
(when (etaf--ordinary-expression-head-p (car form))
(when (and (null (gethash (car form) etaf--view-registry))
(etaf--ordinary-expression-head-p (car form)))
(etaf--syntax-error
"Elisp expression %S must be inside (expr :value ...)" (car form)))
"Elisp expression %S must be inside (expr FORM)" (car form)))
(etaf--compile-view-form form slot-mode))
((consp form)
(etaf--syntax-error "Invalid View child form: %S" form))
@ -384,7 +771,7 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
SLOT-MODE distinguishes Component-owned projections from call-site inputs."
(cond
((null form) nil)
((stringp form) `(quote ,form))
((stringp form) `(etaf--text-view-from-string ,form))
((not (and (consp form) (symbolp (car form))))
(etaf--syntax-error "View form must start with a symbol: %S" form))
((eq (car form) 'expr)
@ -394,24 +781,6 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
;; the Component definition macro, so the public macro defaults to
;; projection mode. An unowned projection simply uses its fallback.
(etaf--compile-slot-form (cdr form) slot-mode))
((eq (car form) 'raw-ebox)
(let ((parts (etaf--parse-attributes-and-children (cdr form))))
(when (cdr parts)
(etaf--syntax-error "Raw-ebox accepts :value, optional :key, and no children"))
(let ((props (car parts)))
(unless (and (plist-member props :value)
(cl-every #'keywordp (cl-loop for (key _value) on props by #'cddr collect key)))
(etaf--syntax-error "Raw-ebox requires :value"))
(let ((allowed '(:value :key))
(token (gensym "etaf-raw-site-")))
(dolist (key (cl-loop for (key _value) on props by #'cddr collect key))
(unless (memq key allowed)
(etaf--syntax-error "Raw-ebox does not accept %S" key)))
`(etaf--raw-ebox-create
:token ',token
:thunk (lambda () ,(plist-get props :value))
:key-thunk ,(when (plist-member props :key)
`(lambda () ,(plist-get props :key))))))))
(t
(let* ((parts (etaf--parse-attributes-and-children (cdr form)))
(props (car parts))
@ -423,10 +792,8 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
(gensym "etaf-fragment-site-"))))
`(etaf--view-call ',(car form)
(list ,@(etaf--compile-property-plist props))
(list ,@(mapcar (lambda (child)
(etaf--compile-child-form
child child-slot-mode))
children))
(list ,@(etaf--compile-child-sequence
children child-slot-mode))
,(and token `',token)))))))
;;;###autoload
@ -438,8 +805,9 @@ FORM uses one grammar for Hosts and Component calls:
(NAME :PROPERTY VALUE ... CHILD ...)
Properties must come first and children must come last. Property values are
ordinary Elisp expressions. `expr' is the only computation bridge in the
child region and accepts only `:value'."
ordinary Elisp expressions. In structural child positions, `(expr FORM)'
returns nil, strings, typed Views, or proper sequences of those values.
Inside a `text' Host, an expression must return one string."
(declare (indent 1) (debug (form)))
(if (fboundp 'etaf-compiler-expand-view)
(etaf-compiler-expand-view form :projection)
@ -451,40 +819,162 @@ ordinary Elisp expressions. `expr' is the only computation bridge in the
name
(etaf--keyword-for-name name)))
(defun etaf--validate-component-props (spec props)
"Validate Component SPEC against evaluated property PLIST PROPS."
(let ((allowed (append '(:key)
(mapcar #'etaf--component-prop-key
(etaf--component-spec-props spec))))
(tail (etaf--validate-property-plist props)))
(defun etaf--partition-component-input (spec props)
"Partition SPEC input PROPS into business props and Host attrs.
Return `(BUSINESS ATTRS)'. `:key' remains framework-owned input metadata."
(let ((declared (mapcar #'etaf--component-prop-key
(etaf--component-spec-props spec)))
(tail (etaf--validate-property-plist props))
(attr-domains (make-hash-table :test #'eq))
business
attrs)
(while tail
(let ((key (pop tail)))
(pop tail)
(unless (memq key allowed)
(let ((key (pop tail))
(value (pop tail)))
(cond
((or (eq key :key) (memq key declared))
(setq business (append business (list key value))))
((etaf--host-attribute-p key)
(let ((domain (etaf--property-domain-key key)))
(when (gethash domain attr-domains)
(etaf--component-error
"Duplicate Component Host attribute domain: %S" key))
(puthash domain t attr-domains)
(setq attrs (append attrs (list domain value)))))
(t
(etaf--component-error
"Unknown prop %S for Component %S"
key (etaf--component-spec-name spec)))))
props))
"Unknown prop or Host attribute %S for Component %S"
key (etaf--component-spec-name spec))))))
(list business attrs)))
(defun etaf--component-business-props (call)
"Return CALL's declared business props without framework `:key'."
(cl-loop for (key value) on (etaf--component-call-props call) by #'cddr
unless (eq key :key)
append (list key value)))
(defun etaf--typed-view-child-p (value)
"Return non-nil when VALUE is one already validated View child."
(or (null value)
(stringp value)
;; Code-mode setup may retain a structural program (for example, a
;; direct Range expression) and pass that opaque value to `etaf-node'.
;; It is still validated and interpreted only at the renderer boundary;
;; arbitrary lists remain rejected here.
(etaf--expr-p value)
(etaf--view-node-p value)
(etaf--component-call-p value)
(etaf--slot-projection-p value)))
(defun etaf--validate-component-render-result (value component-name)
"Return typed VALUE or reject COMPONENT-NAME's ambiguous render result."
(unless (etaf--typed-view-child-p value)
(etaf--component-error
"Component %S must render nil, a string, or one typed View; got %S"
component-name value))
value)
(defun etaf--validate-code-children (children context)
"Return a detached CHILDREN spine after typed validation for CONTEXT."
(unless (proper-list-p children)
(etaf--component-error "%s children must be a proper list: %S"
context children))
(dolist (child children)
(unless (etaf--typed-view-child-p child)
(etaf--component-error
"%s child must be nil, string, or typed View: %S" context child)))
(copy-sequence children))
(defun etaf--validate-code-slots (slots)
"Return typed named SLOTS as internal slot inputs."
(unless (proper-list-p slots)
(etaf--component-error "Named slots must be a proper alist: %S" slots))
(let (seen result)
(dolist (entry slots (nreverse result))
(unless (and (consp entry)
(symbolp (car entry))
(not (keywordp (car entry)))
(not (memq (car entry) '(nil t))))
(etaf--component-error "Invalid named slot entry: %S" entry))
(when (memq (car entry) seen)
(etaf--component-error "Duplicate Component slot %S" (car entry)))
(push (car entry) seen)
(push (etaf--slot-input-create
:name (car entry)
:children (etaf--validate-code-children
(cdr entry) (format "Slot %S" (car entry))))
result))))
;;;###autoload
(defun etaf-node (tag props children &optional named-slots)
"Construct one typed View node from evaluated ordinary Elisp values.
TAG is an exact Host or Component registry symbol. PROPS is a keyword plist,
CHILDREN is a list of typed View children, and NAMED-SLOTS is a Component-only
alist from stable slot symbols to typed child lists."
(unless (symbolp tag)
(etaf--component-error "Node tag must be a symbol: %S" tag))
(setq props (etaf--validate-property-plist props))
(dolist (directive etaf--directive-properties)
(when (plist-member props directive)
(etaf--component-error
"Code node %S rejects DSL directive %S" tag directive)))
(when (plist-member props :key)
(setq props
(plist-put props :key
(etaf--validate-key (plist-get props :key)))))
(let* ((entry (gethash tag etaf--view-registry))
(children (etaf--validate-code-children children
(format "Node %S" tag)))
(slot-inputs (etaf--validate-code-slots named-slots)))
(when (and slot-inputs (eq entry etaf--host-marker))
(etaf--component-error "Host %S does not accept named slots" tag))
(etaf--view-call tag props (append children slot-inputs))))
(defun etaf--text-view-from-string (value)
"Return one normalized Text View containing string VALUE."
(etaf--view-node-create :name 'text :props nil :children (list value)))
(defun etaf--normalize-structural-child (child)
"Normalize static structural CHILD without evaluating expressions."
(cond
((stringp child) (etaf--text-view-from-string child))
((etaf--slot-input-p child)
(let ((copy (copy-sequence child)))
(setf (etaf--slot-input-children copy)
(mapcar #'etaf--normalize-structural-child
(etaf--slot-input-children child)))
copy))
(t child)))
(defun etaf--view-call (name props children &optional token)
"Construct NAME from PROPS and CHILDREN, retaining optional site TOKEN."
(unless (symbolp name)
(etaf--syntax-error "View name must be a symbol: %S" name))
(setq props (etaf--validate-property-plist props))
(let ((entry (gethash name etaf--view-registry)))
(let* ((entry (gethash name etaf--view-registry))
(host-name (and (eq entry etaf--host-marker)
name))
(children
(if (eq host-name 'text)
children
(mapcar #'etaf--normalize-structural-child children))))
(cond
((eq entry etaf--host-marker)
(when (and (eq host-name 'text) (/= (length children) 1))
(etaf--syntax-error
"Text requires exactly one string or expr payload"))
(when (plist-member props :key)
(etaf--validate-key
(etaf--resolve-property-value (plist-get props :key))))
(etaf--view-node-create
:name (etaf--canonical-host-name name)
(etaf--view-node-create
:name host-name
:token token
:props props
:children children))
((etaf--component-spec-p entry)
(etaf--validate-component-props entry props)
(let (default-children named-slots)
(pcase-let* ((`(,business-props ,attrs)
(etaf--partition-component-input entry props)))
(let (default-children named-slots)
(dolist (child children)
(if (etaf--slot-input-p child)
(progn
@ -502,10 +992,11 @@ ordinary Elisp expressions. `expr' is the only computation bridge in the
"Component default slot has both children and an explicit input"))
(etaf--component-call-create
:spec entry
:props props
:props business-props
:attrs attrs
:slots (if default-children
(cons (cons 'default default-children) named-slots)
named-slots))))
named-slots)))))
(t
(etaf--component-error "Unknown ETAF Host or Component: %S" name)))))

11
etaf.el
View File

@ -3,8 +3,8 @@
;; SPDX-License-Identifier: GPL-3.0-or-later
;; Author: ETAF contributors
;; Version: 0.1.0
;; Package-Requires: ((emacs "29.1") (ebox "2.0.0"))
;; Version: 0.2.1
;; Package-Requires: ((emacs "29.1") (ebox "3.0.0") (tp "2.0.0"))
;; Keywords: ui, tools, convenience
;; URL: https://github.com/ginqi7/etaf
@ -30,17 +30,22 @@
(require 'etaf-view)
(require 'etaf-compiler)
(require 'etaf-component)
(require 'etaf-scheduler)
(require 'etaf-reactive)
(require 'etaf-observer)
(require 'etaf-context)
(require 'etaf-resource)
(require 'etaf-data)
(require 'etaf-generation)
(require 'etaf-host)
(require 'etaf-retirement)
(require 'etaf-render-port)
(require 'etaf-renderer)
(etaf--prefer-local-files)
(require 'etaf-runtime)
(require 'etaf-behavior)
(require 'etaf-actions)
(require 'etaf-events)
(require 'etaf-performance)
(unless (fboundp 'ebox-call-with-render-burst)
(error "ETAF requires an Ebox build with framework render-burst support"))

View File

@ -25,66 +25,25 @@
('reset 0)
(_ (user-error "Unknown counter operation: %S" operation)))))
(defun etaf-counter-example--header (title)
"Return the counter header for TITLE."
(etaf-view
(column :class "hero"
(text :class "eyebrow" "BEST PRACTICE / RETAINED STATE")
(text :face 'bold (expr :value title))
(text :color "#66706A"
"State belongs to setup; rendering only reads it."))))
(defun etaf-counter-example--metrics (count double status)
"Return metric cards for COUNT, DOUBLE, and STATUS."
(etaf-view
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
(text :class "metric"
(expr :value (format "COUNT %d" (etaf-value count))))
(text :class "metric"
(expr :value (format "DOUBLE %d" (etaf-value double))))
(text :class "metric"
(expr :value (format "STATE %s" (etaf-value status)))))))
(defun etaf-counter-example--action (count label host-ref operation)
"Return one COUNT action named LABEL using HOST-REF and OPERATION."
(etaf-view
(text :class "action" :ref host-ref :role 'button
:use (list (etaf-focusable))
:on-press (lambda ()
(etaf-dispatch 'etaf-counter-example-update
count operation))
(expr :value label))))
(defun etaf-counter-example--actions (count)
"Return the action group for COUNT."
(etaf-view
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
(expr :value
(etaf-counter-example--action
count " DECREMENT" 'counter-decrement 'decrement))
(expr :value
(etaf-counter-example--action
count "RESET" 'counter-reset 'reset))
(expr :value
(etaf-counter-example--action
count "+ INCREMENT" 'counter-increment 'increment)))))
(etaf-define-component etaf-counter-example-action
(&key count label operation)
"Render one semantic counter action."
:view
(box :class "action" :role 'button :use (list (etaf-focusable))
:on-press
(let ((cell count) (next-operation operation))
(lambda ()
(etaf-dispatch 'etaf-counter-example-update
cell next-operation)))
(text (expr label)))
:styles
(styles
("&" :flex-grow 1 :flex-shrink 1 :flex-basis (160)
:min-width (140) :padding (1 (12)) :border "#4E7890"
:bgcolor "#D9EAF2" :text-align center :font-weight bold)))
(etaf-define-component etaf-counter-example-card (&key title initial-value)
"Render a retained counter named TITLE starting at INITIAL-VALUE."
:styles
(styles
("&" :width (680) :color "#252A2E" :bgcolor "#F8F5EE")
(".hero" :width (680) :padding (1 (18)) :border "#8F432F"
:bgcolor "#FFFDF8" :text-align center)
(".eyebrow" :color "#8F432F" :face bold)
(".metric" :flex-grow 1 :flex-shrink 1 :flex-basis (200)
:min-width (180) :padding (1 (14)) :border "#6D8A73"
:bgcolor "#DCEBDD" :text-align center)
(".action" :flex-grow 1 :flex-shrink 1 :flex-basis (160)
:min-width (140) :padding (1 (12)) :border "#4E7890"
:bgcolor "#D9EAF2" :text-align center :face bold)
(".note" :width (680) :padding (1 (16)) :border "#8D887F"
:color "#4D5651" :bgcolor "#EEEAE2"))
:setup
(let* ((count (etaf-ref (or initial-value 0) :name 'counter))
(double (etaf-computed
@ -94,18 +53,57 @@
(lambda ()
(if (zerop (etaf-value count)) "READY" "ACTIVE"))
:name 'counter-status)))
(lambda ()
(etaf-view
(column
(expr :value (etaf-counter-example--header title))
(spacer :height 1)
(expr :value
(etaf-counter-example--metrics count double status))
(spacer :height 1)
(expr :value (etaf-counter-example--actions count))
(spacer :height 1)
(text :class "note"
"Public path: Event → Action → Ref → Computed → Runtime commit"))))))
(list :count count :double double :status status))
:view
(column
(box :class "hero"
(column
(text :class "eyebrow" "BEST PRACTICE / RETAINED STATE")
(text :font-weight 'bold (expr title))
(text :color "#66706A"
"State belongs to setup; rendering only reads it.")))
(box :height 1)
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
(box :class "metric"
(text (expr
(format "COUNT %d"
(etaf-value (plist-get (etaf-state) :count))))))
(box :class "metric"
(text (expr
(format "DOUBLE %d"
(etaf-value (plist-get (etaf-state) :double))))))
(box :class "metric"
(text (expr
(format "STATE %s"
(etaf-value (plist-get (etaf-state) :status)))))))
(box :height 1)
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
(etaf-counter-example-action
:ref 'counter-decrement
:count (plist-get (etaf-state) :count)
:label " DECREMENT" :operation 'decrement)
(etaf-counter-example-action
:ref 'counter-reset
:count (plist-get (etaf-state) :count)
:label "RESET" :operation 'reset)
(etaf-counter-example-action
:ref 'counter-increment
:count (plist-get (etaf-state) :count)
:label "+ INCREMENT" :operation 'increment))
(box :height 1)
(box :class "note"
(text "Public path: Event → Action → Ref → Computed → Runtime commit")))
:styles
(styles
("&" :width (680) :color "#252A2E" :bgcolor "#F8F5EE")
(".hero" :width (680) :padding (1 (18)) :border "#8F432F"
:bgcolor "#FFFDF8" :text-align center)
(".eyebrow" :color "#8F432F" :font-weight bold)
(".metric" :flex-grow 1 :flex-shrink 1 :flex-basis (200)
:min-width (180) :padding (1 (14)) :border "#6D8A73"
:bgcolor "#DCEBDD" :text-align center)
(".note" :width (680) :padding (1 (16)) :border "#8D887F"
:color "#4D5651" :bgcolor "#EEEAE2")))
;;;###autoload
(defun etaf-counter-example-view ()

View File

@ -45,106 +45,53 @@
(etaf-data-set-query controller query)
(etaf-data-load controller))
(defun etaf-data-example--row (controller task)
"Return one TASK row bound to CONTROLLER."
(let* ((identity (plist-get task :id))
(selected (etaf-data-selected-p controller identity))
(status (plist-get task :status))
(host-ref (intern (format "data-task-%d" identity))))
(etaf-view
(flex :width '(718) :flex-flow '(row nowrap) :gap '(0 (10))
:padding '(1 (12)) :border "#6D8A73"
:bgcolor (if selected "#DCEBDD" "#FFFDF8")
:ref host-ref :role 'button :use (list (etaf-focusable))
:on-press (lambda ()
(etaf-dispatch 'etaf-data-example-toggle
controller identity))
(text :width '(36) :face 'bold
:color (if selected "#2F6B43" "#8D887F")
(expr :value (if selected "" "")))
(text :flex-grow 1 :flex-shrink 1 :flex-basis '(390)
:min-width '(280)
(expr :value (plist-get task :title)))
(text :width '(96) :color "#66706A"
(expr :value (plist-get task :owner)))
(text :width '(84) :face 'bold :text-align 'right
:color (if (eq status 'done) "#2F6B43" "#9B4A34")
(expr :value (upcase (symbol-name status))))))))
(etaf-define-component etaf-data-example-row (&key controller task)
"Render one retained TASK row from CONTROLLER."
:view
(flex :width '(718) :flex-flow '(row nowrap) :gap '(0 (10))
:padding '(1 (12)) :border "#6D8A73"
:bgcolor
(if (etaf-value
(etaf-data-selected-ref controller (plist-get task :id)))
"#DCEBDD" "#FFFDF8")
:role 'button :use (list (etaf-focusable))
:on-press
(let ((data-controller controller)
(identity (plist-get task :id)))
(lambda ()
(etaf-dispatch 'etaf-data-example-toggle
data-controller identity)))
(box :width '(36) :font-weight 'bold
:color
(if (etaf-value
(etaf-data-selected-ref controller (plist-get task :id)))
"#2F6B43" "#8D887F")
(text
(expr
(if (etaf-value
(etaf-data-selected-ref controller (plist-get task :id)))
"" ""))))
(box :flex-grow 1 :flex-shrink 1 :flex-basis '(390)
:min-width '(280)
(text (expr (plist-get task :title))))
(box :width '(96) :color "#66706A"
(text (expr (plist-get task :owner))))
(box :width '(84) :font-weight 'bold :text-align 'right
:color (if (eq (plist-get task :status) 'done)
"#2F6B43" "#9B4A34")
(text (expr (upcase (symbol-name (plist-get task :status))))))))
(defun etaf-data-example--header (controller)
"Return the summary header for CONTROLLER."
(let ((total (etaf-value (etaf-data-total controller)))
(selection (etaf-value (etaf-data-selection controller))))
(etaf-view
(column :width '(720) :padding '(1 (18)) :border "#8F432F"
:bgcolor "#FFFDF8" :text-align 'center
(text :color "#8F432F" :face 'bold
"BEST PRACTICE / DATA OWNERSHIP")
(text :face 'bold "Task controller")
(text :color "#66706A"
(expr :value
(format "%d records · %d selected" total
(length selection))))))))
(defun etaf-data-example--filter-control
(controller label host-ref query border background)
"Return a filter LABEL for CONTROLLER using HOST-REF and QUERY.
Use BORDER and BACKGROUND for its semantic color family."
(etaf-view
(text :padding '(1 (12)) :border border :bgcolor background
:face 'bold :ref host-ref :role 'button
:use (list (etaf-focusable))
:on-press (lambda ()
(etaf-data-example--filter controller query))
(expr :value label))))
(defun etaf-data-example--toolbar (controller next-id)
"Return the action toolbar for CONTROLLER and NEXT-ID."
(etaf-view
(flex :width '(720) :flex-flow '(row wrap) :gap '(1 (10))
(expr :value (etaf-data-example--filter-control
controller "ALL" 'data-filter-all nil
"#4E7890" "#D9EAF2"))
(expr :value (etaf-data-example--filter-control
controller "OPEN" 'data-filter-open '(:status open)
"#C97252" "#F1D4C9"))
(expr :value (etaf-data-example--filter-control
controller "DONE" 'data-filter-done '(:status done)
"#6D8A73" "#DCEBDD"))
(text :padding '(1 (12)) :border "#7A6B95" :bgcolor "#E7E2F1"
:face 'bold :ref 'data-add :role 'button
:use (list (etaf-focusable))
:on-press (lambda ()
(etaf-dispatch 'etaf-data-example-add
controller next-id))
"+ ADD TASK"))))
(defun etaf-data-example--rows (controller)
"Return the loaded task rows for CONTROLLER."
(let ((items (etaf-value (etaf-data-items controller))))
(if items
(mapcar (lambda (task)
(etaf-data-example--row controller task))
items)
(etaf-view
(text :width '(720) :padding '(2 (16))
:border "#8D887F" :bgcolor "#EEEAE2"
:text-align 'center "No matching tasks.")))))
(defun etaf-data-example--view (controller next-id)
"Return the Data example View for CONTROLLER and NEXT-ID."
(etaf-view
(column :width '(720) :color "#252A2E" :bgcolor "#F8F5EE"
(expr :value (etaf-data-example--header controller))
(spacer :height 1)
(expr :value (etaf-data-example--toolbar controller next-id))
(spacer :height 1)
(column :width '(720)
(expr :value (etaf-data-example--rows controller)))
(spacer :height 1)
(text :width '(720) :padding '(1 (16)) :border "#8D887F"
:color "#4D5651" :bgcolor "#EEEAE2"
"Owner rule: create in setup, mutate through Data, stop on unmount"))))
(etaf-define-component etaf-data-example-filter
(&key controller label query border background)
"Render one query filter for CONTROLLER."
:view
(box :padding '(1 (12)) :border border :bgcolor background
:font-weight 'bold :role 'button :use (list (etaf-focusable))
:on-press
(let ((data-controller controller) (next-query query))
(lambda ()
(etaf-data-example--filter data-controller next-query)))
(text (expr label))))
(etaf-define-component etaf-data-example-app ()
"Render a memory-backed task application with owned cleanup."
@ -158,7 +105,70 @@ Use BORDER and BACKGROUND for its semantic color family."
(next-id (etaf-ref 6 :name 'etaf-data-example-next-id)))
(etaf-on-mounted (lambda () (etaf-data-load controller)))
(etaf-on-unmounted (lambda () (etaf-data-stop controller)))
(lambda () (etaf-data-example--view controller next-id))))
(list :controller controller :next-id next-id))
:view
(column :width '(720) :color "#252A2E" :bgcolor "#F8F5EE"
(box :width '(720) :padding '(1 (18)) :border "#8F432F"
:bgcolor "#FFFDF8" :text-align 'center
(column
(text :color "#8F432F" :font-weight 'bold
"BEST PRACTICE / DATA OWNERSHIP")
(text :font-weight 'bold "Task controller")
(text :color "#66706A"
(expr
(format
"%d records · %d selected"
(etaf-value
(etaf-data-total (plist-get (etaf-state) :controller)))
(length
(etaf-value
(etaf-data-selection (plist-get (etaf-state) :controller)))))))))
(box :height 1)
(flex :width '(720) :flex-flow '(row wrap) :gap '(1 (10))
(etaf-data-example-filter
:ref 'data-filter-all
:controller (plist-get (etaf-state) :controller)
:label "ALL" :query nil :border "#4E7890" :background "#D9EAF2")
(etaf-data-example-filter
:ref 'data-filter-open
:controller (plist-get (etaf-state) :controller)
:label "OPEN" :query '(:status open)
:border "#C97252" :background "#F1D4C9")
(etaf-data-example-filter
:ref 'data-filter-done
:controller (plist-get (etaf-state) :controller)
:label "DONE" :query '(:status done)
:border "#6D8A73" :background "#DCEBDD")
(box :padding '(1 (12)) :border "#7A6B95" :bgcolor "#E7E2F1"
:font-weight 'bold :ref 'data-add :role 'button
:use (list (etaf-focusable))
:on-press
(let ((controller (plist-get (etaf-state) :controller))
(next-id (plist-get (etaf-state) :next-id)))
(lambda ()
(etaf-dispatch 'etaf-data-example-add controller next-id)))
(text "+ ADD TASK")))
(box :height 1)
(column :width '(720)
(box :if
(null
(etaf-value
(etaf-data-items (plist-get (etaf-state) :controller))))
:width '(720) :padding '(2 (16))
:border "#8D887F" :bgcolor "#EEEAE2" :text-align 'center
(text "No matching tasks."))
(etaf-data-example-row
:for (task
(etaf-value
(etaf-data-items (plist-get (etaf-state) :controller))))
:key (plist-get task :id)
:ref (intern (format "data-task-%d" (plist-get task :id)))
:controller (plist-get (etaf-state) :controller)
:task task))
(box :height 1)
(box :width '(720) :padding '(1 (16)) :border "#8D887F"
:color "#4D5651" :bgcolor "#EEEAE2"
(text "Owner rule: create in setup, mutate through Data, stop on unmount"))))
;;;###autoload
(defun etaf-data-example-view ()

View File

@ -22,70 +22,6 @@
('loading "Loading service snapshot…")
(_ "Resource has not loaded.")))
(defun etaf-resource-example--header ()
"Return the Resource example header."
(etaf-view
(column :width '(680) :padding '(1 (18)) :border "#8F432F"
:bgcolor "#FFFDF8" :text-align 'center
(text :color "#8F432F" :face 'bold
"BEST PRACTICE / RESOURCE LIFECYCLE")
(text :face 'bold "Service health")
(text :color "#66706A"
"Loader errors become explicit state; cleanup stays scoped."))))
(defun etaf-resource-example--status (resource cleanup-count)
"Return the status card for RESOURCE and CLEANUP-COUNT."
(let* ((status (etaf-resource-status resource))
(success (eq status 'success))
(surface (if success "#DCEBDD" "#F1D4C9"))
(border (if success "#6D8A73" "#C97252"))
(ink (if success "#24422D" "#6B3020")))
(etaf-view
(column :width '(680) :padding '(2 (18)) :border border
:bgcolor surface :color ink :text-align 'center
(text :face 'bold
(expr :value (upcase (symbol-name status))))
(text (expr :value (etaf-resource-example--message resource)))
(text :color "#66706A"
(expr :value
(format "CLEANUPS %d" (etaf-value cleanup-count))))))))
(defun etaf-resource-example--actions (resource fail-next)
"Return action controls for RESOURCE and FAIL-NEXT."
(etaf-view
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
(text :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
:min-width '(180) :padding '(1 (12))
:border "#4E7890" :bgcolor "#D9EAF2" :face 'bold
:text-align 'center :ref 'resource-reload :role 'button
:use (list (etaf-focusable))
:on-press (lambda () (etaf-resource-load resource))
"RELOAD")
(text :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
:min-width '(180) :padding '(1 (12))
:border "#C97252" :bgcolor "#F1D4C9" :face 'bold
:text-align 'center :ref 'resource-fail :role 'button
:use (list (etaf-focusable))
:on-press (lambda ()
(etaf-set-value fail-next t)
(etaf-resource-load resource))
"SIMULATE FAILURE"))))
(defun etaf-resource-example--view (resource fail-next cleanup-count)
"Return the example View for RESOURCE, FAIL-NEXT, and CLEANUP-COUNT."
(etaf-view
(column :width '(680) :color "#252A2E" :bgcolor "#F8F5EE"
(expr :value (etaf-resource-example--header))
(spacer :height 1)
(expr :value
(etaf-resource-example--status resource cleanup-count))
(spacer :height 1)
(expr :value (etaf-resource-example--actions resource fail-next))
(spacer :height 1)
(text :width '(680) :padding '(1 (16)) :border "#8D887F"
:color "#4D5651" :bgcolor "#EEEAE2"
"Scope rule: reload releases the old value; unmount releases the last one"))))
(etaf-define-component etaf-resource-example-app ()
"Render a reloadable Resource with visible cleanup and error state."
:setup
@ -111,8 +47,75 @@
:immediate nil
:name 'etaf-resource-example))
(etaf-on-mounted (lambda () (etaf-resource-load resource)))
(lambda ()
(etaf-resource-example--view resource fail-next cleanup-count))))
(list :resource resource :fail-next fail-next
:cleanup-count cleanup-count))
:view
(column :width '(680) :color "#252A2E" :bgcolor "#F8F5EE"
(box :width '(680) :padding '(1 (18)) :border "#8F432F"
:bgcolor "#FFFDF8" :text-align 'center
(column
(text :color "#8F432F" :font-weight 'bold
"BEST PRACTICE / RESOURCE LIFECYCLE")
(text :font-weight 'bold "Service health")
(text :color "#66706A"
"Loader errors become explicit state; cleanup stays scoped.")))
(box :height 1)
(box :width '(680) :padding '(2 (18))
:border
(if (eq (etaf-resource-status
(plist-get (etaf-state) :resource)) 'success)
"#6D8A73" "#C97252")
:bgcolor
(if (eq (etaf-resource-status
(plist-get (etaf-state) :resource)) 'success)
"#DCEBDD" "#F1D4C9")
:color
(if (eq (etaf-resource-status
(plist-get (etaf-state) :resource)) 'success)
"#24422D" "#6B3020")
:text-align 'center
(column
(text :font-weight 'bold
(expr
(upcase
(symbol-name
(etaf-resource-status (plist-get (etaf-state) :resource))))))
(text
(expr
(etaf-resource-example--message
(plist-get (etaf-state) :resource))))
(text :color "#66706A"
(expr
(format "CLEANUPS %d"
(etaf-value (plist-get (etaf-state) :cleanup-count)))))))
(box :height 1)
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
(box :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
:min-width '(180) :padding '(1 (12))
:border "#4E7890" :bgcolor "#D9EAF2" :font-weight 'bold
:text-align 'center :ref 'resource-reload :role 'button
:use (list (etaf-focusable))
:on-press
(let ((resource (plist-get (etaf-state) :resource)))
(lambda () (etaf-resource-load resource)))
(text "RELOAD"))
(box :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
:min-width '(180) :padding '(1 (12))
:border "#C97252" :bgcolor "#F1D4C9" :font-weight 'bold
:text-align 'center :ref 'resource-fail :role 'button
:use (list (etaf-focusable))
:on-press
(let ((resource (plist-get (etaf-state) :resource))
(fail-next (plist-get (etaf-state) :fail-next)))
(lambda ()
(etaf-set-value fail-next t)
(etaf-resource-load resource)))
(text "SIMULATE FAILURE")))
(box :height 1)
(box :width '(680) :padding '(1 (16)) :border "#8D887F"
:color "#4D5651" :bgcolor "#EEEAE2"
(text
"Scope rule: reload releases the old value; unmount releases the last one"))))
;;;###autoload
(defun etaf-resource-example-view ()

View File

@ -0,0 +1,29 @@
# Historical worktree integration
The September 5 benchmark worktrees contain competing repair attempts against
an earlier ETAF contract. Their changes were reconciled against current main
on September 8, rather than replacing the newer implementation.
- `127aa7a` preserves every existing root metadata value. Current main's
`805323a` already protects owned role and ARIA semantics, composes callbacks
and Behaviors, and allows caller values for ordinary metadata. Retain that
more precise implementation when reconciling the old attempt.
- `a206cfd` changes only the old metadata docstring to describe unrestricted
caller overrides. Retain the current docstring because owned semantic
conflicts are now rejected explicitly.
- The retained-root fixture's instance-scoping test is already present in
`tests/etaf-component-frontends-tests.el`. Its old role-override expectation
conflicts with the current owned-role contract and is superseded by the
existing rejection assertion.
- The three v1 unmount test attempts exercise the same lifecycle outcome.
Production no longer exposes the v1 fallback. Their live-buffer, unmounted,
zero-revision assertions are carried into the current render-port revision
contract test.
- The metadata baseline deliberately rejects every duplicate metadata key;
that blanket rule is superseded by the current property-specific policy.
- The missing-revision baseline deletes an old v1 test. Both that test and the
v1 production route have already been removed by the current SPI boundary.
The historical worktrees remain as evidence. They are not runtime dependencies.
Regression execution was explicitly waived for this integration; static checks
do not establish fresh behavioral or performance acceptance.

175
scripts/README.md Normal file
View File

@ -0,0 +1,175 @@
# Generic Emacs GUI verification
For an already running Emacs, use its existing server through `emacsclient`.
Load the checkout and call the example entry point in an explicit buffer, show
that buffer in the existing graphical frame, and capture only that owned
window. Preserve the user's font and chrome. Do not start another daemon or
frame for this workflow. Preserve application focus so the user can keep working
in other apps. The `emacsclient-render-capture` skill supplies buffer selection
without activation and before/after target guards.
This directory also owns reusable verification mechanisms; application
scenarios live in their respective example repositories:
- `emacs-gui-verifier.el` defines `Scenario`, ordered `Action`, run-local
`Context`, checkpoint sequencing, assertions, completion, and fail-closed
evidence finalization. Its `etaf-gui-verifier-measure-action` entry records
callback wall/CPU/GC time and GUI conditions without taking application focus.
- `benchmark-ebox-resize.el` drives continuous pixel-width sweeps of any
existing mounted Ebox buffer, including ETAF apps, without taking over its
observer. See the existing-server entry below.
- The legacy isolated runner `run-emacs-gui-verification.sh` owns one named daemon, explicit load paths,
external application activation, recorder lifecycle, driver loading, report
generation, and exact cleanup.
- `record-emacs-window.swift` uses macOS 15 ScreenCaptureKit to record only the
frame owned by the supplied Emacs PID. It follows replacement window IDs and
rejects changed pixel mappings. Its desktop-independent window filter works
without activating Emacs. Its canvas is fixed at recording start:
when the scenario includes resize, prepare the largest tested frame before
starting the recorder. Smaller windows retain native pixels with padding;
a window larger than the original canvas invalidates the recording.
- `capture-emacs-window.sh` supplies window-only checkpoint screenshots and
rejects missing, ambiguous, or changing frame identities without activating
Emacs. The runner compiles
the video helper using the system Swift compiler; no package install is needed.
Concrete repositories provide adapter files that construct a Scenario and an
entry function. They can run through the existing server. The following command
instead starts the legacy isolated environment; use it only when that separate
environment is explicitly intended:
```sh
scripts/run-emacs-gui-verification.sh run ADAPTER.el ENTRY \
--load-path /path/to/provider \
--run-dir /private/tmp/my-gui-run
```
In that isolated runner, fresh captures remain `INCOMPLETE` until their selected images
and contact sheet are reviewed. Finalize the same evidence directory with:
```sh
scripts/run-emacs-gui-verification.sh review /private/tmp/my-gui-run
```
Only `VERDICT=PASS` completes that runner's evidence bundle. An existing-server
run reports its actual interaction assertions and inspected screenshots
separately. A failed recorder is never evidence of continuous capture, and
neither screenshots nor recording establish an operation latency bound.
For an existing server, take a background screenshot with the observed process ID:
```sh
ETAF_GUI_CAPTURE_PID=12345 scripts/capture-emacs-window.sh -x /tmp/app-checkpoint.png
```
Keep the target frame open and non-minimized. Validate a known content change in
before/after pixels to establish fresh background rendering. Hidden, minimized,
off-Space and locked-session behavior is not covered by this procedure. Background
Lisp callbacks and runtime timing do not require application activation; report
them as background measurements, separately from foreground input-to-display
latency. Use Emacs-local operations while another app is active, not global input.
## Measuring an existing GUI action
Reuse `etaf-gui-verifier-measure-action` with the adapter's Context and Action:
```elisp
;; Prepare the target control and fixture before entering the measured callback.
(etaf-gui-verifier-measure-action context action t)
(car (etaf-gui-verifier-context-measurements context))
```
The final `t` requires an already selected foreground target. It rejects a
background, hidden, unknown or wrong target before running the action, and
invalidates a sample if focus, target, font or geometry changes. It never raises
Emacs. Omit that argument for background functional work; those samples are
explicitly labeled and must not be reported as foreground latency.
Timing covers exactly `Action.execute`, excluding target inspection,
checkpoints and the verifier's intentional settle waits. Keep fixture setup,
control lookup and focus navigation outside an activation measurement. If the
chosen boundary includes an explicit `redisplay`, put that call in `execute`
and describe the boundary accordingly. Returning from redisplay still does not
prove compositor presentation. Each record says `presentation_measured=nil`.
Context retains every measurement, including first use, warmups, failures and
rejections. Failed callbacks retain their own timing and original condition;
rejections have no duration. Checkpoints export only the most recent record.
Report the full sample count and all-sample maximum as well as any explicitly
labeled steady-state statistics. Compare identical payload/page size, viewport,
loaded code, recording mode and foreground class; do not discard a slow group
because another run is faster. The historical `.omx/component-api-implementation/
current-workbench-sample.el` probe is superseded by this measurement boundary.
For provider traces, scope `etaf-performance-records` by its numeric observer
runtime ID, not buffer name, which can be reused after unmount. Pass the selected
records explicitly to summary/export functions: an empty selection stays empty.
Check operation IDs/counts as well as runtime ID when sampling the same mounted
instance again; the recorder's bounded history is not a per-run sample store.
## Continuous resize on the existing server
Use this entry for resize performance investigations instead of copying the
historical `.omx/component-api-implementation/*continuous-resize*.el` probes.
First show the intended buffer in the user's existing foreground GUI frame.
Preserve its font and chrome. Compile changed product modules before loading
them; `make compile` in this repository also compiles the benchmark tool.
```sh
emacsclient --eval '(progn
(load "/path/to/etaf/scripts/benchmark-ebox-resize.elc" nil t t)
(ebox-resize-benchmark-start "*Your app*" 480 1400
:step 32 :rounds 3 :output "/tmp/resize-run-1.eldata"))'
```
The bounds are outer-frame pixels. Every round goes from narrow to wide and
back, including both endpoints even when the step does not divide the range.
The last measured request returns to the initial width. Consecutive equal
widths are omitted because they request no resize; no warmup or slow sample is
dropped. The function returns immediately. Poll or cancel this owned run with:
```elisp
(ebox-resize-benchmark-status)
(ebox-resize-benchmark-cancel)
```
`:delay` (default 0.01 seconds) runs between completed publications;
`:timeout` (default 5 seconds) bounds startup, publication and final settling.
The tool waits for a preceding render's GC lease to end before recording the
baseline, and for its own run's lease to end before accepting the final result.
Unsupported sizes,
changed targets/focus/font/height, publication failures and cancellation produce
invalid/incomplete evidence. Advice and timers are removed on success, error,
quit and timeout. Failure leaves the last applied width; it does not fight a
user's subsequent window changes. No server, frame, application buffer, observer, profiler
or GC policy is created/replaced to make the benchmark pass.
Use a **new output path** each time. UTF-8 `.eldata` reports retain all requests,
all completed samples, actual published dimensions, node/text counts, GC,
per-operation CPU time, code origins and hashes. Optional `:phases '(FUNCTIONS…)`
records inclusive phase durations for loaded `ebox-`, `tp-` and `etaf-` provider
functions. The driver and outer publication boundary cannot be selected as
phases; nested durations must not be summed.
Publication timing ends when the real public Ebox viewport call returns.
Request→publication also includes event-loop delivery. Neither metric proves
compositor presentation, absence of flicker, or every interaction's correctness;
use the existing visual scenario/capture tools for those claims.
`:valid t` requires complete correctly attributed publication coverage.
`:within-limit t` additionally requires **every** request→publication sample to
meet `:limit-ms` (default 50). Inspect p95 **and** max, including GC samples.
Compare payload counts at matching widths before making speedup claims. A
different page size/content or loaded version is a different baseline.
Code origins and disk hashes alone cannot establish when a running function was
loaded. After recompilation, `:reload-files '("/checkout/ebox/ebox-viewport.elc" …)`
explicitly loads the chosen fresh bytecode before instrumentation. `:code`
contains every explicitly loaded file's canonical path, source/bytecode hashes
and load result, plus observed core function and benchmark driver origins;
matching origins are marked `:reloaded t`. Choose the affected modules; do not reload
application component declarations blindly. Without this option, report code
origin observations separately from independent evidence of a fresh GUI load.
Run the tool's regression checks with `make resize-benchmark-tests`; they also
run in the full `make check` gate. Application-specific data setup and interaction
assertions remain in the example repositories, not this resize driver.

View File

@ -0,0 +1,497 @@
;;; benchmark-ebox-resize.el --- Existing-frame resize benchmark -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Drive any mounted Ebox buffer through a pixel-width sweep in its existing
;; GUI frame. This includes ETAF apps without depending on ETAF Runtime.
;; Publication completion, rather than a fixed sleep, advances each request.
;; The visual scenario engine remains responsible for screenshots/interaction
;; assertions; this tool measures request and publication boundaries only.
;; Internal Ebox state is read for bounded diagnostics, never mutated.
;;; Code:
(require 'cl-lib)
(require 'ebox)
(require 'ebox-viewport)
(declare-function profiler-running-p "profiler" ())
(declare-function ebox-native-reflow-runtime-report "ebox-native-reflow" ())
(defvar ebox-resize-benchmark--run nil
"The sole active run, including its owned timers and instrumentation.")
(defvar ebox-resize-benchmark--last-result nil
"Scalar report for the most recently finished run.")
(defvar ebox-resize-benchmark--phases nil
"Dynamically bound phase counters for the current measured publication.")
(defvar ebox-resize-benchmark--inside nil
"Non-nil inside the outer measured public viewport operation.")
(defun ebox-resize-benchmark--widths (minimum maximum step rounds initial)
"Build MINIMUMMAXIMUM sweeps using STEP and ROUNDS, returning to INITIAL.
Consecutive duplicate widths, which request no change, are omitted."
(unless (and (integerp minimum) (> minimum 0)
(integerp maximum) (> maximum minimum)
(integerp step) (> step 0)
(integerp rounds) (> rounds 0))
(error "Resize requires positive integer bounds, step and rounds; min < max"))
(let* ((ascending (number-sequence minimum maximum step))
(up (if (= (car (last ascending)) maximum) ascending
(append ascending (list maximum))))
(cycle (append up (cdr (reverse up))))
(previous initial) widths)
(dolist (width (append (apply #'append (make-list rounds cycle))
(list initial)))
(unless (= width previous) (push width widths))
(setq previous width))
(nreverse widths)))
(defun ebox-resize-benchmark--summary (values)
"Return count, p50, p95 and max for all numeric VALUES."
(when values
(let ((sorted (sort (copy-sequence values) #'<)))
(list :count (length values)
:p50-ms (nth (1- (ceiling (* .5 (length values)))) sorted)
:p95-ms (nth (1- (ceiling (* .95 (length values)))) sorted)
:max-ms (car (last sorted))))))
(defun ebox-resize-benchmark--condition (condition)
"Summarize CONDITION without printing arbitrary condition data."
(list :symbol (car condition)
:message (if (stringp (cadr condition))
(truncate-string-to-width (cadr condition) 512 nil nil t)
"Non-text condition data omitted")))
(defun ebox-resize-benchmark--hash-file (file)
"Return FILE's literal SHA-256."
(with-temp-buffer
(insert-file-contents-literally file)
(secure-hash 'sha256 (current-buffer))))
(defun ebox-resize-benchmark--file-evidence (file)
"Return canonical FILE and source paths with their literal hashes."
(let* ((path (file-truename file))
(source (if (string-suffix-p ".elc" path) (substring path 0 -1) path)))
(list :file path :sha256 (ebox-resize-benchmark--hash-file path)
:source (and (file-readable-p source) (file-truename source))
:source-sha256 (and (file-readable-p source)
(ebox-resize-benchmark--hash-file source)))))
(defun ebox-resize-benchmark--code (files)
"Reload explicitly supplied compiled FILES and report relevant code origins.
Never reload application declarations implicitly. Without FILES, origin and
disk hashes are observations, not proof that memory matches current bytecode."
(dolist (file files)
(unless (and (stringp file) (string-suffix-p ".elc" file)
(file-readable-p file)
(not (file-newer-than-file-p (substring file 0 -1) file)))
(error "Missing or stale compiled reload file: %s" file)))
(let ((reloads
(mapcar (lambda (file)
(let* ((evidence (ebox-resize-benchmark--file-evidence file))
(loaded (load (plist-get evidence :file) nil t t)))
(unless (equal evidence (ebox-resize-benchmark--file-evidence file))
(error "Reload file changed while loading: %s" file))
(append evidence (list :loaded (and loaded t))))) files)))
(list :reload-files reloads :functions
(mapcar
(lambda (symbol)
(let* ((origin (symbol-file symbol 'defun))
(source (and origin
(if (string-suffix-p ".elc" origin)
(substring origin 0 -1) origin))))
(unless (and origin (file-readable-p origin))
(error "No readable origin for resize function: %s" symbol))
(when (and (string-suffix-p ".elc" origin)
(file-newer-than-file-p source origin))
(error "Recompile stale resize bytecode: %s" origin))
(list :function symbol :origin origin
:origin-sha256 (ebox-resize-benchmark--hash-file origin)
:source-sha256 (and (file-readable-p source)
(ebox-resize-benchmark--hash-file source))
:reloaded (and (member (file-truename origin)
(mapcar #'file-truename files)) t))))
'(ebox-rerender-buffer-with-context ebox--window-size-change
ebox-surface-update-buffer-viewport
ebox-incremental-prepare-viewport-commit ebox-resize-benchmark-start)))))
(defun ebox-resize-benchmark--payload (buffer)
"Read bounded workload facts from BUFFER, without copying runtime graphs."
(let* ((state (and (buffer-live-p buffer) (ebox--buffer-render-state buffer)))
(nodes (plist-get state :node-table)))
(list :nodes (and (hash-table-p nodes) (hash-table-count nodes))
:characters (and (buffer-live-p buffer)
(with-current-buffer buffer (buffer-size)))
:viewport (list (plist-get state :viewport-width)
(plist-get state :viewport-height)))))
(defun ebox-resize-benchmark--guard ()
"Require the captured foreground buffer, frame, font and height."
(let* ((run ebox-resize-benchmark--run)
(frame (plist-get run :frame))
(window (plist-get run :window))
(buffer (plist-get run :buffer)))
(unless (and (frame-live-p frame) (display-graphic-p frame)
(eq frame (selected-frame)) (eq t (frame-visible-p frame))
(eq t (frame-focus-state frame)) (window-live-p window)
(eq window (selected-window))
(eq buffer (window-buffer window))
(ebox-surface-buffer-mounted-p buffer)
(equal (frame-parameter frame 'font) (plist-get run :font))
(= (frame-pixel-height frame) (plist-get run :height))
(not (active-minibuffer-window)))
(error "Resize target, focus, font, height or mount changed"))))
(defun ebox-resize-benchmark--phase (name original &rest arguments)
"Record inclusive NAME timing around ORIGINAL called with ARGUMENTS."
(if (not ebox-resize-benchmark--phases)
(apply original arguments)
(let ((started (float-time)) (gc-start gc-elapsed))
(unwind-protect (apply original arguments)
(let ((row (or (gethash name ebox-resize-benchmark--phases)
(puthash name (vector 0 0.0 0.0)
ebox-resize-benchmark--phases))))
(cl-incf (aref row 0))
(cl-incf (aref row 1) (* 1000 (- (float-time) started)))
(cl-incf (aref row 2) (* 1000 (- gc-elapsed gc-start))))))))
(defun ebox-resize-benchmark--write (file report)
"Write REPORT as UTF-8 data to a new FILE, without overwriting evidence."
(let ((coding-system-for-write 'utf-8-unix))
(with-temp-buffer
(prin1 report (current-buffer))
(insert "\n")
(write-region (point-min) (point-max) file nil 'silent nil 'excl))))
(defun ebox-resize-benchmark--finish (status &optional condition)
"Release owned resources and record STATUS and optional CONDITION."
(let ((run ebox-resize-benchmark--run))
(when run
;; Cleanup precedes report construction: even a dead buffer or write
;; failure cannot leave a timed benchmark attached to the application.
(setq ebox-resize-benchmark--run nil)
(dolist (key '(:timer :watchdog))
(when (timerp (plist-get run key)) (cancel-timer (plist-get run key))))
(advice-remove 'ebox-rerender-buffer-with-context
#'ebox-resize-benchmark--publication)
(dolist (binding (plist-get run :bindings))
(advice-remove (car binding) (cdr binding)))
(let* ((samples (nreverse (plist-get run :samples)))
(valid (and (eq status 'complete)
(= (length samples) (plist-get run :planned-count))
(cl-every (lambda (sample) (plist-get sample :published)) samples)))
(publication (ebox-resize-benchmark--summary
(delq nil (mapcar (lambda (s) (plist-get s :publication-ms)) samples))))
(latency (ebox-resize-benchmark--summary
(delq nil (mapcar (lambda (s) (plist-get s :request-to-published-ms)) samples))))
(report
(list :format-version 1 :status status :valid valid
:failure (and condition (ebox-resize-benchmark--condition condition))
:pid (emacs-pid) :emacs-version emacs-version
:system-type system-type :buffer (plist-get run :buffer-name)
:font (plist-get run :font) :height (plist-get run :height)
:range (plist-get run :range) :rounds (plist-get run :rounds)
:step (plist-get run :step) :delay (plist-get run :delay)
:requested-widths (plist-get run :widths)
:start-width (plist-get run :start-width)
:gc-before (plist-get run :gc-policy)
:gc-after (list gc-cons-threshold gc-cons-percentage)
:whole-run-gcs (- gcs-done (plist-get run :gcs))
:whole-run-gc-ms (* 1000 (- gc-elapsed (plist-get run :gc)))
:code (plist-get run :code) :native (plist-get run :native)
:payload-before (plist-get run :payload)
:payload-after (ebox-resize-benchmark--payload (plist-get run :buffer))
:planned-count (plist-get run :planned-count)
:requested-count (length samples)
:completed-count (cl-count-if (lambda (s) (plist-get s :published)) samples)
:publication publication :request-to-published latency
:limit-ms (plist-get run :limit)
:within-limit (and valid latency
(<= (plist-get latency :max-ms) (plist-get run :limit)))
:phase-columns '(calls inclusive-ms gc-ms)
:samples samples)))
(setq ebox-resize-benchmark--last-result report)
(condition-case write-error
(ebox-resize-benchmark--write (plist-get run :output) report)
((error quit)
(setq ebox-resize-benchmark--last-result
(plist-put report :evidence-write-error
(ebox-resize-benchmark--condition write-error)))
(setf (plist-get ebox-resize-benchmark--last-result :status) 'failed
(plist-get ebox-resize-benchmark--last-result :valid) nil
(plist-get ebox-resize-benchmark--last-result :within-limit) nil)
(message "Resize evidence could not be written: %s"
(plist-get (ebox-resize-benchmark--condition write-error) :message))
(unless condition (signal (car write-error) (cdr write-error)))))))))
(defun ebox-resize-benchmark--abort (condition)
"Record failure and clean up before re-signaling original CONDITION."
(condition-case report-error
(ebox-resize-benchmark--finish 'failed condition)
((error quit)
(message "Resize failure report unavailable: %s"
(plist-get (ebox-resize-benchmark--condition report-error) :message))))
(signal (car condition) (cdr condition)))
(defun ebox-resize-benchmark--schedule ()
"Schedule the next request after the configured event-loop delay."
(setf (plist-get ebox-resize-benchmark--run :timer)
(run-at-time (plist-get ebox-resize-benchmark--run :delay)
nil #'ebox-resize-benchmark--next)))
(defun ebox-resize-benchmark--timeout ()
"Fail a request that did not publish within its configured deadline."
(when ebox-resize-benchmark--run
(ebox-resize-benchmark--finish 'failed '(error "Resize publication timed out"))))
(defun ebox-resize-benchmark--settled ()
"Wait for the product's own GC lease to restore, without changing policy."
(when ebox-resize-benchmark--run
(condition-case condition
(progn
(ebox-resize-benchmark--guard)
(cond
((and (not ebox--deferred-render-gc-state)
(equal (list gc-cons-threshold gc-cons-percentage)
(plist-get ebox-resize-benchmark--run :gc-policy)))
(ebox-resize-benchmark--finish 'complete))
((>= (float-time) (plist-get ebox-resize-benchmark--run :settle-deadline))
(error "GC policy did not restore before the settle deadline"))
(t
(setf (plist-get ebox-resize-benchmark--run :timer)
(run-at-time .05 nil #'ebox-resize-benchmark--settled)))))
((error quit) (ebox-resize-benchmark--abort condition)))))
(defun ebox-resize-benchmark--publication (original buffer width &optional height)
"Measure ORIGINAL publishing BUFFER for WIDTH and HEIGHT."
(if (or ebox-resize-benchmark--inside (not ebox-resize-benchmark--run)
(not (plist-get ebox-resize-benchmark--run :armed))
(not (eq (get-buffer buffer) (plist-get ebox-resize-benchmark--run :buffer))))
(funcall original buffer width height)
(let* ((ebox-resize-benchmark--inside t)
(run ebox-resize-benchmark--run)
(sample (plist-get run :current))
(expected (and sample (not (plist-get sample :published))))
(phase-data (make-hash-table :test #'eq))
before-failure failure result completed)
(unwind-protect
(progn
(condition-case condition (ebox-resize-benchmark--guard)
(error (setq before-failure condition)))
(let ((started (float-time)) (cpu (current-cpu-time))
(gc gc-elapsed) (gcs gcs-done)
(policy (list gc-cons-threshold gc-cons-percentage)))
;; Attribution errors belong to this diagnostic, not the app.
;; Always execute the real call once and preserve its outcome.
(condition-case condition
(let ((ebox-resize-benchmark--phases phase-data))
(setq result (funcall original buffer width height)))
((error quit) (setq failure condition)))
(let ((finished (float-time)) (cpu-end (current-cpu-time))
(gc-end gc-elapsed) (gcs-end gcs-done))
;; An observer may cancel this run or start a replacement.
;; Never mutate a retired sample or schedule through a new run.
(when (eq run ebox-resize-benchmark--run)
(condition-case condition
(progn
(unless (and expected (eq sample (plist-get run :current)))
(error "Unattributed or duplicate publication during resize"))
(let ((payload (ebox-resize-benchmark--payload (get-buffer buffer)))
(window (plist-get run :window)) phases)
(maphash (lambda (name values) (push (cons name values) phases))
phase-data)
(setf (plist-get sample :publication-ms) (* 1000 (- finished started))
(plist-get sample :request-to-published-ms)
(* 1000 (- finished (plist-get sample :requested-at)))
(plist-get sample :cpu-ms)
(* 1000.0 (/ (- (car cpu-end) (car cpu)) (float (cdr cpu))))
(plist-get sample :gc-ms) (* 1000 (- gc-end gc))
(plist-get sample :gcs) (- gcs-end gcs)
(plist-get sample :gc-policy) policy
(plist-get sample :payload) payload
(plist-get sample :phases) phases
(plist-get sample :foreground-before) (not before-failure))
(when failure (signal (car failure) (cdr failure)))
(when before-failure (signal (car before-failure) (cdr before-failure)))
(ebox-resize-benchmark--guard)
(setf (plist-get sample :foreground-after) t)
(unless (and (= (frame-pixel-width (plist-get run :frame))
(plist-get sample :width))
(equal (list width height)
(list (ebox-viewport-window-width window)
(window-body-height window)))
(equal (list width height) (plist-get payload :viewport)))
(error "Requested, actual and published viewport dimensions disagree"))
(when (> finished (+ (plist-get sample :requested-at)
(plist-get run :timeout)))
(error "Resize publication exceeded its deadline"))
(setf (plist-get sample :published) t)
(cancel-timer (plist-get run :watchdog))
(setf (plist-get run :watchdog) nil)
(ebox-resize-benchmark--schedule)))
((error quit) (ebox-resize-benchmark--observation-failed run condition))))))
(setq completed t)
(if failure (signal (car failure) (cdr failure)) result))
(unless completed
(ebox-resize-benchmark--observation-failed
run '(error "Publication exited before observation completed")))))))
(defun ebox-resize-benchmark--observation-failed (run condition)
"Retire captured RUN with CONDITION without changing a product return value."
(when (eq run ebox-resize-benchmark--run)
(condition-case report-error
(ebox-resize-benchmark--finish 'failed condition)
((error quit)
(message "Resize failure report unavailable: %s"
(plist-get (ebox-resize-benchmark--condition report-error) :message))))))
(defun ebox-resize-benchmark--ready-p (run)
"Arm RUN after preceding rendering has released its GC lease."
(or (plist-get run :armed)
(cond
((>= (float-time) (plist-get run :ready-deadline))
(error "Preceding render did not settle before the startup deadline"))
(ebox--deferred-render-gc-state
(ebox-resize-benchmark--schedule)
nil)
(t
(setf (plist-get run :gc-policy) (list gc-cons-threshold gc-cons-percentage)
(plist-get run :gcs) gcs-done
(plist-get run :gc) gc-elapsed
(plist-get run :payload)
(ebox-resize-benchmark--payload (plist-get run :buffer))
(plist-get run :armed) t)))))
(defun ebox-resize-benchmark--next ()
"Issue one resize, then return to Emacs until its publication completes."
(when ebox-resize-benchmark--run
(condition-case condition
(let ((inhibit-quit nil))
(ebox-resize-benchmark--guard)
(let* ((run ebox-resize-benchmark--run)
(frame (plist-get run :frame))
(width (car (plist-get run :remaining))))
(setf (plist-get run :timer) nil)
(when (ebox-resize-benchmark--ready-p run)
(if (not width)
(progn
(setf (plist-get run :settle-deadline)
(+ (float-time) (plist-get run :timeout)))
(ebox-resize-benchmark--settled))
;; Allocate every mutable slot before sharing this record with
;; the publication callback: plist setters may replace a head
;; when adding a previously absent key.
(let ((sample (list :index (1+ (length (plist-get run :samples)))
:width width :requested-at (float-time)
:publication-ms nil :request-to-published-ms nil
:cpu-ms nil :gc-ms nil :gcs nil :gc-policy nil
:payload nil :phases nil :published nil
:foreground-before nil :foreground-after nil))
(frame-resize-pixelwise t))
(setf (plist-get run :remaining) (cdr (plist-get run :remaining))
(plist-get run :current) sample
(plist-get run :samples) (cons sample (plist-get run :samples))
(plist-get run :watchdog)
(run-at-time (plist-get run :timeout) nil
#'ebox-resize-benchmark--timeout))
(set-frame-size frame
(- width (- (frame-pixel-width frame)
(frame-text-width frame)))
(frame-text-height frame) t)
(redisplay t))))))
((error quit) (ebox-resize-benchmark--abort condition)))))
;;;###autoload
(cl-defun ebox-resize-benchmark-start
(buffer minimum maximum &key (step 32) (rounds 3) (delay .01)
(timeout 5.0) (limit-ms 50.0) output reload-files phases)
"Resize existing BUFFER from MINIMUM to MAXIMUM outer-frame pixels.
STEP and ROUNDS control repeated narrowwidenarrow sweeps. The final measured
request restores the starting width. OUTPUT must name a new evidence file.
DELAY spaces completed publications; TIMEOUT bounds startup and publication.
LIMIT-MS applies to all requestpublication samples, including GC and first use.
RELOAD-FILES explicitly reloads fresh compiled modules before measurement.
PHASES names loaded ebox-/tp-/etaf- functions for inclusive diagnostics.
Use `ebox-resize-benchmark-status' to poll and `ebox-resize-benchmark-cancel'
to stop. Failure stops at the current width. No frame or server is created,
no application observer is replaced, and no GC/font policy is changed."
(when ebox-resize-benchmark--run (error "A resize benchmark is already active"))
(unless (and (stringp output) (not (file-exists-p output))
(file-directory-p (file-name-directory (expand-file-name output)))
(numberp delay) (> delay 0) (numberp timeout) (> timeout delay)
(numberp limit-ms) (> limit-ms 0))
(error "Resize requires a new output path and positive delay/timeout/limit"))
(when (and (fboundp 'profiler-running-p) (profiler-running-p))
(error "Stop profiling before collecting resize latency"))
(dolist (name phases)
(unless (and (symbolp name) (fboundp name)
(string-match-p "\\`\\(?:ebox\\|tp\\|etaf\\)-" (symbol-name name))
(not (string-prefix-p "ebox-resize-benchmark-" (symbol-name name)))
(not (eq name 'ebox-rerender-buffer-with-context)))
(error "Invalid or duplicate outer measurement phase: %s" name)))
(let* ((target (get-buffer buffer))
(frame (selected-frame))
(initial (frame-pixel-width frame))
(widths (ebox-resize-benchmark--widths minimum maximum step rounds initial)))
(setq ebox-resize-benchmark--last-result nil
ebox-resize-benchmark--run
(list :buffer target :buffer-name (and target (buffer-name target))
:frame frame :window (selected-window)
:font (frame-parameter frame 'font) :height (frame-pixel-height frame)
:gc-policy (list gc-cons-threshold gc-cons-percentage)
:gcs gcs-done :gc gc-elapsed :code nil :native nil :payload nil
:start-width initial :widths widths :remaining widths
:planned-count (length widths) :range (list minimum maximum)
:rounds rounds :step step :delay delay :timeout timeout
:limit limit-ms :output (expand-file-name output)
:timer nil :watchdog nil :current nil :samples nil
:bindings nil :settle-deadline nil :armed nil :ready-deadline nil))
(condition-case condition
(progn
(ebox-resize-benchmark--guard)
(setf (plist-get ebox-resize-benchmark--run :code)
(ebox-resize-benchmark--code reload-files)
(plist-get ebox-resize-benchmark--run :native)
(and (fboundp 'ebox-native-reflow-runtime-report)
(ebox-native-reflow-runtime-report))
(plist-get ebox-resize-benchmark--run :payload)
(ebox-resize-benchmark--payload target)
(plist-get ebox-resize-benchmark--run :gcs) gcs-done
(plist-get ebox-resize-benchmark--run :gc) gc-elapsed)
(ebox-resize-benchmark--guard)
(setf (plist-get ebox-resize-benchmark--run :ready-deadline)
(+ (float-time) timeout))
(dolist (name (delete-dups (copy-sequence phases)))
(let ((wrapper (apply-partially #'ebox-resize-benchmark--phase name)))
(push (cons name wrapper) (plist-get ebox-resize-benchmark--run :bindings))
(advice-add name :around wrapper)))
(advice-add 'ebox-rerender-buffer-with-context :around
#'ebox-resize-benchmark--publication)
(ebox-resize-benchmark--schedule)
(ebox-resize-benchmark-status))
((error quit) (ebox-resize-benchmark--abort condition)))))
;;;###autoload
(defun ebox-resize-benchmark-status ()
"Return bounded progress or the last run's completion/latency summary."
(if ebox-resize-benchmark--run
(list :status 'running
:requested (length (plist-get ebox-resize-benchmark--run :samples))
:planned (plist-get ebox-resize-benchmark--run :planned-count)
:output (plist-get ebox-resize-benchmark--run :output))
(cl-loop for key in '(:status :valid :failure :completed-count :planned-count
:publication :request-to-published :within-limit
:evidence-write-error)
append (list key (plist-get ebox-resize-benchmark--last-result key)))))
;;;###autoload
(defun ebox-resize-benchmark-cancel ()
"Stop this benchmark and release its timers and advice."
(interactive)
(ebox-resize-benchmark--finish 'cancelled '(quit "Resize cancelled"))
(ebox-resize-benchmark-status))
(provide 'benchmark-ebox-resize)
;;; benchmark-ebox-resize.el ends here

View File

@ -0,0 +1,142 @@
;;; benchmark-scheduler-context.el --- ETAF dispatcher microbenchmark -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Runs the M3a T6 fixed scheduler scenario: 40 changed sources fan out to one
;; Effect in each of four isolated contexts. Five warmups precede thirty timed
;; samples. Exact work counters and a 50 ms p95/max gate make the result useful
;; as a small dispatcher regression baseline; product GUI performance is a
;; separate end-to-end gate.
;;; Code:
(require 'cl-lib)
(require 'etaf)
(defconst etaf-scheduler-benchmark-warmups 5)
(defconst etaf-scheduler-benchmark-samples 30)
(defconst etaf-scheduler-benchmark-source-count 40)
(defconst etaf-scheduler-benchmark-context-count 4)
(defconst etaf-scheduler-benchmark-limit-ms 50.0)
(defun etaf-scheduler-benchmark--percentile (values percentile)
"Return nearest-rank PERCENTILE from numeric VALUES."
(let* ((ordered (sort (copy-sequence values) #'<))
(rank (max 1 (ceiling (* percentile (length ordered))))))
(nth (1- rank) ordered)))
(defun etaf-scheduler-benchmark--metric-total (contexts key)
"Return the sum of metric KEY across scheduler CONTEXTS."
(cl-loop for context in contexts
sum (or (plist-get (etaf-scheduler-context-metrics context) key)
0)))
(defun etaf-scheduler-benchmark--iteration (sources iteration)
"Publish ITERATION through all reactive SOURCES once."
(etaf-reactive-call-with-batch
(lambda ()
(cl-loop for source in sources
for index from 0
do (setf (etaf-value source)
(+ (* iteration 1000) index))))))
;;;###autoload
(defun etaf-scheduler-benchmark-run ()
"Run the fixed scheduler benchmark, print its result, and return it."
(let* ((contexts
(cl-loop for index below etaf-scheduler-benchmark-context-count
collect
(etaf-scheduler-context-create
:name (list 'benchmark index))))
(sources
(cl-loop repeat etaf-scheduler-benchmark-source-count
collect (etaf-ref 0)))
effects durations result)
(unwind-protect
(progn
(dolist (context contexts)
(let ((effect
(etaf-scheduler-call-with-context
context
(lambda ()
(etaf-reactive-effect-create
(lambda () (mapcar #'etaf-value sources)))))))
(push effect effects)
(etaf-reactive-effect-run effect)))
(dotimes (index etaf-scheduler-benchmark-warmups)
(etaf-scheduler-benchmark--iteration sources (1+ index)))
(let ((source-before
(etaf-scheduler-benchmark--metric-total
contexts :source-enqueues))
(visit-before
(etaf-scheduler-benchmark--metric-total
contexts :subscriber-visits))
(effect-before
(etaf-scheduler-benchmark--metric-total
contexts :effect-evaluations))
(turn-before
(etaf-scheduler-benchmark--metric-total
contexts :turn-count)))
(dotimes (index etaf-scheduler-benchmark-samples)
(let ((started (float-time)))
(etaf-scheduler-benchmark--iteration
sources (+ etaf-scheduler-benchmark-warmups index 1))
(push (* 1000.0 (- (float-time) started)) durations)))
(setq durations (nreverse durations))
(let* ((expected-source-work
(* etaf-scheduler-benchmark-samples
etaf-scheduler-benchmark-source-count
etaf-scheduler-benchmark-context-count))
(expected-context-work
(* etaf-scheduler-benchmark-samples
etaf-scheduler-benchmark-context-count))
(source-work
(- (etaf-scheduler-benchmark--metric-total
contexts :source-enqueues)
source-before))
(subscriber-visits
(- (etaf-scheduler-benchmark--metric-total
contexts :subscriber-visits)
visit-before))
(effect-work
(- (etaf-scheduler-benchmark--metric-total
contexts :effect-evaluations)
effect-before))
(turn-work
(- (etaf-scheduler-benchmark--metric-total
contexts :turn-count)
turn-before))
(p95
(etaf-scheduler-benchmark--percentile durations 0.95))
(maximum (apply #'max durations)))
(unless (and (= source-work expected-source-work)
(= subscriber-visits expected-source-work)
(= effect-work expected-context-work)
(= turn-work expected-context-work))
(error "Scheduler work counters diverged: %S"
(list source-work subscriber-visits
effect-work turn-work)))
(setq result
(list
:scenario 'scheduler-40-sources-4-contexts
:warmups etaf-scheduler-benchmark-warmups
:samples etaf-scheduler-benchmark-samples
:p95-ms p95 :max-ms maximum
:source-enqueues source-work
:subscriber-visits subscriber-visits
:effect-evaluations effect-work
:turns turn-work))
(when (or (> p95 etaf-scheduler-benchmark-limit-ms)
(> maximum etaf-scheduler-benchmark-limit-ms))
(error "Scheduler benchmark exceeds %.1f ms: %S"
etaf-scheduler-benchmark-limit-ms result)))))
(dolist (effect effects) (etaf--stop-effect effect)))
(prin1 result)
(terpri)
result))
(provide 'benchmark-scheduler-context)
;;; benchmark-scheduler-context.el ends here

69
scripts/capture-emacs-window.sh Executable file
View File

@ -0,0 +1,69 @@
#!/bin/sh
# Select an owned frame each time: fullscreen transitions can replace its
# WindowServer ID. Never fall back to capturing the desktop.
set -eu
usage() {
echo "usage: $0 --window-id PID | -x OUTPUT" >&2
exit 2
}
window_id() {
case $1 in
''|*[!0-9]*) echo "invalid Emacs capture PID: $1" >&2; return 1 ;;
esac
[ "$1" -gt 1 ] && kill -0 "$1" 2>/dev/null || {
echo "Emacs capture process is not alive: $1" >&2
return 1
}
osascript -l JavaScript - "$1" <<'JXA'
ObjC.import("CoreGraphics");
function run(argv) {
var pid = Number(argv[0]);
var windows = ObjC.deepUnwrap(ObjC.castRefToObject(
$.CGWindowListCopyWindowInfo($.kCGWindowListOptionAll,
$.kCGNullWindowID)));
var candidates = windows.filter(function (window) {
var bounds = window.kCGWindowBounds;
return window.kCGWindowOwnerPID === pid &&
window.kCGWindowOwnerName === "Emacs" &&
window.kCGWindowLayer === 0 && window.kCGWindowAlpha > 0 &&
window.kCGWindowName && bounds &&
bounds.Width > 0 && bounds.Height > 0;
});
candidates.sort(function (a, b) {
return b.kCGWindowBounds.Width * b.kCGWindowBounds.Height -
a.kCGWindowBounds.Width * a.kCGWindowBounds.Height;
});
if (!candidates.length) {
throw new Error("No named Emacs frame owned by PID " + pid);
}
if (candidates.length > 1 &&
candidates[0].kCGWindowBounds.Width * candidates[0].kCGWindowBounds.Height ===
candidates[1].kCGWindowBounds.Width * candidates[1].kCGWindowBounds.Height) {
throw new Error("Ambiguous largest Emacs frame for PID " + pid);
}
return String(candidates[0].kCGWindowNumber);
}
JXA
}
[ "$#" -eq 2 ] || usage
case $1 in
--window-id) window_id "$2" ;;
-x)
GUI_CAPTURE_PID=${ETAF_GUI_CAPTURE_PID:?ETAF_GUI_CAPTURE_PID is required}
GUI_CAPTURE_ID=$(window_id "$GUI_CAPTURE_PID")
GUI_CAPTURE_BIN=${ETAF_GUI_SCREENCAPTURE:-/usr/sbin/screencapture}
"$GUI_CAPTURE_BIN" -l "$GUI_CAPTURE_ID" -o -x "$2"
# Reject a capture made while macOS replaced the intended frame.
GUI_CAPTURE_AFTER=$(window_id "$GUI_CAPTURE_PID")
if [ "$GUI_CAPTURE_ID" != "$GUI_CAPTURE_AFTER" ]; then
rm -f -- "$2"
echo "Emacs frame changed during screenshot; capture again" >&2
exit 1
fi
;;
*) usage ;;
esac

View File

@ -0,0 +1,329 @@
;;; emacs-gui-verifier.el --- Generic temporal GUI scenario engine -*- lexical-binding: t; -*-
;;; Commentary:
;; This developer tool executes declarative GUI scenarios against any Emacs
;; buffer. It owns action ordering, checkpoint phases, target-buffer guards,
;; completion, and evidence lifecycle. It does not know ETAF Runtime, Ebox,
;; Playground, or any concrete example; adapters supply those facts through
;; callbacks and opaque context data.
;;; Code:
(require 'cl-lib)
(declare-function emacs-dynamic-ui-verification-start
"capture-checkpoint" (directory run-id claim required-phases))
(declare-function emacs-dynamic-ui-verification-checkpoint
"capture-checkpoint"
(action-id phase adapter assertions screenshot))
(declare-function emacs-dynamic-ui-verification-finish
"capture-checkpoint" (completed adapter))
(cl-defstruct (etaf-gui-verifier-action
(:constructor etaf-gui-verifier-action-create))
"One ordered GUI action and its postcondition callback."
id execute assertions screenshot settled-p
(settle-timeout 5.0) (settle-interval 0.05))
(cl-defstruct (etaf-gui-verifier-scenario
(:constructor etaf-gui-verifier-scenario-create))
"One reusable GUI scenario assembled by an adapter."
name claim initialize actions invariants adapter completion)
(cl-defstruct (etaf-gui-verifier-context
(:constructor etaf-gui-verifier--context-create))
"Mutable execution state owned only by one verifier run."
scenario target-buffer data (action-count 0) (last-duration-ms 0.0)
measurements)
(defun etaf-gui-verifier-context-put (context key value)
"Store adapter VALUE for KEY in CONTEXT and return VALUE."
(setf (alist-get key (etaf-gui-verifier-context-data context)) value)
value)
(defun etaf-gui-verifier-context-get (context key &optional default)
"Return CONTEXT adapter value KEY, or DEFAULT when absent."
(alist-get key (etaf-gui-verifier-context-data context) default))
(defun etaf-gui-verifier--measurement-state (context)
"Return CONTEXT's live identities followed by JSON-safe GUI facts."
(let* ((frame (selected-frame))
(window (selected-window))
(target (etaf-gui-verifier-context-target-buffer context))
(selected-buffer (window-buffer window))
(focus (frame-focus-state frame)))
(cons
(list frame window target selected-buffer)
`((graphic . ,(and (display-graphic-p frame) t))
(focus . ,(cond ((eq focus t) "foreground")
((null focus) "background")
(t "unknown")))
(frame_name . ,(frame-parameter frame 'name))
(frame_window_id . ,(frame-parameter frame 'window-id))
(frame_visible . ,(pcase (frame-visible-p frame)
('t "visible") ('icon "icon") (_ "hidden")))
(target_buffer . ,(and (buffer-live-p target) (buffer-name target)))
(selected_buffer . ,(buffer-name selected-buffer))
(target_selected . ,(and (buffer-live-p target)
(eq target selected-buffer)))
(font . ,(format "%s" (frame-parameter frame 'font)))
(frame_width_px . ,(frame-pixel-width frame))
(frame_height_px . ,(frame-pixel-height frame))
(window_edges_px . ,(vconcat (window-pixel-edges window)))
(inhibit_quit . ,(and inhibit-quit t))
(inhibit_redisplay . ,(and inhibit-redisplay t))
(noninteractive . ,(and noninteractive t))))))
(defun etaf-gui-verifier-measure-action (context action &optional require-foreground)
"Measure ACTION's execute callback once with CONTEXT; return its exact result.
Retain a JSON-safe measurement in CONTEXT's measurements, newest first,
including failed or quit callbacks, and update the legacy last duration.
Wall/CPU/GC timing covers only the callback, excluding GUI-state snapshots and
the verifier's later checkpoints, redisplay, and settling. Calls made inside
the callback are included. No focus or execution bindings change.
With REQUIRE-FOREGROUND, reject a non-graphical, unfocused, unknown, hidden,
or unselected target before invoking the callback. Rejection retains an
untimed record and clears the legacy duration. Changes to frame/window/buffer
identities, graphical display, focus, visibility, native window ID, target
selection, font, frame pixel size, or window pixel edges invalidate the record
and, when foreground is required, signal after a successful callback. Frame
and buffer names and execution bindings are diagnostic observations, not
identity guards. Callback errors and quits propagate with their original data.
A closing snapshot quit is recorded and propagated after a successful callback,
but never replaces an existing callback error or quit.
Background callbacks are allowed by default and labeled accordingly. A
valid record requires a successful callback with a live selected target in
an unchanged environment; even a foreground record does not certify
input-to-presentation latency."
(let* ((before (etaf-gui-verifier--measurement-state context))
(facts (cdr before))
(foreground (if (alist-get 'graphic facts)
(alist-get 'focus facts)
"unknown"))
(status "rejected")
started cpu-start gc-start gcs-start result changed snapshot-quit)
(unwind-protect
(progn
(when (and require-foreground
(not (and (equal foreground "foreground")
(equal (alist-get 'frame_visible facts) "visible")
(alist-get 'target_selected facts))))
(error "GUI action requires a selected foreground target: %s"
(etaf-gui-verifier-action-id action)))
(setq cpu-start (current-cpu-time)
gc-start gc-elapsed
gcs-start gcs-done
started (float-time))
(condition-case condition
(progn
(setq result
(funcall (etaf-gui-verifier-action-execute action) context)
status "success"))
((error quit)
(setq status (if (eq (car condition) 'quit) "quit" "error"))
(signal (car condition) (cdr condition)))))
(let* ((finished (and started (float-time)))
(cpu-end (and started (current-cpu-time)))
(gc-end gc-elapsed)
(gcs-end gcs-done)
(wall-ms (and started (* 1000.0 (- finished started))))
;; Snapshot failure must not replace an action's error or quit.
(after (and started
(condition-case condition
(etaf-gui-verifier--measurement-state context)
(quit (setq snapshot-quit condition) nil)
(error nil)))))
(setq changed
(and started
(or (not (equal (car before) (car after)))
(cl-some
(lambda (key)
(not (equal (alist-get key facts)
(alist-get key (cdr after)))))
'(graphic focus frame_visible frame_window_id
target_selected font frame_width_px frame_height_px
window_edges_px)))))
(when (and snapshot-quit (equal status "success"))
(setq status "quit"))
(when (and changed require-foreground (equal status "success"))
(setq status "invalid"))
(setf (etaf-gui-verifier-context-last-duration-ms context) wall-ms)
(push
`((action_id . ,(etaf-gui-verifier-action-id action))
(boundary . "action.execute callback")
(presentation_measured . nil)
(status . ,status)
(valid . ,(and (equal status "success") (not changed)
(alist-get 'target_selected facts)))
(foreground . ,(if changed "changed" foreground))
(foreground_required . ,(and require-foreground t))
(wall_ms . ,wall-ms)
(cpu_ms . ,(and cpu-end
(* 1000.0
(- (/ (float (car cpu-end)) (cdr cpu-end))
(/ (float (car cpu-start)) (cdr cpu-start))))))
(gc_count . ,(and started (- gcs-end gcs-start)))
(gc_ms . ,(and started (* 1000.0 (- gc-end gc-start))))
(before . ,facts)
(after . ,(cdr after)))
(etaf-gui-verifier-context-measurements context))))
;; An action's nonlocal failure bypasses this point and keeps precedence.
(when snapshot-quit
(signal (car snapshot-quit) (cdr snapshot-quit)))
(when (equal status "invalid")
(error "GUI action environment changed during callback: %s"
(etaf-gui-verifier-action-id action)))
result))
(defun etaf-gui-verifier-context-select-buffer (context buffer)
"Select live BUFFER as CONTEXT's single-window target."
(unless (buffer-live-p buffer)
(error "GUI verifier target buffer is not live"))
(setf (etaf-gui-verifier-context-target-buffer context) buffer)
(switch-to-buffer buffer)
(delete-other-windows)
buffer)
(defun etaf-gui-verifier-assert (name passed &optional detail)
"Return one normalized assertion NAME for PASSED and optional DETAIL."
(append (list (cons 'name name) (cons 'passed (and passed t)))
(when detail (list (cons 'detail detail)))))
(defun etaf-gui-verifier--target-assertions (context)
"Return generic selected-target assertions for CONTEXT."
(let ((buffer (etaf-gui-verifier-context-target-buffer context)))
(list
(etaf-gui-verifier-assert
"target-buffer-selected"
(and (buffer-live-p buffer)
(eq (window-buffer (selected-window)) buffer))))))
(defun etaf-gui-verifier--scenario-assertions (context)
"Return generic and adapter assertions for CONTEXT."
(let* ((scenario (etaf-gui-verifier-context-scenario context))
(function (etaf-gui-verifier-scenario-invariants scenario)))
(append
(etaf-gui-verifier--target-assertions context)
(and function (funcall function context)))))
(defun etaf-gui-verifier--adapter-data (context)
"Return generic and adapter JSON data for CONTEXT."
(let* ((scenario (etaf-gui-verifier-context-scenario context))
(function (etaf-gui-verifier-scenario-adapter scenario)))
(append
(list
(cons 'scenario (etaf-gui-verifier-scenario-name scenario))
(cons 'action_count
(etaf-gui-verifier-context-action-count context))
(cons 'duration_ms
(etaf-gui-verifier-context-last-duration-ms context))
(cons 'last_measurement
(car (etaf-gui-verifier-context-measurements context))))
(and function (funcall function context)))))
(defun etaf-gui-verifier--checkpoint
(context action-id phase screenshot &optional extra)
"Capture CONTEXT ACTION-ID PHASE with SCREENSHOT and EXTRA assertions."
(emacs-dynamic-ui-verification-checkpoint
action-id phase
(etaf-gui-verifier--adapter-data context)
(append (etaf-gui-verifier--scenario-assertions context) extra)
screenshot))
(defun etaf-gui-verifier--settle-action (context action)
"Wait until ACTION's visible result is settled in CONTEXT."
(let ((settled-p (etaf-gui-verifier-action-settled-p action))
(timeout (etaf-gui-verifier-action-settle-timeout action))
(interval (etaf-gui-verifier-action-settle-interval action)))
(unless settled-p
(error "GUI action has no settle predicate: %s"
(etaf-gui-verifier-action-id action)))
(unless (and (numberp timeout) (> timeout 0))
(error "GUI action settle timeout must be positive: %s"
(etaf-gui-verifier-action-id action)))
(unless (and (numberp interval) (> interval 0))
(error "GUI action settle interval must be positive: %s"
(etaf-gui-verifier-action-id action)))
;; Always complete at least one redisplay before accepting a predicate.
;; A predicate proves adapter state, not that Emacs painted that state.
(redisplay t)
(sit-for 0)
(let ((deadline
(+ (float-time) timeout))
settled)
(while (not settled)
(when (>= (float-time) deadline)
(error "GUI action did not settle before timeout: %s"
(etaf-gui-verifier-action-id action)))
(if (funcall settled-p context)
;; Require the same postcondition across one event/paint turn.
;; Runtime state can be synchronous while the GUI compositor still
;; presents the preceding frame.
(progn
(sit-for interval)
(redisplay t)
(setq settled (funcall settled-p context)))
(sit-for interval)
(redisplay t))))))
(defun etaf-gui-verifier--run-action (context action)
"Execute ACTION once inside CONTEXT's ordered checkpoint protocol."
(let ((action-id (etaf-gui-verifier-action-id action))
(assertions (etaf-gui-verifier-action-assertions action)))
(etaf-gui-verifier--checkpoint
context action-id "before-action" nil)
(etaf-gui-verifier-measure-action context action)
(cl-incf (etaf-gui-verifier-context-action-count context))
(etaf-gui-verifier--checkpoint
context action-id "after-action" nil)
(etaf-gui-verifier--settle-action context action)
(etaf-gui-verifier--checkpoint
context action-id "after-redisplay"
(etaf-gui-verifier-action-screenshot action)
(and assertions (funcall assertions context)))))
;;;###autoload
(defun etaf-gui-verifier-run (scenario run-directory)
"Execute generic SCENARIO and write temporal evidence to RUN-DIRECTORY."
(unless (etaf-gui-verifier-scenario-p scenario)
(signal 'wrong-type-argument
(list 'etaf-gui-verifier-scenario-p scenario)))
(let* ((context
(etaf-gui-verifier--context-create :scenario scenario))
(initialize (etaf-gui-verifier-scenario-initialize scenario))
(completion (etaf-gui-verifier-scenario-completion scenario))
finished-p)
(emacs-dynamic-ui-verification-start
run-directory
(etaf-gui-verifier-scenario-name scenario)
(etaf-gui-verifier-scenario-claim scenario)
'("before-action" "after-action" "after-redisplay"))
(condition-case error-data
(progn
(when initialize (funcall initialize context))
(dolist (action (etaf-gui-verifier-scenario-actions scenario))
(etaf-gui-verifier--run-action context action))
(let ((completed (if completion
(funcall completion context)
t)))
(emacs-dynamic-ui-verification-finish
completed (etaf-gui-verifier--adapter-data context))
(setq finished-p t)
(unless completed
(error "GUI scenario completion predicate failed")))
context)
((error quit)
(unless finished-p
(condition-case finish-error
(emacs-dynamic-ui-verification-finish
nil (etaf-gui-verifier--adapter-data context))
(error
(message "GUI verifier could not record failed completion: %s"
(error-message-string finish-error)))))
(signal (car error-data) (cdr error-data))))))
(provide 'emacs-gui-verifier)
;;; emacs-gui-verifier.el ends here

View File

@ -0,0 +1,315 @@
;;; etaf-m0a-inventory.el --- M0a current-contract inventory -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; This is a read-only M0a inventory surface. It records current contracts,
;; known pre-activation baselines, and the condition handlers present in ETAF
;; source files. It intentionally does not turn future architecture targets
;; into passing assertions.
;;; Code:
(require 'cl-lib)
(require 'etaf)
(require 'json)
(require 'macroexp)
(defconst etaf-m0a-package-root
(file-name-directory
(directory-file-name
(file-name-directory (or load-file-name buffer-file-name))))
"Absolute ETAF package root inferred when this inventory is loaded.")
(defconst etaf-m0a-current-contract-inventory
'((:id component-definition
:evidence-mode current-contract
:summary ":view or :render is required; :setup/:styles are optional"
:tests (etaf-component-frontends-definition-boundary-is-strict
etaf-component-definition-keywords-have-one-owner))
(:id host-attrs
:evidence-mode current-contract
:summary "undeclared Host attrs fall through a single-root Component chain"
:tests (etaf-component-host-attrs-fall-through-one-root-chain
etaf-component-host-attrs-reject-ambiguous-or-invalid-targets
etaf-component-host-attrs-rollback-root-shape-failure))
(:id slots-key-lifecycle-rollback
:evidence-mode current-contract
:summary "slots retain caller ownership; key is framework-owned; lifecycle and rollback are ordered"
:tests (etaf-component-frontends-project-default-and-named-slots
etaf-component-key-is-framework-owned-and-render-result-is-typed
etaf-component-lifecycle-and-scope-cleanup-are-ordered
etaf-component-render-side-effect-rolls-back-completely))
(:id action-registration
:evidence-mode observed-baseline
:activation-milestone M0b
:owner etaf-actions
:summary "registering an existing Action name replaces the current spec"
:tests (etaf-m0a-action-registration-replaces-current-definition))
(:id behavior-duplicates
:evidence-mode observed-baseline
:activation-milestone M0b
:owner etaf-runtime
:summary "same-name Behaviors are currently processed in declaration order; no pre-install duplicate gate exists"
:tests (etaf-runtime-composes-host-and-behavior-events-in-order
etaf-behavior-replacement-disposes-previous-installer))
(:id event-rules
:evidence-mode current-contract
:summary "event names normalize keyword/symbol/string on-* spellings; Host callback precedes Behavior callback"
:tests (etaf-m0a-event-kind-normalizes-current-spellings
etaf-runtime-composes-host-and-behavior-events-in-order))
(:id dependency-only-publication
:evidence-mode current-contract
:summary "semantic generation advances without Ebox commit or TP surface revision"
:tests (etaf-m0a-dependency-only-skips-ebox-and-tp-publication))
(:id initial-attach
:evidence-mode current-contract
:summary "initial observed publication reports TP, Ebox, then ETAF"
:tests (etaf-runtime-observer-covers-initial-publication))
(:id unmount-kill
:evidence-mode current-contract
:summary "unmount disposes lifecycle before scope cleanup; kill follows unmount; repeated public unmount signals"
:tests (etaf-component-lifecycle-and-scope-cleanup-are-ordered
etaf-runtime-killed-buffer-unmounts-owned-scope
etaf-m0a-repeated-public-unmount-signals-runtime-error))
(:id condition-trailer
:evidence-mode current-contract
:activation-milestone M3a
:owner etaf-runtime
:summary "postcommit errors preserve the raw condition symbol/data prefix and append the v1 committed trailer"
:tests (etaf-m0a-public-update-preserves-raw-condition-symbol-and-data))
(:id document-examples
:evidence-mode observed-baseline
:activation-milestone M0b
:owner etaf-documentation
:summary "all user-facing fenced Elisp blocks have reviewed read, macroexpand, load-safety, and drift outcomes"
:tests (etaf-m0a-document-example-inventory-matches-reviewed-golden)))
"Machine-readable M0a ledger for ETAF current behavior and future gates.")
(defconst etaf-m0a-document-example-files
'("README.md"
"README.zh-CN.md"
"examples/README.md"
"examples/README.zh-CN.md"
"docs/architecture.en.md"
"docs/architecture.zh.md"
"docs/user-guide.en.md"
"docs/user-guide.zh.md"
"docs/implementation-plan.en.md"
"docs/implementation-plan.zh.md")
"User-facing documents whose fenced Elisp blocks belong to M0a inventory.")
(defun etaf-m0a--condition-handler-symbols (clause)
"Return the condition symbols handled by `condition-case' CLAUSE."
(let ((head (car-safe clause)))
(cond
((symbolp head) (list head))
((proper-list-p head) (cl-remove-if-not #'symbolp head))
(t nil))))
(defun etaf-m0a--condition-policy (conditions)
"Return the current handling policy for CONDITIONS."
(if (cl-every (lambda (condition) (memq condition '(error quit))) conditions)
'generic-containment
'specific-compatibility))
(defun etaf-m0a--walk-condition-consumers (form file line)
"Return condition consumer records below FORM from FILE at LINE."
(let (records)
(when (consp form)
(unless (memq (car form) '(quote function))
(when (memq (car form) '(condition-case condition-case-unless-debug))
(dolist (clause (cdddr form))
(let ((conditions (etaf-m0a--condition-handler-symbols clause)))
(when conditions
(push (list :file file :line line :form (car form)
:conditions conditions
:owner (intern (file-name-base file))
:policy (etaf-m0a--condition-policy conditions))
records)))))
(setq records
(nconc records
(etaf-m0a--walk-condition-consumers
(car form) file line)
(etaf-m0a--walk-condition-consumers
(cdr form) file line)))))
records))
(defun etaf-m0a-condition-consumer-inventory (&optional directory)
"Return condition consumers in top-level ETAF sources under DIRECTORY.
DIRECTORY defaults to the package root inferred from this script. Test and
example files are excluded so this inventory describes product consumers."
(let* ((root (file-name-as-directory
(expand-file-name
(or directory etaf-m0a-package-root))))
(files (sort (directory-files root t "\\`etaf-.*\\.el\\'")
#'string<))
records)
(dolist (file files)
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(condition-case nil
(while t
(let ((line (line-number-at-pos))
(form (read (current-buffer))))
(setq records
(nconc records
(etaf-m0a--walk-condition-consumers
form (file-relative-name file root) line)))))
(end-of-file nil))))
(sort records
(lambda (left right)
(or (string< (plist-get left :file) (plist-get right :file))
(and (equal (plist-get left :file) (plist-get right :file))
(< (plist-get left :line) (plist-get right :line))))))))
(defun etaf-m0a-condition-consumer-signatures (&optional directory)
"Return stable golden signatures for source consumers under DIRECTORY.
Line numbers remain available in the diagnostic inventory but are excluded
from this signature so unrelated line movement does not rewrite the golden."
(mapcar
(lambda (entry)
(list :file (plist-get entry :file)
:form (plist-get entry :form)
:conditions (plist-get entry :conditions)
:owner (plist-get entry :owner)
:policy (plist-get entry :policy)))
(etaf-m0a-condition-consumer-inventory directory)))
(defun etaf-m0a--document-elisp-blocks (file root)
"Return fenced Elisp blocks from FILE below ROOT."
(with-temp-buffer
(insert-file-contents (expand-file-name file root))
(goto-char (point-min))
(let ((index 0) blocks)
(while (re-search-forward "^```elisp[[:space:]]*$" nil t)
(let ((line (line-number-at-pos))
(start (line-beginning-position 2)))
(unless (re-search-forward "^```[[:space:]]*$" nil t)
(error "Unclosed Elisp block in %s" file))
(cl-incf index)
(push (list :index index :line line
:source (buffer-substring-no-properties
start (match-beginning 0)))
blocks)))
(nreverse blocks))))
(defun etaf-m0a--read-document-forms (source)
"Read all forms from documentation SOURCE and return a result plist."
(with-temp-buffer
(emacs-lisp-mode)
(insert source)
(goto-char (point-min))
(let (forms failure)
(condition-case condition
(while (progn
(skip-chars-forward " \t\r\n")
(< (point) (point-max)))
(push (read (current-buffer)) forms))
(error (setq failure (car condition))))
(if failure
(list :status 'error :detail failure :forms nil)
(list :status 'ok :detail (length forms) :forms (nreverse forms))))))
(defun etaf-m0a--macroexpand-document-forms (forms)
"Macroexpand FORMS and return a stable outcome plist."
(condition-case condition
(progn
(mapc #'macroexpand-all forms)
(list :status 'ok :detail (length forms)))
(error (list :status 'error :detail (car condition)))))
(defun etaf-m0a-document-example-inventory (&optional directory)
"Return current read/macroexpand/load outcomes for user documentation.
DIRECTORY defaults to `etaf-m0a-package-root'.
Arbitrary documentation code is never evaluated in the agent process: it may
mount buffers, mutate files, start async work, or depend on user state. Every
block therefore has an explicit skipped load outcome and safety reason."
(let ((root (file-name-as-directory
(expand-file-name (or directory etaf-m0a-package-root)))))
(mapcar
(lambda (file)
(list
:file file
:blocks
(mapcar
(lambda (block)
(let* ((source (plist-get block :source))
(read-result (etaf-m0a--read-document-forms source))
(macro-result
(if (eq 'ok (plist-get read-result :status))
(etaf-m0a--macroexpand-document-forms
(plist-get read-result :forms))
(list :status 'skipped :detail 'read-failed)))
(drift
(cond
((eq 'error (plist-get read-result :status)) 'read-error)
((eq 'error (plist-get macro-result :status))
'macroexpand-error)
(t 'none))))
(list :index (plist-get block :index)
:line (plist-get block :line)
:sha256 (secure-hash 'sha256 source)
:read-status (plist-get read-result :status)
:read-detail (plist-get read-result :detail)
:macroexpand-status (plist-get macro-result :status)
:macroexpand-detail (plist-get macro-result :detail)
:load-status 'skipped-unsafe
:load-reason 'arbitrary-document-code
:drift drift)))
(etaf-m0a--document-elisp-blocks file root))))
etaf-m0a-document-example-files)))
(defun etaf-m0a-document-example-signatures (&optional directory)
"Return stable golden signatures for documentation under DIRECTORY."
(mapcar
(lambda (file-entry)
(list
:file (plist-get file-entry :file)
:blocks
(mapcar
(lambda (block)
(list (plist-get block :index)
(plist-get block :sha256)
(plist-get block :read-status)
(plist-get block :read-detail)
(plist-get block :macroexpand-status)
(plist-get block :macroexpand-detail)
(plist-get block :load-status)
(plist-get block :load-reason)
(plist-get block :drift)))
(plist-get file-entry :blocks))))
(etaf-m0a-document-example-inventory directory)))
(defun etaf-m0a-inventory-json (&optional directory)
"Return the current M0a ledger and condition inventory as JSON.
DIRECTORY is forwarded to `etaf-m0a-condition-consumer-inventory'."
(json-encode
(list :schema-version 1
:contract-inventory (vconcat etaf-m0a-current-contract-inventory)
:condition-consumers
(vconcat (etaf-m0a-condition-consumer-inventory directory))
:document-examples
(vconcat
(mapcar
(lambda (entry)
(let ((copy (copy-sequence entry)))
(plist-put copy :blocks
(vconcat (plist-get copy :blocks)))))
(etaf-m0a-document-example-inventory directory))))))
(when noninteractive
(when (member "--etaf-m0a-print-inventory" command-line-args-left)
(setq command-line-args-left
(delete "--etaf-m0a-print-inventory" command-line-args-left))
(princ (etaf-m0a-inventory-json))
(terpri)))
(provide 'etaf-m0a-inventory)
;;; etaf-m0a-inventory.el ends here

View File

@ -0,0 +1,111 @@
;;; etaf-m0b-component-manifest.el --- Observed Component contract manifest -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Emit a machine-readable M0b manifest that keeps Component business props,
;; forwarded Host attributes, and the single-root forwarding guarantee in
;; separate fields. The manifest is emitted only after a real mounted probe.
;;; Code:
(require 'cl-lib)
(require 'json)
(require 'etaf)
(defconst etaf-m0b-component-manifest--dsl-name
'etaf-m0b-manifest-dsl-card)
(defconst etaf-m0b-component-manifest--render-name
'etaf-m0b-manifest-render-card)
(defun etaf-m0b-component-manifest--define-fixtures ()
"Define the two manifest probe Components through the public authoring API."
(etaf-component-redefine-run
(lambda ()
(eval
'(etaf-define-component etaf-m0b-manifest-dsl-card (&key title)
:view
(box :class "definition" (text (expr title)))))
(eval
'(etaf-define-component etaf-m0b-manifest-render-card (&key label)
:render
(etaf-node 'box (list :class "definition")
(list (etaf-node 'text nil (list label)))))))))
(defun etaf-m0b-component-manifest--spec-props (name)
"Return declared business props for Component NAME."
(let ((spec (gethash name etaf--view-registry)))
(unless (etaf--component-spec-p spec)
(error "Manifest fixture is not a Component: %S" name))
(mapcar #'symbol-name (etaf--component-spec-props spec))))
(defun etaf-m0b-component-manifest--mounted-probe (name prop value ref text)
"Mount NAME with PROP VALUE and verify forwarded attrs at REF and TEXT."
(let ((buffer (generate-new-buffer-name " *etaf-m0b-manifest*")))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-node name
(list prop value :class "caller"
:aria-label "manifest-probe" :ref ref)
nil))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(props (etaf-runtime-host-props-for runtime ref)))
(unless (and (string-match-p (regexp-quote text)
(with-current-buffer buffer
(buffer-string)))
(member "caller" (plist-get props :class))
(equal "manifest-probe"
(plist-get props :aria-label)))
(error "Mounted Component forwarding probe failed: %S" name)))
t)
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer)))
(kill-buffer live)))))
(defun etaf-m0b-component-manifest-data ()
"Return the observed M0b Component manifest as an alist."
(etaf-m0b-component-manifest--define-fixtures)
(let ((dsl-ok
(etaf-m0b-component-manifest--mounted-probe
etaf-m0b-component-manifest--dsl-name :title "DSL" 'manifest-dsl
"DSL"))
(render-ok
(etaf-m0b-component-manifest--mounted-probe
etaf-m0b-component-manifest--render-name :label "Render"
'manifest-render "Render"))
(attrs '("class" "style/presentation" "layout" "ref"
"role/tab-index" "aria-*" "on-*" "use")))
`((schema-version . 1)
(evidence-mode . "observed")
(components
. (((name . ,(symbol-name etaf-m0b-component-manifest--dsl-name))
(frontend . "view")
(declared-business-props
. ,(etaf-m0b-component-manifest--spec-props
etaf-m0b-component-manifest--dsl-name))
(forwarded-host-attrs . ,attrs)
(root-shape-forwarding-guarantee
. "single attr-capable root only; fragment, text, and multi-root results reject forwarded attrs")
(mounted-validation . ,dsl-ok))
((name . ,(symbol-name etaf-m0b-component-manifest--render-name))
(frontend . "render")
(declared-business-props
. ,(etaf-m0b-component-manifest--spec-props
etaf-m0b-component-manifest--render-name))
(forwarded-host-attrs . ,attrs)
(root-shape-forwarding-guarantee
. "single attr-capable root only; fragment, text, and multi-root results reject forwarded attrs")
(mounted-validation . ,render-ok)))))))
(defun etaf-m0b-component-manifest-write-json ()
"Write the observed M0b Component manifest as JSON."
(princ (json-encode (etaf-m0b-component-manifest-data))))
(provide 'etaf-m0b-component-manifest)
;;; etaf-m0b-component-manifest.el ends here

View File

@ -0,0 +1,322 @@
// Record only the owned Emacs frame. Build with swiftc -parse-as-library.
import Foundation
import CoreGraphics
import ScreenCaptureKit
import AVFoundation
struct CaptureFailure: Error, CustomStringConvertible {
let description: String
init(_ description: String) { self.description = description }
}
// Delegate callbacks and signal handlers do not share an execution queue.
final class CaptureEvents: NSObject, SCStreamDelegate, SCRecordingOutputDelegate,
SCStreamOutput, @unchecked Sendable {
private let lock = NSLock()
private var started = false
private var finished = false
private var stopping = false
private var frames = 0
private var failure: String?
private var nativeSize: (width: Int, height: Int)?
private var pixelMapping: Double?
private var firstPTS: Double?
private var lastPTS: Double?
private let requireNative: Bool
private let expectedPixelScale: Double
init(pixelScale: Double, requireNative: Bool = true) {
self.expectedPixelScale = pixelScale
self.requireNative = requireNative
}
func state() -> (started: Bool, finished: Bool, stopping: Bool,
frames: Int, failure: String?, nativeSize: (width: Int, height: Int)?,
pixelMapping: Double?, firstPTS: Double?, lastPTS: Double?) {
lock.withLock {
(started, finished, stopping, frames, failure, nativeSize,
pixelMapping, firstPTS, lastPTS)
}
}
func stop() { lock.withLock { stopping = true } }
func fail(_ message: String) { lock.withLock { failure = message } }
func recordingOutputDidStartRecording(_ output: SCRecordingOutput) {
lock.withLock { started = true }
}
func recordingOutputDidFinishRecording(_ output: SCRecordingOutput) {
lock.withLock { finished = true }
}
func recordingOutput(_ output: SCRecordingOutput, didFailWithError error: Error) {
fail("Recording failed: \(error)")
}
func stream(_ stream: SCStream, didStopWithError error: Error) {
fail("Capture stream stopped: \(error)")
}
func stream(_ stream: SCStream, didOutputSampleBuffer sampleBuffer: CMSampleBuffer,
of type: SCStreamOutputType) {
guard type == .screen else { return }
inspectScreenSample(sampleBuffer)
}
func inspectScreenSample(_ sampleBuffer: CMSampleBuffer) {
guard let attachments = CMSampleBufferGetSampleAttachmentsArray(
sampleBuffer, createIfNecessary: false) as? [[SCStreamFrameInfo: Any]],
let info = attachments.first,
let status = info[.status] as? Int,
status == SCFrameStatus.complete.rawValue else { return }
guard let scale = info[.contentScale] as? Double, scale.isFinite, scale > 0,
let backing = info[.scaleFactor] as? Double, backing.isFinite, backing > 0,
let rectDictionary = info[.contentRect] as? [String: Any],
let rect = CGRect(dictionaryRepresentation: rectDictionary as CFDictionary),
rect.origin.x.isFinite, rect.origin.y.isFinite,
rect.width.isFinite, rect.height.isFinite,
rect.width > 0, rect.height > 0 else {
fail("Captured frame has no usable native geometry")
return
}
// SCK can render at a higher resolution than the window's display.
// Its source-to-surface scale and source backing scale together define
// output pixels per logical point; compare that with the real display.
let mapping = scale * backing / expectedPixelScale
if requireNative && abs(mapping - 1) >= 0.0001 {
let image = CMSampleBufferGetImageBuffer(sampleBuffer)
let dimensions = image.map { "\(CVPixelBufferGetWidth($0))x\(CVPixelBufferGetHeight($0))" } ?? "missing"
fail("Captured frame was scaled; native pixels are required. Buffer=\(dimensions), attachments=\(info)")
return
}
let sourceWidth = rect.width / scale * expectedPixelScale
let sourceHeight = rect.height / scale * expectedPixelScale
if requireNative {
guard let image = CMSampleBufferGetImageBuffer(sampleBuffer) else {
fail("Captured frame has no pixel buffer")
return
}
let width = Double(CVPixelBufferGetWidth(image))
let height = Double(CVPixelBufferGetHeight(image))
guard sourceWidth <= width, sourceHeight <= height,
rect.minX >= 0, rect.minY >= 0,
rect.maxX * backing <= width, rect.maxY * backing <= height else {
fail("Captured frame exceeds original native-pixel canvas or is clipped")
return
}
}
let timestamp = CMTimeGetSeconds(CMSampleBufferGetPresentationTimeStamp(sampleBuffer))
guard timestamp.isFinite else { fail("Captured frame has no valid timestamp"); return }
lock.withLock {
nativeSize = (Int(ceil(sourceWidth)), Int(ceil(sourceHeight)))
pixelMapping = mapping
if abs(mapping - 1) < 0.0001 {
frames += 1
if firstPTS == nil { firstPTS = timestamp }
lastPTS = timestamp
}
}
}
}
@main
struct RecordEmacsWindow {
static func windowID(pid: pid_t) throws -> CGWindowID {
guard kill(pid, 0) == 0,
let inventory = CGWindowListCopyWindowInfo(.optionAll, kCGNullWindowID)
as? [[String: Any]] else {
throw CaptureFailure("Owned Emacs process is unavailable: \(pid)")
}
let candidates = inventory.compactMap { item -> (CGWindowID, Double)? in
guard item[kCGWindowOwnerPID as String] as? Int == Int(pid),
item[kCGWindowOwnerName as String] as? String == "Emacs",
item[kCGWindowLayer as String] as? Int == 0,
let alpha = item[kCGWindowAlpha as String] as? Double, alpha > 0,
let title = item[kCGWindowName as String] as? String, !title.isEmpty,
let bounds = item[kCGWindowBounds as String] as? [String: Double],
let width = bounds["Width"], let height = bounds["Height"],
width > 0, height > 0,
let number = item[kCGWindowNumber as String] as? UInt32 else { return nil }
return (number, width * height)
}.sorted { $0.1 > $1.1 }
guard let first = candidates.first else {
throw CaptureFailure("No named Emacs frame owned by PID \(pid)")
}
guard candidates.count == 1 || first.1 != candidates[1].1 else {
throw CaptureFailure("Ambiguous largest Emacs frame for PID \(pid)")
}
return first.0
}
static func filter(pid: pid_t, id: CGWindowID) async throws -> SCContentFilter {
let content = try await SCShareableContent.excludingDesktopWindows(
true, onScreenWindowsOnly: false)
guard let window = content.windows.first(where: {
$0.windowID == id && $0.owningApplication?.processID == pid
&& $0.windowLayer == 0
}) else { throw CaptureFailure("Owned frame is not shareable: \(id)") }
return SCContentFilter(desktopIndependentWindow: window)
}
static func emit(_ values: [String: Any]) throws {
let data = try JSONSerialization.data(withJSONObject: values, options: [.sortedKeys])
FileHandle.standardOutput.write(data + Data([10]))
}
static func configureNativeCanvas(filter: SCContentFilter,
configuration: SCStreamConfiguration) async throws {
// Fullscreen WindowServer bounds can exclude native window decoration.
// Discover the full source extent from one unrecorded sample; never
// guess offsets or grow the canvas iteratively after recording starts.
let probe = CaptureEvents(pixelScale: Double(filter.pointPixelScale), requireNative: false)
let stream = SCStream(filter: filter, configuration: configuration, delegate: probe)
try stream.addStreamOutput(probe, type: .screen,
sampleHandlerQueue: DispatchQueue(label: "capture-probe"))
try await stream.startCapture()
let deadline = Date().addingTimeInterval(10)
do {
while probe.state().nativeSize == nil {
if let failure = probe.state().failure { throw CaptureFailure(failure) }
guard Date() < deadline else { throw CaptureFailure("No native geometry sample") }
try await Task.sleep(nanoseconds: 20_000_000)
}
let size = probe.state().nativeSize!
configuration.width = size.width + size.width % 2
configuration.height = size.height + size.height % 2
try await stream.updateConfiguration(configuration)
while probe.state().pixelMapping.map({ abs($0 - 1) >= 0.0001 }) ?? true {
if let failure = probe.state().failure { throw CaptureFailure(failure) }
guard Date() < deadline else {
throw CaptureFailure("Measured canvas did not preserve native pixels")
}
try await Task.sleep(nanoseconds: 20_000_000)
}
try await stream.stopCapture()
} catch {
try? await stream.stopCapture()
throw error
}
}
static func record(pid: pid_t, output: URL, ready: URL) async throws {
guard !FileManager.default.fileExists(atPath: output.path),
!FileManager.default.fileExists(atPath: ready.path) else {
throw CaptureFailure("Recording output or readiness file already exists")
}
var id = try windowID(pid: pid)
var currentFilter = try await filter(pid: pid, id: id)
let scale = Double(currentFilter.pointPixelScale)
let width = Int(ceil(currentFilter.contentRect.width * scale))
let height = Int(ceil(currentFilter.contentRect.height * scale))
guard width > 0, height > 0 else { throw CaptureFailure("Empty frame") }
let configuration = SCStreamConfiguration()
// Fixed canvas; smaller windows are padded, never enlarged. The frame
// callback rejects any change to the display's native pixel mapping.
configuration.width = width + width % 2
configuration.height = height + height % 2
configuration.scalesToFit = false
configuration.captureResolution = .automatic
configuration.preservesAspectRatio = true
configuration.ignoreShadowsSingleWindow = true
configuration.showsCursor = false
let background = CGColor(gray: 0, alpha: 1)
defer { withExtendedLifetime(background) {} }
configuration.backgroundColor = background
configuration.minimumFrameInterval = CMTime(value: 1, timescale: 60)
configuration.capturesAudio = false
try await configureNativeCanvas(filter: currentFilter, configuration: configuration)
let events = CaptureEvents(pixelScale: scale)
try emit(["event": "configuration", "window_id": id, "pid": pid,
"width": configuration.width, "height": configuration.height,
"pixel_scale": scale, "content_rect": NSStringFromRect(currentFilter.contentRect)])
let stream = SCStream(filter: currentFilter, configuration: configuration,
delegate: events)
try stream.addStreamOutput(events, type: .screen,
sampleHandlerQueue: DispatchQueue(label: "capture-frames"))
let recordingConfiguration = SCRecordingOutputConfiguration()
recordingConfiguration.outputURL = output
recordingConfiguration.outputFileType = .mov
let recording = SCRecordingOutput(configuration: recordingConfiguration, delegate: events)
try stream.addRecordingOutput(recording)
let signals = [SIGTERM, SIGINT].map { number -> DispatchSourceSignal in
signal(number, SIG_IGN)
let source = DispatchSource.makeSignalSource(signal: number, queue: .global())
source.setEventHandler { events.stop() }
source.resume()
return source
}
defer { signals.forEach { $0.cancel() } }
try await stream.startCapture()
let startedAt = Date()
var announced = false
do {
while true {
let nextID = try windowID(pid: pid)
// SCContentFilter is a snapshot: refresh even for the same ID,
// whose source can resize independently of window replacement.
currentFilter = try await filter(pid: pid, id: nextID)
let nextScale = Double(currentFilter.pointPixelScale)
guard nextScale.isFinite, nextScale > 0,
currentFilter.contentRect.width > 0,
currentFilter.contentRect.height > 0,
currentFilter.contentRect.width * nextScale <= Double(configuration.width),
currentFilter.contentRect.height * nextScale <= Double(configuration.height) else {
throw CaptureFailure("Owned frame exceeds original native-pixel canvas or has invalid geometry")
}
if nextID != id {
try await stream.updateContentFilter(currentFilter)
id = nextID
try emit(["event": "window-replaced", "window_id": id, "pid": pid])
}
// Check the current source before readiness and requested stop;
// also re-read callback failures after the asynchronous refresh.
let state = events.state()
if let failure = state.failure { throw CaptureFailure(failure) }
if state.stopping { break }
if state.finished { throw CaptureFailure("Recording ended before requested stop") }
let elapsed = Date().timeIntervalSince(startedAt)
if elapsed > 600 { throw CaptureFailure("Recording exceeded 600 seconds") }
if !announced && elapsed > 10 { throw CaptureFailure("No verified recording frames") }
if !announced && state.started && state.frames > 0 {
let metadata: [String: Any] = ["pid": pid, "window_id": id,
"width": configuration.width, "height": configuration.height,
"pixel_scale": scale, "capture": "desktop-independent-window",
"ready_wall_time": Date().timeIntervalSince1970,
"source_first_pts": state.firstPTS!]
try JSONSerialization.data(withJSONObject: metadata).write(to: ready, options: .atomic)
try emit(metadata)
announced = true
}
try await Task.sleep(nanoseconds: 100_000_000)
}
try await stream.stopCapture()
let stopDeadline = Date().addingTimeInterval(4)
while !events.state().finished {
if let failure = events.state().failure { throw CaptureFailure(failure) }
guard Date() < stopDeadline else { throw CaptureFailure("Recording did not finalize") }
try await Task.sleep(nanoseconds: 20_000_000)
}
if let failure = events.state().failure { throw CaptureFailure(failure) }
guard announced, events.state().frames > 0 else {
throw CaptureFailure("Recording stopped without verified frames")
}
let final = events.state()
try emit(["event": "finished", "frames": final.frames,
"source_first_pts": final.firstPTS!, "source_last_pts": final.lastPTS!,
"source_span_seconds": final.lastPTS! - final.firstPTS!,
"recorded_duration_seconds": CMTimeGetSeconds(recording.recordedDuration),
"wall_duration_seconds": Date().timeIntervalSince(startedAt)])
} catch {
try? await stream.stopCapture()
throw error
}
}
static func main() async {
do {
let arguments = CommandLine.arguments
guard arguments.count == 4, let pid = Int32(arguments[1]), pid > 1 else {
throw CaptureFailure("usage: record-emacs-window PID OUTPUT.mov READY_FILE")
}
try await record(pid: pid, output: URL(fileURLWithPath: arguments[2]),
ready: URL(fileURLWithPath: arguments[3]))
} catch {
FileHandle.standardError.write(Data("\(error)\n".utf8))
exit(1)
}
}
}

View File

@ -0,0 +1,335 @@
#!/bin/sh
set -eu
GUI_CORE_SCRIPT_DIR=$(CDPATH= cd "$(dirname "$0")" && pwd)
GUI_ENGINE="$GUI_CORE_SCRIPT_DIR/emacs-gui-verifier.el"
GUI_RECORDER_SOURCE="$GUI_CORE_SCRIPT_DIR/record-emacs-window.swift"
GUI_CAPTURE="$GUI_CORE_SCRIPT_DIR/capture-emacs-window.sh"
GUI_EMACS_APP=${EMACS_APP:-/Applications/Emacs.app}
GUI_EMACS_BIN="$GUI_EMACS_APP/Contents/MacOS/Emacs"
GUI_EMACSCLIENT="$GUI_EMACS_APP/Contents/MacOS/bin/emacsclient"
GUI_CODEX_ROOT=${CODEX_HOME:-${HOME}/.codex}
GUI_DYNAMIC_SKILL=${EMACS_DYNAMIC_UI_SKILL_DIR:-$GUI_CODEX_ROOT/skills/emacs-dynamic-ui-verification}
GUI_CHECKPOINT_EL="$GUI_DYNAMIC_SKILL/scripts/capture-checkpoint.el"
GUI_EVIDENCE_PY="$GUI_DYNAMIC_SKILL/scripts/evidence.py"
usage() {
echo "usage:" >&2
echo " $0 doctor" >&2
echo " $0 review RUN_DIR" >&2
echo " $0 run ADAPTER_EL ENTRY_FUNCTION [--initialize-function FUNCTION] [--run-dir DIR] [--load-path DIR]..." >&2
exit 2
}
require_file() {
[ -f "$1" ] || {
echo "required file is missing: $1" >&2
exit 1
}
}
doctor() {
require_file "$GUI_EMACS_BIN"
require_file "$GUI_EMACSCLIENT"
require_file "$GUI_ENGINE"
require_file "$GUI_RECORDER_SOURCE"
require_file "$GUI_CAPTURE"
require_file "$GUI_CHECKPOINT_EL"
require_file "$GUI_EVIDENCE_PY"
command -v osascript >/dev/null 2>&1
xcrun --find swiftc >/dev/null 2>&1
command -v ffmpeg >/dev/null 2>&1
command -v python3 >/dev/null 2>&1
echo "EMACS-GUI-VERIFIER DOCTOR PASS"
}
review_run() {
[ "$#" -eq 1 ] || usage
GUI_REVIEW_DIR=$1
require_file "$GUI_REVIEW_DIR/manifest.jsonl"
require_file "$GUI_REVIEW_DIR/recording.mov"
python3 "$GUI_EVIDENCE_PY" finalize \
--run-dir "$GUI_REVIEW_DIR" --temporal-reviewed
}
GUI_DAEMON=""
GUI_DAEMON_PID=""
GUI_RECORDER_PID=""
GUI_DAEMON_STARTED=false
valid_pid() {
case $1 in
''|*[!0-9]*) return 1 ;;
*) [ "$1" -gt 1 ] ;;
esac
}
process_alive() {
valid_pid "$1" && kill -0 "$1" 2>/dev/null
}
wait_for_exit() {
GUI_WAIT_PID=$1
GUI_WAIT_LIMIT=$2
GUI_WAIT_ATTEMPT=0
while process_alive "$GUI_WAIT_PID"; do
[ "$GUI_WAIT_ATTEMPT" -lt "$GUI_WAIT_LIMIT" ] || return 1
sleep 0.1
GUI_WAIT_ATTEMPT=$((GUI_WAIT_ATTEMPT + 1))
done
}
force_owned_exit() {
GUI_FORCE_PID=$1
GUI_FORCE_LABEL=$2
process_alive "$GUI_FORCE_PID" || return 0
echo "forcing owned $GUI_FORCE_LABEL process to exit: $GUI_FORCE_PID" >&2
kill -TERM "$GUI_FORCE_PID" 2>/dev/null || return 1
if ! wait_for_exit "$GUI_FORCE_PID" 20; then
kill -KILL "$GUI_FORCE_PID" 2>/dev/null || return 1
wait_for_exit "$GUI_FORCE_PID" 10 || return 1
fi
return 0
}
stop_recorder() {
[ -n "$GUI_RECORDER_PID" ] || return 0
GUI_RECORDER_STOP_FAILED=0
if process_alive "$GUI_RECORDER_PID"; then
if ! kill -TERM "$GUI_RECORDER_PID"; then
GUI_RECORDER_STOP_FAILED=1
elif ! wait_for_exit "$GUI_RECORDER_PID" 50; then
GUI_RECORDER_STOP_FAILED=1
if ! force_owned_exit "$GUI_RECORDER_PID" "window recorder"; then
GUI_RECORDER_STOP_FAILED=1
fi
fi
fi
if ! wait "$GUI_RECORDER_PID" 2>/dev/null; then
GUI_RECORDER_STOP_FAILED=1
fi
GUI_RECORDER_PID=""
[ "$GUI_RECORDER_STOP_FAILED" -eq 0 ]
}
stop_daemon() {
[ "$GUI_DAEMON_STARTED" = true ] || return 0
GUI_DAEMON_STOP_FAILED=0
if ! "$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -e '(kill-emacs 0)' \
>"$GUI_RUN_DIR/daemon-shutdown.log" 2>&1; then
GUI_DAEMON_STOP_FAILED=1
fi
if ! wait_for_exit "$GUI_DAEMON_PID" 50; then
GUI_DAEMON_STOP_FAILED=1
if ! force_owned_exit "$GUI_DAEMON_PID" "Emacs daemon"; then
GUI_DAEMON_STOP_FAILED=1
fi
fi
GUI_DAEMON_STARTED=false
GUI_DAEMON_PID=""
GUI_DAEMON=""
[ "$GUI_DAEMON_STOP_FAILED" -eq 0 ]
}
cleanup() {
GUI_CLEANUP_FAILED=0
if ! stop_recorder; then
echo "GUI recorder cleanup failed" >&2
GUI_CLEANUP_FAILED=1
fi
if ! stop_daemon; then
echo "GUI daemon cleanup failed" >&2
GUI_CLEANUP_FAILED=1
fi
[ "$GUI_CLEANUP_FAILED" -eq 0 ]
}
on_exit() {
GUI_MAIN_STATUS=$?
trap - EXIT HUP INT TERM
if ! cleanup; then
[ "$GUI_MAIN_STATUS" -ne 0 ] || GUI_MAIN_STATUS=1
fi
exit "$GUI_MAIN_STATUS"
}
trap on_exit EXIT
trap 'exit 130' HUP INT TERM
activate_emacs() {
osascript -e "tell application \"System Events\" to set frontmost of first application process whose unix id is $GUI_DAEMON_PID to true"
GUI_ACTIVATE_ATTEMPTS=0
while [ "$GUI_ACTIVATE_ATTEMPTS" -lt 30 ]; do
GUI_FRONTMOST=$(osascript -e \
'tell application "System Events" to get unix id of first application process whose frontmost is true')
if [ "$GUI_FRONTMOST" = "$GUI_DAEMON_PID" ]; then
# macOS fullscreen/Space animations continue after focus changes.
sleep 1
return 0
fi
sleep 0.1
GUI_ACTIVATE_ATTEMPTS=$((GUI_ACTIVATE_ATTEMPTS + 1))
done
echo "Emacs did not become the frontmost application" >&2
exit 1
}
start_recorder() {
"$GUI_RECORDER" "$GUI_DAEMON_PID" "$GUI_RUN_DIR/recording.mov" \
"$GUI_RUN_DIR/recorder.ready" \
>"$GUI_RUN_DIR/recorder.log" 2>&1 &
GUI_RECORDER_PID=$!
GUI_RECORDER_ATTEMPTS=0
while [ "$GUI_RECORDER_ATTEMPTS" -lt 150 ]; do
if ! kill -0 "$GUI_RECORDER_PID" 2>/dev/null; then
echo "screen recorder exited before the scenario started" >&2
exit 1
fi
if [ -s "$GUI_RUN_DIR/recorder.ready" ]; then
return 0
fi
sleep 0.1
GUI_RECORDER_ATTEMPTS=$((GUI_RECORDER_ATTEMPTS + 1))
done
echo "window recorder did not produce a verified frame" >&2
exit 1
}
parse_run_arguments() {
[ "$#" -ge 2 ] || usage
GUI_ADAPTER=$1
GUI_ENTRY=$2
shift 2
GUI_RUN_DIR=""
GUI_LOAD_PATHS=""
GUI_INITIALIZE_FUNCTION=""
while [ "$#" -gt 0 ]; do
case $1 in
--initialize-function)
[ "$#" -ge 2 ] || usage
GUI_INITIALIZE_FUNCTION=$2
shift 2
;;
--run-dir)
[ "$#" -ge 2 ] || usage
GUI_RUN_DIR=$2
shift 2
;;
--load-path)
[ "$#" -ge 2 ] || usage
case $2 in *:*)
echo "load path cannot contain a colon: $2" >&2
exit 1
;;
esac
if [ -n "$GUI_LOAD_PATHS" ]; then
GUI_LOAD_PATHS="$GUI_LOAD_PATHS:$2"
else
GUI_LOAD_PATHS=$2
fi
shift 2
;;
*) usage ;;
esac
done
require_file "$GUI_ADAPTER"
if [ -z "$GUI_RUN_DIR" ]; then
GUI_RUN_DIR=$(mktemp -d /private/tmp/emacs-gui-verification.XXXXXX)
else
mkdir -p "$GUI_RUN_DIR"
fi
if [ -e "$GUI_RUN_DIR/manifest.jsonl" ] || [ -e "$GUI_RUN_DIR/recording.mov" ]; then
echo "run directory already contains GUI evidence: $GUI_RUN_DIR" >&2
exit 1
fi
}
run_adapter() {
doctor >/dev/null
GUI_RECORDER="$GUI_RUN_DIR/record-emacs-window"
xcrun swiftc -parse-as-library -warnings-as-errors -O \
"$GUI_RECORDER_SOURCE" -o "$GUI_RECORDER"
export ETAF_GUI_RUN_DIR="$GUI_RUN_DIR"
export ETAF_GUI_LOAD_PATHS="$GUI_LOAD_PATHS"
export ETAF_GUI_ENTRY="$GUI_ENTRY"
export ETAF_GUI_INITIALIZE_FUNCTION="$GUI_INITIALIZE_FUNCTION"
export SCREENCAPTURE="$GUI_CAPTURE"
GUI_DAEMON="emacs-gui-verify-$$"
"$GUI_EMACS_BIN" -Q --daemon="$GUI_DAEMON" \
--eval '(setq native-comp-jit-compilation nil load-prefer-newer t)'
GUI_DAEMON_STARTED=true
GUI_DAEMON_PID=$(
"$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -e '(emacs-pid)'
)
valid_pid "$GUI_DAEMON_PID" || {
echo "Emacs daemon returned an invalid process id: $GUI_DAEMON_PID" >&2
exit 1
}
"$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -c -e \
"(progn
(dolist (path (split-string (or (getenv \"ETAF_GUI_LOAD_PATHS\") \"\") path-separator t))
(add-to-list 'load-path path))
(load \"$GUI_CHECKPOINT_EL\" nil nil t)
(load \"$GUI_ENGINE\" nil nil t)
(load \"$GUI_ADAPTER\" nil nil t)
(when (fboundp 'tool-bar-mode) (tool-bar-mode -1))
(when (fboundp 'menu-bar-mode) (menu-bar-mode -1))
(when (fboundp 'scroll-bar-mode) (scroll-bar-mode -1))
(setenv \"ETAF_GUI_CAPTURE_PID\" (number-to-string (emacs-pid)))
(set-frame-parameter nil 'fullscreen 'fullboth)
(when-let* ((initialize (getenv \"ETAF_GUI_INITIALIZE_FUNCTION\"))
((> (length initialize) 0)))
(funcall (intern initialize)))
(select-frame-set-input-focus (selected-frame))
(message nil)
(redisplay t)
t)" >"$GUI_RUN_DIR/bootstrap.out"
activate_emacs
start_recorder
"$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -e \
'(funcall (intern (getenv "ETAF_GUI_ENTRY")))' \
>"$GUI_RUN_DIR/scenario.out"
stop_recorder
require_file "$GUI_RUN_DIR/recording.mov"
[ -s "$GUI_RUN_DIR/recording.mov" ] || {
echo "screen recording is empty" >&2
exit 1
}
stop_daemon
set +e
python3 "$GUI_EVIDENCE_PY" finalize --run-dir "$GUI_RUN_DIR" \
>"$GUI_RUN_DIR/finalize.out" 2>&1
GUI_FINALIZE_STATUS=$?
set -e
cat "$GUI_RUN_DIR/finalize.out"
if [ "$GUI_FINALIZE_STATUS" -eq 1 ]; then
echo "GUI verification assertions failed: $GUI_RUN_DIR" >&2
exit 1
fi
if [ "$GUI_FINALIZE_STATUS" -ne 2 ]; then
echo "fresh capture unexpectedly bypassed temporal review" >&2
exit 1
fi
echo "EMACS-GUI-VERIFIER CAPTURE COMPLETE verdict=INCOMPLETE entry=$GUI_ENTRY run-dir=$GUI_RUN_DIR"
}
[ "$#" -ge 1 ] || usage
GUI_COMMAND=$1
shift
case $GUI_COMMAND in
doctor)
[ "$#" -eq 0 ] || usage
doctor
;;
review)
review_run "$@"
;;
run)
parse_run_arguments "$@"
run_adapter
;;
*) usage ;;
esac

View File

@ -5,10 +5,6 @@
(require 'ert)
(require 'etaf)
(defmacro etaf-compiler-test--legacy-view (form)
"Construct FORM through the pre-compiler View expansion for comparison."
(etaf--compile-view-form form :projection))
(defun etaf-compiler-test--canonical (value)
"Return VALUE as comparable View data, resolving lazy holes once."
(cond
@ -27,42 +23,31 @@
((null value) nil)
(t value)))
(defun etaf-compiler-test--interpreted (color text)
"Return an interpreted fixture using COLOR and TEXT."
(etaf-compiler-test--legacy-view
(column :color color
(column :padding '(1 2)
(text "static"))
(text (expr :value text)))))
(defun etaf-compiler-test--lowered (color text)
"Return an automatically lowered fixture using COLOR and TEXT."
(etaf-view
(column :color color
(column :padding '(1 2)
(text "static"))
(text (expr :value text)))))
(text (expr text)))))
(defun etaf-compiler-test--fallback-view ()
"Return a View containing unsupported slot grammar."
(defun etaf-compiler-test--slot-view ()
"Return a blueprint-backed View containing a slot projection."
(etaf-view
(column (slot (text "fallback")))))
(defun etaf-compiler-test--fallback-reference ()
"Return the interpreted reference for `etaf-compiler-test--fallback-view'."
(etaf-compiler-test--legacy-view
(column (slot (text "fallback")))))
(ert-deftest etaf-automatic-view-fallback-is-exact ()
"An unsupported slot keeps the existing View semantics."
(let ((before (plist-get (etaf-compiler-statistics) :fallbacks)))
(should
(equal (etaf-compiler-test--canonical
(etaf-compiler-test--fallback-view))
(etaf-compiler-test--canonical
(etaf-compiler-test--fallback-reference))))
(should (= (1+ before)
(plist-get (etaf-compiler-statistics) :fallbacks)))))
(ert-deftest etaf-automatic-view-slot-uses-current-blueprint-abi ()
"Slot projection is a `/2' block and never takes a compatibility path."
(let* ((before (plist-get (etaf-compiler-statistics) :instantiations))
(view (etaf-compiler-test--slot-view))
(after (etaf-compiler-statistics))
(root (plist-get etaf-compiler--last-blueprint :root)))
(should (etaf--slot-projection-p
(car (etaf--view-node-children view))))
(should (eq 'slot
(plist-get (car (plist-get root :children)) :kind)))
(should (= (1+ before) (plist-get after :instantiations)))
(should-not (plist-member after :fallbacks))))
(defun etaf-compiler-test--lowered-supported (color)
"Return a supported automatically lowered fixture using COLOR."
@ -73,22 +58,18 @@
(text "static-b"))
(text :color "blue" "tail"))))
(defun etaf-compiler-test--interpreted-supported (color)
"Return the matching interpreted fixture using COLOR."
(etaf-compiler-test--legacy-view
(column :color color
(column :padding '(1 2)
(text "static-a")
(text "static-b"))
(text :color "blue" "tail"))))
(ert-deftest etaf-automatic-view-supported-output-is-exact ()
"A supported blueprint produces the same normalized View data."
"A blueprint produces the exact normalized typed View data."
(should
(equal (etaf-compiler-test--canonical
(etaf-compiler-test--lowered-supported "green"))
(etaf-compiler-test--canonical
(etaf-compiler-test--interpreted-supported "green")))))
'(:host column :props (:color "green")
:children
((:host column :props (:padding (1 2))
:children
((:host text :props nil :children ("static-a"))
(:host text :props nil :children ("static-b"))))
(:host text :props (:color "blue") :children ("tail")))))))
(ert-deftest etaf-automatic-view-reuses-static-subtrees ()
"Repeated instantiation reuses a static child while rebuilding its root."
@ -111,14 +92,7 @@
(cl-incf calls)
(apply original arguments))))
(etaf-compiler-test--lowered-supported "next"))
(should (= calls 1))
(setq calls 0)
(cl-letf (((symbol-function 'etaf--view-call)
(lambda (&rest arguments)
(cl-incf calls)
(apply original arguments))))
(etaf-compiler-test--interpreted-supported "next"))
(should (> calls 1))))
(should (= calls 1))))
(ert-deftest etaf-automatic-view-exposes-blueprint-coverage ()
"The compiler reports static nodes, dynamic paths, and holes."
@ -139,7 +113,7 @@
"Expr becomes one dynamic child program without forcing root fallback."
(pcase-let* ((`(,blueprint . ,programs)
(etaf-compiler--compile
'(column (text (expr :value value)))))
'(column (text (expr value)))))
(root (plist-get blueprint :root))
(text-block (car (plist-get root :children)))
(expr-block (car (plist-get text-block :children))))
@ -147,5 +121,29 @@
(should-not (plist-get root :static-p))
(should (= (length programs) 1))))
(ert-deftest etaf-automatic-view-directives-are-blueprint-blocks ()
"Branch and keyed list topology are represented inside the `/2' blueprint."
(pcase-let* ((`(,blueprint . ,programs)
(etaf-compiler--compile
'(column
(text :if selected "selected")
(text :else t "empty")
(row :for (item items) :key (car item)
(text (expr (cdr item)))))))
(children (plist-get (plist-get blueprint :root) :children)))
(should (equal '(branch keyed-list)
(mapcar (lambda (block) (plist-get block :kind)) children)))
(should (= 2 (length programs)))
(should (= 2 (plist-get blueprint :hole-count)))))
(ert-deftest etaf-automatic-view-rejects-stale-blueprint-abi ()
"A stale View IR requests a clean rebuild instead of compatibility."
(let ((blueprint
(list :kind 'etaf/view-blueprint
:abi "etaf-view-blueprint/1"
:id "stale" :root nil :hole-count 0)))
(should-error (etaf-compiler-instantiate blueprint [])
:type 'error)))
(provide 'etaf-compiler-tests)
;;; etaf-compiler-tests.el ends here

View File

@ -0,0 +1,715 @@
;;; etaf-component-frontends-tests.el --- Component frontend contract -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'etaf)
(defvar etaf-test-g6b-dsl-setup-count 0)
(defvar etaf-test-g6b-code-setup-count 0)
(defvar etaf-test-g6b-lifecycle nil)
(etaf-define-component etaf-test-g6b-dsl-counter (&key initial)
:setup
(progn
(cl-incf etaf-test-g6b-dsl-setup-count)
(etaf-ref (or initial 0)))
:view
(column :background-color "#102030" :padding-inline 1
(text :font-weight 'bold
(expr (format "Count %d" (etaf-value (etaf-state)))))
(box :ref 'g6b-dsl-increment
:on-press
(let ((count (etaf-state)))
(lambda ()
(setf (etaf-value count) (1+ (etaf-value count)))))
"Increment")))
(etaf-define-component etaf-test-g6b-code-counter (&key initial)
:setup
(progn
(cl-incf etaf-test-g6b-code-setup-count)
(etaf-ref (or initial 0)))
:render
(let ((count (etaf-state)))
(etaf-node
'column (list :background-color "#102030" :padding-inline 1)
(list
(etaf-node 'text (list :font-weight 'bold)
(list (format "Count %d" (etaf-value count))))
(etaf-node
'box
(list :ref 'g6b-code-increment
:on-press
(lambda ()
(setf (etaf-value count) (1+ (etaf-value count)))))
(list "Increment"))))))
(etaf-define-component etaf-test-g6b-nil-state ()
:setup nil
:view (text (expr (if (null (etaf-state)) "nil-state" "bad-state"))))
(etaf-define-component etaf-test-g6b-directives (&key selected items)
:view
(column
(text :if selected :key 'selected (expr selected))
(text :else t :key 'empty "No selection")
(row :for (item items) :key (car item)
(text (expr (cdr item))))))
(etaf-define-component etaf-test-g6b-pair (&key item)
:view
(fragment
(text (expr (format "%s-1" (cdr item))))
(text (expr (format "%s-2" (cdr item))))))
(etaf-define-component etaf-test-g6b-component-loop (&key items)
:view
(column
(etaf-test-g6b-pair :for (item items) :key (car item) :item item)))
(etaf-define-component etaf-test-g6b-key-boundary (&key value)
:setup
(list :framework-key (etaf-current-prop 'key) :initial value)
:view
(text
(expr
(format "%s/%s"
(plist-get (etaf-state) :initial)
(or (plist-get (etaf-state) :framework-key) "no-key")))))
(etaf-define-component etaf-test-g6b-invalid-list-result ()
:render
(list (etaf-node 'text nil (list "ambiguous"))))
(etaf-define-component etaf-test-g6b-rollback (&key fail)
:setup (etaf-ref 7)
:render
(let ((state (etaf-state)))
(when fail
(setf (etaf-value state) 99))
(etaf-node 'text nil (list (format "Stable %d" (etaf-value state))))))
(etaf-define-component etaf-test-g6b-lifecycle (&key label)
:setup
(progn
(etaf-on-mounted
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(mounted)))))
(etaf-on-updated
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(updated)))))
(etaf-on-unmounted
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(unmounted)))))
(etaf-on-scope-dispose
(lambda ()
(setq etaf-test-g6b-lifecycle
(append etaf-test-g6b-lifecycle '(cleanup)))))
nil)
:view (text (expr label)))
(etaf-define-component etaf-test-g6b-provider (&key count on-press)
:setup
(progn
(etaf-provide 'g6b-message "Context")
(etaf-theme-provide '(:color "#34D399"))
nil)
:view (column (etaf-test-g6b-context-action :count count :on-press on-press)))
(etaf-define-component etaf-test-g6b-context-action (&key count on-press)
:render
(etaf-node
'box
(list :class '(g6b-context-action)
:ref 'g6b-context-action
:use (etaf-focusable)
:on-press on-press)
(list (format "%s %d" (etaf-inject 'g6b-message "missing") count)))
:styles
(styles
(".g6b-context-action" :background-color "#1F2937")))
(etaf-define-component etaf-test-g6b-attr-leaf (&key label)
:view
(box :class '(leaf base) :color "#111111"
(text (expr label))))
(etaf-define-component etaf-test-g6b-attr-wrapper (&key label)
:view
(etaf-test-g6b-attr-leaf :label label))
(etaf-define-component etaf-test-g6b-attr-fragment ()
:view
(fragment (text "One") (text "Two")))
(etaf-define-component etaf-test-g6b-attr-text ()
:view (text "Text"))
(etaf-define-component etaf-test-g6b-attr-role ()
:view (box :role 'button "Role"))
(etaf-define-component etaf-test-g6b-attr-shape (&key split)
:render
(if split
(etaf-node 'fragment nil
(list (etaf-node 'text nil (list "One"))
(etaf-node 'text nil (list "Two"))))
(etaf-node 'box nil (list "Stable"))))
(etaf-define-component etaf-test-g6b-dsl-panel ()
:view
(column :background-color "#203040" :padding-inline 1
(row :class 'header (slot :name 'header))
(box (slot))
(row :class 'actions (slot :name 'actions))))
(etaf-define-component etaf-test-g6b-code-panel ()
:render
(etaf-node
'column (list :background-color "#203040" :padding-inline 1)
(list
(etaf-node 'row (list :class 'header)
(etaf-current-slot 'header))
(etaf-node 'box nil (etaf-current-slot 'default))
(etaf-node 'row (list :class 'actions)
(etaf-current-slot 'actions)))))
(defun etaf-test-g6b-dsl-counter (&rest _arguments)
"Ordinary Elisp function colliding with a Component registry name."
'ordinary-function)
(defun etaf-test-g6b--text (buffer)
"Return BUFFER text without properties."
(with-current-buffer buffer
(substring-no-properties (buffer-string))))
(defun etaf-test-g6b--face-at (buffer regexp)
"Return BUFFER face at the first REGEXP match."
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(re-search-forward regexp)
(get-text-property (match-beginning 0) 'face))))
(defun etaf-test-g6b--face-value (face property)
"Return PROPERTY from anonymous FACE values."
(cond
((and (listp face) (keywordp (car-safe face)))
(plist-get face property))
((listp face)
(cl-loop for entry in face
when (and (listp entry) (keywordp (car-safe entry))
(plist-member entry property))
return (plist-get entry property)))))
(ert-deftest etaf-component-frontends-definition-boundary-is-strict ()
"Definitions choose one frontend and keep exact registry names."
(should (etaf--component-spec-p
(gethash 'etaf-test-g6b-dsl-counter etaf--view-registry)))
(should-not (gethash 'test-g6b-dsl-counter etaf--view-registry))
(should (eq 'ordinary-function (etaf-test-g6b-dsl-counter)))
(dolist
(definition
'((etaf-define-component invalid-both ()
:view (box) :render (etaf-node 'box nil nil))
(etaf-define-component invalid-neither () :setup nil)
(etaf-define-component invalid-reserved (&key key) :view (box))
(etaf-define-component invalid-setup-view ()
:setup (etaf-node 'box nil nil) :view (box))))
(should-error (macroexpand definition)
:type 'etaf-component-definition-error)))
(ert-deftest etaf-node-validates-code-mode-structure ()
"Code nodes accept typed values and reject DSL or raw-list ambiguity."
(should (etaf--view-node-p
(etaf-node 'box (list :padding 1) (list "A"))))
(should (etaf--component-call-p
(etaf-node 'etaf-test-g6b-dsl-counter
(list :initial 1) nil)))
(should-error (etaf-node 'box (list :if t) nil)
:type 'etaf-component-call-error)
(should-error (etaf-node 'box nil '((text "raw")))
:type 'etaf-component-call-error)
(should-error (etaf-node 'box nil nil '((header . ("H"))))
:type 'etaf-component-call-error)
(should-error (etaf-node 'box (list :key nil) nil)
:type 'etaf-component-call-error))
(ert-deftest etaf-component-directives-validate-branch-and-loop-grammar ()
"DSL directives reject ambiguous structure during macro expansion."
(dolist
(form
'((etaf-view (column (text :else t "orphan")))
(etaf-view
(column (text :if t :for (item '(1)) :key item "bad")))
(etaf-view (column (text :for (item '(1)) "missing key")))
(etaf-view
(column (text :if nil "a") (text :else maybe "b")))))
(should-error (macroexpand form) :type 'etaf-view-syntax-error)))
(ert-deftest etaf-component-directives-render-and-retain-keyed-identity ()
"Branch changes and keyed reorder publish locally with stable item ids."
(let ((buffer " *etaf-g6b-directives*")
(selected (etaf-ref nil))
(items (etaf-ref '((a . "A") (b . "B")))))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-directives
:selected (etaf-value selected)
:items (etaf-value items)))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(range
(cl-loop for _identity being the hash-keys of
(etaf-generation-identity-index generation)
using (hash-values semantic-id)
for semantic = (etaf--pvec-get
(etaf-generation-semantic-nodes
generation)
semantic-id)
when (and (etaf--semantic-range-p semantic)
(etaf--semantic-range-keyed-key-order
semantic))
return semantic))
(a-roots
(gethash
'a
(etaf--semantic-range-keyed-item-root-id-index range)))
(b-roots
(gethash
'b
(etaf--semantic-range-keyed-item-root-id-index range))))
(should (string-match-p "No selection"
(etaf-test-g6b--text buffer)))
(should (string-match-p "A[[:space:]]+B"
(etaf-test-g6b--text buffer)))
(setf (etaf-value selected) "Selected")
(setf (etaf-value items) '((b . "B2") (a . "A")))
(should (string-match-p "Selected"
(etaf-test-g6b--text buffer)))
(should (string-match-p "B2[[:space:]]+A"
(etaf-test-g6b--text buffer)))
(let* ((generation (etaf-runtime-current-generation runtime))
(next (etaf--pvec-get
(etaf-generation-semantic-nodes generation)
(etaf--semantic-range-semantic-id range))))
(should
(equal
a-roots
(gethash
'a
(etaf--semantic-range-keyed-item-root-id-index next))))
(should
(equal
b-roots
(gethash
'b
(etaf--semantic-range-keyed-item-root-id-index next)))))
(let ((generation (etaf-runtime-current-generation runtime))
(text (with-current-buffer buffer (buffer-string))))
(should-error
(setf (etaf-value items) '((a . "A") (a . "duplicate")))
:type 'etaf-component-call-error)
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (equal-including-properties
text (with-current-buffer buffer (buffer-string)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-keyed-loop-owns-transparent-component-spans ()
"A keyed item may be a transparent multi-root Component without a fake Box."
(let ((buffer " *etaf-g6b-component-spans*")
(items (etaf-ref '((a . "A") (b . "B")))))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-component-loop :items (etaf-value items)))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(range
(cl-loop for _identity being the hash-keys of
(etaf-generation-identity-index generation)
using (hash-values semantic-id)
for semantic =
(etaf--pvec-get
(etaf-generation-semantic-nodes generation)
semantic-id)
when (and (etaf--semantic-range-p semantic)
(equal
'(a b)
(etaf--semantic-range-keyed-key-order
semantic)))
return semantic))
(root-index
(etaf--semantic-range-keyed-item-root-id-index range))
(a-roots (copy-sequence (gethash 'a root-index)))
(b-roots (copy-sequence (gethash 'b root-index))))
(should (string-match-p
"A-1[[:space:]]+A-2[[:space:]]+B-1[[:space:]]+B-2"
(etaf-test-g6b--text buffer)))
(should (= 1 (length a-roots)))
(should (= 1 (length b-roots)))
(should
(etaf--semantic-component-p
(etaf--pvec-get
(etaf-generation-semantic-nodes generation) (car a-roots))))
(setf (etaf-value items) '((b . "B2") (a . "A")))
(setq generation (etaf-runtime-current-generation runtime)
range
(etaf--pvec-get
(etaf-generation-semantic-nodes generation)
(etaf--semantic-range-semantic-id range))
root-index
(etaf--semantic-range-keyed-item-root-id-index range))
(should (string-match-p
"B2-1[[:space:]]+B2-2[[:space:]]+A-1[[:space:]]+A-2"
(etaf-test-g6b--text buffer)))
(should (equal a-roots (gethash 'a root-index)))
(should (equal b-roots (gethash 'b root-index)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-frontends-project-default-and-named-slots ()
"DSL and code Components preserve caller-owned slot order and styling."
(let ((dsl-buffer " *etaf-g6b-dsl-slots*")
(code-buffer " *etaf-g6b-code-slots*"))
(unwind-protect
(progn
(etaf-mount
dsl-buffer
(etaf-view
(etaf-test-g6b-dsl-panel
(slot :name 'header (text :font-weight 'bold "Header"))
(slot :name 'actions "Actions")
"Body")))
(etaf-mount
code-buffer
(etaf-node
'etaf-test-g6b-code-panel nil (list "Body")
(list
(cons 'header
(list (etaf-node 'text (list :font-weight 'bold)
(list "Header"))))
(cons 'actions (list "Actions")))))
(dolist (buffer (list dsl-buffer code-buffer))
(let ((text (etaf-test-g6b--text buffer)))
(should (string-match-p
"Header[[:space:]]+Body[[:space:]]+Actions" text)))
(should (eq 'bold
(etaf-test-g6b--face-value
(etaf-test-g6b--face-at buffer "Header")
:weight)))))
(dolist (buffer-name (list dsl-buffer code-buffer))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))))
(ert-deftest etaf-component-frontends-render-state-layout-style-and-events ()
"DSL and code Components mount equivalent stateful interactive surfaces."
(setq etaf-test-g6b-dsl-setup-count 0
etaf-test-g6b-code-setup-count 0)
(let ((dsl-buffer " *etaf-g6b-dsl*")
(code-buffer " *etaf-g6b-code*"))
(unwind-protect
(progn
(etaf-mount dsl-buffer
(etaf-view
(etaf-test-g6b-dsl-counter :initial 1)))
(etaf-mount code-buffer
(etaf-node 'etaf-test-g6b-code-counter
(list :initial 1) nil))
(should (= 1 etaf-test-g6b-dsl-setup-count))
(should (= 1 etaf-test-g6b-code-setup-count))
(dolist (buffer (list dsl-buffer code-buffer))
(let ((text (etaf-test-g6b--text buffer)))
(should (string-match-p "Count 1" text))
(should (string-match-p "Increment" text))
(should (= 2 (length (split-string text "\n" t)))))
(should (eq 'bold
(etaf-test-g6b--face-value
(etaf-test-g6b--face-at buffer "Count 1")
:weight))))
(let* ((dsl-runtime (etaf-runtime-for-buffer dsl-buffer))
(code-runtime (etaf-runtime-for-buffer code-buffer))
(dsl-instance
(car (hash-table-values (etaf-runtime-instances dsl-runtime))))
(code-instance
(car (hash-table-values (etaf-runtime-instances code-runtime)))))
(etaf-dispatch-event dsl-runtime 'g6b-dsl-increment 'press)
(etaf-dispatch-event code-runtime 'g6b-code-increment 'press)
(should (string-match-p "Count 2"
(etaf-test-g6b--text dsl-buffer)))
(should (string-match-p "Count 2"
(etaf-test-g6b--text code-buffer)))
(should (= 1 etaf-test-g6b-dsl-setup-count))
(should (= 1 etaf-test-g6b-code-setup-count))
(should (eq dsl-instance
(car (hash-table-values
(etaf-runtime-instances dsl-runtime)))))
(should (eq code-instance
(car (hash-table-values
(etaf-runtime-instances code-runtime)))))))
(dolist (buffer-name (list dsl-buffer code-buffer))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))))
(ert-deftest etaf-component-state-distinguishes-nil-from-no-setup ()
"A completed setup may return nil without becoming setup absence."
(let ((buffer " *etaf-g6b-nil-state*"))
(unwind-protect
(progn
(etaf-mount buffer (etaf-view (etaf-test-g6b-nil-state)))
(should (equal "nil-state" (etaf-test-g6b--text buffer))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live))))
(should-error (etaf-state) :type 'etaf-component-definition-error))
(ert-deftest etaf-component-key-is-framework-owned-and-render-result-is-typed ()
"Identity metadata stays outside business props and node lists stay invalid."
(let ((buffer " *etaf-g6b-key-boundary*")
(invalid-buffer " *etaf-g6b-invalid-result*"))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-test-g6b-key-boundary :key 'stable :value "Business")))
(should (string-match-p "Business/no-key"
(etaf-test-g6b--text buffer)))
(should-error
(etaf-mount
invalid-buffer
(etaf-view (etaf-test-g6b-invalid-list-result)))
:type 'etaf-component-call-error))
(dolist (buffer-name (list buffer invalid-buffer))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer-name))) (kill-buffer live))))))
(ert-deftest etaf-component-render-side-effect-rolls-back-completely ()
"A detectable render mutation preserves the published generation and state."
(let ((buffer " *etaf-g6b-render-rollback*")
(fail (etaf-ref nil)))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-rollback :fail (etaf-value fail)))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(published (with-current-buffer buffer (buffer-string)))
(instance
(car (hash-table-values (etaf-runtime-instances runtime))))
(state (etaf--component-instance-state instance)))
(should-error (setf (etaf-value fail) t)
:type 'etaf-render-write-error)
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (equal-including-properties
published (with-current-buffer buffer (buffer-string))))
(should (= 7 (etaf-value state)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-lifecycle-and-scope-cleanup-are-ordered ()
"Mount, update, removal, and Scope cleanup each run once in order."
(let ((buffer " *etaf-g6b-lifecycle*")
(label (etaf-ref "A")))
(setq etaf-test-g6b-lifecycle nil)
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-lifecycle :label (etaf-value label)))))
(should (equal '(mounted) etaf-test-g6b-lifecycle))
(setf (etaf-value label) "B")
(should (equal '(mounted updated) etaf-test-g6b-lifecycle))
(should (string-match-p "B" (etaf-test-g6b--text buffer)))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (equal '(mounted updated unmounted cleanup)
etaf-test-g6b-lifecycle)))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-frontends-compose-context-theme-style-and-behavior ()
"Test child inheritance and composition; separate tests cover slot authors."
(let ((buffer " *etaf-g6b-composition*")
(count (etaf-ref 0)))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-provider
:count (etaf-value count)
:on-press
(let ((source count))
(lambda ()
(setf (etaf-value source)
(1+ (etaf-value source)))))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(face (etaf-test-g6b--face-at buffer "Context 0"))
(props
(etaf-runtime-host-props-for
runtime 'g6b-context-action)))
(should (equal "#34D399"
(etaf-test-g6b--face-value face :foreground)))
(should (equal "#1F2937"
(etaf-test-g6b--face-value face :background)))
(should (= 0 (plist-get props :tab-index)))
(etaf-dispatch-event runtime 'g6b-context-action 'press)
(should (string-match-p "Context 1"
(etaf-test-g6b--text buffer)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-host-attrs-fall-through-one-root-chain ()
"Undeclared Host attrs cross a root Component chain without entering props."
(let ((buffer " *etaf-g6b-attrs*")
(color (etaf-ref "#224466")))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-attr-wrapper
:label "Leaf" :class '(caller base)
:color (etaf-value color) :padding-inline 2
:ref 'g6b-attr-root))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(instances (hash-table-values
(etaf-runtime-instances runtime)))
(props (etaf-runtime-host-props-for
runtime 'g6b-attr-root)))
(should (equal '("leaf" "base" "caller")
(plist-get props :class)))
(should (equal "#224466" (plist-get props :color)))
(should (equal "#224466"
(etaf-test-g6b--face-value
(etaf-test-g6b--face-at buffer "Leaf")
:foreground)))
(should (= 2 (plist-get props :padding-inline)))
(setf (etaf-value color) "#335577")
(setq props (etaf-runtime-host-props-for
runtime 'g6b-attr-root))
(should (equal "#335577" (plist-get props :color)))
(should (equal "#335577"
(etaf-test-g6b--face-value
(etaf-test-g6b--face-at buffer "Leaf")
:foreground)))
(should
(cl-every
(lambda (instance)
(memq instance (hash-table-values
(etaf-runtime-instances runtime))))
instances))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-host-attrs-reject-ambiguous-or-invalid-targets ()
"Fallthrough fails closed for unknown, duplicate, conflicting, and multi-root input."
(should-error
(etaf-node 'etaf-test-g6b-attr-leaf (list :unknown-attr 1) nil)
:type 'etaf-component-call-error)
(should-error
(etaf-node 'etaf-test-g6b-attr-leaf
(list :bgcolor "red" :background-color "blue") nil)
:type 'etaf-component-call-error)
(dolist
(entry
`((" *etaf-g6b-attrs-fragment*"
,(etaf-view (etaf-test-g6b-attr-fragment :color "red")))
(" *etaf-g6b-attrs-text*"
,(etaf-view (etaf-test-g6b-attr-text :padding 1)))))
(let ((buffer (car entry)))
(unwind-protect
(should-error (etaf-mount buffer (cadr entry))
:type 'etaf-component-call-error)
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(let ((buffer " *etaf-g6b-attrs-role*"))
(unwind-protect
(should-error
(etaf-mount
buffer
(etaf-view
(etaf-test-g6b-attr-role
:role 'navigation :ref 'g6b-attrs-role)))
:type 'etaf-component-call-error)
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-host-attrs-rollback-root-shape-failure ()
"A later multi-root result cannot publish or retire the previous root."
(let ((buffer " *etaf-g6b-attrs-rollback*")
(split (etaf-ref nil)))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-test-g6b-attr-shape
:split (etaf-value split) :color "#224466"))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(published (with-current-buffer buffer (buffer-string))))
(should-error (setf (etaf-value split) t)
:type 'etaf-component-call-error)
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (equal-including-properties
published (with-current-buffer buffer (buffer-string))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-compiled-host-sites-are-instance-scoped ()
"Two instances of one compiled Component never share generated Host refs."
(let ((buffer " *etaf-g6b-instance-sites*"))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(column
(etaf-test-g6b-attr-leaf :key 'one :label "One")
(etaf-test-g6b-attr-leaf :key 'two :label "Two"))))
(should (string-match-p
"One[[:space:]]+Two" (etaf-test-g6b--text buffer))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(provide 'etaf-component-frontends-tests)
;;; etaf-component-frontends-tests.el ends here

View File

@ -6,6 +6,7 @@
(require 'ert)
(require 'etaf-data)
(require 'etaf-observer)
(defconst etaf-data-test-records
'((:id 1 :name "Ada" :group "compiler")
@ -62,17 +63,22 @@
(ert-deftest etaf-data-loading-state-is-visible-to-source-boundary ()
"Publish loading before invoking the source load capability."
(let (controller seen)
(let (controller seen candidate-kinds)
(let ((source (etaf-data-source
:load (lambda (_query _page _page-size)
(push (etaf-value (etaf-data-status controller))
seen)
(push (etaf-data--projection-candidate-kind
(etaf-data--controller-projection-candidate
controller))
candidate-kinds)
(list :items '(a b) :total 2)))))
(setq controller (etaf-data-controller source))
(unwind-protect
(progn
(etaf-data-load controller)
(should (equal '(loading) seen))
(should (equal '(loading) candidate-kinds))
(should (eq 'success (etaf-value
(etaf-data-status controller)))))
(etaf-data-stop controller)))))
@ -184,6 +190,444 @@
(car (etaf-value (etaf-data-error controller))))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-malformed-load-publishes-atomic-error ()
"A malformed source result leaves old data intact and exits loading."
(let* ((source (etaf-data-source
:load (lambda (&rest _args) '(:total 99))))
(controller
(etaf-data-controller
source
:initial-result '(:items (old) :total 1 :page 2 :page-size 7)))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-load controller)
(error (setq captured condition)))
(should captured)
(should (eq 'error (car captured)))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should (equal captured
(etaf-value (etaf-data-error controller))))
(should (equal '(old) (etaf-value (etaf-data-items controller))))
(should (= 1 (etaf-value (etaf-data-total controller))))
(should (= 2 (etaf-value (etaf-data-page controller))))
(should (= 7 (etaf-value (etaf-data-page-size controller)))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-committed-load-error-has-read-only-retry ()
"A committed mutation reports a trailer and retry never mutates twice."
(let* ((load-count 0)
(mutate-count 0)
(source
(etaf-data-source
:load (lambda (&rest _args)
(cl-incf load-count)
(if (= load-count 1)
(error "reconciliation read failed")
'(:items (new) :total 1)))
:mutate-v2 (lambda (&rest _args)
(cl-incf mutate-count)
'(:certainty committed :result committed-result))))
(controller
(etaf-data-controller
source :initial-result '(:items (old) :total 1)))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-mutate controller 'update 'payload)
(error (setq captured condition)))
(should captured)
(should (eq 'error (car captured)))
(should (equal '(error "reconciliation read failed")
(butlast captured)))
(should (equal 'committed-result
(plist-get (etaf-data-condition-projection-info
captured)
:result)))
(should (= 1 mutate-count))
(should (= 1 load-count))
(should (eq 'committed
(plist-get (etaf-data-mutation-outcome controller)
:certainty)))
(should (eq 'projection-pending
(etaf-data-reconciliation-state controller)))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should (equal '(old) (etaf-value (etaf-data-items controller))))
(should (equal '(:items (new) :total 1)
(etaf-data-retry-reconciliation controller)))
(should (= 1 mutate-count))
(should (= 2 load-count))
(should (eq 'success (etaf-value (etaf-data-status controller))))
(should (equal '(new) (etaf-value (etaf-data-items controller))))
(should (eq 'projected
(etaf-data-reconciliation-state controller))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-external-unknown-is-not-replayed ()
"A v1 mutation signal is conservatively unknown and never auto-retried."
(let* ((mutate-count 0)
(load-count 0)
(source
(etaf-data-source
:load (lambda (&rest _args)
(cl-incf load-count)
'(:items (old) :total 1))
:mutate (lambda (&rest _args)
(cl-incf mutate-count)
(error "write uncertainty"))))
(controller
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-mutate controller 'update 'payload)
(error (setq captured condition)))
(should captured)
(should (equal '(error "write uncertainty") captured))
(should (= 1 mutate-count))
(should (= 0 load-count))
(should (eq 'external-unknown
(plist-get (etaf-data-mutation-outcome controller)
:certainty)))
(should (eq 'external-unknown
(etaf-data-reconciliation-state controller)))
(should-not (etaf-data-retry-reconciliation controller))
(should-not (etaf-data-retry-render controller)))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-uncertain-mutation-projection-fault-keeps-cause ()
"A mutation projection fault preserves the primary cause and adds a trailer."
(let* ((source
(etaf-data-source
:load (lambda (&rest _args) '(:items (old) :total 1))
:mutate (lambda (&rest _args) (error "write uncertainty"))))
(controller
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
(stop-status-watch
(etaf-watch
(etaf-data-status controller)
(lambda (new _old)
(when (eq new 'error)
(error "status projection failed")))))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-mutate controller 'update 'payload)
(error (setq captured condition)))
(should (equal '(error "write uncertainty") (butlast captured)))
(let ((projection-info (etaf-data-condition-projection-info captured))
(token (etaf-data-reconciliation-token controller)))
(should projection-info)
(should (eq 'external-unknown
(plist-get projection-info
:external-commit-certainty)))
(should (equal token (plist-get projection-info
:reconciliation-token)))
(should (equal '(error "status projection failed")
(plist-get token :projection-condition)))))
(funcall stop-status-watch)
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-mutation-loading-is-a-candidate ()
"The mutation boundary exposes loading through the shared candidate path."
(let (controller seen kinds)
(let ((source
(etaf-data-source
:load (lambda (&rest _args) '(:items (old) :total 1))
:mutate (lambda (&rest _args)
(push (etaf-value (etaf-data-status controller)) seen)
(push (etaf-data--projection-candidate-kind
(etaf-data--controller-projection-candidate
controller))
kinds)
'mutation-result))))
(setq controller
(etaf-data-controller source
:initial-result '(:items (old) :total 1))))
(unwind-protect
(progn
(should (equal 'mutation-result
(etaf-data-mutate controller 'update 'payload)))
(should (equal '(loading) seen))
(should (equal '(loading) kinds)))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-loading-projection-fault-exits-terminally ()
"A loading dispatch fault publishes error and prevents the mutation call."
(let* ((mutate-count 0)
(source
(etaf-data-source
:load (lambda (&rest _args) '(:items (old) :total 1))
:mutate (lambda (&rest _args)
(cl-incf mutate-count)
'mutation-result)))
(controller
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
(stop-status-watch
(etaf-watch
(etaf-data-status controller)
(lambda (new _old)
(when (eq new 'loading)
(error "loading projection failed")))))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-mutate controller 'update 'payload)
(error (setq captured condition)))
(should (equal '(error "loading projection failed") captured))
(should (= 0 mutate-count))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should (equal captured (etaf-value (etaf-data-error controller)))))
(funcall stop-status-watch)
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-committed-candidate-is-one-shot ()
"A committed projection candidate cannot be submitted or rolled back twice."
(let* ((source (etaf-data-source
:load (lambda (&rest _args)
'(:items (new) :total 2))))
(controller
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
candidate)
(unwind-protect
(progn
(etaf-data-load controller)
(setq candidate (etaf-data--controller-projection-candidate controller))
(let ((items-version (etaf-ref-version (etaf-data-items controller)))
(total-version (etaf-ref-version (etaf-data-total controller))))
(should (eq 'committed
(etaf-data--projection-candidate-state candidate)))
(should-error
(etaf-data--commit-projection controller candidate)
:type 'etaf-data-projection-conflict)
(should (eq 'committed
(etaf-data--projection-candidate-state candidate)))
(should (equal '(new) (etaf-value (etaf-data-items controller))))
(should (= 2 (etaf-value (etaf-data-total controller))))
(should (= items-version
(etaf-ref-version (etaf-data-items controller))))
(should (= total-version
(etaf-ref-version (etaf-data-total controller))))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-v2-malformed-outcome-is-unknown ()
"Malformed v2 metadata publishes an error without starting a read."
(let* ((load-count 0)
(source
(etaf-data-source
:load (lambda (&rest _args)
(cl-incf load-count)
'(:items (old) :total 1))
:mutate-v2 (lambda (&rest _args) '(:certainty committed :error bad))))
(controller
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-mutate controller 'update 'payload)
(error (setq captured condition)))
(should captured)
(should (eq 'external-unknown
(plist-get (etaf-data-mutation-outcome controller)
:certainty)))
(should (eq 'external-unknown
(etaf-data-reconciliation-state controller)))
(should (= 0 load-count))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should-not (etaf-data-retry-reconciliation controller)))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-v2-outcome-validates-result-and-rollback-error ()
"Reject contradictory results and incomplete rolled-back outcomes."
(dolist (outcome
'((:certainty committed :result left :mutation-result right)
(:certainty committed)
(:certainty rolled-back)))
(let* ((load-count 0)
(source
(etaf-data-source
:load (lambda (&rest _args)
(cl-incf load-count)
'(:items (old) :total 1))
:mutate-v2 (lambda (&rest _args) outcome)))
(controller
(etaf-data-controller source :initial-result '(:items (old)
:total 1)))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-mutate controller 'update 'payload)
(error (setq captured condition)))
(should captured)
(should (eq 'external-unknown
(plist-get (etaf-data-mutation-outcome controller)
:certainty)))
(should (eq 'external-unknown
(etaf-data-reconciliation-state controller)))
(should (zerop load-count)))
(etaf-data-stop controller)))))
(ert-deftest etaf-data-m4a-field-apply-fault-restores-written-fields ()
"A field fault before dispatch restores every field written by the candidate."
(let* ((source (etaf-data-source
:load (lambda (&rest _args)
'(:items (new) :total 2))))
(controller
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
(old-apply etaf-data--projection-field-apply-function)
(old-items-version (etaf-ref-version (etaf-data-items controller)))
(old-total-version (etaf-ref-version (etaf-data-total controller)))
captured)
(unwind-protect
(progn
(setq etaf-data--projection-field-apply-function
(lambda (entry)
(let ((ref (plist-get entry :ref)))
(setf (etaf-ref-value ref) (plist-get entry :new-value)
(etaf-ref-version ref)
(1+ (plist-get entry :old-version))))
(error "field installation failed")))
(condition-case condition
(etaf-data-load controller)
(error (setq captured condition)))
(should captured)
(should (equal '(old) (etaf-value (etaf-data-items controller))))
(should (= 1 (etaf-value (etaf-data-total controller))))
(should (= old-items-version
(etaf-ref-version (etaf-data-items controller))))
(should (= old-total-version
(etaf-ref-version (etaf-data-total controller)))))
(setq etaf-data--projection-field-apply-function old-apply)
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-field-apply-runs-once-per-entry ()
"Install each changed field exactly once after version validation."
(let* ((source (etaf-data-source
:load (lambda (&rest _args)
(list :items '(new) :total 2))))
(controller
(etaf-data-controller source
:initial-result '(:items (old) :total 1)))
(old-apply etaf-data--projection-field-apply-function)
(apply-count 0))
(unwind-protect
(progn
(setq etaf-data--projection-field-apply-function
(lambda (entry)
(cl-incf apply-count)
(etaf-data--projection-default-apply-field entry)))
(etaf-data-load controller)
(let* ((candidate (etaf-data-projection-candidate controller))
(entries (etaf-data--projection-candidate-entries candidate)))
(should (= apply-count (length entries)))
(should (equal '(new) (etaf-value (etaf-data-items controller))))
(should (= 2 (etaf-value (etaf-data-total controller))))))
(setq etaf-data--projection-field-apply-function old-apply)
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-item-key-fault-exits-loading ()
"A materialization fault publishes error instead of leaving loading set."
(let* ((source (etaf-data-source
:load (lambda (&rest _args)
(list :items '((:id new)) :total 2))))
(controller
(etaf-data-controller
source
:initial-result '(:items ((:id old)) :total 1)
:item-key
(lambda (item)
(if (eq (plist-get item :id) 'new)
(error "item key failed")
(plist-get item :id)))))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-load controller)
(error (setq captured condition)))
(should (equal '(error "item key failed") captured))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should (equal captured
(etaf-value (etaf-data-error controller))))
(should (equal '((:id old))
(etaf-value (etaf-data-items controller))))
(should (= 1 (etaf-value (etaf-data-total controller))))
(should (eq 'load-error
(etaf-data--projection-candidate-kind
(etaf-data--controller-projection-candidate
controller)))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-source-error-projection-fault-exits-loading ()
"A source error plus error projection fault still leaves terminal error state."
(let* ((source (etaf-data-source
:load (lambda (&rest _args)
(error "source boom"))))
(controller
(etaf-data-controller source
:initial-result '(:items (old) :total 1)))
(old-apply etaf-data--projection-field-apply-function)
captured)
(unwind-protect
(progn
(setq etaf-data--projection-field-apply-function
(lambda (entry)
(let ((ref (plist-get entry :ref)))
(setf (etaf-ref-value ref) (plist-get entry :new-value)
(etaf-ref-version ref)
(1+ (plist-get entry :old-version))))
(error "error projection installation failed")))
(condition-case condition
(etaf-data-load controller)
(error (setq captured condition)))
(should (equal '(error "source boom") captured))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should (equal captured
(etaf-value (etaf-data-error controller))))
(should (equal '(old) (etaf-value (etaf-data-items controller))))
(should (= 1 (etaf-value (etaf-data-total controller))))
(should (eq 'aborted
(etaf-data--projection-candidate-state
(etaf-data--controller-projection-candidate
controller)))))
(setq etaf-data--projection-field-apply-function old-apply)
(etaf-data-stop controller))))
(ert-deftest etaf-data-m4a-plain-load-projection-fault-keeps-raw-condition ()
"A plain successful load keeps a projection fault in the v1 condition shape."
(let* ((source (etaf-data-source
:load (lambda (&rest _args)
'(:items (new) :total 2))))
(controller
(etaf-data-controller source :initial-result '(:items (old) :total 1)))
(stop-status-watch
(etaf-watch
(etaf-data-status controller)
(lambda (new _old)
(when (eq new 'success)
(error "success projection failed")))))
captured)
(unwind-protect
(progn
(condition-case condition
(etaf-data-load controller)
(error (setq captured condition)))
(should (equal '(error "success projection failed") captured))
(should-not (etaf-data-condition-projection-info captured))
(should-not (etaf-data-reconciliation-token controller))
(should (eq 'success (etaf-value (etaf-data-status controller))))
(should (equal '(new) (etaf-value (etaf-data-items controller))))
(should (= 2 (etaf-value (etaf-data-total controller)))))
(funcall stop-status-watch)
(etaf-data-stop controller))))
(ert-deftest etaf-data-selection-is-reactive-state ()
"Select, deselect, and clear identities through the controller API."
(let* ((source (etaf-data-memory-source etaf-data-test-records
@ -325,4 +769,94 @@
(should-error (etaf-data-set-page controller 2)
:type 'etaf-data-stopped-error)))
(ert-deftest etaf-data-observes-source-capabilities-once-in-call-order ()
"Report source load and mutation without timing controller publication."
(let* ((source (etaf-data-memory-source '((:id 1)) :id-key :id))
(controller (etaf-data-controller source))
reports
diagnostics
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 41
:runtime-id 7
:buffer-name nil
:diagnostic (lambda (diagnostic) (push diagnostic diagnostics)))))
(unwind-protect
(progn
(etaf--observer-call-with-context
context
(lambda ()
(etaf-data-load controller)
(etaf-data-mutate controller 'insert '(:id 2))))
(setq reports (nreverse reports))
(should-not diagnostics)
(should (equal '(load mutate load)
(mapcar (lambda (report)
(plist-get report :stage))
reports)))
(should (equal '(memory memory memory)
(mapcar (lambda (report)
(plist-get report :provider))
reports)))
(should (equal '(1 nil 1)
(mapcar (lambda (report)
(plist-get report :page))
reports)))
(should (eq 'insert (plist-get (cadr reports) :operation)))
(should (equal '((:id 1) (:id 2))
(etaf-value (etaf-data-items controller))))
(should (eq 'success (etaf-value
(etaf-data-status controller)))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-observed-source-error-preserves-controller-state ()
"Report a source error and preserve the ordinary Data error contract."
(let* ((source (etaf-data-source
:load (lambda (&rest _args) (error "unavailable"))))
(controller (etaf-data-controller source))
reports
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 42
:runtime-id 7
:buffer-name nil
:diagnostic #'ignore)))
(unwind-protect
(progn
(should-error
(etaf--observer-call-with-context
context (lambda () (etaf-data-load controller)))
:type 'error)
(should (= 1 (length reports)))
(should (eq 'data (plist-get (car reports) :provider)))
(should (eq 'load (plist-get (car reports) :stage)))
(should (eq 'error (plist-get (car reports) :status)))
(should (eq 'error (etaf-value (etaf-data-status controller))))
(should (string-match-p
"unavailable"
(cadr (etaf-value (etaf-data-error controller))))))
(etaf-data-stop controller))))
(ert-deftest etaf-data-source-rejects-invalid-observation-provider ()
"Require an explicit source provider to be a non-nil symbol."
(should-error
(etaf-data-source :provider nil
:load (lambda (&rest _args) (list :items nil)))
:type 'wrong-type-argument)
(should-error
(etaf-data-source :provider 7
:load (lambda (&rest _args) (list :items nil)))
:type 'wrong-type-argument))
(ert-deftest etaf-data-unobserved-source-call-bypasses-stage-runtime ()
"Keep the standalone source path free of observation work."
(let ((source (etaf-data-memory-source '((:id 1)) :id-key :id)))
(cl-letf (((symbol-function 'etaf--observer-call-stage)
(lambda (&rest _args)
(ert-fail "unobserved Data call entered stage runtime"))))
(should (equal '((:id 1))
(plist-get (etaf-data-source-load-page source) :items))))))
;;; etaf-data-tests.el ends here

View File

@ -6,6 +6,12 @@
(require 'ert)
(require 'cl-lib)
(require 'json)
(require 'macroexp)
(require 'etaf)
(declare-function etaf-m0b-component-manifest-write-json
"etaf-m0b-component-manifest" ())
(defconst etaf-docs-test--root
(file-name-directory
@ -30,7 +36,7 @@
(unless (re-search-forward "^```[[:space:]]*$" nil t)
(error "Unclosed Elisp documentation block"))
(push (buffer-substring-no-properties start
(line-beginning-position))
(match-beginning 0))
blocks))))
(nreverse blocks)))
@ -47,6 +53,159 @@
(end-of-file count)
(error (error "Cannot read documentation form: %S" err))))))
(defun etaf-docs-test--forms (source)
"Read and return every form in documentation SOURCE."
(with-temp-buffer
(insert source)
(goto-char (point-min))
(let (forms)
(condition-case nil
(while t (push (read (current-buffer)) forms))
(end-of-file (nreverse forms))))))
(defun etaf-docs-test--marked-examples (contents)
"Extract named executable documentation examples from CONTENTS."
(with-temp-buffer
(insert contents)
(goto-char (point-min))
(let (examples)
(while (re-search-forward
"^<!-- etaf-example: \\([^ ]+\\) -->\n```elisp\n" nil t)
(let ((name (match-string 1))
(start (point)))
(unless (re-search-forward "^```$" nil t)
(error "Unclosed executable example %s" name))
(push (cons name (buffer-substring-no-properties
start (match-beginning 0)))
examples)))
(nreverse examples))))
(defun etaf-docs-test--run-fresh (source assertions)
"Run exact example SOURCE and ASSERTIONS in a fresh core-only Emacs."
(let ((script (make-temp-file "etaf-readme-" nil ".el")))
(unwind-protect
(progn
(with-temp-file script
(insert source "\n")
(prin1 assertions (current-buffer))
(insert "\n(should-not (featurep 'etaf-ui))\n"
"(should-not (featurep 'etaf-playground))\n"))
(with-temp-buffer
(let ((status
(apply #'call-process
(expand-file-name invocation-name invocation-directory)
nil (current-buffer) nil "-Q" "--batch"
(append
(cl-loop for directory in '("." "../ebox" "../tp"
"../ecss")
append (list "-L" (expand-file-name
directory
etaf-docs-test--root)))
(list "--eval"
(prin1-to-string
'(progn
(require 'ert)
(require 'jka-compr)
(setq load-suffixes '(".el" ".elc")
load-prefer-newer t)))
"-l" script)))))
(unless (equal status 0)
(ert-fail (format "Documentation child exited %S:\n%s"
status (buffer-string)))))))
(delete-file script))))
(ert-deftest etaf-docs-readme-examples-mount-and-dispatch-in-fresh-emacs ()
"Both READMEs must work from their exact requires in isolated processes."
(dolist (file '("README.md" "README.zh-CN.md"))
(let ((examples (etaf-docs-test--marked-examples
(etaf-docs-test--read file))))
(should (equal '("hello" "card" "counter") (mapcar #'car examples)))
(dolist (example examples)
(etaf-docs-test--run-fresh
(cdr example)
(pcase (car example)
("hello"
'(let ((runtime (etaf-runtime-for-buffer "*etaf-hello*")))
(should runtime)
(should (equal "Hello ETAF"
(etaf-dispatch-event runtime 'hello 'press)))
(etaf-unmount runtime)))
("card"
'(let ((runtime (etaf-runtime-for-buffer "*etaf-card*")))
(should runtime)
(with-current-buffer "*etaf-card*"
(should (string-match-p
"Account[[:space:]]+Connected[[:space:]]+Footer"
(buffer-string))))
(etaf-unmount runtime)))
("counter"
'(let ((runtime (etaf-runtime-for-buffer "*etaf-counter*")))
(should runtime)
(etaf-dispatch-event runtime 'increment 'press)
(with-current-buffer "*etaf-counter*"
(should (string-match-p "Count: 1" (buffer-string))))
(etaf-unmount runtime)))))))))
(ert-deftest etaf-docs-context-and-theme-examples-mount-in-fresh-emacs ()
"Run exact Context and Theme examples without prior definitions or imports."
(dolist (file '("docs/user-guide.en.md" "docs/user-guide.zh.md"
"docs/architecture.en.md" "docs/architecture.zh.md"))
(let ((examples (etaf-docs-test--marked-examples
(etaf-docs-test--read file))))
(should (equal '("context" "theme")
(sort (mapcar #'car examples) #'string<)))
(dolist (example examples)
(etaf-docs-test--run-fresh
(cdr example)
(pcase (car example)
("context"
'(let ((runtime (etaf-runtime-for-buffer "*etaf-context*")))
(should runtime)
(with-current-buffer "*etaf-context*"
(should (string-match-p "Service: demo-service"
(buffer-string))))
(etaf-unmount runtime)))
("theme"
'(let* ((runtime (etaf-runtime-for-buffer "*etaf-theme*"))
(props (gethash 'themed-content
(etaf-runtime-host-props runtime))))
(should runtime)
(should (equal "#F4F6FB" (plist-get props :color)))
(should (equal "#202634" (plist-get props :background-color)))
(with-current-buffer "*etaf-theme*"
(goto-char (point-min))
(should (search-forward "Themed content" nil t))
(let ((face (get-text-property (1- (point)) 'face)))
(should (string-match-p "#F4F6FB" (format "%S" face)))
(should (string-match-p "#202634" (format "%S" face)))))
(etaf-unmount runtime)))))))))
(defun etaf-docs-test--mounted-collection-probe (forms)
"Load exact documentation FORMS and mount the collection composition."
(etaf-component-redefine-run
(lambda ()
(dolist (form forms)
(eval form t))))
(let ((buffer (generate-new-buffer " *etaf-docs-m0b*")))
(unwind-protect
(progn
(let ((view
(eval
'(etaf-view
(etaf-docs-collection-card
:items '((1 . "One") (2 . "Two"))
:footer-view (etaf-view (text "Dynamic"))
(slot :name 'footer (text "Footer"))))
t)))
(etaf-mount buffer view))
(let ((text (with-current-buffer buffer (buffer-string))))
(dolist (expected '("One" "Two" "Dynamic" "Footer"))
(should (string-match-p expected text)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when (buffer-live-p buffer)
(kill-buffer buffer)))))
(ert-deftest etaf-docs-have-paired-long-lived-files ()
"Keep the public architecture, guide, and plan in both languages."
(dolist (file '("README.md"
@ -61,6 +220,8 @@
"docs/user-guide.zh.md"
"docs/implementation-plan.en.md"
"docs/implementation-plan.zh.md"
"docs/migration-0.2.en.md"
"docs/migration-0.2.zh.md"
"postmortem/2026-08-05-executable-core-examples.en.md"
"postmortem/2026-08-05-executable-core-examples.zh.md"))
(should (file-exists-p (expand-file-name file etaf-docs-test--root)))))
@ -76,7 +237,12 @@
(let ((contents (etaf-docs-test--read file)))
(should-not
(string-match-p
(regexp-opt '("etaf-template" "etaf-create-app")) contents))
(regexp-opt '("etaf-template" "etaf-create-app" "expr :value"
"ETAF also registers the short alias"
"registry assigns a semantic"
"ETAF 也会注册短 alias"
"注册表会分配语义明确的"))
contents))
(should-not (string-match-p "(text \"[^\"]+\" :" contents))))
(let ((guide (etaf-docs-test--read "docs/user-guide.en.md")))
(dolist (token '("etaf-view" "etaf-mount" "etaf-define-component"
@ -95,8 +261,142 @@
(etaf-docs-test--read file)))
(should (> (etaf-docs-test--read-all block) 0)))))
(ert-deftest etaf-docs-component-contract-is-current ()
"Keep public Component prose aligned with the authoritative macro contract."
(dolist (file '("docs/architecture.en.md" "docs/architecture.zh.md"
"docs/user-guide.en.md" "docs/user-guide.zh.md"
"docs/implementation-plan.en.md"
"docs/implementation-plan.zh.md"))
(let ((contents (etaf-docs-test--read file)))
(should (string-match-p (regexp-quote ":view") contents))
(should (string-match-p (regexp-quote ":render") contents))
(should (string-match-p (regexp-quote ":setup") contents))
(should (string-match-p (regexp-opt '("opaque state" "opaque 状态"))
contents))
(should-not
(string-match-p
(regexp-opt '("setup returns a zero-argument render function"
":setup` runs once per retained identity and returns a zero-argument render function"
":setup` runs once for a retained Component instance and must return a zero-argument render function"
"返回零参数 render 函数"
"必须返回零参数 render 函数"))
contents)))))
(ert-deftest etaf-docs-data-grid-selection-contract-is-current ()
"Document only selection inputs actually declared by `etaf-data-grid'."
(dolist (file '("docs/user-guide.en.md" "docs/user-guide.zh.md"))
(let ((contents (etaf-docs-test--read file)))
(should (string-match-p (regexp-quote ":row-selected-p") contents))
(should-not (string-match-p (regexp-quote ":selected-key") contents)))))
(ert-deftest etaf-docs-superseded-proposals-not-current-contract ()
"Keep the old Component proposal explicitly historical."
(let ((contents
(etaf-docs-test--read "docs/proposals/component-definition.zh.md")))
(should (string-match-p "SUPERSEDED" contents))
(should (string-match-p "historical" contents))
(should (string-match-p (regexp-quote "docs/architecture.zh.md") contents))
(should-not (string-match-p "尚未实现" contents))))
(ert-deftest etaf-docs-module-boundaries-target-vocabulary-is-paired ()
"Keep the English and Chinese target Component vocabulary equivalent."
(dolist (file '("docs/proposals/module-boundaries.en.md"
"docs/proposals/module-boundaries.zh.md"))
(let ((contents (etaf-docs-test--read file)))
(dolist (token '(":view" ":render" ":setup" "etaf-state" "etaf-node"
"opaque"))
(should (string-match-p (regexp-quote token) contents))))))
(ert-deftest etaf-docs-interaction-contract-is-current ()
"Keep the public Action/Behavior/event composition contract explicit."
(dolist (file '("docs/architecture.en.md" "docs/architecture.zh.md"
"docs/user-guide.en.md" "docs/user-guide.zh.md"))
(let ((contents (etaf-docs-test--read file)))
(dolist (token '("Host" "Behavior" "short-circuit" "first"
"capture" "bubble" "application" "feature"
"etaf-action-redefine-run" "dispatch"))
(should (string-match-p (regexp-quote token) contents))))))
(ert-deftest etaf-docs-component-manifest-is-machine-readable ()
"Validate the three-column Component manifest and observed evidence."
(let* ((script (expand-file-name "scripts/etaf-m0b-component-manifest.el"
etaf-docs-test--root))
(json-object-type 'alist)
(json-array-type 'list)
(manifest
(with-temp-buffer
(let ((standard-output (current-buffer)))
(load script nil t)
(etaf-m0b-component-manifest-write-json))
(goto-char (point-min))
(json-read))))
(should (equal 1 (alist-get 'schema-version manifest)))
(should (equal "observed" (alist-get 'evidence-mode manifest)))
(dolist (entry (alist-get 'components manifest))
(should (alist-get 'declared-business-props entry))
(should (alist-get 'forwarded-host-attrs entry))
(should (alist-get 'root-shape-forwarding-guarantee entry))
(should (eq t (alist-get 'mounted-validation entry))))))
(defun etaf-docs-test--snapshot-probe (forms)
"Run exact snapshot FORMS after one local publication in the documented app."
(let ((label (etaf-ref "Before"))
(buffer-name "*etaf-hello*"))
(should-not (get-buffer buffer-name))
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-view (text (expr (etaf-value label)))))
(setf (etaf-value label) "Current")
(let ((result (eval (cons 'progn forms) t)))
(should (= 3 (length result)))
(should (and (integerp (nth 0 result)) (> (nth 0 result) 0)))
(should (integerp (nth 1 result)))
(should (equal "Current" (substring-no-properties (nth 2 result))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-docs-executable-suite-is-fail-closed ()
"Classify exact blocks before macroexpansion, loading, or mounted smoke."
(let ((fixture (expand-file-name
"tests/fixtures/etaf-m0b-doc-examples.sexp"
etaf-docs-test--root)))
(should (file-readable-p fixture))
(let ((records (with-temp-buffer
(insert-file-contents fixture)
(goto-char (point-min))
(read (current-buffer)))))
(should records)
(dolist (record records)
(let* ((file (plist-get record :file))
(index (plist-get record :block))
(classification (plist-get record :classification))
(blocks (etaf-docs-test--elisp-blocks
(etaf-docs-test--read file)))
(source (nth (1- index) blocks)))
(should source)
(should (equal (secure-hash 'sha256 source)
(plist-get record :sha256)))
(should (memq classification
'(macroexpand-only load-safe mounted-smoke)))
(pcase classification
('macroexpand-only
(should (> (etaf-docs-test--read-all source) 0)))
((or 'load-safe 'mounted-smoke)
(let ((forms (etaf-docs-test--forms source)))
(dolist (form forms)
(should (macroexpand-all (copy-tree form))))
(pcase (plist-get record :probe)
('collection-composition
(etaf-docs-test--mounted-collection-probe forms))
('runtime-snapshot
(etaf-docs-test--snapshot-probe forms))
('nil (dolist (form forms) (eval form t)))
(_ (ert-fail "Unknown safe documentation probe")))))))))))
(ert-deftest etaf-source-uses-only-public-ebox-names ()
"Keep the ETAF implementation independent of Ebox private functions."
"Reject Ebox private functions, fields and dynamic construction context."
(dolist (file
(append
(directory-files etaf-docs-test--root t "\\.el\\'")
@ -105,7 +405,9 @@
t "\\.el\\'")))
(with-temp-buffer
(insert-file-contents file)
(should-not (re-search-forward "ebox--" nil t)))))
;; Include module-qualified names such as canonical input accessors;
;; checking only the facade prefix misses those boundary violations.
(should-not (re-search-forward "\\_<ebox[-[:alnum:]]*--" nil t)))))
(ert-deftest etaf-examples-use-only-public-etaf-names ()
"Keep executable examples on the public ETAF contract."

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,789 @@
;;; etaf-event-forwarding-tests.el --- Composable Host interaction tests -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Exercise fallthrough, committed disabled state, and interaction boundaries.
;;; Code:
(require 'ert)
(require 'etaf)
(defvar etaf-forward-test--trace nil)
(defvar etaf-forward-test--inner-use nil)
(defvar etaf-forward-test--middle-use nil)
(defvar etaf-forward-test--inner-disabled nil)
(defun etaf-forward-test--record (item)
"Append ITEM to the current interaction trace."
(setq etaf-forward-test--trace (append etaf-forward-test--trace (list item))))
(defun etaf-forward-test--dispose (buffer)
"Unmount and kill test BUFFER."
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))
(etaf-define-component etaf-forward-test-leaf (&key on-press use disabled ref)
:view (text :ref ref :role 'button :tab-index 0 :disabled disabled
:on-press on-press :use use "Press"))
(etaf-define-component etaf-forward-test-middle ()
:view (etaf-forward-test-leaf
:ref 'internal
:disabled (if (etaf-ref-p etaf-forward-test--inner-disabled)
(etaf-value etaf-forward-test--inner-disabled)
etaf-forward-test--inner-disabled)
:use etaf-forward-test--inner-use
:on-press (lambda () (etaf-forward-test--record 'inner))))
(etaf-define-component etaf-forward-test-outer ()
:view (etaf-forward-test-middle
:use etaf-forward-test--middle-use
:on-press (lambda () (etaf-forward-test--record 'middle))))
(etaf-define-component etaf-forward-test-business (&key on-change)
:view (text :role 'checkbox :aria-checked nil
:on-press (let ((change on-change))
(lambda ()
(etaf-forward-test--record 'business)
(funcall change t)))
"Toggle"))
(etaf-define-component etaf-forward-test-layout (&key width classes use renders)
:render
(progn
(cl-incf (aref renders 0))
(if (eq use 'absent)
(etaf-view (box :ref 'layout :width (etaf-value width)
:class (etaf-value classes) (text "Text")))
(etaf-view (box :ref 'layout :width (etaf-value width)
:class (etaf-value classes) :use use (text "Text"))))))
(ert-deftest etaf-forward-behavior-keeps-host-property-dependencies-local ()
"Omitted, empty, and active `:use' preserve the same Host update boundary."
(let ((installs 0) (cleanups 0) installed-props)
(dolist (use (list 'absent nil (etaf-focusable)
(etaf-behavior-create
'layout-probe
:install
(lambda ()
(cl-incf installs)
(setq installed-props
(etaf-behavior-context-host-props
(etaf-current-behavior-context)))
(lambda () (cl-incf cleanups))))))
(let ((buffer (generate-new-buffer " *etaf-behavior-layout*"))
(width (etaf-ref 10))
(classes (etaf-ref '(first)))
(renders (vector 0)))
(unwind-protect
(progn
(etaf-mount
buffer (etaf-node 'etaf-forward-test-layout
(list :width width :classes classes
:use use :renders renders) nil))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(should (equal renders [1]))
(setf (etaf-value width) 12)
(should (= 12 (plist-get (etaf-runtime-host-props-for runtime 'layout)
:width)))
(should (equal renders [1]))
(setf (etaf-value classes) '(second))
(should (equal '(second)
(plist-get (etaf-runtime-host-props-for runtime 'layout)
:class)))
(should (equal renders [1]))
(let ((generation (etaf-runtime-current-generation runtime)))
(cl-letf (((symbol-function 'etaf--runtime-swap-generation)
(lambda (&rest _) (error "Reject layout candidate"))))
(should-error (setf (etaf-value width) 14)))
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (= 12 (plist-get (etaf-runtime-host-props-for runtime 'layout)
:width)))
(should (equal renders [1])))))
(etaf-forward-test--dispose buffer))))
(should (= installs 1))
(should (= cleanups 1))
(should (= 10 (plist-get installed-props :width)))
(should (equal '(first) (plist-get installed-props :class)))
(should (eq 'layout (plist-get installed-props :ref)))))
(ert-deftest etaf-forward-declared-events-and-use-compose-once ()
"Consume declared callback/use props once through two root wrappers."
(let ((buffer " *etaf-forward-events*")
(etaf-forward-test--trace nil)
(etaf-forward-test--inner-use
(etaf-behavior-create
'inner :on-press (lambda () (etaf-forward-test--record 'behavior-inner))))
(etaf-forward-test--middle-use
(etaf-behavior-create
'middle :on-press (lambda () (etaf-forward-test--record 'behavior-middle)))))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-forward-test-outer
:ref 'target
:on-press (lambda () (etaf-forward-test--record 'outer))
:use (etaf-behavior-create
'outer :on-press
(lambda () (etaf-forward-test--record 'behavior-outer))))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-dispatch-event runtime 'target 'press)
(should (equal etaf-forward-test--trace
'(inner middle outer behavior-inner
behavior-middle behavior-outer)))
(should-not (etaf-runtime-handler-for runtime 'internal))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-disabled-or-recomputes-and-guards-public-input ()
"Outer nil never enables an internally disabled Host; later inputs recover."
(let* ((buffer " *etaf-forward-disabled*")
(outer-disabled (etaf-ref nil))
(inner-disabled (etaf-ref t))
(etaf-forward-test--inner-disabled inner-disabled)
(etaf-forward-test--trace nil))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view (etaf-forward-test-middle
:ref 'target :disabled (etaf-value outer-disabled)))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(should (plist-get (etaf-runtime-host-props-for runtime 'target)
:disabled))
(should-error (etaf-dispatch-event runtime 'target 'press)
:type 'etaf-event-error)
(should-error (etaf-focus runtime 'target) :type 'etaf-event-error)
(setf (etaf-value inner-disabled) nil)
(etaf-dispatch-event runtime 'target 'press)
(should (equal etaf-forward-test--trace '(inner)))
(setf (etaf-value outer-disabled) t)
(should-error (etaf-dispatch-event runtime 'target 'press)
:type 'etaf-event-error)
(setf (etaf-value outer-disabled) nil)
(etaf-dispatch-event runtime 'target 'press)
(should (equal etaf-forward-test--trace '(inner inner)))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-host-attribute-ownership ()
"Presentation defaults and caller labels coexist with owned role/state."
(let* ((root '(:color "red" :class "base" :role button :aria-checked nil
:tab-index 0 :aria-label "Default" :ref fallback))
(merged (etaf--merge-host-attrs
root '(:color nil :class (caller base) :tab-index 2
:aria-label "Caller" :ref target) 'text 'example)))
(should (equal "red" (plist-get merged :color)))
(should (equal '("base" "caller") (plist-get merged :class)))
(should (= 2 (plist-get merged :tab-index)))
(should (equal "Caller" (plist-get merged :aria-label)))
(should (eq 'target (plist-get merged :ref)))
(should-error (etaf--merge-host-attrs root '(:role navigation) 'text 'example)
:type 'etaf-component-call-error)
(should-error (etaf--merge-host-attrs root '(:aria-checked t) 'text 'example)
:type 'etaf-component-call-error)))
(ert-deftest etaf-forward-business-conversion-precedes-subscriptions ()
"A consumed change prop remains the business conversion for one press."
(let ((buffer " *etaf-forward-conversion*")
(etaf-forward-test--trace nil) (value nil))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-forward-test-business
:ref 'target
:on-change (lambda (next)
(setq value next)
(etaf-forward-test--record 'change))
:on-press (lambda () (etaf-forward-test--record 'outer))
:use (etaf-behavior-create
'observer :on-press
(lambda () (etaf-forward-test--record 'behavior))))))
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) 'target 'press)
(should value)
(should (equal etaf-forward-test--trace
'(business change outer behavior))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-wrapper-duplicate-behaviors-fail-before-install ()
"Do not lose duplicate names when declared use props consume fallthrough."
(let* ((buffer " *etaf-forward-duplicate-use*")
(installs 0)
(behavior (etaf-behavior-create
'duplicate :install (lambda () (cl-incf installs) nil)))
(etaf-forward-test--inner-use behavior))
(unwind-protect
(progn
(should-error
(etaf-mount buffer (etaf-view (etaf-forward-test-middle :use behavior)))
:type 'etaf-behavior-error)
(should (zerop installs)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-failed-callback-stops-outer-subscriptions ()
"An inner callback error stops outer subscriptions and Behaviors."
(let ((buffer " *etaf-forward-callback-failure*")
(etaf-forward-test--trace nil))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-forward-test-business
:ref 'target :on-change (lambda (_) (error "change failed"))
:on-press (lambda () (etaf-forward-test--record 'outer))
:use (etaf-behavior-create
'observer :on-press
(lambda () (etaf-forward-test--record 'behavior))))))
(should-error
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) 'target 'press))
(should (equal etaf-forward-test--trace '(business))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-behavior-final-props-precede-any-installer ()
"Installers receive final merged semantic props, after validation."
(let ((buffer " *etaf-forward-behavior-props*") (installs 0) (observed nil))
(unwind-protect
(let ((first
(etaf-behavior-create
'first :install
(lambda ()
(cl-incf installs)
(setq observed
(etaf-behavior-context-host-props
(etaf-current-behavior-context)))
nil))))
(etaf-mount
buffer
(etaf-view
(text :ref 'target
:use (list first
(etaf-behavior-create 'label :aria-label "Final"))
"Target")))
(should (= installs 1))
(should (equal "Final" (plist-get observed :aria-label)))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(setq installs 0)
(should-error
(etaf-mount
buffer
(etaf-view
(text :ref 'target
:use (list first
(etaf-behavior-create 'invalid :disabled 'wrong))
"Target")))
:type 'etaf-renderer-error)
(should (zerop installs)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-disabled-behavior-never-installs ()
"Final disabled state, including Behavior defaults, precedes installation."
(let ((buffer " *etaf-forward-behavior-disabled*") (installs 0))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(text :ref 'target :disabled nil
:use (list
(etaf-behavior-create
'first :install (lambda () (cl-incf installs) nil))
(etaf-behavior-create 'disabled :disabled t))
"Disabled")))
(should (zerop installs))
(should (plist-get (etaf-runtime-host-props-for
(etaf-runtime-for-buffer buffer) 'target)
:disabled)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-behavior-disabled-transitions-and-rollback ()
"Commit disables clean up once; failed disables preserve the old resource."
(let ((buffer " *etaf-forward-behavior-transition*")
(mode (etaf-ref 'enabled))
(installs 0) (cleanups 0))
(unwind-protect
(let ((behavior (etaf-behavior-create
'resource :install
(lambda () (cl-incf installs)
(lambda () (cl-incf cleanups))))))
(etaf-mount
buffer
(lambda ()
(etaf-view
(column
(text :ref 'target :use behavior
:disabled (not (eq (etaf-value mode) 'enabled)) "Target")
(text (expr (if (eq (etaf-value mode) 'failed)
(error "later sibling failed") "OK")))))))
(should (= installs 1))
(should-error (setf (etaf-value mode) 'failed))
(should (= cleanups 0))
(should-not (plist-get (etaf-runtime-host-props-for
(etaf-runtime-for-buffer buffer) 'target)
:disabled))
(setf (etaf-value mode) 'disabled)
(should (= cleanups 1))
(setf (etaf-value mode) 'enabled)
(should (= installs 2))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (= cleanups 2)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-failed-enable-disposes-only-candidate-behavior ()
"A failed enable cleans its new resource while committed Host stays disabled."
(let ((buffer " *etaf-forward-enable-rollback*")
(mode (etaf-ref 'disabled)) (installs 0) (cleanups 0))
(unwind-protect
(let ((behavior
(etaf-behavior-create
'resource :install
(lambda () (cl-incf installs)
(lambda () (cl-incf cleanups))))))
(etaf-mount
buffer
(etaf-view
(column
(text :ref 'target :use behavior
:disabled (eq (etaf-value mode) 'disabled) "Target")
(text (expr (if (eq (etaf-value mode) 'failed)
(error "later sibling failed") "OK"))))))
(should (zerop installs))
(should-error (setf (etaf-value mode) 'failed))
(should (= installs 1))
(should (= cleanups 1))
(should (plist-get (etaf-runtime-host-props-for
(etaf-runtime-for-buffer buffer) 'target)
:disabled))
(setf (etaf-value mode) 'enabled)
(should (= installs 2))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (= cleanups 2)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-component-overlay-promotes-behavior-lifetime ()
"A locally enabled Component owns its installed Behavior through teardown."
(let ((buffer " *etaf-forward-overlay-behavior*")
(disabled (etaf-ref t)) (installs 0) (cleanups 0))
(unwind-protect
(let ((behavior
(etaf-behavior-create
'resource :install
(lambda () (cl-incf installs)
(lambda () (cl-incf cleanups))))))
;; Passing a View value keeps dependency ownership on the Component
;; input effect, exercising local overlay instead of Root rebuild.
(etaf-mount buffer
(etaf-view (etaf-forward-test-leaf
:ref 'target :use behavior
:disabled (etaf-value disabled))))
(should (zerop installs))
(setf (etaf-value disabled) nil)
(should (= installs 1))
(should (zerop cleanups))
(setf (etaf-value disabled) t)
(should (= cleanups 1))
(setf (etaf-value disabled) nil)
(should (= installs 2))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (= cleanups 2)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-root-fallback-releases-abandoned-behavior ()
"A local anchor proof miss releases candidate resources before Root retry."
(let ((buffer " *etaf-forward-fallback-behavior*")
(disabled (etaf-ref t)) (installs 0) (cleanups 0)
(miss-next t))
(unwind-protect
(let ((behavior
(etaf-behavior-create
'resource :install
(lambda () (cl-incf installs)
(lambda () (cl-incf cleanups))))))
(etaf-mount
buffer
(etaf-view
(column
(etaf-forward-test-leaf :ref 'target :use behavior
:disabled (etaf-value disabled))
;; Read here to change this structural Range. A text child's
;; deferred Expr correctly owns its own independent update.
(expr (etaf-node
'text nil
(list (if (etaf-value disabled) "Disabled" "Enabled")))))))
(let ((original
(symbol-function 'etaf--runtime-range-change-has-backend-anchor-p)))
(cl-letf (((symbol-function 'etaf--runtime-range-change-has-backend-anchor-p)
(lambda (runtime change)
(if miss-next
(progn (setq miss-next nil) nil)
(funcall original runtime change)))))
(setf (etaf-value disabled) nil)))
(should-not miss-next)
(should (= installs 2))
(should (= cleanups 1))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (= cleanups 2)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-removed-component-retires-behavior-immediately ()
"A removed dynamic child releases its Behavior without waiting for unmount."
(let ((buffer " *etaf-forward-removed-behavior*")
(visible (etaf-ref t)) (installs 0) (cleanups 0))
(unwind-protect
(let ((behavior
(etaf-behavior-create
'resource :install
(lambda () (cl-incf installs)
(lambda () (cl-incf cleanups))))))
(etaf-mount
buffer
(etaf-view (column
(etaf-forward-test-leaf :if (etaf-value visible)
:ref 'target :use behavior))))
(should (= installs 1))
(setf (etaf-value visible) nil)
(should (= cleanups 1))
(should-not
(etaf--generation-index-entries
(etaf-runtime-current-generation (etaf-runtime-for-buffer buffer))
'behaviors))
(setf (etaf-value visible) t)
(should (= installs 2))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (= cleanups 2)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-component-overlay-removes-use-resources ()
"Changing or removing use retires obsolete names on a retained Host."
(let ((buffer " *etaf-forward-overlay-use*")
(use (etaf-ref nil)) (installs 0) (cleanups 0))
(unwind-protect
(let* ((install (lambda () (cl-incf installs)
(lambda () (cl-incf cleanups))))
(first (etaf-behavior-create 'first :install install))
(second (etaf-behavior-create 'second :install install)))
(setf (etaf-value use) first)
(etaf-mount
buffer (etaf-view (etaf-forward-test-leaf
:ref 'target :use (etaf-value use))))
(should (= installs 1))
(setf (etaf-value use) second)
(should (= installs 2))
(should (= cleanups 1))
(setf (etaf-value use) nil)
(should (= cleanups 2))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (= cleanups 2)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-keyed-host-behaviors-follow-owner-through-reorder ()
"Keyed Host resources follow semantic owners through reorder and removal."
(let ((buffer " *etaf-forward-keyed-behavior*") active events)
(unwind-protect
(let* ((behavior
(etaf-behavior-create
'resource :install
(lambda ()
(let ((ref (plist-get
(etaf-behavior-context-host-props
(etaf-current-behavior-context)) :ref)))
(push ref active)
(push (list 'install ref) events)
(lambda ()
(setq active (delq ref active))
(push (list 'cleanup ref) events))))))
(a (etaf-node 'box (list :key 'a :ref 'a :use behavior) '("A")))
(b (etaf-node 'box (list :key 'b :ref 'b :use behavior) '("B")))
(items (etaf-ref (list a b))))
(etaf-mount buffer (etaf-view (column (expr (etaf-value items)))))
(setf (etaf-value items) (list b a))
(should (equal events '((install b) (install a))))
(setf (etaf-value items) (list b))
(should (equal active '(b)))
(should (equal events '((cleanup a) (install b) (install a))))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should-not active)
(should (= 1 (cl-count '(cleanup a) events :test #'equal)))
(should (= 1 (cl-count '(cleanup b) events :test #'equal))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-keyed-behavior-failure-retains-committed-owners ()
"Failed reorder/removal keeps committed resources and cleans only new ones."
(let ((buffer " *etaf-forward-keyed-behavior-rollback*") active events)
(unwind-protect
(let* ((behavior
(etaf-behavior-create
'resource :install
(lambda ()
(let ((ref (plist-get
(etaf-behavior-context-host-props
(etaf-current-behavior-context)) :ref)))
(push ref active)
(push (list 'install ref) events)
(lambda ()
(setq active (delq ref active))
(push (list 'cleanup ref) events))))))
(a (etaf-node 'box (list :key 'a :ref 'a :use behavior) '("A")))
(b (etaf-node 'box (list :key 'b :ref 'b :use behavior) '("B")))
(c (etaf-node 'box (list :key 'c :ref 'c :use behavior) '("C")))
(mode (etaf-ref 'initial)))
(etaf-mount
buffer
(etaf-view
(column
(expr (pcase (etaf-value mode)
('initial (list a b))
('failed (list b c))
(_ (list b))))
(text (expr (if (eq (etaf-value mode) 'failed)
(error "later sibling failed") "OK"))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime)))
(should-error (setf (etaf-value mode) 'failed))
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (equal active '(b a)))
(should (equal events
'((cleanup c) (install c) (install b) (install a))))
(setf (etaf-value mode) 'removed)
(should (equal active '(b)))
(should (equal (car events) '(cleanup a)))
(etaf-unmount runtime)
(should-not active)
(dolist (ref '(a b c))
(should (= 1 (cl-count (list 'install ref) events :test #'equal)))
(should (= 1 (cl-count (list 'cleanup ref) events :test #'equal))))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-behavior-installer-receives-effective-host-ref ()
"An installer receives the effective address of an automatically referenced Host."
(let ((buffer " *etaf-forward-behavior-generated-ref*") installed-ref)
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(text :role 'button :on-press #'ignore
:use (etaf-behavior-create
'resource :install
(lambda ()
(setq installed-ref
(plist-get
(etaf-behavior-context-host-props
(etaf-current-behavior-context)) :ref))
nil))
"Control")))
(should installed-ref)
(should (etaf-runtime-handler-for
(etaf-runtime-for-buffer buffer) installed-ref)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-behavior-address-change-reinstalls-after-commit ()
"A retained Host changing its ref replaces the resource bound to that address."
(let ((buffer " *etaf-forward-behavior-ref-change*")
(ref (etaf-ref 'a)) active events)
(unwind-protect
(let ((behavior
(etaf-behavior-create
'resource :install
(lambda ()
(let ((address (plist-get
(etaf-behavior-context-host-props
(etaf-current-behavior-context)) :ref)))
(push address active)
(push (list 'install address) events)
(lambda ()
(setq active (delq address active))
(push (list 'cleanup address) events)))))))
(etaf-mount
buffer
(etaf-view (box :key 'stable :ref (etaf-value ref) :use behavior "Host")))
(setf (etaf-value ref) 'b)
(should (equal active '(b)))
(should (equal events '((cleanup a) (install b) (install a))))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should-not active)
(should (equal (car events) '(cleanup b))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-carried-component-keeps-behavior-resource ()
"A Root update carrying an unchanged Component retains its Host resource."
(let ((buffer " *etaf-forward-carried-behavior*")
(version (etaf-ref 0)) (installs 0) (cleanups 0))
(unwind-protect
(let ((behavior
(etaf-behavior-create
'resource :install
(lambda () (cl-incf installs)
(lambda () (cl-incf cleanups))))))
(etaf-mount
buffer
(lambda ()
(etaf-value version)
(etaf-view
(column
(etaf-forward-test-leaf :ref 'target :use behavior)))))
(should (= installs 1))
(setf (etaf-value version) 1)
(should (= installs 1))
(should (zerop cleanups))
(etaf-unmount (etaf-runtime-for-buffer buffer))
(should (= cleanups 1)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-callback-snapshot-changes-only-after-commit ()
"Composed subscriptions preserve committed scalar props after render fails."
(let ((buffer " *etaf-forward-callback-commit*")
(version (etaf-ref 'a)) (seen nil)
(etaf-forward-test--trace nil))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(column
(etaf-forward-test-middle
:ref 'target
:on-press (let ((snapshot (etaf-value version)))
(lambda () (push snapshot seen))))
(text (expr (if (eq (etaf-value version) 'failed)
(error "later sibling failed") "OK"))))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-dispatch-event runtime 'target 'press)
(should-error (setf (etaf-value version) 'failed))
(etaf-dispatch-event runtime 'target 'press)
(setf (etaf-value version) 'b)
(etaf-dispatch-event runtime 'target 'press)
(should (equal seen '(b a a)))
(should (equal etaf-forward-test--trace '(inner inner inner)))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-child-boundary-blocks-parent-activation ()
"A disabled or callbackless child owns its hit area, including equal bounds."
(let ((buffer " *etaf-forward-hit-boundary*") (trace nil))
(unwind-protect
(dolist (child-props '((:disabled t :on-press ignore) nil))
(etaf-mount
buffer
(lambda ()
(etaf-node
'box (list :ref 'aaa-parent :role 'row :tab-index 0
:on-press (lambda () (push 'parent trace)))
(list (etaf-node
'text (append '(:ref zzz-child :role button) child-props)
'("Child"))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(position (etaf-host-ref-position runtime 'zzz-child)))
(should (equal (etaf-host-ref-bounds runtime 'aaa-parent)
(etaf-host-ref-bounds runtime 'zzz-child)))
(should-error (etaf--activation-at-position runtime position)
:type 'user-error)
(should-not trace)
(etaf-focus runtime 'aaa-parent)
(etaf-activate runtime)
(should (equal trace '(parent)))
(setq trace nil)
(etaf-unmount runtime)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-child-wins-and-ordinary-text-belongs-to-parent ()
"Semantic descendants beat equal bounds; passive text keeps row activation."
(let ((buffer " *etaf-forward-hit-order*") (trace nil))
(unwind-protect
(dolist (interactive '(t nil))
(etaf-mount
buffer
(lambda ()
(etaf-node
'box (list :ref 'aaa-parent
:on-press (lambda () (push 'parent trace)))
(list (etaf-node
'text (append '(:ref zzz-child)
(when interactive
(list :role 'button :on-press
(lambda () (push 'child trace)))))
'("Child"))))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf--activation-at-position
runtime (etaf-host-ref-position runtime 'zzz-child))
(should (equal trace (if interactive '(child) '(parent))))
(setq trace nil)
(etaf-unmount runtime)))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-focused-control-follows-changing-layout ()
"Repeated keyboard activation follows a retained control after width changes."
(let ((buffer " *etaf-forward-focus-layout*") (page (etaf-ref 9)))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(row
(text (expr (format "Page %s" (etaf-value page))))
(text :ref 'next :role 'button :tab-index 0
:on-press (lambda () (cl-incf (etaf-value page))) "Next"))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-focus runtime 'next)
(etaf-activate runtime)
(should (= (etaf-value page) 10))
(should (eq (etaf-focused-host-ref runtime) 'next))
(with-current-buffer buffer
(should (= (point) (etaf-host-ref-position runtime 'next))))
(etaf-activate runtime)
(should (= (etaf-value page) 11))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-layout-update-respects-manually-moved-point ()
"A layout commit must not pull point back after the user leaves a control."
(let ((buffer " *etaf-forward-focus-manual*") (page (etaf-ref 9)))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(row
(text (expr (format "Page %s" (etaf-value page))))
(text :ref 'next :role 'button :tab-index 0 "Next"))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-focus runtime 'next)
(with-current-buffer buffer (goto-char (point-min)))
(setf (etaf-value page) 10)
(with-current-buffer buffer
(should (= (point) (point-min)))
(should-not (= (point) (etaf-host-ref-position runtime 'next))))))
(etaf-forward-test--dispose buffer))))
(ert-deftest etaf-forward-focused-point-survives-failed-publication ()
"A failed candidate retains the old focus and point; the next commit follows."
(let ((buffer " *etaf-forward-focus-rollback*") (page (etaf-ref 9)))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(row
(text (expr (format "Page %s" (etaf-value page))))
(text :ref 'next :role 'button :tab-index 0 "Next")
(text (expr (if (= (etaf-value page) 10)
(error "later rendering failed") "OK"))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(position (etaf-host-ref-position runtime 'next)))
(etaf-focus runtime 'next)
(should-error (setf (etaf-value page) 10))
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (eq (etaf-focused-host-ref runtime) 'next))
(with-current-buffer buffer (should (= (point) position)))
(setf (etaf-value page) 11)
(with-current-buffer buffer
(should (= (point) (etaf-host-ref-position runtime 'next))))))
(etaf-forward-test--dispose buffer))))
(provide 'etaf-event-forwarding-tests)
;;; etaf-event-forwarding-tests.el ends here

View File

@ -0,0 +1,852 @@
;;; etaf-g1-cross-layer-tests.el --- G1 cross-layer fault gate -*- lexical-binding: t; -*-
(require 'cl-lib)
(require 'ert)
(require 'etaf)
(require 'etaf-render-port)
(require 'tp-reactive)
(require 'ebox-spi)
(require 'ebox-surface)
(require 'ebox-native-reflow)
(define-error 'etaf-g1-retirement-error "G1 retirement test error")
(defvar etaf-g1--tp-trace nil)
(defvar etaf-g1--tp-precommit-condition nil)
(defun etaf-g1--tp-precommit-probe ()
"Record and optionally signal the G1 TP precommit fault."
(push 'precommit etaf-g1--tp-trace)
(when etaf-g1--tp-precommit-condition
(signal (car etaf-g1--tp-precommit-condition)
(cdr etaf-g1--tp-precommit-condition))))
(defconst etaf-g1--workspace-root
(expand-file-name "../.."
(file-name-directory
(or load-file-name buffer-file-name)))
"Workspace root used by cross-package evidence checks.")
(defconst etaf-g1-fault-matrix
'((tp-order . etaf-g1-tp-order-precommit-and-rollback-are-atomic)
(multi-surface . etaf-g1-tp-multi-surface-final-accept-restores-in-order)
(combined-participant . etaf-g1-ebox-etaf-combined-participant-same-report)
(spi-branches . etaf-g1-spi-four-branches-and-selected-port-immutability)
(generation-host-cas . etaf-g1-generation-cas-and-host-lifecycle-guards)
(v2-runtime-contract . etaf-g1-v2-runtime-contract)
(runtime-fault-rollback . etaf-g1-runtime-fault-restores-authorities)
(postcommit-diagnostics . etaf-g1-postcommit-report-fault-keeps-accepted-state)
(host-unmount-kill . etaf-g1-host-unmount-and-kill-inflight-route)
(nested-runtime-event . etaf-g1-nested-runtime-event-batches-once)
(multi-context . etaf-g1-multi-context-runtimes-isolate)
(native-fallback . etaf-g1-native-fallback-keeps-surface)
(retirement . etaf-g1-retirement-diagnostics-are-cause-compatible)
(load-path-harness . etaf-g1-research-shelf-load-path-harness-contract)
(gui-recovery-harness . etaf-g1-research-shelf-gui-recovery-harness-contract))
"Auditable G1 fault-gate coverage map.")
(defconst etaf-g1--required-fault-keys
'(tp-order multi-surface combined-participant spi-branches
generation-host-cas v2-runtime-contract runtime-fault-rollback
postcommit-diagnostics host-unmount-kill nested-runtime-event multi-context
native-fallback retirement load-path-harness gui-recovery-harness)
"Required unique behavior keys for the G1 cross-layer gate.")
(defun etaf-g1--cleanup-buffer (buffer-or-name)
"Unmount and kill BUFFER-OR-NAME, signaling any cleanup failure."
(when-let* ((runtime (etaf-runtime-for-buffer buffer-or-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-or-name)))
(when (ebox-surface-buffer-mounted-p buffer)
(ebox-unmount-buffer buffer))
(kill-buffer buffer)))
(defun etaf-g1--view (source)
"Return a small reactive View that exposes SOURCE as styled text."
(etaf-view
(text :ref 'g1-value :color "red"
(expr (format "value=%s" (etaf-value source))))))
(defun etaf-g1--normalized-property-runs (text)
"Return TEXT property runs with backend identities normalized by topology."
(let ((identity-map (make-hash-table :test #'equal))
(next-identity 0)
(position 0)
runs)
(cl-labels
((normalize
(identity)
(when identity
(or (gethash identity identity-map)
(prog1 next-identity
(puthash identity next-identity identity-map)
(cl-incf next-identity))))))
(while (< position (length text))
(let* ((next (or (next-property-change position text)
(length text)))
(properties (copy-tree (text-properties-at position text))))
(dolist (key '(ebox-content ebox-content-owner))
(when (plist-member properties key)
(setq properties
(plist-put properties key
(normalize (plist-get properties key))))))
(when (plist-member properties 'ebox-content-owners)
(setq properties
(plist-put
properties 'ebox-content-owners
(mapcar #'normalize
(plist-get properties 'ebox-content-owners)))))
(push (list :from position :to next :properties properties) runs)
(setq position next))))
(nreverse runs)))
(defun etaf-g1--surface-snapshot (buffer)
"Return public, rollback-sensitive rendering evidence for BUFFER."
(let* ((text (with-current-buffer buffer
(buffer-substring (point-min) (point-max))))
(semantic-text (copy-sequence text)))
(remove-text-properties
0 (length semantic-text)
'(ebox-content nil ebox-content-owner nil ebox-content-owners nil)
semantic-text)
(list :text text
:semantic-text semantic-text
:property-runs (etaf-g1--normalized-property-runs text)
:region-count (length (ebox-region-ids text))
:mounted (ebox-surface-buffer-mounted-p buffer)
:revision (and (ebox-surface-buffer-mounted-p buffer)
(ebox-surface-buffer-revision buffer))
:report (and (ebox-surface-buffer-mounted-p buffer)
(ebox-buffer-update-report buffer)))))
(defun etaf-g1--report-contract (report)
"Return route-independent committed fields from REPORT."
(mapcar (lambda (key) (cons key (plist-get report key)))
'(:runtime-published :surface-revision :strategy
:render-scope :publication-scope)))
(defun etaf-g1--surface-contract (buffer)
"Return route-independent visible surface evidence for BUFFER."
(let ((snapshot (etaf-g1--surface-snapshot buffer)))
(list :semantic-text (plist-get snapshot :semantic-text)
:property-runs (plist-get snapshot :property-runs)
:region-count (plist-get snapshot :region-count)
:mounted (plist-get snapshot :mounted)
:revision (plist-get snapshot :revision))))
(defun etaf-g1--runtime-host-contract (runtime)
"Return lifecycle and route authority evidence for RUNTIME."
(let ((authority (etaf-runtime-host-authority runtime))
(route (etaf-runtime-route-token runtime)))
(list :host-state (etaf-host-authority-state authority)
:host-version (etaf-host-authority-version authority)
:mounted (etaf-runtime-mounted-p runtime)
:pending (etaf-runtime-pending-p runtime)
:route-live (and (etaf-runtime-route-live-p route) t))))
(defun etaf-g1--runtime-visible-contract (runtime)
"Return route-independent visible and authority evidence for RUNTIME."
(append
(etaf-g1--surface-contract (etaf-runtime-buffer runtime))
(list :generation (etaf-runtime-generation runtime)
:token (etaf-runtime-generation-token runtime)
:store-versions (copy-tree (etaf-runtime-store-versions runtime)))
(etaf-g1--runtime-host-contract runtime)))
(defun etaf-g1--runtime-state (runtime)
"Return rollback-sensitive ETAF, Ebox, route, and store state for RUNTIME."
(let* ((buffer (etaf-runtime-buffer runtime))
(surface (etaf-g1--surface-snapshot buffer))
(report (plist-get surface :report)))
(list :visible (etaf-g1--runtime-visible-contract runtime)
:handlers (etaf-runtime-handler-entries runtime)
:host-props (etaf-runtime-host-props-entries runtime)
:resource-count
(hash-table-count (etaf-runtime-resource-registry runtime))
:artifact-count
(hash-table-count (etaf-runtime-artifact-registry runtime))
:range-artifact-count
(hash-table-count (etaf-runtime-range-artifact-registry runtime))
:route-source-count
(hash-table-count (etaf-runtime-route-sources runtime))
:paint-count
(hash-table-count (etaf-runtime-theme-paint-slots runtime))
:behavior-count
(hash-table-count (etaf-runtime-behaviors runtime))
:surface-report (and report (etaf-g1--report-contract report)))))
(ert-deftest etaf-g1-fault-matrix-is-auditable ()
(let ((keys (mapcar #'car etaf-g1-fault-matrix))
(tests (mapcar #'cdr etaf-g1-fault-matrix)))
(should (equal keys etaf-g1--required-fault-keys))
(should (= (length keys) (length (delete-dups (copy-sequence keys)))))
(should (= (length tests) (length (delete-dups (copy-sequence tests)))))
(dolist (test tests)
(should (symbolp test))
(should (ert-get-test test)))))
(ert-deftest etaf-g1-tp-order-precommit-and-rollback-are-atomic ()
"TP stages in order and reverses partial-stage and precommit faults."
(let (etaf-g1--tp-trace)
(let ((tp--transaction-participant-precommit-allowed-functions nil)
(tp--transaction-precommit-functions nil))
(should-error
(tp-with-transaction
(tp-transaction-participate-v2
:key 'tp-first
:stage (lambda () (push 'first-stage etaf-g1--tp-trace))
:rollback (lambda () (push 'first-rollback etaf-g1--tp-trace)))
(tp-transaction-participate-v2
:key 'tp-second
:stage (lambda () (push 'second-stage etaf-g1--tp-trace)
(error "G1 injected partial apply"))
:rollback (lambda () (push 'second-rollback etaf-g1--tp-trace))))))
(should
(equal (nreverse etaf-g1--tp-trace)
'(first-stage second-stage second-rollback first-rollback))))
(let ((etaf-g1--tp-trace nil)
(etaf-g1--tp-precommit-condition
'(error "G1 injected precommit failure"))
(tp--transaction-precommit-functions
'(etaf-g1--tp-precommit-probe))
(tp--transaction-precommit-allowed-functions
'(etaf-g1--tp-precommit-probe)))
(should-error
(tp-with-transaction
(tp-transaction-participate-v2
:key 'tp-first
:stage (lambda () (push 'first-stage etaf-g1--tp-trace))
:rollback (lambda () (push 'first-rollback etaf-g1--tp-trace)))
(tp-transaction-participate-v2
:key 'tp-second
:stage (lambda () (push 'second-stage etaf-g1--tp-trace))
:rollback (lambda () (push 'second-rollback etaf-g1--tp-trace)))))
(should
(equal (nreverse etaf-g1--tp-trace)
'(first-stage second-stage precommit
second-rollback first-rollback)))))
(ert-deftest etaf-g1-tp-multi-surface-final-accept-restores-in-order ()
"One TP publication updates two surfaces atomically and restores both."
(let* ((source (tp-signal-create 0))
(left-buffer (generate-new-buffer " *etaf-g1-tp-left*"))
(right-buffer (generate-new-buffer " *etaf-g1-tp-right*"))
(left nil) (right nil))
(unwind-protect
(progn
(setq left
(tp-surface-mount
left-buffer
(lambda (context)
(tp-object-ensure context nil 'root 'text)
(tp-surface-plan-create
:key 'root :kind 'text
:text (format "L%s" (tp-signal-read source))
:capability 'content))))
(setq right
(tp-surface-mount
right-buffer
(lambda (context)
(tp-object-ensure context nil 'root 'text)
(tp-surface-plan-create
:key 'root :kind 'text
:text (format "R%s" (tp-signal-read source))
:capability 'content))))
(let ((left-before (with-current-buffer left-buffer (buffer-string)))
(right-before (with-current-buffer right-buffer (buffer-string)))
(left-revision (tp-surface-revision left))
(right-revision (tp-surface-revision right))
condition)
(cl-letf (((symbol-function 'accept-change-group)
(lambda (&rest _)
(error "G1 injected final-accept failure"))))
(setq condition
(condition-case error-data
(progn (tp-signal-set source 1) nil)
((error quit) error-data))))
(should condition)
(should (tp-publication-failure-outcome-p
tp--last-transaction-outcome))
(should (= 2
(length
(tp-publication-failure-outcome-target-results
tp--last-transaction-outcome))))
(should (equal-including-properties
left-before (with-current-buffer left-buffer (buffer-string))))
(should (equal-including-properties
right-before (with-current-buffer right-buffer (buffer-string))))
(should (= left-revision (tp-surface-revision left)))
(should (= right-revision (tp-surface-revision right)))
(should (= 0 (tp-signal-peek source)))
(should (null (tp--transaction-condition-trailer
condition :rollback-failures)))))
(when (tp-surface-live-p left) (tp-surface-unmount left))
(when (tp-surface-live-p right) (tp-surface-unmount right))
(when (buffer-live-p left-buffer) (kill-buffer left-buffer))
(when (buffer-live-p right-buffer) (kill-buffer right-buffer))
(when (tp-signal-live-p source) (tp-signal-dispose source)))))
(ert-deftest etaf-g1-ebox-etaf-combined-participant-same-report ()
"Ebox SPI callbacks share reports while TP outcomes remain observational."
(let ((buffer (generate-new-buffer " *etaf-g1-combined*"))
(input (ebox-build '(box "g1")))
seen)
(unwind-protect
(progn
(let ((report
(ebox-framework-spi-initial
buffer input
(lambda (value) (setq seen value))
(lambda (_value) nil))))
(should (eq report seen))
(should (eq (plist-get report :framework-participant-state)
'completed))
(should (equal (mapcar (lambda (x) (plist-get x :provider))
(ebox-framework-spi-initial-observation-reports
report))
'(tp ebox)))
(should (tp-committed-success-outcome-p
tp--last-transaction-outcome))
(let ((first (tp--committed-success-outcome-snapshot
tp--last-transaction-outcome))
(second (tp--committed-success-outcome-snapshot
tp--last-transaction-outcome)))
(should (equal first second))
(should-not (eq first second))
(let ((counts (plist-get first :operation-counts)))
(should (consp counts))
(setcar counts :g1-mutated-counts)
(should-not (equal first second))
(should
(equal second
(tp--committed-success-outcome-snapshot
tp--last-transaction-outcome)))))
(let (update-seen update-return)
(setq update-return
(ebox-framework-spi-update
buffer input (lambda (value) (setq update-seen value)) #'ignore))
(should (eq update-seen update-return))
(should (tp-committed-success-outcome-p
tp--last-transaction-outcome)))))
(when (buffer-live-p buffer)
(when (ebox-surface-buffer-mounted-p buffer)
(ebox-unmount-buffer buffer))
(kill-buffer buffer)))))
(ert-deftest etaf-g1-runtime-fault-restores-authorities ()
"A semantic participant fault restores observable cross-layer authority."
(let* ((buffer-name (generate-new-buffer-name " *etaf-g1-runtime-fault*"))
(source (etaf-ref 0))
(events nil)
(failure-seen nil))
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-g1--view source))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(before (etaf-g1--runtime-state runtime))
(old-publish (symbol-function 'etaf--runtime-participant-publish))
(old-rollback (symbol-function 'etaf--runtime-participant-rollback))
(condition nil))
(cl-letf
(((symbol-function 'etaf--runtime-participant-publish)
(lambda (participant)
(push 'semantic-publish events)
(prog1 (funcall old-publish participant)
(unless failure-seen
(setq failure-seen t)
(error "G1 injected semantic participant failure")))))
((symbol-function 'etaf--runtime-participant-rollback)
(lambda (participant)
(push 'semantic-rollback events)
(funcall old-rollback participant))))
(setq condition
(condition-case error-data
(progn (setf (etaf-value source) 1) nil)
((error quit) error-data))))
(should condition)
(should (equal (nreverse events)
'(semantic-publish semantic-rollback)))
(should
(equal-including-properties
before (etaf-g1--runtime-state runtime)))
(should (etaf-host-authority-attached-p
(etaf-runtime-host-authority runtime)))
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
(should (tp-publication-failure-outcome-p
tp--last-transaction-outcome))
(should (null (tp--transaction-condition-trailer
condition :rollback-failures)))
;; A retry is a fresh publication, not a partial continuation of
;; the failed candidate.
(etaf-runtime-flush runtime)
(should (equal "value=1"
(with-current-buffer buffer-name (buffer-string))))))
(etaf-g1--cleanup-buffer buffer-name))))
(ert-deftest etaf-g1-postcommit-report-fault-keeps-accepted-state ()
"A report-finalization fault is diagnostic only after commit."
(let* ((buffer-name (generate-new-buffer-name " *etaf-g1-postcommit*"))
(source (etaf-ref 0)))
(unwind-protect
(progn
(cl-letf (((symbol-function 'ebox-surface--participant-complete)
(lambda (&rest _)
(error "G1 injected report finalization fault"))))
(etaf-mount buffer-name (etaf-g1--view source)))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(report (ebox-buffer-update-report buffer-name))
(diagnostics
(plist-get report :framework-participant-diagnostics)))
(should (etaf-host-authority-attached-p
(etaf-runtime-host-authority runtime)))
(should (etaf-runtime-mounted-p runtime))
(should (= 1 (etaf-runtime-generation runtime)))
(should (= 1 (etaf-runtime-generation-token runtime)))
(should (equal "value=0"
(with-current-buffer buffer-name (buffer-string))))
(should (cl-some
(lambda (entry)
(eq (plist-get entry :phase)
'framework-report-finalization))
diagnostics))))
(etaf-g1--cleanup-buffer buffer-name))))
(ert-deftest etaf-g1-host-unmount-and-kill-inflight-route ()
"Detach invalidates routes before cleanup and never revives dead buffers."
(let* ((source (etaf-ref 0))
(explicit-name (generate-new-buffer-name " *etaf-g1-explicit*"))
(killed-name (generate-new-buffer-name " *etaf-g1-killed*")))
(unwind-protect
(progn
(etaf-mount explicit-name (etaf-g1--view source))
(let* ((runtime (etaf-runtime-for-buffer explicit-name))
(route (etaf-runtime-route-token runtime))
(authority (etaf-runtime-host-authority runtime)))
(etaf-unmount runtime)
(should (eq (etaf-host-authority-state authority) 'terminal))
(should-not (etaf-runtime-route-live-p route))
(should-not (etaf-runtime-for-buffer explicit-name)))
(etaf-mount killed-name (etaf-g1--view source))
(let* ((runtime (etaf-runtime-for-buffer killed-name))
(route (etaf-runtime-route-token runtime))
(authority (etaf-runtime-host-authority runtime)))
;; Hold a logical event open so the source write is in-flight;
;; killing the buffer must invalidate the route and drop it.
(etaf-runtime-event-begin runtime)
(setf (etaf-value source) 1)
(kill-buffer (get-buffer killed-name))
(etaf-runtime-event-end runtime)
(should-not (etaf-runtime-mounted-p runtime))
(should (eq (etaf-host-authority-state authority) 'terminal))
(should-not (etaf-runtime-route-live-p route))
(should-not (etaf-runtime-pending-p runtime))
(should-not (gethash route (etaf-ref-subscribers source)))
(setf (etaf-value source) 2)
(should-not (etaf-runtime-pending-p runtime))))
(etaf-g1--cleanup-buffer explicit-name)
(etaf-g1--cleanup-buffer killed-name))))
(ert-deftest etaf-g1-multi-context-runtimes-isolate ()
"Sibling render roots share a source but isolate scheduler contexts."
(let* ((source (etaf-ref 0))
(left-context (etaf-scheduler-context-create :name 'g1-left))
(right-context (etaf-scheduler-context-create :name 'g1-right))
(left-name (generate-new-buffer-name " *etaf-g1-left*"))
(right-name (generate-new-buffer-name " *etaf-g1-right*")))
(unwind-protect
(progn
(etaf-mount left-name (etaf-view (column (text "L")
(text (expr (format "%s" (etaf-value source))))))
(list :scheduler-context left-context))
(etaf-mount right-name (etaf-view (column (text "R")
(box (text (expr (format "%s" (etaf-value source)))))))
(list :scheduler-context right-context))
(let ((left (etaf-runtime-for-buffer left-name))
(right (etaf-runtime-for-buffer right-name)))
(setf (etaf-value source) 1)
(should (= 2 (etaf-runtime-generation left)))
(should (= 2 (etaf-runtime-generation right)))
(should (equal "L1"
(replace-regexp-in-string
"\n" ""
(with-current-buffer left-name (buffer-string)))))
(should (equal "R1"
(replace-regexp-in-string
"\n" ""
(with-current-buffer right-name (buffer-string)))))
(should (etaf-scheduler-context-idle-p left-context))
(should (etaf-scheduler-context-idle-p right-context))
(etaf-unmount left)
(setf (etaf-value source) 2)
(should (= 3 (etaf-runtime-generation right)))
(should (equal "R2"
(replace-regexp-in-string
"\n" ""
(with-current-buffer right-name (buffer-string)))))
(should-not (etaf-runtime-pending-p left))))
(etaf-g1--cleanup-buffer left-name)
(etaf-g1--cleanup-buffer right-name))))
(ert-deftest etaf-g1-nested-runtime-event-batches-once ()
"A nested Runtime event boundary publishes only its final source value."
(let* ((source (etaf-ref 0))
(buffer-name (generate-new-buffer-name " *etaf-g1-nested-event*")))
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-g1--view source))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(before (etaf-runtime-generation runtime)))
(etaf-runtime-event-begin runtime)
(etaf-runtime-event-begin runtime)
(setf (etaf-value source) 1)
(should (= before (etaf-runtime-generation runtime)))
(should (etaf-runtime-pending-p runtime))
(etaf-runtime-event-end runtime)
(should (= before (etaf-runtime-generation runtime)))
(setf (etaf-value source) 2)
(etaf-runtime-event-end runtime)
(should (= (1+ before) (etaf-runtime-generation runtime)))
(should-not (etaf-runtime-pending-p runtime))
(should
(equal "value=2"
(with-current-buffer buffer-name (buffer-string))))))
(etaf-g1--cleanup-buffer buffer-name))))
(ert-deftest etaf-g1-native-fallback-keeps-surface ()
"A forced native execution failure truthfully commits ordinary fallback."
(let ((buffer (generate-new-buffer " *etaf-g1-native-fallback*"))
(initial (ebox-build '(column (box :key a "A")
(box :key b "B"))))
(updated (ebox-build '(column (box :key a "A")
(box :key b "B2")
(box :key c "C"))))
(native-attempts 0))
(unwind-protect
(let ((ebox-viewport-width 240)
(ebox-viewport-height 8)
(ebox-runtime-idle-prewarm nil)
(ebox-runtime-idle-reflow-cache-prewarm nil))
;; Establish an ordinary surface, then explicitly make the
;; structural update eligible for native bootstrap.
(cl-letf (((symbol-function 'ebox-native-reflow-layout-ready-p)
(lambda () nil)))
(ebox-render-to-buffer buffer initial))
(let ((before (with-current-buffer buffer (buffer-string))))
(cl-letf (((symbol-function 'ebox-native-reflow-layout-ready-p)
(lambda () t))
((symbol-function 'ebox-style-cascade-active-p)
(lambda () nil))
((symbol-function 'ebox-native-reflow-create-session)
(lambda (&rest _)
(ebox-native-reflow--make-session
:handle 'g1-native-session
:generation 0
:layout-fragment-cache
(make-hash-table :test #'equal)
:layout-fragment-revision 0)))
((symbol-function 'ebox-native-reflow-release-session)
(lambda (session)
(setf (ebox-native-reflow-session-released-p session) t)))
((symbol-function 'ebox-native-reflow-execute-session-sync)
(lambda (&rest _)
(cl-incf native-attempts)
(error "G1 forced native failure"))))
(let ((report (ebox-commit buffer updated)))
(should (= native-attempts 1))
(should (equal "AB2C"
(replace-regexp-in-string
"[[:space:]]" ""
(with-current-buffer buffer (buffer-string)))))
(should (not (equal before (with-current-buffer buffer
(buffer-string)))))
(should (eq (plist-get report :strategy) 'ordinary-fallback))
(should (eq (plist-get report :native-attempt) 'failed))
(should (equal (plist-get report :native-fallback-reason)
"G1 forced native failure"))
(should (eq (plist-get report :render-scope) 'surface))
(should-not (plist-get report :projection-kind))
(should-not (plist-get report :native-frame-kind))
(should (ebox-surface-buffer-mounted-p buffer))))))
(when (buffer-live-p buffer)
(when (ebox-surface-buffer-mounted-p buffer)
(ebox-unmount-buffer buffer))
(kill-buffer buffer)))))
(ert-deftest etaf-g1-retirement-diagnostics-are-cause-compatible ()
"Retirement errors retain the business condition and committed metadata."
(let* ((journal
(etaf-retirement-journal-create
:operation-id 17 :outcome-id 18 :generation-id 19 :revision 20))
captured)
(condition-case condition
(etaf-retirement-resignal
'(etaf-g1-retirement-error "business" (:cause injected)) journal)
(etaf-g1-retirement-error (setq captured condition)))
(should captured)
(should (equal (butlast (cdr captured))
'("business" (:cause injected))))
(should (equal (etaf-condition-postcommit-info captured)
(list :kind 'postcommit :committed-p t :operation-id 17
:outcome-id 18 :generation-id 19 :revision 20
:diagnostic-journal-id
(etaf-retirement-journal-id journal))))))
(ert-deftest etaf-g1-research-shelf-load-path-harness-contract ()
"The Research Shelf execution harness names every required artifact."
(dolist (file '("etaf-playground/examples/research-shelf.el"
"etaf-playground/scripts/benchmark-research-shelf.el"
"etaf-playground/scripts/playground-gui-scenarios.el"
"etaf-playground/scripts/run-gui-verification.sh"))
(should (file-exists-p (expand-file-name file etaf-g1--workspace-root)))))
(ert-deftest etaf-g1-research-shelf-gui-recovery-harness-contract ()
"The GUI harness exposes the actions required by external GUI execution."
(let* ((adapter (expand-file-name
"etaf-playground/scripts/playground-gui-scenarios.el"
etaf-g1--workspace-root))
(evidence (expand-file-name
"etaf-playground/scripts/research-shelf-m0a-evidence.el"
etaf-g1--workspace-root))
(adapter-source (with-temp-buffer
(insert-file-contents adapter)
(buffer-string)))
(evidence-source (with-temp-buffer
(insert-file-contents evidence)
(buffer-string)))
(engine-source (with-temp-buffer
(insert-file-contents
(expand-file-name
"etaf/scripts/emacs-gui-verifier.el"
etaf-g1--workspace-root))
(buffer-string))))
(dolist (token '("research-shelf" "screenshot"))
(should (string-match-p (regexp-quote token) adapter-source)))
(should (string-match-p "after-redisplay" engine-source))
(dolist (token '("load-error" "buffer-killed" "unmounted"))
(should (string-match-p (regexp-quote token) evidence-source)))))
(ert-deftest etaf-g1-spi-four-branches-and-selected-port-immutability ()
"Absent, valid, malformed and incompatible SPI providers fail distinctly."
(let ((selected (etaf-render-port-selected))
(original-featurep (symbol-function 'featurep))
(provider (ebox-framework-spi-capabilities)))
(cl-letf (((symbol-function 'featurep)
(lambda (feature)
(and (not (eq feature 'ebox-framework-spi-v2))
(funcall original-featurep feature))))
((symbol-function 'ebox-framework-spi-capabilities) nil))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(should (eq (etaf-render-port-route (etaf-render-port--bootstrap)) 'v2))
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities)
(lambda () (error "G1 malformed provider"))))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-spi-version)
(lambda (_provider) 99)))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))
(should (eq selected (etaf-render-port-selected)))
(should-error (eval `(setf (etaf-render-port--route ',selected) 'v1)))))
(ert-deftest etaf-g1-generation-cas-and-host-lifecycle-guards ()
"Generation authority rejects stale tokens and host authority is revocable."
(let* ((authority (etaf-generation-authority-create))
(generation (etaf--generation-create :generation-id 1))
(token (etaf-generation-authority-token authority))
(versions (etaf-generation-authority-store-versions authority)))
(should (= token 0))
(should (etaf-generation-authority-compare-and-swap
authority nil token versions generation 1 versions))
(should-error
(etaf-generation-authority-compare-and-swap
authority generation token versions
(etaf--generation-create :generation-id 2) 2 versions)
:type 'etaf-generation-error))
(let ((buffer (generate-new-buffer " *g1-host*"))
(source (etaf-ref 0)) runtime)
(unwind-protect
(progn
(etaf-mount buffer (etaf-g1--view source))
(setq runtime (etaf-runtime-for-buffer buffer))
(let* ((host (etaf-runtime-host-authority runtime))
(token (etaf-host-authority-token host)))
(should (etaf-host-authority-accepts-token-p host token))
(etaf-unmount runtime)
(setq runtime nil)
(should-not (etaf-host-authority-accepts-token-p host token))))
(when runtime (etaf-unmount runtime))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(defun etaf-g1--run-selected-render-port-route ()
"Run one lifecycle through the process-selected port and return evidence."
(let* ((source (etaf-ref 0))
(buffer-name (generate-new-buffer-name " *etaf-g1-route*"))
(original-publish
(symbol-function 'etaf--runtime-participant-publish))
runtime initial updated rolled-back lifecycle result injected)
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-g1--view source))
(setq runtime (etaf-runtime-for-buffer buffer-name)
initial (etaf-g1--runtime-visible-contract runtime))
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
(let ((initial-marker-count
(tp-committed-success-outcome-marker-count
tp--last-transaction-outcome)))
(setf (etaf-value source) 1)
(setq updated (etaf-g1--runtime-visible-contract runtime))
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
(let ((update-report
(ebox-buffer-update-report
(etaf-runtime-buffer runtime)))
(update-marker-count
(tp-committed-success-outcome-marker-count
tp--last-transaction-outcome)))
(cl-letf
(((symbol-function 'etaf--runtime-participant-publish)
(lambda (participant)
(prog1 (funcall original-publish participant)
(unless injected
(setq injected t)
(error "G1 failed Runtime update"))))))
(should-error (setf (etaf-value source) 2) :type 'error))
(should injected)
(setq rolled-back
(etaf-g1--runtime-visible-contract runtime))
(should (equal-including-properties updated rolled-back))
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
(etaf-unmount runtime)
(push (etaf-g1--runtime-host-contract runtime) lifecycle)
(setq result
(list
:initial initial
:updated updated
:rolled-back rolled-back
:update-report
(etaf-g1--report-contract update-report)
:initial-marker-count initial-marker-count
:update-marker-count update-marker-count
:lifecycle (nreverse lifecycle))))))
(etaf-g1--cleanup-buffer buffer-name))
result))
(defun etaf-g1--selected-route-evidence ()
"Return lifecycle and dispatcher evidence for the actual selected port."
(let* ((selected (etaf-render-port-selected))
(initial-function (etaf-render-port-initial-function selected))
(update-function (etaf-render-port-update-function selected))
(original-initial (symbol-function initial-function))
(original-update (symbol-function update-function))
(initial-calls 0)
(update-calls 0)
lifecycle-evidence)
(cl-letf (((symbol-function initial-function)
(lambda (&rest arguments)
(setq initial-calls (1+ initial-calls))
(apply original-initial arguments)))
((symbol-function update-function)
(lambda (&rest arguments)
(setq update-calls (1+ update-calls))
(apply original-update arguments))))
(setq lifecycle-evidence (etaf-g1--run-selected-render-port-route)))
(list
:selected-route (etaf-render-port-route selected)
:bootstrap-outcome (etaf-render-port-bootstrap-outcome selected)
:generation-mirror-route etaf-generation-mirror-route
:semantic-commit-route etaf-semantic-commit-route
:v2-feature-present (featurep 'ebox-framework-spi-v2)
:v2-predicate-present (fboundp 'ebox-framework-spi-capabilities)
:selected-stable (eq selected (etaf-render-port-selected))
:initial-dispatch initial-function
:update-dispatch update-function
:initial-dispatch-count initial-calls
:update-dispatch-count update-calls
:lifecycle-evidence lifecycle-evidence)))
(defun etaf-g1--emacs-executable ()
"Return the executable running this test process."
(or (and invocation-directory
(let ((path (expand-file-name invocation-name
invocation-directory)))
(and (file-executable-p path) path)))
(executable-find invocation-name)
(error "Cannot resolve current Emacs executable: %S" invocation-name)))
(defun etaf-g1--probe-v2-in-fresh-emacs ()
"Bootstrap the required v2 port in a fresh Emacs and return its evidence."
(let* ((etaf-root (expand-file-name "etaf" etaf-g1--workspace-root))
(test-file (expand-file-name "tests/etaf-g1-cross-layer-tests.el"
etaf-root))
(load-directories
(mapcar (lambda (directory)
(expand-file-name directory etaf-g1--workspace-root))
'("etaf" "etaf/examples" "etaf/scripts"
"ebox" "tp" "ecss")))
(arguments
(append
'("-Q" "--batch")
(apply #'append
(mapcar (lambda (directory) (list "-L" directory))
load-directories))
'("--eval" "(setq load-prefer-newer t)")
(list
"-l" test-file
"--eval"
(concat
"(princ (concat \"ETAF_G1_ROUTE_EVIDENCE:\" "
"(base64-encode-string "
"(prin1-to-string (etaf-g1--selected-route-evidence)) t) "
"\"\\n\"))"))))
status output encoded)
(with-temp-buffer
(setq status
(apply #'call-process (etaf-g1--emacs-executable) nil
(list (current-buffer) t) nil arguments)
output (buffer-string))
(unless (and (integerp status) (zerop status))
(ert-fail (format "Fresh v2 route probe failed (%S):\n%s"
status output)))
(goto-char (point-min))
(unless (re-search-forward
"^ETAF_G1_ROUTE_EVIDENCE:\\([^[:space:]]+\\)$" nil t)
(ert-fail (format "Fresh v2 route probe emitted no evidence:\n%s"
output)))
(setq encoded (match-string-no-properties 1)))
(read (base64-decode-string encoded))))
(ert-deftest etaf-g1-v2-runtime-contract ()
"A fresh v2 bootstrap preserves lifecycle, identity and failed-update state."
(let* ((v2 (etaf-g1--probe-v2-in-fresh-emacs))
(lifecycle (plist-get v2 :lifecycle-evidence))
(initial (plist-get lifecycle :initial))
(updated (plist-get lifecycle :updated))
(rolled-back (plist-get lifecycle :rolled-back))
(host-lifecycle (plist-get lifecycle :lifecycle)))
(should (eq (plist-get v2 :selected-route) 'v2))
(should (eq (plist-get v2 :bootstrap-outcome)
'valid-v2-selected))
(should (plist-get v2 :v2-feature-present))
(should (plist-get v2 :v2-predicate-present))
(should (eq (plist-get v2 :generation-mirror-route) 'project))
(should (eq (plist-get v2 :semantic-commit-route) 'cas))
(should (plist-get v2 :selected-stable))
(should (eq (plist-get v2 :initial-dispatch)
'ebox-framework-spi-initial))
(should (eq (plist-get v2 :update-dispatch)
'ebox-framework-spi-update))
(should (= 1 (plist-get v2 :initial-dispatch-count)))
(should (= 2 (plist-get v2 :update-dispatch-count)))
(should (equal (plist-get initial :semantic-text) "value=0"))
(should (equal (plist-get updated :semantic-text) "value=1"))
(should (equal-including-properties updated rolled-back))
(should (= 4 (length host-lifecycle)))
(should (eq (plist-get (car host-lifecycle) :host-state) 'attached))
(should (eq (plist-get (car (last host-lifecycle)) :host-state) 'terminal))
(should (= 1 (plist-get lifecycle :initial-marker-count)))
(should (= 0 (plist-get lifecycle :update-marker-count)))))
(provide 'etaf-g1-cross-layer-tests)
;;; etaf-g1-cross-layer-tests.el ends here

View File

@ -0,0 +1,454 @@
;;; etaf-generation-tests.el --- M3a generation authority gates -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'ert)
(require 'etaf)
(require 'etaf-generation)
(etaf-define-component etaf-generation-test-dependency-only (&key source)
"Track SOURCE while producing an equal Ebox artifact."
:view
(text (expr (progn (etaf-value source) "same"))))
(etaf-define-component etaf-generation-test-visible (&key source)
"Render SOURCE as visible text for semantic conflict tests."
:view
(text (expr (format "value=%s" (etaf-value source)))))
(defun etaf-generation-test--view (visible)
"Return a root View selected by reactive VISIBLE."
(if (etaf-value visible)
(etaf-view
(text :ref 'generation-target :role 'button
:on-press #'ignore "visible"))
(etaf-view (text :ref 'generation-other "other"))))
(ert-deftest etaf-generation-authority-is-runtime-single-source ()
"Runtime compatibility access reads and writes one authority object."
(let* ((runtime (etaf--runtime-create))
(first (etaf--generation-create :generation-id 1))
(second (etaf--generation-create :generation-id 2)))
(should-not (etaf-runtime-current-generation runtime))
(setf (etaf-runtime-current-generation runtime) first)
(let ((authority (etaf-runtime-generation-authority runtime)))
(should (etaf-generation-authority-p authority))
(should (eq first (etaf-generation-authority-current authority)))
(should (eq first (etaf-runtime-current-generation runtime)))
(setf (etaf-runtime-current-generation runtime) second)
(should (eq authority (etaf-runtime-generation-authority runtime)))
(should (eq second (etaf-runtime-current-generation runtime)))
(should (zerop (etaf-generation-authority-token authority))))))
(ert-deftest etaf-generation-projection-is-detached-and-rejects-duplicates ()
"Compatibility projections copy facts and reject ambiguous keys."
(let* ((handlers '((host . ((press . callback)))))
(projection
(etaf-generation-project-mirrors handlers '((host :role button))))
(handler-table (plist-get projection :handlers))
(props-table (plist-get projection :host-props)))
(setcdr (car handlers) 'mutated)
(should (equal (gethash 'host handler-table) '((press . callback))))
(should (equal (gethash 'host props-table) '(:role button)))
(should-error
(etaf-generation-project-mirror '((host . one) (host . two)))
:type 'etaf-generation-error)))
(ert-deftest etaf-generation-mirrors-follow-committed-generation ()
"Every commit projects exact mirrors and removes stale Host facts."
(let ((buffer-name " *etaf-generation-mirror-test*")
(visible (etaf-ref t)))
(unwind-protect
(progn
(etaf-mount buffer-name
(lambda () (etaf-generation-test--view visible)))
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
(should (etaf-runtime-handler-for runtime 'generation-target))
(should (gethash 'generation-target
(etaf-runtime-handlers runtime)))
(setf (etaf-value visible) nil)
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
(should-not (etaf-runtime-handler-for runtime 'generation-target))
(should-not (gethash 'generation-target
(etaf-runtime-handlers runtime)))
(should (gethash 'generation-other
(etaf-runtime-host-props runtime)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-generation-query-ignores-compatibility-mirror-drift ()
"Corrupting a mirror never changes committed generation queries."
(let ((buffer-name " *etaf-generation-query-test*")
(visible (etaf-ref t)))
(unwind-protect
(progn
(etaf-mount buffer-name
(lambda () (etaf-generation-test--view visible)))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(committed
(copy-tree
(etaf-runtime-handler-for runtime 'generation-target))))
(puthash 'generation-target 'corrupt
(etaf-runtime-handlers runtime))
(should-not (etaf-runtime-generation-mirrors-consistent-p runtime))
(should (equal committed
(etaf-runtime-handler-for
runtime 'generation-target)))
(setf (etaf-value visible) nil)
(setf (etaf-value visible) t)
(should (etaf-runtime-generation-mirrors-consistent-p runtime))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-generation-shadow-route-proves-legacy-equivalence ()
"The shadow route accepts a legacy projection only when facts are equal."
(let ((buffer-name " *etaf-generation-shadow-test*")
(visible (etaf-ref t))
(etaf-generation-mirror-route 'shadow))
(unwind-protect
(progn
(etaf-mount buffer-name
(lambda () (etaf-generation-test--view visible)))
(setf (etaf-value visible) nil)
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
(should (etaf-runtime-generation-mirrors-consistent-p runtime))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-generation-rejects-unknown-mirror-route ()
"An unknown compatibility route cannot silently publish mirrors."
(let ((runtime (etaf--runtime-create
:generation-authority
(etaf-generation-authority-create)))
(etaf-generation-mirror-route 'unknown))
(should-error
(etaf--runtime-install-generation-mirrors runtime nil t)
:type 'etaf-generation-error)))
(ert-deftest etaf-semantic-candidate-cas-and-rollback-are-exactly-once ()
"CAS stages generation/token/versions together and rollback restores all."
(let* ((old (list 'old-generation))
(next (list 'next-generation))
(authority (etaf-generation-authority-create old))
(candidate
(etaf-semantic-candidate-create
authority next 7 11 13 17)))
(etaf-semantic-candidate-stage candidate)
(should (eq next (etaf-generation-authority-current authority)))
(should (= (etaf-generation-authority-token authority) 1))
(should
(equal (etaf-generation-authority-store-versions authority)
(etaf-semantic-candidate-candidate-store-versions candidate)))
(should-error (etaf-semantic-candidate-stage candidate)
:type 'etaf-generation-error)
(etaf-semantic-candidate-rollback candidate)
(should (eq old (etaf-generation-authority-current authority)))
(should (zerop (etaf-generation-authority-token authority)))
(should
(equal (etaf-generation-authority-store-versions authority)
(etaf-semantic-candidate-expected-store-versions candidate)))
(etaf-semantic-candidate-rollback candidate)
(should-error (etaf-semantic-candidate-commit candidate)
:type 'etaf-generation-error)))
(ert-deftest etaf-semantic-candidate-rejects-stale-authority-snapshots ()
"Generation, token, and store-version conflicts fail before authority swap."
(dolist (kind '(generation token stores))
(let* ((old (list 'old-generation))
(next (list 'next-generation))
(authority (etaf-generation-authority-create old))
(candidate
(etaf-semantic-candidate-create authority next 1 2 3 4)))
(pcase kind
('generation
(etaf-generation-authority-set-current authority (list 'foreign)))
('token
(setf (etaf-generation-authority-token authority) 9))
('stores
(setf (etaf-generation-authority-store-versions authority)
(etaf-generation-store-versions-next
(etaf-generation-authority-store-versions authority)))))
(should-error (etaf-semantic-candidate-stage candidate)
:type 'etaf-generation-conflict)
(should (eq (etaf-semantic-candidate-state candidate) 'prepared)))))
(ert-deftest etaf-semantic-candidate-commit-is-terminal ()
"A committed semantic candidate cannot rollback or commit twice."
(let* ((authority (etaf-generation-authority-create 'old))
(candidate
(etaf-semantic-candidate-create authority 'next 1 2 3 4)))
(etaf-semantic-candidate-stage candidate)
(etaf-semantic-candidate-commit candidate)
(should (eq (etaf-semantic-candidate-state candidate) 'committed))
(should-error (etaf-semantic-candidate-commit candidate)
:type 'etaf-generation-error)
(should-error (etaf-semantic-candidate-rollback candidate)
:type 'etaf-generation-error)
(should (eq (etaf-generation-authority-current authority) 'next))))
(ert-deftest etaf-semantic-only-commit-advances-token-without-ebox-or-tp ()
"Equal output commits semantic token/version only, with no surface revision."
(let ((buffer-name " *etaf-semantic-token-test*")
(source (etaf-ref 0))
(ebox-updates 0))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-generation-test-dependency-only
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(surface (with-current-buffer buffer-name
(car tp--buffer-surfaces)))
(generation (etaf-runtime-generation runtime))
(token (etaf-runtime-generation-token runtime))
(versions (etaf-runtime-store-versions runtime))
(revision (tp-surface-revision surface))
(original
(symbol-function 'etaf-render-port-update)))
(cl-letf (((symbol-function 'etaf-render-port-update)
(lambda (&rest arguments)
(cl-incf ebox-updates)
(apply original arguments))))
(setf (etaf-value source) 1))
(should (= (1+ generation)
(etaf-runtime-generation runtime)))
(should (= (1+ token)
(etaf-runtime-generation-token runtime)))
(should
(equal (etaf-generation-store-versions-next versions)
(etaf-runtime-store-versions runtime)))
(should (zerop ebox-updates))
(should (= revision (tp-surface-revision surface)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-semantic-store-conflict-restores-and-retries ()
"A stale store version leaves generation/buffer old and a fresh retry wins."
(let ((buffer-name " *etaf-semantic-conflict-test*")
(source (etaf-ref 0)))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-generation-test-visible
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(authority (etaf-runtime-generation-authority runtime))
(generation (etaf-runtime-current-generation runtime))
(token (etaf-runtime-generation-token runtime))
(versions (etaf-runtime-store-versions runtime))
(original
(symbol-function 'etaf--runtime-participant-publish)))
(cl-letf
(((symbol-function 'etaf--runtime-participant-publish)
(lambda (participant)
(setf (etaf-generation-authority-store-versions authority)
(etaf-generation-store-versions-next versions))
(funcall original participant))))
(should-error (setf (etaf-value source) 1)
:type 'etaf-generation-conflict))
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (= token (etaf-runtime-generation-token runtime)))
(should (equal "value=0"
(with-current-buffer buffer-name
(buffer-string))))
(etaf-runtime-flush runtime)
(should (= (1+ token) (etaf-runtime-generation-token runtime)))
(should (equal "value=1"
(with-current-buffer buffer-name
(buffer-string))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-semantic-postcommit-mirror-failure-keeps-token-committed ()
"A postcommit mirror error cannot reverse generation/token or TP facts."
(let ((buffer-name " *etaf-semantic-postcommit-test*")
(source (etaf-ref 0))
captured
(rollback-count 0))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-generation-test-dependency-only
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(surface (with-current-buffer buffer-name
(car tp--buffer-surfaces)))
(generation (etaf-runtime-generation runtime))
(token (etaf-runtime-generation-token runtime))
(revision (tp-surface-revision surface))
(original-rollback
(symbol-function 'etaf-semantic-candidate-rollback)))
(cl-letf
(((symbol-function 'etaf--runtime-install-generation-mirrors)
(lambda (&rest _arguments)
(error "injected postcommit mirror failure")))
((symbol-function 'etaf-semantic-candidate-rollback)
(lambda (candidate)
(cl-incf rollback-count)
(funcall original-rollback candidate))))
(condition-case condition
(setf (etaf-value source) 1)
(error (setq captured condition))))
(should captured)
(should (eq (car captured) 'error))
(should
(equal (butlast (cdr captured))
'("injected postcommit mirror failure")))
(should (etaf-condition-postcommit-info captured))
(should (zerop rollback-count))
(should (= (1+ generation)
(etaf-runtime-generation runtime)))
(should (= (1+ token)
(etaf-runtime-generation-token runtime)))
(should (= revision (tp-surface-revision surface)))
(should (equal "same"
(with-current-buffer buffer-name
(buffer-string))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-semantic-ebox-report-finalization-fault-does-not-rollback ()
"A postaccept Ebox report fault still commits ETAF generation and buffer."
(let ((buffer-name " *etaf-ebox-report-postaccept-test*")
(source (etaf-ref 0))
(rollback-count 0))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-generation-test-visible
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-generation runtime))
(original-rollback
(symbol-function 'etaf-semantic-candidate-rollback)))
(cl-letf
(((symbol-function 'ebox-surface--participant-complete)
(lambda (&rest _arguments)
(error "injected Ebox report finalization fault")))
((symbol-function 'etaf-semantic-candidate-rollback)
(lambda (candidate)
(cl-incf rollback-count)
(funcall original-rollback candidate))))
(setf (etaf-value source) 1))
(should (zerop rollback-count))
(should (= (1+ generation)
(etaf-runtime-generation runtime)))
(should (equal "value=1"
(with-current-buffer buffer-name
(buffer-string))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-semantic-render-rollback-restores-all-authority-in-callback ()
"Framework rollback restores token, stores, and journals before TP returns."
(let ((buffer-name " *etaf-semantic-render-rollback-test*")
(source (etaf-ref 0))
rollback-evidence)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-generation-test-visible
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-current-generation runtime))
(token (etaf-runtime-generation-token runtime))
(versions (etaf-runtime-store-versions runtime))
(original-precommit
(symbol-function 'tp--run-transaction-precommit-functions))
(original-rollback
(symbol-function 'etaf--runtime-participant-rollback)))
(cl-letf
(((symbol-function 'tp--run-transaction-precommit-functions)
(lambda ()
(funcall original-precommit)
(error "injected precommit failure")))
((symbol-function 'etaf--runtime-participant-rollback)
(lambda (participant)
(prog1 (funcall original-rollback participant)
(let* ((semantic
(etaf--generation-participant-semantic-candidate
participant))
(inverse
(etaf-semantic-candidate-inverse-journal semantic)))
(setq rollback-evidence
(list
:generation
(eq generation
(etaf-runtime-current-generation runtime))
:token
(= token (etaf-runtime-generation-token runtime))
:versions
(equal versions
(etaf-runtime-store-versions runtime))
:candidate-state
(etaf-semantic-candidate-state semantic)
:journal-state
(plist-get inverse :state))))))))
(should-error (setf (etaf-value source) 1) :type 'error))
(should
(equal rollback-evidence
'(:generation t :token t :versions t
:candidate-state rolled-back
:journal-state rolled-back)))
(should (equal "value=0"
(with-current-buffer buffer-name
(buffer-string))))
(etaf-runtime-flush runtime)
(should (equal "value=1"
(with-current-buffer buffer-name
(buffer-string))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-semantic-legacy-and-shadow-routes-remain-recoverable ()
"Legacy keeps its token while shadow validates and advances the CAS token."
(dolist (route '(legacy shadow))
(let ((buffer-name
(format " *etaf-semantic-%s-route-test*" route))
(source (etaf-ref 0))
(etaf-semantic-commit-route route))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-generation-test-visible
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-generation runtime))
(token (etaf-runtime-generation-token runtime)))
(setf (etaf-value source) 1)
(should (= (1+ generation)
(etaf-runtime-generation runtime)))
(should (= (etaf-runtime-generation-token runtime)
(if (eq route 'legacy) token (1+ token))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))))
(provide 'etaf-generation-tests)
;;; etaf-generation-tests.el ends here

View File

@ -0,0 +1,590 @@
;;; etaf-gui-verifier-tests.el --- Generic GUI scenario engine tests -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'json)
(require 'emacs-gui-verifier)
(ert-deftest etaf-gui-verifier-measures-success-and-original-failure ()
"Each callback retains its own timing, result, and error condition."
(let* ((scenario (etaf-gui-verifier-scenario-create :name "measurement"))
(context (etaf-gui-verifier--context-create :scenario scenario))
(result (list 'exact-result))
(error-data (list "original failure" result))
(wall-times '(1.0 1.002 10.0 10.03))
(cpu-times '((1000 . 1000) (1004 . 1000)
(2000 . 1000) (2010 . 1000)))
(gcs-done 5) (gc-elapsed 0.1)
(calls 0))
(cl-letf (((symbol-function 'float-time)
(lambda (&optional _time) (pop wall-times)))
((symbol-function 'current-cpu-time)
(lambda () (pop cpu-times))))
(should
(eq result
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "success"
:execute (lambda (current)
(should (eq current context))
(cl-incf calls)
result)))))
(should
(equal (cons 'error error-data)
(should-error
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "failure"
:execute (lambda (_current)
(cl-incf calls)
(cl-incf gcs-done 2)
(cl-incf gc-elapsed 0.003)
(signal 'error error-data))))))))
(should (= calls 2))
(let* ((measurements (etaf-gui-verifier-context-measurements context))
(failed (car measurements))
(succeeded (cadr measurements))
(adapter (etaf-gui-verifier--adapter-data context)))
(should (= (length measurements) 2))
(should (equal (alist-get 'status succeeded) "success"))
(should (equal (alist-get 'status failed) "error"))
(should (equal (alist-get 'action_id failed) "failure"))
(should-not (alist-get 'valid failed))
(should (< (abs (- (alist-get 'wall_ms failed) 30.0)) 0.001))
(should (< (abs (- (alist-get 'wall_ms succeeded) 2.0)) 0.001))
(should (< (abs (- (alist-get 'cpu_ms failed) 10.0)) 0.001))
(should (= (alist-get 'gc_count failed) 2))
(should (< (abs (- (alist-get 'gc_ms failed) 3.0)) 0.001))
(should (= (alist-get 'duration_ms adapter)
(alist-get 'wall_ms failed)))
(should (eq (alist-get 'last_measurement adapter) failed))
(should-not (assq 'measurements adapter)))))
(ert-deftest etaf-gui-verifier-labels-callback-context-without-changing-it ()
"Foreground, background, and unknown callbacks keep their execution context."
(let* ((focus t) (calls 0)
(inhibit-quit t) (inhibit-redisplay t)
(threshold gc-cons-threshold) (percentage gc-cons-percentage)
(context
(etaf-gui-verifier--context-create
:target-buffer (window-buffer (selected-window)))))
(cl-letf (((symbol-function 'display-graphic-p)
(lambda (&optional _frame) t))
((symbol-function 'frame-focus-state)
(lambda (&optional _frame) focus))
((symbol-function 'redisplay)
(lambda (&rest _arguments) (ert-fail "Forced redisplay")))
((symbol-function 'sit-for)
(lambda (&rest _arguments) (ert-fail "Waited for display")))
((symbol-function 'garbage-collect)
(lambda () (ert-fail "Forced GC"))))
(dolist (state '((t "foreground") (nil "background") (unknown "unknown")))
(setq focus (car state))
(should
(eq 'exact-result
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "context"
:execute (lambda (_context)
(cl-incf calls)
(should inhibit-quit)
(should inhibit-redisplay)
(should (= gc-cons-threshold threshold))
(should (= gc-cons-percentage percentage))
'exact-result))
(eq focus t))))
(let* ((measurement
(car (etaf-gui-verifier-context-measurements context)))
(before (alist-get 'before measurement)))
(should (equal (alist-get 'foreground measurement) (cadr state)))
(should (equal (alist-get 'status measurement) "success"))
(should (alist-get 'valid measurement))
(should (alist-get 'inhibit_quit before))
(should (alist-get 'inhibit_redisplay before))
(should (eq (alist-get 'noninteractive before) noninteractive))
(should (stringp (json-serialize measurement))))))
(should (= calls 3))))
(ert-deftest etaf-gui-verifier-unselected-target-runs-with-invalid-timing ()
"An unchanged unselected target permits the callback but invalidates timing."
(let* ((target (generate-new-buffer " *etaf-gui-unselected-target*"))
(context (etaf-gui-verifier--context-create :target-buffer target))
(result (list 'exact-result))
(calls 0))
(unwind-protect
(cl-letf (((symbol-function 'display-graphic-p)
(lambda (&optional _frame) t))
((symbol-function 'frame-focus-state)
(lambda (&optional _frame) nil)))
(should
(eq result
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "unselected-target"
:execute (lambda (_context)
(cl-incf calls)
result)))))
(should (= calls 1))
(let ((measurement
(car (etaf-gui-verifier-context-measurements context))))
(should (equal (alist-get 'status measurement) "success"))
(should (equal (alist-get 'foreground measurement) "background"))
(should (equal (alist-get 'before measurement)
(alist-get 'after measurement)))
(should-not (alist-get 'target_selected
(alist-get 'before measurement)))
(should-not (alist-get 'valid measurement))
(should (numberp (alist-get 'wall_ms measurement)))))
(kill-buffer target))))
(ert-deftest etaf-gui-verifier-foreground-rejection-does-not-execute-or-focus ()
"Foreground requirements reject absent focus or targets before execution."
(let ((focus t) (graphic t) (calls 0)
(context (etaf-gui-verifier--context-create)))
(cl-letf (((symbol-function 'display-graphic-p)
(lambda (&optional _frame) graphic))
((symbol-function 'frame-focus-state)
(lambda (&optional _frame) focus))
((symbol-function 'raise-frame)
(lambda (&rest _arguments) (ert-fail "Raised frame")))
((symbol-function 'select-frame-set-input-focus)
(lambda (&rest _arguments) (ert-fail "Changed focus")))
((symbol-function 'x-focus-frame)
(lambda (&rest _arguments) (ert-fail "Focused frame"))))
(dolist (state '((nil t t) (unknown t t) (t nil t) (t t nil)))
(setq focus (nth 0 state) graphic (nth 1 state))
(setf (etaf-gui-verifier-context-target-buffer context)
(and (nth 2 state) (window-buffer (selected-window))))
(should-error
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "foreground-only" :execute (lambda (_context) (cl-incf calls)))
t))
(let ((measurement
(car (etaf-gui-verifier-context-measurements context))))
(should (equal (alist-get 'status measurement) "rejected"))
(should-not (alist-get 'valid measurement))
(should-not (alist-get 'wall_ms measurement)))))
(should (zerop calls))))
(ert-deftest etaf-gui-verifier-retains-valid-timing-when-frame-title-changes ()
"A GC count in the frame title must not invalidate a stable target."
(let* ((gcs-done 713)
(calls 0)
(result (list 'exact-result))
(frame-parameter-function (symbol-function 'frame-parameter))
(context
(etaf-gui-verifier--context-create
:target-buffer (window-buffer (selected-window)))))
(cl-letf (((symbol-function 'display-graphic-p)
(lambda (&optional _frame) t))
((symbol-function 'frame-focus-state)
(lambda (&optional _frame) t))
((symbol-function 'frame-parameter)
(lambda (frame parameter)
(if (eq parameter 'name) (format "GC%d" gcs-done)
(funcall frame-parameter-function frame parameter)))))
(should
(eq result
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "title-update"
:execute (lambda (_context)
(cl-incf calls)
(cl-incf gcs-done)
result))
t))))
(should (= calls 1))
(let ((measurement
(car (etaf-gui-verifier-context-measurements context))))
(should (equal (alist-get 'status measurement) "success"))
(should (equal (alist-get 'foreground measurement) "foreground"))
(should (alist-get 'valid measurement))
(should (= (alist-get 'gc_count measurement) 1))
(should (equal (alist-get 'frame_name (alist-get 'before measurement))
"GC713"))
(should (equal (alist-get 'frame_name (alist-get 'after measurement))
"GC714")))))
(ert-deftest etaf-gui-verifier-invalidates-replaced-selected-target ()
"A different live selected buffer remains an identity change."
(let ((target (generate-new-buffer " *etaf-gui-original-target*"))
(replacement (generate-new-buffer " *etaf-gui-replacement-target*"))
(calls 0))
(unwind-protect
(save-window-excursion
(switch-to-buffer target)
(let ((context (etaf-gui-verifier--context-create :target-buffer target)))
(cl-letf (((symbol-function 'display-graphic-p)
(lambda (&optional _frame) t))
((symbol-function 'frame-focus-state)
(lambda (&optional _frame) t)))
(should-error
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "replace-selected-target"
:execute (lambda (_context)
(cl-incf calls)
(setf (etaf-gui-verifier-context-target-buffer context)
replacement)
(set-window-buffer (selected-window) replacement)))
t)))
(should (= calls 1))
(let ((measurement
(car (etaf-gui-verifier-context-measurements context))))
(should (alist-get 'target_selected
(alist-get 'before measurement)))
(should (alist-get 'target_selected
(alist-get 'after measurement)))
(should (equal (alist-get 'status measurement) "invalid"))
(should-not (alist-get 'valid measurement)))))
(kill-buffer target)
(kill-buffer replacement))))
(ert-deftest etaf-gui-verifier-invalidates-changed-foreground-environment ()
"Changed focus, target, font, or dimensions invalidate strict timing."
(let ((focus t) (width 800) (font "original-font") (calls 0)
(frame-parameter-function (symbol-function 'frame-parameter))
(context (etaf-gui-verifier--context-create)))
(cl-letf (((symbol-function 'display-graphic-p)
(lambda (&optional _frame) t))
((symbol-function 'frame-focus-state)
(lambda (&optional _frame) focus))
((symbol-function 'frame-pixel-width)
(lambda (&optional _frame) width))
((symbol-function 'frame-parameter)
(lambda (frame parameter)
(if (eq parameter 'font) font
(funcall frame-parameter-function frame parameter)))))
(dolist (change '(focus target font dimensions))
(setq focus t width 800 font "original-font")
(setf (etaf-gui-verifier-context-target-buffer context)
(window-buffer (selected-window)))
(should-error
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id (symbol-name change)
:execute
(lambda (_context)
(cl-incf calls)
(pcase change
('focus (setq focus nil))
('target
(setf (etaf-gui-verifier-context-target-buffer context) nil))
('font (setq font "changed-font"))
('dimensions (setq width 900)))))
t))
(let ((measurement
(car (etaf-gui-verifier-context-measurements context))))
(should (equal (alist-get 'status measurement) "invalid"))
(should (equal (alist-get 'foreground measurement) "changed"))
(should-not (alist-get 'valid measurement))
(should (numberp (alist-get 'wall_ms measurement))))))
(should (= calls 4))))
(ert-deftest etaf-gui-verifier-preserves-quit-despite-focus-change ()
"A quit keeps its exact data even if strict environment checks also fail."
(let* ((focus t)
(quit-data (list 'original-quit))
(context
(etaf-gui-verifier--context-create
:target-buffer (window-buffer (selected-window)))))
(cl-letf (((symbol-function 'display-graphic-p)
(lambda (&optional _frame) t))
((symbol-function 'frame-focus-state)
(lambda (&optional _frame) focus)))
(should
(equal (cons 'quit quit-data)
(condition-case condition
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "quit"
:execute (lambda (_context)
(setq focus nil)
(signal 'quit quit-data)))
t)
(quit condition)))))
(let ((measurement
(car (etaf-gui-verifier-context-measurements context))))
(should (equal (alist-get 'status measurement) "quit"))
(should (equal (alist-get 'foreground measurement) "changed"))
(should-not (alist-get 'valid measurement))
(should (numberp (alist-get 'wall_ms measurement))))))
(ert-deftest etaf-gui-verifier-retains-timing-despite-closing-snapshot-failure ()
"Snapshot errors and quits preserve action failures and retain fresh timing."
(dolist (action-outcome '(error quit success))
(dolist (snapshot-outcome '(error quit))
(let* ((context
(etaf-gui-verifier--context-create
:target-buffer (window-buffer (selected-window))
:last-duration-ms 999.0))
(before (etaf-gui-verifier--measurement-state context))
(result (list 'exact-result))
(action-data (list "original-action-failure" result))
(snapshot-data (list "snapshot-interrupted" result))
(wall-times '(1.0 1.025))
(calls 0) (snapshots 0) observed-condition returned)
(cl-letf (((symbol-function 'float-time)
(lambda (&optional _time) (pop wall-times)))
((symbol-function 'etaf-gui-verifier--measurement-state)
(lambda (_context)
(if (= (cl-incf snapshots) 1) before
(signal snapshot-outcome snapshot-data)))))
(setq returned
(condition-case condition
(etaf-gui-verifier-measure-action
context
(etaf-gui-verifier-action-create
:id "snapshot-failure"
:execute (lambda (_context)
(cl-incf calls)
(if (eq action-outcome 'success) result
(signal action-outcome action-data)))))
((error quit)
(setq observed-condition condition)
nil))))
(should (= calls 1))
(should (= snapshots 2))
(cond
((not (eq action-outcome 'success))
(should (eq (car observed-condition) action-outcome))
(should (eq (cdr observed-condition) action-data)))
((eq snapshot-outcome 'quit)
(should (eq (car observed-condition) 'quit))
(should (eq (cdr observed-condition) snapshot-data)))
(t
(should-not observed-condition)
(should (eq returned result))))
(let* ((measurements (etaf-gui-verifier-context-measurements context))
(measurement (car measurements)))
(should (= (length measurements) 1))
(should-not (alist-get 'valid measurement))
(should-not (alist-get 'after measurement))
(should
(equal (alist-get 'status measurement)
(symbol-name
(if (and (eq action-outcome 'success)
(eq snapshot-outcome 'quit))
'quit action-outcome))))
(should (< (abs (- (alist-get 'wall_ms measurement) 25.0)) 0.001))
(should (= (etaf-gui-verifier-context-last-duration-ms context)
(alist-get 'wall_ms measurement))))))))
(ert-deftest etaf-gui-verifier-measures-callback-without-settle-or-checkpoints ()
"The action callback is timed separately from checkpoints and settling."
(let ((context (etaf-gui-verifier--context-create))
(clock 0.0) events)
(cl-letf (((symbol-function 'float-time)
(lambda (&optional _time) clock))
((symbol-function 'etaf-gui-verifier--checkpoint)
(lambda (_context _id phase _screenshot &optional _extra)
(cl-incf clock 1.0)
(push phase events)))
((symbol-function 'etaf-gui-verifier--settle-action)
(lambda (_context _action)
(cl-incf clock 2.0)
(push 'settle events))))
(etaf-gui-verifier--run-action
context
(etaf-gui-verifier-action-create
:id "callback-only"
:execute (lambda (_context)
(cl-incf clock 0.025)
(push 'execute events)))))
(should (< (abs (- (etaf-gui-verifier-context-last-duration-ms context)
25.0))
0.001))
(should (equal (nreverse events)
'("before-action" execute "after-action"
settle "after-redisplay")))
(let ((measurement
(car (etaf-gui-verifier-context-measurements context))))
(should (equal (alist-get 'boundary measurement) "action.execute callback"))
(should-not (alist-get 'presentation_measured measurement)))))
(ert-deftest etaf-gui-verifier-runs-and-settles-without-raising-frame ()
"Actions and settled checkpoints must complete without raising Emacs."
(let ((context (etaf-gui-verifier--context-create))
(settle-checks 0)
events)
(cl-letf (((symbol-function 'raise-frame)
(lambda (&rest _arguments)
(error "GUI verifier must preserve application focus")))
((symbol-function 'etaf-gui-verifier--checkpoint)
(lambda (_context _action-id phase _screenshot &optional _extra)
(push phase events))))
(etaf-gui-verifier--run-action
context
(etaf-gui-verifier-action-create
:id "background-action" :settle-interval 0.001
:execute
(lambda (current)
(etaf-gui-verifier-context-put current 'executed t)
(push 'execute events))
:settled-p
(lambda (current)
(should (etaf-gui-verifier-context-get current 'executed))
(cl-incf settle-checks)
(push 'settle events)
t)
:assertions
(lambda (_current)
(push 'assertions events)
(list (etaf-gui-verifier-assert "action-settled" t))))))
(should (= 1 (etaf-gui-verifier-context-action-count context)))
(should (= 2 settle-checks))
(should
(equal '("before-action" execute "after-action" settle settle
assertions "after-redisplay")
(nreverse events)))))
(ert-deftest etaf-gui-verifier-composes-generic-scenario-actions ()
"The engine should own ordering while adapters own actions and assertions."
(let ((buffer (generate-new-buffer " *etaf-gui-verifier-test*"))
events checkpoints finished (settle-checks 0))
(unwind-protect
(cl-letf
(((symbol-function 'emacs-dynamic-ui-verification-start)
(lambda (_directory run-id _claim phases)
(push (list 'start run-id phases) events)))
((symbol-function 'emacs-dynamic-ui-verification-checkpoint)
(lambda (action phase adapter assertions screenshot)
(push (list action phase adapter assertions screenshot)
checkpoints)))
((symbol-function 'emacs-dynamic-ui-verification-finish)
(lambda (completed adapter)
(setq finished (list completed adapter)))))
(let* ((scenario
(etaf-gui-verifier-scenario-create
:name "generic"
:claim "generic claim"
:initialize
(lambda (context)
(etaf-gui-verifier-context-select-buffer context buffer))
:invariants
(lambda (context)
(list
(etaf-gui-verifier-assert
"buffer-live"
(buffer-live-p
(etaf-gui-verifier-context-target-buffer context)))))
:adapter
(lambda (context)
(list
(cons 'size
(with-current-buffer
(etaf-gui-verifier-context-target-buffer context)
(buffer-size)))))
:actions
(list
(etaf-gui-verifier-action-create
:id "insert-a" :settle-interval 0.001
:execute
(lambda (context)
(with-current-buffer
(etaf-gui-verifier-context-target-buffer context)
(insert "A")))
:settled-p
(lambda (_context)
(>= (cl-incf settle-checks) 2))
:assertions
(lambda (context)
(list
(etaf-gui-verifier-assert
"one-character"
(= 1
(with-current-buffer
(etaf-gui-verifier-context-target-buffer context)
(buffer-size))))))
:screenshot t)
(etaf-gui-verifier-action-create
:id "insert-b"
:execute
(lambda (context)
(with-current-buffer
(etaf-gui-verifier-context-target-buffer context)
(insert "B")))
:settled-p (lambda (_context) t)))
:completion
(lambda (context)
(= 2 (etaf-gui-verifier-context-action-count context)))))
(context (etaf-gui-verifier-run scenario "/tmp/generic")))
(should (= 2 (etaf-gui-verifier-context-action-count context)))
(should (equal "AB" (with-current-buffer buffer (buffer-string))))
(should (car finished))
(should (= settle-checks 3))
(should (= 6 (length checkpoints)))
(should
(equal
'("before-action" "after-action" "after-redisplay"
"before-action" "after-action" "after-redisplay")
(mapcar #'cadr (nreverse checkpoints))))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-gui-verifier-rejects-invalid-settle-contracts ()
"Every action should have a bounded, non-busy settle contract."
(let ((context (etaf-gui-verifier--context-create)))
(dolist
(action
(list
(etaf-gui-verifier-action-create :id "missing")
(etaf-gui-verifier-action-create
:id "timeout" :settled-p (lambda (_context) t)
:settle-timeout 0)
(etaf-gui-verifier-action-create
:id "interval" :settled-p (lambda (_context) t)
:settle-interval 0)))
(should-error (etaf-gui-verifier--settle-action context action)))))
(ert-deftest etaf-gui-verifier-timeout-finishes-false-and-propagates ()
"A settle timeout should finish incomplete and preserve its error."
(let ((buffer (generate-new-buffer " *etaf-gui-timeout-test*"))
finished)
(unwind-protect
(cl-letf
(((symbol-function 'emacs-dynamic-ui-verification-start)
(lambda (&rest _arguments) nil))
((symbol-function 'emacs-dynamic-ui-verification-checkpoint)
(lambda (&rest _arguments) nil))
((symbol-function 'emacs-dynamic-ui-verification-finish)
(lambda (completed adapter)
(setq finished (list completed adapter)))))
(let* ((scenario
(etaf-gui-verifier-scenario-create
:name "timeout"
:claim "timeout must fail closed"
:initialize
(lambda (context)
(etaf-gui-verifier-context-select-buffer context buffer))
:actions
(list
(etaf-gui-verifier-action-create
:id "never-settles"
:execute (lambda (_context) nil)
:settled-p (lambda (_context) nil)
:settle-timeout 0.003
:settle-interval 0.001))))
(error-data
(should-error
(etaf-gui-verifier-run scenario "/tmp/timeout"))))
(should
(string-match-p
"did not settle" (error-message-string error-data)))
(should finished)
(should-not (car finished))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(provide 'etaf-gui-verifier-tests)
;;; etaf-gui-verifier-tests.el ends here

215
tests/etaf-host-tests.el Normal file
View File

@ -0,0 +1,215 @@
;;; etaf-host-tests.el --- M3a Host authority gates -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
(require 'ert)
(require 'etaf)
(require 'tp-transaction)
(defvar etaf-host-test-unmount-error-p nil)
(etaf-define-component etaf-host-test-component (&key source fail-unmount)
"Render SOURCE and optionally fail the public unmounted hook."
:setup
(progn
(etaf-on-unmounted
(lambda ()
(when (or fail-unmount etaf-host-test-unmount-error-p)
(error "injected Host retirement failure"))))
nil)
:view
(text :ref 'host-value (expr (format "host=%s" (etaf-value source)))))
(ert-deftest etaf-host-initial-marker-attaches-on-final-accept-only ()
"Initial v2 mount uses one marker; ordinary update uses zero markers."
(let ((buffer-name " *etaf-host-marker-test*")
(source (etaf-ref 0))
lookup-during-stage
(original-stage (symbol-function 'etaf-host-authority-stage-attach)))
(unwind-protect
(progn
(cl-letf (((symbol-function 'etaf-host-authority-stage-attach)
(lambda (authority)
(setq lookup-during-stage
(etaf-runtime-for-buffer buffer-name))
(funcall original-stage authority))))
(etaf-mount
buffer-name
(etaf--view-call 'etaf-host-test-component
(list :source source) nil)))
(should-not lookup-during-stage)
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(authority (etaf-runtime-host-authority runtime)))
(should (etaf-host-authority-attached-p authority))
(should (= (etaf-host-authority-version authority) 1))
(should (= (tp-committed-success-outcome-marker-count
tp--last-transaction-outcome)
1))
(setf (etaf-value source) 1)
(should (= (tp-committed-success-outcome-marker-count
tp--last-transaction-outcome)
0))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-host-initial-faults-restore-detached-authority ()
"Precommit and final-accept faults restore Host and Ebox initial state."
(dolist (phase '(precommit final-accept))
(let ((buffer-name
(format " *etaf-host-%s-fault-test*" phase))
captured-authority
(source (etaf-ref 0))
(original-create (symbol-function 'etaf-host-authority-create))
(original-precommit
(symbol-function 'tp--run-transaction-precommit-functions))
(original-accept (symbol-function 'accept-change-group)))
(unwind-protect
(cl-letf
(((symbol-function 'etaf-host-authority-create)
(lambda (&rest arguments)
(setq captured-authority (apply original-create arguments))))
((symbol-function 'tp--run-transaction-precommit-functions)
(if (eq phase 'precommit)
(lambda ()
(funcall original-precommit)
(error "injected Host precommit failure"))
original-precommit))
((symbol-function 'accept-change-group)
(if (eq phase 'final-accept)
(lambda (_group)
(error "injected Host final-accept failure"))
original-accept)))
(should-error
(etaf-mount
buffer-name
(etaf--view-call 'etaf-host-test-component
(list :source source) nil))
:type 'error)
(should (etaf-host-authority-p captured-authority))
(should (eq (etaf-host-authority-state captured-authority)
'detached))
(should (zerop
(etaf-host-authority-version captured-authority)))
(should-not (etaf-runtime-for-buffer buffer-name))
(should-not
(ebox-surface-buffer-mounted-p (get-buffer buffer-name))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))))
(ert-deftest etaf-host-postaccept-report-fault-still-finishes-attach ()
"Ebox report-finalization failure cannot roll back an accepted Host."
(let ((buffer-name " *etaf-host-report-postaccept-test*")
(source (etaf-ref 0))
(rollback-count 0)
(original-rollback
(symbol-function 'etaf-semantic-candidate-rollback)))
(unwind-protect
(progn
(cl-letf
(((symbol-function 'ebox-surface--participant-complete)
(lambda (&rest _arguments)
(error "injected initial report finalization fault")))
((symbol-function 'etaf-semantic-candidate-rollback)
(lambda (candidate)
(cl-incf rollback-count)
(funcall original-rollback candidate))))
(etaf-mount
buffer-name
(etaf--view-call 'etaf-host-test-component
(list :source source) nil)))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(authority (etaf-runtime-host-authority runtime)))
(should runtime)
(should (etaf-host-authority-attached-p authority))
(should (zerop rollback-count))
(should (ebox-surface-buffer-mounted-p
(get-buffer buffer-name)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-host-unmount-invalidates-before-component-cleanup ()
"Explicit unmount invalidates Host token before any Component hook runs."
(let ((buffer-name " *etaf-host-unmount-boundary-test*")
(source (etaf-ref 0))
checked)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-host-test-component
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(authority (etaf-runtime-host-authority runtime))
(original
(symbol-function 'etaf--runtime-dispose-instance)))
(cl-letf (((symbol-function 'etaf--runtime-dispose-instance)
(lambda (&rest arguments)
(should-not (etaf-host-authority-token authority))
(should (eq (etaf-host-authority-state authority)
'detached-retiring))
(setq checked t)
(apply original arguments))))
(etaf-unmount runtime))
(should checked)
(should (eq (etaf-host-authority-state authority) 'terminal))
(should-not (etaf-runtime-for-buffer buffer-name))
(should (eq (etaf--runtime-unmount-now runtime) runtime))
(should-error (etaf-unmount runtime) :type 'etaf-runtime-error)))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-host-kill-contains-user-cleanup-failure ()
"Buffer kill never rethrows user cleanup after Host authority invalidation."
(let ((buffer-name " *etaf-host-kill-contained-test*")
(source (etaf-ref 0))
runtime authority)
(setq etaf-host-test-unmount-error-p nil)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-host-test-component
(list :source source :fail-unmount t) nil))
(setq runtime (etaf-runtime-for-buffer buffer-name)
authority (etaf-runtime-host-authority runtime))
(kill-buffer (get-buffer buffer-name))
(should (eq (etaf-host-authority-state authority) 'terminal))
(should-not (etaf-runtime-mounted-p runtime))
(should-not (gethash (etaf-runtime-mount-epoch runtime)
etaf--runtime-route-registry)))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-host-detach-makes-route-token-stale ()
"A detached Host route cannot schedule later source changes."
(let ((buffer-name " *etaf-host-stale-route-test*")
(source (etaf-ref 0))
runtime route)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-host-test-component
(list :source source) nil))
(setq runtime (etaf-runtime-for-buffer buffer-name)
route (etaf-runtime-route-token runtime))
(etaf-unmount runtime)
(should-not
(etaf-host-authority-accepts-token-p
(etaf-runtime-host-authority runtime)
(etaf-runtime-route-authority-token route)))
(setf (etaf-value source) 1)
(should-not (etaf-runtime-pending-p runtime)))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(provide 'etaf-host-tests)
;;; etaf-host-tests.el ends here

View File

@ -0,0 +1,284 @@
;;; etaf-interaction-contract-tests.el --- Interaction contract tests -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Lock the M0b Action, Behavior, and local event composition contract.
;;; Code:
(require 'ert)
(require 'etaf)
(defun etaf-interaction-test--dispose-buffer (buffer-name)
"Unmount and kill BUFFER-NAME when either still exists."
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))
(ert-deftest etaf-interaction-duplicate-behavior-fails-before-install ()
"Reject duplicate names on one Host without running either installer."
(let ((buffer-name " *etaf-duplicate-behavior-contract*")
(installs 0))
(unwind-protect
(let ((first
(etaf-behavior-create
'duplicate
:install (lambda () (cl-incf installs) #'ignore)))
(second
(etaf-behavior-create
'duplicate
:install (lambda () (cl-incf installs) #'ignore))))
(should-error
(etaf-mount
buffer-name
(lambda ()
(etaf--view-call
'text (list :ref 'target :use (list first second))
(list "target"))))
:type 'etaf-behavior-error)
(should (zerop installs)))
(etaf-interaction-test--dispose-buffer buffer-name))))
(ert-deftest etaf-interaction-behaviors-compose-in-declaration-order ()
"Preserve installer/event order, first-wins props, and one cleanup each."
(let ((buffer-name " *etaf-behavior-order-contract*")
install-order event-order cleanup-counts)
(unwind-protect
(let* ((first
(etaf-behavior-create
'first
:class "first"
:on-press (lambda () (setq event-order
(append event-order '(first))))
:install (lambda ()
(setq install-order (append install-order '(first)))
(lambda () (push 'first cleanup-counts)))))
(second
(etaf-behavior-create
'second
:class "second"
:on-press (lambda () (setq event-order
(append event-order '(second))))
:install (lambda ()
(setq install-order (append install-order '(second)))
(lambda () (push 'second cleanup-counts))))))
(etaf-mount
buffer-name
(lambda ()
(etaf--view-call
'text
(list :ref 'target :use (list first second)
:on-press
(lambda () (setq event-order (append event-order '(host)))))
(list "target"))))
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
(should (equal install-order '(first second)))
(should (equal (plist-get
(etaf-runtime-host-props-for runtime 'target)
:class)
"first"))
(etaf-dispatch-event runtime 'target 'press)
(should (equal event-order '(host first second)))
(etaf-unmount runtime))
(should (= 1 (cl-count 'first cleanup-counts)))
(should (= 1 (cl-count 'second cleanup-counts))))
(etaf-interaction-test--dispose-buffer buffer-name))))
(ert-deftest etaf-interaction-callback-failure-short-circuits-behaviors ()
"Stop Behavior callbacks after an earlier callback signals."
(let ((buffer-name " *etaf-behavior-failure-contract*") trace)
(unwind-protect
(let ((first
(etaf-behavior-create
'first :on-press
(lambda () (push 'first trace) (error "first failed"))))
(second
(etaf-behavior-create
'second :on-press (lambda () (push 'second trace)))))
(etaf-mount
buffer-name
(lambda ()
(etaf--view-call
'text
(list :ref 'target :use (list first second)
:on-press (lambda () (push 'host trace) (error "host failed")))
(list "target"))))
(should-error
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
'target 'press))
(should (equal trace '(host)))
(etaf-unmount (etaf-runtime-for-buffer buffer-name))
(setq trace nil)
(etaf-mount
buffer-name
(lambda ()
(etaf--view-call
'text
(list :ref 'target :use (list first second)
:on-press (lambda () (push 'host trace)))
(list "target"))))
(should-error
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
'target 'press))
(should (equal trace '(first host))))
(etaf-interaction-test--dispose-buffer buffer-name))))
(ert-deftest etaf-interaction-stable-installer-identity-cleans-up-once ()
"Reuse an identical installer and run its cleanup exactly once."
(let ((buffer-name " *etaf-behavior-identity-contract*")
(trigger (etaf-ref 0))
(installs 0)
(cleanups 0))
(unwind-protect
(let* ((installer
(lambda ()
(cl-incf installs)
(lambda () (cl-incf cleanups))))
(behavior
(etaf-behavior-create 'stable :install installer)))
(etaf-mount
buffer-name
(lambda ()
(etaf--view-call
'text
(list :ref 'target :use behavior
:aria-label (format "version-%d" (etaf-value trigger)))
(list "target"))))
(should (= installs 1))
(setf (etaf-value trigger) 1)
(should (= installs 1))
(should (zerop cleanups))
(etaf-unmount (etaf-runtime-for-buffer buffer-name))
(should (= cleanups 1)))
(etaf-interaction-test--dispose-buffer buffer-name))))
(ert-deftest etaf-interaction-events-do-not-capture-or-bubble ()
"Dispatch only the callback owned by the exact Host reference."
(let ((buffer-name " *etaf-local-event-contract*") trace)
(unwind-protect
(progn
(etaf-mount
buffer-name
(lambda ()
(etaf--view-call
'column
(list :ref 'parent :on-press (lambda () (push 'parent trace)))
(list
(etaf--view-call
'text
(list :ref 'child :on-press (lambda () (push 'child trace)))
(list "child"))))))
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-dispatch-event runtime 'child 'press)
(should (equal trace '(child)))
(setq trace nil)
(etaf-dispatch-event runtime 'parent 'press)
(should (equal trace '(parent)))))
(etaf-interaction-test--dispose-buffer buffer-name))))
(ert-deftest etaf-action-duplicate-registration-errors-by-default ()
"Keep the first Action when another application claims the same name."
(let ((name 'etaf-interaction-test-cross-app-action)
(first (lambda (_runtime) 'first))
(second (lambda (_runtime) 'second)))
(unwind-protect
(progn
(etaf-action-register name first)
(should-error (etaf-action-register name second)
:type 'etaf-action-error)
(should (eq first
(etaf-action-spec-function
(gethash name etaf--action-registry)))))
(etaf-action-undefine name))))
(ert-deftest etaf-action-redefine-boundary-affects-only-future-dispatch ()
"Replace name lookup explicitly without flushing a mounted Runtime."
(let ((buffer-name " *etaf-action-redefine-contract*")
(name 'etaf-interaction-test-future-action)
(first-calls 0)
(second-calls 0))
(unwind-protect
(progn
(etaf-action-register
name (lambda (_runtime) (cl-incf first-calls)))
(etaf-mount
buffer-name
(lambda ()
(etaf--view-call
'text
(list :ref 'target
:on-press (lambda () (etaf-dispatch name)))
(list "target"))))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-current-generation runtime)))
(etaf-dispatch-event runtime 'target 'press)
(should (= first-calls 1))
(etaf-action-redefine-run
(lambda ()
(etaf-action-register
name (lambda (_runtime) (cl-incf second-calls)))))
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (= first-calls 1))
(should (zerop second-calls))
(etaf-dispatch-event runtime 'target 'press)
(should (= second-calls 1))))
(etaf-action-undefine name)
(etaf-interaction-test--dispose-buffer buffer-name))))
(ert-deftest etaf-action-reload-requires-explicit-redefine-boundary ()
"Make repeated authoring definitions explicit and dynamically scoped."
(let ((name 'etaf-interaction-test-reload-action)
(function-symbol 'etaf-interaction-test-reload-action--etaf-action))
(unwind-protect
(progn
(eval '(etaf-action-define etaf-interaction-test-reload-action
(_runtime)
'first)
t)
(should-error
(eval '(etaf-action-define etaf-interaction-test-reload-action
(_runtime)
'unintended)
t)
:type 'etaf-action-error)
(should
(eq 'first
(funcall
(etaf-action-spec-function
(gethash name etaf--action-registry))
nil)))
(etaf-action-redefine-run
(lambda ()
(eval '(etaf-action-define etaf-interaction-test-reload-action
(_runtime)
'second)
t)))
(should
(eq 'second
(funcall
(etaf-action-spec-function
(gethash name etaf--action-registry))
nil)))
(should-error
(eval '(etaf-action-define etaf-interaction-test-reload-action
(_runtime)
'unintended)
t)
:type 'etaf-action-error)
(should
(eq 'second
(funcall
(etaf-action-spec-function
(gethash name etaf--action-registry))
nil))))
(etaf-action-undefine name)
(when (fboundp function-symbol)
(fmakunbound function-symbol)))))
(provide 'etaf-interaction-contract-tests)
;;; etaf-interaction-contract-tests.el ends here

View File

@ -0,0 +1,203 @@
;;; etaf-m0a-current-characterization-tests.el --- M0a ETAF baseline -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'etaf)
(require 'etaf-m0a-inventory)
(define-error 'etaf-test-m0a-lifecycle-condition
"M0a lifecycle characterization condition")
(defconst etaf-test-m0a-condition-data
'(:phase updated
:payload ((account-id . 42) (tags alpha beta))
:retryable nil)
"Non-trivial raw condition data used by the M0a public update probe.")
(etaf-define-component etaf-test-m0a-dependency-only (&key source)
"Observe SOURCE while retaining equal rendered output."
:view (text (expr (progn (etaf-value source) "same"))))
(etaf-define-component etaf-test-m0a-lifecycle-failure (&key label)
"Publish LABEL, then signal a custom condition from the update lifecycle."
:setup
(progn
(etaf-on-updated
(lambda ()
(signal 'etaf-test-m0a-lifecycle-condition
etaf-test-m0a-condition-data)))
nil)
:view (text (expr label)))
(ert-deftest etaf-m0a-action-registration-requires-explicit-redefinition ()
"Duplicate Action registration fails outside the authoring boundary."
(let* ((name (make-symbol "etaf-m0a-action"))
(first (lambda (_runtime) 'first))
(second (lambda (_runtime) 'second)))
(unwind-protect
(progn
(etaf-action-register name first)
(should-error (etaf-action-register name second)
:type 'etaf-action-error)
(should (eq first
(etaf-action-spec-function
(gethash name etaf--action-registry))))
(etaf-action-redefine-run
(lambda () (etaf-action-register name second)))
(should (eq second
(etaf-action-spec-function
(gethash name etaf--action-registry)))))
(etaf-action-undefine name))))
(ert-deftest etaf-m0a-event-kind-normalizes-current-spellings ()
"Keyword, symbol, and string event spellings normalize to one symbol."
(dolist (spelling '(:press press on-press "press" "on-press"))
(should (eq 'press (etaf-event-kind spelling)))))
(ert-deftest etaf-m0a-dependency-only-skips-ebox-and-tp-publication ()
"An equal-output dependency update advances ETAF only, not Ebox or TP."
(let ((buffer-name " *etaf-m0a-dependency-only*")
(source (etaf-ref 0))
(ebox-commits 0))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view (etaf-test-m0a-dependency-only :source source)))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(surface (with-current-buffer buffer-name
(car tp--buffer-surfaces)))
(generation (etaf-runtime-generation runtime))
(revision (tp-surface-revision surface))
(original-ebox-commit (symbol-function 'ebox-commit)))
(cl-letf (((symbol-function 'ebox-commit)
(lambda (&rest arguments)
(cl-incf ebox-commits)
(apply original-ebox-commit arguments))))
(setf (etaf-value source) 1))
(should (= (1+ generation) (etaf-runtime-generation runtime)))
(should (zerop ebox-commits))
(should (= revision (tp-surface-revision surface)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-m0a-repeated-public-unmount-signals-runtime-error ()
"Calling the public unmount boundary twice signals runtime error."
(let ((buffer-name " *etaf-m0a-repeated-unmount*") runtime)
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-view (text "mounted")))
(setq runtime (etaf-runtime-for-buffer buffer-name))
(etaf-unmount runtime)
(should-error (etaf-unmount runtime) :type 'etaf-runtime-error))
(when (and runtime (etaf-runtime-mounted-p runtime))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-m0a-public-update-preserves-raw-condition-symbol-and-data ()
"A public update exposes the exact lifecycle condition symbol and payload."
(let ((buffer-name " *etaf-m0a-lifecycle-condition*")
(label (etaf-ref "A"))
captured)
(unwind-protect
(progn
(etaf-mount
buffer-name
(lambda ()
(etaf-view
(etaf-test-m0a-lifecycle-failure
:label (etaf-value label)))))
(condition-case condition
(setf (etaf-value label) "B")
(etaf-test-m0a-lifecycle-condition
(setq captured condition)))
(should
(eq (car captured) 'etaf-test-m0a-lifecycle-condition))
(should (equal (butlast (cdr captured))
etaf-test-m0a-condition-data))
(should (etaf-condition-postcommit-info captured))
(should (equal "B"
(with-current-buffer buffer-name
(buffer-string)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-m0a-condition-consumer-inventory-is-machine-readable ()
"The source consumer inventory exactly matches its reviewed golden."
(let ((consumers (etaf-m0a-condition-consumer-inventory))
(golden-file
(expand-file-name "tests/fixtures/etaf-m0a-condition-consumers.sexp"
etaf-m0a-package-root)))
(should consumers)
(should (cl-find "etaf-runtime.el" consumers
:key (lambda (entry) (plist-get entry :file))
:test #'equal))
(should (cl-every (lambda (entry)
(and (stringp (plist-get entry :file))
(integerp (plist-get entry :line))
(symbolp (plist-get entry :form))
(proper-list-p (plist-get entry :conditions))
(symbolp (plist-get entry :owner))
(memq (plist-get entry :policy)
'(generic-containment
specific-compatibility))))
consumers))
(with-temp-buffer
(insert-file-contents golden-file)
(should (equal (read (current-buffer))
(etaf-m0a-condition-consumer-signatures)))
(skip-chars-forward " \t\r\n")
(should (eobp)))
(should (cl-find 'observed-baseline
etaf-m0a-current-contract-inventory
:key (lambda (entry)
(plist-get entry :evidence-mode))))
(let ((json (json-parse-string (etaf-m0a-inventory-json))))
(should (= 1 (gethash "schema-version" json)))
(should (= (length etaf-m0a-current-contract-inventory)
(length (gethash "contract-inventory" json))))
(should (= (length consumers)
(length (gethash "condition-consumers" json))))
(should (= (length etaf-m0a-document-example-files)
(length (gethash "document-examples" json)))))))
(ert-deftest etaf-m0a-document-example-inventory-matches-reviewed-golden ()
"Every user documentation block matches its reviewed M0a outcome."
(let* ((golden-file
(expand-file-name "tests/fixtures/etaf-m0a-document-examples.sexp"
etaf-m0a-package-root))
(inventory (etaf-m0a-document-example-inventory))
(blocks (apply #'append
(mapcar (lambda (entry)
(plist-get entry :blocks))
inventory)))
golden)
(with-temp-buffer
(insert-file-contents golden-file)
(setq golden (read (current-buffer)))
(skip-chars-forward " \t\r\n")
(should (eobp)))
(should (equal golden (etaf-m0a-document-example-signatures)))
(should (= 124 (length blocks)))
(should (= 0 (cl-count 'read-error blocks
:key (lambda (entry)
(plist-get entry :drift)))))
;; Canonical README expressions no longer carry the four baseline errors.
(should (= 0 (cl-count 'macroexpand-error blocks
:key (lambda (entry)
(plist-get entry :drift)))))
(should (cl-every
(lambda (entry)
(and (eq 'skipped-unsafe (plist-get entry :load-status))
(eq 'arbitrary-document-code
(plist-get entry :load-reason))))
blocks))))
(provide 'etaf-m0a-current-characterization-tests)
;;; etaf-m0a-current-characterization-tests.el ends here

View File

@ -0,0 +1,26 @@
;;; etaf-m0b-component-manifest-tests.el --- M0b manifest probes -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Code:
(require 'ert)
(require 'etaf-m0b-component-manifest)
(ert-deftest etaf-m0b-component-manifest-is-derived-and-mounted ()
"Derive business props and prove Host-attribute forwarding by mounting."
(let* ((manifest (etaf-m0b-component-manifest-data))
(components (alist-get 'components manifest)))
(should (= 2 (length components)))
(should (equal '("title")
(alist-get 'declared-business-props (car components))))
(should (equal '("label")
(alist-get 'declared-business-props (cadr components))))
(dolist (entry components)
(should (alist-get 'forwarded-host-attrs entry))
(should (string-match-p "single attr-capable root"
(alist-get 'root-shape-forwarding-guarantee
entry)))
(should (eq t (alist-get 'mounted-validation entry))))))
;;; etaf-m0b-component-manifest-tests.el ends here

View File

@ -0,0 +1,168 @@
;;; etaf-observer-tests.el --- Scoped observer port tests -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Tests for the dynamically scoped ETAF observer port.
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'etaf-observer)
(defun etaf-test-observer-context (sink &optional diagnostic)
"Return a test observer context using SINK and DIAGNOSTIC."
(etaf--observer-context-create
:sink sink
:operation-id 41
:runtime-id 9
:buffer-name "*etaf-test*"
:diagnostic (or diagnostic #'ignore)))
(ert-deftest etaf-observer-stage-preserves-success-and-metadata ()
"Observed stages preserve results and emit required flat metadata."
(let (reports)
(should
(eq 'result
(etaf--observer-call-with-context
(etaf-test-observer-context
(lambda (report) (push report reports)))
(lambda ()
(etaf-observer-with-stage ('etaf 'render :detail "root")
'result)))))
(let ((report (car reports)))
(should (= 1 (length reports)))
(should (= etaf-observer-report-format-version
(plist-get report :format-version)))
(should (eq 'etaf (plist-get report :provider)))
(should (eq 'render (plist-get report :stage)))
(should (= 41 (plist-get report :operation-id)))
(should (= 1 (plist-get report :sequence)))
(should (= 9 (plist-get report :runtime-id)))
(should (equal "*etaf-test*" (plist-get report :buffer-name)))
(should (eq 'success (plist-get report :status)))
(should (equal "root" (plist-get report :detail)))
(should (>= (plist-get report :duration-ms) 0.0)))))
(ert-deftest etaf-observer-stage-preserves-error-and-quit ()
"Observed failures are reported and re-signaled without translation."
(let (reports error-condition quit-condition)
(let ((context
(etaf-test-observer-context
(lambda (report) (push report reports)))))
(setq error-condition
(condition-case condition
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-with-stage ('etaf 'render)
(signal 'wrong-type-argument '(integerp bad)))))
(error condition)))
(setq quit-condition
(condition-case condition
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-with-stage ('ebox 'commit)
(signal 'quit '(requested)))))
(quit condition))))
(should (equal '(wrong-type-argument integerp bad) error-condition))
(should (equal '(quit requested) quit-condition))
(setq reports (nreverse reports))
(should (equal '(error quit)
(mapcar (lambda (report) (plist-get report :status))
reports)))
(should (equal '(1 2)
(mapcar (lambda (report) (plist-get report :sequence))
reports)))))
(ert-deftest etaf-observer-emits-defensive-flat-copy ()
"Observer mutation cannot alter the producer's report snapshot."
(let* ((detail (copy-sequence "producer"))
(report (list :provider 'ebox :stage 'commit
:status 'success :duration-ms 1.0
:detail (list detail)))
(original (copy-tree report)))
(etaf--observer-call-with-context
(etaf-test-observer-context
(lambda (delivered)
(setcar delivered :mutated)
(setcar (cdr delivered) 99)
(aset (car (plist-get delivered :detail)) 0 ?!)))
(lambda () (etaf-observer-emit report)))
(should (equal original report))
(should (equal "producer" detail))))
(ert-deftest etaf-observer-contains-observer-failures-and-invalid-reports ()
"Observer and validation failures are diagnostics, not product failures."
(let (diagnostics failure)
(let ((context
(etaf-test-observer-context
(lambda (_report)
(if (eq failure 'error)
(error "Observer error")
(signal 'quit '(observer-quit))))
(lambda (diagnostic) (push diagnostic diagnostics)))))
(setq failure 'error)
(should
(eq 'product-result
(etaf--observer-call-with-context
context
(lambda ()
(prog1 'product-result
(etaf-observer-emit
'(:provider etaf :stage render
:status success :duration-ms 0.0)))))))
(setq failure 'quit)
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-emit
'(:provider etaf :stage commit
:status success :duration-ms 0.0))))
(etaf--observer-call-with-context
context
(lambda ()
(etaf-observer-emit '(:provider etaf :nested (not flat))))))
(should (equal '(observer-failure observer-failure invalid-report)
(mapcar (lambda (diagnostic)
(plist-get diagnostic :kind))
(nreverse diagnostics))))))
(ert-deftest etaf-observer-clears-context-during-reentrant-delivery ()
"Observer reentry sees no active observation context."
(let (context-seen reports)
(etaf--observer-call-with-context
(etaf-test-observer-context
(lambda (report)
(push report reports)
(setq context-seen etaf--observer-context)
(etaf-observer-with-stage ('etaf 'reentrant) 'ignored)))
(lambda ()
(etaf-observer-with-stage ('etaf 'outer) 'done)))
(should-not context-seen)
(should (= 1 (length reports)))
(should (eq 'outer (plist-get (car reports) :stage)))))
(ert-deftest etaf-observer-nil-path-does-zero-instrumentation ()
"The unobserved path does not time, allocate delivery, or inspect GC state."
(let ((body-count 0)
(etaf--observer-context nil))
(cl-letf (((symbol-function 'float-time)
(lambda (&optional _time) (error "Unexpected clock read")))
((symbol-function 'etaf--observer-call-stage)
(lambda (&rest _arguments) (error "Unexpected stage wrapper")))
((symbol-function 'etaf-observer-emit)
(lambda (&rest _arguments) (error "Unexpected report"))))
(should
(eq 'plain-result
(etaf-observer-with-stage ('etaf 'render)
(setq body-count (1+ body-count))
'plain-result))))
(should (= 1 body-count))))
(provide 'etaf-observer-tests)
;;; etaf-observer-tests.el ends here

View File

@ -6,445 +6,427 @@
(require 'ert)
(require 'etaf)
(defconst etaf-performance-test--facade-loaded-recorder-p
(featurep 'etaf-performance)
"Whether loading the ETAF facade eagerly loaded the optional recorder.")
(require 'etaf-performance)
(ert-deftest etaf-performance-is-not-an-etaf-facade-dependency ()
"The optional recorder must be loaded explicitly."
(should-not etaf-performance-test--facade-loaded-recorder-p))
(defmacro etaf-performance-test--isolated (&rest body)
"Run BODY with isolated performance recorder state."
"Run BODY with isolated recorder state."
(declare (indent 0) (debug t))
`(unwind-protect
(progn
(etaf-performance-mode -1)
(etaf-performance-clear)
,@body)
(etaf-performance-mode -1)
(etaf-performance-clear)))
`(let ((etaf-performance--record-ring nil)
(etaf-performance--pending (make-hash-table :test #'equal))
(etaf-performance--attachments (make-hash-table :test #'eq)))
,@body))
(ert-deftest etaf-performance-records-success-result-and-error ()
"Recording preserves successful results and original error data."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(should (equal 42
(etaf-performance--call-operation
(lambda () 42) 'test-success 'test nil)))
(let ((condition
(condition-case error-data
(etaf-performance--call-operation
(lambda ()
(etaf-performance--call-stage
(lambda ()
(signal 'args-out-of-range '(source 1 2)))
'failing-stage 'test 'failure nil))
'test-error 'test nil)
(args-out-of-range error-data))))
(should (equal condition '(args-out-of-range source 1 2))))
(let ((records (etaf-performance-records)))
(should (= 2 (length records)))
(should (eq 'error
(etaf-performance-operation-status (car records))))
(should (eq 'error
(etaf-performance-stage-status
(car (etaf-performance-operation-stages
(car records))))))
(should (eq 'success
(etaf-performance-operation-status (cadr records)))))))
(cl-defmacro etaf-performance-test--with-runtime
((runtime buffer-name) &rest body)
"Mount RUNTIME in BUFFER-NAME, evaluate BODY, then clean up."
(declare (indent 1) (debug ((symbolp symbolp) body)))
`(let ((,buffer-name (generate-new-buffer-name " *etaf-performance-test*"))
,runtime)
(unwind-protect
(progn
(etaf-mount ,buffer-name (etaf-view (box "Performance")))
(setq ,runtime (etaf-runtime-for-buffer ,buffer-name))
,@body)
(when ,runtime
(etaf-performance-stop ,runtime)
(when (etaf-runtime-mounted-p ,runtime)
(etaf-unmount ,runtime)))
(when-let* ((buffer (get-buffer ,buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-performance-records-preserve-quit ()
"Recording marks and re-signals a quit without changing its data."
(ert-deftest etaf-performance-start-stop-own-exact-runtime-sink ()
"Attach idempotently and remove only this recorder's exact sink."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(let ((condition
(condition-case quit-data
(etaf-performance--call-operation
(lambda () (signal 'quit '(performance-test)))
'test-quit 'test nil)
(quit quit-data))))
(should (equal condition '(quit performance-test)))
(should (eq 'quit
(etaf-performance-operation-status
(car (etaf-performance-records))))))))
(etaf-performance-test--with-runtime (runtime buffer-name)
(should (eq runtime (etaf-performance-start runtime)))
(let* ((attachment
(gethash runtime etaf-performance--attachments))
(sink (etaf-performance--attachment-sink attachment)))
(should (functionp sink))
(should (etaf-runtime-compare-and-set-observer runtime sink sink))
(should (eq runtime (etaf-performance-start runtime)))
(should (eq runtime (etaf-performance-stop runtime)))
(should (etaf-runtime-compare-and-set-observer runtime nil nil))))))
(ert-deftest etaf-performance-public-operation-wrapper-is-generic ()
"The public operation API records arbitrary code and preserves its result."
(ert-deftest etaf-performance-start-rejects-foreign-observer ()
"Never replace an observer owned by another consumer."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(should
(equal '(generic result)
(etaf-performance-with-operation ('command "generic fixture")
'(generic result))))
(let ((operation (car (etaf-performance-records))))
(should (eq 'command
(etaf-performance-operation-kind operation)))
(should (equal "generic fixture"
(etaf-performance-operation-label operation))))))
(etaf-performance-test--with-runtime (runtime buffer-name)
(let ((foreign #'ignore))
(etaf-runtime-set-observer runtime foreign)
(should-error (etaf-performance-start runtime))
(should (etaf-runtime-compare-and-set-observer
runtime foreign foreign))
(etaf-runtime-set-observer runtime nil)))))
(ert-deftest etaf-performance-stage-registration-is-load-order-safe ()
"Third-party stages may register before their function is defined."
(ert-deftest etaf-performance-stop-preserves-replacement-observer ()
"A later foreign replacement is not detached by recorder stop."
(etaf-performance-test--isolated
(let ((function (make-symbol "etaf-performance-generic-stage")))
(etaf-performance-test--with-runtime (runtime buffer-name)
(etaf-performance-start runtime)
(let ((foreign #'ignore))
(etaf-runtime-set-observer runtime foreign)
(etaf-performance-stop runtime)
(should (etaf-runtime-compare-and-set-observer
runtime foreign foreign))
(etaf-runtime-set-observer runtime nil)))))
(ert-deftest etaf-performance-mode-is-current-buffer-convenience ()
"The local mode attaches only the Runtime in its current buffer."
(etaf-performance-test--isolated
(etaf-performance-test--with-runtime (runtime buffer-name)
(with-current-buffer buffer-name
(etaf-performance-mode 1)
(should etaf-performance-mode)
(should (eq runtime etaf-performance--mode-runtime))
(let* ((attachment
(gethash runtime etaf-performance--attachments))
(sink (etaf-performance--attachment-sink attachment)))
(should (functionp sink))
(should (etaf-runtime-compare-and-set-observer
runtime sink sink)))
(etaf-performance-mode -1)
(should-not etaf-performance-mode)
(should (etaf-runtime-compare-and-set-observer runtime nil nil))))))
(ert-deftest etaf-performance-mode-rejects-non-runtime-buffer ()
"The buffer-local convenience requires a mounted Runtime."
(with-temp-buffer
(should-error (etaf-performance-mode 1))
(should-not etaf-performance-mode)))
(ert-deftest etaf-performance-unmount-records-and-releases-attachment ()
"Record unmount before the Runtime detaches this recorder."
(etaf-performance-test--isolated
(let ((buffer-name (generate-new-buffer-name " *etaf-performance-unmount*"))
runtime)
(unwind-protect
(progn
(etaf-performance-register-stage function 'extension 'prepare)
(etaf-performance-mode 1)
(should-not (assq function etaf-performance--installed-advices))
(fset function (lambda () 'extension-result))
(etaf-performance--install-loaded-advices)
(should (assq function etaf-performance--installed-advices))
(should (eq 'extension-result
(etaf-performance-call-operation
'extension "registered stage"
(lambda () (funcall function)))))
(let ((stage
(car (etaf-performance-operation-stages
(car (etaf-performance-records))))))
(should (eq function
(etaf-performance-stage-function stage)))
(should (eq 'extension
(etaf-performance-stage-category stage)))))
(etaf-performance-unregister-stage function)
(when (fboundp function)
(fmakunbound function))))))
(ert-deftest etaf-performance-default-registry-keeps-per-node-probes-opt-in ()
"High-frequency per-node probes must not distort default operation timing."
(dolist (function '(ebox-incremental--candidate-local-changed-keys
ebox-tree-node-local-source-signature))
(should-not (assq function etaf-performance--stage-functions))))
(ert-deftest etaf-performance-stage-advice-survives-package-reload ()
"Reattach the tracked stage closure after its function is redefined."
(etaf-performance-test--isolated
(let ((function (make-symbol "etaf-performance-reloaded-stage")))
(unwind-protect
(progn
(fset function (lambda () 'first))
(etaf-performance-register-stage function 'extension 'reload)
(etaf-performance-mode 1)
(let ((entry (assq function
etaf-performance--installed-advices)))
(should (advice-member-p (cdr entry) function))
(fset function (lambda () 'second))
(should-not (advice-member-p (cdr entry) function))
(etaf-performance--install-loaded-advices)
(should (advice-member-p (cdr entry) function)))
(etaf-performance-clear)
(should (eq 'second
(etaf-performance-call-operation
'reload "package reload"
(lambda () (funcall function)))))
(should (= 1
(length
(etaf-performance-operation-stages
(car (etaf-performance-records)))))))
(etaf-performance-unregister-stage function)
(when (fboundp function) (fmakunbound function))))))
(ert-deftest etaf-performance-stage-registration-rejects-operation-collision ()
"A detail stage must not replace a public operation boundary advice."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(let* ((function 'etaf-data-load)
(entry (assq function etaf-performance--installed-advices)))
(should entry)
(should-error
(etaf-performance-register-stage function 'data 'nested-load))
(should-error (etaf-performance-unregister-stage function))
(should (eq entry (assq function etaf-performance--installed-advices)))
(should (advice-member-p (cdr entry) function)))))
(ert-deftest etaf-performance-public-data-resource-and-viewport-boundaries ()
"Public cross-package operations are boundaries, never duplicate stages."
(etaf-performance-test--isolated
(let ((functions '(etaf-data-load etaf-data-source-load-page
etaf-data-mutate etaf-resource-load
ebox-surface-update-buffer-viewport
ebox-rerender-buffer-with-context)))
(dolist (function functions)
(should (assq function etaf-performance--operation-functions))
(should-not (assq function etaf-performance--stage-functions)))
(etaf-performance-mode 1)
(dolist (function functions)
(when (fboundp function)
(should (assq function etaf-performance--installed-advices))))
(let* ((source (etaf-data-memory-source
'((:id 1 :name "one")) :id-key :id))
(controller (etaf-data-controller source))
(resource (etaf-resource (lambda () 'loaded) :immediate nil)))
(unwind-protect
(progn
(etaf-data-load controller)
(etaf-data-source-load-page source nil 1 20)
(etaf-data-mutate controller 'insert '(:id 2 :name "two"))
(etaf-resource-load resource)
(let ((kinds
(mapcar #'etaf-performance-operation-kind
(etaf-performance-records))))
(should (memq 'data-load kinds))
(should (memq 'data-prepare kinds))
(should (memq 'data-mutate kinds))
(should (memq 'resource-load kinds))))
(etaf-data-stop controller)
(etaf-resource-dispose resource))))))
(ert-deftest etaf-performance-records-nested-stage-exclusive-time ()
"Nested stages retain depth and subtract child inclusive time."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(etaf-performance--call-operation
(lambda ()
(etaf-performance--call-stage
(lambda ()
(sleep-for 0.002)
(etaf-performance--call-stage
(lambda () (sleep-for 0.002) 'inner-result)
'inner-stage 'inner 'work nil)
(sleep-for 0.002))
'outer-stage 'outer 'work nil))
'nested-operation 'test nil)
(let* ((operation (car (etaf-performance-records)))
(stages (etaf-performance-operation-stages operation))
(outer (car stages))
(inner (cadr stages)))
(should (= 2 (length stages)))
(should (= 0 (etaf-performance-stage-depth outer)))
(should (= 1 (etaf-performance-stage-depth inner)))
(should (>= (etaf-performance-stage-inclusive outer)
(etaf-performance-stage-inclusive inner)))
(should (< (abs (- (etaf-performance-stage-exclusive outer)
(- (etaf-performance-stage-inclusive outer)
(etaf-performance-stage-inclusive inner))))
0.001)))))
(ert-deftest etaf-performance-records-are-bounded ()
"Only the configured number of newest operations is retained."
(etaf-performance-test--isolated
(let ((etaf-performance-max-records 2))
(etaf-performance-mode 1)
(dotimes (index 4)
(etaf-performance--call-operation
(lambda () index) 'bounded 'test nil))
(let* ((records (etaf-performance-records))
(ids (mapcar #'etaf-performance-operation-id records)))
(should (= 2 (length records)))
(should (= 1 (- (car ids) (cadr ids))))))))
(ert-deftest etaf-performance-clear-keeps-correlation-ids-monotonic ()
"Clearing history inside an operation must not reuse its ID."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(etaf-performance-call-operation
'outer "clear inside" (lambda () (etaf-performance-clear)))
(etaf-performance-call-operation 'next "after clear" #'ignore)
(let ((ids (mapcar #'etaf-performance-operation-id
(etaf-performance-records))))
(should (= 2 (length (delete-dups (copy-sequence ids)))))
(should (= 1 (- (car ids) (cadr ids)))))))
(ert-deftest etaf-performance-summaries-aggregate-off-the-hot-path ()
"Summarize operation percentiles and non-overlapping category self time."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(dolist (delay '(0.001 0.002 0.003))
(etaf-performance-call-operation
'summary "generic"
(lambda ()
(etaf-performance--call-stage
(lambda () (sleep-for delay)) 'summary-stage 'application 'work nil))))
(let* ((records (etaf-performance-records))
(summary (car (etaf-performance-summary records)))
(stage-summary
(car (etaf-performance-operation-stage-summary (car records)))))
(should (= 3 (plist-get summary :count)))
(should (<= (plist-get summary :min-ms)
(plist-get summary :p50-ms)
(plist-get summary :p95-ms)
(plist-get summary :max-ms)))
(should (eq 'application (plist-get stage-summary :category)))
(should (= 1 (plist-get stage-summary :count)))
(should (<= (plist-get stage-summary :exclusive-ms)
(plist-get stage-summary :inclusive-ms))))))
(ert-deftest etaf-performance-records-real-event-and-runtime-stages ()
"A real mounted event creates an event operation and runtime stages."
(etaf-performance-test--isolated
(let ((buffer-name " *etaf-performance-event-test*")
(calls 0)
runtime-holder)
(unwind-protect
(progn
(etaf-performance-mode 1)
(etaf-mount
buffer-name
(etaf-view
(text :ref 'button
:on-press (lambda ()
(cl-incf calls)
(etaf-runtime-flush runtime-holder))
"Press")))
(etaf-performance-clear)
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
(setq runtime-holder runtime)
(etaf-dispatch-event runtime 'button 'press)
(should (= calls 1))
(let ((operation
(cl-find 'event (etaf-performance-records)
:key #'etaf-performance-operation-kind)))
(should (eq 'event
(etaf-performance-operation-kind operation)))
(should (= (etaf-runtime-mount-epoch runtime)
(etaf-performance-operation-runtime-id operation)))
(should (equal buffer-name
(etaf-performance-operation-buffer-name
operation)))
(should (numberp
(etaf-performance-operation-generation-before
operation)))
(should
(cl-some
(lambda (record)
(cl-some
(lambda (stage)
(memq (etaf-performance-stage-category stage)
'(runtime reactive ebox tp)))
(etaf-performance-operation-stages record)))
(etaf-performance-records))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-mount buffer-name (etaf-view (box "Unmount")))
(setq runtime (etaf-runtime-for-buffer buffer-name))
(etaf-performance-start runtime)
(etaf-unmount runtime)
(should-not (gethash runtime etaf-performance--attachments))
(let ((operation (car (etaf-performance-records))))
(should (eq 'unmount
(etaf-performance-operation-kind operation)))
(should (eq 'success
(etaf-performance-operation-status operation))))
(should (eq runtime (etaf-performance-stop runtime))))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))))
(ert-deftest etaf-performance-panel-has-operation-and-stage-entries ()
"The tabulated panel expands one operation into its stage rows."
(ert-deftest etaf-performance-killed-buffer-releases-runtime-attachment ()
"Direct buffer death unmounts Runtime and releases recorder ownership."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(etaf-performance--call-operation
(lambda ()
(etaf-performance--call-stage
(lambda () 'ok) 'panel-stage 'panel 'detail nil))
'panel-operation 'test nil)
(let ((entries (etaf-performance--tabulated-entries)))
(should (= 2 (length entries)))
(should (equal "operation" (aref (cadr (car entries)) 4)))
(should (equal "stage" (aref (cadr (cadr entries)) 2))))
(with-temp-buffer
(etaf-performance-panel-mode)
(tabulated-list-print t)
(should (string-match-p "panel-operation" (buffer-string)))
(should (string-match-p "panel-stage" (buffer-string))))))
(let ((buffer-name (generate-new-buffer-name " *etaf-performance-kill*"))
runtime buffer)
(etaf-mount buffer-name (etaf-view (box "Kill")))
(setq buffer (get-buffer buffer-name)
runtime (etaf-runtime-for-buffer buffer))
(etaf-performance-start runtime)
(should (gethash runtime etaf-performance--attachments))
(kill-buffer buffer)
(should-not (buffer-live-p buffer))
(should-not (etaf-runtime-mounted-p runtime))
(should-not (gethash runtime etaf-performance--attachments))
(should-error (etaf-performance-start runtime)
:type 'etaf-runtime-error))))
(ert-deftest etaf-performance-report-is-portable-and-copyable ()
"The shareable report contains environment, operation, and stage data."
(ert-deftest etaf-performance-groups-flat-reports-in-sequence-order ()
"One ETAF final report retains one ordered, categorized operation."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(etaf-performance-call-operation
'report "copy fixture"
(lambda ()
(etaf-performance--call-stage
(lambda () 'ok) 'report-stage 'fixture 'work nil)))
(let* ((data (etaf-performance-report-data))
(operations (plist-get data :operations))
(operation (car operations))
(stage (car (plist-get operation :stages)))
(kill-ring nil)
(kill-ring-yank-pointer nil)
(report (etaf-performance-copy-report)))
(should (= etaf-performance-report-format-version
(plist-get data :format-version)))
(should (equal emacs-version
(plist-get (plist-get data :environment)
:emacs-version)))
(should (equal "copy fixture" (plist-get operation :label)))
(should (eq 'report-stage (plist-get stage :function)))
(should (equal report (current-kill 0 t)))
(should (string-match-p "ETAF performance report" report)))))
(etaf-performance-test--with-runtime (runtime buffer-name)
(etaf-performance-start runtime)
(should
(equal
'result
(etaf-performance-call-operation
runtime 'command "flat fixture"
(lambda ()
(etaf-observer-emit
'(:provider data :stage load :duration-ms 2.0 :rows 4))
(etaf-observer-emit
'(:provider ebox :stage commit :duration-ms 3.0 :patches 2))
'result))))
(let* ((records (etaf-performance-records))
(operation (car records))
(stages (etaf-performance-operation-stages operation)))
(should (= 1 (length records)))
(should (eq 'command (etaf-performance-operation-kind operation)))
(should (equal "flat fixture"
(etaf-performance-operation-label operation)))
(should (equal '(1 2 3)
(mapcar #'etaf-performance-stage-sequence stages)))
(should (equal '(data ebox etaf)
(mapcar #'etaf-performance-stage-provider stages)))
(should (equal '(data ebox runtime)
(mapcar #'etaf-performance-stage-category stages)))
(should (eq 'runtime-operation
(etaf-performance-stage-name (car (last stages)))))
(should (= 4 (plist-get
(etaf-performance-stage-metadata (car stages))
:rows)))))))
(ert-deftest etaf-performance-operation-wrapper-preserves-errors ()
"The public wrapper delegates result, timing, and failure to Runtime."
(etaf-performance-test--isolated
(etaf-performance-test--with-runtime (runtime buffer-name)
(etaf-performance-start runtime)
(let ((condition
(condition-case data
(etaf-performance-with-operation
(runtime 'command "failure")
(signal 'args-out-of-range '(source 1 2)))
(args-out-of-range data))))
(should (equal condition '(args-out-of-range source 1 2))))
(let ((operation (car (etaf-performance-records))))
(should (eq 'error (etaf-performance-operation-status operation)))
(should (eq 'error
(etaf-performance-stage-status
(car (last
(etaf-performance-operation-stages operation))))))))))
(ert-deftest etaf-performance-record-ring-is-bounded ()
"Retain only the configured number of newest operations."
(etaf-performance-test--isolated
(let ((etaf-performance-max-records 2))
(etaf-performance-test--with-runtime (runtime buffer-name)
(etaf-performance-start runtime)
(dotimes (index 4)
(etaf-performance-call-operation
runtime 'bounded (format "operation %d" index) #'ignore))
(let ((records (etaf-performance-records)))
(should (= 2 (length records)))
(should (> (etaf-performance-operation-id (car records))
(etaf-performance-operation-id (cadr records)))))))))
(ert-deftest etaf-performance-records-return-deep-snapshots ()
"Caller mutation cannot alter retained operations or stages."
(etaf-performance-test--isolated
(etaf-performance-test--with-runtime (runtime buffer-name)
(etaf-performance-start runtime)
(etaf-performance-call-operation
runtime 'snapshot "stable label"
(lambda ()
(etaf-observer-emit
'(:provider data :stage load :duration-ms 1.0
:detail ("stable")))
'result))
(let* ((operation (car (etaf-performance-records)))
(stage (car (etaf-performance-operation-stages operation)))
(detail (car (plist-get
(etaf-performance-stage-metadata stage) :detail))))
(setf (etaf-performance-operation-label operation) "changed"
(etaf-performance-stage-name stage) 'changed)
(aset detail 0 ?X))
(let* ((operation (car (etaf-performance-records)))
(stage (car (etaf-performance-operation-stages operation))))
(should (equal "stable label"
(etaf-performance-operation-label operation)))
(should (eq 'load (etaf-performance-stage-name stage)))
(should (equal '("stable")
(plist-get (etaf-performance-stage-metadata stage)
:detail)))))))
(ert-deftest etaf-performance-records-filter-by-runtime-report-identity ()
"Select isolated history by report identity when buffer names are reused."
(etaf-performance-test--isolated
(dolist (entry '((1 101 "first mount")
(1 202 "second mount")
(2 101 "first unmount")))
(etaf-performance--retain
(etaf-performance--operation-create
:id (nth 0 entry) :runtime-id (nth 1 entry) :label (nth 2 entry)
:buffer-name " *reused performance buffer*"
:metadata '(:detail ("stable")))))
(should (= 3 (length (etaf-performance-records))))
(should (equal (etaf-performance-records)
(etaf-performance-records nil)))
(let ((first (etaf-performance-records 101))
(second (etaf-performance-records 202)))
(should (equal '("first unmount" "first mount")
(mapcar #'etaf-performance-operation-label first)))
(should (equal '("second mount")
(mapcar #'etaf-performance-operation-label second)))
(setf (etaf-performance-operation-label (car first)) "changed")
(setcar (plist-get (etaf-performance-operation-metadata (car first))
:detail)
"changed")
(let ((retained (car (etaf-performance-records 101))))
(should (equal "first unmount"
(etaf-performance-operation-label retained)))
(should (equal '("stable")
(plist-get (etaf-performance-operation-metadata retained)
:detail)))))
(should-not (etaf-performance-records 303))
(should-error (etaf-performance-records "101")
:type 'wrong-type-argument)))
(ert-deftest etaf-performance-summary-keeps-explicit-empty-selection ()
"An omitted selection summarizes all records; an explicit nil stays empty."
(etaf-performance-test--isolated
(etaf-performance--retain
(etaf-performance--operation-create
:kind 'report :label "retained fixture" :elapsed 1.0))
(should (= 1 (length (etaf-performance-summary))))
(should-not (etaf-performance-summary nil))))
(ert-deftest etaf-performance-report-data-keeps-explicit-empty-selection ()
"An empty data export cannot fall back to previously retained records."
(etaf-performance-test--isolated
(etaf-performance--retain
(etaf-performance--operation-create
:kind 'report :label "retained fixture" :elapsed 1.0))
(let ((all (etaf-performance-report-data))
(empty (etaf-performance-report-data nil)))
(should (= 1 (length (plist-get all :summary))))
(should (= 1 (length (plist-get all :operations))))
(should-not (plist-get empty :summary))
(should-not (plist-get empty :operations)))))
(ert-deftest etaf-performance-report-string-keeps-explicit-empty-selection ()
"Report strings preserve both omitted and explicitly empty selections."
(etaf-performance-test--isolated
(etaf-performance--retain
(etaf-performance--operation-create
:kind 'report :label "retained fixture" :elapsed 1.0))
(let ((all (read (etaf-performance-report-string)))
(empty (read (etaf-performance-report-string nil))))
(should (= 1 (length (plist-get all :summary))))
(should (= 1 (length (plist-get all :operations))))
(should-not (plist-get empty :summary))
(should-not (plist-get empty :operations)))))
(ert-deftest etaf-performance-reports-keep-empty-runtime-selection ()
"An unmatched runtime report identity produces empty summary and exports."
(etaf-performance-test--isolated
(etaf-performance--retain
(etaf-performance--operation-create
:runtime-id 101 :kind 'report :label "retained fixture" :elapsed 1.0))
(let ((records (etaf-performance-records 202)))
(should-not records)
(should-not (etaf-performance-summary records))
(dolist (report (list (etaf-performance-report-data records)
(read (etaf-performance-report-string records))))
(should-not (plist-get report :summary))
(should-not (plist-get report :operations))))))
(ert-deftest etaf-performance-summary-uses-flat-duration ()
"Summaries expose percentiles and overlapping provider durations honestly."
(etaf-performance-test--isolated
(etaf-performance-test--with-runtime (runtime buffer-name)
(etaf-performance-start runtime)
(dotimes (_ 3)
(etaf-performance-call-operation
runtime 'summary "fixture"
(lambda ()
(etaf-observer-emit
'(:provider tp :stage publish :duration-ms 2.5)))))
(let* ((operation (car (etaf-performance-records)))
(summary (car (etaf-performance-summary)))
(stage-summary
(etaf-performance-operation-stage-summary operation))
(tp-summary
(cl-find 'tp stage-summary :key
(lambda (entry) (plist-get entry :category)))))
(should (= 3 (plist-get summary :count)))
(should (<= (plist-get summary :min-ms)
(plist-get summary :p50-ms)
(plist-get summary :p95-ms)
(plist-get summary :max-ms)))
(should (= 1 (plist-get tp-summary :count)))
(should (= 2.5 (plist-get tp-summary :duration-ms)))
(should-not (plist-member tp-summary :exclusive-ms))))))
(ert-deftest etaf-performance-report-panel-copy-and-export-remain-usable ()
"Portable reports, the panel, copy, and export consume flat records."
(etaf-performance-test--isolated
(etaf-performance-test--with-runtime (runtime buffer-name)
(etaf-performance-start runtime)
(etaf-performance-call-operation
runtime 'report "portable fixture"
(lambda ()
(etaf-observer-emit
'(:provider tp :stage publish :duration-ms 1.25))))
(let* ((data (etaf-performance-report-data))
(operation (car (plist-get data :operations)))
(stage (car (plist-get operation :stages)))
(kill-ring nil)
(kill-ring-yank-pointer nil)
(copied (etaf-performance-copy-report))
(file (make-temp-file "etaf-performance-" nil ".eld")))
(unwind-protect
(progn
(delete-file file)
(should (= 2 (plist-get data :format-version)))
(should (equal "portable fixture"
(plist-get operation :label)))
(should (eq 'tp (plist-get stage :provider)))
(should (equal copied (current-kill 0 t)))
(should (equal file (etaf-performance-export file)))
(with-temp-buffer
(insert-file-contents file)
(should (string-match-p "portable fixture"
(buffer-string)))))
(when (file-exists-p file)
(delete-file file))))
(let ((entries (etaf-performance--tabulated-entries)))
(should (= 3 (length entries))))
(with-temp-buffer
(etaf-performance-panel-mode)
(tabulated-list-print t)
(should (string-match-p "portable fixture" (buffer-string)))
(should (string-match-p "publish" (buffer-string)))))))
(ert-deftest etaf-performance-environment-normalizes-darwin-power-state ()
"Reports distinguish AC, battery low-power, and unknown power states."
(should
(equal
'(:source battery :low-power-mode on)
(etaf-performance--parse-darwin-power-state
"Now drawing from 'Battery Power'\n"
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
(equal '(:source battery :low-power-mode on)
(etaf-performance--parse-darwin-power-state
"Now drawing from 'Battery Power'\n"
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
(should
(equal
'(:source ac :low-power-mode off)
(etaf-performance--parse-darwin-power-state
"Now drawing from 'AC Power'\n"
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
(equal '(:source ac :low-power-mode off)
(etaf-performance--parse-darwin-power-state
"Now drawing from 'AC Power'\n"
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
(should
(equal
'(:source unknown :low-power-mode unknown)
(etaf-performance--parse-darwin-power-state "" ""))))
(equal '(:source unknown :low-power-mode unknown)
(etaf-performance--parse-darwin-power-state "" ""))))
(ert-deftest etaf-performance-panel-exposes-power-and-load-context ()
"The visible panel explains system-wide latency shifts."
(let ((line
(etaf-performance--panel-environment-line
'(:emacs-version "31.1"
:power-state (:source battery :low-power-mode on)
:load-average (2.5 2.0 1.5)))))
(should (string-match-p "Emacs 31.1" line))
(should (string-match-p "power battery/low:on" line))
(should (string-match-p "load 2.50" line))))
(ert-deftest etaf-performance-environment-reports-native-jit-state ()
"Expose background JIT state beside absolute latency records."
(let ((native-comp-jit-compilation t))
(should (eq t (plist-get (etaf-performance-environment-data)
:native-comp-jit-compilation))))
(let ((native-comp-jit-compilation nil))
(should-not (plist-get (etaf-performance-environment-data)
:native-comp-jit-compilation))))
(ert-deftest etaf-performance-export-writes-readable-report ()
"The interactive export payload is a readable plain-data report."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(etaf-performance-call-operation 'export "file fixture" #'ignore)
(let ((file (concat (make-temp-name
(expand-file-name "etaf-performance-test-"
temporary-file-directory))
".eld")))
(unwind-protect
(progn
(should (equal file (etaf-performance-export file)))
(with-temp-buffer
(insert-file-contents file)
(should (string-match-p "ETAF performance report"
(buffer-string)))
(should (string-match-p "file fixture" (buffer-string)))))
(when (file-exists-p file)
(delete-file file))))))
(ert-deftest etaf-performance-captures-public-ebox-report-metadata ()
"Attach compact public Ebox report facts to the active operation."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(etaf-performance--call-operation
(lambda ()
(etaf-performance--call-stage
(lambda ()
'(:strategy mixed-owner-reflow
:projection-kind mixed-owner-reflow
:dirty-count 8 :owner-ids (1 2 3) :patch-count 3
:tp-scope-count 3 :tp-text-operations 12
:tp-property-operations 111 :tp-full-root nil
:tp-scope-fallback nil))
'ebox-commit 'ebox 'commit nil))
'report-operation 'test nil)
(let* ((operation (car (etaf-performance-records)))
(report (plist-get
(etaf-performance-operation-metadata operation) :ebox)))
(should (eq 'mixed-owner-reflow (plist-get report :strategy)))
(should (= 3 (plist-get report :owner-count)))
(should (= 111 (plist-get report :tp-property-operations)))
(should (string-match-p "mixed-owner-reflow"
(etaf-performance--format-report operation))))))
(ert-deftest etaf-performance-mode-uninstalls-all-advices ()
"Disabling recording removes operation, stage, and after-load hooks."
(etaf-performance-test--isolated
(etaf-performance-mode 1)
(let ((installed (copy-sequence etaf-performance--installed-advices)))
(should installed)
(dolist (entry installed)
(should (advice-member-p (cdr entry) (car entry))))
(etaf-performance-mode -1)
(should-not etaf-performance--installed-advices)
(should-not (memq #'etaf-performance--install-loaded-advices
after-load-functions))
(dolist (entry installed)
(should-not (advice-member-p (cdr entry) (car entry)))))))
(ert-deftest etaf-performance-source-has-no-advice-or-private-provider-registry ()
"Recorder source depends only on the public Runtime observation boundary."
(let ((source
(with-temp-buffer
(insert-file-contents
(expand-file-name
"etaf-performance.el"
(file-name-directory (locate-library "etaf-performance"))))
(buffer-string))))
(dolist (pattern '("advice-add" "advice-remove" "after-load-functions"
"operation-functions" "stage-functions"
"etaf-runtime-mount-epoch"
"etaf-runtime-observer runtime"
"etaf-runtime-mounted-p"
"ebox--" "tp--" "etaf-sqlite--"))
(should-not (string-match-p (regexp-quote pattern) source)))))
(provide 'etaf-performance-tests)

View File

@ -0,0 +1,620 @@
;;; etaf-render-port-tests.el --- M3a renderer-port gates -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
(require 'ert)
(require 'etaf-render-port)
(defconst etaf-render-port-test--root
(file-name-directory
(directory-file-name
(file-name-directory (or load-file-name buffer-file-name))))
"ETAF package root used by static bootstrap-owner checks.")
(ert-deftest etaf-render-port-package-metadata-requires-final-v2-stack ()
"ETAF 0.2.1 declares the Ebox 3 and TP 2 runtime requirements."
(require 'package)
(with-temp-buffer
(insert-file-contents
(expand-file-name "etaf.el" etaf-render-port-test--root))
(let ((description (package-buffer-info)))
(should (equal (package-desc-version description) '(0 2 1)))
(should
(equal (package-desc-reqs description)
'((emacs (29 1)) (ebox (3 0 0)) (tp (2 0 0))))))))
(ert-deftest etaf-render-port-selects-valid-v2-immutably ()
"A valid provider produces one immutable v2 selected port."
(let* ((port (etaf-render-port--bootstrap))
(capabilities (etaf-render-port-capabilities port)))
(should (etaf-render-port-p port))
(should (eq (etaf-render-port-route port) 'v2))
(should (= (etaf-render-port-spi-version port) 2))
(should (eq (etaf-render-port-schema-version port)
'ebox-framework-spi-schema/v2))
(should (memq (etaf-render-port-tp-protocol port)
etaf-render-port--accepted-tp-protocols))
(should (eq (etaf-render-port-initial-function port)
'ebox-framework-spi-initial))
(should (eq (etaf-render-port-update-function port)
'ebox-framework-spi-update))
(should (eq (etaf-render-port-revision-function port)
'ebox-surface-buffer-revision))
(should (eq (etaf-render-port-snapshot-function port)
'ebox-surface-buffer-snapshot))
(should (eq (etaf-render-port-bootstrap-outcome port)
'valid-v2-selected))
(setcar capabilities 'mutated)
(should (eq (car (etaf-render-port-capabilities port))
'initial-paired-stage-rollback))
(should-error
(eval `(setf (etaf-render-port--route ',port) 'broken)))))
(ert-deftest etaf-render-port-requires-public-snapshot-query ()
"An otherwise valid v2 provider cannot omit the public snapshot query."
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot) nil))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error)))
(ert-deftest etaf-render-port-snapshot-forwards-owned-export-once ()
"The port forwards one Ebox-owned export without copying or publishing it."
(let* ((snapshot (list :input (ebox-build '(box "snapshot"))
:revision 7 :mount-id 23))
(calls 0))
(with-temp-buffer
(let ((buffer (current-buffer)))
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot)
(lambda (target)
(should (eq target buffer))
(cl-incf calls)
snapshot))
((symbol-function 'etaf-render-port-update)
(lambda (&rest _) (error "Snapshot published"))))
(should (eq snapshot (etaf-render-port-snapshot buffer)))
(should (= calls 1)))))))
(ert-deftest etaf-render-port-snapshot-rejects-malformed-export ()
"The adapter checks the public envelope without probing private state."
(dolist (snapshot (list nil '(:input wrong :revision 7 :mount-id 23)
(list :input (ebox-build '(box "snapshot"))
:revision "7" :mount-id 23)
(list :input (ebox-build '(box "snapshot"))
:revision 7 :mount-id nil)))
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot)
(lambda (_buffer) snapshot)))
(should-error (etaf-render-port-snapshot (current-buffer)) :type 'error))))
(ert-deftest etaf-render-port-snapshot-preserves-query-errors ()
"An Ebox rejection remains visible and never triggers a render fallback."
(let ((condition '(user-error "snapshot is unavailable in this transaction")))
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot)
(lambda (_buffer) (signal (car condition) (cdr condition)))))
(should (equal condition
(should-error (etaf-render-port-snapshot (current-buffer))
:type 'user-error))))))
(ert-deftest etaf-runtime-flush-returns-revision-without-export ()
"Explicit flush requests a drain and returns a cheap committed revision."
(require 'etaf)
(let* ((runtime (etaf--runtime-create :buffer (current-buffer)))
trace)
(cl-letf (((symbol-function 'etaf-runtime-require-mounted)
(lambda (target) (should (eq target runtime)) runtime))
((symbol-function 'etaf--runtime-request-flush)
(lambda (target) (should (eq target runtime)) (push 'drain trace)))
((symbol-function 'etaf-render-port-revision)
(lambda (buffer)
(should (eq buffer (current-buffer)))
(push 'revision trace)
13))
((symbol-function 'etaf-runtime-snapshot)
(lambda (&rest _) (error "Flush exported a whole tree")))
((symbol-function 'etaf--runtime-render-root-turn)
(lambda (&rest _) (error "Flush forced a Root rebuild"))))
(should (= 13 (etaf-runtime-flush runtime)))
(should (equal '(drain revision) (nreverse trace))))))
(ert-deftest etaf-runtime-flush-rejects-transaction-before-drain ()
"Public flush never drains work or exposes a provisional TP revision."
(require 'etaf)
(let ((runtime (etaf--runtime-create :buffer (current-buffer))) trace)
(cl-letf (((symbol-function 'etaf-runtime-require-mounted)
(lambda (_target) runtime))
((symbol-function 'etaf--runtime-request-flush)
(lambda (&rest _) (push 'drain trace)))
((symbol-function 'etaf-render-port-revision)
(lambda (&rest _) (push 'revision trace) 99)))
(tp-with-transaction
(should-error (etaf-runtime-flush runtime) :type 'etaf-runtime-error))
(should-not trace))))
(ert-deftest etaf-runtime-obsolete-root-getter-compiles-as-snapshot-query ()
"Compiled compatibility reads query current input, not the reserved slot."
(require 'etaf)
(require 'bytecomp)
(let* ((runtime (etaf--runtime-create :reserved-root-node 'stale-root))
(snapshot (list :input (ebox-build '(box "Current"))
:revision 7 :mount-id 23))
(getter (let ((byte-compile-warnings '(not obsolete)))
(byte-compile '(lambda (runtime)
(etaf-runtime-root-node runtime)))))
(calls 0))
(should (= 3 (cl-struct-slot-offset 'etaf-runtime 'reserved-root-node)))
(should (= 4 (cl-struct-slot-offset 'etaf-runtime 'scope)))
(should-not (get 'etaf-runtime-root-node 'compiler-macro))
(should-not (get 'etaf-runtime-root-node 'side-effect-free))
(cl-letf (((symbol-function 'etaf-runtime-snapshot)
(lambda (target)
(should (eq target runtime))
(cl-incf calls)
snapshot)))
(should (eq (car (ebox-canonical-input-roots (plist-get snapshot :input)))
(funcall getter runtime)))
(should (= 1 calls)))))
(ert-deftest etaf-render-port-requires-v2-provider ()
"Complete provider absence fails closed instead of selecting a legacy port."
(let ((original-featurep (symbol-function 'featurep)))
(cl-letf (((symbol-function 'featurep)
(lambda (feature)
(and (not (eq feature 'ebox-framework-spi-v2))
(funcall original-featurep feature))))
((symbol-function 'ebox-framework-spi-capabilities) nil))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))))
(ert-deftest etaf-render-port-accepts-each-v2-capable-tp-manifest ()
"Both transitional dual-capability and final v2-only providers are valid."
(let ((provider (ebox-framework-spi-capabilities)))
(dolist (protocol '(tp-transaction-protocol-v1+v2
tp-transaction-protocol-v2))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-tp-protocol)
(lambda (_provider) protocol)))
(should (eq (etaf-render-port-tp-protocol
(etaf-render-port--bootstrap))
protocol))))))
(ert-deftest etaf-render-port-rejects-half-present-v2 ()
"Feature-only and predicate-only providers fail instead of downgrading."
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities) nil))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(let ((original-featurep (symbol-function 'featurep)))
(cl-letf (((symbol-function 'featurep)
(lambda (feature)
(and (not (eq feature 'ebox-framework-spi-v2))
(funcall original-featurep feature)))))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))))
(ert-deftest etaf-render-port-rejects-broken-v2-provider ()
"Throwing, non-record, and malformed providers fail closed."
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () (error "injected provider failure"))))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () 'not-a-provider)))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))
(let ((provider (ebox-framework-spi-capabilities)))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-capabilities)
(lambda (_provider) "not-a-capability-list")))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-bootstrap-error))))
(ert-deftest etaf-render-port-rejects-incompatible-v2-provider ()
"Version, required-capability, and TP protocol mismatches are incompatible."
(let ((provider (ebox-framework-spi-capabilities)))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-spi-version)
(lambda (_provider) 99)))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-capabilities)
(lambda (_provider)
'(initial-paired-stage-rollback
update-paired-stage-rollback
same-object-legacy-report))))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))
(cl-letf
(((symbol-function 'ebox-framework-spi-capabilities)
(lambda () provider))
((symbol-function 'ebox-framework-spi-provider-tp-protocol)
(lambda (_provider) 'tp-transaction-protocol-v0)))
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))))
(ert-deftest etaf-render-port-v2-initial-delegates-paired-rollback ()
"The selected SPI operation owns stage failure and paired rollback."
(let ((buffer (generate-new-buffer " *etaf-v2-paired-rollback*")) trace)
(unwind-protect
(cl-letf (((symbol-function 'ebox-framework-spi-initial)
(lambda (_buffer _input stage rollback)
(push 'render trace)
(condition-case condition
(funcall stage nil)
(error
(funcall rollback nil)
(signal (car condition) (cdr condition)))))))
(should-error
(etaf-render-port-initial
buffer 'input
(lambda (_report)
(push 'stage trace)
(error "injected v2 initial failure"))
(lambda (_report) (push 'rollback trace))))
(should (equal (nreverse trace) '(render stage rollback))))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v2-initial-restores-real-ebox-surface ()
"A failed SPI stage removes Ebox authority and restores buffer content."
(let ((buffer (generate-new-buffer " *etaf-v2-real-cleanup*"))
(input (ebox-build '(box "committed")))
(rollback-count 0)
captured)
(unwind-protect
(progn
(with-current-buffer buffer (insert "sentinel"))
(condition-case condition
(etaf-render-port-initial
buffer input
(lambda (_report)
(error "injected real v2 stage failure"))
(lambda (_report) (cl-incf rollback-count)))
(error (setq captured condition)))
(should (equal captured '(error "injected real v2 stage failure")))
(should (= rollback-count 1))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(should (equal "sentinel"
(with-current-buffer buffer (buffer-string)))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v2-failure-restores-exact-editor-custody ()
"SPI stage rollback preserves Emacs-owned editor identities and undo."
(let ((buffer (generate-new-buffer " *etaf-v2-editor-custody*"))
(input (ebox-build '(box "committed")))
overlay left-marker right-marker snapshot captured)
(unwind-protect
(progn
(with-current-buffer buffer
(buffer-enable-undo)
(insert (propertize "sentinel" 'face 'bold))
(undo-boundary)
(goto-char 4)
(set-mark 2)
(setq mark-active t)
(setq overlay (make-overlay 2 6 buffer t t)
left-marker (copy-marker 3 nil)
right-marker (copy-marker 5 t))
(overlay-put overlay 'etaf-test-property '(owned value))
(narrow-to-region 2 7)
(set-buffer-modified-p nil)
(setq snapshot
(list
:contents
(save-restriction
(widen)
(buffer-substring (point-min) (point-max)))
:point (point)
:mark-marker (mark-marker)
:mark-position (mark t)
:mark-insertion-type
(marker-insertion-type (mark-marker))
:mark-active mark-active
:narrow-start (point-min)
:narrow-end (point-max)
:overlay-start (overlay-start overlay)
:overlay-end (overlay-end overlay)
:overlay-properties (overlay-properties overlay)
:left-position (marker-position left-marker)
:left-insertion-type (marker-insertion-type left-marker)
:right-position (marker-position right-marker)
:right-insertion-type (marker-insertion-type right-marker)
:undo-list (copy-tree buffer-undo-list)
:modified-p (buffer-modified-p))))
(condition-case condition
(etaf-render-port-initial
buffer input
(lambda (_report) (error "editor custody primary"))
#'ignore)
(error (setq captured condition)))
(should (equal captured '(error "editor custody primary")))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(with-current-buffer buffer
(should
(equal (save-restriction
(widen)
(buffer-substring (point-min) (point-max)))
(plist-get snapshot :contents)))
(should (= (point) (plist-get snapshot :point)))
(should (eq (mark-marker) (plist-get snapshot :mark-marker)))
(should (= (mark t) (plist-get snapshot :mark-position)))
(should
(eq (marker-insertion-type (mark-marker))
(plist-get snapshot :mark-insertion-type)))
(should (eq mark-active (plist-get snapshot :mark-active)))
(should (= (point-min) (plist-get snapshot :narrow-start)))
(should (= (point-max) (plist-get snapshot :narrow-end)))
(should (overlayp overlay))
(should (eq (overlay-buffer overlay) buffer))
(should (= (overlay-start overlay)
(plist-get snapshot :overlay-start)))
(should (= (overlay-end overlay)
(plist-get snapshot :overlay-end)))
(should (equal (overlay-properties overlay)
(plist-get snapshot :overlay-properties)))
(should (eq (marker-buffer left-marker) buffer))
(should (= (marker-position left-marker)
(plist-get snapshot :left-position)))
(should
(eq (marker-insertion-type left-marker)
(plist-get snapshot :left-insertion-type)))
(should (eq (marker-buffer right-marker) buffer))
(should (= (marker-position right-marker)
(plist-get snapshot :right-position)))
(should
(eq (marker-insertion-type right-marker)
(plist-get snapshot :right-insertion-type)))
(should (equal buffer-undo-list (plist-get snapshot :undo-list)))
(should (eq (buffer-modified-p)
(plist-get snapshot :modified-p)))))
(when (overlayp overlay) (delete-overlay overlay))
(when (markerp left-marker) (set-marker left-marker nil))
(when (markerp right-marker) (set-marker right-marker nil))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v2-nonlocal-exit-runs-exact-cleanup ()
"A SPI stage throw cannot escape with mounted or editor state retained."
(let ((buffer (generate-new-buffer " *etaf-v2-nonlocal-cleanup*"))
(input (ebox-build '(box "committed")))
(rollback-count 0))
(unwind-protect
(progn
(with-current-buffer buffer (insert "before"))
(should
(eq
(catch 'etaf-v2-test-escape
(etaf-render-port-initial
buffer input
(lambda (_report)
(throw 'etaf-v2-test-escape 'escaped))
(lambda (_report) (cl-incf rollback-count)))
'not-escaped)
'escaped))
(should (= rollback-count 1))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string)))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v2-precondition-keeps-existing-mount ()
"Rejecting an already mounted target must not clean up foreign authority."
(let ((buffer (generate-new-buffer " *etaf-v1-existing-mount*")))
(unwind-protect
(progn
(ebox-render-to-buffer buffer (ebox-build '(box "existing")))
(let ((revision (ebox-surface-buffer-revision buffer)))
(should-error
(etaf-render-port-initial
buffer (ebox-build '(box "replacement")) #'ignore #'ignore)
:type 'error)
(should (ebox-surface-buffer-mounted-p buffer))
(should (= revision (ebox-surface-buffer-revision buffer)))
(should (equal "existing"
(with-current-buffer buffer (buffer-string))))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v2-rollback-throw-cannot-stop-cleanup-tail ()
"A framework rollback throw propagates only after SPI cleanup completes."
(let ((buffer (generate-new-buffer " *etaf-v2-rollback-throw*"))
(input (ebox-build '(box "committed"))))
(unwind-protect
(progn
(with-current-buffer buffer (insert "before"))
(should
(eq
(catch 'etaf-v2-rollback-escape
(etaf-render-port-initial
buffer input
(lambda (_report) (error "primary before rollback throw"))
(lambda (_report)
(throw 'etaf-v2-rollback-escape 'rollback-escaped)))
'not-escaped)
'rollback-escaped))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string)))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v2-cleanup-fault-keeps-primary-and-continues ()
"A secondary rollback fault is contained while Ebox cleanup continues."
(let ((buffer (generate-new-buffer " *etaf-v2-cleanup-fault*"))
(input (ebox-build '(box "committed")))
captured)
(unwind-protect
(progn
(with-current-buffer buffer (insert "before"))
(condition-case condition
(etaf-render-port-initial
buffer input
(lambda (_report) (error "primary stage failure"))
(lambda (_report) (error "secondary rollback failure")))
(error (setq captured condition)))
(should (equal captured '(error "primary stage failure")))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string)))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-revision-fails-closed-for-mounted-surface ()
"Revision is zero only without a mount; mounted lookup errors stay visible."
(let ((buffer (generate-new-buffer " *etaf-revision-contract*")))
(unwind-protect
(progn
(should (zerop (etaf-render-port-revision buffer)))
(ebox-render-to-buffer buffer (ebox-build '(box "mounted")))
(should (> (etaf-render-port-revision buffer) 0))
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
(lambda (_buffer) (error "injected report failure"))))
(should-error (etaf-render-port-revision buffer) :type 'error))
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
(lambda (_buffer) 0)))
(should-error (etaf-render-port-revision buffer) :type 'error))
(etaf-render-port-unmount buffer)
(should (buffer-live-p buffer))
(should-not (etaf-render-port-mounted-p buffer))
(should (zerop (etaf-render-port-revision buffer))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v2-preserves-provider-report-identity ()
"Initial and update return the exact report seen by framework staging."
(let ((buffer (generate-new-buffer " *etaf-v2-report-identity*"))
initial-stage-report update-stage-report)
(unwind-protect
(let ((initial-report
(etaf-render-port-initial
buffer (ebox-build '(box "one"))
(lambda (report) (setq initial-stage-report report))
#'ignore)))
(should (eq initial-report initial-stage-report))
(let ((update-report
(etaf-render-port-update
buffer (ebox-build '(box "two"))
(lambda (report) (setq update-stage-report report))
#'ignore)))
(should (eq update-report update-stage-report))
(should (= (etaf-render-port-revision buffer)
(plist-get update-report :surface-revision)))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-is-the-only-protocol-probe-owner ()
"No downstream ETAF module probes Ebox framework SPI protocol state."
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
(unless (string= (file-name-nondirectory file) "etaf-render-port.el")
(with-temp-buffer
(insert-file-contents file)
(let ((source (buffer-string)))
(should-not (string-match-p "ebox-framework-spi" source))
(should-not (string-match-p "ebox-framework-spi-v2" source)))))))
(ert-deftest etaf-render-port-owns-runtime-update-routing ()
"Runtime updates use the selected port instead of calling Ebox directly."
(with-temp-buffer
(insert-file-contents
(expand-file-name "etaf-runtime.el" etaf-render-port-test--root))
(let ((source (buffer-string)))
(should (string-match-p "(etaf-render-port-update" source))
(should-not (string-match-p "(ebox-commit" source)))))
(ert-deftest etaf-render-port-owns-all-live-publication-routing ()
"No ETAF module except the selected-port owner publishes directly to Ebox."
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
(unless (string= (file-name-nondirectory file) "etaf-render-port.el")
(with-temp-buffer
(insert-file-contents file)
(let ((source (buffer-string)))
(dolist (call '("(ebox-render-to-buffer"
"(ebox-commit"
"(ebox-surface-"))
(should-not (string-match-p (regexp-quote call) source))))))))
(ert-deftest etaf-render-port-production-has-no-v1-render-route ()
"Production ETAF contains no retired render-port policy or v1 helper."
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
(with-temp-buffer
(insert-file-contents file)
(let ((source (buffer-string)))
(should-not (string-match-p "etaf-render-port-selection-policy" source))
(should-not (string-match-p "etaf-render-port--v1" source))))))
(ert-deftest etaf-render-port-routes-standalone-renderer-mount ()
"The no-Runtime compatibility mount uses the immutable selected port."
(require 'etaf-renderer)
(let ((buffer (generate-new-buffer " *etaf-standalone-port-mount*"))
seen-input seen-viewport)
(unwind-protect
(cl-letf (((symbol-function 'etaf-runtime-mount) nil)
((symbol-function 'etaf-render-port-initial)
(lambda (target input framework-stage framework-rollback
&optional _observer)
(setq seen-input input
seen-viewport
(list ebox-viewport-width ebox-viewport-height))
(funcall framework-stage nil)
(ignore framework-rollback)
(list :status 'success :buffer target))))
(should
(eq (etaf-mount
buffer (etaf-view (text "standalone"))
'(:viewport-width 91 :viewport-height 17))
buffer))
(should (ebox-canonical-input-p seen-input))
(should (equal seen-viewport '(91 17))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-standalone-render-failure-creates-no-buffer ()
"Pure lowering must fail before standalone mount allocates its target buffer."
(require 'etaf-renderer)
(let ((name " *etaf-standalone-render-failure*"))
(when-let* ((buffer (get-buffer name))) (kill-buffer buffer))
(cl-letf (((symbol-function 'etaf-runtime-mount) nil))
(should-error (etaf-mount name 'invalid-etaf-view)
:type 'etaf-renderer-error))
(should-not (get-buffer name))))
(ert-deftest etaf-render-port-selected-port-is-process-stable ()
"Every downstream read returns the one bootstrap-selected port identity."
(let ((selected (etaf-render-port-selected)))
(should (eq selected (etaf-render-port-selected)))
(should (eq (etaf-render-port-route selected) 'v2))))
(provide 'etaf-render-port-tests)
;;; etaf-render-port-tests.el ends here

View File

@ -0,0 +1,293 @@
;;; etaf-render-view-tests.el --- Ordinary Elisp View frontend -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; The render frontend shares View compilation and retained runtime semantics.
;;; Code:
(require 'ert)
(require 'bytecomp)
(require 'etaf)
(defvar etaf-rv--renders 0)
(defvar etaf-rv--left-reads 0)
(defvar etaf-rv--right-reads 0)
(defvar etaf-rv--events nil)
(defun etaf-rv--define (name arguments &rest clauses)
"Define test Component NAME with ARGUMENTS and CLAUSES lexically."
(etaf-component-redefine-run
(lambda ()
(eval `(etaf-define-component ,name ,arguments ,@clauses) t))))
(defmacro etaf-rv--with-buffer (&rest body)
"Run BODY in a temporary buffer and always dispose its Runtime."
(declare (indent 0) (debug t))
`(with-temp-buffer
(unwind-protect
(progn ,@body)
(when-let* ((runtime (etaf-runtime-for-buffer (current-buffer))))
(etaf-unmount runtime)))))
(ert-deftest etaf-render-view-equivalent-to-view-and-node ()
"All frontends produce the same visible structure and Host properties."
(etaf-rv--define 'etaf-rv-view '(&key label)
:view '(column :padding-inline 1
(text :font-weight 'bold (expr label))
(text "Body")))
(etaf-rv--define 'etaf-rv-render '(&key label)
:render '(let ((caption label))
(etaf-view
(column :padding-inline 1
(text :font-weight 'bold (expr caption))
(text "Body")))))
(etaf-rv--define 'etaf-rv-node '(&key label)
:render '(etaf-node
'column '(:padding-inline 1)
(list (etaf-node 'text '(:font-weight bold)
(list label))
(etaf-node 'text nil '("Body")))))
(let ((outputs
(mapcar
(lambda (name)
(etaf-rv--with-buffer
(etaf-mount (current-buffer)
(etaf-node name '(:label "Title") nil))
(list (buffer-substring-no-properties (point-min) (point-max))
(progn
(goto-char (point-min))
(search-forward "Title")
(get-text-property (match-beginning 0) 'face)))))
'(etaf-rv-view etaf-rv-render etaf-rv-node))))
(should (equal (car outputs) (cadr outputs)))
(should (equal (car outputs) (caddr outputs)))))
(ert-deftest etaf-render-view-prop-loop-conflicts-match-view ()
"Nested Views use Component prop validation during definition expansion."
(dolist (body '((etaf-view
(column (text :for (item '("A")) :key item (expr item))))
(let ((prefix "item"))
(etaf-view
(column (text :for (item '("A")) :key item
(expr (concat prefix item))))))
(funcall
(lambda ()
(etaf-view
(column (text :for (item '("A")) :key item
(expr item))))))))
(let ((failure
(should-error
(macroexpand
`(etaf-define-component etaf-rv-conflict (&key item)
:render ,body))
:type 'etaf-view-syntax-error)))
(should (string-match-p "conflicts with a Component prop"
(error-message-string failure)))))
(should-error
(macroexpand
'(etaf-define-component etaf-rv-conflict (&key item)
:view (column (text :for (item '("A")) :key item (expr item)))))
:type 'etaf-view-syntax-error))
(ert-deftest etaf-render-view-preserves-ordinary-lexical-shadowing ()
"Let and lambda bindings shadow prop shorthand using normal Elisp scope."
(etaf-rv--define
'etaf-rv-shadow '(&key label)
:render
'(let* ((original label)
(label "local")
(caption (funcall (lambda (label) (concat original "/" label))
label)))
(etaf-view
(box :ref 'etaf-rv-shadow-button
:on-press (lambda () (push caption etaf-rv--events))
(text (expr caption))))))
(let ((etaf-rv--events nil))
(etaf-rv--with-buffer
(etaf-mount (current-buffer)
(etaf-node 'etaf-rv-shadow '(:label "prop") nil))
(should (equal "prop/local" (buffer-string)))
(etaf-dispatch-event (etaf-runtime-for-buffer (current-buffer))
'etaf-rv-shadow-button 'press)
(should (equal '("prop/local") etaf-rv--events)))))
(ert-deftest etaf-render-view-retains-surrounding-macro-environment ()
"A lexically scoped macro cannot hide a View from prop grammar checks."
(should-error
(macroexpand-all
'(cl-macrolet
((local-view ()
'(etaf-view
(column (text :for (item '("A")) :key item (expr item))))))
(etaf-define-component etaf-rv-macro-conflict (&key item)
:render (local-view))))
:type 'etaf-view-syntax-error))
(ert-deftest etaf-render-view-props-shadow-surrounding-symbol-macros ()
"A Component's prop scope overrides same-named outer symbol macros."
(etaf-component-redefine-run
(lambda ()
(eval
'(cl-symbol-macrolet ((label "Outer"))
(etaf-define-component etaf-rv-outer-shadow (&key label)
:render (etaf-view (text (expr label)))))
t)))
(etaf-rv--with-buffer
(etaf-mount (current-buffer)
(etaf-node 'etaf-rv-outer-shadow '(:label "Prop") nil))
(should (equal "Prop" (buffer-string)))))
(ert-deftest etaf-render-view-byte-compiled-callback-retains-lexical-props ()
"Compiled Component definitions preserve the same delayed callback scope."
(let ((byte-compile-error-on-warn t)
(etaf-rv--events nil))
(etaf-component-redefine-run
(lambda ()
(funcall
(byte-compile
'(lambda ()
(etaf-define-component etaf-rv-compiled (&key label)
:render
(let ((caption label))
(etaf-view
(box :ref 'etaf-rv-compiled-button
:on-press (lambda () (push caption etaf-rv--events))
(text (expr caption)))))))))))
(etaf-rv--with-buffer
(etaf-mount (current-buffer)
(etaf-node 'etaf-rv-compiled '(:label "Compiled") nil))
(should (equal "Compiled" (buffer-string)))
(etaf-dispatch-event (etaf-runtime-for-buffer (current-buffer))
'etaf-rv-compiled-button 'press)
(should (equal '("Compiled") etaf-rv--events)))))
(ert-deftest etaf-render-view-keeps-deferred-dependencies-local ()
"Capturing stable handles does not pull reactive reads into Component render."
(etaf-rv--define
'etaf-rv-deferred '(&key left right)
:setup '(list left right)
:render
'(progn
(cl-incf etaf-rv--renders)
(let* ((state (etaf-state))
(left-ref (car state))
(right-ref (cadr state)))
(etaf-view
(column
(text (expr (progn (cl-incf etaf-rv--left-reads)
(etaf-value left-ref))))
(text (expr (progn (cl-incf etaf-rv--right-reads)
(etaf-value right-ref)))))))))
(let ((left (etaf-ref "Left A"))
(right (etaf-ref "Right A"))
(etaf-rv--renders 0)
(etaf-rv--left-reads 0)
(etaf-rv--right-reads 0))
(etaf-rv--with-buffer
(etaf-mount (current-buffer)
(etaf-node 'etaf-rv-deferred (list :left left :right right)
nil))
(let ((renders etaf-rv--renders)
(left-reads etaf-rv--left-reads)
(right-reads etaf-rv--right-reads))
(setf (etaf-value left) "Left B")
(should (string-match-p "Left B" (buffer-string)))
(should (= renders etaf-rv--renders))
(should (> etaf-rv--left-reads left-reads))
(should (= right-reads etaf-rv--right-reads))))))
(ert-deftest etaf-render-view-projects-caller-owned-slots ()
"Embedded Views distinguish projections from named inputs and caller props."
(etaf-rv--define
'etaf-rv-panel '(&key label)
:render '(let ((heading label))
(etaf-view
(column
(text (expr heading))
(slot)
(slot :name 'footer (text "Fallback"))))))
(etaf-rv--define
'etaf-rv-slot-owner '(&key label)
:render '(let ((caption label))
(etaf-view
(etaf-rv-panel :label "Panel"
(text (expr label))
(slot :name 'footer (text (expr (concat caption " footer"))))))))
(etaf-rv--with-buffer
(etaf-mount (current-buffer)
(etaf-node 'etaf-rv-slot-owner '(:label "Caller") nil))
(should (string-match-p "Panel[[:space:]]+Caller[[:space:]]+Caller footer"
(buffer-string)))
(should-not (string-match-p "Fallback" (buffer-string))))
(etaf-rv--with-buffer
(etaf-mount (current-buffer)
(etaf-node 'etaf-rv-panel '(:label "Panel") nil))
(should (string-match-p "Fallback" (buffer-string)))))
(ert-deftest etaf-render-view-callback-captures-committed-prop-snapshot ()
"A normal lexical callback uses new committed props and survives rollback."
(etaf-rv--define
'etaf-rv-snapshot '(&key label)
:render '(let ((caption label))
(etaf-view
(box :ref 'etaf-rv-snapshot-button
:on-press (lambda () (push caption etaf-rv--events))
(text (expr caption))))))
(let ((label (etaf-ref "A"))
(etaf-rv--events nil))
(etaf-rv--with-buffer
(etaf-mount
(current-buffer)
(lambda ()
(etaf-node
'column nil
(list (etaf-node 'etaf-rv-snapshot
(list :label (etaf-value label)) nil)
(etaf-view
(text (expr (if (equal (etaf-value label) "Failed")
(error "Rejected sibling")
"Sibling"))))))))
(let ((runtime (etaf-runtime-for-buffer (current-buffer))))
(etaf-dispatch-event runtime 'etaf-rv-snapshot-button 'press)
(setf (etaf-value label) "B")
(etaf-dispatch-event runtime 'etaf-rv-snapshot-button 'press)
(let ((published (buffer-string)))
(should-error (setf (etaf-value label) "Failed"))
(should (equal-including-properties published (buffer-string))))
(etaf-dispatch-event runtime 'etaf-rv-snapshot-button 'press)
(should (equal '("B" "B" "A") etaf-rv--events))))))
(ert-deftest etaf-render-view-callback-live-ref-is-not-a-ui-snapshot ()
"An explicit shared ref remains live even when a sibling rejects its UI."
(etaf-rv--define
'etaf-rv-live '(&key model)
:render '(let ((shared model))
(etaf-view
(box :ref 'etaf-rv-live-button
:on-press (lambda ()
(push (etaf-value shared) etaf-rv--events))
(text "Read live")))))
(let ((model (etaf-ref "A"))
(etaf-rv--events nil))
(etaf-rv--with-buffer
(etaf-mount
(current-buffer)
(etaf-node
'column nil
(list (etaf-node 'etaf-rv-live (list :model model) nil)
(etaf-view
(text (expr (if (equal (etaf-value model) "B")
(error "Rejected live value")
"Sibling")))))))
(let ((runtime (etaf-runtime-for-buffer (current-buffer)))
(published (buffer-string)))
(should-error (setf (etaf-value model) "B"))
(should (equal-including-properties published (buffer-string)))
(etaf-dispatch-event runtime 'etaf-rv-live-button 'press)
(should (equal '("B") etaf-rv--events))))))
(provide 'etaf-render-view-tests)
;;; etaf-render-view-tests.el ends here

View File

@ -0,0 +1,337 @@
;;; etaf-resize-benchmark-tests.el --- Resize driver contracts -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'benchmark-ebox-resize)
(defmacro etaf-resize-test--with-run (&rest body)
"Evaluate BODY with isolated evidence and deterministic frame/publication IO."
(declare (indent 0) (debug t))
`(let* ((directory (make-temp-file "etaf-resize-test-" t))
(output (expand-file-name "result.eldata" directory))
(buffer (generate-new-buffer " *resize-test*"))
(ebox-resize-benchmark--run nil)
(ebox-resize-benchmark--last-result nil)
(ebox--deferred-render-gc-state nil)
(width 600))
(unwind-protect
(cl-letf (((symbol-function 'ebox-resize-benchmark--guard) #'ignore)
((symbol-function 'ebox-resize-benchmark--code) (lambda (_) nil))
((symbol-function 'ebox-native-reflow-runtime-report) #'ignore)
((symbol-function 'ebox-resize-benchmark--payload)
(lambda (_buffer) (list :nodes 3 :characters 4 :viewport (list width 24))))
((symbol-function 'frame-pixel-width) (lambda (&optional _) width))
((symbol-function 'frame-text-width) (lambda (&optional _) width))
((symbol-function 'frame-text-height) (lambda (&optional _) 400))
((symbol-function 'ebox-viewport-window-width) (lambda (_) width))
((symbol-function 'window-body-height) (lambda (&rest _) 24))
((symbol-function 'redisplay) #'ignore)
((symbol-function 'set-frame-size)
(lambda (_frame new-width _height &optional _) (setq width new-width))))
,@body)
(when ebox-resize-benchmark--run
(ebox-resize-benchmark-cancel))
(when (buffer-live-p buffer) (kill-buffer buffer))
(delete-directory directory t))))
(defun etaf-resize-test--tick ()
"Consume the owned driver timer and execute one request synchronously."
(cancel-timer (plist-get ebox-resize-benchmark--run :timer))
(ebox-resize-benchmark--next))
(ert-deftest etaf-resize-widths-cover-both-endpoints-and-return ()
"Non-divisible ranges retain their widest point on every sweep."
(should (equal (ebox-resize-benchmark--widths 400 505 40 2 600)
'(400 440 480 505 480 440 400 440 480 505 480 440 400 600)))
(should (equal (ebox-resize-benchmark--widths 400 500 100 1 400)
'(500 400)))
(dolist (args '((0 500 1 1 400) (500 400 1 1 400)
(400 500 0 1 400) (400 500 1 0 400)))
(should-error (apply #'ebox-resize-benchmark--widths args))))
(ert-deftest etaf-resize-completion-keeps-every-publication-and-restores-width ()
"Only successful publication advances the driver; all samples are retained."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :step 200 :rounds 1 :delay 10 :timeout 20 :output output)
(let ((planned (plist-get ebox-resize-benchmark--run :planned-count)))
(dotimes (_ planned)
(etaf-resize-test--tick)
(should-not (plist-get ebox-resize-benchmark--run :timer))
(should (timerp (plist-get ebox-resize-benchmark--run :watchdog)))
(should (eq :published
(ebox-resize-benchmark--publication (lambda (&rest _) :published)
buffer width 24)))
(should (timerp (plist-get ebox-resize-benchmark--run :timer)))
(should-not (plist-get ebox-resize-benchmark--run :watchdog)))
(etaf-resize-test--tick)
(should-not ebox-resize-benchmark--run)
(should (= width 600))
(should (plist-get ebox-resize-benchmark--last-result :valid))
(should (= planned (plist-get ebox-resize-benchmark--last-result :completed-count)))
(should (file-exists-p output))
(should-not (advice-member-p #'ebox-resize-benchmark--publication
'ebox-rerender-buffer-with-context)))))
(ert-deftest etaf-resize-publication-error-and-quit-preserve-cause-and-cleanup ()
"Original errors and C-g cannot leave advice or timers attached."
(dolist (failure '((error "original publication failure") (quit "publication interrupted")))
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(let ((watchdog (plist-get ebox-resize-benchmark--run :watchdog)) caught)
(condition-case condition
(ebox-resize-benchmark--publication
(lambda (&rest _) (signal (car failure) (cdr failure))) buffer width 24)
((error quit) (setq caught condition)))
(should (equal caught failure))
(should-not ebox-resize-benchmark--run)
(should-not (memq watchdog timer-list))
(should-not (advice-member-p #'ebox-resize-benchmark--publication
'ebox-rerender-buffer-with-context))
(should (= 0 (plist-get ebox-resize-benchmark--last-result :completed-count)))
(should-not (plist-get ebox-resize-benchmark--last-result :valid))))))
(ert-deftest etaf-resize-timeout-is-incomplete-and-releases-owned-resources ()
"No publication must produce failed evidence, never a successful sample."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(let ((watchdog (plist-get ebox-resize-benchmark--run :watchdog)))
(ebox-resize-benchmark--timeout)
(should-not ebox-resize-benchmark--run)
(should-not (memq watchdog timer-list))
(should (eq 'failed (plist-get ebox-resize-benchmark--last-result :status)))
(should (= 1 (plist-get ebox-resize-benchmark--last-result :requested-count)))
(should (= 0 (plist-get ebox-resize-benchmark--last-result :completed-count))))))
(ert-deftest etaf-resize-report-failure-preserves-publication-failure ()
"A secondary write failure is visible while the original error survives."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(let (warning)
(cl-letf (((symbol-function 'ebox-resize-benchmark--write)
(lambda (&rest _) (error "disk failure")))
((symbol-function 'message)
(lambda (format-string &rest args)
(setq warning (apply #'format format-string args)))))
(should (equal '(error "original")
(should-error (ebox-resize-benchmark--abort '(error "original"))))))
(should (string-match-p "disk failure" warning))
(should (plist-get ebox-resize-benchmark--last-result :evidence-write-error))
(should-not ebox-resize-benchmark--run))))
(ert-deftest etaf-resize-partial-installation-releases-earlier-phase-advice ()
"Instrumentation setup failure cleans previously installed advice."
(etaf-resize-test--with-run
(let ((original-add (symbol-function 'advice-add)) (calls 0))
(cl-letf (((symbol-function 'advice-add)
(lambda (&rest args)
(if (= 2 (cl-incf calls)) (error "injected install failure")
(apply original-add args)))))
(should-error
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20
:phases '(ebox-viewport-window-width ebox-surface-buffer-revision)
:output output)))
(should-not ebox-resize-benchmark--run)
(let (remaining)
(advice-mapc (lambda (_fn _props) (setq remaining t)) 'ebox-viewport-window-width)
(should-not remaining)))))
(ert-deftest etaf-resize-mismatched-viewport-cannot-count-as-publication ()
"A call returning normally is insufficient when published geometry differs."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(should (eq :real-result
(ebox-resize-benchmark--publication (lambda (&rest _) :real-result)
buffer (1+ width) 24)))
(should-not (plist-get ebox-resize-benchmark--last-result :valid))
(should (= 0 (plist-get ebox-resize-benchmark--last-result :completed-count)))))
(ert-deftest etaf-resize-writer-refuses-existing-evidence ()
"A later invocation must not silently overwrite a previous report."
(etaf-resize-test--with-run
(ebox-resize-benchmark--write output '(:original t))
(should-error (ebox-resize-benchmark--write output '(:replacement t)))
(with-temp-buffer
(insert-file-contents output)
(should (equal '(:original t) (read (current-buffer)))))))
(ert-deftest etaf-resize-nested-publication-counts-only-the-outer-call ()
"Nested public calls belong to the same measured viewport request."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(should
(eq :outer
(ebox-resize-benchmark--publication
(lambda (&rest _)
(ebox-resize-benchmark--publication #'ignore buffer width 24)
:outer)
buffer width 24)))
(should (= 1 (length (plist-get ebox-resize-benchmark--run :samples))))
(should (timerp (plist-get ebox-resize-benchmark--run :timer)))))
(ert-deftest etaf-resize-successful-coverage-without-written-evidence-fails ()
"Successful calls cannot yield a passed tool result if evidence was lost."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :step 400 :rounds 1
:delay 10 :timeout 20 :output output)
(dotimes (_ (plist-get ebox-resize-benchmark--run :planned-count))
(etaf-resize-test--tick)
(ebox-resize-benchmark--publication #'ignore buffer width 24))
(cl-letf (((symbol-function 'ebox-resize-benchmark--write)
(lambda (&rest _) (error "disk failure")))
((symbol-function 'message) #'ignore))
(should-error (etaf-resize-test--tick)))
(should-not ebox-resize-benchmark--run)
(should (eq 'failed (plist-get ebox-resize-benchmark--last-result :status)))
(should-not (plist-get ebox-resize-benchmark--last-result :valid))
(should-not (plist-get ebox-resize-benchmark--last-result :within-limit))
(should (plist-get ebox-resize-benchmark--last-result :evidence-write-error))))
(ert-deftest etaf-resize-unattributed-call-still-executes-product-once ()
"Diagnostic attribution failure must not prevent real application work."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(ebox-resize-benchmark--publication #'ignore buffer width 24)
(let ((calls 0))
(should (eq :real-result
(ebox-resize-benchmark--publication
(lambda (&rest _) (cl-incf calls) :real-result) buffer width 24)))
(should (= calls 1))
(should-not ebox-resize-benchmark--run)
(should-not (plist-get ebox-resize-benchmark--last-result :valid)))))
(ert-deftest etaf-resize-cancel-from-product-callback-cannot-rearm-run ()
"Cancellation inside a publication prevents its old callback from rearming."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(should (eq :real-result
(ebox-resize-benchmark--publication
(lambda (&rest _) (ebox-resize-benchmark-cancel) :real-result)
buffer width 24)))
(should-not ebox-resize-benchmark--run)
(should (eq 'cancelled (plist-get ebox-resize-benchmark--last-result :status)))))
(ert-deftest etaf-resize-old-publication-cannot-reschedule-replacement-run ()
"A callback may replace the benchmark; old completion cannot own its timer."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(let (new-run new-timer)
(ebox-resize-benchmark--publication
(lambda (&rest _)
(ebox-resize-benchmark-cancel)
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20
:output (expand-file-name "new.eldata" directory))
(setq new-run ebox-resize-benchmark--run
new-timer (plist-get new-run :timer)))
buffer width 24)
(should (eq new-run ebox-resize-benchmark--run))
(should (eq new-timer (plist-get new-run :timer)))
(should-not (plist-get new-run :samples)))))
(ert-deftest etaf-resize-publication-boundary-detects-transient-focus-loss ()
"Losing focus before publication invalidates it even if the call restores it."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(let (focused)
(cl-letf (((symbol-function 'ebox-resize-benchmark--guard)
(lambda () (unless focused (error "lost focus")))))
(should (eq :real-result
(ebox-resize-benchmark--publication
(lambda (&rest _) (setq focused t) :real-result) buffer width 24))))
(should-not ebox-resize-benchmark--run)
(should-not (plist-get ebox-resize-benchmark--last-result :valid)))))
(ert-deftest etaf-resize-blocking-publication-cannot-hide-expired-deadline ()
"Completion must check the deadline even if the event loop could not poll it."
(etaf-resize-test--with-run
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(setf (plist-get (plist-get ebox-resize-benchmark--run :current) :requested-at)
(- (float-time) 30))
(should (eq :real-result
(ebox-resize-benchmark--publication (lambda (&rest _) :real-result)
buffer width 24)))
(should-not ebox-resize-benchmark--run)
(should-not (plist-get ebox-resize-benchmark--last-result :valid))
(should (> (plist-get (car (plist-get ebox-resize-benchmark--last-result :samples))
:request-to-published-ms) 20000))))
(ert-deftest etaf-resize-code-evidence-includes-every-reload-and-the-driver ()
"Explicitly loaded modules need evidence even without a sentinel function."
(let* ((directory (make-temp-file "etaf-resize-code-" t))
(source (expand-file-name "etaf-resize-evidence-fixture.el" directory))
(compiled (concat source "c"))
(features (copy-sequence features)))
(unwind-protect
(progn
(with-temp-file source
(insert ";;; -*- lexical-binding: t; -*-\n"
"(provide 'etaf-resize-evidence-fixture)\n"))
(should (byte-compile-file source))
(let* ((code (ebox-resize-benchmark--code (list compiled)))
(reload (car (plist-get code :reload-files)))
(driver (cl-find 'ebox-resize-benchmark-start (plist-get code :functions)
:key (lambda (entry) (plist-get entry :function)))))
(should (featurep 'etaf-resize-evidence-fixture))
(should (equal (plist-get reload :file) (file-truename compiled)))
(should (plist-get reload :loaded))
(should (equal (plist-get reload :sha256)
(ebox-resize-benchmark--hash-file compiled)))
(should (equal (plist-get reload :source-sha256)
(ebox-resize-benchmark--hash-file source)))
(should (plist-get driver :origin-sha256))))
(delete-directory directory t))))
(ert-deftest etaf-resize-start-waits-for-existing-gc-lease-without-measuring-it ()
"A preceding render must settle before recording the benchmark baseline."
(etaf-resize-test--with-run
(let ((ebox--deferred-render-gc-state '(:busy t))
(gc-cons-threshold (* 128 1024 1024))
(gc-cons-percentage .1))
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(etaf-resize-test--tick)
(should-not (plist-get ebox-resize-benchmark--run :samples))
(should (= width 600))
(should (eq :prior-render
(ebox-resize-benchmark--publication
(lambda (&rest _) :prior-render) buffer width 24)))
(setq ebox--deferred-render-gc-state nil gc-cons-threshold (* 16 1024 1024))
(etaf-resize-test--tick)
(should (plist-get ebox-resize-benchmark--run :armed))
(should (= width 400))
(should (equal (plist-get ebox-resize-benchmark--run :gc-policy)
(list gc-cons-threshold gc-cons-percentage))))))
(ert-deftest etaf-resize-startup-lease-wait-is-bounded ()
"A stuck preceding render fails without issuing a benchmark resize."
(etaf-resize-test--with-run
(let ((ebox--deferred-render-gc-state '(:busy t)))
(ebox-resize-benchmark-start buffer 400 800 :delay 10 :timeout 20 :output output)
(setf (plist-get ebox-resize-benchmark--run :ready-deadline) (1- (float-time)))
(should-error (etaf-resize-test--tick))
(should (= width 600))
(should-not ebox-resize-benchmark--run)
(should-not (plist-get ebox-resize-benchmark--last-result :valid))
(should (= 0 (plist-get ebox-resize-benchmark--last-result :requested-count))))))
(ert-deftest etaf-resize-phase-selection-rejects-the-measurement-machinery ()
"Instrumentation cannot recursively time its own clock and bookkeeping."
(etaf-resize-test--with-run
(dolist (phase '(float-time gethash ebox-resize-benchmark--payload
ebox-rerender-buffer-with-context))
(should-error (ebox-resize-benchmark-start buffer 400 800
:phases (list phase) :output output)))
(should-not ebox-resize-benchmark--run)
(should-not (file-exists-p output))))
(provide 'etaf-resize-benchmark-tests)
;;; etaf-resize-benchmark-tests.el ends here

View File

@ -5,6 +5,7 @@
;;; Code:
(require 'ert)
(require 'etaf-observer)
(require 'etaf-resource)
(ert-deftest etaf-resource-loads-synchronous-value ()
@ -108,4 +109,84 @@
(lambda (_condition) (error "handler")))
:type 'error))
(ert-deftest etaf-resource-observes-only-loader-execution ()
"Report Resource loads while preserving replacement cleanup semantics."
(let* ((loads 0)
(cleanups 0)
reports
resource
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 51
:runtime-id 8
:buffer-name nil
:diagnostic #'ignore)))
(unwind-protect
(progn
(etaf--observer-call-with-context
context
(lambda ()
(setq resource
(etaf-resource
(lambda ()
(etaf-resource-result
(cl-incf loads)
:cleanup (lambda () (cl-incf cleanups))))))
(etaf-resource-load resource)))
(setq reports (nreverse reports))
(should (equal '(resource resource)
(mapcar (lambda (report)
(plist-get report :provider))
reports)))
(should (equal '(load load)
(mapcar (lambda (report)
(plist-get report :stage))
reports)))
(should (equal '(success success)
(mapcar (lambda (report)
(plist-get report :status))
reports)))
(should (= 2 (etaf-resource-value resource)))
(should (= 1 cleanups))
(etaf-resource-dispose resource)
(should (= 2 cleanups)))
(when resource
(etaf-resource-dispose resource)))))
(ert-deftest etaf-resource-observed-error-keeps-captured-error-contract ()
"Report loader failure without changing Resource error containment."
(let* (reports resource
(context
(etaf--observer-context-create
:sink (lambda (report) (push report reports))
:operation-id 52
:runtime-id 8
:buffer-name nil
:diagnostic #'ignore)))
(unwind-protect
(progn
(etaf--observer-call-with-context
context
(lambda ()
(setq resource (etaf-resource (lambda () (error "boom"))))))
(should (= 1 (length reports)))
(should (eq 'error (plist-get (car reports) :status)))
(should (eq 'error (etaf-resource-status resource)))
(should (string-match-p "boom" (cadr (etaf-resource-error resource)))))
(when resource
(etaf-resource-dispose resource)))))
(ert-deftest etaf-resource-unobserved-load-bypasses-stage-runtime ()
"Keep standalone Resource loading free of observation work."
(let (resource)
(unwind-protect
(cl-letf (((symbol-function 'etaf--observer-call-stage)
(lambda (&rest _args)
(ert-fail "unobserved Resource entered stage runtime"))))
(setq resource (etaf-resource (lambda () "ready")))
(should (equal "ready" (etaf-resource-value resource))))
(when resource
(etaf-resource-dispose resource)))))
;;; etaf-resource-tests.el ends here

View File

@ -0,0 +1,279 @@
;;; etaf-retirement-tests.el --- M3a retirement gates -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'cl-lib)
(require 'ert)
(require 'etaf)
(require 'etaf-retirement)
(define-error 'etaf-retirement-test-condition
"ETAF retirement test condition")
(defvar etaf-retirement-test-update-fail-p nil)
(defvar etaf-retirement-test-update-count 0)
(defvar etaf-retirement-test-unmount-first-count 0)
(defvar etaf-retirement-test-unmount-second-count 0)
(defvar etaf-retirement-test-scope-cleanup-count 0)
(etaf-define-component etaf-retirement-test-updated (&key source)
"Render SOURCE and expose a failing updated lifecycle entry."
:setup
(progn
(etaf-on-updated
(lambda ()
(cl-incf etaf-retirement-test-update-count)
(when etaf-retirement-test-update-fail-p
(signal 'etaf-retirement-test-condition
'("update failed" :payload update)))))
nil)
:view
(text (expr (format "updated=%s" (etaf-value source)))))
(etaf-define-component etaf-retirement-test-unmounted ()
"Expose ordered unmounted hooks and structural scope cleanup."
:setup
(progn
(etaf-on-unmounted
(lambda ()
(cl-incf etaf-retirement-test-unmount-first-count)
(signal 'etaf-retirement-test-condition
'("unmount failed" :payload unmount))))
(etaf-on-unmounted
(lambda () (cl-incf etaf-retirement-test-unmount-second-count)))
(etaf-on-scope-dispose
(lambda () (cl-incf etaf-retirement-test-scope-cleanup-count)))
nil)
:view (text "retire"))
(ert-deftest etaf-retirement-drain-stops-public-and-continues-structure ()
"First public failure abandons later hooks but retries structural cleanup."
(let ((journal
(etaf-retirement-journal-create
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4))
(attempts 0)
trace)
(etaf-retirement-enqueue
journal :owner 'first :kind 'updated
:payload (lambda ()
(push 'first trace)
(signal 'etaf-retirement-test-condition '("first")))
:ordering-key 1 :policy 'run-once-public :max-attempts 1)
(etaf-retirement-enqueue
journal :owner 'second :kind 'updated
:payload (lambda () (push 'second trace))
:ordering-key 2 :policy 'run-once-public :max-attempts 1)
(etaf-retirement-enqueue
journal :owner 'structure :kind 'route-cleanup
:payload (lambda ()
(cl-incf attempts)
(push 'structure trace)
(when (= attempts 1) (error "retry")))
:ordering-key 3 :policy 'retryable-idempotent :max-attempts 2)
(let ((condition (etaf-retirement-drain journal)))
(should (eq (car condition) 'etaf-retirement-test-condition))
(should (equal (nreverse trace) '(first structure structure)))
(should (= attempts 2))
(should
(equal (mapcar #'etaf-retirement-entry-state
(etaf-retirement-journal-entries journal))
'(failed-contained abandoned-contained completed))))))
(ert-deftest etaf-retirement-ordering-keys-sort-structurally ()
"Numeric ordering remains correct after single-digit entry counts."
(let ((journal
(etaf-retirement-journal-create
:operation-id 4 :outcome-id 5 :generation-id 6 :revision 7))
trace)
(dolist (key '((2 10 0) (2 2 0) (1 12 0) (1 3 0)))
(let ((captured-key key))
(etaf-retirement-enqueue
journal :owner captured-key :kind 'ordering
:payload (lambda () (push captured-key trace))
:ordering-key captured-key :policy 'contained-once :max-attempts 1)))
(should-not (etaf-retirement-drain journal))
(should (equal (nreverse trace)
'((1 3 0) (1 12 0) (2 2 0) (2 10 0))))))
(ert-deftest etaf-retirement-condition-trailer-is-cause-compatible ()
"Re-signal keeps symbol/data prefix and the reader rejects lookalikes."
(let* ((journal
(etaf-retirement-journal-create
:operation-id 7 :outcome-id 8 :generation-id 9 :revision 10))
captured)
(condition-case condition
(etaf-retirement-resignal
'(etaf-retirement-test-condition "original" (:business t))
journal)
(etaf-retirement-test-condition (setq captured condition)))
(should (eq (car captured) 'etaf-retirement-test-condition))
(should (equal (butlast (cdr captured))
'("original" (:business t))))
(should
(equal (etaf-condition-postcommit-info captured)
(list :kind 'postcommit :committed-p t :operation-id 7
:outcome-id 8 :generation-id 9 :revision 10
:diagnostic-journal-id
(etaf-retirement-journal-id journal))))
(should-not
(etaf-condition-postcommit-info
'(error (:etaf-condition-trailer/v1 (:kind postcommit)) business)))
(should-not
(etaf-condition-postcommit-info
'(error business
(:etaf-condition-trailer/v2
(:kind postcommit :committed-p t)))))
(dolist
(malformed
'((:kind postcommit :committed-p t :operation-id 1
:outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id 5 :unexpected accepted)
(:kind postcommit :committed-p t :operation-id 1
:outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id 5 :operation-id 6)
(:kind postcommit :committed-p t :operation-id 1
:outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id)
(:kind postcommit :committed-p t :operation-id -1
:outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id 5)))
(should-not
(etaf-condition-postcommit-info
(list 'error
(list :etaf-condition-trailer/v1 malformed)))))
(let (decorated)
(condition-case condition
(etaf-retirement-resignal
'(etaf-retirement-test-condition
"business"
(:etaf-condition-trailer/v1
(:kind postcommit :committed-p t :operation-id 1
:outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id 5 :unexpected accepted)))
journal)
(etaf-retirement-test-condition (setq decorated condition)))
(should decorated)
(should (etaf-condition-postcommit-info decorated))
(should (= 3 (length (cdr decorated)))))))
(ert-deftest etaf-retirement-data-projection-trailer-reader ()
"Projection trailers are readable while preserving the condition prefix."
(let* ((journal (etaf-retirement-journal-create
:operation-id 11 :outcome-id 12 :generation-id 13
:revision 14))
(trailer (etaf-retirement-condition-trailer
journal 'projection
:external-commit-certainty 'committed
:reconciliation-token 'reconcile-1
:projection-token 'projection-1
:result 'mutation-result))
(condition (append '(etaf-retirement-test-condition "business"
(:cause original)) (list trailer)))
(info (etaf-data-condition-projection-info condition)))
(should info)
(should (equal (butlast (cdr condition))
'("business" (:cause original))))
(should (equal info
(list :kind 'projection :committed-p t
:external-commit-certainty 'committed
:reconciliation-token 'reconcile-1
:projection-token 'projection-1
:result 'mutation-result
:operation-id 11 :outcome-id 12
:generation-id 13 :revision 14
:diagnostic-journal-id
(etaf-retirement-journal-id journal))))
(should-not (etaf-condition-postcommit-info condition))
;; Unknown versions, malformed payloads, and non-final lookalikes are inert.
(should-not
(etaf-data-condition-projection-info
'(error (:etaf-condition-trailer/v2 (:kind projection)))))
(should-not
(etaf-data-condition-projection-info
'(error (:etaf-condition-trailer/v1
(:kind projection :committed-p t
:external-commit-certainty committed
:reconciliation-token r :projection-token p
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id 5 :unexpected x)))))
(should
(etaf-data-condition-projection-info
(list 'error
'(:etaf-condition-trailer/v1
(:kind projection :committed-p t
:external-commit-certainty committed
:reconciliation-token r :projection-token p :result result
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id 5))
'(:etaf-condition-trailer/v1
(:kind projection :committed-p t
:external-commit-certainty committed
:reconciliation-token r :projection-token p :result result
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
:diagnostic-journal-id 6)))))))
(ert-deftest etaf-retirement-updated-error-is-committed-and-not-rerun ()
"Updated hook error carries a trailer while generation and buffer stay new."
(let ((buffer-name " *etaf-retirement-update-test*")
(source (etaf-ref "A"))
captured)
(setq etaf-retirement-test-update-count 0
etaf-retirement-test-update-fail-p nil)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf--view-call 'etaf-retirement-test-updated
(list :source source) nil))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-generation runtime))
(token (etaf-runtime-generation-token runtime)))
(setq etaf-retirement-test-update-fail-p t)
(condition-case condition
(setf (etaf-value source) "B")
(etaf-retirement-test-condition (setq captured condition)))
(should captured)
(should (equal (butlast (cdr captured))
'("update failed" :payload update)))
(should (etaf-condition-postcommit-info captured))
(should (= (1+ generation) (etaf-runtime-generation runtime)))
(should (= (1+ token) (etaf-runtime-generation-token runtime)))
(should (= etaf-retirement-test-update-count 1))
(should (equal "updated=B"
(with-current-buffer buffer-name (buffer-string))))
(setq etaf-retirement-test-update-fail-p nil)
(setf (etaf-value source) "C")
(should (= etaf-retirement-test-update-count 2))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-retirement-unmount-error-drains-structure-before-resignal ()
"Explicit unmount remains detached, abandons later hooks, and cleans scope."
(let ((buffer-name " *etaf-retirement-unmount-test*") runtime authority captured)
(setq etaf-retirement-test-unmount-first-count 0
etaf-retirement-test-unmount-second-count 0
etaf-retirement-test-scope-cleanup-count 0)
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-view (etaf-retirement-test-unmounted)))
(setq runtime (etaf-runtime-for-buffer buffer-name)
authority (etaf-runtime-host-authority runtime))
(condition-case condition
(etaf-unmount runtime)
(etaf-retirement-test-condition (setq captured condition)))
(should captured)
(should (etaf-condition-postcommit-info captured))
(should (= etaf-retirement-test-unmount-first-count 1))
(should (zerop etaf-retirement-test-unmount-second-count))
(should (= etaf-retirement-test-scope-cleanup-count 1))
(should-not (etaf-runtime-mounted-p runtime))
(should (eq (etaf-host-authority-state authority) 'terminal))
(should-not (etaf-render-port-mounted-p (get-buffer buffer-name))))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(provide 'etaf-retirement-tests)
;;; etaf-retirement-tests.el ends here

File diff suppressed because it is too large Load Diff

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,35 @@
((:file "etaf-data.el" :form condition-case :conditions (error) :owner etaf-data :policy generic-containment)
(:file "etaf-data.el" :form condition-case :conditions (error) :owner etaf-data :policy generic-containment)
(:file "etaf-observer.el" :form condition-case :conditions (error quit) :owner etaf-observer :policy generic-containment)
(:file "etaf-observer.el" :form condition-case :conditions (error quit) :owner etaf-observer :policy generic-containment)
(:file "etaf-observer.el" :form condition-case :conditions (error) :owner etaf-observer :policy generic-containment)
(:file "etaf-observer.el" :form condition-case :conditions (quit) :owner etaf-observer :policy generic-containment)
(:file "etaf-performance.el" :form condition-case :conditions (etaf-runtime-error) :owner etaf-performance :policy specific-compatibility)
(:file "etaf-performance.el" :form condition-case :conditions (error) :owner etaf-performance :policy generic-containment)
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
(:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment)
(:file "etaf-render-port.el" :form condition-case :conditions (etaf-spi-incompatible-error etaf-spi-bootstrap-error) :owner etaf-render-port :policy specific-compatibility)
(:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment)
(:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment)
(:file "etaf-retirement.el" :form condition-case :conditions (error quit) :owner etaf-retirement :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment))

File diff suppressed because one or more lines are too long

View File

@ -0,0 +1,15 @@
((:file "docs/user-guide.en.md"
:block 19
:sha256 "79390863a3fdf604969cc4f424b36a9a466e569bd0ac740e61c580b2518cb2da"
:classification mounted-smoke
:probe collection-composition)
(:file "docs/user-guide.en.md"
:block 8
:sha256 "5e7b4088abd90a8ff9a5676d8ac98a2534ef43b79e927f14b4a67fe1189a9c11"
:classification mounted-smoke
:probe runtime-snapshot)
(:file "docs/user-guide.zh.md"
:block 8
:sha256 "5e7b4088abd90a8ff9a5676d8ac98a2534ef43b79e927f14b4a67fe1189a9c11"
:classification mounted-smoke
:probe runtime-snapshot))

View File

@ -0,0 +1,382 @@
"""Owned-window capture routing preflight; never captures a real screen."""
import json
import os
from pathlib import Path
import subprocess
import tempfile
import unittest
ROOT = Path(__file__).resolve().parents[1]
CAPTURE = ROOT / "scripts/capture-emacs-window.sh"
RUNNER = ROOT / "scripts/run-emacs-gui-verification.sh"
RECORDER_SOURCE = ROOT / "scripts/record-emacs-window.swift"
class RecorderCanvasTests(unittest.TestCase):
@classmethod
def setUpClass(cls):
cls.build = tempfile.TemporaryDirectory()
cls.addClassCleanup(cls.build.cleanup)
source = RECORDER_SOURCE.read_text()
# Run the actual polling guard with fixture-only providers. Compiling
# the rest of the recorder also keeps its real validation available;
# the recorder's main and all capture APIs remain uninvoked.
guard = source.split(" let nextID = try windowID(pid: pid)\n", 1)[1]
guard_end = ' try emit(["event": "window-replaced", "window_id": id, "pid": pid])\n }'
guard = ("let nextID = try windowID(pid: pid)\n" + guard.split(
guard_end, 1)[0] + guard_end)
driver = r'''
struct FixtureFilter {
let contentRect: CGRect
let pointPixelScale: Double
}
final class FixtureStream {
var updates = 0
func updateContentFilter(_ filter: FixtureFilter) async throws { updates += 1 }
}
extension RecordEmacsWindow {
static func checkFixture(_ input: [String: Any]) async -> [String: Any] {
let pid: pid_t = 123
var id = CGWindowID(input["current_id"] as! Int)
var currentFilter = FixtureFilter(contentRect: CGRect(x: 0, y: 0, width: 500, height: 400),
pointPixelScale: 2)
let configuration = SCStreamConfiguration()
configuration.width = 1000
configuration.height = 800
let stream = FixtureStream()
var reads = 0
func windowID(pid: pid_t) throws -> CGWindowID { CGWindowID(input["next_id"] as! Int) }
func filter(pid: pid_t, id: CGWindowID) async throws -> FixtureFilter {
reads += 1
return FixtureFilter(contentRect: CGRect(x: 0, y: 0,
width: input["width"] as! Double, height: input["height"] as! Double),
pointPixelScale: input["scale"] as! Double)
}
func emit(_ values: [String: Any]) throws {}
var failure: String?
do {
''' + guard + r'''
} catch { failure = String(describing: error) }
return ["error": failure as Any? ?? NSNull(), "filter_reads": reads,
"updates": stream.updates, "window_id": id]
}
}
func checkFrameFixture(_ input: [String: Any]) throws -> [String: Any] {
var image: CVPixelBuffer?
guard CVPixelBufferCreate(kCFAllocatorDefault, 1000, 800, kCVPixelFormatType_32BGRA,
nil, &image) == kCVReturnSuccess, let image else {
throw CaptureFailure("Cannot create fixture pixels")
}
var format: CMVideoFormatDescription?
guard CMVideoFormatDescriptionCreateForImageBuffer(allocator: kCFAllocatorDefault,
imageBuffer: image, formatDescriptionOut: &format) == noErr, let format else {
throw CaptureFailure("Cannot create fixture video format")
}
var timing = CMSampleTimingInfo(duration: CMTime(value: 1, timescale: 60),
presentationTimeStamp: CMTime(value: 1, timescale: 60), decodeTimeStamp: .invalid)
var sample: CMSampleBuffer?
guard CMSampleBufferCreateReadyWithImageBuffer(allocator: kCFAllocatorDefault,
imageBuffer: image, formatDescription: format, sampleTiming: &timing,
sampleBufferOut: &sample) == noErr, let sample else {
throw CaptureFailure("Cannot create fixture sample")
}
let attachments = CMSampleBufferGetSampleAttachmentsArray(sample, createIfNecessary: true)!
as! [NSMutableDictionary]
attachments[0][SCStreamFrameInfo.status.rawValue] = SCFrameStatus.complete.rawValue
attachments[0][SCStreamFrameInfo.contentScale.rawValue] = input["content_scale"] as! Double
attachments[0][SCStreamFrameInfo.scaleFactor.rawValue] = input["backing_scale"] as! Double
attachments[0][SCStreamFrameInfo.contentRect.rawValue] = CGRect(
x: input["x"] as! Double, y: input["y"] as! Double,
width: input["width"] as! Double, height: input["height"] as! Double).dictionaryRepresentation
let events = CaptureEvents(pixelScale: 2)
events.inspectScreenSample(sample)
let result = events.state()
return ["error": result.failure as Any? ?? NSNull(), "frames": result.frames]
}
@main
struct CanvasFixtureMain {
static func main() async throws {
let input = try JSONSerialization.jsonObject(with: FileHandle.standardInput.readDataToEndOfFile())
as! [String: Any]
let result = input["frame"] as? Bool == true
? try checkFrameFixture(input) : await RecordEmacsWindow.checkFixture(input)
try RecordEmacsWindow.emit(result)
}
}
'''
path = Path(cls.build.name) / "canvas-fixture.swift"
path.write_text(source.replace("@main\nstruct RecordEmacsWindow",
"struct RecordEmacsWindow", 1) + driver)
cls.fixture = Path(cls.build.name) / "canvas-fixture"
subprocess.run(
["xcrun", "swiftc", "-parse-as-library", "-warnings-as-errors", "-O",
str(path), "-o", str(cls.fixture)], check=True,
)
def check_canvas(self, next_id, width, height, scale=2):
result = subprocess.run(
[str(self.fixture)], input=json.dumps(dict(current_id=123, next_id=next_id,
width=width, height=height, scale=scale)),
capture_output=True, text=True, check=True, timeout=10,
)
return json.loads(result.stdout)
def test_same_id_fit_uses_fresh_geometry(self):
result = self.check_canvas(123, 400, 300)
self.assertIsNone(result["error"])
self.assertEqual(result["filter_reads"], 1)
self.assertEqual(result["updates"], 0)
def test_same_id_growth_rejects_either_dimension(self):
for width, height in ((501, 400), (500, 401)):
with self.subTest(width=width, height=height):
result = self.check_canvas(123, width, height)
self.assertIsNotNone(result["error"])
self.assertIn("exceeds original native-pixel canvas", result["error"])
self.assertEqual(result["updates"], 0)
def test_replacement_fit_updates_filter(self):
result = self.check_canvas(456, 400, 300)
self.assertIsNone(result["error"])
self.assertEqual(result["filter_reads"], 1)
self.assertEqual(result["updates"], 1)
self.assertEqual(result["window_id"], 456)
def test_replacement_growth_rejects_before_filter_update(self):
for width, height in ((501, 400), (500, 401)):
with self.subTest(width=width, height=height):
result = self.check_canvas(456, width, height)
self.assertIn("exceeds original native-pixel canvas", result["error"])
self.assertEqual(result["updates"], 0)
self.assertEqual(result["window_id"], 123)
def test_exact_native_canvas_boundary(self):
for identifier in (123, 456):
for width, height, scale in ((500, 400, 2), (1000, 800, 1)):
with self.subTest(identifier=identifier, scale=scale):
result = self.check_canvas(identifier, width, height, scale)
self.assertIsNone(result["error"])
self.assertEqual(result["filter_reads"], 1)
def test_fractional_native_pixel_overflow_rejects(self):
for identifier in (123, 456):
for width, height in ((500.01, 400), (500, 400.01)):
with self.subTest(identifier=identifier, width=width, height=height):
self.assertIsNotNone(self.check_canvas(identifier, width, height)["error"])
def test_unusable_fresh_geometry_is_rejected(self):
for identifier in (123, 456):
for width, height, scale in ((0, 400, 2), (500, 0, 2), (500, 400, 0)):
with self.subTest(identifier=identifier, width=width, height=height, scale=scale):
result = self.check_canvas(identifier, width, height, scale)
self.assertIsNotNone(result["error"])
self.assertEqual(result["updates"], 0)
def check_frame(self, width, height, x=0, y=0, content_scale=1, backing_scale=2):
result = subprocess.run(
[str(self.fixture)], input=json.dumps(dict(frame=True, width=width, height=height,
x=x, y=y, content_scale=content_scale, backing_scale=backing_scale)),
capture_output=True, text=True, check=True, timeout=10,
)
return json.loads(result.stdout)
def test_native_frame_exact_boundary_and_padding(self):
for width, height, x, y in ((500, 400, 0, 0), (400, 300, 50, 50)):
with self.subTest(width=width, height=height):
result = self.check_frame(width, height, x, y)
self.assertIsNone(result["error"])
self.assertEqual(result["frames"], 1)
def test_native_frame_extent_cannot_exceed_buffer(self):
for width, height in ((501, 400), (500, 401), (500.01, 400)):
with self.subTest(width=width, height=height):
result = self.check_frame(width, height)
self.assertIsNotNone(result["error"])
self.assertEqual(result["frames"], 0)
def test_native_frame_content_cannot_extend_outside_buffer(self):
for x, y in ((-1, 0), (0, -1), (1, 0), (0, 1)):
with self.subTest(x=x, y=y):
result = self.check_frame(500, 400, x, y)
self.assertIsNotNone(result["error"])
self.assertEqual(result["frames"], 0)
def test_scaled_frame_stays_rejected(self):
result = self.check_frame(400, 320, content_scale=0.8)
self.assertIn("scaled", result["error"])
self.assertEqual(result["frames"], 0)
class WindowCaptureTests(unittest.TestCase):
@classmethod
def setUpClass(cls):
cls.build = tempfile.TemporaryDirectory()
cls.addClassCleanup(cls.build.cleanup)
cls.recorder = Path(cls.build.name) / "recorder"
subprocess.run(
["xcrun", "swiftc", "-parse-as-library", "-warnings-as-errors", "-O",
str(RECORDER_SOURCE), "-o", str(cls.recorder)], check=True,
)
def setUp(self):
self.directory = tempfile.TemporaryDirectory()
self.addCleanup(self.directory.cleanup)
self.path = Path(self.directory.name)
self.output = self.path / "a frame.png"
self.log = self.path / "arguments.json"
self.environment = dict(os.environ)
self.environment.update(
PATH=f"{self.path}:{os.environ['PATH']}",
ETAF_GUI_CAPTURE_PID=str(os.getpid()),
CAPTURE_TEST_LOG=str(self.log),
CAPTURE_TEST_ID="123",
)
self.script("osascript", "#!/bin/sh\ncat >/dev/null\nprintf '%s\\n' \"$CAPTURE_TEST_ID\"\n")
self.capture = self.script(
"screencapture",
"#!/usr/bin/env python3\n"
"import json, os, pathlib, sys\n"
"pathlib.Path(os.environ['CAPTURE_TEST_LOG']).write_text(json.dumps(sys.argv[1:]))\n"
"pathlib.Path(sys.argv[-1]).write_bytes(b'capture stub')\n"
)
self.environment["ETAF_GUI_SCREENCAPTURE"] = str(self.capture)
def script(self, name, contents):
path = self.path / name
path.write_text(contents)
path.chmod(0o755)
return path
def run_capture(self, *arguments):
return subprocess.run(
[str(CAPTURE), *arguments], env=self.environment,
capture_output=True, text=True, check=False,
)
def test_screenshot_captures_exact_owned_window_without_shadow(self):
result = self.run_capture("-x", str(self.output))
self.assertEqual(result.returncode, 0, result.stderr)
self.assertEqual(json.loads(self.log.read_text()),
["-l", "123", "-o", "-x", str(self.output)])
def test_screenshot_resolves_replacement_window_for_next_capture(self):
for window_id in ("123", "456"):
self.environment["CAPTURE_TEST_ID"] = window_id
result = self.run_capture("-x", str(self.output))
self.assertEqual(result.returncode, 0, result.stderr)
self.assertEqual(json.loads(self.log.read_text())[1], window_id)
def test_missing_owner_fails_without_invoking_capture(self):
self.script("osascript", "#!/bin/sh\nexit 1\n")
result = self.run_capture("-x", str(self.output))
self.assertNotEqual(result.returncode, 0)
self.assertFalse(self.log.exists())
def test_invalid_pid_fails_without_invoking_capture(self):
self.environment["ETAF_GUI_CAPTURE_PID"] = "1; echo unsafe"
result = self.run_capture("-x", str(self.output))
self.assertNotEqual(result.returncode, 0)
self.assertFalse(self.log.exists())
def test_window_replacement_during_capture_rejects_image(self):
counter = self.path / "counter"
self.script("osascript", f'''#!/bin/sh
cat >/dev/null
if [ -f '{counter}' ]; then echo 456; else touch '{counter}'; echo 123; fi
''')
result = self.run_capture("-x", str(self.output))
self.assertNotEqual(result.returncode, 0)
self.assertFalse(self.output.exists())
def test_video_rejects_missing_or_invalid_owner_before_capture(self):
for arguments in ([], ["0", str(self.output), "ready"],
["123; echo unsafe", str(self.output), "ready"]):
result = subprocess.run(
[str(self.recorder), *arguments],
env=self.environment, capture_output=True, check=False,
)
self.assertNotEqual(result.returncode, 0)
self.assertFalse(self.log.exists())
def run_recorder_lifecycle(self, recorder):
source = RUNNER.read_text().rsplit('[ "$#" -ge 1 ] || usage', 1)[0]
self.environment.update(TEST_RECORDER=str(recorder), TEST_RUN_DIR=str(self.path))
return subprocess.run(
["sh", "-c", source + '''
GUI_RUN_DIR=$TEST_RUN_DIR
GUI_RECORDER=$TEST_RECORDER
GUI_DAEMON_PID=$ETAF_GUI_CAPTURE_PID
start_recorder
stop_recorder
'''], env=self.environment, capture_output=True, text=True, timeout=10, check=False,
)
def test_runner_waits_for_verified_frame_and_stops_owned_recorder(self):
recorder = self.script(
"recorder-stub", "#!/usr/bin/env python3\n"
"import json, os, pathlib, signal, sys\n"
"signal.signal(signal.SIGTERM, lambda *_: sys.exit(0))\n"
"pathlib.Path(os.environ['CAPTURE_TEST_LOG']).write_text(json.dumps(sys.argv[1:]))\n"
"pathlib.Path(sys.argv[3]).write_text('verified frame')\n"
"signal.pause()\n",
)
result = self.run_recorder_lifecycle(recorder)
self.assertEqual(result.returncode, 0, result.stderr)
self.assertEqual(json.loads(self.log.read_text()),
[str(os.getpid()), str(self.path / "recording.mov"),
str(self.path / "recorder.ready")])
def test_runner_rejects_recording_exit_before_ready(self):
recorder = self.script("recorder-stub", "#!/bin/sh\nexit 1\n")
result = self.run_recorder_lifecycle(recorder)
self.assertNotEqual(result.returncode, 0)
self.assertIn("exited before", result.stderr)
def test_selector_rejects_other_owners_helpers_and_ambiguous_frames(self):
source = CAPTURE.read_text().split("<<'JXA'\n", 1)[1].split("\nJXA", 1)[0]
source = source[source.index("function run(argv)"):]
def window(identifier, **overrides):
result = dict(kCGWindowNumber=identifier, kCGWindowOwnerPID=123,
kCGWindowOwnerName="Emacs", kCGWindowLayer=0,
kCGWindowAlpha=1, kCGWindowName="*target*",
kCGWindowBounds=dict(Width=1000, Height=800))
result.update(overrides)
return result
def select(windows):
# Evaluate the actual JXA selector against a fixed WindowServer
# inventory. The test does not enumerate or capture live windows.
fixture = (
"var ObjC = {deepUnwrap: function(x) {return x;}, "
"castRefToObject: function(x) {return x;}};\n"
"var $ = {CGWindowListCopyWindowInfo: function() {return "
+ json.dumps(windows) + ";}};\n"
)
script = source.replace("function run(argv) {",
"function run(argv) {\n" + fixture, 1)
return subprocess.run(
["/usr/bin/osascript", "-l", "JavaScript", "-", "123"],
input=script, capture_output=True, text=True, check=False,
)
candidates = [
window(1, kCGWindowOwnerPID=456),
window(2, kCGWindowOwnerName="Other"),
window(3, kCGWindowName=""),
window(4, kCGWindowAlpha=0),
window(5, kCGWindowLayer=1),
window(6, kCGWindowBounds=dict(Width=1000, Height=24)),
window(7),
]
result = select(candidates)
self.assertEqual(result.returncode, 0, result.stderr)
self.assertEqual(result.stdout.strip(), "7")
self.assertNotEqual(select(candidates + [window(8)]).returncode, 0)
self.assertNotEqual(select(candidates[:5]).returncode, 0)
if __name__ == "__main__":
unittest.main()