Compare commits

...

16 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
53 changed files with 9754 additions and 1471 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 技能。
## 最终目标驱动
开始工作前先明确最终可观察结果、硬性指标、不可牺牲的功能、权威验证方式
@ -123,6 +141,8 @@ GUI 反馈失败时,以 GUI 为当前事实,回到最小假设重新定位
- 先用通用记录面板确认真实热区,再选择架构或算法改动。
- 一次优化只绑定一个主要瓶颈和一个预期收益,记录优化前后的相同口径数据。
- 根因确认后按全局 Root-cause follow-through 规则检查同类路径;在当前证据记录中
列出各路径的触发场景、正确性边界、实测影响与修复状态,不能用候选清单代替闭环。
- 不用示例名称或业务概念污染通用工具、编译器和底层包协议。
- 不以关闭校验、减少功能、弱化文本属性、破坏身份或回滚语义换取数字。
- 缓存和预编译提示不能自行授权快速路径;运行时仍负责验证和精确回退。

View File

@ -1,10 +1,10 @@
EMACS ?= emacs
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
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-component-frontends-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 = 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 scheduler-benchmark 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)" \
@ -15,7 +15,7 @@ compile: clean
$(EMACS) -Q --batch $(LOAD_PATH) \
--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,15 +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
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)))))"
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 compile test docs-check scheduler-benchmark
check: checkdoc metadata-check compile test docs-check scheduler-benchmark
clean:
rm -f *.elc examples/*.elc scripts/*.elc tests/*.elc

124
README.md
View File

@ -1,44 +1,85 @@
# 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 :font-weight '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 :font-weight '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
@ -75,6 +116,13 @@ 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
@ -112,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.1 are independent packages and may be installed in either order. Install both before Ebox 2.0.1, then install ETAF 0.1.1. ETAF declares TP directly because Host final-accept authority uses the TP transaction contract; rendering still consumes only the Ebox 2.0 public 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,44 +1,82 @@
# 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 :font-weight '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 :font-weight '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。
## 性能记录面板
@ -70,6 +108,11 @@ p50/p95/max、每次 operation、GC 增量和有序 provider 阶段;面板 hea
`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`
@ -106,11 +149,20 @@ operation 的 flat 阶段。`etaf-performance-records` 返回 operation/stage
## 加载与验证
ECSS 0.1.0 与 TP 1.0.1 是互相独立的包,安装顺序任意;两者都安装后再安装 Ebox 2.0.1,最后安装 ETAF 0.1.1。ETAF 会直接声明 TP 依赖,因为 Host final-accept authority 使用 TP transaction contract渲染仍只使用 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

@ -132,6 +132,9 @@ the other two clauses are optional:
```
`: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.
@ -175,7 +178,7 @@ 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 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
@ -222,6 +225,13 @@ Named slot names are stable non-keyword symbols. Strings, numbers, variables, an
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:
@ -326,32 +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)
service)
:view (slot))
(require 'etaf)
(etaf-define-component service-consumer ()
"Read the inherited service."
:setup (etaf-inject 'service nil t)
:view (text (expr (etaf-value (etaf-state)))))
: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
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
:view (slot))
'(: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
@ -458,6 +486,13 @@ 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

View File

@ -128,7 +128,9 @@ ATTRIBUTE = :KEY VALUE
:styles (styles RULE...))
```
`:view``:render` 互斥且必须恰好出现一个;`: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` 文件。
@ -170,7 +172,7 @@ state不重新运行 setup。setup 负责局部 ref、computed、watch、Effe
`: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
@ -217,6 +219,12 @@ children 只是匿名/默认 slot 的便捷写法,不是第二套内容模型
在 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
@ -318,32 +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)
service)
:view (slot))
(require 'etaf)
(etaf-define-component service-consumer ()
"Read the inherited service."
:setup (etaf-inject 'service nil t)
:view (text (expr (etaf-value (etaf-state)))))
: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
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
:view (slot))
'(: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 提供
@ -447,6 +471,12 @@ generationRuntime 中同名 hash table 只是由 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

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 FORM)`, 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 |
@ -65,7 +65,9 @@ Do not split a file merely to create a shorter name. Split only when a stable re
- `etaf-define-component` chooses exactly one of `:view` or `:render`; `:setup`
and `:styles` are optional.
- `:view` and `:render` are mutually exclusive frontends.
- `: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.

View File

@ -18,7 +18,7 @@
| 里程碑 | 已交付职责 | 证据 |
| --- | --- | --- |
| P0 grammar | 统一 View 形状、属性优先解析、`etaf-view`、`(expr FORM)`、核心 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 测试 |
@ -65,7 +65,8 @@
- `etaf-define-component` 必须在 `:view``:render` 中恰好选择一个;`:setup` 与
`:styles` 可选。
- `:view``:render` 是互斥 frontend。
- `:view``:render` 是同一 View 模型的互斥 frontend普通 `:render` 可返回
`etaf-view`,保留词法作用域与相同的 compiler prop/slot 规则。
- `:setup` 对每个 retained identity 只运行一次,返回 opaque 状态,并由两个 frontend
中的 `etaf-state` 读取。
- Props 更新只重新 render不重新运行 setup。

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。

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)
@ -67,6 +69,38 @@ that viewport directly instead of immediately rerendering:
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
@ -95,7 +129,9 @@ The child region is structural. `expr` is the one explicit bridge for ordinary E
```
`expr` accepts exactly one ordinary Elisp form and no structural children. Its
result can be a string, typed View, proper typed View sequence, or `nil`.
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:
@ -106,6 +142,11 @@ Quote has one ordinary Elisp meaning:
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:
```elisp
@ -143,20 +184,20 @@ 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` | Declarative View frontend; mutually exclusive with `:render` |
| `:render` | Ordinary-Elisp frontend returning one typed View through `etaf-node` |
| `: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 |
@ -170,22 +211,23 @@ 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 () (message "%s unmounted" initial-title)))
count)
:view
(column
(text :font-weight 'bold (expr title))
(text (expr (format "Count: %d" (etaf-value (etaf-state)))))
(text
:role 'button
:on-press
(let ((count (etaf-state)))
(lambda () (cl-incf (etaf-value count))))
"Increment")))
: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 and returns one opaque state value.
@ -194,6 +236,14 @@ 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:
```elisp
@ -256,6 +306,14 @@ 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
@ -311,13 +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
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
:view (slot))
'(: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
@ -395,12 +462,36 @@ 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.
Composition rules are fixed: the Host callback runs before Behavior callbacks,
Behaviors follow declaration order, and a callback error short-circuits the
rest. For non-event attributes the Host wins, then the first Behavior wins.
Duplicate Behavior names fail before installation. Stable installers are reused
and each installed cleanup runs exactly once. Dispatch targets one exact Host;
there is no capture or bubble phase.
<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
@ -423,14 +514,9 @@ 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)
service)
:view (slot))
(require 'etaf)
(etaf-define-component service-label ()
"Read the inherited service."
@ -438,13 +524,28 @@ Use Context for a dependency shared across component depth, not for ordinary pro
: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-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:
@ -664,6 +765,14 @@ 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-call-operation` or `etaf-performance-with-operation` for
application work that does not enter through a built-in public boundary. Both
@ -675,7 +784,7 @@ rewrite any function.
| 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 |
@ -703,8 +812,8 @@ Most applications need only `etaf-view`, `etaf-mount`, `etaf-define-component`,
- 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)
@ -67,6 +69,33 @@ Headless host 或已经知道最终布局上下文的调用方,可以通过可
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. 属性与子节点
@ -94,8 +123,9 @@ View 含有状态型 Component、响应式数据、事件或生命周期时
(etaf-view (text :font-style 'italic "Details"))))))
```
`expr` 只接受一个普通 Elisp form不能有结构子节点。返回值可以是字符串、typed
View、typed View proper sequence 或 `nil`。`if`、`when`、`cond`、`let`、`mapcar` 和
`expr` 只接受一个普通 Elisp form不能有结构子节点。在结构子节点位置返回值
可以是字符串、typed Host 或 Component View、这些值组成的 proper sequence 或 `nil`
`text` Host 内,表达式必须返回字符串。`if`、`when`、`cond`、`let`、`mapcar` 和
`cl-loop` 仍是普通 Elisp。
quote 只有普通 Elisp 的含义:
@ -106,6 +136,11 @@ quote 只有普通 Elisp 的含义:
例如 `'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 用于二维布局:
```elisp
@ -143,20 +178,20 @@ 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` | 声明式 View frontend`:render` 互斥 |
| `:render` | 普通 Elisp frontend通过 `etaf-node` 返回一个 typed View |
| `:render` | 普通 Elisp 返回一个 typed View通常使用 `etaf-view`;程序化构造也可使用 `etaf-node` |
| `:setup` | 可选的一次性初始化,返回由 `etaf-state` 读取的 opaque 状态 |
| `:styles` | 可选的静态作用域样式声明 |
@ -170,22 +205,23 @@ 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 () (message "%s unmounted" initial-title)))
count)
:view
(column
(text :font-weight 'bold (expr title))
(text (expr (format "Count: %d" (etaf-value (etaf-state)))))
(text
:role 'button
:on-press
(let ((count (etaf-state)))
(lambda () (cl-incf (etaf-value count))))
"Increment")))
: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 只执行一次,返回一个 opaque 状态值。选定的 `:view`
@ -193,6 +229,12 @@ Setup 对 retained instance 只执行一次,返回一个 opaque 状态值。
`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 只有一套模型:
```elisp
@ -255,6 +297,12 @@ callback。Scope 释放时会自动停止响应式 effect 并运行 cleanup。
默认 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
@ -308,13 +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
(etaf-theme-provide
'(:color "#F4F6FB" :bgcolor "#202634"))
:view (slot))
'(: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 中,
@ -390,10 +447,30 @@ 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。
组合规则固定Host callback 先于 Behavior callbackBehavior 按声明顺序运行callback
error 会 short-circuit 剩余 callback。非事件属性先由 Host 获胜,否则由第一个
Behavior 获胜first-wins。重复 Behavior name 在 installer 前失败;稳定 installer 会复用,每个
已安装 cleanup exactly-once。dispatch 只命中准确 Host不存在 capture 或 bubble。
<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不会
@ -415,14 +492,9 @@ 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)
service)
:view (slot))
(require 'etaf)
(etaf-define-component service-label ()
"Read the inherited service."
@ -430,13 +502,27 @@ Context 适合跨多层共享依赖,不适合普通 label
: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-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 契约:
@ -647,6 +733,11 @@ Ebox、TP、Data、Resource 与 SQLite 可以贡献按 sequence 排列的 flat p
`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-call-operation`/`etaf-performance-with-operation`;它们直接委托
@ -657,7 +748,7 @@ observer不修改任何函数。
| 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` | 观察状态或同步外部资源 |
@ -685,7 +776,7 @@ observer不修改任何函数。
- 产品级控件使用 `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

@ -4,13 +4,14 @@
;;; Commentary:
;; Components have one public definition boundary with two strict authoring
;; 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)
@ -229,8 +230,11 @@ or:
:styles (styles (SELECTOR ATTR ...)))
`:setup' runs once per retained identity and returns opaque state. `:view'
is unquoted DSL; `:render' is ordinary Elisp and constructs nodes with
`etaf-node'."
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
@ -292,10 +296,6 @@ is unquoted DSL; `:render' is ordinary Elisp and constructs nodes with
(memq (car setup-form) '(lambda function)))
(etaf--component-definition-error
"Component %S :setup cannot return a render function" name))
(when (and saw-render
(etaf--component-form-contains-head-p render-form '(etaf-view)))
(etaf--component-definition-error
"Component %S :render cannot embed the DSL frontend" name))
(let* ((props (etaf--parse-component-props arguments))
(styles-form (etaf--validate-styles-form styles-form name))
(definition-symbol
@ -305,13 +305,18 @@ is unquoted DSL; `:render' is ordinary Elisp and constructs nodes with
(let ((etaf--current-component-props etaf--component-props)
(etaf--current-component-slots etaf--component-slots)
(etaf--component-phase 'render))
(cl-symbol-macrolet
,(etaf--component-prop-symbol-macros props)
,(if saw-view
(let ((etaf--compiling-component-props props))
(etaf-compiler-expand-view
view-form :projection))
render-form)))))
,(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)

File diff suppressed because it is too large Load Diff

View File

@ -27,6 +27,7 @@
(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))
@ -71,6 +72,11 @@ otherwise call the local callback with no arguments."
(setq runtime (etaf-runtime-require-mounted runtime))
(let* ((dispatch
(lambda ()
(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
@ -119,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."
@ -191,6 +227,30 @@ RUNTIME is the mounted Runtime to activate, or nil for the current buffer."
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.
@ -202,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

View File

@ -5,7 +5,7 @@
;;; Commentary:
;; Owns one mounted Runtime's fixed Host authority token and state machine.
;; Initial v2 attachment registers a bounded TP final marker so attached
;; 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.
@ -83,10 +83,8 @@
:index index
:value value))
(defun etaf-host-authority-stage-attach (authority &optional legacy-p)
"Stage AUTHORITY attachment and register its final marker.
When LEGACY-P is non-nil, publish attached state directly after the legacy Ebox
initial operation and rely on manual framework rollback."
(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))))
@ -94,32 +92,28 @@ initial operation and rely on manual framework rollback."
(token (etaf-host-authority-token authority))
(version (etaf-host-authority-version authority)))
(aset slots etaf-host--state-slot 'provisionally-attached)
(if legacy-p
(let ((inhibit-quit t))
(aset slots etaf-host--state-slot 'attached)
(aset slots etaf-host--version-slot (1+ version)))
(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))
(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)

View File

@ -112,12 +112,24 @@
:stages (mapcar #'etaf-performance--copy-stage
(etaf-performance-operation-stages operation))))
(defun etaf-performance-records ()
"Return newest-first immutable snapshots of completed records."
(if etaf-performance--record-ring
(mapcar #'etaf-performance--copy-operation
(ring-elements etaf-performance--record-ring))
nil))
(defun etaf-performance-records (&optional runtime-id)
"Return newest-first immutable snapshots of completed records.
When RUNTIME-ID is non-nil, select only that integer observer report identity,
as exposed by `etaf-performance-operation-runtime-id'. This also selects
historical records after unmount or reuse of a buffer name. Omitted or nil
RUNTIME-ID selects all retained records."
(unless (or (null runtime-id) (integerp runtime-id))
(signal 'wrong-type-argument (list 'integerp runtime-id)))
(let ((records (and etaf-performance--record-ring
(ring-elements etaf-performance--record-ring))))
(mapcar #'etaf-performance--copy-operation
(if runtime-id
(seq-filter
(lambda (operation)
(equal runtime-id
(etaf-performance-operation-runtime-id operation)))
records)
records))))
(defun etaf-performance--percentile (samples percentile)
"Return nearest-rank PERCENTILE from numeric SAMPLES."
@ -180,10 +192,12 @@ durations may overlap and are therefore never presented as exclusive time."
(> (plist-get left :duration-ms)
(plist-get right :duration-ms))))))
(defun etaf-performance-summary (&optional records)
"Summarize completed RECORDS by operation kind and label."
(cl-defun etaf-performance-summary
(&optional (records (etaf-performance-records)))
"Summarize completed RECORDS by operation kind and label.
Omitted RECORDS selects all retained records; explicit nil selects none."
(let ((groups (make-hash-table :test #'equal)) result)
(dolist (operation (or records (etaf-performance-records)))
(dolist (operation records)
(let ((key (cons (etaf-performance-operation-kind operation)
(etaf-performance-operation-label operation))))
(puthash key
@ -469,20 +483,23 @@ BATTERY-OUTPUT identifies the active source; CUSTOM-OUTPUT contains settings."
:power-state (etaf-performance--power-state)))
;;;###autoload
(defun etaf-performance-report-data (&optional records)
"Return a portable report for completed performance RECORDS."
(let ((records (or records (etaf-performance-records))))
(list :format-version etaf-performance-report-format-version
:generated-at (format-time-string "%Y-%m-%dT%H:%M:%S%z")
:environment (etaf-performance-environment-data)
:summary (etaf-performance-summary records)
:operations
(mapcar #'etaf-performance--operation-report-data
(reverse (copy-sequence records))))))
(cl-defun etaf-performance-report-data
(&optional (records (etaf-performance-records)))
"Return a portable report for completed performance RECORDS.
Omitted RECORDS selects all retained records; explicit nil selects none."
(list :format-version etaf-performance-report-format-version
:generated-at (format-time-string "%Y-%m-%dT%H:%M:%S%z")
:environment (etaf-performance-environment-data)
:summary (etaf-performance-summary records)
:operations
(mapcar #'etaf-performance--operation-report-data
(reverse (copy-sequence records)))))
;;;###autoload
(defun etaf-performance-report-string (&optional records)
"Return completed performance RECORDS as a readable report string."
(cl-defun etaf-performance-report-string
(&optional (records (etaf-performance-records)))
"Return completed performance RECORDS as a readable report string.
Omitted RECORDS selects all retained records; explicit nil selects none."
(concat ";; ETAF performance report\n"
(pp-to-string (etaf-performance-report-data records))))

View File

@ -284,15 +284,23 @@ of the run."
(puthash effect t (etaf--source-subscribers source)))
(setf (etaf-effect-deps effect) old-deps)))))))))
(defun etaf--dispatch-source (source)
"Notify every current subscriber of SOURCE once."
(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)))
(cond
(when (or (null context-filter)
(funcall context-filter context))
(cond
((etaf-runtime-route-p subscriber)
(if (etaf-runtime-route-live-p subscriber)
(puthash context
@ -300,8 +308,9 @@ of the run."
(etaf-scheduler-record-stale-route-drop context)))
((and (etaf-effect-p subscriber)
(etaf-effect-active-p subscriber))
(puthash context
(puthash context
(cons subscriber (gethash context groups)) groups)))))
)
(etaf--source-subscribers source))
(let (contexts)
(maphash (lambda (context _) (push context contexts)) groups)

View File

@ -4,11 +4,9 @@
;;; Commentary:
;; This file is ETAF's only Ebox framework-SPI bootstrap owner. It probes the
;; additive Ebox v2 provider once, selects one immutable port, and exposes that
;; selection to downstream ETAF code without repeated `featurep' or `fboundp'
;; protocol guesses. A completely absent v2 provider receives a complete v1
;; fallback; a present but broken or incompatible provider fails closed.
;; 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:
@ -37,9 +35,11 @@
initial-observation-replay)
"Capabilities required from an Ebox framework SPI v2 provider.")
(defconst etaf-render-port--required-tp-protocol
'tp-transaction-protocol-v1+v2
"TP transaction protocol required by the Ebox framework SPI.")
(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)
@ -63,10 +63,11 @@
(update-function nil :read-only t)
(revision-function nil :read-only t)
(bootstrap-outcome nil :read-only t)
(provider 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, either `v1' or `v2'."
"Return selected PORT route, always `v2'."
(etaf-render-port--route port))
(defun etaf-render-port-spi-version (port)
@ -94,9 +95,13 @@
(etaf-render-port--update-function port))
(defun etaf-render-port-revision-function (port)
"Return PORT's committed-revision query function symbol."
"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))
@ -107,7 +112,7 @@
(list :reason reason :detail detail)))
(defun etaf-render-port--ensure-accessors ()
"Require every public Ebox v2 record accessor before reading a provider."
"Require Ebox's public v2 accessors and explicit snapshot query."
(dolist
(function
'(ebox-framework-spi-provider-p
@ -126,7 +131,8 @@
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-framework-spi-initial-observation-reports
ebox-surface-buffer-snapshot))
(unless (fboundp function)
(etaf-render-port--bootstrap-error
'missing-provider-accessor function))))
@ -221,8 +227,8 @@
(dolist (capability etaf-render-port--required-capabilities)
(unless (memq capability capabilities)
(push (list :missing-capability capability) failures))))
(unless (eq (plist-get snapshot :tp-protocol)
etaf-render-port--required-tp-protocol)
(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)
@ -255,292 +261,6 @@
(push (list slot operation) failures))))
(nreverse failures)))
(defun etaf-render-port--validate-framework-pair
(framework-stage framework-rollback)
"Validate FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK as one required pair."
(unless (functionp framework-stage)
(signal 'wrong-type-argument (list 'functionp framework-stage)))
(unless (functionp framework-rollback)
(signal 'wrong-type-argument (list 'functionp framework-rollback)))
t)
(defvar-local etaf-render-port--v1-cleanup-diagnostics nil
"Contained cleanup failures from the latest failed v1 initial operation.")
(defvar-local etaf-render-port--v1-committed-revision nil
"ETAF-owned revision evidence for a mounted legacy Ebox v1 surface.")
(defun etaf-render-port-v1-cleanup-diagnostics (buffer)
"Return a defensive copy of BUFFER's latest v1 cleanup diagnostics."
(and (buffer-live-p (get-buffer buffer))
(with-current-buffer (get-buffer buffer)
(copy-tree etaf-render-port--v1-cleanup-diagnostics))))
(defun etaf-render-port--v1-buffer-snapshot (buffer)
"Return BUFFER content and editor state needed by v1 manual cleanup."
(with-current-buffer buffer
(let ((narrowed-p (buffer-narrowed-p))
(start (point-min))
(end (point-max)))
(save-restriction
(widen)
(list :contents (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
:narrowed-p narrowed-p
:narrow-start start
:narrow-end end
:read-only buffer-read-only
:modified-p (buffer-modified-p)
:undo-list buffer-undo-list
:overlays
(mapcar
(lambda (overlay)
(list :overlay overlay
:start (overlay-start overlay)
:end (overlay-end overlay)))
(delete-dups
(append (car (overlay-lists)) (cdr (overlay-lists))))))))))
(defun etaf-render-port--v1-restore-buffer
(buffer snapshot &optional restore-contents-p)
"Restore BUFFER editor state from a pre-render v1 SNAPSHOT.
When RESTORE-CONTENTS-P is non-nil, also re-materialize text as a last-resort
fallback after change-group cancellation itself failed."
(unless (buffer-live-p buffer)
(error "Legacy Ebox target died during manual cleanup"))
(with-current-buffer buffer
(let ((inhibit-read-only t)
(inhibit-modification-hooks t))
(widen)
(when restore-contents-p
(let ((buffer-undo-list t))
(erase-buffer)
(insert (plist-get snapshot :contents))))
(let* ((saved-overlays (plist-get snapshot :overlays))
(saved-identities
(mapcar (lambda (entry) (plist-get entry :overlay))
saved-overlays)))
(dolist
(overlay
(delete-dups
(append (car (overlay-lists)) (cdr (overlay-lists)))))
(unless (memq overlay saved-identities)
(delete-overlay overlay)))
(dolist (entry saved-overlays)
(let ((overlay (plist-get entry :overlay)))
(move-overlay overlay
(plist-get entry :start)
(plist-get entry :end)
buffer))))
(when (plist-get snapshot :narrowed-p)
(narrow-to-region
(min (point-max) (plist-get snapshot :narrow-start))
(min (point-max) (plist-get snapshot :narrow-end))))
(goto-char (min (point-max)
(max (point-min) (plist-get snapshot :point))))
(let ((mark-marker (plist-get snapshot :mark-marker)))
(set-marker mark-marker (plist-get snapshot :mark-position) buffer)
(set-marker-insertion-type
mark-marker (plist-get snapshot :mark-insertion-type)))
(setq mark-active (plist-get snapshot :mark-active))
(setq buffer-read-only (plist-get snapshot :read-only))
(set-buffer-modified-p (plist-get snapshot :modified-p))
(setq buffer-undo-list (plist-get snapshot :undo-list))))
buffer)
(defun etaf-render-port--v1-cleanup-failed-initial
(buffer snapshot change-group change-group-active-p stage-entered
observer framework-rollback)
"Clean one failed legacy initial operation and return diagnostics.
BUFFER and SNAPSHOT identify editor custody. CHANGE-GROUP-ACTIVE-P says
whether CHANGE-GROUP still needs cancellation. STAGE-ENTERED controls the
paired FRAMEWORK-ROLLBACK. OBSERVER is detached before Ebox unmount."
(let (cancel-failed-p)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq-local etaf-render-port--v1-cleanup-diagnostics nil)))
(cl-labels
((record
(diagnostic)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq-local
etaf-render-port--v1-cleanup-diagnostics
(append etaf-render-port--v1-cleanup-diagnostics
(list diagnostic))))))
(run-phase
(entry)
(let ((phase (nth 0 entry))
(function (nth 1 entry))
(failure-function (nth 2 entry))
completed-p)
(unwind-protect
(let ((inhibit-quit t) (quit-flag nil))
(condition-case condition
(progn (funcall function) (setq completed-p t))
((error quit)
(setq completed-p t)
(when failure-function (funcall failure-function))
(record
(list :phase phase
:condition (copy-tree condition))))))
(unless completed-p
(when failure-function (funcall failure-function))
(record (list :phase phase :nonlocal-exit t))))))
(run-phases
(entries)
(when entries
;; A cleanup callback may perform an arbitrary nonlocal exit.
;; Nested unwind cleanup guarantees every later phase still runs.
(unwind-protect
(run-phase (car entries))
(run-phases (cdr entries))))))
(run-phases
`((framework-rollback
,(lambda ()
(when stage-entered
(funcall framework-rollback nil))))
(observer-detach
,(lambda ()
(when (and observer (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-buffer-set-observer buffer nil))))
(ebox-unmount
,(lambda ()
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))))
(revision-reset
,(lambda ()
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq-local
etaf-render-port--v1-committed-revision nil)))))
(change-group-cancel
,(lambda ()
(when change-group-active-p
(with-current-buffer buffer
(cancel-change-group change-group))))
,(lambda () (setq cancel-failed-p t)))
(buffer-restore
,(lambda ()
(etaf-render-port--v1-restore-buffer
buffer snapshot cancel-failed-p))))))
(and (buffer-live-p buffer)
(etaf-render-port-v1-cleanup-diagnostics buffer))))
(defun etaf-render-port--v1-record-revision (buffer revision)
"Record committed v1 REVISION for BUFFER without postaccept failure."
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq-local etaf-render-port--v1-committed-revision
(if (and (integerp revision) (> revision 0))
revision
'unavailable)))))
(defun etaf-render-port--v1-revision (buffer)
"Return ETAF's committed revision evidence for legacy v1 BUFFER."
(let ((revision
(and (buffer-live-p buffer)
(buffer-local-value
'etaf-render-port--v1-committed-revision buffer))))
(unless (and (integerp revision) (> revision 0))
(error "Mounted legacy Ebox surface has no committed revision: %S"
revision))
revision))
(defun etaf-render-port--v1-initial
(buffer input framework-stage framework-rollback &optional observer)
"Publish INPUT initially to BUFFER through legacy Ebox.
FRAMEWORK-STAGE runs after publication; FRAMEWORK-ROLLBACK performs contained
manual framework cleanup if staging fails. OBSERVER, when non-nil, is passed
through Ebox's legacy initial option."
(etaf-render-port--validate-framework-pair
framework-stage framework-rollback)
(let* ((buffer (get-buffer-create buffer))
(snapshot (etaf-render-port--v1-buffer-snapshot buffer))
(change-group (with-current-buffer buffer (prepare-change-group)))
result stage-entered operation-started-p change-group-active-p
cleanup-ran-p)
(cl-labels
((cleanup
()
(unless cleanup-ran-p
(setq cleanup-ran-p t)
(when operation-started-p
(let ((active-p change-group-active-p))
(setq change-group-active-p nil)
(etaf-render-port--v1-cleanup-failed-initial
buffer snapshot change-group active-p stage-entered
observer framework-rollback))))))
(unwind-protect
(condition-case primary
(progn
(when (ebox-surface-buffer-mounted-p buffer)
(error
"Legacy Ebox initial operation requires an unmounted buffer"))
(with-current-buffer buffer
(setq-local etaf-render-port--v1-cleanup-diagnostics nil
etaf-render-port--v1-committed-revision nil)
(activate-change-group change-group)
(setq operation-started-p t
change-group-active-p t)
(save-restriction
(widen)
(setq result
(ebox-render-to-buffer
buffer input
(and observer (list :observer observer))))))
(setq stage-entered t)
(funcall framework-stage nil)
(with-current-buffer buffer
(accept-change-group change-group))
(setq change-group-active-p nil)
;; TP surfaces start at committed revision one. Legacy Ebox
;; does not expose its surface handle, so ETAF owns this
;; compatibility evidence and advances it from update reports.
(etaf-render-port--v1-record-revision buffer 1)
result)
((error quit)
(cleanup)
(signal (car primary) (cdr primary))))
(when change-group-active-p
(cleanup))))))
(defun etaf-render-port--v1-update
(buffer input framework-stage framework-rollback)
"Update BUFFER from INPUT through the legacy Ebox callback pair.
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
(etaf-render-port--validate-framework-pair
framework-stage framework-rollback)
(let ((report
(ebox-commit buffer input framework-stage framework-rollback)))
;; Publication is accepted here. Missing compatibility metadata must not
;; become a rollback-capable error after commit; a later read fails closed.
(etaf-render-port--v1-record-revision
(get-buffer buffer) (plist-get report :surface-revision))
report))
(defun etaf-render-port--v1-fallback ()
"Return the complete immutable fallback port for an absent Ebox v2 SPI."
(etaf-render-port--create
:route 'v1
:spi-version 1
:schema-version 'etaf-ebox-v1-fallback/v1
:capabilities
'(initial-manual-cleanup update-paired-stage-rollback
same-object-update-report)
:tp-protocol 'tp-transaction-protocol-v1
:initial-function 'etaf-render-port--v1-initial
:update-function 'etaf-render-port--v1-update
:revision-function 'etaf-render-port--v1-revision
:bootstrap-outcome 'v2-absent-v1-selected))
(defun etaf-render-port--v2-port (snapshot)
"Return an immutable selected v2 port from compatible SNAPSHOT."
(let ((failures (etaf-render-port--incompatibilities snapshot)))
@ -558,6 +278,7 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
: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))))
@ -567,7 +288,7 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
(predicate-present-p (fboundp 'ebox-framework-spi-capabilities)))
(cond
((and (not feature-present-p) (not predicate-present-p))
(etaf-render-port--v1-fallback))
(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)
@ -597,19 +318,15 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK retain their existing Ebox meanings."
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."
(if (eq (etaf-render-port-route etaf-render-port--selected-port) 'v1)
(funcall (etaf-render-port-initial-function
etaf-render-port--selected-port)
buffer input framework-stage framework-rollback observer)
(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)))
(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)
@ -621,18 +338,16 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair."
(defun etaf-render-port-unmount (buffer)
"Release the retained Ebox surface owned by mounted BUFFER."
(let ((buffer (get-buffer buffer)))
(prog1 (ebox-unmount-buffer buffer)
(when (buffer-live-p buffer)
(with-current-buffer buffer
(setq-local etaf-render-port--v1-committed-revision nil))))))
(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 committed Ebox revision, or zero when it is unmounted."
"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)))
@ -647,6 +362,23 @@ FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair."
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

@ -18,6 +18,7 @@
(require 'etaf-component)
(require 'etaf-context)
(require 'etaf-behavior)
(require 'etaf-render-port)
(declare-function etaf--runtime-render-component "etaf-runtime" (runtime call path))
@ -116,6 +117,21 @@
(defvar etaf--rendering-range-p nil
"Non-nil while eagerly lowering descendants of one Range item Host.")
(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.")
@ -124,10 +140,8 @@
(unless etaf--ebox-source-builder
(signal 'etaf-renderer-error
(list "Canonical Ebox input escaped its lowering boundary")))
(ebox-source-builder-import
etaf--ebox-source-builder
(ebox-canonical-input--source-index input))
(copy-sequence (ebox-canonical-input--nodes input)))
(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."
@ -142,12 +156,11 @@
"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)
(let ((site (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--rendering-range-p
(list :range etaf--current-semantic-parent-id
:site site))
(etaf--render-runtime
(list :parent etaf--current-semantic-parent-id :site site))
(t
@ -266,12 +279,18 @@ tokens, not Ebox Host properties, and therefore are not materialized here."
(props (copy-sequence
(etaf--resolve-property-plist
(etaf--view-node-props node))))
(template (etaf--theme-host-defaults defaults name)))
(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 (plist-get props key)
(setq props (etaf--merge-property props key value)))))
(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 name
:token (etaf--view-node-token node)
@ -493,11 +512,11 @@ SITE-TOKEN supplies the stable generated Host identity when non-nil."
:class (plist-get props :class)
:declarations declarations
:provenance (list :adapter 'etaf-renderer :tag tag))))
(let ((ebox-canonical--source-builder etaf--ebox-source-builder))
(ebox-box-create
:layout layout :outer outer :children children
:owned-facts (ebox-canonical-facts-from-declarations tag declarations)
:source-handle source-handle))))
(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.
@ -623,12 +642,27 @@ multi-root forest; a single material root is returned unchanged."
(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)
@ -669,7 +703,11 @@ multi-root forest; a single material root is returned unchanged."
(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)
@ -735,6 +773,7 @@ multi-root forest; a single material root is returned unchanged."
(etaf--render-value-list children (append path (list :fragment))))
((or 'box 'row 'column 'flex 'grid)
(let ((nodes nil)
(etaf--render-parent-path path)
(index 0)
(range-child-p nil)
(semantic-id
@ -818,7 +857,7 @@ RANGE-CHILD-P preserves the direct material Range parent."
((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
@ -843,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

@ -24,6 +24,12 @@
: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))
@ -237,47 +243,95 @@ without rerunning the failed operation or changing committed authority."
(etaf-retirement-journal-diagnostics journal))
condition)
(defun etaf-retirement-condition-trailer (journal &optional kind)
"Return the canonical committed trailer for JOURNAL and optional KIND."
(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))))
(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."
(when (and (consp condition) (symbolp (car condition))
(proper-list-p (cdr condition)) (cdr condition))
(let* ((trailer (car (last (cdr condition))))
(payload
(and (proper-list-p trailer)
(= (length trailer) 2)
(eq (car trailer) :etaf-condition-trailer/v1)
(cadr trailer))))
(when (and (proper-list-p payload)
(= (length payload)
(* 2 (length etaf-retirement--condition-payload-keys)))
(equal
(cl-loop for (key _value) on payload by #'cddr
collect key)
etaf-retirement--condition-payload-keys)
(eq (plist-get payload :committed-p) t)
(eq (plist-get payload :kind) 'postcommit)
(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))
(copy-tree payload)))))
(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."

File diff suppressed because it is too large Load Diff

View File

@ -427,13 +427,16 @@ PROJECTION-ID identifies the bounded projection owning the detached turn."
first-condition))
(defun etaf-scheduler--record-fault
(context projection-id condition &optional phase)
"Record CONTEXT failure CONDITION for PROJECTION-ID and optional PHASE."
(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
(etaf-scheduler-context-active-turn-id context))
(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))
@ -459,8 +462,9 @@ PROJECTION-ID identifies the bounded projection owning the detached turn."
"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)
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
@ -482,11 +486,19 @@ PROJECTION-ID identifies the bounded projection owning the detached turn."
(when-let* ((source-condition
(etaf-scheduler--drain-context-sources
context projection-id)))
(signal (car source-condition)
(cdr source-condition))))
(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 first-condition (setq first-condition condition))
(unless fatal-condition (setq fatal-condition condition))
(etaf-scheduler--record-fault
context projection-id condition)
(etaf-scheduler--reset-pending context)))))))
@ -502,14 +514,35 @@ PROJECTION-ID identifies the bounded projection owning the detached turn."
(when-let* ((runtime-condition
(etaf-scheduler--run-runtime-turn
context turn)))
(signal (car runtime-condition)
(cdr runtime-condition))))
(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 first-condition (setq first-condition condition))
(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)
@ -519,8 +552,8 @@ PROJECTION-ID identifies the bounded projection owning the detached turn."
(setf (etaf-scheduler-context-completed-projection-epoch context)
projection-id
(etaf-scheduler-context-fault-state context) nil)))
(when first-condition
(signal (car first-condition) (cdr first-condition)))))
(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."

View File

@ -260,11 +260,41 @@ disposing the old Runtime.")
(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.
Visual Ebox attributes override Component defaults. Class tokens merge.
Conflicting Runtime metadata is rejected so fallthrough cannot silently alter
Component semantics. COMPONENT-NAME labels diagnostics."
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
@ -282,10 +312,36 @@ Component semantics. COMPONENT-NAME labels diagnostics."
(etaf--plist-set
result :class
(etaf--merge-class-input (plist-get result :class) value))))
(style-p
((etaf--event-property-p key)
(setq result
(append (etaf--plist-remove-domain result key)
(list key value))))
(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
@ -306,7 +362,11 @@ COMPONENT-NAME identifies the forwarding owner for diagnostics."
(let ((key (pop tail))
(value (pop tail)))
(if (memq key declared)
(setq props (etaf--plist-set props key value))
;; 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)))))
@ -745,7 +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 FORM)' is text interpolation only."
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)

View File

@ -3,8 +3,8 @@
;; SPDX-License-Identifier: GPL-3.0-or-later
;; Author: ETAF contributors
;; Version: 0.1.1
;; Package-Requires: ((emacs "29.1") (ebox "2.0.1") (tp "1.0.1"))
;; 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

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.

View File

@ -1,19 +1,42 @@
# Generic Emacs GUI verification
This directory owns the reusable verification mechanism, not application
scenarios:
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.
- `run-emacs-gui-verification.sh` owns one named daemon, explicit load paths,
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-screen.exp` keeps macOS `screencapture -v` attached to a PTY and stops
it through an explicit signal. It contains no Emacs or application logic.
- `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. The generic command is:
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 \
@ -21,11 +44,132 @@ scripts/run-emacs-gui-verification.sh run ADAPTER.el ENTRY \
--run-dir /private/tmp/my-gui-run
```
Fresh captures intentionally remain `INCOMPLETE` until their selected images
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` is completion evidence.
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

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

@ -34,7 +34,8 @@
(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))
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."
@ -45,6 +46,138 @@
"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)
@ -86,7 +219,9 @@
(cons 'action_count
(etaf-gui-verifier-context-action-count context))
(cons 'duration_ms
(etaf-gui-verifier-context-last-duration-ms context)))
(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
@ -140,14 +275,10 @@
(assertions (etaf-gui-verifier-action-assertions action)))
(etaf-gui-verifier--checkpoint
context action-id "before-action" nil)
(let ((started (float-time)))
(funcall (etaf-gui-verifier-action-execute action) context)
(setf (etaf-gui-verifier-context-last-duration-ms context)
(* 1000.0 (- (float-time) started))))
(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)
(raise-frame)
(etaf-gui-verifier--settle-action context action)
(etaf-gui-verifier--checkpoint
context action-id "after-redisplay"

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

@ -1,31 +0,0 @@
#!/usr/bin/expect -f
# Keep macOS screencapture attached to a real PTY. Redirecting its stdin to
# /dev/null makes current macOS builds stop recording immediately.
set maximum_seconds 600
if {$argc != 1} {
puts stderr "usage: record-screen.exp OUTPUT"
exit 2
}
set output [lindex $argv 0]
spawn -noecho /usr/sbin/screencapture -v -D 1 -x $output
set deadline [expr {[clock seconds] + $maximum_seconds}]
trap {
send -- "q"
expect eof
exit 0
} {SIGTERM SIGINT}
while {1} {
after 1000
if {[clock seconds] >= $deadline} {
send -- "q"
expect eof
puts stderr "screen recording exceeded $maximum_seconds seconds"
exit 1
}
}

View File

@ -4,11 +4,11 @@ set -eu
GUI_CORE_SCRIPT_DIR=$(CDPATH= cd "$(dirname "$0")" && pwd)
GUI_ENGINE="$GUI_CORE_SCRIPT_DIR/emacs-gui-verifier.el"
GUI_RECORDER="$GUI_CORE_SCRIPT_DIR/record-screen.exp"
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_EMACS_APP_NAME=${EMACS_APP_NAME:-Emacs}
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"
@ -18,7 +18,7 @@ usage() {
echo "usage:" >&2
echo " $0 doctor" >&2
echo " $0 review RUN_DIR" >&2
echo " $0 run ADAPTER_EL ENTRY_FUNCTION [--run-dir DIR] [--load-path DIR]..." >&2
echo " $0 run ADAPTER_EL ENTRY_FUNCTION [--initialize-function FUNCTION] [--run-dir DIR] [--load-path DIR]..." >&2
exit 2
}
@ -33,11 +33,12 @@ doctor() {
require_file "$GUI_EMACS_BIN"
require_file "$GUI_EMACSCLIENT"
require_file "$GUI_ENGINE"
require_file "$GUI_RECORDER"
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
command -v expect >/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"
@ -55,7 +56,6 @@ review_run() {
GUI_DAEMON=""
GUI_DAEMON_PID=""
GUI_RECORDER_PID=""
GUI_RECORDER_CHILD_PID=""
GUI_DAEMON_STARTED=false
valid_pid() {
@ -101,22 +101,15 @@ stop_recorder() {
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" "recorder wrapper"; then
if ! force_owned_exit "$GUI_RECORDER_PID" "window recorder"; then
GUI_RECORDER_STOP_FAILED=1
fi
fi
fi
if process_alive "$GUI_RECORDER_CHILD_PID"; then
GUI_RECORDER_STOP_FAILED=1
if ! force_owned_exit "$GUI_RECORDER_CHILD_PID" "screen recorder"; then
GUI_RECORDER_STOP_FAILED=1
fi
fi
if ! wait "$GUI_RECORDER_PID" 2>/dev/null; then
GUI_RECORDER_STOP_FAILED=1
fi
GUI_RECORDER_PID=""
GUI_RECORDER_CHILD_PID=""
[ "$GUI_RECORDER_STOP_FAILED" -eq 0 ]
}
@ -165,17 +158,16 @@ trap on_exit EXIT
trap 'exit 130' HUP INT TERM
activate_emacs() {
osascript -e "tell application \"$GUI_EMACS_APP_NAME\" to activate"
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 name of first application process whose frontmost is true')
case $GUI_FRONTMOST in
*Emacs*)
sleep 0.2
return 0
;;
esac
'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
@ -184,26 +176,23 @@ activate_emacs() {
}
start_recorder() {
/usr/bin/expect "$GUI_RECORDER" "$GUI_RUN_DIR/recording.mov" \
"$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 30 ]; do
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
GUI_RECORDER_CHILD_PID=$(
pgrep -P "$GUI_RECORDER_PID" -x screencapture 2>/dev/null |
sed -n '1p'
)
if process_alive "$GUI_RECORDER_CHILD_PID"; then
if [ -s "$GUI_RUN_DIR/recorder.ready" ]; then
return 0
fi
sleep 0.1
GUI_RECORDER_ATTEMPTS=$((GUI_RECORDER_ATTEMPTS + 1))
done
echo "screen recorder did not create its PTY child" >&2
echo "window recorder did not produce a verified frame" >&2
exit 1
}
@ -214,8 +203,14 @@ parse_run_arguments() {
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
@ -252,9 +247,14 @@ parse_run_arguments() {
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)'
@ -276,8 +276,13 @@ run_adapter() {
(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))
(set-frame-parameter nil 'fullscreen 'maximized)
(raise-frame)
(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

View File

@ -112,13 +112,13 @@
nil)
:view (text (expr label)))
(etaf-define-component etaf-test-g6b-provider ()
(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 (slot)))
: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
@ -219,9 +219,7 @@
(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))
(etaf-define-component invalid-render-dsl ()
:render (etaf-view (box)))))
:setup (etaf-node 'box nil nil) :view (box))))
(should-error (macroexpand definition)
:type 'etaf-component-definition-error)))
@ -558,7 +556,7 @@
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(ert-deftest etaf-component-frontends-compose-context-theme-style-and-behavior ()
"A DSL provider and code Component share Context, Theme, style, and events."
"Test child inheritance and composition; separate tests cover slot authors."
(let ((buffer " *etaf-g6b-composition*")
(count (etaf-ref 0)))
(unwind-protect
@ -568,13 +566,12 @@
(lambda ()
(etaf-view
(etaf-test-g6b-provider
(etaf-test-g6b-context-action
:count (etaf-value count)
:on-press
(let ((source count))
(lambda ()
(setf (etaf-value source)
(1+ (etaf-value source))))))))))
(1+ (etaf-value source)))))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(face (etaf-test-g6b--face-at buffer "Context 0"))
(props
@ -661,18 +658,13 @@
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
(let ((buffer " *etaf-g6b-attrs-role*"))
(unwind-protect
(progn
(etaf-mount
(should-error
(etaf-mount
buffer
(etaf-view
(etaf-test-g6b-attr-role
:role 'navigation :ref 'g6b-attrs-role)))
(should
(eq 'navigation
(plist-get
(etaf-runtime-host-props-for
(etaf-runtime-for-buffer buffer) 'g6b-attrs-role)
: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)))))

View File

@ -63,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)))))
@ -185,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

View File

@ -63,6 +63,123 @@
(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
@ -103,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)))))
@ -118,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"
@ -214,6 +338,25 @@
(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
@ -247,11 +390,13 @@
(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\\'")
@ -260,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

@ -4,8 +4,452 @@
(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*"))

View File

@ -30,10 +30,10 @@
(unwind-protect
(progn
(cl-letf (((symbol-function 'etaf-host-authority-stage-attach)
(lambda (authority &optional legacy-p)
(lambda (authority)
(setq lookup-during-stage
(etaf-runtime-for-buffer buffer-name))
(funcall original-stage authority legacy-p))))
(funcall original-stage authority))))
(etaf-mount
buffer-name
(etaf--view-call 'etaf-host-test-component

View File

@ -184,11 +184,12 @@
(skip-chars-forward " \t\r\n")
(should (eobp)))
(should (equal golden (etaf-m0a-document-example-signatures)))
(should (= 122 (length blocks)))
(should (= 124 (length blocks)))
(should (= 0 (cl-count 'read-error blocks
:key (lambda (entry)
(plist-get entry :drift)))))
(should (= 4 (cl-count 'macroexpand-error blocks
;; 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

View File

@ -236,6 +236,89 @@
(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

View File

@ -12,6 +12,18 @@
(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))
@ -21,14 +33,16 @@
(should (= (etaf-render-port-spi-version port) 2))
(should (eq (etaf-render-port-schema-version port)
'ebox-framework-spi-schema/v2))
(should (eq (etaf-render-port-tp-protocol port)
'tp-transaction-protocol-v1+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)
@ -37,25 +51,132 @@
(should-error
(eval `(setf (etaf-render-port--route ',port) 'broken)))))
(ert-deftest etaf-render-port-falls-back-only-when-v2-is-fully-absent ()
"Only complete feature/predicate absence selects the immutable v1 port."
(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))
(let ((port (etaf-render-port--bootstrap)))
(should (eq (etaf-render-port-route port) 'v1))
(should (= (etaf-render-port-spi-version port) 1))
(should (eq (etaf-render-port-initial-function port)
'etaf-render-port--v1-initial))
(should (eq (etaf-render-port-update-function port)
'etaf-render-port--v1-update))
(should (eq (etaf-render-port-revision-function port)
'etaf-render-port--v1-revision))
(should (eq (etaf-render-port-bootstrap-outcome port)
'v2-absent-v1-selected))))))
(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."
@ -119,27 +240,31 @@
(should-error (etaf-render-port--bootstrap)
:type 'etaf-spi-incompatible-error))))
(ert-deftest etaf-render-port-v1-initial-runs-manual-framework-cleanup ()
"A failed legacy initial stage invokes its paired cleanup exactly once."
(let ((buffer (generate-new-buffer " *etaf-v1-manual-cleanup*")) trace)
(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-render-to-buffer)
(lambda (&rest _arguments)
(cl-letf (((symbol-function 'ebox-framework-spi-initial)
(lambda (_buffer _input stage rollback)
(push 'render trace)
buffer)))
(condition-case condition
(funcall stage nil)
(error
(funcall rollback nil)
(signal (car condition) (cdr condition)))))))
(should-error
(etaf-render-port--v1-initial
(etaf-render-port-initial
buffer 'input
(lambda (_report)
(push 'stage trace)
(error "injected v1 initial failure"))
(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-v1-initial-restores-real-ebox-surface ()
"A failed legacy stage removes Ebox authority and restores buffer content."
(let ((buffer (generate-new-buffer " *etaf-v1-real-cleanup*"))
(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)
@ -147,28 +272,26 @@
(progn
(with-current-buffer buffer (insert "sentinel"))
(condition-case condition
(etaf-render-port--v1-initial
(etaf-render-port-initial
buffer input
(lambda (_report)
(error "injected real v1 stage failure"))
(error "injected real v2 stage failure"))
(lambda (_report) (cl-incf rollback-count)))
(error (setq captured condition)))
(should (equal captured '(error "injected real v1 stage failure")))
(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))))
(should-not
(etaf-render-port-v1-cleanup-diagnostics buffer)))
(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-v1-failure-restores-exact-editor-custody ()
"Legacy stage rollback preserves Emacs-owned editor identities and undo."
(let ((buffer (generate-new-buffer " *etaf-v1-editor-custody*"))
(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
@ -210,7 +333,7 @@
:undo-list (copy-tree buffer-undo-list)
:modified-p (buffer-modified-p))))
(condition-case condition
(etaf-render-port--v1-initial
(etaf-render-port-initial
buffer input
(lambda (_report) (error "editor custody primary"))
#'ignore)
@ -264,9 +387,9 @@
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-nonlocal-exit-runs-exact-cleanup ()
"A legacy stage throw cannot escape with mounted or editor state retained."
(let ((buffer (generate-new-buffer " *etaf-v1-nonlocal-cleanup*"))
(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
@ -274,11 +397,11 @@
(with-current-buffer buffer (insert "before"))
(should
(eq
(catch 'etaf-v1-test-escape
(etaf-render-port--v1-initial
(catch 'etaf-v2-test-escape
(etaf-render-port-initial
buffer input
(lambda (_report)
(throw 'etaf-v1-test-escape 'escaped))
(throw 'etaf-v2-test-escape 'escaped))
(lambda (_report) (cl-incf rollback-count)))
'not-escaped)
'escaped))
@ -286,15 +409,13 @@
(should-not (ebox-surface-buffer-mounted-p buffer))
(should-not (ebox-surface-buffer-observer buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string))))
(should-not
(etaf-render-port-v1-cleanup-diagnostics buffer)))
(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-v1-precondition-keeps-existing-mount ()
(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
@ -302,7 +423,7 @@
(ebox-render-to-buffer buffer (ebox-build '(box "existing")))
(let ((revision (ebox-surface-buffer-revision buffer)))
(should-error
(etaf-render-port--v1-initial
(etaf-render-port-initial
buffer (ebox-build '(box "replacement")) #'ignore #'ignore)
:type 'error)
(should (ebox-surface-buffer-mounted-p buffer))
@ -314,48 +435,42 @@
(ebox-unmount-buffer buffer))
(when (buffer-live-p buffer) (kill-buffer buffer)))))
(ert-deftest etaf-render-port-v1-rollback-throw-cannot-stop-cleanup-tail ()
"A framework rollback throw still unmounts and restores legacy editor state."
(let ((buffer (generate-new-buffer " *etaf-v1-rollback-throw*"))
(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-v1-rollback-escape
(etaf-render-port--v1-initial
(catch 'etaf-v2-rollback-escape
(etaf-render-port-initial
buffer input
(lambda (_report) (error "primary before rollback throw"))
(lambda (_report)
(throw 'etaf-v1-rollback-escape 'rollback-escaped)))
(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))))
(let ((diagnostic
(cl-find 'framework-rollback
(etaf-render-port-v1-cleanup-diagnostics buffer)
:key (lambda (entry) (plist-get entry :phase)))))
(should diagnostic)
(should (plist-get diagnostic :nonlocal-exit))))
(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-v1-cleanup-fault-keeps-primary-and-continues ()
"A secondary v1 cleanup fault is diagnosed while Ebox cleanup continues."
(let ((buffer (generate-new-buffer " *etaf-v1-cleanup-fault*"))
(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--v1-initial
(etaf-render-port-initial
buffer input
(lambda (_report) (error "primary stage failure"))
(lambda (_report) (error "secondary rollback failure")))
@ -363,14 +478,7 @@
(should (equal captured '(error "primary stage failure")))
(should-not (ebox-surface-buffer-mounted-p buffer))
(should (equal "before"
(with-current-buffer buffer (buffer-string))))
(let ((diagnostics
(etaf-render-port-v1-cleanup-diagnostics buffer)))
(should (= 1 (length diagnostics)))
(should (eq (plist-get (car diagnostics) :phase)
'framework-rollback))
(should (equal (plist-get (car diagnostics) :condition)
'(error "secondary rollback failure")))))
(with-current-buffer buffer (buffer-string)))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
@ -389,52 +497,35 @@
(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)))
(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-v1-revision-needs-no-v2-ebox-accessor ()
"A v1-only Ebox retains revisions without a v2-only query symbol."
(let ((buffer (generate-new-buffer " *etaf-v1-revision*"))
(etaf-render-port--selected-port (etaf-render-port--v1-fallback)))
(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
(cl-letf (((symbol-function 'ebox-surface-buffer-revision) nil))
(etaf-render-port-initial
buffer (ebox-build '(box "one")) #'ignore #'ignore)
(should (= (etaf-render-port-revision buffer) 1))
(let ((report
(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")) #'ignore #'ignore)))
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 report :surface-revision))))
(with-current-buffer buffer
(setq-local etaf-render-port--v1-committed-revision nil))
(should-error (etaf-render-port-revision buffer) :type 'error))
(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-v1-missing-update-revision-fails-later ()
"A committed v1 update may finish, but missing revision evidence fails closed."
(let ((buffer (generate-new-buffer " *etaf-v1-missing-revision*"))
(etaf-render-port--selected-port (etaf-render-port--v1-fallback))
(report (list :strategy 'injected-without-revision)))
(unwind-protect
(progn
(etaf-render-port-initial
buffer (ebox-build '(box "one")) #'ignore #'ignore)
(cl-letf (((symbol-function 'ebox-commit)
(lambda (_buffer _input framework-stage _rollback)
(funcall framework-stage report)
report)))
(should
(eq (etaf-render-port-update
buffer (ebox-build '(box "two")) #'ignore #'ignore)
report)))
(should-error (etaf-render-port-revision buffer) :type 'error))
(plist-get update-report :surface-revision)))))
(when (and (buffer-live-p buffer)
(ebox-surface-buffer-mounted-p buffer))
(ebox-unmount-buffer buffer))
@ -459,12 +550,70 @@
(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."
(should (eq (etaf-render-port-selected)
(etaf-render-port-selected)))
(should (memq (etaf-render-port-route (etaf-render-port-selected))
'(v1 v2))))
(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)

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

@ -156,6 +156,62 @@
(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*")

View File

@ -17,6 +17,9 @@
(define-error 'etaf-scheduler-test-render-recovery-condition
"ETAF scheduler render recovery condition")
(defvar etaf-scheduler-test-partial-failure-enabled nil)
(defvar etaf-scheduler-test-partial-failure-context nil)
(etaf-define-component etaf-scheduler-test-pair (&key left right)
"Render reactive LEFT and RIGHT values."
:view
@ -45,6 +48,18 @@
(signal 'etaf-scheduler-test-projection-condition '("projection")))
(etaf-node 'text nil (list (symbol-name status)))))
(etaf-define-component etaf-scheduler-test-data-partial-failure
(&key controller)
"Fail the success projection only in one selected scheduler context."
:render
(let ((status (etaf-value (etaf-data-status controller))))
(when (and etaf-scheduler-test-partial-failure-enabled
(eq status 'success)
(eq (etaf-scheduler-current-context)
etaf-scheduler-test-partial-failure-context))
(signal 'etaf-scheduler-test-projection-condition '("partial")))
(etaf-node 'text nil (list (symbol-name status)))))
(etaf-define-component etaf-scheduler-test-render-recovery
(&key source fail)
"Render SOURCE unless FAIL requests a deterministic render error."
@ -269,7 +284,7 @@
(ert-deftest etaf-scheduler-source-fault-does-not-suppress-context-tail ()
"A failing source delivery cannot discard later sources in the same turn."
(let ((context (etaf-scheduler-context-create :name 'source-fault-tail))
second-ran captured)
second-ran runtime-ran captured)
(condition-case condition
(etaf-scheduler-call-with-projection
(lambda ()
@ -278,14 +293,84 @@
(lambda (_context _source _projection-id)
(signal 'etaf-scheduler-test-source-condition '("first"))))
(etaf-scheduler-enqueue-source
context 'second
context 'second
(lambda (_context _source _projection-id)
(setq second-ran t)))))
(setq second-ran t)
(etaf-scheduler-enqueue-runtime
context 'second-runtime
(lambda () (setq runtime-ran t)))))))
(etaf-scheduler-test-source-condition (setq captured condition)))
(should (equal captured
'(etaf-scheduler-test-source-condition "first")))
(should second-ran)
(should runtime-ran)
(should (= 2 (etaf-scheduler-test--metric context :source-deliveries)))
(should (= 1 (etaf-scheduler-test--metric context :runtime-executions)))
(should (etaf-scheduler-context-idle-p context))))
(ert-deftest etaf-scheduler-control-fault-precedes-contained-item-fault ()
"A later fatal budget fault outranks an earlier contained source condition."
(let ((context
(etaf-scheduler-context-create
:name 'control-fault-precedence :fixed-point-step-budget 1))
runtime-ran captured summary)
(let ((etaf-scheduler-projection-observer
(lambda (value) (setq summary value))))
(condition-case condition
(etaf-scheduler-call-with-projection
(lambda ()
(etaf-scheduler-enqueue-source
context 'item-fault
(lambda (_context _source _projection-id)
(signal 'etaf-scheduler-test-source-condition '("item"))))
(cl-labels
((deliver (_context source _projection-id)
(etaf-scheduler-enqueue-source
context (1+ source) #'deliver)))
(etaf-scheduler-enqueue-source context 0 #'deliver))
(etaf-scheduler-enqueue-runtime
context 'runtime (lambda () (setq runtime-ran t)))))
((error quit) (setq captured condition))))
(should (eq (car captured) 'etaf-scheduler-error))
(should (eq (plist-get (cdr captured) :kind)
'fixed-point-step-budget))
(should (= (plist-get (cdr captured) :steps) 2))
(should (= (plist-get (cdr captured) :budget) 1))
(should-not runtime-ran)
(should (equal (etaf-scheduler-context-fault-state context) captured))
(should (equal (plist-get summary :condition) captured))
(should (etaf-scheduler-context-idle-p context))))
(ert-deftest etaf-scheduler-contained-fault-keeps-originating-turn-id ()
"Delayed item-fault quarantine records the source turn, not Runtime turn."
(let ((context (etaf-scheduler-context-create :name 'fault-origin-turn))
runtime-ran captured)
(condition-case condition
(etaf-scheduler-call-with-projection
(lambda ()
(etaf-scheduler-enqueue-source
context 'item-fault
(lambda (_context _source _projection-id)
(signal 'etaf-scheduler-test-source-condition '("origin"))))
(cl-labels
((deliver (_context source _projection-id)
(when (zerop source)
(etaf-scheduler-enqueue-source
context 1 #'deliver))))
(etaf-scheduler-enqueue-source context 0 #'deliver))
(etaf-scheduler-enqueue-runtime
context 'runtime (lambda () (setq runtime-ran t)))))
(etaf-scheduler-test-source-condition (setq captured condition)))
(should (equal captured
'(etaf-scheduler-test-source-condition "origin")))
(should runtime-ran)
(should (= (etaf-scheduler-context-active-turn-id context) 2))
(let ((diagnostic
(cl-find captured (etaf-scheduler-context-diagnostics context)
:key (lambda (entry) (plist-get entry :condition))
:test #'equal)))
(should diagnostic)
(should (= (plist-get diagnostic :turn-id) 1)))
(should (etaf-scheduler-context-idle-p context))))
(ert-deftest etaf-scheduler-subscriber-fault-does-not-suppress-group-tail ()
@ -293,6 +378,7 @@
(let* ((context
(etaf-scheduler-context-create :name 'subscriber-fault-tail))
second-ran
runtime-ran
(first
(etaf-runtime-route-create
:runtime-id 1 :mount-epoch 1 :authority-token 'first
@ -305,7 +391,12 @@
(etaf-runtime-route-create
:runtime-id 2 :mount-epoch 1 :authority-token 'second
:scheduler-context context
:scheduler (lambda (_route _source) (setq second-ran t))))
:scheduler
(lambda (_route _source)
(setq second-ran t)
(etaf-scheduler-enqueue-runtime
context 'second-runtime
(lambda () (setq runtime-ran t))))))
captured)
(condition-case condition
(etaf-scheduler-call-with-projection
@ -319,7 +410,9 @@
(should (equal captured
'(etaf-scheduler-test-source-condition "subscriber")))
(should second-ran)
(should runtime-ran)
(should (= 2 (etaf-scheduler-test--metric context :subscriber-visits)))
(should (= 1 (etaf-scheduler-test--metric context :runtime-executions)))
(should (etaf-scheduler-context-idle-p context))))
(ert-deftest etaf-scheduler-authority-predicate-fault-is-diagnostic ()
@ -589,6 +682,79 @@
(kill-buffer buffer)))
(etaf-data-stop controller))))
(ert-deftest etaf-scheduler-data-partial-retry-only-failed-context ()
"A committed Data projection retries only the context that failed."
(let* ((left-buffer " *etaf-scheduler-data-partial-left*")
(right-buffer " *etaf-scheduler-data-partial-right*")
(left-context (etaf-scheduler-context-create :name 'partial-left))
(right-context (etaf-scheduler-context-create :name 'partial-right))
(load-count 0)
(mutate-count 0)
(source
(etaf-data-source
:load
(lambda (_query _page _page-size)
(cl-incf load-count)
(list :items '(new) :total 2))
:mutate-v2
(lambda (_operation _payload)
(cl-incf mutate-count)
'(:certainty committed :result changed))))
(controller (etaf-data-controller source
:initial-result
'(:items (old) :total 1)))
(view (etaf--view-call
'etaf-scheduler-test-data-partial-failure
(list :controller controller) nil))
captured)
(setq etaf-scheduler-test-partial-failure-enabled nil
etaf-scheduler-test-partial-failure-context nil)
(unwind-protect
(progn
(etaf-mount left-buffer view
(list :scheduler-context left-context))
(etaf-mount right-buffer view
(list :scheduler-context right-context))
(setq etaf-scheduler-test-partial-failure-context left-context
etaf-scheduler-test-partial-failure-enabled t)
(let ((left-before (etaf-scheduler-test--metric
left-context :runtime-enqueues))
(right-before (etaf-scheduler-test--metric
right-context :runtime-enqueues)))
(condition-case condition
(etaf-data-mutate controller 'update 'payload)
(etaf-scheduler-test-projection-condition
(setq captured condition)))
(should captured)
(should (= 1 mutate-count))
(should (= 1 load-count))
(should (equal '(new)
(etaf-value (etaf-data-items controller))))
(should (eq 'render-pending
(etaf-data-reconciliation-state controller)))
(let ((right-after (etaf-scheduler-test--metric
right-context :runtime-enqueues)))
(should (> (- (etaf-scheduler-test--metric
left-context :runtime-enqueues)
left-before)
0))
(should (> (- right-after right-before) 0))
(setq etaf-scheduler-test-partial-failure-enabled nil)
(should (etaf-data-retry-render controller))
(should (eq 'projected
(etaf-data-reconciliation-state controller)))
(should (= right-after
(etaf-scheduler-test--metric
right-context :runtime-enqueues))))))
(setq etaf-scheduler-test-partial-failure-enabled nil
etaf-scheduler-test-partial-failure-context nil)
(dolist (buffer-name (list left-buffer right-buffer))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))
(etaf-data-stop controller))))
(ert-deftest etaf-scheduler-data-separates-source-and-projection-errors ()
"Source failure sets Data error; render failure leaves successful refs."
(let* ((buffer-name " *etaf-scheduler-data-projection-error*")

View File

@ -55,6 +55,7 @@
(defvar etaf-test-nested-range-present nil)
(defvar etaf-test-nested-range-source nil)
(defvar etaf-test-nested-range-evals 0)
(defvar etaf-test-nested-inner-range-evals 0)
(defvar etaf-test-nested-outer-source nil)
(defvar etaf-test-nested-inner-source nil)
(defvar etaf-test-inline-shared nil)
@ -151,6 +152,7 @@
(defun etaf-test--nested-range-children ()
"Return keyed nested Hosts from the nested Range source."
(cl-incf etaf-test-nested-inner-range-evals)
(let ((state (etaf-value etaf-test-nested-range-source)))
(append
(and (cdr state)
@ -351,7 +353,7 @@
(etaf-node 'column nil (list "prefix" (etaf-state) "suffix")))
(etaf-define-component etaf-test-unsupported-direct-range ()
"Start with a Host Range whose later unsupported output must fail."
"Start with a Host Range and then produce nested dynamic Components."
:setup
(let ((range (etaf--expr-create
:token 'etaf-test-unsupported-range-site
@ -884,7 +886,7 @@
(setq etaf-test-theme-cell theme)
(etaf-provide 'theme theme)
theme)
:view (column (slot)))
:view (column (etaf-test-consumer)))
(etaf-define-component etaf-test-consumer ()
"Render the nearest Context theme."
@ -1938,14 +1940,13 @@
(should (equal theme left-value))))
(ert-deftest etaf-context-provide-inject-follows-component-tree ()
"Resolve the nearest Context and react to its provided ref."
"Test Component inheritance; separate slot tests cover author environments."
(let ((buffer-name " *etaf-context-test*"))
(unwind-protect
(progn
(etaf-mount buffer-name
(etaf-view
(etaf-test-provider
(etaf-test-consumer))))
(etaf-test-provider)))
(with-current-buffer buffer-name
(should (equal "dark" (buffer-string))))
(setf (etaf-value etaf-test-theme-cell) 'light)
@ -2371,17 +2372,21 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(should (plist-get condition :path))
(should (= 3 (length (plist-get condition :path))))))))
(ert-deftest etaf-runtime-skips-descendant-range-under-rendered-component ()
"A freshly rendered Component absorbs its old descendant Range effect."
(ert-deftest etaf-runtime-skips-reevaluated-descendant-range-effects ()
"Only actual candidate evaluation absorbs a queued descendant Range effect."
(let* ((component
(etaf--semantic-component-create
:semantic-id 7 :identity '(parent-component)))
(range
(etaf--semantic-range-create
:semantic-id 8 :effect-id 8 :component-id 7 :parent-id 7))
(effect
(etaf--generation-effect-create
:effect-id 8 :kind 'range :semantic-id 8))
(generation
(etaf--generation-create
:generation-id 1
:effect-map (etaf--pvec-put nil 8 effect)
:semantic-nodes (etaf--pvec-put
(etaf--pvec-put nil 7 component) 8 range)))
(runtime
@ -2389,16 +2394,19 @@ Event composition is a Runtime contract, not a UI-library helper contract."
:candidate-rendered-identities '((parent-component))
:candidate-effects (make-hash-table :test #'eql)
:candidate-graph-nodes (make-hash-table :test #'eql))))
(puthash 8
(etaf--generation-effect-create
:effect-id 8 :kind 'range :semantic-id 8)
(etaf-runtime-candidate-effects runtime))
(puthash 8 effect (etaf-runtime-candidate-effects runtime))
(puthash 8 range (etaf-runtime-candidate-graph-nodes runtime))
(should (etaf--runtime-range-owned-by-rendered-component-p
runtime generation range))
(should-not (etaf--runtime-range-effect-staged-p runtime generation effect))
;; Reparenting or invalidating a semantic record is not effect evaluation.
(puthash 8 (copy-sequence range) (etaf-runtime-candidate-graph-nodes runtime))
(should-not (etaf--runtime-range-effect-staged-p runtime generation effect))
(puthash 8 (copy-sequence effect) (etaf-runtime-candidate-effects runtime))
(should (etaf--runtime-range-effect-staged-p runtime generation effect))
;; Root-owned Range ancestors have the same completed-work certificate.
(setf (etaf-runtime-candidate-rendered-identities runtime) nil)
(should-not (etaf--runtime-range-owned-by-rendered-component-p
runtime generation range))))
(should (etaf--runtime-range-effect-staged-p runtime generation effect))
(remhash 8 (etaf-runtime-candidate-graph-nodes runtime))
(should-not (etaf--runtime-range-effect-staged-p runtime generation effect))))
(ert-deftest etaf-stateful-props-update-without-rerunning-setup ()
@ -3004,8 +3012,11 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-current-generation runtime))
(effects (etaf--generation-source-effects generation source))
(parent (etaf--generation-semantic
generation '(etaf-test-local-style-parent (root)))))
(parent
(cl-loop for identity being the hash-keys of
(etaf-generation-identity-index generation)
when (eq (car-safe identity) 'etaf-test-local-style-parent)
return (etaf--generation-semantic generation identity))))
(should-not (memq (etaf--semantic-component-effect-id parent)
effects))
(setf (etaf-value source) "B")
@ -3628,6 +3639,32 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(should (equal '(20 30)
(etaf-runtime-candidate-removed-semantic-ids runtime)))))
(ert-deftest etaf-runtime-range-closure-preserves-removals-and-rejects-unknown ()
"Completing a reused graph cannot revive tombstones or invent owners."
(let* ((retained (etaf--semantic-host-create :semantic-id 1 :name 'text))
(generation
(etaf--generation-create
:semantic-nodes (etaf--pvec-put nil 1 retained)))
(runtime
(etaf--runtime-create
:generation-authority (etaf-generation-authority-create generation)
:candidate-graph-nodes (make-hash-table :test #'eql)
:candidate-graph-children (make-hash-table :test #'eql)
:candidate-removed-semantic-ids '(1))))
(cl-letf (((symbol-function 'etaf--runtime-carry-committed-subtree)
(lambda (&rest _) (error "A removed owner was resurrected"))))
(dolist (id '(1 99))
(let ((ids (etaf--runtime-candidate-descendant-ids runtime (list id))))
(should (equal ids (list id)))
(should-error
(etaf--runtime-index-range-item-identities
runtime ids (make-hash-table :test #'equal))
:type 'etaf-runtime-error))))
(should (zerop (hash-table-count
(etaf-runtime-candidate-graph-nodes runtime))))
(should (eq retained (etaf--pvec-get
(etaf-generation-semantic-nodes generation) 1)))))
(ert-deftest etaf-runtime-two-direct-ranges-batch-one-publication ()
"Evaluate and splice two disjoint Ranges once in one logical commit."
(let ((buffer-name " *etaf-two-range-test*")
@ -3833,8 +3870,8 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name))) (kill-buffer buffer)))))
(ert-deftest etaf-runtime-direct-range-rejects-step4b-output-without-reownership ()
"Reject direct Component output while retaining Range-only dependency."
(ert-deftest etaf-runtime-direct-range-accepts-nested-components-without-reownership ()
"Retain ordinary and nested Components under one Range-only dependency."
(dolist (unsupported '(component deep-component
deep-expr-component))
(let ((buffer-name (format " *etaf-range-unsupported-%S*" unsupported))
@ -3845,11 +3882,11 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(etaf-view (etaf-test-unsupported-direct-range)))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-current-generation runtime)))
(should-error
(setf (etaf-value etaf-test-unsupported-range-source)
unsupported)
:type 'etaf-runtime-error)
(should (eq generation (etaf-runtime-current-generation runtime)))
(setf (etaf-value etaf-test-unsupported-range-source) unsupported)
(should-not (eq generation (etaf-runtime-current-generation runtime)))
(setq generation (etaf-runtime-current-generation runtime))
(should (string-match-p "component\\|deep"
(etaf-test--buffer-text buffer-name)))
(should
(equal '(range)
(mapcar
@ -3892,7 +3929,8 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(let ((buffer-name " *etaf-nested-range-hosts-test*")
(etaf-test-nested-range-present (etaf-ref t))
(etaf-test-nested-range-source (etaf-ref (cons "A" nil)))
(etaf-test-nested-range-evals 0))
(etaf-test-nested-range-evals 0)
(etaf-test-nested-inner-range-evals 0))
(unwind-protect
(progn
(etaf-mount buffer-name (etaf-view (etaf-test-nested-host-range)))
@ -3904,19 +3942,29 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(range-id (etaf--generation-effect-semantic-id effect))
(range (etaf--pvec-get
(etaf-generation-semantic-nodes generation) range-id))
(outer-effect-id
(car (etaf--generation-source-effects
generation etaf-test-nested-range-present)))
(nested-id
(cl-loop for identity being the hash-keys of
(etaf--semantic-range-item-identity-index range)
using (hash-values semantic-id)
when (equal (plist-get (cddr identity) :key) 'nested)
return semantic-id)))
(setq etaf-test-nested-range-evals 0)
(should (= 1 etaf-test-nested-range-evals))
(should (= 1 etaf-test-nested-inner-range-evals))
(should-not (= effect-id outer-effect-id))
(setq etaf-test-nested-range-evals 0
etaf-test-nested-inner-range-evals 0)
(cl-letf (((symbol-function 'etaf--runtime-render-dirty-component)
(lambda (&rest _)
(error "Nested Range entered Component owner"))))
(setf (etaf-value etaf-test-nested-range-source)
(cons "B" t)))
(should (= 1 etaf-test-nested-range-evals))
;; The Host boundary gives this source to the inner Range alone.
(should (= 0 etaf-test-nested-range-evals))
(should (= 1 etaf-test-nested-inner-range-evals))
(should (equal "S sibling B" (etaf-test--buffer-text buffer-name)))
(should (= 1 (plist-get
(plist-get (ebox-buffer-update-report buffer-name)
:range-metrics)
@ -3940,12 +3988,17 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(etaf--generation-source-effects
generation etaf-test-nested-range-source))))
(let* ((old-generation generation)
(old-range range)
(old-range
(etaf--generation-effect-semantic
old-generation outer-effect-id))
(removed-ids
(etaf--runtime-generation-descendant-ids
old-generation
(etaf--semantic-range-item-root-ids old-range))))
(setf (etaf-value etaf-test-nested-range-present) nil)
(should (= 1 etaf-test-nested-range-evals))
(should (= 1 etaf-test-nested-inner-range-evals))
(should (equal "S" (etaf-test--buffer-text buffer-name)))
(let ((new-generation
(etaf-runtime-current-generation runtime)))
(dolist (semantic-id removed-ids)
@ -4010,6 +4063,7 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(setf (etaf-value etaf-test-nested-inner-source)
'((row-a . "two"))))
(should (equal (list inner-ref) (nreverse replacements)))
(should (equal "A two" (etaf-test--buffer-text buffer-name)))
(setq generation (etaf-runtime-current-generation runtime))
(let ((new-outer (etaf--pvec-get
(etaf-generation-semantic-nodes generation)
@ -4724,8 +4778,10 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-current-generation runtime))
(parent
(etaf--generation-semantic
generation '(etaf-test-ancestor-artifact-parent (root)))))
(cl-loop for identity being the hash-keys of
(etaf-generation-identity-index generation)
when (eq (car-safe identity) 'etaf-test-ancestor-artifact-parent)
return (etaf--generation-semantic generation identity))))
(should (etaf--semantic-component-p parent))
(should-not (etaf--semantic-component-artifact-key parent))
(setf (etaf-value etaf-test-ancestor-parent-source) "dark")
@ -4842,6 +4898,7 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(let ((runtime
(etaf--runtime-create
:candidate-removed-host-refs '(stable other)
:behaviors (make-hash-table :test #'equal)
:candidate-host-props (make-hash-table :test #'equal)
:candidate-handlers (make-hash-table :test #'equal)
:candidate-semantic-nodes (make-hash-table :test #'equal)
@ -4902,6 +4959,7 @@ Event composition is a Runtime contract, not a UI-library helper contract."
(let ((etaf-generation-index-max-depth 4)
(runtime
(etaf--runtime-create
:behaviors (make-hash-table :test #'equal)
:candidate-handlers (make-hash-table :test #'equal)
:candidate-host-props (make-hash-table :test #'equal)
:candidate-semantic-nodes (make-hash-table :test #'equal)

View File

@ -11,8 +11,6 @@
(: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 (error quit) :owner etaf-render-port :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 diff suppressed because one or more lines are too long

View File

@ -1,5 +1,15 @@
((:file "docs/user-guide.en.md"
:block 18
:block 19
:sha256 "79390863a3fdf604969cc4f424b36a9a466e569bd0ac740e61c580b2518cb2da"
:classification mounted-smoke
:probe collection-composition))
: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()