Compare commits
No commits in common. "main" and "perf-qualified-2026-08-26" have entirely different histories.
main
...
perf-quali
48
AGENTS.md
48
AGENTS.md
@ -4,24 +4,6 @@
|
||||
`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 技能。
|
||||
|
||||
## 最终目标驱动
|
||||
|
||||
开始工作前先明确最终可观察结果、硬性指标、不可牺牲的功能、权威验证方式
|
||||
@ -84,34 +66,6 @@ ETAF 当前性能工作的最终结果是：通用性能工具能解释每次操
|
||||
最小验证不能偷换最终目标。微基准只能证明局部机制；真实跨包场景和完整门禁
|
||||
仍是最终证据。
|
||||
|
||||
## 可验证的小赌注与反馈控制环
|
||||
|
||||
不要把一次无法控制、无法快速证伪的“大赌注”当作工程推进方式。任何跨包、
|
||||
跨阶段或“国民级应用”尺度的大 gap，都必须拆成一组彼此有清晰因果关系、能够
|
||||
独立验证和独立回退的小 gap。每个小 gap 只承载一个主要假设，并在扩大范围前
|
||||
得到新鲜证据。
|
||||
|
||||
这不是三条孤立技巧，而是一条完整的反馈控制环：
|
||||
|
||||
- **拆解**缩短因果距离：一次只改变一个可命名机制，使失败能直接指向假设，
|
||||
不让多个变量同时变化后再靠猜测定位；
|
||||
- **验证**限制错误传播：定向测试、静态编译、CI、事务回滚和真实 GUI 门禁必须
|
||||
放在对应边界上，不能等到最终集成时才第一次发现问题；
|
||||
- **迭代**提高反馈频率：小步实现、立即运行最小有判定力的检查，通过后才扩大
|
||||
一个维度，并在完整子目标证明后及时提交 Git 基线。
|
||||
|
||||
工程目标不是假装“零错误”，而是让错误出现得早、扩散得不远、定位有证据、
|
||||
回退代价低。一个实验若不能快速回答“假设是否成立”，就说明切片仍然过大；
|
||||
一个门禁若失败后不能指出责任边界，就说明验证粒度仍然过粗。不得用继续堆代码、
|
||||
增加兼容分支或推迟集成来掩盖反馈环已经失效。
|
||||
|
||||
凡目标涉及用户可观察的 Emacs 界面、文本属性、交互或性能，只有在目标版本的
|
||||
真实 GUI Emacs 中实际渲染并执行对应操作所得的视觉结果、动态过程和耗时数据，
|
||||
才称为反馈。batch ERT、静态编译、CI、mock、结构检查和微基准只是进入 GUI 前的
|
||||
预检或定位工具，不能替代 GUI 反馈，也不能据此宣称功能正确、视觉合格或性能收敛。
|
||||
GUI 反馈失败时，以 GUI 为当前事实，回到最小假设重新定位；不得用逻辑测试绿色
|
||||
反驳用户实测。
|
||||
|
||||
## 控制变更规模
|
||||
|
||||
- 避免一次编写大段跨层代码后才首次运行测试。
|
||||
@ -141,8 +95,6 @@ GUI 反馈失败时，以 GUI 为当前事实，回到最小假设重新定位
|
||||
|
||||
- 先用通用记录面板确认真实热区，再选择架构或算法改动。
|
||||
- 一次优化只绑定一个主要瓶颈和一个预期收益，记录优化前后的相同口径数据。
|
||||
- 根因确认后按全局 Root-cause follow-through 规则检查同类路径；在当前证据记录中
|
||||
列出各路径的触发场景、正确性边界、实测影响与修复状态，不能用候选清单代替闭环。
|
||||
- 不用示例名称或业务概念污染通用工具、编译器和底层包协议。
|
||||
- 不以关闭校验、减少功能、弱化文本属性、破坏身份或回滚语义换取数字。
|
||||
- 缓存和预编译提示不能自行授权快速路径；运行时仍负责验证和精确回退。
|
||||
|
||||
30
Makefile
30
Makefile
@ -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 scripts/benchmark-ebox-resize.el
|
||||
LOAD_PATH = -L . -L examples -L ../ebox -L ../tp -L ../ecss
|
||||
SOURCES = etaf-view.el etaf-compiler.el etaf-component.el etaf-reactive.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el
|
||||
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-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
|
||||
TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-performance-tests.el
|
||||
|
||||
.PHONY: test compile load checkdoc docs-check metadata-check scheduler-benchmark resize-benchmark-tests check clean
|
||||
.PHONY: test compile load checkdoc docs-check check clean
|
||||
|
||||
test: compile
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval "(setq load-prefer-newer t)" \
|
||||
@ -13,9 +13,9 @@ test: compile
|
||||
|
||||
compile: clean
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) \
|
||||
--eval "(setq load-prefer-newer t byte-compile-error-on-warn t byte-compile-warnings '(not obsolete))" \
|
||||
--eval "(setq load-prefer-newer t)" \
|
||||
--eval "(load-file \"etaf.el\")" \
|
||||
--eval "(dolist (file '($(foreach file,$(SOURCES) $(EXAMPLES),\"$(file)\"))) (unless (byte-compile-file file) (error \"Compilation failed: %s\" file)))"
|
||||
--eval "(dolist (file '($(foreach file,$(SOURCES) $(EXAMPLES),\"$(file)\"))) (byte-compile-file file))"
|
||||
|
||||
load: compile
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval "(setq load-prefer-newer t)" --eval "(require 'etaf)" --eval "(princ \"ETAF load OK\\n\")"
|
||||
@ -24,22 +24,10 @@ 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)))))'
|
||||
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (directory (list "." "examples")) (dolist (file (directory-files directory t)) (when (string-suffix-p ".el" file) (checkdoc-file file)))))'
|
||||
|
||||
check: checkdoc metadata-check compile test docs-check scheduler-benchmark
|
||||
check: checkdoc compile test docs-check
|
||||
|
||||
clean:
|
||||
rm -f *.elc examples/*.elc scripts/*.elc tests/*.elc
|
||||
rm -f *.elc examples/*.elc tests/*.elc
|
||||
|
||||
160
README.md
160
README.md
@ -1,97 +1,53 @@
|
||||
# ETAF
|
||||
|
||||
ETAF builds text applications from reusable Components above the independent
|
||||
[Ebox](../ebox) layout and rendering engine.
|
||||
ETAF is a small text-application framework built above the independent [Ebox](../ebox) layout and rendering engine.
|
||||
|
||||
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”:
|
||||
Its complete public model is:
|
||||
|
||||
<!-- etaf-example: hello -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-mount
|
||||
"*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"))))
|
||||
```text
|
||||
Component(props, Scope) → View → Renderer → Ebox Node → Emacs buffer
|
||||
```
|
||||
|
||||
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.
|
||||
Every visible structure uses one form:
|
||||
|
||||
<!-- etaf-example: card -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf)
|
||||
(name :property value ... child ...)
|
||||
```
|
||||
|
||||
(etaf-define-component demo-card (&key title)
|
||||
The only child computation bridge is `expr :value`; attribute values are ordinary Elisp expressions.
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(column
|
||||
(text :face 'bold "Hello")
|
||||
(text
|
||||
:color "#687386"
|
||||
(expr :value (if ready "Ready" "Waiting")))))
|
||||
```
|
||||
|
||||
Define a Component:
|
||||
|
||||
```elisp
|
||||
(etaf-define-component status-label (&key label)
|
||||
"Render a status label."
|
||||
:view
|
||||
(column
|
||||
(text :font-weight 'bold (expr title))
|
||||
(slot)
|
||||
(slot :name 'footer)))
|
||||
(text :face 'bold (expr :value label)))
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-card*"
|
||||
(etaf-view
|
||||
(demo-card :title "Account"
|
||||
(text "Connected")
|
||||
(slot :name 'footer (text "Footer")))))
|
||||
"*etaf-demo*"
|
||||
(etaf-view (status-label :label "Connected")))
|
||||
```
|
||||
|
||||
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.
|
||||
`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`.
|
||||
|
||||
## Performance records
|
||||
|
||||
ETAF provides an independent, opt-in, application-neutral timing recorder. It
|
||||
consumes public Runtime observer reports without advice or private cross-package
|
||||
probes. Runtime operations such as Event, Action, mount, flush, and unmount are
|
||||
recorded automatically; Ebox, TP, Data, Resource, and SQLite provider stages
|
||||
inside the same operation are correlated by sequence.
|
||||
ETAF includes an opt-in, application-neutral timing recorder. It recognizes
|
||||
public Event, Action, mount, flush, focus, Data, Resource, and viewport
|
||||
operations, then correlates coarse ETAF, Ebox, TP, and SQLite stages when those
|
||||
packages are loaded.
|
||||
|
||||
```elisp
|
||||
(require 'etaf-performance)
|
||||
;; In a buffer with a mounted ETAF Runtime:
|
||||
(etaf-performance-mode 1)
|
||||
;; Use any mounted ETAF application normally.
|
||||
(etaf-performance-show)
|
||||
@ -102,32 +58,30 @@ reproducing the operations, press `c` in the panel (or run
|
||||
`M-x etaf-performance-copy-report`) to copy a complete report. Press `w` (or
|
||||
run `M-x etaf-performance-export`) to save the same report as an `.eld` file.
|
||||
The portable report includes the Emacs/display environment, power source,
|
||||
low-power mode, native-JIT state, system load, grouped p50/p95/max, individual
|
||||
operations, GC deltas, and ordered provider stages. The panel header exposes
|
||||
the same environment context so a machine-wide slowdown is not mistaken for
|
||||
one package hotspot.
|
||||
low-power mode, system load, grouped p50/p95/max, individual operations, GC
|
||||
deltas, and nested stages. The panel header exposes the same environment
|
||||
context so a machine-wide slowdown is not mistaken for one package hotspot.
|
||||
|
||||
The `*ETAF Performance*` panel shows operation IDs, generation changes, total
|
||||
latency, GC deltas, and each flat provider stage in sequence. Provider stages
|
||||
may overlap, so they are not presented as exclusive/self time. Records are
|
||||
bounded by `etaf-performance-max-records`; disabling the mode only detaches the
|
||||
Runtime observer and never rewrites functions. `etaf-performance-summary`
|
||||
computes operation p50/p95/max statistics on demand, while
|
||||
`etaf-performance-operation-stage-summary` groups one operation's flat stages
|
||||
by provider category. `etaf-performance-records` returns defensive operation
|
||||
and stage snapshots; caller mutation cannot rewrite retained history.
|
||||
Pass a numeric observer runtime ID to `etaf-performance-records` to select one
|
||||
mount's history even when a buffer name is reused. Summary and report functions
|
||||
use all retained records when called without an argument; an explicit `nil`
|
||||
means an empty selection. The exported environment describes report generation,
|
||||
not each historical operation. These synchronous operation durations do not
|
||||
measure physical input-to-presentation latency; use the GUI measurement entry
|
||||
in [scripts/README.md](scripts/README.md) for per-action condition checks.
|
||||
The `*ETAF Performance*` panel shows operation IDs and parent operations,
|
||||
generation changes, total latency, GC deltas, and nested stage inclusive/self
|
||||
time. Records are bounded by `etaf-performance-max-records`; disabling the
|
||||
mode removes all recorder advice. `etaf-performance-summary` computes
|
||||
operation p50/p95/max statistics on demand, while
|
||||
`etaf-performance-operation-stage-summary` ranks one operation's package
|
||||
categories by exclusive time.
|
||||
|
||||
The default registry deliberately uses coarse package boundaries to keep the
|
||||
measured application representative. A package or application can add a
|
||||
temporary detail probe without coupling itself to an example:
|
||||
|
||||
```elisp
|
||||
(etaf-performance-register-stage
|
||||
'my-package-expensive-step 'application 'expensive-step)
|
||||
```
|
||||
|
||||
Use `etaf-performance-call-operation` or
|
||||
`etaf-performance-with-operation` to trace an arbitrary operation that has no
|
||||
built-in public boundary. Both delegate to the same Runtime operation boundary;
|
||||
they do not create a second timer.
|
||||
built-in public boundary.
|
||||
|
||||
## Executable examples
|
||||
|
||||
@ -160,21 +114,11 @@ There is no separate `etaf-data` install: Data is a core ETAF capability. There
|
||||
|
||||
## Load and verify
|
||||
|
||||
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.
|
||||
ECSS 0.1.0 and TP 1.0.0 are independent packages and may be installed in either order. Install both before Ebox 2.0.0, then install ETAF. ETAF consumes only the Ebox 2.0 public rendering contract.
|
||||
|
||||
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)
|
||||
|
||||
146
README.zh-CN.md
146
README.zh-CN.md
@ -1,93 +1,53 @@
|
||||
# ETAF
|
||||
|
||||
ETAF 在独立的 [Ebox](../ebox) 布局与渲染引擎上，使用可复用的 Component 构建文本应用。
|
||||
ETAF 是构建在独立 [Ebox](../ebox) 布局与渲染引擎之上的小型文本应用框架。
|
||||
|
||||
从 `etaf-view` 和 `etaf-mount` 开始。`(name :property value ... child ...)`
|
||||
中属性在前、子节点在后，属性值是普通 Elisp。求值下面完整例子，切换到
|
||||
`*etaf-hello*`，即可激活 “Say hello”：
|
||||
完整的公共模型是：
|
||||
|
||||
<!-- etaf-example: hello -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-mount
|
||||
"*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"))))
|
||||
```text
|
||||
Component(props, Scope) → View → Renderer → Ebox Node → Emacs buffer
|
||||
```
|
||||
|
||||
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)
|
||||
(name :property value ... child ...)
|
||||
```
|
||||
|
||||
(etaf-define-component demo-card (&key title)
|
||||
子节点中唯一的计算桥接是 `expr :value`；属性值则是普通 Elisp 表达式。
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(column
|
||||
(text :face 'bold "Hello")
|
||||
(text
|
||||
:color "#687386"
|
||||
(expr :value (if ready "Ready" "Waiting")))))
|
||||
```
|
||||
|
||||
定义 Component：
|
||||
|
||||
```elisp
|
||||
(etaf-define-component status-label (&key label)
|
||||
"Render a status label."
|
||||
:view
|
||||
(column
|
||||
(text :font-weight 'bold (expr title))
|
||||
(slot)
|
||||
(slot :name 'footer)))
|
||||
(text :face 'bold (expr :value label)))
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-card*"
|
||||
(etaf-view
|
||||
(demo-card :title "Account"
|
||||
(text "Connected")
|
||||
(slot :name 'footer (text "Footer")))))
|
||||
"*etaf-demo*"
|
||||
(etaf-view (status-label :label "Connected")))
|
||||
```
|
||||
|
||||
组件拥有状态时才增加 `:setup`，它对每个保留的实例执行一次。
|
||||
`:render` 使用普通 Elisp 捕获句柄，再返回 `etaf-view`；更短的 `:view`
|
||||
形式编译为同一种 View 模型。
|
||||
|
||||
<!-- etaf-example: counter -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component demo-counter ()
|
||||
:setup (etaf-ref 0)
|
||||
:render
|
||||
(let ((count (etaf-state)))
|
||||
(etaf-view
|
||||
(column
|
||||
(text (expr (format "Count: %d" (etaf-value count))))
|
||||
(box :ref 'increment :role 'button :tab-index 0
|
||||
:on-press (lambda () (cl-incf (etaf-value count)))
|
||||
"Increment")))))
|
||||
|
||||
(etaf-mount "*etaf-counter*" (etaf-view (demo-counter)))
|
||||
```
|
||||
|
||||
把 `etaf-value` 放在需要更新的属性或 `expr` 内，保留局部更新边界。
|
||||
事件回调捕获普通词法变量，`etaf-state` 在 render 时读取。可复用应用代码放进
|
||||
启用 lexical-binding 的 `.el` 文件。程序化构造 View 时也可使用 `etaf-node`。
|
||||
Context、Data、Behavior 和命名 Action 按需学习，简单回调不需要注册 Action。
|
||||
|
||||
加载 `(require 'etaf-ui)` 后，使用 `etaf-button` 等准确目录名称。
|
||||
Core 不加载 `.etaf` 文件；Playground 将它们作为 inert 结构，由其显式的 companion
|
||||
注册入口管理可执行 Elisp。
|
||||
`etaf-view` 是唯一的公共 View 构造入口。结构 form 不使用 quote；quote 仍然是普通 Elisp 数据语法，例如 `'bold`。普通 Elisp 返回 View 时，必须在 `expr` 中显式使用 `(etaf-view ...)` 构造它。
|
||||
|
||||
## 性能记录面板
|
||||
|
||||
ETAF 提供一个独立、按需加载、与具体应用无关的性能记录器。它消费 Runtime
|
||||
公共 observer 报告，不使用 advice 或私有跨包探针。Event、Action、mount、flush
|
||||
和 unmount 等 Runtime operation 会自动记录；同一 operation 内的 Ebox、TP、Data、
|
||||
Resource 和 SQLite 等 provider 阶段按 sequence 关联到同一条记录。
|
||||
ETAF 内置了一个按需启用、与具体应用无关的性能记录器。它自动识别公共
|
||||
Event、Action、mount、flush、focus、Data、Resource 和 viewport 操作；当
|
||||
Ebox、TP、SQLite 等包已加载时，还会把这些包的粗粒度阶段关联到同一个
|
||||
operation。
|
||||
|
||||
```elisp
|
||||
(require 'etaf-performance)
|
||||
;; 在已挂载 ETAF Runtime 的 buffer 中：
|
||||
(etaf-performance-mode 1)
|
||||
;; 正常操作任意已挂载的 ETAF 应用。
|
||||
(etaf-performance-show)
|
||||
@ -96,27 +56,28 @@ Resource 和 SQLite 等 provider 阶段按 sequence 关联到同一条记录。
|
||||
交互采集时先执行 `M-x etaf-performance-clear`，复现一组操作后，在面板按
|
||||
`c`（或执行 `M-x etaf-performance-copy-report`）即可把完整报告复制到剪贴板；
|
||||
按 `w`（或执行 `M-x etaf-performance-export`）可保存为 `.eld` 文件。报告包含
|
||||
Emacs/显示环境、电源来源、低功耗模式、native JIT 状态、系统负载、分组
|
||||
p50/p95/max、每次 operation、GC 增量和有序 provider 阶段；面板 header 也显示
|
||||
同一环境信息，避免把整机降频误判成某个包的热点。
|
||||
Emacs/显示环境、电源来源、低功耗模式、系统负载、分组 p50/p95/max、每次
|
||||
operation、GC 增量和嵌套阶段；面板 header 也显示同一环境信息，避免把整机降频
|
||||
误判成某个包的热点。
|
||||
|
||||
`*ETAF Performance*` 面板会显示 operation ID、generation 变化、总耗时、GC
|
||||
增量，以及 flat provider 阶段的顺序和各自耗时。provider 阶段可能重叠，因此
|
||||
不会伪装成 exclusive/self 时间。记录数量由 `etaf-performance-max-records`
|
||||
限制；关闭 mode 只会解除当前 Runtime 的 observer，不修改任何函数。
|
||||
`*ETAF Performance*` 面板会显示 operation ID 与父 operation、generation
|
||||
变化、总耗时、GC 增量，以及嵌套阶段的 inclusive/self 耗时。记录数量由
|
||||
`etaf-performance-max-records` 限制；关闭 mode 会移除全部记录 advice。
|
||||
`etaf-performance-summary` 会按需计算 operation 的 p50/p95/max，
|
||||
`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-operation-stage-summary` 则按 exclusive 耗时排列单次
|
||||
operation 的包级阶段。
|
||||
|
||||
默认注册表刻意只记录包级粗边界，避免分析工具明显改变被测应用。任意包或
|
||||
应用可以临时增加更细的探针，不需要绑定某个示例：
|
||||
|
||||
```elisp
|
||||
(etaf-performance-register-stage
|
||||
'my-package-expensive-step 'application 'expensive-step)
|
||||
```
|
||||
|
||||
没有内置公共边界的任意操作，可以使用
|
||||
`etaf-performance-call-operation` 或 `etaf-performance-with-operation`
|
||||
包裹；它们直接委托同一个 Runtime operation 边界，不建立第二套计时器。
|
||||
包裹。
|
||||
|
||||
## 可执行示例
|
||||
|
||||
@ -149,20 +110,11 @@ operation 的 flat 阶段。`etaf-performance-records` 返回 operation/stage
|
||||
|
||||
## 加载与验证
|
||||
|
||||
先安装 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 v2；provider 缺失、格式错误或不兼容时，
|
||||
ETAF 会在 bootstrap 阶段 fail closed。
|
||||
|
||||
ETAF 为当前 Emacs 进程 snapshot 一个不可变的 v2 render port。按依赖顺序升级时，
|
||||
也接受 Ebox 过渡期的 TP 双能力 manifest，因为其中包含所需的 v2 协议；ETAF
|
||||
不会调用已经退役的 v1 capability。
|
||||
ECSS 0.1.0 与 TP 1.0.0 是互相独立的包，安装顺序任意；两者都安装后再安装 Ebox 2.0.0，最后安装 ETAF。ETAF 只使用 Ebox 2.0 的公共渲染契约。
|
||||
|
||||
开发时先把同级 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)
|
||||
|
||||
@ -45,6 +45,7 @@ These are mechanisms rather than additional visual node types:
|
||||
- `watch` observes reactive state.
|
||||
- `Context` provides inherited dependencies.
|
||||
- `Data` owns application-data state and source requests.
|
||||
- `raw-ebox` is the explicit low-level escape at the ETAF/Ebox boundary.
|
||||
|
||||
## 3. The unified View grammar
|
||||
|
||||
@ -61,10 +62,10 @@ Properties must be complete before the first child. A child can be a string, a n
|
||||
(etaf-view
|
||||
(column
|
||||
:class "welcome"
|
||||
(text :font-weight 'bold "Hello")
|
||||
(text :face 'bold "Hello")
|
||||
(text
|
||||
:color "#687386"
|
||||
(expr (if ready "Ready" "Waiting")))))
|
||||
(expr :value (if ready "Ready" "Waiting")))))
|
||||
```
|
||||
|
||||
An attribute appearing after a child is invalid because the two regions may
|
||||
@ -77,20 +78,21 @@ not be interleaved.
|
||||
The rule is simple:
|
||||
|
||||
1. Structural View positions are not quoted. This includes `etaf-view`, Hosts, Component calls, children, slot forms, and static Component styles.
|
||||
2. Elisp expression positions follow normal Elisp evaluation. This includes attribute values, `:key`, `:on-*`, `:use`, `expr`, `:setup`, Context values, Behavior constructors, and Actions.
|
||||
2. Elisp expression positions follow normal Elisp evaluation. This includes attribute values, `:key`, `:on-*`, `:use`, `expr :value`, `:setup`, Context values, Behavior constructors, Actions, and `raw-ebox :value`.
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(text
|
||||
:color (if dark "#F4F6FB" "#1F2328")
|
||||
(expr label)))
|
||||
:face (if dark 'light 'dark)
|
||||
(expr :value label)))
|
||||
|
||||
(etaf-view
|
||||
(column
|
||||
(expr
|
||||
:value
|
||||
(when open
|
||||
(etaf-view
|
||||
(text :font-weight 'bold "Details"))))))
|
||||
(text :face 'bold "Details"))))))
|
||||
```
|
||||
|
||||
`'bold` is an ordinary Elisp literal symbol. `'(text "Details")` is ordinary data, not a View; use `(etaf-view (text "Details"))` when an Elisp expression must construct a View. ETAF does not run `eval` on quoted View data and does not add separate literal/eval nodes.
|
||||
@ -102,40 +104,30 @@ Attribute values do not need an `expr` wrapper. `expr` exists only because the c
|
||||
`expr` accepts exactly one property and no children:
|
||||
|
||||
```elisp
|
||||
(expr ELISP-EXPRESSION)
|
||||
(expr :value ELISP-EXPRESSION)
|
||||
```
|
||||
|
||||
It evaluates the expression, then accepts a string, typed View, proper typed
|
||||
View sequence, or `nil`. It creates no Ebox wrapper, identity, lifecycle,
|
||||
watcher, or effect. `if`, `when`, `cond`, `let`, `mapcar`, `cl-loop`, and other
|
||||
Elisp forms remain ordinary Elisp inside the form.
|
||||
It evaluates the expression, then accepts a string, View, sequence, or `nil`. It creates no Ebox wrapper, identity, lifecycle, watcher, or effect. `if`, `when`, `cond`, `let`, `mapcar`, `cl-loop`, and other Elisp forms remain ordinary Elisp inside `:value`.
|
||||
|
||||
The current core has no file-facing `.etaf` pair loader. `etaf-define-component` is the structure/style/behavior unit: its View defines structure, `:styles` owns presentation rules, and `:setup` owns retained state, events, and lifecycle behavior. A future `.etaf` single-file component format belongs in a compiler layer that lowers into this same public View and Component contract; it is not a second runtime grammar.
|
||||
|
||||
## 4. Components
|
||||
|
||||
The public definition macro has four keywords. Choose exactly one frontend;
|
||||
the other two clauses are optional:
|
||||
The public definition macro has exactly three keywords:
|
||||
|
||||
```text
|
||||
```elisp
|
||||
(etaf-define-component NAME (&key PROPS)
|
||||
DOCSTRING?
|
||||
:setup OPAQUE-STATE-FORM
|
||||
:view VIEW
|
||||
:styles (styles RULE...))
|
||||
|
||||
(etaf-define-component NAME (&key PROPS)
|
||||
DOCSTRING?
|
||||
:setup OPAQUE-STATE-FORM
|
||||
:render ORDINARY-ELISP
|
||||
:setup SETUP
|
||||
:styles (styles RULE...))
|
||||
```
|
||||
|
||||
`: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.
|
||||
`:view` and `:setup` are mutually exclusive. `:styles` is optional and may appear once. Props are the only declared business inputs; ordinary trailing children and named slots are normalized separately into the Component's slot collection.
|
||||
|
||||
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.
|
||||
|
||||
@ -146,39 +138,36 @@ The Component definition is the current structure/style/behavior boundary. Keep
|
||||
"Render a status label."
|
||||
:view
|
||||
(text
|
||||
:font-weight 'bold
|
||||
(expr label)))
|
||||
:face 'bold
|
||||
(expr :value label)))
|
||||
```
|
||||
|
||||
```elisp
|
||||
(etaf-define-component disclosure (&key title)
|
||||
"Render a retained disclosure."
|
||||
:setup
|
||||
(etaf-ref nil)
|
||||
:view
|
||||
(column
|
||||
(text
|
||||
:role 'button
|
||||
:on-press
|
||||
(let ((open (etaf-state)))
|
||||
(lambda ()
|
||||
(setf (etaf-value open)
|
||||
(not (etaf-value open)))))
|
||||
(expr (if (etaf-value (etaf-state)) "Hide" "Show")))
|
||||
(expr
|
||||
(when (etaf-value (etaf-state))
|
||||
(etaf-view (text (expr title)))))))
|
||||
(let ((open (etaf-ref nil)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(column
|
||||
(text
|
||||
:role 'button
|
||||
:on-press
|
||||
(lambda ()
|
||||
(setf (etaf-value open)
|
||||
(not (etaf-value open))))
|
||||
(expr :value (if (etaf-value open) "Hide" "Show")))
|
||||
(expr
|
||||
:value
|
||||
(when (etaf-value open)
|
||||
(etaf-view (text (expr :value title))))))))))
|
||||
```
|
||||
|
||||
`:setup` runs once for a retained Component instance and returns one opaque state
|
||||
value. `etaf-state` returns that exact value during `:view` or `:render`.
|
||||
Re-render reads current props and state without rerunning setup. Setup is the
|
||||
owner for local refs, computed values, watches, Effects, and cleanup
|
||||
registration; it never returns a render function.
|
||||
`:setup` runs once for a retained Component instance and must return a zero-argument render function. Re-render reads current props and refs without rerunning setup. Setup is the owner for local refs, computed values, watches, Effects, and cleanup registration.
|
||||
|
||||
`: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.
|
||||
`:key` is stable identity metadata, not a business prop. On a Component call it selects the retained Component instance within the sibling scope; on a Host or `raw-ebox` it is forwarded as the Ebox node key. If a render candidate fails, the Runtime restores the previous instance, handlers, behaviors, and buffer.
|
||||
|
||||
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.
|
||||
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.
|
||||
|
||||
## 5. Children and slots
|
||||
|
||||
@ -204,7 +193,7 @@ Named content uses the same structural shape:
|
||||
```elisp
|
||||
(card
|
||||
:title "Account"
|
||||
(slot :name 'header (text :font-weight 'bold "Account settings"))
|
||||
(slot :name 'header (text :face 'bold "Account settings"))
|
||||
(text "Card body"))
|
||||
```
|
||||
|
||||
@ -212,26 +201,19 @@ Inside a Component View, the default outlet and its fallback are:
|
||||
|
||||
```elisp
|
||||
(slot)
|
||||
(slot (text :color "#687386" "No content"))
|
||||
(slot (text :face 'shadow "No content"))
|
||||
```
|
||||
|
||||
The explicit normalized spelling is:
|
||||
|
||||
```elisp
|
||||
(slot :name 'default (text :color "#687386" "No content"))
|
||||
(slot :name 'default (text :face 'shadow "No content"))
|
||||
```
|
||||
|
||||
Named slot names are stable non-keyword symbols. Strings, numbers, variables, and runtime expressions are rejected because a slot name is part of retained structure. A named input may appear only once. An explicitly empty input `(slot :name 'header)` suppresses the outlet fallback. Slot forms do not create Ebox wrappers.
|
||||
|
||||
Inside a Component, `slot` projects content. In a Component call's child region, `slot :name` contributes content. The compiler uses the same normalized slot representation for both roles.
|
||||
|
||||
Authored slot expressions retain their author's props, state, and Context across
|
||||
the entire projected subtree. A Component created in that subtree owns its own
|
||||
props, state, styles, and Scope, inheriting Context from the slot author. The
|
||||
receiver's own fallback, ordinary children, and View-producing callbacks use
|
||||
the receiver environment instead. Table/Grid cell callbacks keep the same
|
||||
ordinary rule: their Context is the consuming Table/Grid location.
|
||||
|
||||
## 6. Core Hosts and Ebox
|
||||
|
||||
ETAF core intentionally provides only minimal, unstyled Hosts:
|
||||
@ -256,9 +238,18 @@ Strings are the smallest text View and lower to Ebox content. Nested `text` View
|
||||
|
||||
`grid` reuses Ebox's public two-dimensional layout contract. Its properties include track templates, `auto`/fractional/`minmax` tracks, gaps, row/column placement, spans, auto-flow, and item alignment. Ebox owns track measurement and placement; ETAF only maps the `grid` Host into that node. Ebox's optional native reflow backend is not required for correctness; a Grid tree uses the ordinary Ebox renderer when that backend does not support the node.
|
||||
|
||||
ETAF's Renderer is the only framework module that lowers View semantics into Ebox nodes, properties, and Host queries; `etaf-render-port.el` is the only module that probes the versioned Ebox framework SPI and selects a publication route. Both use only public Ebox APIs, while Runtime reads the already-selected immutable port instead of guessing the Ebox version. Ebox does not know about Components, slots, Actions, Context, Behaviors, or Data.
|
||||
ETAF's Renderer is the only framework module that calls Ebox. It uses Ebox public constructors, property readers, host-reference queries, and publication APIs. Ebox does not know about Components, slots, Actions, Context, Behaviors, or Data.
|
||||
|
||||
The public View grammar does not accept raw Ebox Nodes. Framework integrations construct canonical TextNode and BoxNode values through Ebox's typed integration port, while ordinary ETAF applications stay on Hosts and Components. This keeps measurement, identity, and rollback ownership inside one lowering path.
|
||||
`raw-ebox` is the one deliberate escape:
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(raw-ebox
|
||||
:key 'backend-row
|
||||
:value (ebox-create :content "Low-level")))
|
||||
```
|
||||
|
||||
It accepts only `:value` and optional `:key`. The returned Ebox Node remains opaque and does not receive Component props, slots, events, or Behaviors. Using it transfers measurement, identity, rollback, and backend responsibility to the caller.
|
||||
|
||||
## 7. Runtime and reactive state
|
||||
|
||||
@ -315,19 +306,6 @@ Use `etaf-action-define` and `etaf-dispatch` when the mutation is named and shar
|
||||
|
||||
`etaf-behavior-create` accepts the reserved `:install` attribute for an optional zero-argument installer. The installer may return a cleanup function; `etaf-current-behavior-context` exposes the current Runtime, structural path, and Host props while it runs. Installer state is disposed when the Behavior is replaced or its owner is unmounted.
|
||||
|
||||
Interaction composition is deterministic. An explicit Host `:on-*` callback
|
||||
runs first, followed by Behavior callbacks in declaration order; an error
|
||||
short-circuits the remaining callbacks. For non-event attributes the explicit
|
||||
Host value wins, otherwise the first declaring Behavior wins. Behavior names
|
||||
must be unique on one Host before any installer runs. Stable installer identity
|
||||
is reused, and every installed cleanup runs exactly once. Events dispatch only
|
||||
to the exact Host reference: ETAF has no capture or bubble phase.
|
||||
|
||||
Action names should be application- or feature-prefixed symbols. Duplicate
|
||||
registration is an error by default. `etaf-action-redefine-run` is the explicit
|
||||
authoring/reload boundary; replacement affects future name-based dispatch and
|
||||
does not flush a mounted Runtime.
|
||||
|
||||
Runtime events are dispatched through `etaf-dispatch-event`, and focus/hit testing use public Ebox Host-reference queries through `etaf-activate`, `etaf-focus`, `etaf-focus-next`, `etaf-host-ref-bounds`, and `etaf-host-ref-position`.
|
||||
|
||||
## 9. Context, Theme, Data, and Resource
|
||||
@ -336,50 +314,34 @@ Runtime events are dispatched through `etaf-dispatch-event`, and focus/hit testi
|
||||
|
||||
Context is an inherited Component Scope environment:
|
||||
|
||||
<!-- etaf-example: context -->
|
||||
```elisp
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component service-consumer ()
|
||||
"Read the inherited service."
|
||||
:setup (etaf-inject 'service nil t)
|
||||
:view (text (expr (format "Service: %s" (etaf-value (etaf-state))))))
|
||||
|
||||
(etaf-define-component service-provider ()
|
||||
"Provide a reactive service to its own child Component."
|
||||
"Provide a reactive service to descendants."
|
||||
:setup
|
||||
(let ((service (etaf-ref "demo-service")))
|
||||
(etaf-provide 'service service)
|
||||
service)
|
||||
:view (service-consumer))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
|
||||
(etaf-mount "*etaf-context*" (etaf-view (service-provider)))
|
||||
(etaf-define-component service-consumer ()
|
||||
"Read the inherited service."
|
||||
:setup
|
||||
(let ((service (etaf-inject 'service nil t)))
|
||||
(lambda ()
|
||||
(etaf-view (text (expr :value (etaf-value service)))))))
|
||||
|
||||
(etaf-view (service-provider (service-consumer)))
|
||||
```
|
||||
|
||||
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:
|
||||
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:
|
||||
|
||||
<!-- etaf-example: theme -->
|
||||
```elisp
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component themed-shell ()
|
||||
"Provide semantic colors to its own View."
|
||||
"Provide default text colors to a subtree."
|
||||
:setup
|
||||
(etaf-theme-provide
|
||||
'(:text-color "#F4F6FB" :surface-color "#202634"))
|
||||
:view
|
||||
(text :ref 'themed-content
|
||||
:color (etaf-theme-token :text-color)
|
||||
:background-color (etaf-theme-token :surface-color)
|
||||
"Themed content"))
|
||||
|
||||
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
|
||||
(progn
|
||||
(etaf-theme-provide
|
||||
'(:color "#F4F6FB" :bgcolor "#202634"))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
```
|
||||
|
||||
Palette resolution remains a Theme concern, not a UI catalog concern. Core
|
||||
@ -478,90 +440,6 @@ through one outer reactive dispatch. A local owner evaluates into a candidate
|
||||
generation and Ebox logical replacement; disjoint owners are coalesced into
|
||||
one TP/Ebox publication. The Root owner is the only complete-root adapter.
|
||||
|
||||
The sole mutable pointer to the committed semantic generation belongs to
|
||||
`etaf-generation-authority`. Public handler and Host-property queries read that
|
||||
generation directly. Same-named Runtime hash tables are one-way compatibility
|
||||
mirrors rebuilt from the generation; they neither authorize queries nor write
|
||||
back into it. The migration-only `legacy`, `project`, and `shadow` routes prove
|
||||
projection equivalence and rollback safety without introducing a second
|
||||
committed truth.
|
||||
|
||||
At process bootstrap, `etaf-render-port` requires Ebox framework SPI v2 and
|
||||
snapshots exactly one immutable port. A missing, malformed, or incompatible
|
||||
provider fails closed before any Runtime is mounted. The ordered dependency
|
||||
upgrade may expose either a transitional TP v1+v2 manifest or the final v2-only
|
||||
manifest; both prove the required v2 capability, and ETAF never calls a v1
|
||||
operation. A mounted or in-flight Runtime never switches ports.
|
||||
|
||||
Each semantic candidate captures the expected generation, semantic token, and
|
||||
instance/resource/artifact/route store versions. The render path stages one CAS
|
||||
inside the Ebox framework callback and restores it through the same inverse
|
||||
journal on failure. A semantic-only change runs that CAS under ETAF ownership
|
||||
without creating an Ebox commit or TP revision. Mirror projection and obsolete
|
||||
route cleanup after CAS are postcommit work and cannot reverse the committed
|
||||
token if they fail. Such failures are retained in the retirement diagnostic
|
||||
journal and re-signaled with the same committed trailer used by lifecycle
|
||||
failures; they never re-enter semantic rollback.
|
||||
|
||||
Each mounted Runtime also owns a distinct Host authority containing `state /
|
||||
opaque token / version`. The initial v2 framework stage enters only a
|
||||
provisional state and registers a fixed-slot TP final marker; the Host becomes
|
||||
attached only when buffer final accept succeeds. Public lookup, events, and
|
||||
source routes validate both attached state and token. Detach invalidates the
|
||||
token at one O(1) boundary before removing registries, routes, Component scopes,
|
||||
or Behaviors, so cleanup volume or failure cannot revive the old Host.
|
||||
|
||||
Lifecycle callbacks and structural cleanup run after that commit boundary in
|
||||
an `etaf-retirement-journal`. Every entry has a stable identity, ordering key,
|
||||
attempt count, policy, and terminal state. Public mounted, updated, and
|
||||
unmounted callbacks are run once; the first public failure abandons later
|
||||
public callbacks while structural cleanup continues. Idempotent framework
|
||||
cleanup has a bounded retry count, and contained cleanup records diagnostics
|
||||
without changing the committed generation, Ebox revision, or Host authority.
|
||||
Completed journals are retained separately from committed outcomes on the
|
||||
Runtime, with a bounded history.
|
||||
|
||||
When an explicit operation must expose a postcommit callback failure, ETAF
|
||||
re-signals the original condition symbol and preserves its original data as a
|
||||
prefix. It appends one fixed `:etaf-condition-trailer/v1` datum containing the
|
||||
operation, outcome, generation, Ebox revision, and diagnostic-journal IDs.
|
||||
`etaf-condition-postcommit-info` validates and reads that trailer, so callers
|
||||
can distinguish “committed, then callback failed” from a rollback failure.
|
||||
The buffer-kill path drains or contains retirement work but never throws a
|
||||
retirement condition from the kill hook.
|
||||
|
||||
Reactive publication is coordinated by an explicit `etaf-scheduler-context`.
|
||||
The context owns the source and Runtime FIFOs, their dedupe sets, effect claims,
|
||||
turn and projection epochs, nesting/busy state, fault diagnostics, and cost
|
||||
counters; it does not own Component, resource, or generation state. Existing
|
||||
callers use `etaf-scheduler-default-context`, while a mount may supply
|
||||
`:scheduler-context` to isolate its dispatch authority. Scopes, Effects, and
|
||||
opaque Runtime routes inherit and retain that context.
|
||||
|
||||
One logical projection groups every changed source by its live subscriber
|
||||
contexts in one subscriber-table scan before draining. Source propagation
|
||||
settles across all touched contexts before any Runtime callback publishes.
|
||||
Within a context, each source and Effect is delivered once per scheduler turn,
|
||||
and multiple changed sources enqueue a Runtime once. A reentrant write to an
|
||||
already delivered source is deferred to the next turn; a per-context turn
|
||||
budget contains cross-context cycles with reusable fault diagnostics. A source
|
||||
wave snapshots the current FIFO, so newly discovered distinct sources consume
|
||||
another budgeted turn and cannot monopolize one drain. Dedupe in one context
|
||||
never suppresses another, and registry/token/Host validation filters stale
|
||||
Runtime routes before fan-out.
|
||||
|
||||
Runtime callbacks are detached as a turn, so a lifecycle write enters the
|
||||
following turn. One failing callback is retained as the context fault only
|
||||
after every later callback in that detached turn has run. Data success/error
|
||||
multi-ref publication and event/action callbacks use this same projection
|
||||
boundary, while the legacy facade continues through the default context. Data
|
||||
source failures update the Controller error state; a later projection/render
|
||||
failure propagates unchanged and cannot be reclassified as a source failure.
|
||||
Runtime operation reports include both the local context deltas and full
|
||||
cross-context projection summaries for source
|
||||
delivery, subscriber visits, effect work, Runtime work, stale drops, turns,
|
||||
and faults.
|
||||
|
||||
Each Runtime flush records a candidate-aware effect tuple containing the
|
||||
generation id, effect-to-source edges and source versions, plus an immutable
|
||||
semantic-node stamp for candidate input/context/output facts. A repeated tuple
|
||||
@ -592,5 +470,6 @@ Before adding a new concept, choose the smallest existing owner:
|
||||
| Cross-depth dependency | Context |
|
||||
| Request or mutation state | Data / Resource |
|
||||
| Geometry or layout algorithm | Ebox |
|
||||
| Low-level backend escape | `raw-ebox` |
|
||||
|
||||
Add a new public concept only when an existing owner cannot express the behavior, the new owner can state identity/lifecycle/error/rollback rules, and a public-path test can prove it. This keeps the model small while retaining full Elisp expressiveness.
|
||||
|
||||
@ -45,6 +45,7 @@ ETAF 是面向文本应用的统一 View 与 Component 层。Elisp 仍然是完
|
||||
- `watch` 观察响应式状态。
|
||||
- `Context` 提供继承的依赖。
|
||||
- `Data` 管理应用数据状态和数据源请求。
|
||||
- `raw-ebox` 是 ETAF/Ebox 边界上的明确底层出口。
|
||||
|
||||
## 3. 统一 View 语法
|
||||
|
||||
@ -61,10 +62,10 @@ ATTRIBUTE = :KEY VALUE
|
||||
(etaf-view
|
||||
(column
|
||||
:class "welcome"
|
||||
(text :font-weight 'bold "Hello")
|
||||
(text :face 'bold "Hello")
|
||||
(text
|
||||
:color "#687386"
|
||||
(expr (if ready "Ready" "Waiting")))))
|
||||
(expr :value (if ready "Ready" "Waiting")))))
|
||||
```
|
||||
|
||||
属性出现在子节点之后时，属性区和子节点区被交错，属于非法结构。
|
||||
@ -76,20 +77,21 @@ ATTRIBUTE = :KEY VALUE
|
||||
规则只有两条：
|
||||
|
||||
1. 结构性 View 位置不需要 quote，包括 `etaf-view`、Host、Component 调用、子节点、slot 和静态 Component styles。
|
||||
2. Elisp 表达式位置遵循普通 Elisp 求值，包括属性值、`:key`、`:on-*`、`:use`、`expr`、`:setup`、Context 值、Behavior 构造器和 Action。
|
||||
2. Elisp 表达式位置遵循普通 Elisp 求值，包括属性值、`:key`、`:on-*`、`:use`、`expr :value`、`:setup`、Context 值、Behavior 构造器、Action 以及 `raw-ebox :value`。
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(text
|
||||
:color (if dark "#F4F6FB" "#1F2328")
|
||||
(expr label)))
|
||||
:face (if dark 'light 'dark)
|
||||
(expr :value label)))
|
||||
|
||||
(etaf-view
|
||||
(column
|
||||
(expr
|
||||
:value
|
||||
(when open
|
||||
(etaf-view
|
||||
(text :font-weight 'bold "Details"))))))
|
||||
(text :face 'bold "Details"))))))
|
||||
```
|
||||
|
||||
`'bold` 是普通 Elisp 字面量 symbol。`'(text "Details")` 只是普通数据，不是 View；当 Elisp 表达式需要构造 View 时，使用 `(etaf-view (text "Details"))`。ETAF 不会对被 quote 的 View 数据再次 `eval`，也不增加单独的 literal/eval 节点。
|
||||
@ -101,36 +103,30 @@ ATTRIBUTE = :KEY VALUE
|
||||
`expr` 只接受一个属性且不能有子节点：
|
||||
|
||||
```elisp
|
||||
(expr ELISP-EXPRESSION)
|
||||
(expr :value ELISP-EXPRESSION)
|
||||
```
|
||||
|
||||
它执行表达式，然后接受字符串、typed View、typed View proper sequence 或 `nil`。
|
||||
它不创建 Ebox wrapper、identity、生命周期、watch 或 effect。`if`、`when`、`cond`、
|
||||
`let`、`mapcar`、`cl-loop` 等仍是 form 中的普通 Elisp。
|
||||
它执行表达式，然后接受字符串、View、View 序列或 `nil`。它不创建 Ebox wrapper、identity、生命周期、watch 或 effect。`if`、`when`、`cond`、`let`、`mapcar`、`cl-loop` 等 Elisp 形式仍然只是 `:value` 中的普通 Elisp。
|
||||
|
||||
当前 core 没有面向文件的 `.etaf` pair loader。`etaf-define-component` 才是结构/样式/行为单元：View 定义结构，`:styles` 负责 presentation，`:setup` 负责 retained state、事件和生命周期行为。未来的 `.etaf` SFC 属于把结果 lowering 到同一套公共 View/Component 契约的 compiler layer，而不是第二套 Runtime 语法。
|
||||
|
||||
## 4. Component
|
||||
|
||||
公共定义宏有四个关键字。两个 frontend 必须二选一，另外两个 clause 可选：
|
||||
公共定义宏只有三个关键字：
|
||||
|
||||
```text
|
||||
```elisp
|
||||
(etaf-define-component NAME (&key PROPS)
|
||||
DOCSTRING?
|
||||
:setup OPAQUE-STATE-FORM
|
||||
:view VIEW
|
||||
:styles (styles RULE...))
|
||||
|
||||
(etaf-define-component NAME (&key PROPS)
|
||||
DOCSTRING?
|
||||
:setup OPAQUE-STATE-FORM
|
||||
:render ORDINARY-ELISP
|
||||
:setup SETUP
|
||||
:styles (styles RULE...))
|
||||
```
|
||||
|
||||
`:view` 和 `:render` 互斥且必须恰好出现一个。`:render` 是普通 Elisp，可以返回
|
||||
`etaf-view` 或程序化构造的 `etaf-node`；两者共用 View 编译、prop 校验与 slot
|
||||
投影，不增加另一套表示或状态模型。`:setup` 与 `:styles` 可选且各最多出现一次。Props 是唯一需要声明的业务输入；普通尾部子节点和命名 slot 会被规范化为 Component 的 slot 集合。
|
||||
`:view` 和 `:setup` 互斥；`:styles` 可选且最多出现一次。Props 是唯一需要声明的业务输入；普通尾部子节点和命名 slot 会被规范化为 Component 的 slot 集合。
|
||||
|
||||
Component definition 是当前结构/样式/行为边界：动态状态、Action callback 和生命周期工作放进 `:setup`，静态 presentation 放进 `:styles`。未来 `.etaf` SFC compiler 可以生成这些 definition，但 Runtime 不会直接加载 `.etaf` 文件。
|
||||
|
||||
@ -141,38 +137,36 @@ Component definition 是当前结构/样式/行为边界：动态状态、Action
|
||||
"Render a status label."
|
||||
:view
|
||||
(text
|
||||
:font-weight 'bold
|
||||
(expr label)))
|
||||
:face 'bold
|
||||
(expr :value label)))
|
||||
```
|
||||
|
||||
```elisp
|
||||
(etaf-define-component disclosure (&key title)
|
||||
"Render a retained disclosure."
|
||||
:setup
|
||||
(etaf-ref nil)
|
||||
:view
|
||||
(column
|
||||
(text
|
||||
:role 'button
|
||||
:on-press
|
||||
(let ((open (etaf-state)))
|
||||
(lambda ()
|
||||
(setf (etaf-value open)
|
||||
(not (etaf-value open)))))
|
||||
(expr (if (etaf-value (etaf-state)) "Hide" "Show")))
|
||||
(expr
|
||||
(when (etaf-value (etaf-state))
|
||||
(etaf-view (text (expr title)))))))
|
||||
(let ((open (etaf-ref nil)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(column
|
||||
(text
|
||||
:role 'button
|
||||
:on-press
|
||||
(lambda ()
|
||||
(setf (etaf-value open)
|
||||
(not (etaf-value open))))
|
||||
(expr :value (if (etaf-value open) "Hide" "Show")))
|
||||
(expr
|
||||
:value
|
||||
(when (etaf-value open)
|
||||
(etaf-view (text (expr :value title))))))))))
|
||||
```
|
||||
|
||||
`:setup` 对一个 retained Component instance 只运行一次，返回一个 opaque 状态值。
|
||||
`:view` 或 `:render` 中用 `etaf-state` 取得这个准确值。重新渲染读取当前 props 和
|
||||
state，不重新运行 setup。setup 负责局部 ref、computed、watch、Effect 和 cleanup，
|
||||
不返回 render 函数。
|
||||
`:setup` 对一个 retained Component instance 只运行一次，并且必须返回零参数 render 函数。重新渲染读取当前 props 和 ref，不重新运行 setup。setup 负责局部 ref、computed、watch、Effect 和 cleanup 的创建。
|
||||
|
||||
`:key` 是稳定的 identity metadata，不是业务 prop。放在 Component 调用上时，它选择同级作用域内要保留的 Component instance；放在 Host 上时，它会作为 Ebox node key 向下传递。候选渲染失败时，Runtime 恢复旧 instance、handlers、Behaviors 和 buffer。
|
||||
`:key` 是稳定的 identity metadata，不是业务 prop。放在 Component 调用上时，它选择同级作用域内要保留的 Component instance；放在 Host 或 `raw-ebox` 上时，它会作为 Ebox node key 向下传递。候选渲染失败时，Runtime 恢复旧 instance、handlers、Behaviors 和 buffer。
|
||||
|
||||
Component 调用使用定义时准确注册的名称，注册表不会自动生成省略前缀或 `-view` alias。官方目录组件使用 `etaf-button` 等名称；应用可以显式使用任何合法且尚未占用的名称定义自己的组件。
|
||||
在 View 语法中，Component 的规范名称可以省略 `etaf-` 前缀。如果短名称会与 Elisp 函数、special form 或 Host 冲突，注册表会分配语义明确的 `-view` alias。普通 Elisp API，例如 `etaf-value`、`etaf-ref` 和 `etaf-mount`，始终保留前缀。
|
||||
|
||||
## 5. children 与 slot
|
||||
|
||||
@ -198,7 +192,7 @@ children 只是匿名/默认 slot 的便捷写法，不是第二套内容模型
|
||||
```elisp
|
||||
(card
|
||||
:title "Account"
|
||||
(slot :name 'header (text :font-weight 'bold "Account settings"))
|
||||
(slot :name 'header (text :face 'bold "Account settings"))
|
||||
(text "Card body"))
|
||||
```
|
||||
|
||||
@ -206,25 +200,19 @@ children 只是匿名/默认 slot 的便捷写法，不是第二套内容模型
|
||||
|
||||
```elisp
|
||||
(slot)
|
||||
(slot (text :color "#687386" "No content"))
|
||||
(slot (text :face 'shadow "No content"))
|
||||
```
|
||||
|
||||
完整的内部规范写法是：
|
||||
|
||||
```elisp
|
||||
(slot :name 'default (text :color "#687386" "No content"))
|
||||
(slot :name 'default (text :face 'shadow "No content"))
|
||||
```
|
||||
|
||||
对用户来说，优先使用前两个简写；只有需要明确名字时才写 `:name`。Slot 名称必须是稳定的、非 keyword 的 symbol。字符串、数字、变量和运行时表达式都会被拒绝，因为 slot 名称属于 retained 结构。同名输入只能出现一次。显式空输入 `(slot :name 'header)` 会抑制 outlet fallback。Slot form 不创建 Ebox wrapper。
|
||||
|
||||
在 Component 内，`slot` 表示投影；在 Component 调用的子节点区，带 `:name` 的 `slot` 表示贡献内容。编译器对两种位置使用同一个规范化 slot 表示。
|
||||
|
||||
Slot 中作者写下的表达式在整个投影子树中保留作者的 props、state 和 Context。
|
||||
其中创建的 Component 拥有自己的 props、state、styles 和 Scope，但其 Context
|
||||
从 slot 作者环境继承。接收方自己定义的 fallback、普通子节点和产生 View 的
|
||||
callback 使用接收方环境。Table/Grid 的 cell callback 遵循相同的普通规则：
|
||||
Context 来自消费它的 Table/Grid 所在位置。
|
||||
|
||||
## 6. Core Host 与 Ebox
|
||||
|
||||
ETAF core 只提供最小且无样式的 Host：
|
||||
@ -249,9 +237,18 @@ text · fragment · container · row · column · stack · flex · grid · space
|
||||
|
||||
`grid` 复用 Ebox 的公共二维布局契约，支持轨道模板、`auto`/分数/`minmax` 轨道、间距、行列放置、跨度、自动流向和 item 对齐。轨道测量和放置由 Ebox 负责；ETAF 只把 `grid` Host 映射到这个节点。Ebox 的可选 native reflow 后端不参与正确性保证；如果该后端不支持 Grid，Grid 树会使用普通 Ebox 渲染器。
|
||||
|
||||
ETAF 的 Renderer 是唯一把 View 语义 lower 为 Ebox 节点、属性与 Host 查询的框架模块；`etaf-render-port.el` 是唯一探测 versioned Ebox framework SPI 并选择发布路径的模块。两者都只使用 Ebox 公共 API，Runtime 只读取已经选定的 immutable port，不再自行猜测 Ebox 版本。Ebox 不理解 Component、slot、Action、Context、Behavior 或 Data。
|
||||
ETAF 的 Renderer 是唯一调用 Ebox 的框架模块，并且只使用 Ebox 公共构造器、属性读取器、Host 引用查询和发布 API。Ebox 不理解 Component、slot、Action、Context、Behavior 或 Data。
|
||||
|
||||
公共 View 语法不接受裸 Ebox Node。框架集成层通过 Ebox 的 typed integration port 构造规范的 TextNode 和 BoxNode；普通 ETAF 应用只使用 Host 与 Component。这样 measurement、identity 和 rollback 始终由同一条 lowering 路径负责。
|
||||
`raw-ebox` 是唯一明确的底层出口：
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(raw-ebox
|
||||
:key 'backend-row
|
||||
:value (ebox-create :content "Low-level")))
|
||||
```
|
||||
|
||||
它只接受 `:value` 和可选的 `:key`。返回的 Ebox Node 保持 opaque，不获得 Component props、slot、事件或 Behavior 语义。使用它意味着调用方承担 measurement、identity、rollback 和 backend 契约。
|
||||
|
||||
## 7. Runtime 与响应式状态
|
||||
|
||||
@ -308,16 +305,6 @@ Behavior = 安装多个非视觉能力的可复用 bundle
|
||||
|
||||
`etaf-behavior-create` 接受保留的 `:install` 属性，用于可选的零参数 installer。Installer 可以返回 cleanup；运行期间可通过 `etaf-current-behavior-context` 读取当前 Runtime、结构路径和 Host props。Behavior 被替换或 owner 卸载时，installer 状态会被释放。
|
||||
|
||||
交互组合是确定的：显式 Host `:on-*` callback 先运行，然后按声明顺序运行 Behavior
|
||||
callback；任一错误会 short-circuit 后续 callback。非事件属性由显式 Host 值优先，
|
||||
否则第一个声明该属性的 Behavior 获胜（first-wins）。同一 Host 的 Behavior name 必须在任何
|
||||
installer 运行前保持唯一。稳定 installer identity 会复用，每个已安装 cleanup
|
||||
exactly-once。事件只 dispatch 给准确 Host ref；ETAF 没有 capture 或 bubble 阶段。
|
||||
|
||||
Action name 应使用 application/feature-prefixed symbol。重复注册默认报错。
|
||||
`etaf-action-redefine-run` 是显式 authoring/reload 边界；替换只影响未来按 name 的
|
||||
dispatch，不会 flush 已挂载 Runtime。
|
||||
|
||||
Runtime 事件通过 `etaf-dispatch-event` 进入；命中测试和 focus 通过 Ebox Host 引用查询，并由 `etaf-activate`、`etaf-focus`、`etaf-focus-next`、`etaf-host-ref-bounds` 和 `etaf-host-ref-position` 提供公共入口。
|
||||
|
||||
## 9. Context、Theme、Data 与 Resource
|
||||
@ -326,48 +313,34 @@ Runtime 事件通过 `etaf-dispatch-event` 进入；命中测试和 focus 通过
|
||||
|
||||
Context 是继承的 Component Scope 环境：
|
||||
|
||||
<!-- etaf-example: context -->
|
||||
```elisp
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component service-consumer ()
|
||||
"Read the inherited service."
|
||||
:setup (etaf-inject 'service nil t)
|
||||
:view (text (expr (format "Service: %s" (etaf-value (etaf-state))))))
|
||||
|
||||
(etaf-define-component service-provider ()
|
||||
"Provide a reactive service to its own child Component."
|
||||
"Provide a reactive service to descendants."
|
||||
:setup
|
||||
(let ((service (etaf-ref "demo-service")))
|
||||
(etaf-provide 'service service)
|
||||
service)
|
||||
:view (service-consumer))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
|
||||
(etaf-mount "*etaf-context*" (etaf-view (service-provider)))
|
||||
(etaf-define-component service-consumer ()
|
||||
"Read the inherited service."
|
||||
:setup
|
||||
(let ((service (etaf-inject 'service nil t)))
|
||||
(lambda ()
|
||||
(etaf-view (text (expr :value (etaf-value service)))))))
|
||||
|
||||
(etaf-view (service-provider (service-consumer)))
|
||||
```
|
||||
|
||||
key 使用稳定的普通 symbol。最近的祖先优先，缺失的 required key 触发
|
||||
`etaf-context-error`。在根位置编写的 slot 内容及其子树保留根的空 Context。
|
||||
迁移旧版本中意外继承接收方 Context 的用法时，应把消费者写进 provider 自己的
|
||||
View，或在那里调用普通的 View-producing callback。投影的 slot 继续使用作者
|
||||
环境。Theme 遵循同一套 Context 继承关系，内容是属性 plist：
|
||||
key 使用稳定的普通 symbol。最近的祖先优先，缺失的 required key 触发 `etaf-context-error`。Theme 是一个 Context value，内容是属性 plist：
|
||||
|
||||
<!-- etaf-example: theme -->
|
||||
```elisp
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component themed-shell ()
|
||||
"Provide semantic colors to its own View."
|
||||
"Provide default text colors to a subtree."
|
||||
:setup
|
||||
(etaf-theme-provide
|
||||
'(:text-color "#F4F6FB" :surface-color "#202634"))
|
||||
:view
|
||||
(text :ref 'themed-content
|
||||
:color (etaf-theme-token :text-color)
|
||||
:background-color (etaf-theme-token :surface-color)
|
||||
"Themed content"))
|
||||
|
||||
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
|
||||
(progn
|
||||
(etaf-theme-provide
|
||||
'(:color "#F4F6FB" :bgcolor "#202634"))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
```
|
||||
|
||||
Palette 解析属于 Theme，而不是 UI 目录。core 提供
|
||||
@ -464,78 +437,6 @@ mounted Component、expr、slot、fragment、raw、inline 和 Root owner 都经
|
||||
replacement；不相交 owner 会合并为一次 TP/Ebox publication。只有 Root owner
|
||||
可以进入 complete-root adapter。
|
||||
|
||||
已提交 semantic generation 的唯一 mutable pointer 由
|
||||
`etaf-generation-authority` 持有。handler 与 Host-prop 等公共查询直接读取该
|
||||
generation；Runtime 中同名 hash table 只是由 generation 单向重建的兼容 mirror，
|
||||
既不能独立授权查询，也不能反向改写 generation。迁移期的
|
||||
`legacy`/`project`/`shadow` 路由只用于证明投影等价与安全回退，不增加第二份
|
||||
committed truth。
|
||||
|
||||
进程 bootstrap 时，`etaf-render-port` 要求 Ebox framework SPI v2，并 snapshot
|
||||
唯一的不可变 port。provider 缺失、格式错误或不兼容都会在 Runtime mount 前 fail
|
||||
closed。按依赖顺序升级时，Ebox 可暂时报告 TP v1+v2 双能力 manifest，也可报告最终
|
||||
的 v2-only manifest；两者都证明所需的 v2 capability，ETAF 不会调用 v1 operation。
|
||||
mounted 或 in-flight Runtime 绝不会切换 port。
|
||||
|
||||
每个 semantic candidate 同时捕获 expected generation、semantic token，以及
|
||||
instance/resource/artifact/route store versions。render 路径在 Ebox framework
|
||||
stage 中暂存一次 CAS，失败时由同一个 inverse journal 恢复；没有可见 Ebox
|
||||
变化的 semantic-only 路径由 ETAF 自己执行同一 CAS，不创建 Ebox commit 或 TP
|
||||
revision。CAS 后的 mirror 与旧 route 清理属于 postcommit，失败不能反向恢复已提交
|
||||
token；这类失败会写入 retirement diagnostic journal，并用与 lifecycle failure
|
||||
相同的 committed trailer 重新 signal，绝不会重新进入 semantic rollback。
|
||||
|
||||
每个 mounted Runtime 还拥有独立的 Host authority：`state / opaque token /
|
||||
version`。initial v2 framework stage 只进入 provisional state，并向 TP 注册固定
|
||||
slot final marker；只有 buffer final accept 成功时 Host 才成为 attached。公开
|
||||
lookup、event 和 source route 同时校验 attached state 与 token。detach 先在 O(1)
|
||||
边界让 token 失效，再清理 registry、routes、Component scopes 和 Behaviors；因此
|
||||
cleanup 数量或错误不能让旧 Host 重新获得 authority。
|
||||
|
||||
lifecycle callback 与结构 cleanup 在该 commit boundary 之后进入
|
||||
`etaf-retirement-journal`。每个 entry 都有稳定 identity、ordering key、attempt
|
||||
count、policy 与 terminal state。mounted、updated、unmounted 等公开 callback
|
||||
只运行一次；第一个公开 callback 失败后，后续公开 callback 标记为 abandoned，
|
||||
但结构 cleanup 继续。可幂等的框架 cleanup 只做有上限的重试；contained cleanup
|
||||
只写 diagnostics，不改变已提交 generation、Ebox revision 或 Host authority。
|
||||
Runtime 以有界历史保存已完成 journal，且它们与 committed outcome 分离。
|
||||
|
||||
当显式操作需要向调用者暴露 postcommit callback 错误时，ETAF 会用原 condition
|
||||
symbol 重新 signal，并逐项保留原 condition data 前缀；末尾只追加一个固定
|
||||
`:etaf-condition-trailer/v1` datum，其中包含 operation、outcome、generation、
|
||||
Ebox revision 与 diagnostic-journal ID。`etaf-condition-postcommit-info` 会校验并
|
||||
读取该 trailer，让调用者机械区分“已经提交、随后 callback 失败”和 rollback
|
||||
failure。buffer-kill 路径会 drain 或 contain retirement 工作，但绝不会从 kill
|
||||
hook 抛 retirement condition。
|
||||
|
||||
Reactive publication 由显式 `etaf-scheduler-context` 协调。context 拥有 source
|
||||
与 Runtime FIFO、对应 dedupe set、effect claim、turn/projection epoch、
|
||||
nesting/busy 状态、fault diagnostics 与成本计数器；它不拥有 Component、
|
||||
resource 或 generation state。既有调用者继续使用
|
||||
`etaf-scheduler-default-context`，mount 也可以传入 `:scheduler-context` 隔离
|
||||
dispatch authority。Scope、Effect 与 opaque Runtime route 会继承并保留该
|
||||
context。
|
||||
|
||||
一次 logical projection 会先按 live subscriber context 对所有 changed source
|
||||
在一次 subscriber-table scan 中分组；所有已触及 context 的 source propagation
|
||||
都稳定后，Runtime callback 才能 publish。在同一 context 中，每个 source 与
|
||||
Effect 每个 scheduler turn 只 delivery 一次，多个 changed source 也只 enqueue
|
||||
同一 Runtime 一次。已经 delivery 的 source 若重入写入，会延后到下一个 turn；
|
||||
per-context turn budget 会包含跨 context cycle，并留下可复用的 fault diagnostics。
|
||||
每个 source wave 都会 snapshot 当前 FIFO，因此 wave 中发现的不同 source 必须在
|
||||
下一个受预算约束的 turn 执行，不能垄断一次 drain。context A 的 dedupe 不会压制
|
||||
context B；registry/token/Host 校验会在 fan-out 前过滤 stale Runtime route。
|
||||
|
||||
Runtime callback 先作为一个完整 turn detach，因此 lifecycle write 会进入下一个
|
||||
turn；某个 callback 失败时，scheduler 会先执行该 detached turn 中剩余 callback，
|
||||
再把首个 condition 记录为 context fault。Data success/error 的 multi-ref
|
||||
publication 与 event/action callback 都复用同一个 projection boundary，legacy
|
||||
façade 则继续走 default context。Data source failure 会更新 Controller error state；
|
||||
之后发生的 projection/render failure 保持原 condition，不能被重新归类为 source
|
||||
failure。Runtime operation report 同时携带本 context delta 与完整 cross-context
|
||||
projection summary，覆盖 source delivery、
|
||||
subscriber visit、effect work、Runtime work、stale drop、turn 与 fault。
|
||||
|
||||
每次 Runtime flush 都记录 candidate-aware effect tuple：其中包含 generation id、
|
||||
effect→source 边和 source version，以及 candidate input/context/output facts 的
|
||||
immutable semantic-node stamp。重复 tuple 会报告有序的 effect/edge path；step
|
||||
@ -563,5 +464,6 @@ registry 决定当前 authority。失败 candidate 只移除 staged Behavior res
|
||||
| 跨层级依赖 | Context |
|
||||
| 请求或变更状态 | Data / Resource |
|
||||
| 几何或布局算法 | Ebox |
|
||||
| 低层 backend 出口 | `raw-ebox` |
|
||||
|
||||
只有在现有 owner 无法表达、能够明确 identity/lifecycle/error/rollback 规则，并且可以用公共路径测试证明时，才增加新的公共概念。这样既保留完整的 Elisp 表达能力，又让用户模型保持干净。
|
||||
|
||||
@ -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, exact registered Component names | `tests/etaf-tests.el` structural and syntax tests |
|
||||
| P0 grammar | Unified View shape, property-first parsing, `etaf-view`, `expr :value`, core Hosts, aliases | `tests/etaf-tests.el` structural and syntax tests |
|
||||
| P1 Components | `:view`, `:setup`, props, default/named slots, retained instances, lifecycle, `:key`, raw Ebox escape | Component, slot, mount, prop-update, raw-node, and rollback tests |
|
||||
| P2 Runtime | refs, computed, effects, watches, Scope cleanup, Context, Theme, Behaviors, events, focus, Actions | Mounted event/focus tests, reactive failure rollback, cleanup tests |
|
||||
| P3 presentation | scoped styles, selector matching, Theme precedence, inline text runs, Resource and error boundary | Style, Theme, text-surface, Resource, and error tests |
|
||||
@ -55,26 +55,21 @@ Do not split a file merely to create a shorter name. Split only when a stable re
|
||||
- The only structural form is `(NAME :PROPERTY VALUE ... CHILD ...)`.
|
||||
- All properties precede children.
|
||||
- Attribute values are ordinary Elisp expressions.
|
||||
- The only child computation bridge is `(expr ELISP-EXPRESSION)`; its result
|
||||
may be text, a typed View/proper typed View sequence, or `nil`.
|
||||
- The only child computation bridge is `(expr :value ELISP-EXPRESSION)`.
|
||||
- A dynamic View returned by Elisp is constructed with `(etaf-view ...)` inside `expr`; quoted structural data is never executed.
|
||||
- The six visible Host forms are `text`, `box`, `row`, `column`, `flex`, and `grid`; `fragment`, `slot`, and `expr` are transparent framework structure.
|
||||
- There is no raw Ebox View escape hatch. Framework integrations use Ebox's evaluated typed-constructor port outside the author DSL.
|
||||
- Core Hosts are `text`, `fragment`, `container`, `row`, `column`, `stack`, `flex`, `grid`, and `spacer`.
|
||||
- `raw-ebox` accepts only `:value` and optional `:key` and remains opaque to ETAF semantics.
|
||||
|
||||
### 4.2 Component and slots
|
||||
|
||||
- `etaf-define-component` chooses exactly one of `:view` or `:render`; `:setup`
|
||||
and `:styles` are optional.
|
||||
- `:view` and `:render` are mutually exclusive frontends for one View model;
|
||||
ordinary `:render` may return `etaf-view`, preserving lexical scope and the
|
||||
same compiler prop/slot rules.
|
||||
- `:setup` runs once per retained identity and returns opaque state read with
|
||||
`etaf-state` during either frontend.
|
||||
- `etaf-define-component` accepts only `:view`, `:setup`, and optional `:styles`.
|
||||
- `:view` and `:setup` are mutually exclusive.
|
||||
- `:setup` runs once per retained identity and returns a zero-argument render function.
|
||||
- Props update render without rerunning setup.
|
||||
- Trailing children are `slots.default`; named slot input uses `(slot :name 'NAME CHILD...)`.
|
||||
- Default outlet shorthand is `(slot)` or `(slot FALLBACK...)`.
|
||||
- Slot names are stable, non-keyword symbols only.
|
||||
- `:key` is identity metadata, not a business prop: Component calls use it for retained identity, while Hosts project the same parsed fact into the Ebox source index.
|
||||
- `:key` is identity metadata, not a business prop: Component calls use it for retained identity, while Hosts and `raw-ebox` forward it as an Ebox node key.
|
||||
|
||||
### 4.3 Runtime and non-visual capabilities
|
||||
|
||||
|
||||
@ -18,7 +18,7 @@
|
||||
|
||||
| 里程碑 | 已交付职责 | 证据 |
|
||||
| --- | --- | --- |
|
||||
| P0 grammar | 统一 View 形状、属性优先解析、`etaf-view`、`(expr FORM)`、核心 Host、准确注册的 Component 名称 | `tests/etaf-tests.el` 结构和语法测试 |
|
||||
| P0 grammar | 统一 View 形状、属性优先解析、`etaf-view`、`expr :value`、核心 Host、alias | `tests/etaf-tests.el` 结构和语法测试 |
|
||||
| P1 Component | `:view`、`:setup`、props、默认/命名 slot、retained instance、生命周期、`:key`、raw Ebox 出口 | Component、slot、mount、prop 更新、raw node、rollback 测试 |
|
||||
| P2 Runtime | ref、computed、effect、watch、Scope cleanup、Context、Theme、Behavior、事件、focus、Action | 挂载事件/focus、响应式失败回滚和 cleanup 测试 |
|
||||
| P3 presentation | 作用域样式、selector、Theme 优先级、inline text runs、Resource 和 error boundary | 样式、Theme、文本 surface、Resource、error 测试 |
|
||||
@ -55,25 +55,21 @@
|
||||
- 唯一结构形式是 `(NAME :PROPERTY VALUE ... CHILD ...)`。
|
||||
- 所有属性必须先于所有子节点。
|
||||
- 属性值是普通 Elisp 表达式。
|
||||
- 唯一的子节点计算桥接是 `(expr ELISP-EXPRESSION)`；结果可以是文本、typed View、
|
||||
typed View proper sequence 或 `nil`。
|
||||
- 唯一的子节点计算桥接是 `(expr :value ELISP-EXPRESSION)`。
|
||||
- Elisp 返回动态 View 时，在 `expr` 中用 `(etaf-view ...)` 构造；被 quote 的结构数据永远不会被执行。
|
||||
- 六个可见 Host form 是 `text`、`box`、`row`、`column`、`flex`、`grid`；`fragment`、`slot`、`expr` 是透明的框架结构。
|
||||
- View 作者 DSL 不提供 raw Ebox 逃生口；框架集成在作者 DSL 之外使用 Ebox evaluated typed-constructor 端口。
|
||||
- Core Host 是 `text`、`fragment`、`container`、`row`、`column`、`stack`、`flex`、`grid` 和 `spacer`。
|
||||
- `raw-ebox` 只接受 `:value` 和可选 `:key`，并且对 ETAF 语义保持 opaque。
|
||||
|
||||
### 4.2 Component 与 slot
|
||||
|
||||
- `etaf-define-component` 必须在 `:view` 与 `:render` 中恰好选择一个；`:setup` 与
|
||||
`:styles` 可选。
|
||||
- `:view` 与 `:render` 是同一 View 模型的互斥 frontend；普通 `:render` 可返回
|
||||
`etaf-view`，保留词法作用域与相同的 compiler prop/slot 规则。
|
||||
- `:setup` 对每个 retained identity 只运行一次，返回 opaque 状态，并由两个 frontend
|
||||
中的 `etaf-state` 读取。
|
||||
- `etaf-define-component` 只接受 `:view`、`:setup` 和可选 `:styles`。
|
||||
- `:view` 与 `:setup` 互斥。
|
||||
- `:setup` 对每个 retained identity 只运行一次，返回零参数 render 函数。
|
||||
- Props 更新只重新 render，不重新运行 setup。
|
||||
- 尾部 children 是 `slots.default`；命名 slot 输入使用 `(slot :name 'NAME CHILD...)`。
|
||||
- 默认 outlet 简写是 `(slot)` 或 `(slot FALLBACK...)`。
|
||||
- Slot name 只能是稳定的、非 keyword 的 symbol。
|
||||
- `:key` 是 identity metadata，不是业务 prop：Component 调用用它选择 retained identity，Host 则把同一个解析后的事实投影到 Ebox source index。
|
||||
- `:key` 是 identity metadata，不是业务 prop：Component 调用用它选择 retained identity，Host 和 `raw-ebox` 则把它作为 Ebox node key 向下传递。
|
||||
|
||||
### 4.3 Runtime 与非视觉能力
|
||||
|
||||
|
||||
@ -1,16 +0,0 @@
|
||||
# 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.
|
||||
@ -1,14 +0,0 @@
|
||||
# 迁移到 ETAF 0.2
|
||||
|
||||
ETAF 0.2.1 要求 Ebox 3.0.0 与 TP 2.0.0。安装顺序为 TP、Ebox、ETAF。
|
||||
renderer bootstrap 现在强制要求 Ebox framework SPI v2；provider 缺失、格式错误
|
||||
或不兼容时会 fail closed。
|
||||
|
||||
请删除所有 `etaf-render-port-selection-policy` 配置。v1 render port 及其 initial
|
||||
publication 手工清理路径已经退役。Runtime mount 与 update 始终使用不可变的 SPI
|
||||
v2 port，并保留配对 framework stage/rollback、同对象 report、observation replay、
|
||||
revision 与 Host final marker 契约。
|
||||
|
||||
按依赖顺序从源码升级时，ETAF 接受 Ebox 报告
|
||||
`tp-transaction-protocol-v1+v2` 或 `tp-transaction-protocol-v2`。前者只是包含所需
|
||||
v2 协议的过渡期能力声明；ETAF 不会调用 v1 transaction operation。
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -7,8 +7,6 @@ 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)
|
||||
@ -29,7 +27,7 @@ Properties come first and children come last. `etaf-view` receives an unquoted s
|
||||
```elisp
|
||||
(etaf-view
|
||||
(column
|
||||
(text :font-weight 'bold "Hello")
|
||||
(text :face 'bold "Hello")
|
||||
(text :color "#687386" "Welcome to ETAF")))
|
||||
```
|
||||
|
||||
@ -40,7 +38,7 @@ Mount it into an Emacs buffer:
|
||||
"*etaf-hello*"
|
||||
(etaf-view
|
||||
(column
|
||||
(text :font-weight 'bold "Hello")
|
||||
(text :face 'bold "Hello")
|
||||
(text "This is a text application."))))
|
||||
```
|
||||
|
||||
@ -64,43 +62,11 @@ that viewport directly instead of immediately rerendering:
|
||||
```elisp
|
||||
(ebox-render
|
||||
(etaf-render
|
||||
(etaf-view (text :font-weight 'bold "Pure View"))))
|
||||
(etaf-view (text :face 'bold "Pure View"))))
|
||||
```
|
||||
|
||||
Use `etaf-mount` whenever a View contains a stateful Component, reactive data, events, or lifecycle.
|
||||
|
||||
To request pending work explicitly, call `(etaf-runtime-flush runtime)`.
|
||||
Its return value is now the **integer committed Ebox revision**, replacing the
|
||||
previous Ebox-node return type. Busy or batched work may remain pending; the
|
||||
returned revision identifies the publication currently visible to readers.
|
||||
Calls inside an active Ebox/TP transaction fail before requesting work, since
|
||||
that transaction's revision may still be provisional. Ordinary flushes do not
|
||||
export a tree or force a Root rebuild.
|
||||
|
||||
For a current tree and its matching source facts, request an explicit snapshot:
|
||||
|
||||
```elisp
|
||||
(let* ((runtime (etaf-runtime-for-buffer "*etaf-hello*"))
|
||||
(snapshot (etaf-runtime-snapshot runtime)))
|
||||
(list (plist-get snapshot :revision)
|
||||
(plist-get snapshot :mount-id)
|
||||
(ebox-render (plist-get snapshot :input))))
|
||||
```
|
||||
|
||||
The snapshot contains `:input` (a canonical Ebox input), `:revision`, and
|
||||
`:mount-id` (the identity of this mount). Exporting costs O(N) and detaches
|
||||
ordinary mutable node payload; it does not drain pending work, evaluate
|
||||
Components, publish, or increment the revision. The input remains usable after
|
||||
later commits or unmount. Opaque capabilities such as callbacks keep their
|
||||
identity; the query does not freeze external capabilities or the display
|
||||
environment. Unmounted Runtime and active Ebox/TP transaction queries fail.
|
||||
|
||||
The obsolete `etaf-runtime-root-node` getter remains read-compatible through
|
||||
this O(N) query and returns the current single root. Runtime no longer stores a
|
||||
root mirror. Migrate consumers to `etaf-runtime-snapshot` so the canonical input
|
||||
retains the root's matching source facts; do not treat the obsolete getter as a
|
||||
cheap field read or use it as a mutation target.
|
||||
|
||||
The current core has no direct `.etaf` loader. `etaf-define-component` is the structure/style/behavior unit: use its View for structure, `:styles` for static presentation, and `:setup` for retained state, Actions, and lifecycle. A future `.etaf` SFC belongs to a compiler layer that emits this same Component contract; it is not a second Runtime entry point.
|
||||
|
||||
## 3. Properties and children
|
||||
@ -112,9 +78,9 @@ Attribute values are ordinary Elisp expressions. They do not need an extra `expr
|
||||
(label "Theme"))
|
||||
(etaf-view
|
||||
(text
|
||||
:color (if dark "#F4F6FB" "#1F2328")
|
||||
:background-color "#20242B"
|
||||
(expr label))))
|
||||
:face (if dark 'light 'dark)
|
||||
:color "#F4F6FB"
|
||||
(expr :value label))))
|
||||
```
|
||||
|
||||
The child region is structural. `expr` is the one explicit bridge for ordinary Elisp computation:
|
||||
@ -122,17 +88,14 @@ The child region is structural. `expr` is the one explicit bridge for ordinary E
|
||||
```elisp
|
||||
(etaf-view
|
||||
(column
|
||||
(expr (if loading "Loading..." "Ready"))
|
||||
(expr :value (if loading "Loading..." "Ready"))
|
||||
(expr
|
||||
:value
|
||||
(when open
|
||||
(etaf-view (text :font-style 'italic "Details"))))))
|
||||
(etaf-view (text :face 'italic "Details"))))))
|
||||
```
|
||||
|
||||
`expr` accepts exactly one ordinary Elisp form and no structural children. Its
|
||||
result in structural child positions can be a string, typed Host or Component
|
||||
View, a proper sequence of these values, or `nil`. Inside a `text` Host an
|
||||
expression must return a string.
|
||||
`if`, `when`, `cond`, `let`, `mapcar`, and `cl-loop` remain normal Elisp.
|
||||
`expr` accepts exactly `:value` and no children. Its result can be a string, View, sequence, or `nil`. `if`, `when`, `cond`, `let`, `mapcar`, and `cl-loop` remain normal Elisp inside the value.
|
||||
|
||||
Quote has one ordinary Elisp meaning:
|
||||
|
||||
@ -140,12 +103,7 @@ Quote has one ordinary Elisp meaning:
|
||||
- Quote literal symbols and data lists when Elisp requires data.
|
||||
- Use `(etaf-view ...)` inside an expression when the expression must construct a View.
|
||||
|
||||
For example, `'bold` is the `: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 ...)`.
|
||||
For example, `'bold` is the face symbol, while `'(text "data")` is only data and will not render. A dynamic View must be written as `(etaf-view (text "data"))`.
|
||||
|
||||
The core `grid` Host is the two-dimensional layout choice:
|
||||
|
||||
@ -155,16 +113,16 @@ The core `grid` Host is the two-dimensional layout choice:
|
||||
(etaf-view
|
||||
(grid
|
||||
:width '(640)
|
||||
:grid-template-columns '((200) (fr 1))
|
||||
:grid-template-columns '((200) 1fr)
|
||||
:grid-template-rows '(1 1)
|
||||
:gap '(1 (12))
|
||||
(text :font-weight 'bold "Name")
|
||||
(text :face 'bold "Name")
|
||||
(text "Value")
|
||||
(text "Ada")
|
||||
(text "Lovelace"))))
|
||||
```
|
||||
|
||||
Use `auto`, `min-content`, `max-content`, `(fr FACTOR)`, `(minmax MIN MAX)`, and `(repeat COUNT TRACK-LIST)` in track templates. `:grid-auto-columns` and `:grid-auto-rows` size implicit tracks; `:grid-auto-flow` accepts `row` or `column`. Children may use `:grid-column`, `:grid-row`, `:grid-column-span`, and `:grid-row-span`; Ebox performs measurement, placement, and item/content alignment. The optional native backend falls back to the Elisp Ebox renderer for Grid trees.
|
||||
Use `auto`, `(fr FACTOR)`, symbols such as `1fr`, `(minmax MIN MAX)`, and `(repeat COUNT TRACK)` in track templates. `:grid-auto-columns` and `:grid-auto-rows` size implicit tracks; `:grid-auto-flow` accepts `row` or `column`. Children may use `:grid-column`, `:grid-row`, `:grid-column-span`, and `:grid-row-span`; Ebox performs measurement, placement, and item/content alignment. The optional native backend falls back to the Elisp Ebox renderer for Grid trees.
|
||||
|
||||
## 4. Define a Component
|
||||
|
||||
@ -175,8 +133,8 @@ The beginner form is a stateless `:view` Component:
|
||||
"Render a status label."
|
||||
:view
|
||||
(text
|
||||
:font-weight 'bold
|
||||
(expr label)))
|
||||
:face 'bold
|
||||
(expr :value label)))
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-status*"
|
||||
@ -184,21 +142,20 @@ The beginner form is a stateless `:view` Component:
|
||||
(status-label :label "Connected")))
|
||||
```
|
||||
|
||||
Use the exact name supplied to `etaf-define-component`:
|
||||
The canonical Component name may include the `etaf-` prefix:
|
||||
|
||||
```elisp
|
||||
(etaf-view (status-label :label "Connected"))
|
||||
(etaf-view (etaf-status-label :label "Connected"))
|
||||
```
|
||||
|
||||
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`.
|
||||
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 definition macro accepts only these keywords:
|
||||
|
||||
| Keyword | Meaning |
|
||||
| --- | --- |
|
||||
| `:view` | Declarative View frontend; mutually exclusive with `:render` |
|
||||
| `:render` | Ordinary Elisp returning one typed View, usually with `etaf-view`; programmatic builders may use `etaf-node` |
|
||||
| `:setup` | Optional one-time initialization returning opaque state read with `etaf-state` |
|
||||
| `:view` | The stateless View producer; mutually exclusive with `:setup` |
|
||||
| `:setup` | One-time Component initialization returning a zero-argument render function |
|
||||
| `:styles` | Optional static scoped style declaration |
|
||||
|
||||
There is no separate declaration block for children, slots, events, state, or variants. Props are declared with `(&key ...)`; children and slots are implicit content.
|
||||
@ -211,38 +168,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))
|
||||
(initial-title title))
|
||||
(let ((count (etaf-ref 0)))
|
||||
(etaf-on-mounted
|
||||
(lambda () (message "%s mounted" initial-title)))
|
||||
(lambda () (message "%s mounted" title)))
|
||||
(etaf-on-unmounted
|
||||
(lambda () (message "%s unmounted" initial-title)))
|
||||
count)
|
||||
:render
|
||||
(let ((count (etaf-state))
|
||||
(caption title))
|
||||
(etaf-view
|
||||
(column
|
||||
(text :font-weight 'bold (expr caption))
|
||||
(text (expr (format "Count: %d" (etaf-value count))))
|
||||
(text :role 'button :tab-index 0
|
||||
:on-press (lambda () (cl-incf (etaf-value count)))
|
||||
"Increment")))))
|
||||
(lambda () (message "%s unmounted" title)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(column
|
||||
(text :face 'bold (expr :value title))
|
||||
(text (expr :value (format "Count: %d" (etaf-value count))))
|
||||
(text
|
||||
:role 'button
|
||||
:on-press (lambda () (cl-incf (etaf-value count)))
|
||||
"Increment"))))))
|
||||
```
|
||||
|
||||
Setup runs once for the retained instance and returns one opaque state value.
|
||||
The selected `:view` or `:render` frontend runs on each update and reads that
|
||||
exact value with `etaf-state`. `etaf-on-mounted`, `etaf-on-updated`, and
|
||||
`etaf-on-unmounted` register lifecycle callbacks for that Component instance.
|
||||
Scope disposal automatically stops reactive effects and cleanup.
|
||||
|
||||
`:view` and `:render` share compilation, slot projection, and prop validation.
|
||||
Use ordinary `let`/`let*` to capture state handles or current prop values for
|
||||
callbacks. `etaf-state` is a render-time accessor, not an event-time accessor.
|
||||
Keep reactive `etaf-value` reads inside the property or `expr` that needs the
|
||||
update; extracting a handle does not require reading its value early. Component
|
||||
code with retained closures belongs in an `.el` file with lexical binding.
|
||||
Simple local callbacks need no Action definition.
|
||||
Setup runs once for the retained instance. Its returned render function runs on each update. `etaf-on-mounted`, `etaf-on-updated`, and `etaf-on-unmounted` register lifecycle callbacks for that Component instance. Scope disposal automatically stops reactive effects and cleanup.
|
||||
|
||||
The small reactive API is:
|
||||
|
||||
@ -277,8 +219,8 @@ Trailing children are the anonymous/default slot:
|
||||
"Render a titled panel."
|
||||
:view
|
||||
(column
|
||||
(text :font-weight 'bold (expr title))
|
||||
(slot (text :color "#687386" "No content"))))
|
||||
(text :face 'bold (expr :value title))
|
||||
(slot (text :face 'shadow "No content"))))
|
||||
|
||||
(etaf-view
|
||||
(panel
|
||||
@ -294,8 +236,8 @@ Named slots use `:name` and must use a stable non-keyword symbol:
|
||||
:view
|
||||
(column
|
||||
(slot :name 'header
|
||||
(text :font-weight 'bold (expr title)))
|
||||
(slot (text :color "#687386" "No body"))))
|
||||
(text :face 'bold (expr :value title)))
|
||||
(slot (text :face 'shadow "No body"))))
|
||||
|
||||
(etaf-view
|
||||
(card
|
||||
@ -306,30 +248,6 @@ Named slots use `:name` and must use a stable non-keyword symbol:
|
||||
|
||||
The two default-slot shorthands are `(slot)` and `(slot FALLBACK...)`. The normalized spelling is `(slot :name 'default FALLBACK...)`. At a call site, ordinary children fill `default`; a named input uses `(slot :name 'header CHILD...)`. An explicit empty `(slot :name 'header)` suppresses the fallback. Strings, numbers, variables, and runtime expressions are not valid slot names.
|
||||
|
||||
Slot expressions keep their author's props, state, and Context throughout the
|
||||
projected subtree. Components created inside that subtree still own their own
|
||||
props, state, styles, and Scope; they inherit Context from the slot author's
|
||||
environment. A receiving Component does not inject its own Context into caller
|
||||
content. Its fallback, ordinary children, and View-producing callbacks use its
|
||||
own environment. A Table/Grid cell callback likewise runs in the consuming
|
||||
Table/Grid's Context.
|
||||
|
||||
`expr` may return a typed View or a proper sequence of typed Views at a
|
||||
structural boundary. It never exposes or accepts ETAF's private structs. The
|
||||
same Component can combine a keyed `:for`, a structural expression, and a
|
||||
named footer slot:
|
||||
|
||||
```elisp
|
||||
(etaf-define-component etaf-docs-collection-card (&key items footer-view)
|
||||
"Render keyed rows, one dynamic typed View, and a footer slot."
|
||||
:view
|
||||
(column
|
||||
(row :for (item items) :key (car item)
|
||||
(text (expr (cdr item))))
|
||||
(expr footer-view)
|
||||
(slot :name 'footer (text "No footer"))))
|
||||
```
|
||||
|
||||
## 7. Styles and themes
|
||||
|
||||
Static Component styles use one declaration form:
|
||||
@ -341,8 +259,8 @@ Static Component styles use one declaration form:
|
||||
(styles
|
||||
("&"
|
||||
:padding (1 2)
|
||||
:border (1 solid "#687386"))
|
||||
(".title" :font-weight bold)
|
||||
:border ((1) solid "#687386"))
|
||||
(".title" :face bold)
|
||||
(".danger" :color "#FF6B6B"))
|
||||
:view
|
||||
(column
|
||||
@ -369,22 +287,14 @@ 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 semantic colors to its own View."
|
||||
"Provide default text colors to a subtree."
|
||||
:setup
|
||||
(etaf-theme-provide
|
||||
'(:text-color "#F4F6FB" :surface-color "#202634"))
|
||||
:view
|
||||
(text :ref 'themed-content
|
||||
:color (etaf-theme-token :text-color)
|
||||
:background-color (etaf-theme-token :surface-color)
|
||||
"Themed content"))
|
||||
|
||||
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
|
||||
(progn
|
||||
(etaf-theme-provide
|
||||
'(:color "#F4F6FB" :bgcolor "#202634"))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
```
|
||||
|
||||
For a light/dark application palette, keep the semantic roles in one palette
|
||||
@ -462,42 +372,6 @@ For a reusable installer, reserve `:install` for the cleanup-producing part of t
|
||||
|
||||
The installer can call `etaf-current-behavior-context` when it needs the current Runtime or Host path. Replacing the Behavior runs the old cleanup before the new state becomes current. Behavior equality keeps function and reactive-value identity with `eq`; a newly-created installer closure is therefore a deliberate replacement, not an accidental reuse. The replacement is staged under the mounted resource registry and becomes authoritative only when its generation commits.
|
||||
|
||||
<a id="interaction-migration"></a>
|
||||
|
||||
Root event forwarding is additive: the internal business handler runs first,
|
||||
then extra wrapper callbacks from inner to outer, then Behaviors in declaration
|
||||
order. Each declaration runs once. For a Checkbox, `:on-change` still receives
|
||||
the next boolean before an added `:on-press` observer. A callback error
|
||||
short-circuits the remaining callbacks; UI rollback does not undo external
|
||||
business writes. Dispatch targets one exact Host, with no capture or bubble.
|
||||
|
||||
Wrapper `:use` lists concatenate; duplicate Behavior names fail before any
|
||||
installer runs. Non-event Behavior defaults retain first-wins order after Host
|
||||
attributes, except `:disabled`, which combines with OR. Inner and outer disabled
|
||||
inputs are recomputed on every update: callers can further disable a control,
|
||||
and clearing the outer input enables it only when its inner input is also nil.
|
||||
Disabled Hosts reject `etaf-dispatch-event` and `etaf-focus` with
|
||||
`etaf-event-error`. Their input Behaviors are not installed; a committed disable
|
||||
cleans up installed resources, and re-enabling installs them again.
|
||||
|
||||
Hit testing selects the deepest interaction boundary before checking whether
|
||||
it is enabled. Clicking a disabled cell button does not activate its parent
|
||||
row, including when their bounds coincide. Ordinary non-interactive row text
|
||||
can still select the row; explicitly focusing the row can activate its action.
|
||||
|
||||
Migration: an extra root `:on-*` callback now appends instead of replacing the
|
||||
existing action. To define a different business action, use the Component's
|
||||
explicit business callback prop or define a Component with that behavior.
|
||||
Fallthrough cannot change an existing `:role` or owned aria state such as
|
||||
`:aria-checked` to a conflicting value; that signals a Component input error.
|
||||
Expose an intentional semantic variation as a business prop. Caller-provided
|
||||
`:aria-label` and `:aria-description` can still override accessible text.
|
||||
|
||||
Use application- or feature-prefixed Action names. Duplicate Action
|
||||
registration is an error. During deliberate reload, wrap the replacement in
|
||||
`etaf-action-redefine-run`; it changes future name-based dispatch without
|
||||
flushing the mounted Runtime.
|
||||
|
||||
Focus and hit testing are Runtime operations:
|
||||
|
||||
```elisp
|
||||
@ -514,38 +388,29 @@ 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
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component service-label ()
|
||||
"Read the inherited service."
|
||||
:setup (etaf-inject 'service nil t)
|
||||
:view
|
||||
(text (expr (format "Service: %s" (etaf-value (etaf-state))))))
|
||||
|
||||
(etaf-define-component application-shell ()
|
||||
"Provide a service to its own child Component."
|
||||
"Provide a service to descendants."
|
||||
:setup
|
||||
(let ((service (etaf-ref "demo-service")))
|
||||
(etaf-provide 'service service)
|
||||
service)
|
||||
:view (service-label))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
|
||||
(etaf-define-component service-label ()
|
||||
"Read the inherited service."
|
||||
:setup
|
||||
(let ((service (etaf-inject 'service nil t)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(text (expr :value (format "Service: %s" (etaf-value service)))))))
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-context*"
|
||||
(etaf-view (application-shell)))
|
||||
(etaf-view (application-shell (service-label))))
|
||||
```
|
||||
|
||||
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:
|
||||
@ -604,9 +469,8 @@ updates only when that identity enters or leaves the main selection, including
|
||||
when application code writes `etaf-data-selection` directly. The default
|
||||
DataGrid path uses these refs with keyed retained row owners, so a single-select
|
||||
change invalidates the old and new rows rather than the complete visible page.
|
||||
Custom `:row-selected-p` remains available when selection is owned outside the
|
||||
Controller. Stable identity still comes from the required `:row-key`; there is
|
||||
no second selection-key DataGrid prop.
|
||||
Custom `:row-selected-p` and `:selected-key` contracts remain available when
|
||||
selection is owned outside the Controller.
|
||||
|
||||
`etaf-data-controller` accepts `:item-key` for stable selected-row lookup. When
|
||||
created inside a Component setup, its internal effect Scope is owned by the
|
||||
@ -695,7 +559,16 @@ Loader errors are stored in `etaf-resource-error`; cleanup/type errors remain vi
|
||||
nil))
|
||||
```
|
||||
|
||||
The public View grammar accepts Hosts and Components, not raw Ebox Nodes. Framework integrations that need the lower-level port use Ebox's typed TextNode and BoxNode constructors directly; application Views remain on the normal Host and Component lowering path.
|
||||
The only low-level escape is `raw-ebox`:
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(raw-ebox
|
||||
:key 'manual-node
|
||||
:value (ebox-create :content "Backend node")))
|
||||
```
|
||||
|
||||
Use it only when the normal Host and Component lowering path cannot express a real Ebox requirement. The returned Node is opaque to ETAF semantics.
|
||||
|
||||
## 12. Playgrounds
|
||||
|
||||
@ -739,8 +612,6 @@ Enable the generic recorder around any application workload, then open its
|
||||
ordinary `tabulated-list-mode` panel:
|
||||
|
||||
```elisp
|
||||
(require 'etaf-performance)
|
||||
;; In a buffer with a mounted ETAF Runtime:
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-show)
|
||||
```
|
||||
@ -749,42 +620,29 @@ Run `M-x etaf-performance-clear` before the measured reproduction. Afterwards,
|
||||
press `c` in the panel, or run `M-x etaf-performance-copy-report`, to copy the
|
||||
environment, summary, operation, GC, and stage data. Press `w`, or run
|
||||
`M-x etaf-performance-export`, to save the same portable report as an `.eld`
|
||||
file. The report and panel header include power source, low-power mode,
|
||||
native-JIT state, and system load alongside the ordinary Emacs/display
|
||||
environment.
|
||||
file. The report and panel header include power source, low-power mode, and
|
||||
system load alongside the ordinary Emacs/display environment.
|
||||
|
||||
The recorder only consumes public Runtime observer reports and installs no
|
||||
advice. Runtime Event, Action, mount, flush, and unmount boundaries create
|
||||
bounded operation records. Ebox, TP, Data, Resource, and SQLite may contribute
|
||||
flat provider stages, ordered by sequence, inside the same operation. Stages
|
||||
may overlap and are therefore not reported as exclusive/self time; failures and
|
||||
quits are recorded and then re-signaled unchanged.
|
||||
The recorder creates bounded operation records for public interaction,
|
||||
lifecycle, Data, Resource, and viewport boundaries. Loaded Ebox, TP, and
|
||||
SQLite functions contribute nested coarse stages without depending on ETAF.
|
||||
Each stage reports inclusive and exclusive milliseconds; failures and quits
|
||||
are recorded and then re-signaled unchanged.
|
||||
|
||||
`etaf-performance-summary` calculates grouped p50/p95/max statistics only when
|
||||
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.
|
||||
requested. `etaf-performance-operation-stage-summary` ranks the package
|
||||
categories of one recorded operation by exclusive 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
|
||||
delegate to the same Runtime operation boundary. Disable the mode when the
|
||||
capture is complete; this only detaches the Runtime observer and does not
|
||||
rewrite any function.
|
||||
Use `etaf-performance-register-stage` for a temporary package-specific detail
|
||||
probe. Use `etaf-performance-with-operation` for application work that does
|
||||
not enter through a built-in public boundary. Disable the mode when the
|
||||
capture is complete; all installed advice is removed.
|
||||
|
||||
## 14. Public API map
|
||||
|
||||
| API family | Main entry points | Use it when |
|
||||
| --- | --- | --- |
|
||||
| View and Runtime | `etaf-view`, `etaf-render`, `etaf-mount`, `etaf-unmount`, `etaf-runtime-flush`, `etaf-runtime-snapshot` | Build, render, mount, flush, or explicitly export the committed application |
|
||||
| View and Runtime | `etaf-view`, `etaf-render`, `etaf-mount`, `etaf-unmount`, `etaf-runtime-flush` | Build, render, mount, or explicitly flush an 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 |
|
||||
@ -797,23 +655,23 @@ rewrite any function.
|
||||
| Resource | `etaf-resource`, `etaf-resource-result`, `etaf-error-boundary-run` | Own loader state and cleanup |
|
||||
| Official UI | `require 'etaf-ui`, `etaf-button`, `etaf-checkbox`, `etaf-number-input`, `etaf-label`, `etaf-panel`, `etaf-data-grid` | Use ready-made Components |
|
||||
| Playground | `etaf-playground-open`, `etaf-playground-open-ui`, `etaf-playground-close`, `ebox-playground-open`, `ebox-playground-close` | Explore the corresponding layer interactively |
|
||||
| Performance | `etaf-performance-start`, `etaf-performance-stop`, `etaf-performance-mode`, `etaf-performance-show`, `etaf-performance-copy-report`, `etaf-performance-export`, `etaf-performance-environment-data`, `etaf-performance-records`, `etaf-performance-summary`, `etaf-performance-operation-stage-summary`, `etaf-performance-call-operation`, `etaf-performance-with-operation` | Attribute generic operation latency through public observers and share reports |
|
||||
| Performance | `etaf-performance-mode`, `etaf-performance-show`, `etaf-performance-copy-report`, `etaf-performance-export`, `etaf-performance-environment-data`, `etaf-performance-records`, `etaf-performance-summary`, `etaf-performance-operation-stage-summary`, `etaf-performance-with-operation`, `etaf-performance-register-stage` | Attribute generic operation latency across loaded packages and share reports |
|
||||
|
||||
Most applications need only `etaf-view`, `etaf-mount`, `etaf-define-component`, `etaf-ref`, and event callbacks at first. The remaining APIs are additive capabilities, not prerequisites for understanding the core grammar.
|
||||
|
||||
## 15. Common mistakes
|
||||
|
||||
- Put every property before the first child.
|
||||
- Use `:font-weight 'bold`, not `:font-weight :bold`; the weight is an Elisp symbol value, not a property keyword.
|
||||
- Use `:face 'bold`, not `:face :bold`; a face is an Elisp symbol value, not a property keyword.
|
||||
- Do not quote a structural View form.
|
||||
- Use `(expr FORM)` for `if`, `when`, `let`, `mapcar`, or a typed View returned by ordinary Elisp.
|
||||
- Use `expr :value` for `if`, `when`, `let`, `mapcar`, or a View returned by ordinary Elisp.
|
||||
- Use `(slot)` or `(slot FALLBACK...)` for the default outlet; use `:name 'header` for named slot content.
|
||||
- Keep writes out of rendering; use an event, Action, watch callback, or Effect.
|
||||
- Use `etaf-ui` Components for product controls; core Hosts are the structural foundation.
|
||||
- Stop a Data Controller and unmount a Runtime when their owner is no longer needed.
|
||||
|
||||
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.
|
||||
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.
|
||||
|
||||
@ -7,8 +7,6 @@ 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)
|
||||
@ -29,7 +27,7 @@ ETAF 依赖独立的 Ebox 包。开发时把核心检出目录放入 `load-path`
|
||||
```elisp
|
||||
(etaf-view
|
||||
(column
|
||||
(text :font-weight 'bold "Hello")
|
||||
(text :face 'bold "Hello")
|
||||
(text :color "#687386" "Welcome to ETAF")))
|
||||
```
|
||||
|
||||
@ -40,7 +38,7 @@ ETAF 依赖独立的 Ebox 包。开发时把核心检出目录放入 `load-path`
|
||||
"*etaf-hello*"
|
||||
(etaf-view
|
||||
(column
|
||||
(text :font-weight 'bold "Hello")
|
||||
(text :face 'bold "Hello")
|
||||
(text "This is a text application."))))
|
||||
```
|
||||
|
||||
@ -64,38 +62,11 @@ Headless host 或已经知道最终布局上下文的调用方，可以通过可
|
||||
```elisp
|
||||
(ebox-render
|
||||
(etaf-render
|
||||
(etaf-view (text :font-weight 'bold "Pure View"))))
|
||||
(etaf-view (text :face 'bold "Pure View"))))
|
||||
```
|
||||
|
||||
View 含有状态型 Component、响应式数据、事件或生命周期时，使用 `etaf-mount`。
|
||||
|
||||
需要显式请求处理待办更新时，调用 `(etaf-runtime-flush runtime)`。
|
||||
它现在返回 **Ebox 已提交 revision 整数**，不再返回旧版的 Ebox 节点。
|
||||
Runtime 忙碌或仍处于批处理时，更新可能继续等待；返回值标识此刻读者可见的
|
||||
发布版本。活动 Ebox/TP 事务内的调用会在请求更新之前报错，因为事务中的
|
||||
revision 可能尚未提交。普通 flush 不导出整棵树，也不强制重建 Root。
|
||||
|
||||
需要当前树及其配套 source facts 时，显式获取快照：
|
||||
|
||||
```elisp
|
||||
(let* ((runtime (etaf-runtime-for-buffer "*etaf-hello*"))
|
||||
(snapshot (etaf-runtime-snapshot runtime)))
|
||||
(list (plist-get snapshot :revision)
|
||||
(plist-get snapshot :mount-id)
|
||||
(ebox-render (plist-get snapshot :input))))
|
||||
```
|
||||
|
||||
快照包含 `:input`（canonical Ebox input）、`:revision` 和 `:mount-id`
|
||||
（本次挂载的身份）。导出成本为 O(N)，会分离节点的普通可变数据；它不处理
|
||||
待办更新，不求值 Component，不发布，也不增加 revision。input 在后续提交或
|
||||
卸载后仍可使用。callback 等不透明能力保持身份，查询不会冻结这些外部能力或
|
||||
显示环境。对未挂载 Runtime 或在活动 Ebox/TP 事务内查询会报错。
|
||||
|
||||
已废弃的 `etaf-runtime-root-node` getter 通过上述 O(N) 查询保留读取兼容性，
|
||||
返回当前唯一根节点；Runtime 不再保存根节点镜像。请迁移到
|
||||
`etaf-runtime-snapshot`，保留 canonical input 中与根节点配套的 source facts；
|
||||
不要再把旧 getter 当作低成本字段读取或写入目标。
|
||||
|
||||
当前 core 不直接加载 `.etaf`。`etaf-define-component` 是结构/样式/行为单元：用 View 定义结构，用 `:styles` 放静态 presentation，用 `:setup` 管理 retained state、Action 和生命周期。未来 `.etaf` SFC 属于把结果编译成同一套 Component 契约的 compiler layer，而不是第二个 Runtime 入口。
|
||||
|
||||
## 3. 属性与子节点
|
||||
@ -107,9 +78,9 @@ revision 可能尚未提交。普通 flush 不导出整棵树，也不强制重
|
||||
(label "Theme"))
|
||||
(etaf-view
|
||||
(text
|
||||
:color (if dark "#F4F6FB" "#1F2328")
|
||||
:background-color "#20242B"
|
||||
(expr label))))
|
||||
:face (if dark 'light 'dark)
|
||||
:color "#F4F6FB"
|
||||
(expr :value label))))
|
||||
```
|
||||
|
||||
子节点区是结构语法。`expr` 是执行普通 Elisp 的唯一明确桥接：
|
||||
@ -117,16 +88,14 @@ revision 可能尚未提交。普通 flush 不导出整棵树，也不强制重
|
||||
```elisp
|
||||
(etaf-view
|
||||
(column
|
||||
(expr (if loading "Loading..." "Ready"))
|
||||
(expr :value (if loading "Loading..." "Ready"))
|
||||
(expr
|
||||
:value
|
||||
(when open
|
||||
(etaf-view (text :font-style 'italic "Details"))))))
|
||||
(etaf-view (text :face 'italic "Details"))))))
|
||||
```
|
||||
|
||||
`expr` 只接受一个普通 Elisp form，不能有结构子节点。在结构子节点位置，返回值
|
||||
可以是字符串、typed Host 或 Component View、这些值组成的 proper sequence 或 `nil`。
|
||||
在 `text` Host 内，表达式必须返回字符串。`if`、`when`、`cond`、`let`、`mapcar` 和
|
||||
`cl-loop` 仍是普通 Elisp。
|
||||
`expr` 只接受 `:value`，不能有子节点。返回值可以是字符串、View、序列或 `nil`。`if`、`when`、`cond`、`let`、`mapcar` 和 `cl-loop` 仍然是 value 中的普通 Elisp。
|
||||
|
||||
quote 只有普通 Elisp 的含义：
|
||||
|
||||
@ -134,12 +103,7 @@ quote 只有普通 Elisp 的含义：
|
||||
- 字面量 symbol 和数据列表在 Elisp 需要时才 quote。
|
||||
- Elisp 表达式需要构造 View 时，在其中使用 `(etaf-view ...)`。
|
||||
|
||||
例如 `'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 ...)`。
|
||||
例如 `'bold` 是 face symbol，而 `'(text "data")` 只是数据，不会渲染。动态 View 必须写成 `(etaf-view (text "data"))`。
|
||||
|
||||
核心 `grid` Host 用于二维布局：
|
||||
|
||||
@ -149,16 +113,16 @@ quote 只有普通 Elisp 的含义：
|
||||
(etaf-view
|
||||
(grid
|
||||
:width '(640)
|
||||
:grid-template-columns '((200) (fr 1))
|
||||
:grid-template-columns '((200) 1fr)
|
||||
:grid-template-rows '(1 1)
|
||||
:gap '(1 (12))
|
||||
(text :font-weight 'bold "Name")
|
||||
(text :face 'bold "Name")
|
||||
(text "Value")
|
||||
(text "Ada")
|
||||
(text "Lovelace"))))
|
||||
```
|
||||
|
||||
轨道模板支持 `auto`、`min-content`、`max-content`、`(fr FACTOR)`、`(minmax MIN MAX)` 和 `(repeat COUNT TRACK-LIST)`。`:grid-auto-columns` 与 `:grid-auto-rows` 负责隐式轨道尺寸；`:grid-auto-flow` 支持 `row` 或 `column`。子节点可以使用 `:grid-column`、`:grid-row`、`:grid-column-span` 和 `:grid-row-span`；测量、放置以及 item/content 对齐由 Ebox 完成。可选 native backend 不支持 Grid 时会回退到 Elisp Ebox renderer。
|
||||
轨道模板支持 `auto`、`(fr FACTOR)`、`1fr` 等符号、`(minmax MIN MAX)` 和 `(repeat COUNT TRACK)`。`:grid-auto-columns` 与 `:grid-auto-rows` 负责隐式轨道尺寸；`:grid-auto-flow` 支持 `row` 或 `column`。子节点可以使用 `:grid-column`、`:grid-row`、`:grid-column-span` 和 `:grid-row-span`；测量、放置以及 item/content 对齐由 Ebox 完成。可选 native backend 不支持 Grid 时会回退到 Elisp Ebox renderer。
|
||||
|
||||
## 4. 定义 Component
|
||||
|
||||
@ -169,8 +133,8 @@ quote 只有普通 Elisp 的含义：
|
||||
"Render a status label."
|
||||
:view
|
||||
(text
|
||||
:font-weight 'bold
|
||||
(expr label)))
|
||||
:face 'bold
|
||||
(expr :value label)))
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-status*"
|
||||
@ -178,21 +142,20 @@ quote 只有普通 Elisp 的含义：
|
||||
(status-label :label "Connected")))
|
||||
```
|
||||
|
||||
调用时使用传给 `etaf-define-component` 的准确名称：
|
||||
Component 的规范名称可以带 `etaf-` 前缀：
|
||||
|
||||
```elisp
|
||||
(etaf-view (status-label :label "Connected"))
|
||||
(etaf-view (etaf-status-label :label "Connected"))
|
||||
```
|
||||
|
||||
注册表不会自动生成 alias。定义为 `etaf-status-label` 的组件必须使用这个准确名称；上面的 `status-label` 是本节自己显式定义的名称。加载 `etaf-ui` 后，官方目录使用 `etaf-button`、`etaf-checkbox` 等准确名称。
|
||||
在 View 位置，ETAF 也会注册短 alias `status-label`。如果短名称会与 Elisp 冲突，注册表会使用以 `-view` 结尾的语义 alias。这个规则只作用于 View 名称；普通函数仍然保留前缀。
|
||||
|
||||
定义宏只接受这些关键字：
|
||||
|
||||
| 关键字 | 作用 |
|
||||
| --- | --- |
|
||||
| `:view` | 声明式 View frontend，与 `:render` 互斥 |
|
||||
| `:render` | 普通 Elisp 返回一个 typed View，通常使用 `etaf-view`；程序化构造也可使用 `etaf-node` |
|
||||
| `:setup` | 可选的一次性初始化，返回由 `etaf-state` 读取的 opaque 状态 |
|
||||
| `:view` | 无状态 Component 的 View 生产者，与 `:setup` 互斥 |
|
||||
| `:setup` | 一次性初始化，返回零参数 render 函数 |
|
||||
| `:styles` | 可选的静态作用域样式声明 |
|
||||
|
||||
没有单独的 children、slot、event、state 或 variant 声明块。业务 props 通过 `(&key ...)` 声明，children 和 slot 是隐式内容。
|
||||
@ -205,35 +168,23 @@ Component 自己拥有状态时使用 `:setup`：
|
||||
(etaf-define-component counter (&key title)
|
||||
"Render a retained counter."
|
||||
:setup
|
||||
(let ((count (etaf-ref 0))
|
||||
(initial-title title))
|
||||
(let ((count (etaf-ref 0)))
|
||||
(etaf-on-mounted
|
||||
(lambda () (message "%s mounted" initial-title)))
|
||||
(lambda () (message "%s mounted" title)))
|
||||
(etaf-on-unmounted
|
||||
(lambda () (message "%s unmounted" initial-title)))
|
||||
count)
|
||||
:render
|
||||
(let ((count (etaf-state))
|
||||
(caption title))
|
||||
(etaf-view
|
||||
(column
|
||||
(text :font-weight 'bold (expr caption))
|
||||
(text (expr (format "Count: %d" (etaf-value count))))
|
||||
(text :role 'button :tab-index 0
|
||||
:on-press (lambda () (cl-incf (etaf-value count)))
|
||||
"Increment")))))
|
||||
(lambda () (message "%s unmounted" title)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(column
|
||||
(text :face 'bold (expr :value title))
|
||||
(text (expr :value (format "Count: %d" (etaf-value count))))
|
||||
(text
|
||||
:role 'button
|
||||
:on-press (lambda () (cl-incf (etaf-value count)))
|
||||
"Increment"))))))
|
||||
```
|
||||
|
||||
Setup 对 retained instance 只执行一次，返回一个 opaque 状态值。选定的 `:view` 或
|
||||
`:render` frontend 在更新时运行，并通过 `etaf-state` 读取这个准确值。
|
||||
`etaf-on-mounted`、`etaf-on-updated` 和 `etaf-on-unmounted` 注册该 Component 的生命周期
|
||||
callback。Scope 释放时会自动停止响应式 effect 并运行 cleanup。
|
||||
|
||||
`:view` 和 `:render` 共用编译、slot 投影与 prop 校验。用普通 `let`/`let*`
|
||||
为回调捕获 state 句柄或当前 prop 值；`etaf-state` 只在 render 时读取，不留到
|
||||
事件触发时调用。把 `etaf-value` 保留在需要更新的属性或 `expr` 内；提取句柄
|
||||
不需要提前读取它的值。含有持久闭包的组件代码放在启用 lexical-binding 的 `.el`
|
||||
文件中。简单本地回调不需要定义 Action。
|
||||
Setup 对 retained instance 只执行一次，返回的 render 函数在更新时重复运行。`etaf-on-mounted`、`etaf-on-updated` 和 `etaf-on-unmounted` 注册该 Component 的生命周期 callback。Scope 释放时会自动停止响应式 effect 并运行 cleanup。
|
||||
|
||||
响应式 API 只有一套模型：
|
||||
|
||||
@ -268,8 +219,8 @@ callback。Scope 释放时会自动停止响应式 effect 并运行 cleanup。
|
||||
"Render a titled panel."
|
||||
:view
|
||||
(column
|
||||
(text :font-weight 'bold (expr title))
|
||||
(slot (text :color "#687386" "No content"))))
|
||||
(text :face 'bold (expr :value title))
|
||||
(slot (text :face 'shadow "No content"))))
|
||||
|
||||
(etaf-view
|
||||
(panel
|
||||
@ -285,8 +236,8 @@ callback。Scope 释放时会自动停止响应式 effect 并运行 cleanup。
|
||||
:view
|
||||
(column
|
||||
(slot :name 'header
|
||||
(text :font-weight 'bold (expr title)))
|
||||
(slot (text :color "#687386" "No body"))))
|
||||
(text :face 'bold (expr :value title)))
|
||||
(slot (text :face 'shadow "No body"))))
|
||||
|
||||
(etaf-view
|
||||
(card
|
||||
@ -297,27 +248,6 @@ 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：
|
||||
|
||||
```elisp
|
||||
(etaf-define-component etaf-docs-collection-card (&key items footer-view)
|
||||
"Render keyed rows, one dynamic typed View, and a footer slot."
|
||||
:view
|
||||
(column
|
||||
(row :for (item items) :key (car item)
|
||||
(text (expr (cdr item))))
|
||||
(expr footer-view)
|
||||
(slot :name 'footer (text "No footer"))))
|
||||
```
|
||||
|
||||
## 7. 样式与 Theme
|
||||
|
||||
静态 Component 样式只有一种声明形式：
|
||||
@ -329,8 +259,8 @@ Table/Grid 的 cell callback 同样使用消费它的 Table/Grid 所在位置的
|
||||
(styles
|
||||
("&"
|
||||
:padding (1 2)
|
||||
:border (1 solid "#687386"))
|
||||
(".title" :font-weight bold)
|
||||
:border ((1) solid "#687386"))
|
||||
(".title" :face bold)
|
||||
(".danger" :color "#FF6B6B"))
|
||||
:view
|
||||
(column
|
||||
@ -356,22 +286,14 @@ variant 需要明确覆盖，应使用显式 Host 属性或不同的属性键。
|
||||
|
||||
Theme 是 Context 的便捷形式，不是另一个 Runtime 对象：
|
||||
|
||||
<!-- etaf-example: theme -->
|
||||
```elisp
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component themed-shell ()
|
||||
"Provide semantic colors to its own View."
|
||||
"Provide default text colors to a subtree."
|
||||
:setup
|
||||
(etaf-theme-provide
|
||||
'(:text-color "#F4F6FB" :surface-color "#202634"))
|
||||
:view
|
||||
(text :ref 'themed-content
|
||||
:color (etaf-theme-token :text-color)
|
||||
:background-color (etaf-theme-token :surface-color)
|
||||
"Themed content"))
|
||||
|
||||
(etaf-mount "*etaf-theme*" (etaf-view (themed-shell)))
|
||||
(progn
|
||||
(etaf-theme-provide
|
||||
'(:color "#F4F6FB" :bgcolor "#202634"))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
```
|
||||
|
||||
如果应用有亮/暗两套 palette，应把语义 role 集中放在一份 palette plist 中，
|
||||
@ -447,35 +369,6 @@ Behavior 用来打包可复用的非视觉属性和 cleanup：
|
||||
|
||||
Installer 需要 Runtime 或 Host path 时，可以调用 `etaf-current-behavior-context`。Behavior 被替换时，旧 cleanup 会在新状态成为当前状态前运行。Behavior equality 对 function 和 reactive value 使用 `eq`；因此新建的 installer closure 会被视为有意替换，而不是错误复用。替换状态先以 mounted resource registry 的 staged resource 保存，generation commit 后才成为 authority。
|
||||
|
||||
<a id="interaction-migration"></a>
|
||||
|
||||
根事件透传采用追加规则：内部业务 handler 最先运行（first），然后是由内到外
|
||||
wrapper 附加的 callback，最后是按声明顺序运行的 Behavior。每个声明位置执行
|
||||
一次。Checkbox 的 `:on-change` 仍先收到下一个布尔值，附加的 `:on-press`
|
||||
观察回调随后运行。callback 报错会 short-circuit 剩余回调；UI 回滚不会撤销外部
|
||||
业务写入。dispatch 只命中准确 Host，不存在 capture 或 bubble。
|
||||
|
||||
wrapper 的 `:use` 列表顺序连接，重复 Behavior name 在任何 installer 运行前报错。
|
||||
非事件 Behavior 默认值仍由 Host 优先、其余 first-wins；`:disabled` 则取 OR。
|
||||
每次更新都重新计算内外禁用输入：调用方可进一步禁用控件；解除外层禁用时，只有
|
||||
内部也为 nil 才能启用。禁用 Host 的 `etaf-dispatch-event` 和 `etaf-focus` 会抛出
|
||||
`etaf-event-error`。禁用时不安装输入 Behavior；提交禁用时清理已安装资源，重新启用
|
||||
时再安装。
|
||||
|
||||
命中测试先选择最深的交互边界，再检查是否启用。点击禁用 cell 按钮不会激活父行，
|
||||
即使按钮与行的 bounds 相同。普通非交互行文本仍可选择该行；显式聚焦行后也可触发
|
||||
行动作。
|
||||
|
||||
迁移时注意：附加的根 `:on-*` 现在追加执行，不再覆盖原动作。需要不同业务动作时，
|
||||
使用组件显式公开的业务 callback prop，或定义具有该行为的组件。透传属性不能把
|
||||
已有的 `:role` 或 `:aria-checked` 等归组件所有的 aria 状态改成冲突值，否则报
|
||||
Component 输入错误；有意提供语义变体时应公开业务 prop。调用方仍可覆盖
|
||||
`:aria-label` 与 `:aria-description` 的可访问性文字。
|
||||
|
||||
Action name 使用 application/feature-prefixed symbol；重复 Action 注册默认报错。显式
|
||||
reload 用 `etaf-action-redefine-run` 包住替换，它只改变未来按 name 的 dispatch，不会
|
||||
flush 已挂载 Runtime。
|
||||
|
||||
Focus 和 hit testing 是 Runtime 操作：
|
||||
|
||||
```elisp
|
||||
@ -492,37 +385,29 @@ Focus 和 hit testing 是 Runtime 操作：
|
||||
|
||||
Context 适合跨多层共享依赖，不适合普通 label：
|
||||
|
||||
<!-- etaf-example: context -->
|
||||
```elisp
|
||||
(require 'etaf)
|
||||
|
||||
(etaf-define-component service-label ()
|
||||
"Read the inherited service."
|
||||
:setup (etaf-inject 'service nil t)
|
||||
:view
|
||||
(text (expr (format "Service: %s" (etaf-value (etaf-state))))))
|
||||
|
||||
(etaf-define-component application-shell ()
|
||||
"Provide a service to its own child Component."
|
||||
"Provide a service to descendants."
|
||||
:setup
|
||||
(let ((service (etaf-ref "demo-service")))
|
||||
(etaf-provide 'service service)
|
||||
service)
|
||||
:view (service-label))
|
||||
(lambda () (etaf-view (slot)))))
|
||||
|
||||
(etaf-define-component service-label ()
|
||||
"Read the inherited service."
|
||||
:setup
|
||||
(let ((service (etaf-inject 'service nil t)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(text (expr :value (format "Service: %s" (etaf-value service)))))))
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-context*"
|
||||
(etaf-view (application-shell)))
|
||||
(etaf-view (application-shell (service-label))))
|
||||
```
|
||||
|
||||
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 契约：
|
||||
@ -580,8 +465,8 @@ Controller 通过 `etaf-data-items`、`etaf-data-status`、`etaf-data-error`、`
|
||||
identity 进入或离开主 selection 时它才会变化，应用直接写
|
||||
`etaf-data-selection` 时也一样。DataGrid 默认把这些 ref 与 keyed retained row
|
||||
owner 配合使用，因此单选变化只会使旧行和新行失效，而不是整个可见页。
|
||||
selection 由 Controller 外部拥有时，仍可使用自定义 `:row-selected-p`。稳定 identity
|
||||
继续来自必选的 `:row-key`；DataGrid 没有第二个 selection-key prop。
|
||||
selection 由 Controller 外部拥有时，仍可使用自定义 `:row-selected-p` 与
|
||||
`:selected-key` 契约。
|
||||
|
||||
`etaf-data-controller` 支持用于稳定选中行查找的 `:item-key`。在 Component
|
||||
setup 中创建时，它的内部 effect Scope 会自动归当前 Component Scope 所有；如果
|
||||
@ -668,7 +553,16 @@ Loader 错误会保存在 `etaf-resource-error`；cleanup/type 错误保持可
|
||||
nil))
|
||||
```
|
||||
|
||||
公共 View 语法只接受 Host 和 Component，不接受裸 Ebox Node。需要更低层端口的框架集成直接使用 Ebox typed TextNode 和 BoxNode constructor；应用 View 始终走普通 Host/Component lowering 路径。
|
||||
唯一的低层出口是 `raw-ebox`：
|
||||
|
||||
```elisp
|
||||
(etaf-view
|
||||
(raw-ebox
|
||||
:key 'manual-node
|
||||
:value (ebox-create :content "Backend node")))
|
||||
```
|
||||
|
||||
只有普通 Host 和 Component lowering 无法表达真实 Ebox 需求时才使用它；返回的 Node 对 ETAF 语义保持 opaque。
|
||||
|
||||
## 12. Playgrounds
|
||||
|
||||
@ -711,8 +605,6 @@ Loader 错误会保存在 `etaf-resource-error`；cleanup/type 错误保持可
|
||||
对任意应用负载启用通用记录器，然后打开普通的 `tabulated-list-mode` 面板：
|
||||
|
||||
```elisp
|
||||
(require 'etaf-performance)
|
||||
;; 在已挂载 ETAF Runtime 的 buffer 中：
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-show)
|
||||
```
|
||||
@ -720,35 +612,27 @@ Loader 错误会保存在 `etaf-resource-error`；cleanup/type 错误保持可
|
||||
正式复现前执行 `M-x etaf-performance-clear`。复现后在面板按 `c`，或者执行
|
||||
`M-x etaf-performance-copy-report`，可把环境、汇总、operation、GC 和阶段数据
|
||||
完整复制到剪贴板；按 `w` 或执行 `M-x etaf-performance-export` 可导出 `.eld`
|
||||
文件。报告和面板 header 还会显示电源来源、低功耗模式、native JIT 状态与系统
|
||||
负载。这两种报告都可以直接发送给分析者。
|
||||
文件。报告和面板 header 还会显示电源来源、低功耗模式与系统负载。这两种报告
|
||||
都可以直接发送给分析者。
|
||||
|
||||
记录器只消费 Runtime 的公共 observer 报告，不安装 advice。Runtime 的 Event、
|
||||
Action、mount、flush 和 unmount 会创建有界 operation 记录；同一 operation 内，
|
||||
Ebox、TP、Data、Resource 与 SQLite 可以贡献按 sequence 排列的 flat provider
|
||||
阶段。阶段可能重叠，因此不声称 exclusive/self 时间；error 和 quit 会先被记录，
|
||||
再保持原条件继续抛出。
|
||||
记录器会为公共交互、lifecycle、Data、Resource 和 viewport 边界创建有界的
|
||||
operation 记录。已加载的 Ebox、TP 与 SQLite 可以贡献嵌套的粗粒度阶段，
|
||||
但不需要反向依赖 ETAF。每个阶段同时报告 inclusive 与 exclusive 毫秒；
|
||||
error 和 quit 会先被记录，再保持原条件继续抛出。
|
||||
|
||||
`etaf-performance-summary` 只在请求时计算分组后的 p50/p95/max；
|
||||
`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-operation-stage-summary` 会按 exclusive 时间排列某条记录
|
||||
中的包级阶段。
|
||||
|
||||
没有经过内置公共边界的应用操作可以使用
|
||||
`etaf-performance-call-operation`/`etaf-performance-with-operation`；它们直接委托
|
||||
同一个 Runtime operation 边界。采集结束后关闭 mode，只解除当前 Runtime 的
|
||||
observer，不修改任何函数。
|
||||
使用 `etaf-performance-register-stage` 临时加入包级细节探针。没有经过内置
|
||||
公共边界的应用操作可以使用 `etaf-performance-with-operation`。采集结束后
|
||||
关闭 mode，所有已安装 advice 都会被移除。
|
||||
|
||||
## 14. 公共 API 速查
|
||||
|
||||
| API 家族 | 主要入口 | 何时使用 |
|
||||
| --- | --- | --- |
|
||||
| View 与 Runtime | `etaf-view`、`etaf-render`、`etaf-mount`、`etaf-unmount`、`etaf-runtime-flush`、`etaf-runtime-snapshot` | 构建、渲染、挂载、flush 或显式导出已提交应用 |
|
||||
| View 与 Runtime | `etaf-view`、`etaf-render`、`etaf-mount`、`etaf-unmount`、`etaf-runtime-flush` | 构建、渲染、挂载或显式 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` | 观察状态或同步外部资源 |
|
||||
@ -761,22 +645,22 @@ observer，不修改任何函数。
|
||||
| Resource | `etaf-resource`、`etaf-resource-result`、`etaf-error-boundary-run` | 管理 loader 状态和 cleanup |
|
||||
| 官方 UI | `require 'etaf-ui`、`etaf-button`、`etaf-checkbox`、`etaf-number-input`、`etaf-label`、`etaf-panel`、`etaf-data-grid` | 使用现成 Component |
|
||||
| Playground | `etaf-playground-open`、`etaf-playground-open-ui`、`etaf-playground-close`、`ebox-playground-open`、`ebox-playground-close` | 探索对应层 |
|
||||
| 性能分析 | `etaf-performance-start`、`etaf-performance-stop`、`etaf-performance-mode`、`etaf-performance-show`、`etaf-performance-copy-report`、`etaf-performance-export`、`etaf-performance-environment-data`、`etaf-performance-records`、`etaf-performance-summary`、`etaf-performance-operation-stage-summary`、`etaf-performance-call-operation`、`etaf-performance-with-operation` | 通过公共 observer 定位通用 operation 的耗时并分享报告 |
|
||||
| 性能分析 | `etaf-performance-mode`、`etaf-performance-show`、`etaf-performance-copy-report`、`etaf-performance-export`、`etaf-performance-environment-data`、`etaf-performance-records`、`etaf-performance-summary`、`etaf-performance-operation-stage-summary`、`etaf-performance-with-operation`、`etaf-performance-register-stage` | 跨已加载包定位通用 operation 的耗时并分享报告 |
|
||||
|
||||
大多数应用一开始只需要 `etaf-view`、`etaf-mount`、`etaf-define-component`、`etaf-ref` 和事件 callback。其余 API 都是可选能力，不是理解核心语法的前置条件。
|
||||
|
||||
## 15. 常见错误
|
||||
|
||||
- 所有属性必须放在第一个子节点之前。
|
||||
- 使用 `:font-weight 'bold`，不要使用 `:font-weight :bold`；weight 是 Elisp symbol 值，不是属性 keyword。
|
||||
- 使用 `:face 'bold`，不要使用 `:face :bold`；face 是 Elisp symbol 值，不是属性 keyword。
|
||||
- 结构性 View form 不要 quote。
|
||||
- `if`、`when`、`let`、`mapcar` 或 Elisp 返回 typed View 时，使用 `(expr FORM)`。
|
||||
- `if`、`when`、`let`、`mapcar` 或 Elisp 返回 View 时，使用 `expr :value`。
|
||||
- 默认 outlet 使用 `(slot)` 或 `(slot FALLBACK...)`；命名内容使用 `:name 'header`。
|
||||
- 不要在 render 中写状态；使用事件、Action、watch callback 或 Effect。
|
||||
- 产品级控件使用 `etaf-ui` Component；core Host 只是结构基础。
|
||||
- owner 不再需要时，停止 Data Controller 并卸载 Runtime。
|
||||
|
||||
普通应用在启用 lexical-binding 的 `.el` 文件中定义并挂载 Component。可选的
|
||||
Playground 使用 inert `.etaf` 结构与显式注册的 `.el` companion；core 不会自动
|
||||
发现或执行这组文件。同一 batch 内的响应式写入合并为一次 generation publication；
|
||||
发布失败可以重试，non-converging effect 会报告错误，不会持续占用事件循环。
|
||||
对于保留式更新，建议保持 pair 结构：`.etaf` 只放静态 shell，同名 `.el` companion
|
||||
负责 state、Component 和 action。响应式写入会合并为一次 generation publication；
|
||||
发布失败可以在同一旧状态上重试，non-converging effect 会报告错误，不会让界面
|
||||
持续占用事件循环。
|
||||
|
||||
@ -11,16 +11,9 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-scheduler)
|
||||
(require 'etaf-reactive)
|
||||
(require 'etaf-runtime)
|
||||
|
||||
(defvar etaf--current-runtime)
|
||||
(defvar etaf--observer-context)
|
||||
|
||||
(declare-function etaf-runtime-observer "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-call-operation
|
||||
"etaf-runtime" (runtime kind label function))
|
||||
|
||||
(define-error 'etaf-action-error "Invalid ETAF Action")
|
||||
|
||||
@ -33,23 +26,11 @@
|
||||
(defvar etaf--action-registry (make-hash-table :test #'eq)
|
||||
"Action name -> `etaf-action-spec' table.")
|
||||
|
||||
(defvar etaf--allow-action-redefinition nil
|
||||
"Non-nil only inside `etaf-action-redefine-run'.")
|
||||
|
||||
(defun etaf--action-assert-definition-available (name)
|
||||
"Signal when Action NAME cannot be defined in the current boundary."
|
||||
(when (and (gethash name etaf--action-registry)
|
||||
(not etaf--allow-action-redefinition))
|
||||
(signal 'etaf-action-error
|
||||
(list (format "Duplicate ETAF Action: %S" name)))))
|
||||
|
||||
(defun etaf-action-register (name function)
|
||||
"Register FUNCTION as named Action NAME and return NAME."
|
||||
(etaf--assert-not-rendering 'register-action)
|
||||
(unless (and (symbolp name) (not (keywordp name)) (functionp function))
|
||||
(signal 'etaf-action-error
|
||||
(list (format "Invalid Action registration: %S" name))))
|
||||
(etaf--action-assert-definition-available name)
|
||||
(puthash name (etaf--action-spec-create :name name :function function)
|
||||
etaf--action-registry)
|
||||
name)
|
||||
@ -65,32 +46,18 @@ through `etaf-dispatch'."
|
||||
(let ((docstring (when (stringp (car body)) (pop body)))
|
||||
(function-symbol (intern (format "%s--etaf-action" name))))
|
||||
`(progn
|
||||
(etaf--action-assert-definition-available ',name)
|
||||
(defun ,function-symbol ,arguments
|
||||
,(or docstring (format "Run ETAF Action `%s'." name))
|
||||
,@body)
|
||||
(etaf-action-register ',name #',function-symbol)
|
||||
',name)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-action-redefine-run (function)
|
||||
"Run FUNCTION while allowing intentional Action redefinition.
|
||||
|
||||
Normal duplicate registrations remain errors. This dynamic authoring
|
||||
boundary replaces only the process-global name binding used by future
|
||||
`etaf-dispatch' calls; it does not flush or rerender mounted Runtimes."
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(let ((etaf--allow-action-redefinition t))
|
||||
(funcall function)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-dispatch (action &rest arguments)
|
||||
"Dispatch named ACTION through the active Runtime with ARGUMENTS.
|
||||
|
||||
An explicit Runtime may be supplied as the first argument: `(etaf-dispatch
|
||||
RUNTIME ACTION ...)'. Action functions receive Runtime first."
|
||||
(etaf--assert-not-rendering 'dispatch-action)
|
||||
(let* ((explicit-runtime (etaf-runtime-p action))
|
||||
(runtime (if explicit-runtime
|
||||
action
|
||||
@ -110,25 +77,12 @@ RUNTIME ACTION ...)'. Action functions receive Runtime first."
|
||||
(unless spec
|
||||
(signal 'etaf-action-error
|
||||
(list (format "Unknown ETAF Action: %S" action))))
|
||||
(let ((run
|
||||
(lambda ()
|
||||
(etaf-scheduler-call-with-context
|
||||
(etaf-runtime-scheduler-context runtime)
|
||||
(lambda ()
|
||||
(etaf-reactive-call-with-batch
|
||||
(lambda ()
|
||||
(let ((etaf--current-runtime runtime))
|
||||
(apply (etaf-action-spec-function spec)
|
||||
runtime arguments)))))))))
|
||||
(if (or etaf--observer-context (etaf-runtime-observer runtime))
|
||||
(etaf-runtime-call-operation
|
||||
runtime 'action (format "%S" action) run)
|
||||
(funcall run)))))
|
||||
(let ((etaf--current-runtime runtime))
|
||||
(apply (etaf-action-spec-function spec) runtime arguments))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-action-undefine (name)
|
||||
"Remove named Action NAME and return NAME."
|
||||
(etaf--assert-not-rendering 'undefine-action)
|
||||
(remhash name etaf--action-registry)
|
||||
name)
|
||||
|
||||
|
||||
292
etaf-compiler.el
292
etaf-compiler.el
@ -15,12 +15,12 @@
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-view)
|
||||
|
||||
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/2")
|
||||
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/1")
|
||||
|
||||
(defvar etaf-compiler--static-cache (make-hash-table :test #'equal))
|
||||
(defvar etaf-compiler--site-token-cache (make-hash-table :test #'equal))
|
||||
(defvar etaf-compiler--registry-epoch 0)
|
||||
(defvar etaf-compiler--instantiate-count 0)
|
||||
(defvar etaf-compiler--fallback-count 0)
|
||||
(defvar etaf-compiler--last-blueprint nil)
|
||||
|
||||
(defun etaf-compiler-note-registry-change ()
|
||||
@ -31,27 +31,13 @@
|
||||
(defun etaf-compiler-clear-cache ()
|
||||
"Clear all process-local compiled View materializations."
|
||||
(interactive)
|
||||
(clrhash etaf-compiler--static-cache)
|
||||
(clrhash etaf-compiler--site-token-cache))
|
||||
|
||||
(defun etaf-compiler--site-token (blueprint block)
|
||||
"Return the stable opaque token for compiled BLOCK in BLUEPRINT."
|
||||
(let* ((key (list (plist-get blueprint :id)
|
||||
(plist-get block :path)))
|
||||
(missing (make-symbol "etaf-compiled-site-token-missing"))
|
||||
(token (gethash key etaf-compiler--site-token-cache missing)))
|
||||
(if (not (eq token missing))
|
||||
token
|
||||
(setq token (list 'etaf-compiled-site
|
||||
(plist-get blueprint :id)
|
||||
(plist-get block :path)))
|
||||
(puthash key token etaf-compiler--site-token-cache)
|
||||
token)))
|
||||
(clrhash etaf-compiler--static-cache))
|
||||
|
||||
(defun etaf-compiler-statistics ()
|
||||
"Return a read-only snapshot of compiler runtime statistics."
|
||||
(list :abi etaf-compiler-blueprint-abi
|
||||
:instantiations etaf-compiler--instantiate-count
|
||||
:fallbacks etaf-compiler--fallback-count
|
||||
:static-cache-entries (hash-table-count etaf-compiler--static-cache)
|
||||
:last-blueprint
|
||||
(and etaf-compiler--last-blueprint
|
||||
@ -82,95 +68,29 @@
|
||||
(cons (list :kind 'hole :index index)
|
||||
(append programs (list `(lambda () ,form)))))))
|
||||
|
||||
(defun etaf-compiler--form-directives (form)
|
||||
"Return validated compiler directives from raw View FORM, or nil."
|
||||
(when (and (consp form) (symbolp (car form))
|
||||
(not (memq (car form) '(expr slot))))
|
||||
(let ((props
|
||||
(car (etaf--parse-attributes-and-children (cdr form)))))
|
||||
(etaf--validate-directive-set
|
||||
(etaf--view-directive-properties props)))))
|
||||
|
||||
(defun etaf-compiler--compile-program-block (kind code path programs)
|
||||
"Compile structural KIND from executable CODE at PATH using PROGRAMS."
|
||||
(let ((index (length programs)))
|
||||
(list (list :kind kind :path path :hole index :static-p nil)
|
||||
(append programs (list `(lambda () ,code))))))
|
||||
|
||||
(defun etaf-compiler--compile-children
|
||||
(children path programs slot-mode)
|
||||
"Compile sibling CHILDREN below PATH, extending PROGRAMS.
|
||||
SLOT-MODE selects ordinary projection or slot compilation."
|
||||
(let ((child-index 0)
|
||||
blocks)
|
||||
(while children
|
||||
(let* ((form (car children))
|
||||
(directives (etaf-compiler--form-directives form))
|
||||
compiled
|
||||
consumed)
|
||||
(cond
|
||||
((and directives (plist-member directives :if))
|
||||
(pcase-let ((`(,code . ,remaining)
|
||||
(etaf--compile-branch-children
|
||||
form (cdr children) slot-mode)))
|
||||
(setq compiled
|
||||
(etaf-compiler--compile-program-block
|
||||
'branch code (append path (list child-index)) programs)
|
||||
consumed (- (length children) (length remaining))
|
||||
children remaining)))
|
||||
((and directives (plist-member directives :for))
|
||||
(setq compiled
|
||||
(etaf-compiler--compile-program-block
|
||||
'keyed-list
|
||||
(etaf--compile-for-child form slot-mode)
|
||||
(append path (list child-index)) programs)
|
||||
consumed 1
|
||||
children (cdr children)))
|
||||
((and directives
|
||||
(or (plist-member directives :else-if)
|
||||
(plist-member directives :else)))
|
||||
(etaf--syntax-error "Orphan branch arm: %S" form))
|
||||
(t
|
||||
(setq compiled
|
||||
(etaf-compiler--compile-block
|
||||
form (append path (list child-index)) programs slot-mode)
|
||||
consumed 1
|
||||
children (cdr children))))
|
||||
(setq programs (cadr compiled)
|
||||
blocks (append blocks (list (car compiled))))
|
||||
(cl-incf child-index consumed)))
|
||||
(list blocks programs)))
|
||||
|
||||
(defun etaf-compiler--compile-block (form path programs slot-mode)
|
||||
"Compile View FORM at PATH using PROGRAMS and SLOT-MODE.
|
||||
Return `(BLOCK PROGRAMS)' or nil."
|
||||
(defun etaf-compiler--compile-block (form path programs)
|
||||
"Compile View FORM at PATH, returning `(BLOCK PROGRAMS)' or nil."
|
||||
(cond
|
||||
((or (null form) (stringp form))
|
||||
(list (list :kind 'literal :value form :path path :static-p t) programs))
|
||||
((not (and (consp form) (symbolp (car form))))
|
||||
(etaf--syntax-error "View form must start with a tag symbol: %S" form))
|
||||
((not (and (consp form) (symbolp (car form)))) nil)
|
||||
((eq (car form) 'expr)
|
||||
(let ((index (length programs)))
|
||||
(list (list :kind 'expr :path path :hole index :static-p nil)
|
||||
(append programs
|
||||
(list `(lambda () ,(etaf--parse-expr-form (cdr form))))))))
|
||||
((eq (car form) 'slot)
|
||||
(etaf-compiler--compile-program-block
|
||||
'slot (etaf--compile-slot-form (cdr form) slot-mode) path programs))
|
||||
((and (null (gethash (car form) etaf--view-registry))
|
||||
(etaf--ordinary-expression-head-p (car form)))
|
||||
(etaf--syntax-error
|
||||
"Elisp expression %S must be inside (expr FORM)" (car form)))
|
||||
((memq (car form) '(slot raw-ebox)) nil)
|
||||
((etaf--ordinary-expression-head-p (car form)) nil)
|
||||
(t
|
||||
(let* ((parts (etaf--parse-attributes-and-children (cdr form)))
|
||||
(props (car parts))
|
||||
(children (cdr parts))
|
||||
(host-view-p
|
||||
(eq (gethash (car form) etaf--view-registry) etaf--host-marker))
|
||||
(child-slot-mode (if host-view-p slot-mode :input))
|
||||
(compiled-props nil)
|
||||
(compiled-children nil)
|
||||
(all-static t)
|
||||
(tail props))
|
||||
(tail props)
|
||||
(child-index 0)
|
||||
result)
|
||||
(while tail
|
||||
(let* ((key (pop tail))
|
||||
(value (pop tail))
|
||||
@ -181,15 +101,22 @@ Return `(BLOCK PROGRAMS)' or nil."
|
||||
(setq all-static nil))
|
||||
(setq compiled-props
|
||||
(append compiled-props (list key descriptor)))))
|
||||
(pcase-let* ((`(,compiled-children ,next-programs)
|
||||
(etaf-compiler--compile-children
|
||||
children path programs child-slot-mode)))
|
||||
(dolist (block compiled-children)
|
||||
(unless (plist-get block :static-p) (setq all-static nil)))
|
||||
(while (and children (not (eq result 'unsupported)))
|
||||
(let ((compiled
|
||||
(etaf-compiler--compile-block
|
||||
(pop children) (append path (list child-index)) programs)))
|
||||
(if (not compiled)
|
||||
(setq result 'unsupported)
|
||||
(let ((block (car compiled)))
|
||||
(setq programs (cadr compiled)
|
||||
compiled-children (append compiled-children (list block)))
|
||||
(unless (plist-get block :static-p) (setq all-static nil)))))
|
||||
(cl-incf child-index))
|
||||
(unless (eq result 'unsupported)
|
||||
(list (list :kind 'node :name (car form) :path path
|
||||
:props compiled-props :children compiled-children
|
||||
:static-p all-static)
|
||||
next-programs))))))
|
||||
programs))))))
|
||||
|
||||
(defun etaf-compiler--block-counts (block)
|
||||
"Return `(STATIC . DYNAMIC)' node counts below BLOCK."
|
||||
@ -204,16 +131,15 @@ Return `(BLOCK PROGRAMS)' or nil."
|
||||
(cl-incf dynamic child-dynamic)))
|
||||
(cons static dynamic))))
|
||||
|
||||
(defun etaf-compiler--compile (form &optional slot-mode)
|
||||
"Compile FORM under optional SLOT-MODE into a View blueprint.
|
||||
Return `(BLUEPRINT PROGRAM-CODE...)', or nil."
|
||||
(pcase-let* ((`(,roots ,programs)
|
||||
(etaf-compiler--compile-children
|
||||
(list form) nil nil (or slot-mode :projection)))
|
||||
(root (car roots)))
|
||||
(unless (and root (null (cdr roots)))
|
||||
(etaf--syntax-error "A View blueprint requires exactly one root"))
|
||||
(let* ((programs programs)
|
||||
(defun etaf-compiler--beneficial-blueprint-p (blueprint)
|
||||
"Return non-nil when BLUEPRINT can reuse at least one static node."
|
||||
(> (or (plist-get blueprint :static-nodes) 0) 0))
|
||||
|
||||
(defun etaf-compiler--compile (form)
|
||||
"Compile FORM into `(BLUEPRINT PROGRAM-CODE...)', or return nil."
|
||||
(when-let* ((compiled (etaf-compiler--compile-block form '(0) nil)))
|
||||
(let* ((root (car compiled))
|
||||
(programs (cadr compiled))
|
||||
(id (secure-hash 'sha256 (prin1-to-string form)))
|
||||
(counts (etaf-compiler--block-counts root)))
|
||||
(cons (list :kind 'etaf/view-blueprint
|
||||
@ -224,100 +150,6 @@ Return `(BLUEPRINT PROGRAM-CODE...)', or nil."
|
||||
:hole-count (length programs))
|
||||
programs))))
|
||||
|
||||
(defun etaf-compiler--closed-plist-p (value allowed)
|
||||
"Return non-nil when VALUE is a duplicate-free plist using ALLOWED keys."
|
||||
(and (proper-list-p value)
|
||||
(zerop (% (length value) 2))
|
||||
(let ((tail value)
|
||||
seen
|
||||
valid)
|
||||
(setq valid t)
|
||||
(while (and valid tail)
|
||||
(let ((key (pop tail)))
|
||||
(pop tail)
|
||||
(if (or (not (memq key allowed)) (memq key seen))
|
||||
(setq valid nil)
|
||||
(push key seen))))
|
||||
valid)))
|
||||
|
||||
(defun etaf-compiler--valid-property-descriptor-p (descriptor hole-count)
|
||||
"Return non-nil for one bounded property DESCRIPTOR using HOLE-COUNT."
|
||||
(and (proper-list-p descriptor)
|
||||
(pcase (plist-get descriptor :kind)
|
||||
('static
|
||||
(and (etaf-compiler--closed-plist-p descriptor '(:kind :value))
|
||||
(plist-member descriptor :value)))
|
||||
('hole
|
||||
(and (etaf-compiler--closed-plist-p descriptor '(:kind :index))
|
||||
(natnump (plist-get descriptor :index))
|
||||
(< (plist-get descriptor :index) hole-count)))
|
||||
(_ nil))))
|
||||
|
||||
(defun etaf-compiler--valid-property-block-p (props hole-count)
|
||||
"Return non-nil for a canonical property block PROPS using HOLE-COUNT."
|
||||
(and (proper-list-p props)
|
||||
(zerop (% (length props) 2))
|
||||
(let ((tail props)
|
||||
seen
|
||||
valid)
|
||||
(setq valid t)
|
||||
(while (and valid tail)
|
||||
(let ((key (pop tail))
|
||||
(descriptor (pop tail)))
|
||||
(if (or (not (keywordp key))
|
||||
(memq key seen)
|
||||
(not (etaf-compiler--valid-property-descriptor-p
|
||||
descriptor hole-count)))
|
||||
(setq valid nil)
|
||||
(push key seen))))
|
||||
valid)))
|
||||
|
||||
(defun etaf-compiler--valid-block-p (block hole-count)
|
||||
"Return non-nil when BLOCK is valid for current View IR HOLE-COUNT."
|
||||
(and (proper-list-p block)
|
||||
(proper-list-p (plist-get block :path))
|
||||
(booleanp (plist-get block :static-p))
|
||||
(pcase (plist-get block :kind)
|
||||
('literal
|
||||
(and (etaf-compiler--closed-plist-p
|
||||
block '(:kind :value :path :static-p))
|
||||
(plist-member block :value)
|
||||
(or (null (plist-get block :value))
|
||||
(stringp (plist-get block :value)))
|
||||
(plist-get block :static-p)))
|
||||
((or 'expr 'branch 'keyed-list 'slot)
|
||||
(and (etaf-compiler--closed-plist-p
|
||||
block '(:kind :path :hole :static-p))
|
||||
(natnump (plist-get block :hole))
|
||||
(< (plist-get block :hole) hole-count)
|
||||
(not (plist-get block :static-p))))
|
||||
('node
|
||||
(and (etaf-compiler--closed-plist-p
|
||||
block '(:kind :name :path :props :children :static-p))
|
||||
(symbolp (plist-get block :name))
|
||||
(etaf-compiler--valid-property-block-p
|
||||
(plist-get block :props) hole-count)
|
||||
(proper-list-p (plist-get block :children))
|
||||
(cl-every (lambda (child)
|
||||
(etaf-compiler--valid-block-p child hole-count))
|
||||
(plist-get block :children))))
|
||||
(_ nil))))
|
||||
|
||||
(defun etaf-compiler--valid-blueprint-p (blueprint program-count)
|
||||
"Return non-nil when BLUEPRINT is closed and matches PROGRAM-COUNT."
|
||||
(and (etaf-compiler--closed-plist-p
|
||||
blueprint
|
||||
'(:kind :abi :id :root :static-nodes :dynamic-nodes :hole-count))
|
||||
(eq (plist-get blueprint :kind) 'etaf/view-blueprint)
|
||||
(equal (plist-get blueprint :abi) etaf-compiler-blueprint-abi)
|
||||
(stringp (plist-get blueprint :id))
|
||||
(natnump (plist-get blueprint :static-nodes))
|
||||
(natnump (plist-get blueprint :dynamic-nodes))
|
||||
(natnump (plist-get blueprint :hole-count))
|
||||
(= program-count (plist-get blueprint :hole-count))
|
||||
(etaf-compiler--valid-block-p
|
||||
(plist-get blueprint :root) program-count)))
|
||||
|
||||
(defun etaf-compiler--materialize (blueprint block programs)
|
||||
"Materialize BLOCK from BLUEPRINT using PROGRAMS."
|
||||
(let* ((static-p (plist-get block :static-p))
|
||||
@ -332,36 +164,13 @@ Return `(BLUEPRINT PROGRAM-CODE...)', or nil."
|
||||
cached
|
||||
(let ((value
|
||||
(pcase (plist-get block :kind)
|
||||
;; The compiler's literal block is also used for a root string.
|
||||
;; Keep the same canonicalization as the non-compiled View path:
|
||||
;; a bare string is a Text View, while nil remains an empty
|
||||
;; structural value.
|
||||
('literal
|
||||
(let ((literal (plist-get block :value)))
|
||||
(if (and (stringp literal)
|
||||
(= (length (plist-get block :path)) 1))
|
||||
(etaf--text-view-from-string literal)
|
||||
literal)))
|
||||
('literal (plist-get block :value))
|
||||
('expr
|
||||
(etaf--expr-create
|
||||
:token (etaf-compiler--site-token blueprint block)
|
||||
:token (list 'etaf-compiled-site
|
||||
(plist-get blueprint :id)
|
||||
(plist-get block :path))
|
||||
:thunk (aref programs (plist-get block :hole))))
|
||||
((or 'branch 'keyed-list)
|
||||
(let ((program
|
||||
(funcall (aref programs (plist-get block :hole)))))
|
||||
(unless (and (etaf--expr-p program)
|
||||
(eq (etaf--expr-kind program)
|
||||
(plist-get block :kind)))
|
||||
(error "Invalid ETAF structural program for %S"
|
||||
(plist-get block :kind)))
|
||||
program))
|
||||
('slot
|
||||
(let ((slot
|
||||
(funcall (aref programs (plist-get block :hole)))))
|
||||
(unless (or (etaf--slot-projection-p slot)
|
||||
(etaf--slot-input-p slot))
|
||||
(error "Invalid ETAF slot program"))
|
||||
slot))
|
||||
('node
|
||||
(let ((props nil))
|
||||
(cl-loop for (key descriptor) on (plist-get block :props)
|
||||
@ -396,9 +205,12 @@ Return `(BLUEPRINT PROGRAM-CODE...)', or nil."
|
||||
;;;###autoload
|
||||
(defun etaf-compiler-instantiate (blueprint programs)
|
||||
"Instantiate automatically lowered View BLUEPRINT with dynamic PROGRAMS."
|
||||
(unless (and (vectorp programs)
|
||||
(etaf-compiler--valid-blueprint-p
|
||||
blueprint (length programs)))
|
||||
(unless (and (eq (plist-get blueprint :kind) 'etaf/view-blueprint)
|
||||
(equal (plist-get blueprint :abi)
|
||||
etaf-compiler-blueprint-abi)
|
||||
(stringp (plist-get blueprint :id))
|
||||
(vectorp programs)
|
||||
(= (length programs) (plist-get blueprint :hole-count)))
|
||||
(error "Invalid or incompatible ETAF View blueprint"))
|
||||
(cl-incf etaf-compiler--instantiate-count)
|
||||
(setq etaf-compiler--last-blueprint blueprint)
|
||||
@ -407,12 +219,14 @@ Return `(BLUEPRINT PROGRAM-CODE...)', or nil."
|
||||
|
||||
(defun etaf-compiler-expand-view (form &optional slot-mode)
|
||||
"Return compiler expansion for View FORM.
|
||||
SLOT-MODE distinguishes Component projections from call-site slot inputs."
|
||||
(let* ((compiled (etaf-compiler--compile
|
||||
form (or slot-mode :projection)))
|
||||
(blueprint (car compiled)))
|
||||
`(etaf-compiler-instantiate
|
||||
',blueprint (vector ,@(cdr compiled)))))
|
||||
SLOT-MODE is forwarded to the legacy compiler."
|
||||
(let* ((compiled (etaf-compiler--compile form))
|
||||
(blueprint (car compiled))
|
||||
(legacy (etaf--compile-view-form form (or slot-mode :projection))))
|
||||
(if (and compiled (etaf-compiler--beneficial-blueprint-p blueprint))
|
||||
`(etaf-compiler-instantiate
|
||||
',blueprint (vector ,@(cdr compiled)))
|
||||
`(progn (cl-incf etaf-compiler--fallback-count) ,legacy))))
|
||||
|
||||
(provide 'etaf-compiler)
|
||||
;;; etaf-compiler.el ends here
|
||||
|
||||
@ -4,16 +4,15 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; 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'.
|
||||
;; Components have one public definition boundary. A stateless Component
|
||||
;; declares `:view'; a stateful Component declares `:setup' which runs once
|
||||
;; per retained instance and returns a render function. Both forms produce
|
||||
;; the same normalized View tree and share props, slots, styles, and Context.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'macroexp)
|
||||
(require 'etaf-view)
|
||||
(require 'etaf-compiler)
|
||||
|
||||
(define-error 'etaf-component-definition-error
|
||||
"Invalid ETAF Component definition"
|
||||
@ -26,22 +25,6 @@
|
||||
(defvar etaf--raw-slot-read-p nil
|
||||
"Set while a Component render uses public raw slot accessors.")
|
||||
|
||||
(defvar etaf--component-phase nil
|
||||
"Dynamic Component phase, either `setup', `render', or nil.")
|
||||
|
||||
(defvar etaf--current-component-state nil
|
||||
"Opaque setup result supplied by the current Runtime Component context.")
|
||||
|
||||
(defvar etaf--current-component-setup-defined-p nil
|
||||
"Whether the current Component definition declares setup.")
|
||||
|
||||
(defvar etaf--current-component-setup-complete-p nil
|
||||
"Whether the current Component instance completed setup.")
|
||||
|
||||
(defconst etaf--component-reserved-props
|
||||
'(key if else-if else for)
|
||||
"Framework names forbidden in Component business prop declarations.")
|
||||
|
||||
(defun etaf--component-definition-error (format-string &rest arguments)
|
||||
"Signal a Component definition error from FORMAT-STRING and ARGUMENTS."
|
||||
(signal 'etaf-component-definition-error
|
||||
@ -68,9 +51,6 @@
|
||||
(when (memq entry prop-names)
|
||||
(etaf--component-definition-error
|
||||
"Duplicate Component prop: %S" entry))
|
||||
(when (memq entry etaf--component-reserved-props)
|
||||
(etaf--component-definition-error
|
||||
"Component prop %S is reserved by the View grammar" entry))
|
||||
(push entry prop-names))
|
||||
(nreverse prop-names)))
|
||||
|
||||
@ -88,23 +68,6 @@ The function is also useful to code that deliberately avoids that shorthand."
|
||||
(plist-get etaf--current-component-props
|
||||
(etaf--component-prop-key name)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-state ()
|
||||
"Return the current Component instance's exact setup result.
|
||||
The accessor is valid only while rendering a Component that declares setup.
|
||||
A defined setup may return nil; setup presence is tracked independently."
|
||||
(unless (and (eq etaf--component-phase 'render)
|
||||
etaf--current-component-instance)
|
||||
(etaf--component-definition-error
|
||||
"ETAF state is available only during Component view/render"))
|
||||
(unless etaf--current-component-setup-defined-p
|
||||
(etaf--component-definition-error
|
||||
"Current Component does not declare :setup"))
|
||||
(unless etaf--current-component-setup-complete-p
|
||||
(etaf--component-definition-error
|
||||
"Current Component setup has not completed"))
|
||||
etaf--current-component-state)
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-component-set-styles (name styles)
|
||||
"Replace the static style form for Component NAME with STYLES.
|
||||
@ -147,9 +110,6 @@ does not depend on ETAF's private registry flag."
|
||||
|
||||
(defun etaf-current-slots ()
|
||||
"Return the current Component's normalized slot alist."
|
||||
(unless (eq etaf--component-phase 'render)
|
||||
(etaf--component-definition-error
|
||||
"Slots are available only during Component view/render"))
|
||||
(setq etaf--raw-slot-read-p t)
|
||||
(mapcar (lambda (entry)
|
||||
(cons (car entry)
|
||||
@ -160,9 +120,6 @@ does not depend on ETAF's private registry flag."
|
||||
|
||||
(defun etaf-current-slot (name &optional fallback)
|
||||
"Return the child list for slot NAME, or FALLBACK when it is absent."
|
||||
(unless (eq etaf--component-phase 'render)
|
||||
(etaf--component-definition-error
|
||||
"Slots are available only during Component view/render"))
|
||||
(setq etaf--raw-slot-read-p t)
|
||||
(let ((entry (assq name etaf--current-component-slots)))
|
||||
(if entry
|
||||
@ -201,51 +158,34 @@ does not depend on ETAF's private registry flag."
|
||||
name key)))))))
|
||||
form)
|
||||
|
||||
(defun etaf--component-form-contains-head-p (form heads)
|
||||
"Return non-nil when executable FORM contains a call headed by HEADS."
|
||||
(cond
|
||||
((atom form) nil)
|
||||
((memq (car form) '(quote function)) nil)
|
||||
((memq (car form) heads) t)
|
||||
(t (cl-some (lambda (part)
|
||||
(etaf--component-form-contains-head-p part heads))
|
||||
form))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro etaf-define-component (name arguments &rest clauses)
|
||||
"Define Component NAME from prop ARGUMENTS and CLAUSES.
|
||||
|
||||
Choose exactly one authoring frontend:
|
||||
The definition boundary is intentionally small:
|
||||
|
||||
(etaf-define-component NAME (&key PROPS)
|
||||
[:setup SETUP]
|
||||
:view VIEW
|
||||
:styles (styles (SELECTOR ATTR ...)))
|
||||
|
||||
or:
|
||||
|
||||
(etaf-define-component NAME (&key PROPS)
|
||||
[:setup SETUP]
|
||||
:render ORDINARY-ELISP
|
||||
:setup SETUP
|
||||
:styles (styles (SELECTOR ATTR ...)))
|
||||
|
||||
`:setup' runs once per retained identity and returns opaque state. `:view'
|
||||
is unquoted DSL; `:render' is ordinary Elisp returning the same typed View,
|
||||
usually through `etaf-view'. `etaf-node' also constructs Views
|
||||
programmatically. Both frontends use the same prop and slot rules. Bind state
|
||||
handles and prop snapshots to lexical locals for later event callbacks; keep
|
||||
reactive value reads inside the View properties or expressions they update."
|
||||
`:view' is rendered for every update. `:setup' runs once per retained
|
||||
Component instance and must return a zero-argument render function. View
|
||||
forms do not use quote; ordinary Elisp belongs in `expr :value'."
|
||||
(declare (indent 2) (debug defun))
|
||||
(unless (symbolp name)
|
||||
(etaf--component-definition-error
|
||||
"Component name must be a symbol: %S" name))
|
||||
(let ((docstring (when (stringp (car clauses)) (pop clauses)))
|
||||
view-form
|
||||
render-form
|
||||
setup-form
|
||||
styles-form
|
||||
saw-view
|
||||
saw-render
|
||||
saw-setup
|
||||
saw-styles)
|
||||
(while clauses
|
||||
@ -262,11 +202,6 @@ reactive value reads inside the View properties or expressions they update."
|
||||
(etaf--component-definition-error
|
||||
"Component %S has duplicate :view" name))
|
||||
(setq view-form (pop clauses) saw-view t))
|
||||
(:render
|
||||
(when saw-render
|
||||
(etaf--component-definition-error
|
||||
"Component %S has duplicate :render" name))
|
||||
(setq render-form (pop clauses) saw-render t))
|
||||
(:setup
|
||||
(when saw-setup
|
||||
(etaf--component-definition-error
|
||||
@ -280,49 +215,31 @@ reactive value reads inside the View properties or expressions they update."
|
||||
(_
|
||||
(etaf--component-definition-error
|
||||
"Unknown Component definition keyword %S" keyword)))))
|
||||
(when (and saw-view saw-render)
|
||||
(when (and saw-view saw-setup)
|
||||
(etaf--component-definition-error
|
||||
"Component %S must choose :view or :render, not both" name))
|
||||
(unless (or saw-view saw-render)
|
||||
"Component %S must choose :view or :setup, not both" name))
|
||||
(unless (or saw-view saw-setup)
|
||||
(etaf--component-definition-error
|
||||
"Component %S requires exactly one of :view or :render" name))
|
||||
(when (and saw-setup
|
||||
(etaf--component-form-contains-head-p
|
||||
setup-form '(etaf-view etaf-node)))
|
||||
(etaf--component-definition-error
|
||||
"Component %S :setup cannot construct View structure" name))
|
||||
(when (and saw-setup
|
||||
(consp setup-form)
|
||||
(memq (car setup-form) '(lambda function)))
|
||||
(etaf--component-definition-error
|
||||
"Component %S :setup cannot return a render function" name))
|
||||
"Component %S requires exactly one of :view or :setup" name))
|
||||
(let* ((props (etaf--parse-component-props arguments))
|
||||
(styles-form (etaf--validate-styles-form styles-form name))
|
||||
(definition-symbol
|
||||
(intern (format "%s--etaf-component-definition" name)))
|
||||
(render-lambda
|
||||
`(lambda (etaf--component-props etaf--component-slots)
|
||||
(let ((etaf--current-component-props etaf--component-props)
|
||||
(etaf--current-component-slots etaf--component-slots)
|
||||
(etaf--component-phase 'render))
|
||||
,(let ((etaf--compiling-component-props props))
|
||||
;; Expand every embedded View inside its Component prop
|
||||
;; grammar, including Views produced by lexical macros.
|
||||
;; Include the prop bindings so they shadow outer symbol
|
||||
;; macros while ordinary let/lambda shadowing is preserved.
|
||||
(macroexpand-all
|
||||
`(cl-symbol-macrolet
|
||||
,(etaf--component-prop-symbol-macros props)
|
||||
,(if saw-view
|
||||
(etaf-compiler-expand-view view-form :projection)
|
||||
render-form))
|
||||
macroexpand-all-environment)))))
|
||||
(when saw-view
|
||||
`(lambda (etaf--component-props etaf--component-slots)
|
||||
(let ((etaf--current-component-props etaf--component-props)
|
||||
(etaf--current-component-slots etaf--component-slots)
|
||||
(etaf--current-component-instance
|
||||
etaf--current-component-instance))
|
||||
(cl-symbol-macrolet
|
||||
,(etaf--component-prop-symbol-macros props)
|
||||
,(etaf--compile-view-form view-form :projection))))))
|
||||
(setup-lambda
|
||||
(when saw-setup
|
||||
`(lambda (etaf--component-props _etaf--component-slots)
|
||||
`(lambda (etaf--component-props etaf--component-slots)
|
||||
(let ((etaf--current-component-props etaf--component-props)
|
||||
(etaf--current-component-slots nil)
|
||||
(etaf--component-phase 'setup))
|
||||
(etaf--current-component-slots etaf--component-slots))
|
||||
(cl-symbol-macrolet
|
||||
,(etaf--component-prop-symbol-macros props)
|
||||
,setup-form))))))
|
||||
|
||||
@ -73,7 +73,6 @@ unchanged.")
|
||||
;;;###autoload
|
||||
(defun etaf-provide (key value)
|
||||
"Provide VALUE under stable Context KEY to the current subtree."
|
||||
(etaf--assert-not-rendering 'provide-context)
|
||||
(unless (etaf-context-p etaf--current-context)
|
||||
(error "ETAF provide requires Component setup or render context"))
|
||||
(puthash (etaf--context-key key) value
|
||||
@ -178,8 +177,7 @@ also accepted and remains tracked by the current render effect."
|
||||
validated))))
|
||||
|
||||
(defun etaf--theme-source (&optional default)
|
||||
"Return the inherited Theme source, using DEFAULT when none is provided.
|
||||
This does not read the source's reactive value."
|
||||
"Return the inherited Theme source without reading its reactive value."
|
||||
(etaf-inject 'theme default))
|
||||
|
||||
(defun etaf--theme-source-value (source &optional default tracked-p)
|
||||
|
||||
1444
etaf-data.el
1444
etaf-data.el
File diff suppressed because it is too large
Load Diff
158
etaf-events.el
158
etaf-events.el
@ -12,12 +12,9 @@
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ebox)
|
||||
(require 'etaf-scheduler)
|
||||
(require 'etaf-reactive)
|
||||
(require 'etaf-runtime)
|
||||
|
||||
(defvar etaf--current-runtime)
|
||||
(defvar etaf--observer-context)
|
||||
|
||||
(declare-function etaf-runtime-require-mounted "etaf-runtime" (&optional runtime))
|
||||
(declare-function etaf-runtime-p "etaf-runtime" (value))
|
||||
@ -27,14 +24,10 @@
|
||||
(declare-function etaf-runtime-handler-entries "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-host-props-for "etaf-runtime" (runtime host-ref))
|
||||
(declare-function etaf-runtime-host-props-entries "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-host-ancestries "etaf-runtime" (runtime host-refs))
|
||||
(declare-function etaf-runtime-focus-ref "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-set-focus-ref "etaf-runtime" (runtime host-ref))
|
||||
(declare-function etaf-runtime-event-begin "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-event-end "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-observer "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-call-operation
|
||||
"etaf-runtime" (runtime kind label function))
|
||||
(declare-function ebox-call-with-render-burst
|
||||
"ebox-buffer-backend" (function &rest arguments))
|
||||
|
||||
@ -68,15 +61,9 @@
|
||||
|
||||
When PAYLOAD-P is non-nil, pass PAYLOAD as the callback's only argument;
|
||||
otherwise call the local callback with no arguments."
|
||||
(etaf--assert-not-rendering 'dispatch-event)
|
||||
(setq runtime (etaf-runtime-require-mounted runtime))
|
||||
(let* ((dispatch
|
||||
(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))))
|
||||
(setq runtime (etaf-runtime-require-mounted runtime))
|
||||
(let ((callback (etaf--event-handler runtime host-ref kind)))
|
||||
(unless callback
|
||||
(signal 'etaf-event-error
|
||||
@ -91,19 +78,8 @@ otherwise call the local callback with no arguments."
|
||||
(if payload-p
|
||||
(funcall callback payload)
|
||||
(funcall callback))
|
||||
(etaf-runtime-event-end runtime))))))
|
||||
(run
|
||||
(lambda ()
|
||||
(etaf-scheduler-call-with-context
|
||||
(etaf-runtime-scheduler-context runtime)
|
||||
(lambda ()
|
||||
(etaf-reactive-call-with-batch dispatch))))))
|
||||
(if (or etaf--observer-context (etaf-runtime-observer runtime))
|
||||
(etaf-runtime-call-operation
|
||||
runtime 'event
|
||||
(format "%s %S" (etaf-event-kind kind) host-ref)
|
||||
(lambda () (ebox-call-with-render-burst run)))
|
||||
(ebox-call-with-render-burst run))))
|
||||
(etaf-runtime-event-end runtime)))))))
|
||||
(ebox-call-with-render-burst dispatch)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-host-ref-bounds (runtime host-ref)
|
||||
@ -125,81 +101,51 @@ otherwise call the local callback with no arguments."
|
||||
(t nil)))
|
||||
|
||||
(defun etaf--activation-candidate-before-p (left right)
|
||||
"Return non-nil when hit candidate LEFT is inside or smaller than RIGHT."
|
||||
"Return non-nil when activation candidate LEFT precedes RIGHT."
|
||||
(let ((left-length (nth 2 left))
|
||||
(right-length (nth 2 right))
|
||||
(left-start (nth 1 left))
|
||||
(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"))))
|
||||
(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)))))))))
|
||||
|
||||
(defun etaf--activation-at-position (runtime position &optional quiet)
|
||||
"Activate the deepest interaction boundary at POSITION in RUNTIME.
|
||||
"Activate the smallest enabled Host 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-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)
|
||||
(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)
|
||||
(unless quiet
|
||||
(user-error "No interactive ETAF Host at point")))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-activate (&optional runtime)
|
||||
"Dispatch `press' for the focused Host, or the interaction boundary at point.
|
||||
"Dispatch `press' for the smallest enabled Host containing 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)))
|
||||
(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))))
|
||||
(let ((position (with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(point))))
|
||||
(etaf--activation-at-position runtime position)))
|
||||
|
||||
(defun etaf--focus-candidate-before-p (left right)
|
||||
"Return non-nil when focus candidate LEFT precedes RIGHT."
|
||||
@ -217,40 +163,15 @@ RUNTIME is the mounted Runtime to activate, or nil for the current buffer."
|
||||
(let (candidates)
|
||||
(dolist (entry (etaf-runtime-host-props-entries runtime))
|
||||
(let ((host-ref (car entry)) (props (cdr entry)))
|
||||
(let ((tab-index (plist-get props :tab-index)))
|
||||
(when (and (numberp tab-index) (>= tab-index 0)
|
||||
(not (plist-get props :disabled)))
|
||||
(when-let* ((bounds
|
||||
(ebox-host-ref-bounds
|
||||
(etaf-runtime-buffer runtime) host-ref)))
|
||||
(push (list tab-index (car bounds) (cdr bounds) host-ref)
|
||||
candidates))))))
|
||||
(let ((tab-index (plist-get props :tab-index))
|
||||
(bounds (ebox-host-ref-bounds
|
||||
(etaf-runtime-buffer runtime) host-ref)))
|
||||
(when (and (numberp tab-index) (>= tab-index 0)
|
||||
(not (plist-get props :disabled)) bounds)
|
||||
(push (list tab-index (car bounds) (cdr bounds) host-ref)
|
||||
candidates)))))
|
||||
(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.
|
||||
@ -262,9 +183,6 @@ 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
|
||||
|
||||
@ -1,328 +0,0 @@
|
||||
;;; etaf-generation.el --- ETAF committed generation authority -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Owns the single mutable pointer to ETAF's committed semantic generation and
|
||||
;; pure construction/comparison of compatibility mirrors. Runtime mirrors are
|
||||
;; projections only; they never authorize semantic queries or publication.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'subr-x)
|
||||
|
||||
(define-error 'etaf-generation-error "Invalid ETAF generation authority")
|
||||
(define-error 'etaf-generation-conflict
|
||||
"Stale ETAF semantic generation candidate"
|
||||
'etaf-generation-error)
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-generation-store-versions
|
||||
(:constructor etaf-generation-store-versions--create))
|
||||
"Committed versions for ETAF's independently journaled stores."
|
||||
(instances 0 :read-only t)
|
||||
(resources 0 :read-only t)
|
||||
(artifacts 0 :read-only t)
|
||||
(routes 0 :read-only t))
|
||||
|
||||
(defun etaf-generation-store-versions-create ()
|
||||
"Return an immutable zeroed ETAF store-version snapshot."
|
||||
(etaf-generation-store-versions--create))
|
||||
|
||||
(defun etaf-generation-store-versions-next (versions)
|
||||
"Return the immutable successor of store VERSIONS snapshot."
|
||||
(unless (etaf-generation-store-versions-p versions)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-store-versions-p versions)))
|
||||
(etaf-generation-store-versions--create
|
||||
:instances (1+ (etaf-generation-store-versions-instances versions))
|
||||
:resources (1+ (etaf-generation-store-versions-resources versions))
|
||||
:artifacts (1+ (etaf-generation-store-versions-artifacts versions))
|
||||
:routes (1+ (etaf-generation-store-versions-routes versions))))
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-generation-authority
|
||||
(:constructor etaf-generation-authority--create))
|
||||
"Mutable authority for one Runtime's committed generation."
|
||||
generation
|
||||
(token 0)
|
||||
(store-versions (etaf-generation-store-versions-create)))
|
||||
|
||||
(defun etaf-generation-authority-create (&optional generation)
|
||||
"Return fresh authority initially pointing at GENERATION."
|
||||
(etaf-generation-authority--create
|
||||
:generation generation
|
||||
:token 0
|
||||
:store-versions (etaf-generation-store-versions-create)))
|
||||
|
||||
(defun etaf-generation-authority-current (authority)
|
||||
"Return AUTHORITY's current committed generation."
|
||||
(unless (etaf-generation-authority-p authority)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-authority-p authority)))
|
||||
(etaf-generation-authority-generation authority))
|
||||
|
||||
(defun etaf-generation-authority-set-current (authority generation)
|
||||
"Set AUTHORITY's current committed GENERATION and return GENERATION.
|
||||
This compatibility mutation does not advance the semantic commit token; the
|
||||
versioned compare-and-swap boundary owns token changes."
|
||||
(unless (etaf-generation-authority-p authority)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-authority-p authority)))
|
||||
(setf (etaf-generation-authority-generation authority) generation)
|
||||
generation)
|
||||
|
||||
(defun etaf-generation-authority-snapshot (authority)
|
||||
"Return AUTHORITY's immutable generation/token/version snapshot."
|
||||
(unless (etaf-generation-authority-p authority)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-authority-p authority)))
|
||||
(list :generation (etaf-generation-authority-generation authority)
|
||||
:token (etaf-generation-authority-token authority)
|
||||
:store-versions
|
||||
(etaf-generation-authority-store-versions authority)))
|
||||
|
||||
(defun etaf-generation-authority-validate
|
||||
(authority expected-generation expected-token expected-store-versions)
|
||||
"Validate AUTHORITY against EXPECTED-GENERATION and EXPECTED-TOKEN.
|
||||
EXPECTED-STORE-VERSIONS must also equal the committed version snapshot."
|
||||
(unless (and (eq (etaf-generation-authority-generation authority)
|
||||
expected-generation)
|
||||
(eql (etaf-generation-authority-token authority)
|
||||
expected-token)
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
expected-store-versions))
|
||||
(signal 'etaf-generation-conflict
|
||||
(list
|
||||
:expected-generation expected-generation
|
||||
:actual-generation
|
||||
(etaf-generation-authority-generation authority)
|
||||
:expected-token expected-token
|
||||
:actual-token (etaf-generation-authority-token authority)
|
||||
:expected-store-versions expected-store-versions
|
||||
:actual-store-versions
|
||||
(etaf-generation-authority-store-versions authority))))
|
||||
t)
|
||||
|
||||
(defun etaf-generation-authority-compare-and-swap
|
||||
(authority expected-generation expected-token expected-store-versions
|
||||
next-generation next-token next-store-versions)
|
||||
"Atomically swap AUTHORITY from EXPECTED-GENERATION to NEXT-GENERATION.
|
||||
EXPECTED-TOKEN and EXPECTED-STORE-VERSIONS guard the old authority;
|
||||
NEXT-TOKEN and NEXT-STORE-VERSIONS become committed together."
|
||||
(etaf-generation-authority-validate
|
||||
authority expected-generation expected-token expected-store-versions)
|
||||
(unless (and (integerp next-token) (> next-token expected-token))
|
||||
(signal 'etaf-generation-error
|
||||
(list :invalid-next-token next-token)))
|
||||
(unless (etaf-generation-store-versions-p next-store-versions)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-store-versions-p next-store-versions)))
|
||||
(let ((inhibit-quit t))
|
||||
(setf (etaf-generation-authority-generation authority) next-generation
|
||||
(etaf-generation-authority-token authority) next-token
|
||||
(etaf-generation-authority-store-versions authority)
|
||||
next-store-versions))
|
||||
next-generation)
|
||||
|
||||
(defun etaf-generation-authority-rollback-swap
|
||||
(authority expected-generation expected-token expected-store-versions
|
||||
candidate-generation candidate-token candidate-store-versions)
|
||||
"Restore EXPECTED-GENERATION and EXPECTED-TOKEN in AUTHORITY.
|
||||
EXPECTED-STORE-VERSIONS are restored only while CANDIDATE-GENERATION,
|
||||
CANDIDATE-TOKEN, and CANDIDATE-STORE-VERSIONS still match exactly."
|
||||
(when (and (eq (etaf-generation-authority-generation authority)
|
||||
candidate-generation)
|
||||
(eql (etaf-generation-authority-token authority) candidate-token)
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
candidate-store-versions))
|
||||
(let ((inhibit-quit t))
|
||||
(setf (etaf-generation-authority-generation authority)
|
||||
expected-generation
|
||||
(etaf-generation-authority-token authority) expected-token
|
||||
(etaf-generation-authority-store-versions authority)
|
||||
expected-store-versions))
|
||||
t))
|
||||
|
||||
(defcustom etaf-semantic-commit-route 'cas
|
||||
"Semantic generation commit route.
|
||||
`legacy' changes only the compatibility generation pointer, `cas' performs the
|
||||
versioned token/store compare-and-swap, and `shadow' validates the same expected
|
||||
facts before using the CAS route."
|
||||
:type '(choice (const legacy) (const cas) (const shadow))
|
||||
:group 'etaf)
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-semantic-candidate
|
||||
(:constructor etaf-semantic-candidate--create))
|
||||
"One-shot ETAF semantic authority candidate."
|
||||
operation-id
|
||||
candidate-id
|
||||
runtime-id
|
||||
mount-epoch
|
||||
authority
|
||||
expected-generation
|
||||
candidate-generation
|
||||
expected-store-versions
|
||||
candidate-store-versions
|
||||
expected-token
|
||||
candidate-token
|
||||
inverse-journal
|
||||
route
|
||||
(state 'prepared))
|
||||
|
||||
(defun etaf-semantic-candidate-create
|
||||
(authority candidate-generation operation-id candidate-id runtime-id
|
||||
mount-epoch)
|
||||
"Prepare a semantic candidate for AUTHORITY and CANDIDATE-GENERATION.
|
||||
OPERATION-ID, CANDIDATE-ID, RUNTIME-ID, and MOUNT-EPOCH provide immutable
|
||||
correlation and authority identity."
|
||||
(unless (etaf-generation-authority-p authority)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-generation-authority-p authority)))
|
||||
(let* ((snapshot (etaf-generation-authority-snapshot authority))
|
||||
(expected-token (plist-get snapshot :token))
|
||||
(expected-versions (plist-get snapshot :store-versions)))
|
||||
(etaf-semantic-candidate--create
|
||||
:operation-id operation-id
|
||||
:candidate-id candidate-id
|
||||
:runtime-id runtime-id
|
||||
:mount-epoch mount-epoch
|
||||
:authority authority
|
||||
:expected-generation (plist-get snapshot :generation)
|
||||
:candidate-generation candidate-generation
|
||||
:expected-store-versions expected-versions
|
||||
:candidate-store-versions
|
||||
(etaf-generation-store-versions-next expected-versions)
|
||||
:expected-token expected-token
|
||||
:candidate-token (1+ expected-token))))
|
||||
|
||||
(defun etaf-semantic-candidate-stage (candidate)
|
||||
"Install CANDIDATE provisionally through its selected authority route."
|
||||
(unless (eq (etaf-semantic-candidate-state candidate) 'prepared)
|
||||
(signal 'etaf-generation-error
|
||||
(list :candidate-not-prepared
|
||||
(etaf-semantic-candidate-state candidate))))
|
||||
(let ((authority (etaf-semantic-candidate-authority candidate))
|
||||
(route etaf-semantic-commit-route))
|
||||
(pcase route
|
||||
('legacy
|
||||
(etaf-generation-authority-validate
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)
|
||||
(etaf-semantic-candidate-expected-token candidate)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate))
|
||||
(etaf-generation-authority-set-current
|
||||
authority (etaf-semantic-candidate-candidate-generation candidate)))
|
||||
((or 'cas 'shadow)
|
||||
(etaf-generation-authority-compare-and-swap
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)
|
||||
(etaf-semantic-candidate-expected-token candidate)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate)
|
||||
(etaf-semantic-candidate-candidate-generation candidate)
|
||||
(etaf-semantic-candidate-candidate-token candidate)
|
||||
(etaf-semantic-candidate-candidate-store-versions candidate)))
|
||||
(_
|
||||
(signal 'etaf-generation-error
|
||||
(list :unknown-semantic-commit-route route))))
|
||||
(setf (etaf-semantic-candidate-route candidate) route
|
||||
(etaf-semantic-candidate-state candidate) 'staged)
|
||||
candidate))
|
||||
|
||||
(defun etaf-semantic-candidate-commit (candidate)
|
||||
"Mark provisionally installed CANDIDATE committed exactly once."
|
||||
(unless (eq (etaf-semantic-candidate-state candidate) 'staged)
|
||||
(signal 'etaf-generation-error
|
||||
(list :candidate-not-staged
|
||||
(etaf-semantic-candidate-state candidate))))
|
||||
(let ((authority (etaf-semantic-candidate-authority candidate)))
|
||||
(unless (eq (etaf-generation-authority-generation authority)
|
||||
(etaf-semantic-candidate-candidate-generation candidate))
|
||||
(signal 'etaf-generation-conflict
|
||||
(list :candidate-generation-lost
|
||||
(etaf-semantic-candidate-candidate-id candidate))))
|
||||
(unless (or (eq (etaf-semantic-candidate-route candidate) 'legacy)
|
||||
(eql (etaf-generation-authority-token authority)
|
||||
(etaf-semantic-candidate-candidate-token candidate)))
|
||||
(signal 'etaf-generation-conflict
|
||||
(list :candidate-token-lost
|
||||
(etaf-semantic-candidate-candidate-id candidate))))
|
||||
(setf (etaf-semantic-candidate-state candidate) 'committed)
|
||||
candidate))
|
||||
|
||||
(defun etaf-semantic-candidate-rollback (candidate)
|
||||
"Rollback staged CANDIDATE exactly once and return CANDIDATE."
|
||||
(pcase (etaf-semantic-candidate-state candidate)
|
||||
('prepared
|
||||
(setf (etaf-semantic-candidate-state candidate) 'rolled-back))
|
||||
('staged
|
||||
(let ((authority (etaf-semantic-candidate-authority candidate)))
|
||||
(if (eq (etaf-semantic-candidate-route candidate) 'legacy)
|
||||
(when (eq (etaf-generation-authority-generation authority)
|
||||
(etaf-semantic-candidate-candidate-generation candidate))
|
||||
(etaf-generation-authority-set-current
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)))
|
||||
(etaf-generation-authority-rollback-swap
|
||||
authority
|
||||
(etaf-semantic-candidate-expected-generation candidate)
|
||||
(etaf-semantic-candidate-expected-token candidate)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate)
|
||||
(etaf-semantic-candidate-candidate-generation candidate)
|
||||
(etaf-semantic-candidate-candidate-token candidate)
|
||||
(etaf-semantic-candidate-candidate-store-versions candidate)))
|
||||
(setf (etaf-semantic-candidate-state candidate) 'rolled-back)))
|
||||
('rolled-back nil)
|
||||
(_
|
||||
(signal 'etaf-generation-error
|
||||
(list :candidate-not-rollback-capable
|
||||
(etaf-semantic-candidate-state candidate)))))
|
||||
candidate)
|
||||
|
||||
(defun etaf-generation-project-mirror (entries &optional test)
|
||||
"Project immutable contribution ENTRIES into a fresh hash table.
|
||||
TEST defaults to `equal'. Duplicate keys are rejected so a compatibility
|
||||
mirror cannot silently choose a second semantic truth."
|
||||
(unless (proper-list-p entries)
|
||||
(signal 'wrong-type-argument (list 'proper-list-p entries)))
|
||||
(let ((table (make-hash-table :test (or test #'equal)))
|
||||
(missing (make-symbol "etaf-generation-mirror-missing")))
|
||||
(dolist (entry entries)
|
||||
(unless (consp entry)
|
||||
(signal 'etaf-generation-error
|
||||
(list :malformed-mirror-entry entry)))
|
||||
(let ((key (car entry)))
|
||||
(unless (eq (gethash key table missing) missing)
|
||||
(signal 'etaf-generation-error
|
||||
(list :duplicate-mirror-key key)))
|
||||
(puthash (copy-tree key) (copy-tree (cdr entry)) table)))
|
||||
table))
|
||||
|
||||
(defun etaf-generation-project-mirrors (handler-entries host-prop-entries)
|
||||
"Return fresh mirrors from HANDLER-ENTRIES and HOST-PROP-ENTRIES."
|
||||
(list :handlers
|
||||
(etaf-generation-project-mirror handler-entries #'equal)
|
||||
:host-props
|
||||
(etaf-generation-project-mirror host-prop-entries #'equal)))
|
||||
|
||||
(defun etaf-generation-mirror-equal-p (left right)
|
||||
"Return non-nil when hash tables LEFT and RIGHT contain equal facts."
|
||||
(and (hash-table-p left)
|
||||
(hash-table-p right)
|
||||
(= (hash-table-count left) (hash-table-count right))
|
||||
(let ((missing (make-symbol "etaf-generation-mirror-missing"))
|
||||
equal-p)
|
||||
(setq equal-p t)
|
||||
(maphash
|
||||
(lambda (key value)
|
||||
(unless (equal value (gethash key right missing))
|
||||
(setq equal-p nil)))
|
||||
left)
|
||||
equal-p)))
|
||||
|
||||
(provide 'etaf-generation)
|
||||
|
||||
;;; etaf-generation.el ends here
|
||||
172
etaf-host.el
172
etaf-host.el
@ -1,172 +0,0 @@
|
||||
;;; etaf-host.el --- ETAF Host attach/detach authority -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Owns one mounted Runtime's fixed Host authority token and state machine.
|
||||
;; Initial attachment registers a bounded TP final marker so attached
|
||||
;; authority and buffer publication share one final-accept boundary. Detach
|
||||
;; invalidates authority in O(1) before any unbounded retirement work.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'tp-transaction)
|
||||
(require 'tp-reactive)
|
||||
|
||||
(define-error 'etaf-host-authority-error "Invalid ETAF Host authority state")
|
||||
|
||||
(defconst etaf-host--state-slot 0)
|
||||
(defconst etaf-host--token-slot 1)
|
||||
(defconst etaf-host--version-slot 2)
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-host-authority
|
||||
(:constructor etaf-host-authority--create))
|
||||
"Fixed identity and mutable authority slots for one Runtime Host."
|
||||
host-id
|
||||
mount-epoch
|
||||
buffer
|
||||
slots)
|
||||
|
||||
(defun etaf-host-authority-create (host-id mount-epoch buffer)
|
||||
"Return detached authority for HOST-ID, MOUNT-EPOCH, and BUFFER."
|
||||
(unless (and host-id (integerp mount-epoch) (> mount-epoch 0)
|
||||
(bufferp buffer))
|
||||
(signal 'etaf-host-authority-error
|
||||
(list :invalid-host host-id mount-epoch buffer)))
|
||||
(etaf-host-authority--create
|
||||
:host-id host-id
|
||||
:mount-epoch mount-epoch
|
||||
:buffer buffer
|
||||
:slots (vector 'detached
|
||||
(list 'etaf-host-token mount-epoch (make-symbol "token"))
|
||||
0)))
|
||||
|
||||
(defun etaf-host-authority-state (authority)
|
||||
"Return AUTHORITY's current Host state."
|
||||
(aref (etaf-host-authority-slots authority) etaf-host--state-slot))
|
||||
|
||||
(defun etaf-host-authority-token (authority)
|
||||
"Return AUTHORITY's current opaque token, or nil after detach."
|
||||
(aref (etaf-host-authority-slots authority) etaf-host--token-slot))
|
||||
|
||||
(defun etaf-host-authority-version (authority)
|
||||
"Return AUTHORITY's monotonic registration version."
|
||||
(aref (etaf-host-authority-slots authority) etaf-host--version-slot))
|
||||
|
||||
(defun etaf-host-authority-attached-p (authority)
|
||||
"Return non-nil when AUTHORITY is publicly attached."
|
||||
(and (etaf-host-authority-p authority)
|
||||
(eq (etaf-host-authority-state authority) 'attached)
|
||||
(etaf-host-authority-token authority)))
|
||||
|
||||
(defun etaf-host-authority-accepts-token-p (authority token)
|
||||
"Return non-nil when attached AUTHORITY accepts opaque TOKEN."
|
||||
(and (etaf-host-authority-attached-p authority)
|
||||
(eq token (etaf-host-authority-token authority))))
|
||||
|
||||
(defun etaf-host-authority-begin-attach (authority)
|
||||
"Move detached AUTHORITY into its private attaching state."
|
||||
(unless (eq (etaf-host-authority-state authority) 'detached)
|
||||
(signal 'etaf-host-authority-error
|
||||
(list :begin-attach (etaf-host-authority-state authority))))
|
||||
(aset (etaf-host-authority-slots authority)
|
||||
etaf-host--state-slot 'attaching)
|
||||
authority)
|
||||
|
||||
(defun etaf-host--slot-write (authority index value)
|
||||
"Return one prebuilt TP marker write for AUTHORITY slot INDEX and VALUE."
|
||||
(tp-final-marker-slot-write-create
|
||||
:target (etaf-host-authority-slots authority)
|
||||
:index index
|
||||
:value value))
|
||||
|
||||
(defun etaf-host-authority-stage-attach (authority)
|
||||
"Stage AUTHORITY attachment and register its final marker."
|
||||
(unless (eq (etaf-host-authority-state authority) 'attaching)
|
||||
(signal 'etaf-host-authority-error
|
||||
(list :stage-attach (etaf-host-authority-state authority))))
|
||||
(let* ((slots (etaf-host-authority-slots authority))
|
||||
(token (etaf-host-authority-token authority))
|
||||
(version (etaf-host-authority-version authority)))
|
||||
(aset slots etaf-host--state-slot 'provisionally-attached)
|
||||
(tp-transaction-register-final-marker
|
||||
:owner-key
|
||||
(list 'etaf-host
|
||||
(etaf-host-authority-host-id authority)
|
||||
(etaf-host-authority-mount-epoch authority))
|
||||
:expected-token
|
||||
(tp-final-marker-expectation-create
|
||||
:target slots :index etaf-host--token-slot :value token)
|
||||
:expected-version
|
||||
(tp-final-marker-expectation-create
|
||||
:target slots :index etaf-host--version-slot :value version)
|
||||
:next-values
|
||||
(vector
|
||||
(etaf-host--slot-write authority etaf-host--state-slot 'attached)
|
||||
(etaf-host--slot-write authority etaf-host--version-slot (1+ version)))
|
||||
:inverse-values
|
||||
(vector
|
||||
(etaf-host--slot-write
|
||||
authority etaf-host--state-slot 'provisionally-attached)
|
||||
(etaf-host--slot-write authority etaf-host--version-slot version))
|
||||
:slot-write-count 2
|
||||
:operation-key 'tp-vector-slots/v1)
|
||||
authority))
|
||||
|
||||
(defun etaf-host-authority-rollback-attach (authority)
|
||||
"Restore failed attaching AUTHORITY to detached, idempotently."
|
||||
(pcase (etaf-host-authority-state authority)
|
||||
((or 'attaching 'provisionally-attached 'attached)
|
||||
(aset (etaf-host-authority-slots authority)
|
||||
etaf-host--state-slot 'detached))
|
||||
((or 'detached 'terminal) nil)
|
||||
(state
|
||||
(signal 'etaf-host-authority-error (list :rollback-attach state))))
|
||||
authority)
|
||||
|
||||
(defun etaf-host-authority-finish-attach (authority)
|
||||
"Validate and return final-accept attached AUTHORITY."
|
||||
(unless (etaf-host-authority-attached-p authority)
|
||||
(signal 'etaf-host-authority-error
|
||||
(list :finish-attach (etaf-host-authority-state authority))))
|
||||
authority)
|
||||
|
||||
(defun etaf-host-authority-begin-detach (authority)
|
||||
"Move attached AUTHORITY into pre-boundary detaching state."
|
||||
(unless (etaf-host-authority-attached-p authority)
|
||||
(signal 'etaf-host-authority-error
|
||||
(list :begin-detach (etaf-host-authority-state authority))))
|
||||
(aset (etaf-host-authority-slots authority)
|
||||
etaf-host--state-slot 'detaching)
|
||||
authority)
|
||||
|
||||
(defun etaf-host-authority-invalidate (authority)
|
||||
"Invalidate AUTHORITY token in O(1) and enter detached retirement."
|
||||
(unless (memq (etaf-host-authority-state authority)
|
||||
'(detaching attaching provisionally-attached detached))
|
||||
(signal 'etaf-host-authority-error
|
||||
(list :invalidate (etaf-host-authority-state authority))))
|
||||
(let* ((slots (etaf-host-authority-slots authority))
|
||||
(version (etaf-host-authority-version authority))
|
||||
(inhibit-quit t))
|
||||
(aset slots etaf-host--state-slot 'detached-retiring)
|
||||
(aset slots etaf-host--token-slot nil)
|
||||
(aset slots etaf-host--version-slot (1+ version)))
|
||||
authority)
|
||||
|
||||
(defun etaf-host-authority-finish-detach (authority)
|
||||
"Move detached-retiring AUTHORITY to terminal."
|
||||
(unless (memq (etaf-host-authority-state authority)
|
||||
'(detached-retiring terminal))
|
||||
(signal 'etaf-host-authority-error
|
||||
(list :finish-detach (etaf-host-authority-state authority))))
|
||||
(aset (etaf-host-authority-slots authority)
|
||||
etaf-host--state-slot 'terminal)
|
||||
authority)
|
||||
|
||||
(provide 'etaf-host)
|
||||
|
||||
;;; etaf-host.el ends here
|
||||
202
etaf-observer.el
202
etaf-observer.el
@ -1,202 +0,0 @@
|
||||
;;; etaf-observer.el --- Scoped ETAF Runtime observation -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file defines the deliberately small observation port used by the ETAF
|
||||
;; Runtime. Observation is scoped to one dynamic operation; it is neither a
|
||||
;; global subscription service nor publication authority. When no context is
|
||||
;; active, instrumented stages execute their original body directly.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
|
||||
(define-error 'etaf-observer-error "Invalid ETAF observer operation")
|
||||
|
||||
(defconst etaf-observer-report-format-version 1
|
||||
"Format version of flat ETAF observation reports.")
|
||||
|
||||
(defconst etaf--observer-context-keys
|
||||
'(:format-version :operation-id :sequence :runtime-id :buffer-name)
|
||||
"Report fields owned exclusively by the active operation context.")
|
||||
|
||||
(cl-defstruct (etaf--observer-context
|
||||
(:constructor etaf--observer-context--make))
|
||||
"Dynamic observation state for one ETAF Runtime operation."
|
||||
sink
|
||||
operation-id
|
||||
runtime-id
|
||||
buffer-name
|
||||
(sequence 0)
|
||||
diagnostic)
|
||||
|
||||
(defvar etaf--observer-context nil
|
||||
"Dynamically active ETAF observation context, or nil.")
|
||||
|
||||
(defun etaf--observer-provider-report-valid-p (report)
|
||||
"Return non-nil when REPORT is a valid provider report."
|
||||
(and (proper-list-p report)
|
||||
(zerop (% (length report) 2))
|
||||
(let ((tail report)
|
||||
keys
|
||||
valid)
|
||||
(setq valid t)
|
||||
(while (and tail valid)
|
||||
(let ((key (pop tail)))
|
||||
(pop tail)
|
||||
(setq valid
|
||||
(and (keywordp key)
|
||||
(not (memq key keys))
|
||||
(not (memq key etaf--observer-context-keys))))
|
||||
(push key keys)))
|
||||
(and valid
|
||||
(plist-member report :provider)
|
||||
(let ((provider (plist-get report :provider)))
|
||||
(and provider (symbolp provider) (not (keywordp provider))))
|
||||
(plist-member report :stage)
|
||||
(let ((stage (plist-get report :stage)))
|
||||
(and stage (symbolp stage) (not (keywordp stage))))
|
||||
(or (not (plist-member report :status))
|
||||
(memq (plist-get report :status) '(success error quit)))
|
||||
(plist-member report :duration-ms)
|
||||
(numberp (plist-get report :duration-ms))
|
||||
(>= (plist-get report :duration-ms) 0)))))
|
||||
|
||||
(defun etaf--observer-copy-value (value)
|
||||
"Return a defensive observation copy of VALUE."
|
||||
(cond
|
||||
((stringp value) (copy-sequence value))
|
||||
((consp value)
|
||||
(cons (etaf--observer-copy-value (car value))
|
||||
(etaf--observer-copy-value (cdr value))))
|
||||
((vectorp value)
|
||||
(apply #'vector
|
||||
(mapcar #'etaf--observer-copy-value (append value nil))))
|
||||
(t value)))
|
||||
|
||||
(defun etaf--observer-report-copy (report)
|
||||
"Return an isolated snapshot of validated provider REPORT."
|
||||
(etaf--observer-copy-value report))
|
||||
|
||||
(defun etaf--observer-diagnose (kind condition)
|
||||
"Contain KIND and CONDITION with the active context diagnostic sink."
|
||||
(when-let* ((context etaf--observer-context)
|
||||
(diagnostic (etaf--observer-context-diagnostic context)))
|
||||
(let ((inhibit-quit t)
|
||||
(quit-flag nil))
|
||||
(condition-case nil
|
||||
(funcall diagnostic
|
||||
(list :kind kind :condition (copy-tree condition)))
|
||||
((error quit) nil))))
|
||||
nil)
|
||||
|
||||
(cl-defun etaf--observer-context-create
|
||||
(&key sink operation-id runtime-id buffer-name diagnostic)
|
||||
"Create scoped observer state for one Runtime operation.
|
||||
|
||||
SINK receives one defensive report snapshot. OPERATION-ID and RUNTIME-ID are
|
||||
stable scalar identities, BUFFER-NAME is a string or nil, and DIAGNOSTIC
|
||||
receives contained observer-port failures. This internal constructor is the
|
||||
only Runtime entry point that allocates observation state."
|
||||
(unless (functionp sink)
|
||||
(signal 'etaf-observer-error '(Observer sink must be a function)))
|
||||
(unless (integerp operation-id)
|
||||
(signal 'etaf-observer-error '(Operation identity must be an integer)))
|
||||
(unless (integerp runtime-id)
|
||||
(signal 'etaf-observer-error '(Runtime identity must be an integer)))
|
||||
(unless (or (null buffer-name) (stringp buffer-name))
|
||||
(signal 'etaf-observer-error '(Buffer name must be a string or nil)))
|
||||
(unless (functionp diagnostic)
|
||||
(signal 'etaf-observer-error '(Diagnostic sink must be a function)))
|
||||
(etaf--observer-context--make
|
||||
:sink sink
|
||||
:operation-id operation-id
|
||||
:runtime-id runtime-id
|
||||
:buffer-name (and buffer-name (copy-sequence buffer-name))
|
||||
:diagnostic diagnostic))
|
||||
|
||||
(defun etaf--observer-call-with-context (context function)
|
||||
"Call FUNCTION with internal observer CONTEXT dynamically active."
|
||||
(unless (etaf--observer-context-p context)
|
||||
(signal 'etaf-observer-error '(Invalid observer context)))
|
||||
(unless (functionp function)
|
||||
(signal 'etaf-observer-error '(Observed operation must be a function)))
|
||||
(let ((etaf--observer-context context))
|
||||
(funcall function)))
|
||||
|
||||
(defun etaf-observer-emit (report)
|
||||
"Decorate and deliver immutable provider REPORT in the active context.
|
||||
|
||||
The observer receives a defensive copy. Observer errors, quits, and invalid
|
||||
reports are contained by the context diagnostic sink and never affect product
|
||||
execution. The dynamic context is cleared during delivery so an observer can
|
||||
reenter ETAF without recursively observing itself."
|
||||
(when etaf--observer-context
|
||||
(if (not (etaf--observer-provider-report-valid-p report))
|
||||
(etaf--observer-diagnose 'invalid-report report)
|
||||
(let* ((context etaf--observer-context)
|
||||
(sequence (1+ (etaf--observer-context-sequence context)))
|
||||
(sink (etaf--observer-context-sink context))
|
||||
(provider-report (etaf--observer-report-copy report))
|
||||
(snapshot
|
||||
(append
|
||||
(list :format-version etaf-observer-report-format-version
|
||||
:operation-id
|
||||
(etaf--observer-context-operation-id context)
|
||||
:sequence sequence
|
||||
:runtime-id (etaf--observer-context-runtime-id context)
|
||||
:buffer-name
|
||||
(etaf--observer-copy-value
|
||||
(etaf--observer-context-buffer-name context)))
|
||||
provider-report
|
||||
(unless (plist-member provider-report :status)
|
||||
(list :status 'success))))
|
||||
(inhibit-quit t)
|
||||
(quit-flag nil))
|
||||
(setf (etaf--observer-context-sequence context) sequence)
|
||||
(condition-case condition
|
||||
(let ((etaf--observer-context nil))
|
||||
(funcall sink snapshot))
|
||||
((error quit)
|
||||
(etaf--observer-diagnose 'observer-failure condition))))))
|
||||
nil)
|
||||
|
||||
(defun etaf--observer-finish-stage (provider stage metadata status started)
|
||||
"Emit PROVIDER STAGE with METADATA, STATUS, and STARTED timestamp."
|
||||
(let ((duration-ms (max 0.0 (* 1000.0 (- (float-time) started)))))
|
||||
(etaf-observer-emit
|
||||
(append (list :provider provider :stage stage :status status
|
||||
:duration-ms duration-ms)
|
||||
metadata))))
|
||||
|
||||
(defun etaf--observer-call-stage (provider stage metadata function)
|
||||
"Call observed PROVIDER STAGE FUNCTION with METADATA."
|
||||
(let ((started (float-time)))
|
||||
(condition-case condition
|
||||
(prog1 (funcall function)
|
||||
(etaf--observer-finish-stage
|
||||
provider stage metadata 'success started))
|
||||
(quit
|
||||
(etaf--observer-finish-stage provider stage metadata 'quit started)
|
||||
(signal (car condition) (cdr condition)))
|
||||
(error
|
||||
(etaf--observer-finish-stage provider stage metadata 'error started)
|
||||
(signal (car condition) (cdr condition))))))
|
||||
|
||||
(cl-defmacro etaf-observer-with-stage
|
||||
((provider stage &rest metadata) &rest body)
|
||||
"Execute BODY as PROVIDER STAGE with optional METADATA.
|
||||
|
||||
The nil path is a single branch directly to BODY: it takes no timestamp,
|
||||
allocates no closure or report, and reads no garbage-collection state."
|
||||
(declare (indent 1) (debug ((form form &rest form) body)))
|
||||
`(if (null etaf--observer-context)
|
||||
(progn ,@body)
|
||||
(etaf--observer-call-stage
|
||||
,provider ,stage (list ,@metadata) (lambda () ,@body))))
|
||||
|
||||
(provide 'etaf-observer)
|
||||
|
||||
;;; etaf-observer.el ends here
|
||||
1064
etaf-performance.el
1064
etaf-performance.el
File diff suppressed because it is too large
Load Diff
230
etaf-reactive.el
230
etaf-reactive.el
@ -12,15 +12,11 @@
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'gv)
|
||||
(require 'etaf-scheduler)
|
||||
|
||||
(define-error 'etaf-reactive-error "Invalid ETAF reactive operation")
|
||||
(define-error 'etaf-render-side-effect-error
|
||||
"ETAF render must be side-effect free"
|
||||
'etaf-reactive-error)
|
||||
(define-error 'etaf-render-write-error
|
||||
"ETAF state cannot be written while rendering"
|
||||
'etaf-render-side-effect-error)
|
||||
'etaf-reactive-error)
|
||||
|
||||
(cl-defstruct (etaf-ref
|
||||
(:constructor etaf--ref-create))
|
||||
@ -54,7 +50,6 @@
|
||||
scheduler
|
||||
deps
|
||||
owner-scope
|
||||
scheduler-context
|
||||
on-stop
|
||||
name
|
||||
(active-p t)
|
||||
@ -67,16 +62,13 @@
|
||||
effects
|
||||
children
|
||||
cleanups
|
||||
scheduler-context
|
||||
name
|
||||
(active-p t))
|
||||
|
||||
(cl-defstruct (etaf-runtime-route
|
||||
(:constructor etaf-runtime-route-create))
|
||||
"Opaque Runtime route stored by reactive sources."
|
||||
runtime-id mount-epoch authority-token scheduler scheduler-context
|
||||
accepts-p
|
||||
(active-p t))
|
||||
runtime-id mount-epoch scheduler)
|
||||
|
||||
(defvar etaf--active-effect nil
|
||||
"The effect currently collecting dependencies.")
|
||||
@ -101,71 +93,78 @@
|
||||
(defvar etaf--render-phase-p nil
|
||||
"Whether the current call is producing a View tree.")
|
||||
|
||||
(defun etaf--assert-not-rendering (operation)
|
||||
"Reject detectable side-effect OPERATION during pure render."
|
||||
(when etaf--render-phase-p
|
||||
(signal 'etaf-render-side-effect-error (list operation))))
|
||||
|
||||
(defvar etaf--watch-scheduler nil
|
||||
"Scheduler for watchers created in the current Scope.
|
||||
|
||||
The function receives a zero-argument job and a phase symbol. Outside a
|
||||
Runtime, watchers run synchronously.")
|
||||
|
||||
(defun etaf--subscriber-scheduler-context (subscriber)
|
||||
"Return SUBSCRIBER's scheduler context or the default context."
|
||||
(or (cond
|
||||
((etaf-runtime-route-p subscriber)
|
||||
(etaf-runtime-route-scheduler-context subscriber))
|
||||
((etaf-effect-p subscriber)
|
||||
(etaf-effect-scheduler-context subscriber)))
|
||||
etaf-scheduler-default-context))
|
||||
(defvar etaf--dispatch-depth 0)
|
||||
(defvar etaf--dispatch-source-queue nil)
|
||||
(defvar etaf--dispatch-source-queue-tail nil)
|
||||
(defvar etaf--dispatch-source-set (make-hash-table :test #'eq))
|
||||
(defvar etaf--dispatch-runtime-queue nil)
|
||||
(defvar etaf--dispatch-runtime-queue-tail nil)
|
||||
(defvar etaf--dispatch-runtime-set (make-hash-table :test #'eq))
|
||||
(defvar etaf--dispatch-effect-set (make-hash-table :test #'eq))
|
||||
|
||||
(defun etaf-runtime-route-live-p (route)
|
||||
"Return non-nil when opaque Runtime ROUTE still owns dispatch authority."
|
||||
(and (etaf-runtime-route-p route)
|
||||
(etaf-runtime-route-active-p route)
|
||||
(let ((predicate (etaf-runtime-route-accepts-p route)))
|
||||
(or (null predicate)
|
||||
(condition-case condition
|
||||
(funcall predicate route)
|
||||
((error quit)
|
||||
(etaf-scheduler-record-route-authority-fault
|
||||
(etaf--subscriber-scheduler-context route) condition)
|
||||
nil))))))
|
||||
(defun etaf--dispatch-append-source (source)
|
||||
"Append SOURCE to the reactive FIFO in constant time."
|
||||
(let ((cell (list source)))
|
||||
(if etaf--dispatch-source-queue-tail
|
||||
(setcdr etaf--dispatch-source-queue-tail cell)
|
||||
(setq etaf--dispatch-source-queue cell))
|
||||
(setq etaf--dispatch-source-queue-tail cell)))
|
||||
|
||||
(defun etaf-reactive-enqueue-runtime-flush
|
||||
(runtime function &optional scheduler-context)
|
||||
"Queue FUNCTION once for RUNTIME in SCHEDULER-CONTEXT.
|
||||
The default context preserves the legacy two-argument facade."
|
||||
(etaf-scheduler-enqueue-runtime
|
||||
(or scheduler-context (etaf-scheduler-current-context))
|
||||
runtime function))
|
||||
(defun etaf--dispatch-append-runtime (runtime)
|
||||
"Append RUNTIME to the reactive publication FIFO in constant time."
|
||||
(let ((cell (list runtime)))
|
||||
(if etaf--dispatch-runtime-queue-tail
|
||||
(setcdr etaf--dispatch-runtime-queue-tail cell)
|
||||
(setq etaf--dispatch-runtime-queue cell))
|
||||
(setq etaf--dispatch-runtime-queue-tail cell)))
|
||||
|
||||
(defun etaf--dispatch-subscriber-group
|
||||
(context source _projection-epoch subscribers)
|
||||
"Notify SOURCE SUBSCRIBERS already grouped for scheduler CONTEXT."
|
||||
(let (first-condition)
|
||||
(dolist (subscriber subscribers)
|
||||
(etaf-scheduler-record-subscriber-visit context)
|
||||
(condition-case condition
|
||||
(cond
|
||||
((etaf-runtime-route-p subscriber)
|
||||
(if (etaf-runtime-route-live-p subscriber)
|
||||
(funcall (etaf-runtime-route-scheduler subscriber)
|
||||
subscriber source)
|
||||
(etaf-scheduler-record-stale-route-drop context)))
|
||||
((and (etaf-effect-p subscriber)
|
||||
(etaf-effect-active-p subscriber)
|
||||
(etaf-scheduler-claim-effect context subscriber))
|
||||
(if-let* ((scheduler (etaf-effect-scheduler subscriber)))
|
||||
(funcall scheduler subscriber)
|
||||
(etaf-reactive-effect-run subscriber))))
|
||||
((error quit)
|
||||
(unless first-condition
|
||||
(setq first-condition condition)))))
|
||||
(when first-condition
|
||||
(signal (car first-condition) (cdr first-condition)))))
|
||||
(defun etaf-reactive-enqueue-runtime-flush (runtime function)
|
||||
"Queue FUNCTION once for RUNTIME after the outer reactive dispatch settles."
|
||||
(unless (gethash runtime etaf--dispatch-runtime-set)
|
||||
(puthash runtime function etaf--dispatch-runtime-set)
|
||||
(etaf--dispatch-append-runtime runtime)))
|
||||
|
||||
(defun etaf--dispatch-source-now (source)
|
||||
"Notify SOURCE subscribers without opening another dispatch boundary."
|
||||
(let ((subscribers (copy-hash-table (etaf--source-subscribers source))))
|
||||
(maphash
|
||||
(lambda (subscriber _)
|
||||
(cond
|
||||
((etaf-runtime-route-p subscriber)
|
||||
(funcall (etaf-runtime-route-scheduler subscriber)
|
||||
subscriber source))
|
||||
((etaf-effect-active-p subscriber)
|
||||
(unless (gethash subscriber etaf--dispatch-effect-set)
|
||||
(puthash subscriber t etaf--dispatch-effect-set)
|
||||
(if-let* ((scheduler (etaf-effect-scheduler subscriber)))
|
||||
(funcall scheduler subscriber)
|
||||
(etaf-reactive-effect-run subscriber))))))
|
||||
subscribers)))
|
||||
|
||||
(defun etaf--drain-dispatch ()
|
||||
"Drain reactive sources and Runtime work to a stable outer fixed point."
|
||||
(while (or etaf--dispatch-source-queue etaf--dispatch-runtime-queue)
|
||||
(while etaf--dispatch-source-queue
|
||||
(let ((source (pop etaf--dispatch-source-queue)))
|
||||
(unless etaf--dispatch-source-queue
|
||||
(setq etaf--dispatch-source-queue-tail nil))
|
||||
(remhash source etaf--dispatch-source-set)
|
||||
(etaf--dispatch-source-now source)))
|
||||
;; Detach this turn. A lifecycle write may enqueue a source and the same
|
||||
;; Runtime again for the following turn without merging it into this one.
|
||||
(let ((turn etaf--dispatch-runtime-queue))
|
||||
(setq etaf--dispatch-runtime-queue nil
|
||||
etaf--dispatch-runtime-queue-tail nil)
|
||||
(dolist (runtime turn)
|
||||
(let ((function (gethash runtime etaf--dispatch-runtime-set)))
|
||||
(remhash runtime etaf--dispatch-runtime-set)
|
||||
(funcall function))))))
|
||||
|
||||
(defun etaf--reactive-same-p (left right)
|
||||
"Return whether LEFT and RIGHT are equal under ETAF's shallow rule."
|
||||
@ -223,18 +222,13 @@ The default context preserves the legacy two-argument facade."
|
||||
SCHEDULER receives the effect when a dependency changes. SCOPE defaults to
|
||||
the current Scope. NAME optionally labels the effect. ON-STOP runs once
|
||||
when the effect is disposed."
|
||||
(etaf--assert-not-rendering 'create-effect)
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(let* ((owner (or scope etaf--active-scope))
|
||||
(scheduler-context
|
||||
(or (and owner (etaf-effect-scope-scheduler-context owner))
|
||||
(etaf-scheduler-current-context)))
|
||||
(effect (etaf--effect-create
|
||||
:function function
|
||||
:scheduler scheduler
|
||||
:owner-scope owner
|
||||
:scheduler-context scheduler-context
|
||||
:on-stop on-stop
|
||||
:name name)))
|
||||
(when owner
|
||||
@ -250,12 +244,7 @@ When RENDERING is non-nil, `etaf-value' writes are rejected for the duration
|
||||
of the run."
|
||||
(unless (etaf-effect-p effect)
|
||||
(signal 'wrong-type-argument (list 'etaf-effect-p effect)))
|
||||
(let* ((scheduler-context
|
||||
(or (etaf-effect-scheduler-context effect)
|
||||
(etaf-scheduler-current-context)))
|
||||
(etaf--scheduler-context scheduler-context))
|
||||
(etaf-scheduler-record-effect-evaluation scheduler-context)
|
||||
(cond
|
||||
(cond
|
||||
((etaf-effect-running-p effect)
|
||||
(error "Recursive ETAF effect execution: %S"
|
||||
(or (etaf-effect-name effect) effect)))
|
||||
@ -282,61 +271,29 @@ of the run."
|
||||
(etaf--clear-effect-deps effect)
|
||||
(dolist (source old-deps)
|
||||
(puthash effect t (etaf--source-subscribers source)))
|
||||
(setf (etaf-effect-deps effect) old-deps)))))))))
|
||||
(setf (etaf-effect-deps effect) old-deps))))))))
|
||||
|
||||
(defun etaf--dispatch-source (source &optional context-filter)
|
||||
"Notify current subscribers of SOURCE once.
|
||||
|
||||
When CONTEXT-FILTER is non-nil, it is called with each subscriber's scheduler
|
||||
context and only subscribers for which it returns non-nil are included. The
|
||||
filter is an internal reconciliation hook: the ordinary source publication
|
||||
path leaves it nil, while a retry can target only contexts that did not finish
|
||||
an earlier projection epoch."
|
||||
(etaf-scheduler-call-with-projection
|
||||
(lambda ()
|
||||
(let ((groups (make-hash-table :test #'eq)))
|
||||
(maphash
|
||||
(lambda (subscriber _)
|
||||
(let ((context (etaf--subscriber-scheduler-context subscriber)))
|
||||
(when (or (null context-filter)
|
||||
(funcall context-filter context))
|
||||
(cond
|
||||
((etaf-runtime-route-p subscriber)
|
||||
(if (etaf-runtime-route-live-p subscriber)
|
||||
(puthash context
|
||||
(cons subscriber (gethash context groups)) groups)
|
||||
(etaf-scheduler-record-stale-route-drop context)))
|
||||
((and (etaf-effect-p subscriber)
|
||||
(etaf-effect-active-p subscriber))
|
||||
(puthash context
|
||||
(cons subscriber (gethash context groups)) groups)))))
|
||||
)
|
||||
(etaf--source-subscribers source))
|
||||
(let (contexts)
|
||||
(maphash (lambda (context _) (push context contexts)) groups)
|
||||
(dolist (context
|
||||
(sort contexts
|
||||
(lambda (left right)
|
||||
(< (etaf-scheduler-context-id left)
|
||||
(etaf-scheduler-context-id right)))))
|
||||
(let ((subscribers (nreverse (gethash context groups))))
|
||||
(etaf-scheduler-enqueue-source
|
||||
context source
|
||||
(lambda (delivery-context delivery-source projection-epoch)
|
||||
(etaf--dispatch-subscriber-group
|
||||
delivery-context delivery-source projection-epoch
|
||||
subscribers))))))))))
|
||||
|
||||
(defun etaf-reactive-call-with-batch (function)
|
||||
"Call FUNCTION inside one cross-context reactive projection."
|
||||
(etaf-scheduler-call-with-projection function))
|
||||
(defun etaf--dispatch-source (source)
|
||||
"Notify every current subscriber of SOURCE once."
|
||||
(unless (gethash source etaf--dispatch-source-set)
|
||||
(puthash source t etaf--dispatch-source-set)
|
||||
(etaf--dispatch-append-source source))
|
||||
(when (zerop etaf--dispatch-depth)
|
||||
(let ((etaf--dispatch-depth 1))
|
||||
(unwind-protect (etaf--drain-dispatch)
|
||||
(setq etaf--dispatch-source-queue nil
|
||||
etaf--dispatch-source-queue-tail nil
|
||||
etaf--dispatch-runtime-queue nil
|
||||
etaf--dispatch-runtime-queue-tail nil)
|
||||
(clrhash etaf--dispatch-source-set)
|
||||
(clrhash etaf--dispatch-runtime-set)
|
||||
(clrhash etaf--dispatch-effect-set)))))
|
||||
|
||||
;;;###autoload
|
||||
(cl-defun etaf-ref (initial-value &key test name)
|
||||
"Create a writable shallow reactive cell containing INITIAL-VALUE.
|
||||
|
||||
TEST optionally compares old and new values. NAME is used in diagnostics."
|
||||
(etaf--assert-not-rendering 'create-ref)
|
||||
(when (and test (not (functionp test)))
|
||||
(signal 'wrong-type-argument (list 'functionp test)))
|
||||
(etaf--ref-create :value initial-value
|
||||
@ -373,7 +330,6 @@ TEST optionally compares old and new values. NAME is used in diagnostics."
|
||||
|
||||
TEST optionally compares old and new values. NAME optionally labels the
|
||||
computed value."
|
||||
(etaf--assert-not-rendering 'create-computed)
|
||||
(unless (functionp getter)
|
||||
(signal 'wrong-type-argument (list 'functionp getter)))
|
||||
(when (and test (not (functionp test)))
|
||||
@ -442,7 +398,6 @@ computed value."
|
||||
IMMEDIATE calls CALLBACK for the initial value. FLUSH is passed to the
|
||||
current Runtime scheduler. TEST and NAME customize comparison and
|
||||
diagnostics. Return a stop function."
|
||||
(etaf--assert-not-rendering 'watch)
|
||||
(unless (functionp callback)
|
||||
(signal 'wrong-type-argument (list 'functionp callback)))
|
||||
(let* ((getter (etaf--watch-getter source))
|
||||
@ -489,7 +444,6 @@ diagnostics. Return a stop function."
|
||||
|
||||
FLUSH selects the Runtime scheduler boundary. NAME optionally labels the
|
||||
effect. If FUNCTION returns a function, it cleans up the previous run."
|
||||
(etaf--assert-not-rendering 'watch-effect)
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(let (cleanup effect job)
|
||||
@ -510,20 +464,10 @@ effect. If FUNCTION returns a function, it cleans up the previous run."
|
||||
(lambda () (etaf--stop-effect effect))))
|
||||
|
||||
;;;###autoload
|
||||
(cl-defun etaf-effect-scope (&key detached name scheduler-context)
|
||||
"Create a Scope named NAME, owned by the current Scope unless DETACHED.
|
||||
SCHEDULER-CONTEXT defaults to the parent or dynamically active context."
|
||||
(etaf--assert-not-rendering 'create-scope)
|
||||
(cl-defun etaf-effect-scope (&key detached name)
|
||||
"Create a Scope named NAME, owned by the current Scope unless DETACHED."
|
||||
(let* ((parent (and (not detached) etaf--active-scope))
|
||||
(scheduler-context
|
||||
(or scheduler-context
|
||||
(and parent (etaf-effect-scope-scheduler-context parent))
|
||||
(etaf-scheduler-current-context)))
|
||||
(scope (etaf--effect-scope-create
|
||||
:parent parent
|
||||
:scheduler-context
|
||||
(etaf-scheduler-context-resolve scheduler-context)
|
||||
:name name)))
|
||||
(scope (etaf--effect-scope-create :parent parent :name name)))
|
||||
(when parent
|
||||
(push scope (etaf-effect-scope-children parent)))
|
||||
scope))
|
||||
@ -541,8 +485,6 @@ SCHEDULER-CONTEXT defaults to the parent or dynamically active context."
|
||||
(etaf-effect-scope-active-p scope))
|
||||
(error "Cannot enter an inactive ETAF Scope"))
|
||||
(let ((etaf--active-scope scope)
|
||||
(etaf--scheduler-context
|
||||
(etaf-effect-scope-scheduler-context scope))
|
||||
(etaf--watch-scheduler
|
||||
(if watch-scheduler-p watch-scheduler etaf--watch-scheduler)))
|
||||
(funcall function)))
|
||||
@ -550,7 +492,6 @@ SCHEDULER-CONTEXT defaults to the parent or dynamically active context."
|
||||
;;;###autoload
|
||||
(defun etaf-on-scope-dispose (function)
|
||||
"Register FUNCTION to run when the current Scope is disposed."
|
||||
(etaf--assert-not-rendering 'register-scope-cleanup)
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(unless etaf--active-scope
|
||||
@ -561,7 +502,6 @@ SCHEDULER-CONTEXT defaults to the parent or dynamically active context."
|
||||
;;;###autoload
|
||||
(defun etaf-scope-stop (scope)
|
||||
"Dispose SCOPE and return cleanup errors collected during teardown."
|
||||
(etaf--assert-not-rendering 'stop-scope)
|
||||
(when (and (etaf-effect-scope-p scope)
|
||||
(etaf-effect-scope-active-p scope))
|
||||
(setf (etaf-effect-scope-active-p scope) nil)
|
||||
|
||||
@ -1,384 +0,0 @@
|
||||
;;; etaf-render-port.el --- Versioned Ebox renderer port -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This file is ETAF's only Ebox framework-SPI bootstrap owner. It requires
|
||||
;; one compatible Ebox v2 provider, snapshots it once, and exposes one immutable
|
||||
;; port to downstream ETAF code without repeated protocol guesses.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'subr-x)
|
||||
(require 'ebox)
|
||||
|
||||
(define-error 'etaf-spi-bootstrap-error
|
||||
"Malformed Ebox framework SPI provider")
|
||||
(define-error 'etaf-spi-incompatible-error
|
||||
"Incompatible Ebox framework SPI provider"
|
||||
'etaf-spi-bootstrap-error)
|
||||
|
||||
(defconst etaf-render-port--required-spi-version 2
|
||||
"Ebox framework SPI version consumed by this ETAF build.")
|
||||
|
||||
(defconst etaf-render-port--required-schema-version
|
||||
'ebox-framework-spi-schema/v2
|
||||
"Ebox provider schema consumed by this ETAF build.")
|
||||
|
||||
(defconst etaf-render-port--required-capabilities
|
||||
'(initial-paired-stage-rollback
|
||||
update-paired-stage-rollback
|
||||
combined-participant-ordering
|
||||
same-object-legacy-report
|
||||
initial-observation-replay)
|
||||
"Capabilities required from an Ebox framework SPI v2 provider.")
|
||||
|
||||
(defconst etaf-render-port--accepted-tp-protocols
|
||||
'(tp-transaction-protocol-v1+v2 tp-transaction-protocol-v2)
|
||||
"TP protocols accepted from an Ebox SPI v2 provider.
|
||||
The dual-capability manifest is accepted during dependency-order migration
|
||||
because it contains v2; ETAF never dispatches through its v1 capability.")
|
||||
|
||||
(defconst etaf-render-port--required-stage-order
|
||||
'(ebox-mirror/native framework-stage)
|
||||
"Required stage order inside the combined Ebox participant.")
|
||||
|
||||
(defconst etaf-render-port--required-rollback-order
|
||||
'(framework-rollback ebox-mirror/native tp)
|
||||
"Required rollback order inside the combined Ebox participant.")
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-render-port
|
||||
(:constructor etaf-render-port--create)
|
||||
(:conc-name etaf-render-port--))
|
||||
"Immutable selected Ebox rendering capability."
|
||||
(route nil :read-only t)
|
||||
(spi-version nil :read-only t)
|
||||
(schema-version nil :read-only t)
|
||||
(capabilities nil :read-only t)
|
||||
(tp-protocol nil :read-only t)
|
||||
(initial-function nil :read-only t)
|
||||
(update-function nil :read-only t)
|
||||
(revision-function nil :read-only t)
|
||||
(bootstrap-outcome nil :read-only t)
|
||||
(provider nil :read-only t)
|
||||
(snapshot-function nil :read-only t))
|
||||
|
||||
(defun etaf-render-port-route (port)
|
||||
"Return selected PORT route, always `v2'."
|
||||
(etaf-render-port--route port))
|
||||
|
||||
(defun etaf-render-port-spi-version (port)
|
||||
"Return PORT's selected framework SPI version."
|
||||
(etaf-render-port--spi-version port))
|
||||
|
||||
(defun etaf-render-port-schema-version (port)
|
||||
"Return PORT's selected provider schema version."
|
||||
(etaf-render-port--schema-version port))
|
||||
|
||||
(defun etaf-render-port-capabilities (port)
|
||||
"Return a defensive copy of PORT's capabilities."
|
||||
(copy-sequence (etaf-render-port--capabilities port)))
|
||||
|
||||
(defun etaf-render-port-tp-protocol (port)
|
||||
"Return PORT's selected TP transaction protocol."
|
||||
(etaf-render-port--tp-protocol port))
|
||||
|
||||
(defun etaf-render-port-initial-function (port)
|
||||
"Return PORT's initial mount function symbol."
|
||||
(etaf-render-port--initial-function port))
|
||||
|
||||
(defun etaf-render-port-update-function (port)
|
||||
"Return PORT's update function symbol."
|
||||
(etaf-render-port--update-function port))
|
||||
|
||||
(defun etaf-render-port-revision-function (port)
|
||||
"Return PORT's current-revision query function symbol."
|
||||
(etaf-render-port--revision-function port))
|
||||
|
||||
(defun etaf-render-port-snapshot-function (port)
|
||||
"Return PORT's explicit committed-snapshot query function symbol."
|
||||
(etaf-render-port--snapshot-function port))
|
||||
|
||||
(defun etaf-render-port-bootstrap-outcome (port)
|
||||
"Return PORT's immutable bootstrap outcome tag."
|
||||
(etaf-render-port--bootstrap-outcome port))
|
||||
|
||||
(defun etaf-render-port--bootstrap-error (reason &optional detail)
|
||||
"Signal a fail-closed bootstrap error for REASON and DETAIL."
|
||||
(signal 'etaf-spi-bootstrap-error
|
||||
(list :reason reason :detail detail)))
|
||||
|
||||
(defun etaf-render-port--ensure-accessors ()
|
||||
"Require Ebox's public v2 accessors and explicit snapshot query."
|
||||
(dolist
|
||||
(function
|
||||
'(ebox-framework-spi-provider-p
|
||||
ebox-framework-spi-provider-spi-version
|
||||
ebox-framework-spi-provider-schema-version
|
||||
ebox-framework-spi-provider-capabilities
|
||||
ebox-framework-spi-provider-tp-protocol
|
||||
ebox-framework-spi-provider-stage-order
|
||||
ebox-framework-spi-provider-rollback-order
|
||||
ebox-framework-spi-provider-report-semantics
|
||||
ebox-framework-spi-provider-initial-operation
|
||||
ebox-framework-spi-provider-update-operation
|
||||
ebox-framework-spi-operation-p
|
||||
ebox-framework-spi-operation-kind
|
||||
ebox-framework-spi-operation-function
|
||||
ebox-framework-spi-operation-argument-schema
|
||||
ebox-framework-spi-operation-result-schema
|
||||
ebox-framework-spi-operation-paired-stage-rollback-p
|
||||
ebox-framework-spi-initial-observation-reports
|
||||
ebox-surface-buffer-snapshot))
|
||||
(unless (fboundp function)
|
||||
(etaf-render-port--bootstrap-error
|
||||
'missing-provider-accessor function))))
|
||||
|
||||
(defun etaf-render-port--operation-snapshot (operation label)
|
||||
"Return validated immutable field snapshot for OPERATION named LABEL."
|
||||
(unless (ebox-framework-spi-operation-p operation)
|
||||
(etaf-render-port--bootstrap-error
|
||||
'malformed-operation (list :label label :value operation)))
|
||||
(let ((kind (ebox-framework-spi-operation-kind operation))
|
||||
(function (ebox-framework-spi-operation-function operation))
|
||||
(arguments
|
||||
(ebox-framework-spi-operation-argument-schema operation))
|
||||
(result (ebox-framework-spi-operation-result-schema operation))
|
||||
(paired
|
||||
(ebox-framework-spi-operation-paired-stage-rollback-p operation)))
|
||||
(unless (and (symbolp kind)
|
||||
(symbolp function)
|
||||
(fboundp function)
|
||||
(proper-list-p arguments)
|
||||
(cl-every #'symbolp arguments)
|
||||
(symbolp result)
|
||||
(memq paired '(nil t)))
|
||||
(etaf-render-port--bootstrap-error
|
||||
'malformed-operation-fields
|
||||
(list :label label :kind kind :function function
|
||||
:arguments arguments :result result :paired paired)))
|
||||
(list :kind kind :function function
|
||||
:arguments (copy-sequence arguments)
|
||||
:result result :paired paired)))
|
||||
|
||||
(defun etaf-render-port--provider-snapshot (provider)
|
||||
"Return a validated field snapshot of Ebox v2 PROVIDER."
|
||||
(etaf-render-port--ensure-accessors)
|
||||
(unless (ebox-framework-spi-provider-p provider)
|
||||
(etaf-render-port--bootstrap-error 'non-provider-record provider))
|
||||
(let ((spi-version (ebox-framework-spi-provider-spi-version provider))
|
||||
(schema-version
|
||||
(ebox-framework-spi-provider-schema-version provider))
|
||||
(capabilities
|
||||
(ebox-framework-spi-provider-capabilities provider))
|
||||
(tp-protocol (ebox-framework-spi-provider-tp-protocol provider))
|
||||
(stage-order (ebox-framework-spi-provider-stage-order provider))
|
||||
(rollback-order
|
||||
(ebox-framework-spi-provider-rollback-order provider))
|
||||
(report-semantics
|
||||
(ebox-framework-spi-provider-report-semantics provider)))
|
||||
(unless (and (integerp spi-version)
|
||||
(> spi-version 0)
|
||||
(symbolp schema-version)
|
||||
(proper-list-p capabilities)
|
||||
(cl-every #'symbolp capabilities)
|
||||
(symbolp tp-protocol)
|
||||
(proper-list-p stage-order)
|
||||
(cl-every #'symbolp stage-order)
|
||||
(proper-list-p rollback-order)
|
||||
(cl-every #'symbolp rollback-order)
|
||||
(symbolp report-semantics))
|
||||
(etaf-render-port--bootstrap-error
|
||||
'malformed-provider-fields
|
||||
(list :spi-version spi-version :schema-version schema-version
|
||||
:capabilities capabilities :tp-protocol tp-protocol
|
||||
:stage-order stage-order :rollback-order rollback-order
|
||||
:report-semantics report-semantics)))
|
||||
(list
|
||||
:provider provider
|
||||
:spi-version spi-version
|
||||
:schema-version schema-version
|
||||
:capabilities (copy-sequence capabilities)
|
||||
:tp-protocol tp-protocol
|
||||
:stage-order (copy-sequence stage-order)
|
||||
:rollback-order (copy-sequence rollback-order)
|
||||
:report-semantics report-semantics
|
||||
:initial
|
||||
(etaf-render-port--operation-snapshot
|
||||
(ebox-framework-spi-provider-initial-operation provider) 'initial)
|
||||
:update
|
||||
(etaf-render-port--operation-snapshot
|
||||
(ebox-framework-spi-provider-update-operation provider) 'update))))
|
||||
|
||||
(defun etaf-render-port--incompatibilities (snapshot)
|
||||
"Return deterministic compatibility failures in provider SNAPSHOT."
|
||||
(let (failures)
|
||||
(unless (eql (plist-get snapshot :spi-version)
|
||||
etaf-render-port--required-spi-version)
|
||||
(push (list :spi-version (plist-get snapshot :spi-version)) failures))
|
||||
(unless (eq (plist-get snapshot :schema-version)
|
||||
etaf-render-port--required-schema-version)
|
||||
(push (list :schema-version (plist-get snapshot :schema-version))
|
||||
failures))
|
||||
(let ((capabilities (plist-get snapshot :capabilities)))
|
||||
(dolist (capability etaf-render-port--required-capabilities)
|
||||
(unless (memq capability capabilities)
|
||||
(push (list :missing-capability capability) failures))))
|
||||
(unless (memq (plist-get snapshot :tp-protocol)
|
||||
etaf-render-port--accepted-tp-protocols)
|
||||
(push (list :tp-protocol (plist-get snapshot :tp-protocol)) failures))
|
||||
(unless (equal (plist-get snapshot :stage-order)
|
||||
etaf-render-port--required-stage-order)
|
||||
(push (list :stage-order (plist-get snapshot :stage-order)) failures))
|
||||
(unless (equal (plist-get snapshot :rollback-order)
|
||||
etaf-render-port--required-rollback-order)
|
||||
(push (list :rollback-order (plist-get snapshot :rollback-order))
|
||||
failures))
|
||||
(unless (eq (plist-get snapshot :report-semantics)
|
||||
'same-object-legacy-report)
|
||||
(push (list :report-semantics
|
||||
(plist-get snapshot :report-semantics))
|
||||
failures))
|
||||
(dolist
|
||||
(expectation
|
||||
`((:initial initial ebox-framework-spi-initial
|
||||
(buffer canonical-input framework-stage framework-rollback))
|
||||
(:update update ebox-framework-spi-update
|
||||
(buffer canonical-input-or-candidate
|
||||
framework-stage framework-rollback))))
|
||||
(let* ((slot (nth 0 expectation))
|
||||
(operation (plist-get snapshot slot)))
|
||||
(unless (and (eq (plist-get operation :kind) (nth 1 expectation))
|
||||
(eq (plist-get operation :function) (nth 2 expectation))
|
||||
(equal (plist-get operation :arguments)
|
||||
(nth 3 expectation))
|
||||
(eq (plist-get operation :result)
|
||||
'ebox-legacy-report/same-object)
|
||||
(eq (plist-get operation :paired) t))
|
||||
(push (list slot operation) failures))))
|
||||
(nreverse failures)))
|
||||
|
||||
(defun etaf-render-port--v2-port (snapshot)
|
||||
"Return an immutable selected v2 port from compatible SNAPSHOT."
|
||||
(let ((failures (etaf-render-port--incompatibilities snapshot)))
|
||||
(when failures
|
||||
(signal 'etaf-spi-incompatible-error
|
||||
(list :incompatibilities failures)))
|
||||
(etaf-render-port--create
|
||||
:route 'v2
|
||||
:spi-version (plist-get snapshot :spi-version)
|
||||
:schema-version (plist-get snapshot :schema-version)
|
||||
:capabilities (copy-sequence (plist-get snapshot :capabilities))
|
||||
:tp-protocol (plist-get snapshot :tp-protocol)
|
||||
:initial-function
|
||||
(plist-get (plist-get snapshot :initial) :function)
|
||||
:update-function
|
||||
(plist-get (plist-get snapshot :update) :function)
|
||||
:revision-function 'ebox-surface-buffer-revision
|
||||
:snapshot-function 'ebox-surface-buffer-snapshot
|
||||
:bootstrap-outcome 'valid-v2-selected
|
||||
:provider (plist-get snapshot :provider))))
|
||||
|
||||
(defun etaf-render-port--bootstrap ()
|
||||
"Probe Ebox exactly once and return one immutable selected render port."
|
||||
(let ((feature-present-p (featurep 'ebox-framework-spi-v2))
|
||||
(predicate-present-p (fboundp 'ebox-framework-spi-capabilities)))
|
||||
(cond
|
||||
((and (not feature-present-p) (not predicate-present-p))
|
||||
(etaf-render-port--bootstrap-error 'v2-provider-missing))
|
||||
((not feature-present-p)
|
||||
(etaf-render-port--bootstrap-error 'predicate-without-v2-feature))
|
||||
((not predicate-present-p)
|
||||
(etaf-render-port--bootstrap-error 'v2-feature-without-predicate))
|
||||
(t
|
||||
(condition-case condition
|
||||
(etaf-render-port--v2-port
|
||||
(etaf-render-port--provider-snapshot
|
||||
(ebox-framework-spi-capabilities)))
|
||||
((etaf-spi-incompatible-error etaf-spi-bootstrap-error)
|
||||
(signal (car condition) (cdr condition)))
|
||||
((error quit)
|
||||
(etaf-render-port--bootstrap-error
|
||||
'provider-predicate-failure condition)))))))
|
||||
|
||||
(defconst etaf-render-port--selected-port
|
||||
(etaf-render-port--bootstrap)
|
||||
"Process-wide immutable Ebox render port selected during ETAF bootstrap.")
|
||||
|
||||
(defun etaf-render-port-selected ()
|
||||
"Return the process-wide immutable Ebox render port."
|
||||
etaf-render-port--selected-port)
|
||||
|
||||
(defun etaf-render-port-initial
|
||||
(buffer input framework-stage framework-rollback &optional observer)
|
||||
"Run selected initial operation for BUFFER and canonical INPUT.
|
||||
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair.
|
||||
OBSERVER, when non-nil, receives TP and Ebox snapshots measured during the
|
||||
initial v2 publication and replayed only after successful final accept."
|
||||
(let ((report
|
||||
(funcall
|
||||
(etaf-render-port-initial-function etaf-render-port--selected-port)
|
||||
buffer input framework-stage framework-rollback)))
|
||||
(when observer
|
||||
(dolist (provider-report
|
||||
(ebox-framework-spi-initial-observation-reports report))
|
||||
(funcall observer buffer provider-report)))
|
||||
report))
|
||||
|
||||
(defun etaf-render-port-update
|
||||
(buffer input framework-stage framework-rollback)
|
||||
"Run selected update operation for BUFFER and INPUT.
|
||||
FRAMEWORK-STAGE and FRAMEWORK-ROLLBACK are one required callback pair."
|
||||
(funcall (etaf-render-port-update-function
|
||||
etaf-render-port--selected-port)
|
||||
buffer input framework-stage framework-rollback))
|
||||
|
||||
(defun etaf-render-port-unmount (buffer)
|
||||
"Release the retained Ebox surface owned by mounted BUFFER."
|
||||
(ebox-unmount-buffer (get-buffer buffer)))
|
||||
|
||||
(defun etaf-render-port-mounted-p (buffer)
|
||||
"Return non-nil when BUFFER owns a live retained Ebox surface."
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
|
||||
(defun etaf-render-port-revision (buffer)
|
||||
"Return BUFFER's current Ebox revision, or zero when it is unmounted.
|
||||
During an active TP transaction this can be a provisional revision for the
|
||||
paired publication stage. Public committed queries must exclude that extent."
|
||||
(let ((buffer (get-buffer buffer)))
|
||||
(if (not (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer)))
|
||||
0
|
||||
(let ((revision
|
||||
(funcall
|
||||
(etaf-render-port-revision-function
|
||||
etaf-render-port--selected-port)
|
||||
buffer)))
|
||||
(unless (and (integerp revision) (> revision 0))
|
||||
(error "Mounted Ebox surface has no committed revision: %S"
|
||||
revision))
|
||||
revision))))
|
||||
|
||||
(defun etaf-render-port-snapshot (buffer)
|
||||
"Export BUFFER's committed canonical input, revision, and mount identity.
|
||||
Ebox owns this explicit O(N) detached export and rejects unavailable or
|
||||
transactional reads. The port validates only its envelope and never copies,
|
||||
publishes, or queries private renderer state."
|
||||
(let ((snapshot
|
||||
(funcall
|
||||
(etaf-render-port-snapshot-function etaf-render-port--selected-port)
|
||||
buffer)))
|
||||
(unless (and (proper-list-p snapshot)
|
||||
(ebox-canonical-input-p (plist-get snapshot :input))
|
||||
(integerp (plist-get snapshot :revision))
|
||||
(> (plist-get snapshot :revision) 0)
|
||||
(integerp (plist-get snapshot :mount-id)))
|
||||
(error "Malformed Ebox committed snapshot"))
|
||||
snapshot))
|
||||
|
||||
(provide 'etaf-render-port)
|
||||
|
||||
;;; etaf-render-port.el ends here
|
||||
628
etaf-renderer.el
628
etaf-renderer.el
@ -12,13 +12,10 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'subr-x)
|
||||
(require 'ebox)
|
||||
(require 'etaf-view)
|
||||
(require 'etaf-component)
|
||||
(require 'etaf-context)
|
||||
(require 'etaf-behavior)
|
||||
(require 'etaf-render-port)
|
||||
|
||||
(declare-function etaf--runtime-render-component "etaf-runtime" (runtime call path))
|
||||
|
||||
@ -27,6 +24,8 @@
|
||||
(declare-function etaf--runtime-render-child-range "etaf-runtime" (runtime expr path))
|
||||
(declare-function etaf--runtime-render-fragment-range
|
||||
"etaf-runtime" (runtime fragment path))
|
||||
(declare-function etaf--runtime-render-raw-range
|
||||
"etaf-runtime" (runtime raw path))
|
||||
(declare-function etaf--runtime-render-slot-range
|
||||
"etaf-runtime" (runtime projection path))
|
||||
(declare-function etaf--runtime-register-semantic-host
|
||||
@ -54,53 +53,11 @@
|
||||
|
||||
(define-error 'etaf-renderer-error "ETAF rendering error")
|
||||
|
||||
(defun etaf--behavior-source-p (value)
|
||||
"Return non-nil when VALUE has the public `:use' source grammar."
|
||||
(or (null value)
|
||||
(symbolp value)
|
||||
(etaf-behavior-spec-p value)
|
||||
(and (proper-list-p value)
|
||||
(cl-every (lambda (entry)
|
||||
(or (symbolp entry) (etaf-behavior-spec-p entry)))
|
||||
value))))
|
||||
|
||||
(defun etaf--validate-semantic-properties (props)
|
||||
"Return PROPS after validating ETAF Runtime-owned metadata values."
|
||||
(cl-loop for (property value) on props by #'cddr
|
||||
do
|
||||
(cond
|
||||
((eq property :ref)
|
||||
(unless (or (null value) (symbolp value) (functionp value))
|
||||
(signal 'etaf-renderer-error
|
||||
(list ":ref must be a symbol, function, or nil"))))
|
||||
((eq property :role)
|
||||
(unless (or (null value) (symbolp value) (stringp value))
|
||||
(signal 'etaf-renderer-error
|
||||
(list ":role must be a symbol, string, or nil"))))
|
||||
((etaf--aria-property-p property)
|
||||
(unless (or (null value) (stringp value) (numberp value)
|
||||
(symbolp value))
|
||||
(signal 'etaf-renderer-error
|
||||
(list (format "%S has an invalid semantic value"
|
||||
property)))))
|
||||
((etaf--event-property-p property)
|
||||
(unless (or (null value) (functionp value))
|
||||
(signal 'etaf-renderer-error
|
||||
(list (format "%S must be a function or nil"
|
||||
property)))))
|
||||
((eq property :disabled)
|
||||
(unless (memq value '(nil t))
|
||||
(signal 'etaf-renderer-error
|
||||
(list ":disabled must be boolean"))))
|
||||
((eq property :tab-index)
|
||||
(unless (or (null value) (integerp value))
|
||||
(signal 'etaf-renderer-error
|
||||
(list ":tab-index must be an integer or nil"))))
|
||||
((eq property :use)
|
||||
(unless (etaf--behavior-source-p value)
|
||||
(signal 'etaf-renderer-error
|
||||
(list ":use must be a Behavior symbol, spec, or proper list"))))))
|
||||
props)
|
||||
(defconst etaf--semantic-props
|
||||
'(:class :id :role :disabled :tab-index :ref :use :aria-label
|
||||
:aria-description :on-press :on-key-down :on-mouse-down :on-mouse-drag
|
||||
:on-wheel :on-input :on-focus :on-blur)
|
||||
"ETAF semantic properties that are not Ebox box properties.")
|
||||
|
||||
(defvar etaf--render-runtime nil
|
||||
"Runtime currently lowering a View tree, or nil for a pure render.")
|
||||
@ -117,54 +74,15 @@
|
||||
(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.")
|
||||
|
||||
(defun etaf--ebox-import-input (input)
|
||||
"Import canonical INPUT into the current lowering and return its nodes."
|
||||
(unless etaf--ebox-source-builder
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Canonical Ebox input escaped its lowering boundary")))
|
||||
(ebox-canonical-input-import-roots
|
||||
input (ebox-canonical-input-roots input) etaf--ebox-source-builder))
|
||||
|
||||
(defun etaf--ebox-input-for-nodes (nodes)
|
||||
"Snapshot current source facts for canonical forest NODES."
|
||||
(unless etaf--ebox-source-builder
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Canonical Ebox nodes have no lowering source builder")))
|
||||
(ebox-canonical-input-create
|
||||
nodes
|
||||
(ebox-tree-source-builder-snapshot etaf--ebox-source-builder nodes)))
|
||||
(defun etaf--event-property-p (property)
|
||||
"Return non-nil when PROPERTY is an ETAF event callback property."
|
||||
(and (keywordp property)
|
||||
(string-prefix-p "on-" (substring (symbol-name property) 1))))
|
||||
|
||||
(defun etaf--generated-host-ref (props path &optional site-token)
|
||||
"Return PROPS' explicit Host reference or one generated for PATH.
|
||||
SITE-TOKEN replaces PATH as the generated call-site identity when non-nil."
|
||||
"Return the explicit or generated opaque Host reference."
|
||||
(or (plist-get props :ref)
|
||||
(let ((site (or (and (plist-get props :key)
|
||||
(list :key (plist-get props :key)))
|
||||
site-token (copy-sequence path))))
|
||||
(list 'etaf-host
|
||||
(cond
|
||||
(etaf--render-runtime
|
||||
(list :parent etaf--current-semantic-parent-id :site site))
|
||||
(t
|
||||
(list :path (copy-sequence path) :site site)))))))
|
||||
(list 'etaf-host (or site-token (copy-sequence path)))))
|
||||
|
||||
(defun etaf--merge-property (props key value)
|
||||
"Return PROPS with KEY set to VALUE, preserving the original order."
|
||||
@ -240,33 +158,6 @@ not create another visual node category."
|
||||
:props props
|
||||
:children (etaf--view-node-children node)))))
|
||||
|
||||
(defvar etaf--theme-host-default-cache
|
||||
(make-hash-table :test #'eq :weakness 'key)
|
||||
"Theme-value keyed accepted Host default templates.")
|
||||
|
||||
(defun etaf--theme-host-defaults (defaults name)
|
||||
"Return immutable DEFAULTS accepted by View node NAME."
|
||||
(let* ((by-name
|
||||
(or (gethash defaults etaf--theme-host-default-cache)
|
||||
(let ((table (make-hash-table :test #'eq)))
|
||||
(puthash defaults table etaf--theme-host-default-cache)
|
||||
table)))
|
||||
(missing (make-symbol "etaf-theme-host-defaults-missing"))
|
||||
(cached (gethash name by-name missing)))
|
||||
(if (not (eq cached missing))
|
||||
cached
|
||||
(let ((tail defaults) result)
|
||||
(while tail
|
||||
(let ((key (pop tail))
|
||||
(value (pop tail)))
|
||||
(when (and (etaf--theme-ebox-property-p key)
|
||||
(ebox-style-property-accepted-p name key))
|
||||
(setq result
|
||||
(append result
|
||||
(list key (etaf-theme-token key value)))))))
|
||||
(puthash name result by-name)
|
||||
result))))
|
||||
|
||||
(defun etaf--apply-theme-defaults (node)
|
||||
"Apply known inherited Theme defaults to NODE without overriding props.
|
||||
Unknown Theme keys remain readable through `etaf-theme-value' but are design
|
||||
@ -275,24 +166,19 @@ tokens, not Ebox Host properties, and therefore are not materialized here."
|
||||
(defaults (etaf--theme-source-value source nil nil)))
|
||||
(if (null defaults)
|
||||
node
|
||||
(let* ((name (etaf--view-node-name node))
|
||||
(props (copy-sequence
|
||||
(etaf--resolve-property-plist
|
||||
(etaf--view-node-props node))))
|
||||
(template (etaf--theme-host-defaults defaults name))
|
||||
(present (make-hash-table :test #'eq)))
|
||||
(cl-loop for (key value) on props by #'cddr
|
||||
when value do
|
||||
(puthash (etaf--property-domain-key key) t present))
|
||||
(while template
|
||||
(let ((key (pop template))
|
||||
(value (pop template)))
|
||||
(unless (gethash (etaf--property-domain-key key) present)
|
||||
(setq props (etaf--merge-property props key value))
|
||||
(when value
|
||||
(puthash (etaf--property-domain-key key) t present)))))
|
||||
(let ((props (copy-sequence
|
||||
(etaf--resolve-property-plist
|
||||
(etaf--view-node-props node)))))
|
||||
(while defaults
|
||||
(let ((key (pop defaults))
|
||||
(value (pop defaults)))
|
||||
(when (and (etaf--theme-ebox-property-p key)
|
||||
(not (plist-get props key)))
|
||||
(setq props
|
||||
(etaf--merge-property
|
||||
props key (etaf-theme-token key value))))))
|
||||
(etaf--view-node-create
|
||||
:name name
|
||||
:name (etaf--view-node-name node)
|
||||
:token (etaf--view-node-token node)
|
||||
:props props
|
||||
:children (etaf--view-node-children node))))))
|
||||
@ -325,23 +211,63 @@ tokens, not Ebox Host properties, and therefore are not materialized here."
|
||||
|
||||
(defun etaf--theme-ebox-property-p (key)
|
||||
"Return non-nil when Theme KEY is a known Ebox property.
|
||||
The immutable Ebox schema registry is the sole shared property vocabulary;
|
||||
The public `ebox-property-rules' table is the shared property vocabulary;
|
||||
custom Theme tokens remain Context data and are never copied onto Hosts."
|
||||
(and (keywordp key)
|
||||
(ebox-style-schema-id key)))
|
||||
(boundp 'ebox-property-rules)
|
||||
(assq key ebox-property-rules)))
|
||||
|
||||
(defun etaf--inline-text-surface-properties (props)
|
||||
"Return text properties represented by inline text PROPS."
|
||||
(let ((surface (copy-sequence (or (plist-get props :surface-properties) nil))))
|
||||
(when (plist-member props :face)
|
||||
(setq surface (append surface (list 'face (plist-get props :face)))))
|
||||
(when (plist-member props :color)
|
||||
(setq surface (append surface
|
||||
(list 'foreground (plist-get props :color)))))
|
||||
(when (plist-member props :bgcolor)
|
||||
(setq surface (append surface
|
||||
(list 'background (plist-get props :bgcolor)))))
|
||||
surface))
|
||||
|
||||
(defun etaf--apply-inline-surface-properties (content surface)
|
||||
"Return CONTENT with resolved inline SURFACE properties applied."
|
||||
(let ((result (copy-sequence content)))
|
||||
(when (and surface (not (zerop (length result))))
|
||||
(add-text-properties 0 (length result) surface result))
|
||||
result))
|
||||
|
||||
(defun etaf--inline-text-content (value)
|
||||
"Return `(SUCCESS . STRING)' for inline-compatible text VALUE.
|
||||
|
||||
Only strings and `expr' values that resolve to strings are compatible. View
|
||||
structure must use the ordinary typed lowering path."
|
||||
Nested `text' Hosts become propertized runs in one Ebox content surface.
|
||||
Other View Hosts and Components return a failed result so the caller can use
|
||||
the ordinary layout lowering path instead."
|
||||
(cond
|
||||
((stringp value) (cons t value))
|
||||
((and (etaf--expr-p value)
|
||||
(eq (etaf--expr-kind value) 'interpolation))
|
||||
(let ((result (funcall (etaf--expr-thunk value))))
|
||||
(if (stringp result) (cons t result) (cons nil nil))))
|
||||
((etaf--view-node-p value) (cons nil nil))
|
||||
((etaf--expr-p value)
|
||||
(etaf--inline-text-content (funcall (etaf--expr-thunk value))))
|
||||
((etaf--view-node-p value)
|
||||
(if (eq (etaf--view-node-name value) 'text)
|
||||
(let ((children (etaf--view-node-children value))
|
||||
(result "")
|
||||
(valid-p t))
|
||||
(dolist (child children)
|
||||
(pcase (etaf--inline-text-content child)
|
||||
(`(t . ,content) (setq result (concat result content)))
|
||||
(_ (setq valid-p nil))))
|
||||
(if valid-p
|
||||
(let ((surface
|
||||
(etaf--inline-text-surface-properties
|
||||
(etaf--resolve-property-plist
|
||||
(etaf--view-node-props value)))))
|
||||
(when surface
|
||||
(setq result (copy-sequence result))
|
||||
(unless (zerop (length result))
|
||||
(add-text-properties 0 (length result) surface result)))
|
||||
(cons t result))
|
||||
(cons nil nil)))
|
||||
(cons nil nil)))
|
||||
((proper-list-p value)
|
||||
(let ((result "")
|
||||
(valid-p t))
|
||||
@ -355,209 +281,64 @@ structure must use the ordinary typed lowering path."
|
||||
(defun etaf--inline-text-structural-p (value)
|
||||
"Return non-nil when VALUE can be owned by mounted inline effects."
|
||||
(cond
|
||||
((or (null value) (stringp value)
|
||||
(and (etaf--expr-p value)
|
||||
(eq (etaf--expr-kind value) 'interpolation))) t)
|
||||
((etaf--view-node-p value) nil)
|
||||
((proper-list-p value)
|
||||
(cl-every #'etaf--inline-text-structural-p value))
|
||||
(t nil)))
|
||||
|
||||
(defun etaf--inline-text-dynamic-p (value)
|
||||
"Return non-nil when VALUE contains an inline `expr' update site."
|
||||
(cond
|
||||
((and (etaf--expr-p value)
|
||||
(eq (etaf--expr-kind value) 'interpolation)) t)
|
||||
((or (null value) (stringp value) (etaf--expr-p value)) t)
|
||||
((etaf--view-node-p value)
|
||||
(cl-some #'etaf--inline-text-dynamic-p
|
||||
(etaf--view-node-children value)))
|
||||
(and (eq (etaf--view-node-name value) 'text)
|
||||
(cl-every #'etaf--inline-text-structural-p
|
||||
(etaf--view-node-children value))))
|
||||
((proper-list-p value)
|
||||
(cl-some #'etaf--inline-text-dynamic-p value))
|
||||
(cl-every #'etaf--inline-text-structural-p value))
|
||||
(t nil)))
|
||||
|
||||
(defun etaf--ebox-properties (props path &optional site-token)
|
||||
"Project ETAF PROPS at PATH to canonical Ebox author facts.
|
||||
SITE-TOKEN supplies the stable generated Host identity when non-nil."
|
||||
"Translate ETAF PROPS at PATH into Ebox's public property list."
|
||||
(let* ((source-props (etaf--resolve-property-plist props))
|
||||
(_validated (etaf--validate-semantic-properties source-props))
|
||||
(props (copy-sequence source-props))
|
||||
ebox-props)
|
||||
ebox-props surface-properties)
|
||||
(while props
|
||||
(let ((key (pop props))
|
||||
(value (pop props)))
|
||||
(cond
|
||||
((memq key '(:face :surface-properties))
|
||||
(signal 'etaf-renderer-error
|
||||
(list (format
|
||||
"%S is not a canonical ETAF property" key))))
|
||||
((eq key :face)
|
||||
(push 'face surface-properties)
|
||||
(push value surface-properties))
|
||||
((eq key :surface-properties)
|
||||
(let ((tail value))
|
||||
(while tail
|
||||
(push (pop tail) surface-properties)
|
||||
(push (pop tail) surface-properties))))
|
||||
((eq key :content)
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Use View children for content, not :content")))
|
||||
((or (and (etaf--semantic-property-p key)
|
||||
(not (memq key '(:class :id))))
|
||||
((or (memq key etaf--semantic-props)
|
||||
(etaf--event-property-p key)
|
||||
(eq key :styles))
|
||||
nil)
|
||||
(t
|
||||
;; Component APIs pass optional properties as nil. At the resolved
|
||||
;; author boundary nil means "unspecified"; canonical Ebox defaults
|
||||
;; own the initial value and never receive a synthetic declaration.
|
||||
(when value
|
||||
(push key ebox-props)
|
||||
(push value ebox-props))))))
|
||||
(setq ebox-props (nreverse ebox-props))
|
||||
(push key ebox-props)
|
||||
(push value ebox-props)))))
|
||||
(setq ebox-props (nreverse ebox-props)
|
||||
surface-properties (nreverse surface-properties))
|
||||
(setq ebox-props
|
||||
(etaf--merge-property
|
||||
ebox-props :source-identity
|
||||
ebox-props :host-ref
|
||||
(etaf--generated-host-ref source-props path site-token)))
|
||||
(when surface-properties
|
||||
(setq ebox-props
|
||||
(append ebox-props
|
||||
(list :surface-properties surface-properties))))
|
||||
ebox-props))
|
||||
|
||||
(defconst etaf--ebox-source-fields
|
||||
'(:source-identity :key :class :id)
|
||||
"ETAF source facts compiled into one opaque Ebox source handle.")
|
||||
|
||||
(defvar etaf--ebox-declaration-cache (make-hash-table :test #'equal)
|
||||
"Bounded canonical declaration cache for normalized ETAF author props.")
|
||||
|
||||
(defconst etaf--ebox-declaration-cache-limit 512
|
||||
"Maximum canonical ETAF declaration entries retained across renders.")
|
||||
|
||||
(defvar etaf--ebox-layout-config-cache (make-hash-table :test #'equal)
|
||||
"Bounded typed LayoutConfig cache for normalized ETAF Box forms.")
|
||||
|
||||
(defconst etaf--ebox-layout-config-cache-limit 128
|
||||
"Maximum typed LayoutConfig entries retained across renders.")
|
||||
|
||||
(defun etaf--ebox-remove-properties (props names)
|
||||
"Return PROPS without keys in NAMES."
|
||||
(cl-loop for (key value) on props by #'cddr
|
||||
unless (memq key names)
|
||||
append (list key value)))
|
||||
|
||||
(defun etaf--ebox-declarations (tag props)
|
||||
"Compile TAG style declarations from canonical ETAF PROPS once."
|
||||
(let* ((style-props
|
||||
(etaf--ebox-remove-properties
|
||||
props
|
||||
etaf--ebox-source-fields))
|
||||
(key (cons tag style-props))
|
||||
(missing (make-symbol "etaf-ebox-declarations-missing"))
|
||||
(cached (gethash key etaf--ebox-declaration-cache missing)))
|
||||
(if (not (eq cached missing))
|
||||
cached
|
||||
(let ((compiled (ebox-style-compile-form tag style-props)))
|
||||
(when (>= (hash-table-count etaf--ebox-declaration-cache)
|
||||
etaf--ebox-declaration-cache-limit)
|
||||
(clrhash etaf--ebox-declaration-cache))
|
||||
(puthash (copy-tree key) compiled etaf--ebox-declaration-cache)
|
||||
compiled))))
|
||||
|
||||
(defun etaf--ebox-layout-config (tag declarations)
|
||||
"Return TAG LayoutConfig from normalized DECLARATIONS."
|
||||
(let* ((layout-props
|
||||
(ebox-style-declaration-properties
|
||||
declarations
|
||||
(lambda (property)
|
||||
(memq (plist-get property :name)
|
||||
(ebox-layout-config-property-names tag)))))
|
||||
(key (cons tag layout-props))
|
||||
(config (gethash key etaf--ebox-layout-config-cache)))
|
||||
(or config
|
||||
(let ((created (ebox-layout-config-for-form tag layout-props)))
|
||||
(when (>= (hash-table-count etaf--ebox-layout-config-cache)
|
||||
etaf--ebox-layout-config-cache-limit)
|
||||
(clrhash etaf--ebox-layout-config-cache))
|
||||
(puthash (copy-tree key) created etaf--ebox-layout-config-cache)
|
||||
created))))
|
||||
|
||||
(defun etaf--ebox-text-node (value props)
|
||||
"Return one typed Ebox TextNode for string VALUE and canonical PROPS."
|
||||
(unless (stringp value)
|
||||
(signal 'etaf-renderer-error
|
||||
(list (format "Text payload must resolve to a string: %S" value))))
|
||||
(unless (ebox-source-builder-p etaf--ebox-source-builder)
|
||||
(signal 'etaf-renderer-error
|
||||
(list "ETAF Text lowering requires one source builder")))
|
||||
(let* ((declarations (etaf--ebox-declarations 'text props))
|
||||
(source-handle
|
||||
(ebox-source-builder-bind
|
||||
etaf--ebox-source-builder
|
||||
:identity (plist-get props :source-identity)
|
||||
:key (plist-get props :key)
|
||||
:id (plist-get props :id)
|
||||
:class (plist-get props :class)
|
||||
:declarations declarations
|
||||
:provenance '(:adapter etaf-renderer :tag text))))
|
||||
(ebox-text-create
|
||||
:value value
|
||||
:owned-facts
|
||||
(ebox-canonical-facts-from-declarations 'text declarations)
|
||||
:source-handle source-handle)))
|
||||
|
||||
(defun etaf--ebox-box-node (tag props children)
|
||||
"Return one typed Ebox BoxNode TAG with PROPS over canonical CHILDREN."
|
||||
(unless (ebox-source-builder-p etaf--ebox-source-builder)
|
||||
(signal 'etaf-renderer-error
|
||||
(list "ETAF Box lowering requires one source builder")))
|
||||
(let* ((declarations (etaf--ebox-declarations tag props))
|
||||
(layout (etaf--ebox-layout-config tag declarations))
|
||||
(outer (if (plist-member props :outer)
|
||||
(plist-get props :outer)
|
||||
'block))
|
||||
(source-handle
|
||||
(ebox-source-builder-bind
|
||||
etaf--ebox-source-builder
|
||||
:identity (plist-get props :source-identity)
|
||||
:key (plist-get props :key)
|
||||
:id (plist-get props :id)
|
||||
:class (plist-get props :class)
|
||||
:declarations declarations
|
||||
:provenance (list :adapter 'etaf-renderer :tag tag))))
|
||||
(ebox-box-create
|
||||
:layout layout :outer outer :children children
|
||||
:source-builder etaf--ebox-source-builder
|
||||
:owned-facts (ebox-canonical-facts-from-declarations tag declarations)
|
||||
:source-handle source-handle)))
|
||||
|
||||
(defun etaf--ebox-forest-root (nodes source-identity)
|
||||
"Return one canonical backend root for ordered forest NODES.
|
||||
SOURCE-IDENTITY belongs only to a backend root introduced for an empty or
|
||||
multi-root forest; a single material root is returned unchanged."
|
||||
(cond
|
||||
((null nodes)
|
||||
(etaf--ebox-box-node
|
||||
'box (list :source-identity source-identity) nil))
|
||||
((null (cdr nodes))
|
||||
(car nodes))
|
||||
(t
|
||||
(etaf--ebox-box-node
|
||||
'column (list :source-identity source-identity) nodes))))
|
||||
|
||||
(defun etaf--flatten-view-value (value)
|
||||
"Flatten VALUE through transparent `expr' and sequence values."
|
||||
(cond
|
||||
((null value) nil)
|
||||
((or (stringp value) (etaf--view-node-p value)
|
||||
(etaf--component-call-p value) (etaf--slot-projection-p value))
|
||||
(etaf--component-call-p value) (etaf--slot-projection-p value)
|
||||
(etaf--raw-ebox-p value))
|
||||
(list value))
|
||||
((etaf--expr-p value)
|
||||
(pcase (etaf--expr-kind value)
|
||||
('interpolation
|
||||
(let ((resolved (funcall (etaf--expr-thunk value))))
|
||||
(cond ((null resolved) nil)
|
||||
((stringp resolved) (list resolved))
|
||||
;; Text Hosts validate interpolation through
|
||||
;; `etaf--inline-text-content'. At a structural boundary the
|
||||
;; same evaluated value may be a dynamically produced View
|
||||
;; forest (notably a transparent Component's fragment).
|
||||
(t (etaf--flatten-view-value resolved)))))
|
||||
('branch
|
||||
(etaf--flatten-view-value (funcall (etaf--expr-thunk value))))
|
||||
('keyed-list
|
||||
(let ((snapshot (etaf--keyed-program-snapshot value)))
|
||||
(etaf--flatten-view-value
|
||||
(etaf--keyed-program-outputs value snapshot))))
|
||||
(_ (signal 'etaf-renderer-error
|
||||
(list (format "Unknown View program: %S" value))))))
|
||||
(etaf--flatten-view-value (funcall (etaf--expr-thunk value))))
|
||||
((proper-list-p value)
|
||||
(cl-mapcan #'etaf--flatten-view-value value))
|
||||
(t
|
||||
@ -614,55 +395,34 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(defun etaf--render-component-call-pure (call path)
|
||||
"Render stateless CALL at PATH without a retained Runtime."
|
||||
(let* ((spec (etaf--component-call-spec call))
|
||||
(render (etaf--component-spec-render spec))
|
||||
(props (etaf--resolve-property-plist
|
||||
(etaf--component-business-props call)))
|
||||
(attrs (etaf--resolve-property-plist
|
||||
(etaf--component-call-attrs call))))
|
||||
(render (etaf--component-spec-render spec)))
|
||||
(when (etaf--component-spec-setup spec)
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Stateful Component requires `etaf-mount'")))
|
||||
(let ((etaf--current-component-props props)
|
||||
(let ((etaf--current-component-props
|
||||
(etaf--component-call-props call))
|
||||
(etaf--current-component-slots
|
||||
(etaf--component-call-slots call))
|
||||
(etaf--component-phase 'render))
|
||||
(etaf--component-call-slots call)))
|
||||
(let ((etaf--render-parent-style-stack etaf--render-style-stack)
|
||||
(etaf--render-style-stack
|
||||
(list (cons (etaf--component-spec-styles spec)
|
||||
(append path (list :component
|
||||
(etaf--component-spec-name spec)))))))
|
||||
(etaf--render-value-list
|
||||
(etaf--apply-component-attrs
|
||||
(etaf--validate-component-render-result
|
||||
(funcall render props (etaf--component-call-slots call))
|
||||
(etaf--component-spec-name spec))
|
||||
attrs (etaf--component-spec-name spec))
|
||||
(funcall render
|
||||
(etaf--component-call-props call)
|
||||
(etaf--component-call-slots call))
|
||||
(append path (list :component (etaf--component-spec-name spec))))))))
|
||||
|
||||
(defun etaf--render-value-list (value path)
|
||||
"Render VALUE at structural PATH into a list of Ebox nodes."
|
||||
(let* ((items (etaf--flatten-view-value value))
|
||||
(multiple-p (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))))
|
||||
(multiple-p (> (length items) 1)))
|
||||
(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)
|
||||
@ -672,42 +432,42 @@ multi-root forest; a single material root is returned unchanged."
|
||||
etaf--render-runtime 'text nil nil item-path)))
|
||||
(etaf--runtime-finish-semantic-host
|
||||
etaf--render-runtime semantic-id item)))
|
||||
(list
|
||||
(etaf--ebox-text-node
|
||||
item (etaf--ebox-properties nil item-path))))
|
||||
(list (ebox-create :content item)))
|
||||
((etaf--view-node-p item)
|
||||
(etaf--render-node item item-path))
|
||||
((etaf--component-call-p item)
|
||||
(if etaf--render-runtime
|
||||
(let ((result (etaf--runtime-render-component
|
||||
etaf--render-runtime item item-path)))
|
||||
(cond
|
||||
((eq (car-safe result) 'component-output-material)
|
||||
(etaf--ebox-import-input (cdr result)))
|
||||
((eq (car-safe result) 'component-output-range)
|
||||
(etaf--ebox-import-input (cdr result)))
|
||||
((eq (car-safe result) 'component-output-anchor)
|
||||
(list
|
||||
(apply #'ebox-child-range
|
||||
(nth 1 result)
|
||||
(etaf--ebox-import-input (nth 2 result)))))
|
||||
(t
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Runtime returned invalid Component output")))))
|
||||
(if (and (consp result)
|
||||
(eq (car result) 'component-output-range))
|
||||
(cdr result)
|
||||
(list result)))
|
||||
(etaf--render-component-call-pure item item-path)))
|
||||
((etaf--slot-projection-p item)
|
||||
(etaf--render-slot-projection item item-path))
|
||||
((etaf--raw-ebox-p item)
|
||||
(let ((node (funcall (etaf--raw-ebox-thunk item)))
|
||||
(key (and (etaf--raw-ebox-key-thunk item)
|
||||
(funcall (etaf--raw-ebox-key-thunk item)))))
|
||||
(unless node
|
||||
(signal 'etaf-renderer-error
|
||||
(list "raw-ebox :value returned nil")))
|
||||
(unless (listp node)
|
||||
(signal 'etaf-renderer-error
|
||||
(list "raw-ebox :value must return an Ebox node")))
|
||||
(when key
|
||||
(etaf--validate-key key)
|
||||
(setq node (copy-sequence node))
|
||||
(plist-put node :key key))
|
||||
(list node)))
|
||||
(t
|
||||
(signal 'etaf-renderer-error
|
||||
(list (format "Unresolved View item: %S" item))))))))
|
||||
|
||||
(defun etaf--render-node (node path)
|
||||
"Render normalized Host NODE at structural PATH."
|
||||
(let* ((node (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
|
||||
(let* ((node (if (and etaf--render-runtime
|
||||
(fboundp 'etaf--runtime-behavior-node))
|
||||
(etaf--runtime-behavior-node
|
||||
etaf--render-runtime node path)
|
||||
@ -729,7 +489,7 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(node (if (fboundp 'etaf--runtime-style-node)
|
||||
(etaf--runtime-style-node node path)
|
||||
node))
|
||||
(node (etaf--apply-theme-defaults node))
|
||||
(node (etaf--apply-theme-defaults node))
|
||||
(name (etaf--view-node-name node))
|
||||
(theme-result
|
||||
(etaf--resolve-theme-property-plist
|
||||
@ -740,6 +500,10 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(props (etaf--ebox-properties
|
||||
raw-props path (etaf--view-node-token node)))
|
||||
(children (etaf--view-node-children node)))
|
||||
(when (and etaf--render-runtime
|
||||
(fboundp 'etaf--runtime-register-host))
|
||||
(etaf--runtime-register-host
|
||||
etaf--render-runtime raw-props path (etaf--view-node-token node)))
|
||||
(pcase name
|
||||
('text
|
||||
(let* ((semantic-id
|
||||
@ -752,28 +516,44 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(child-path (append path (list :text)))
|
||||
(runtime-inline
|
||||
(and semantic-id
|
||||
(etaf--inline-text-dynamic-p children)
|
||||
(etaf--inline-text-structural-p children)
|
||||
(etaf--runtime-render-inline-content
|
||||
etaf--render-runtime semantic-id children child-path)))
|
||||
(flat (unless runtime-inline children))
|
||||
(flat (unless runtime-inline
|
||||
(cl-mapcan #'etaf--flatten-view-value children)))
|
||||
(inline (if runtime-inline
|
||||
(cons t (car runtime-inline))
|
||||
(etaf--inline-text-content flat))))
|
||||
(etaf--inline-text-content flat)))
|
||||
(rendered (unless (car inline)
|
||||
(let ((etaf--current-semantic-parent-id
|
||||
(or semantic-id
|
||||
etaf--current-semantic-parent-id)))
|
||||
(etaf--render-value-list flat child-path)))))
|
||||
(when semantic-id
|
||||
(etaf--runtime-finish-semantic-host
|
||||
etaf--render-runtime semantic-id
|
||||
(and (car inline) (cdr inline))
|
||||
(and runtime-inline (cadr runtime-inline))))
|
||||
(if (car inline)
|
||||
(list (etaf--ebox-text-node (cdr inline) props))
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Text payload must resolve to one string")))))
|
||||
(list (apply #'ebox-create :content (cdr inline) props))
|
||||
(list (ebox-build (append (list 'row) props rendered))))))
|
||||
('spacer
|
||||
(when children
|
||||
(signal 'etaf-renderer-error
|
||||
(list "spacer cannot have children")))
|
||||
(when etaf--render-runtime
|
||||
(let ((semantic-id (etaf--runtime-register-semantic-host
|
||||
etaf--render-runtime name raw-props props path
|
||||
theme-bindings theme-deps property-bindings
|
||||
property-deps property-context-deps base-props
|
||||
(etaf--view-node-token node))))
|
||||
(etaf--runtime-finish-semantic-host
|
||||
etaf--render-runtime semantic-id)))
|
||||
(list (apply #'ebox-spacer props)))
|
||||
('fragment
|
||||
(etaf--render-value-list children (append path (list :fragment))))
|
||||
((or 'box 'row 'column 'flex 'grid)
|
||||
((or 'row 'column 'container 'stack 'flex 'grid)
|
||||
(let ((nodes nil)
|
||||
(etaf--render-parent-path path)
|
||||
(index 0)
|
||||
(range-child-p nil)
|
||||
(semantic-id
|
||||
@ -789,13 +569,8 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(let ((etaf--current-semantic-parent-id
|
||||
(or semantic-id
|
||||
etaf--current-semantic-parent-id)))
|
||||
(if (and semantic-id
|
||||
;; Code-mode may carry a retained
|
||||
;; structural Expr through `etaf-node'.
|
||||
;; Both compiler-owned programs and these
|
||||
;; validated Expr values use the same
|
||||
;; direct Range lowering boundary.
|
||||
(etaf--expr-p child))
|
||||
(if (and semantic-id (etaf--expr-p child)
|
||||
(not etaf--rendering-range-p))
|
||||
(let ((result
|
||||
(etaf--runtime-render-child-range
|
||||
etaf--render-runtime child
|
||||
@ -805,7 +580,8 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(cdr result))
|
||||
(if (and semantic-id
|
||||
(etaf--view-node-p child)
|
||||
(eq (etaf--view-node-name child) 'fragment))
|
||||
(eq (etaf--view-node-name child) 'fragment)
|
||||
(not etaf--rendering-range-p))
|
||||
(let ((result
|
||||
(etaf--runtime-render-fragment-range
|
||||
etaf--render-runtime child
|
||||
@ -813,9 +589,19 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(setq range-child-p t)
|
||||
(cdr result))
|
||||
(if (and semantic-id
|
||||
(etaf--raw-ebox-p child)
|
||||
(not etaf--rendering-range-p))
|
||||
(let ((result
|
||||
(etaf--runtime-render-raw-range
|
||||
etaf--render-runtime child
|
||||
(append path (list index)))))
|
||||
(setq range-child-p t)
|
||||
(cdr result))
|
||||
(if (and semantic-id
|
||||
(etaf--slot-projection-p child)
|
||||
(etaf--slot-projection-range-compatible-p
|
||||
child))
|
||||
child)
|
||||
(not etaf--rendering-range-p))
|
||||
(let ((result
|
||||
(etaf--runtime-render-slot-range
|
||||
etaf--render-runtime child
|
||||
@ -823,7 +609,7 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(setq range-child-p t)
|
||||
(cdr result))
|
||||
(etaf--render-value-list
|
||||
child (append path (list index)))))))))
|
||||
child (append path (list index))))))))))
|
||||
(cl-incf index))
|
||||
(when semantic-id
|
||||
(etaf--runtime-finish-semantic-host
|
||||
@ -836,10 +622,23 @@ multi-root forest; a single material root is returned unchanged."
|
||||
(defun etaf--layout-node (name props nodes &optional range-child-p)
|
||||
"Build layout NAME with Ebox PROPS around child NODES.
|
||||
RANGE-CHILD-P records that NODES include nonvisual Range segments."
|
||||
(unless (memq name '(box row column flex grid))
|
||||
(signal 'etaf-renderer-error
|
||||
(list (format "Not a Box form: %S" name))))
|
||||
(let ((node (etaf--ebox-box-node name props nodes)))
|
||||
(let ((node
|
||||
(cond
|
||||
((eq name 'row)
|
||||
(if (null props)
|
||||
(apply #'ebox-row nodes)
|
||||
(ebox-build (append (list 'row) props nodes))))
|
||||
((memq name '(column container stack))
|
||||
(if (null props)
|
||||
(apply #'ebox-column nodes)
|
||||
(ebox-build (append (list 'column) props nodes))))
|
||||
((eq name 'flex)
|
||||
(apply #'ebox-flex (append props nodes)))
|
||||
((eq name 'grid)
|
||||
(apply #'ebox-grid (append props nodes)))
|
||||
(t
|
||||
(signal 'etaf-renderer-error
|
||||
(list (format "Not a layout Host: %S" name)))))))
|
||||
(when range-child-p
|
||||
(push node etaf--rendered-range-container-nodes))
|
||||
node))
|
||||
@ -850,29 +649,27 @@ RANGE-CHILD-P records that NODES include nonvisual Range segments."
|
||||
RANGE-CHILD-P preserves the direct material Range parent."
|
||||
(pcase name
|
||||
('text
|
||||
(when children
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Text cannot contain material child nodes")))
|
||||
(etaf--ebox-text-node content props))
|
||||
((or 'box 'row 'column 'flex 'grid)
|
||||
(if children
|
||||
(etaf--layout-node 'row props children range-child-p)
|
||||
(apply #'ebox-create :content content props)))
|
||||
('spacer (apply #'ebox-spacer props))
|
||||
((or 'row 'column 'container 'stack 'flex 'grid)
|
||||
(etaf--layout-node name props children range-child-p))
|
||||
(_ (signal 'etaf-renderer-error
|
||||
(list (format "Expected text, box, row, column, flex, or grid Host; received %S"
|
||||
(list (format "Semantic Host requires Step4b lowering: %S"
|
||||
name))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-render (view)
|
||||
"Lower normalized VIEW to one atomic canonical Ebox input.
|
||||
"Lower normalized VIEW to one Ebox node.
|
||||
|
||||
This pure entry supports stateless Components. Stateful Components require a
|
||||
Runtime because their setup Scope must have a lifecycle owner."
|
||||
(let ((builder (ebox-source-builder-create)))
|
||||
(let* ((etaf--ebox-source-builder builder)
|
||||
(root
|
||||
(etaf--ebox-forest-root
|
||||
(etaf--render-value-list view '(root)) '(etaf-root pure))))
|
||||
(ebox-canonical-input-create
|
||||
(list root) (ebox-source-builder-finish builder)))))
|
||||
Runtime because their setup Scope must have a lifecycle owner."
|
||||
(let ((nodes (etaf--render-value-list view '(root))))
|
||||
(cond
|
||||
((null nodes) (ebox-spacer))
|
||||
((null (cdr nodes)) (car nodes))
|
||||
(t (apply #'ebox-column nodes)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-mount (buffer-or-name view &optional options)
|
||||
@ -882,10 +679,7 @@ 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)))
|
||||
(let ((input (etaf-render view))
|
||||
(buffer (get-buffer-create buffer-or-name)))
|
||||
(etaf-render-port-initial buffer input #'ignore #'ignore)
|
||||
buffer))))
|
||||
(ebox-render-to-buffer buffer-or-name (etaf-render view)))))
|
||||
|
||||
(provide 'etaf-renderer)
|
||||
|
||||
|
||||
@ -12,7 +12,6 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-observer)
|
||||
(require 'etaf-reactive)
|
||||
|
||||
(define-error 'etaf-resource-error "Invalid ETAF Resource operation"
|
||||
@ -93,7 +92,6 @@ disposed."
|
||||
The Resource owns a child Scope under SCOPE, or under the current active Scope
|
||||
when SCOPE is nil. Without any parent Scope it creates a detached Scope.
|
||||
When IMMEDIATE is non-nil, load the Resource before returning it."
|
||||
(etaf--assert-not-rendering 'create-resource)
|
||||
(unless (functionp loader)
|
||||
(signal 'wrong-type-argument (list 'functionp loader)))
|
||||
(let* ((parent (etaf--resource-parent-scope scope))
|
||||
@ -138,17 +136,15 @@ When IMMEDIATE is non-nil, load the Resource before returning it."
|
||||
|
||||
Only LOADER errors are captured into Resource state. Cleanup failures and
|
||||
wrong Resource usage continue to signal normally."
|
||||
(etaf--assert-not-rendering 'load-resource)
|
||||
(etaf--resource-require-active resource)
|
||||
(etaf--resource-run-cleanup resource)
|
||||
(etaf--resource-set-state resource 'loading nil nil)
|
||||
(let (result error-data)
|
||||
(condition-case err
|
||||
(setq result
|
||||
(etaf-observer-with-stage ('resource 'load)
|
||||
(etaf-scope-run
|
||||
(etaf-resource-scope resource)
|
||||
(etaf-resource-loader resource))))
|
||||
(etaf-scope-run
|
||||
(etaf-resource-scope resource)
|
||||
(etaf-resource-loader resource)))
|
||||
(error (setq error-data err)))
|
||||
(if error-data
|
||||
(etaf--resource-set-state resource 'error nil error-data)
|
||||
@ -163,7 +159,6 @@ wrong Resource usage continue to signal normally."
|
||||
;;;###autoload
|
||||
(defun etaf-resource-dispose (resource)
|
||||
"Dispose RESOURCE and return cleanup errors collected by its Scope."
|
||||
(etaf--assert-not-rendering 'dispose-resource)
|
||||
(unless (etaf-resource-p resource)
|
||||
(signal 'wrong-type-argument (list 'etaf-resource-p resource)))
|
||||
(when (etaf-resource-active-p resource)
|
||||
|
||||
@ -1,348 +0,0 @@
|
||||
;;; etaf-retirement.el --- ETAF postcommit retirement journal -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Defines run-once public lifecycle entries, bounded idempotent structural
|
||||
;; cleanup, append-only diagnostics, and cause-compatible postcommit condition
|
||||
;; trailers. Retirement never owns or rolls back committed generation/surface
|
||||
;; authority.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'subr-x)
|
||||
|
||||
(define-error 'etaf-retirement-error "Invalid ETAF retirement journal")
|
||||
|
||||
(defvar etaf-retirement--journal-id-counter 0)
|
||||
(defvar etaf-retirement--entry-id-counter 0)
|
||||
|
||||
(defconst etaf-retirement--condition-payload-keys
|
||||
'(:kind :committed-p :operation-id :outcome-id :generation-id :revision
|
||||
:diagnostic-journal-id)
|
||||
"Canonical ordered keys in a v1 postcommit condition payload.")
|
||||
|
||||
(defconst etaf-retirement--projection-payload-keys
|
||||
'(:kind :committed-p :external-commit-certainty :reconciliation-token
|
||||
:projection-token :result :operation-id :outcome-id :generation-id
|
||||
:revision :diagnostic-journal-id)
|
||||
"Canonical ordered keys in a v1 data projection condition payload.")
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-retirement-entry
|
||||
(:constructor etaf-retirement-entry--create))
|
||||
"One stable postcommit retirement action."
|
||||
id owner kind payload ordering-key
|
||||
(attempt-count 0)
|
||||
(max-attempts 1)
|
||||
policy
|
||||
(state 'pending)
|
||||
condition)
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-retirement-journal
|
||||
(:constructor etaf-retirement-journal--create))
|
||||
"Append-only postcommit retirement and diagnostic journal."
|
||||
id operation-id outcome-id generation-id revision
|
||||
entries diagnostics
|
||||
(state 'open))
|
||||
|
||||
(cl-defun etaf-retirement-journal-create
|
||||
(&key operation-id outcome-id generation-id revision)
|
||||
"Create a journal bound to OPERATION-ID and OUTCOME-ID.
|
||||
GENERATION-ID and REVISION identify already committed facts."
|
||||
(unless (and (integerp operation-id) (>= operation-id 0)
|
||||
outcome-id
|
||||
(integerp generation-id) (>= generation-id 0)
|
||||
(integerp revision) (>= revision 0))
|
||||
(signal 'etaf-retirement-error
|
||||
(list :invalid-journal-metadata
|
||||
operation-id outcome-id generation-id revision)))
|
||||
(etaf-retirement-journal--create
|
||||
:id (cl-incf etaf-retirement--journal-id-counter)
|
||||
:operation-id operation-id
|
||||
:outcome-id outcome-id
|
||||
:generation-id generation-id
|
||||
:revision revision
|
||||
:entries nil
|
||||
:diagnostics nil))
|
||||
|
||||
(cl-defun etaf-retirement-enqueue
|
||||
(journal &key owner kind payload ordering-key policy max-attempts)
|
||||
"Append one retirement entry to JOURNAL.
|
||||
OWNER, KIND, PAYLOAD, ORDERING-KEY, POLICY, and MAX-ATTEMPTS describe the
|
||||
action."
|
||||
(unless (and (etaf-retirement-journal-p journal)
|
||||
(eq (etaf-retirement-journal-state journal) 'open)
|
||||
owner kind (functionp payload)
|
||||
(memq policy '(run-once-public retryable-idempotent
|
||||
contained-once))
|
||||
(integerp max-attempts) (> max-attempts 0))
|
||||
(signal 'etaf-retirement-error
|
||||
(list :invalid-entry owner kind policy max-attempts)))
|
||||
(let ((entry
|
||||
(etaf-retirement-entry--create
|
||||
:id (cl-incf etaf-retirement--entry-id-counter)
|
||||
:owner owner
|
||||
:kind kind
|
||||
:payload payload
|
||||
:ordering-key ordering-key
|
||||
:policy policy
|
||||
:max-attempts max-attempts)))
|
||||
(push entry (etaf-retirement-journal-entries journal))
|
||||
entry))
|
||||
|
||||
(defun etaf-retirement--ordering-value-rank (value)
|
||||
"Return a stable type rank for retirement ordering VALUE."
|
||||
(cond
|
||||
((null value) 0)
|
||||
((numberp value) 1)
|
||||
((symbolp value) 2)
|
||||
((stringp value) 3)
|
||||
((consp value) 4)
|
||||
(t 5)))
|
||||
|
||||
(defun etaf-retirement--compare-ordering-values (left right)
|
||||
"Compare retirement ordering values LEFT and RIGHT.
|
||||
Return a negative integer when LEFT precedes RIGHT, zero when their ordering
|
||||
forms are equal, and a positive integer otherwise."
|
||||
(cond
|
||||
((equal left right) 0)
|
||||
((and (numberp left) (numberp right))
|
||||
(cond ((= left right) 0) ((< left right) -1) (t 1)))
|
||||
((and (symbolp left) (symbolp right))
|
||||
(if (string< (symbol-name left) (symbol-name right)) -1 1))
|
||||
((and (stringp left) (stringp right))
|
||||
(if (string< left right) -1 1))
|
||||
((and (consp left) (consp right))
|
||||
(let ((left-tail left) (right-tail right) (result 0))
|
||||
(while (and (consp left-tail) (consp right-tail) (= result 0))
|
||||
(setq result
|
||||
(etaf-retirement--compare-ordering-values
|
||||
(car left-tail) (car right-tail))
|
||||
left-tail (cdr left-tail)
|
||||
right-tail (cdr right-tail)))
|
||||
(if (= result 0)
|
||||
(etaf-retirement--compare-ordering-values left-tail right-tail)
|
||||
result)))
|
||||
(t
|
||||
(let ((left-rank (etaf-retirement--ordering-value-rank left))
|
||||
(right-rank (etaf-retirement--ordering-value-rank right)))
|
||||
(cond
|
||||
((< left-rank right-rank) -1)
|
||||
((> left-rank right-rank) 1)
|
||||
((string< (prin1-to-string left) (prin1-to-string right)) -1)
|
||||
(t 1))))))
|
||||
|
||||
(defun etaf-retirement--entry-less-p (left right)
|
||||
"Return non-nil when LEFT sorts before RIGHT deterministically."
|
||||
(let ((order
|
||||
(etaf-retirement--compare-ordering-values
|
||||
(etaf-retirement-entry-ordering-key left)
|
||||
(etaf-retirement-entry-ordering-key right))))
|
||||
(if (= order 0)
|
||||
(< (etaf-retirement-entry-id left)
|
||||
(etaf-retirement-entry-id right))
|
||||
(< order 0))))
|
||||
|
||||
(defun etaf-retirement--record-failure (journal entry condition terminal-state)
|
||||
"Record ENTRY CONDITION in JOURNAL and assign TERMINAL-STATE."
|
||||
(setf (etaf-retirement-entry-condition entry) condition
|
||||
(etaf-retirement-entry-state entry) terminal-state)
|
||||
(push (list :entry-id (etaf-retirement-entry-id entry)
|
||||
:owner (copy-tree (etaf-retirement-entry-owner entry))
|
||||
:kind (etaf-retirement-entry-kind entry)
|
||||
:policy (etaf-retirement-entry-policy entry)
|
||||
:attempt-count (etaf-retirement-entry-attempt-count entry)
|
||||
:state terminal-state
|
||||
:condition (copy-tree condition))
|
||||
(etaf-retirement-journal-diagnostics journal)))
|
||||
|
||||
(defun etaf-retirement--run-entry (journal entry)
|
||||
"Run JOURNAL ENTRY according to its bounded policy and return a condition."
|
||||
(let (condition done)
|
||||
(while (and (not done)
|
||||
(< (etaf-retirement-entry-attempt-count entry)
|
||||
(etaf-retirement-entry-max-attempts entry)))
|
||||
(cl-incf (etaf-retirement-entry-attempt-count entry))
|
||||
(setf (etaf-retirement-entry-state entry) 'running)
|
||||
(setq condition
|
||||
(condition-case failure
|
||||
(progn
|
||||
(funcall (etaf-retirement-entry-payload entry))
|
||||
nil)
|
||||
((error quit) failure)))
|
||||
(if (null condition)
|
||||
(setq done t)
|
||||
(unless (eq (etaf-retirement-entry-policy entry)
|
||||
'retryable-idempotent)
|
||||
(setq done t))))
|
||||
(if (null condition)
|
||||
(setf (etaf-retirement-entry-state entry) 'completed)
|
||||
(etaf-retirement--record-failure
|
||||
journal entry condition 'failed-contained))
|
||||
condition))
|
||||
|
||||
(defun etaf-retirement-drain (journal)
|
||||
"Drain JOURNAL once and return the first public lifecycle condition."
|
||||
(unless (and (etaf-retirement-journal-p journal)
|
||||
(eq (etaf-retirement-journal-state journal) 'open))
|
||||
(signal 'etaf-retirement-error
|
||||
(list :journal-not-open
|
||||
(and (etaf-retirement-journal-p journal)
|
||||
(etaf-retirement-journal-state journal)))))
|
||||
(let ((entries
|
||||
(sort (copy-sequence (etaf-retirement-journal-entries journal))
|
||||
#'etaf-retirement--entry-less-p))
|
||||
public-condition public-failed-p)
|
||||
(dolist (entry entries)
|
||||
(cond
|
||||
((and public-failed-p
|
||||
(eq (etaf-retirement-entry-policy entry) 'run-once-public))
|
||||
(setf (etaf-retirement-entry-state entry) 'abandoned-contained)
|
||||
(push (list :entry-id (etaf-retirement-entry-id entry)
|
||||
:owner (copy-tree (etaf-retirement-entry-owner entry))
|
||||
:kind (etaf-retirement-entry-kind entry)
|
||||
:policy 'run-once-public
|
||||
:attempt-count 0
|
||||
:state 'abandoned-contained)
|
||||
(etaf-retirement-journal-diagnostics journal)))
|
||||
(t
|
||||
(when-let* ((condition (etaf-retirement--run-entry journal entry)))
|
||||
(when (and (eq (etaf-retirement-entry-policy entry)
|
||||
'run-once-public)
|
||||
(null public-condition))
|
||||
(setq public-condition condition
|
||||
public-failed-p t))))))
|
||||
(setf (etaf-retirement-journal-entries journal) entries
|
||||
(etaf-retirement-journal-diagnostics journal)
|
||||
(nreverse (etaf-retirement-journal-diagnostics journal))
|
||||
(etaf-retirement-journal-state journal) 'completed)
|
||||
public-condition))
|
||||
|
||||
(defun etaf-retirement-record-contained-failure
|
||||
(journal owner kind condition)
|
||||
"Append contained postcommit CONDITION metadata to JOURNAL.
|
||||
OWNER and KIND identify the failed postcommit step. This records evidence
|
||||
without rerunning the failed operation or changing committed authority."
|
||||
(unless (and (etaf-retirement-journal-p journal)
|
||||
(eq (etaf-retirement-journal-state journal) 'open)
|
||||
owner kind
|
||||
(consp condition) (symbolp (car condition)))
|
||||
(signal 'etaf-retirement-error
|
||||
(list :invalid-contained-failure owner kind condition)))
|
||||
(push (list :entry-id (cl-incf etaf-retirement--entry-id-counter)
|
||||
:owner (copy-tree owner)
|
||||
:kind kind
|
||||
:policy 'contained-once
|
||||
:attempt-count 1
|
||||
:state 'failed-contained
|
||||
:condition (copy-tree condition))
|
||||
(etaf-retirement-journal-diagnostics journal))
|
||||
condition)
|
||||
|
||||
(cl-defun etaf-retirement-condition-trailer
|
||||
(journal &optional kind &rest options)
|
||||
"Return the canonical v1 trailer for JOURNAL and KIND.
|
||||
|
||||
The legacy POSTCOMMIT form is unchanged. KIND `projection' additionally
|
||||
requires the certainty and both reconciliation/projection tokens, which are
|
||||
encoded in the same versioned sentinel wire format."
|
||||
;; Accept both the historical positional KIND and a keyword-style KIND.
|
||||
(when (keywordp kind)
|
||||
(setq options (cons kind options)
|
||||
kind (plist-get options :kind)))
|
||||
(let ((external-commit-certainty
|
||||
(plist-get options :external-commit-certainty))
|
||||
(reconciliation-token (plist-get options :reconciliation-token))
|
||||
(projection-token (plist-get options :projection-token))
|
||||
(result (plist-get options :result)))
|
||||
(if (eq (or kind 'postcommit) 'projection)
|
||||
(list :etaf-condition-trailer/v1
|
||||
(list :kind 'projection
|
||||
:committed-p t
|
||||
:external-commit-certainty external-commit-certainty
|
||||
:reconciliation-token reconciliation-token
|
||||
:projection-token projection-token
|
||||
:result result
|
||||
:operation-id (etaf-retirement-journal-operation-id journal)
|
||||
:outcome-id (etaf-retirement-journal-outcome-id journal)
|
||||
:generation-id (etaf-retirement-journal-generation-id journal)
|
||||
:revision (etaf-retirement-journal-revision journal)
|
||||
:diagnostic-journal-id (etaf-retirement-journal-id journal)))
|
||||
(list :etaf-condition-trailer/v1
|
||||
(list :kind (or kind 'postcommit)
|
||||
:committed-p t
|
||||
:operation-id (etaf-retirement-journal-operation-id journal)
|
||||
:outcome-id (etaf-retirement-journal-outcome-id journal)
|
||||
:generation-id (etaf-retirement-journal-generation-id journal)
|
||||
:revision (etaf-retirement-journal-revision journal)
|
||||
:diagnostic-journal-id (etaf-retirement-journal-id journal))))))
|
||||
|
||||
(defun etaf-retirement--condition-trailer-payload (condition)
|
||||
"Return the final validated-looking trailer payload in CONDITION, or nil.
|
||||
Validation of kind-specific fields is performed by the public readers."
|
||||
(when (and (consp condition) (symbolp (car condition))
|
||||
(proper-list-p (cdr condition)) (cdr condition))
|
||||
(let ((trailer (car (last (cdr condition)))))
|
||||
(when (and (proper-list-p trailer)
|
||||
(= (length trailer) 2)
|
||||
(eq (car trailer) :etaf-condition-trailer/v1)
|
||||
(proper-list-p (cadr trailer)))
|
||||
(cadr trailer)))))
|
||||
|
||||
(defun etaf-retirement--valid-payload-p (payload keys kind)
|
||||
"Return non-nil when PAYLOAD exactly matches KEYS and has KIND metadata."
|
||||
(and (= (length payload) (* 2 (length keys)))
|
||||
(equal (cl-loop for (key _value) on payload by #'cddr collect key)
|
||||
keys)
|
||||
(eq (plist-get payload :kind) kind)
|
||||
(eq (plist-get payload :committed-p) t)
|
||||
(integerp (plist-get payload :operation-id))
|
||||
(>= (plist-get payload :operation-id) 0)
|
||||
(plist-get payload :outcome-id)
|
||||
(integerp (plist-get payload :generation-id))
|
||||
(>= (plist-get payload :generation-id) 0)
|
||||
(integerp (plist-get payload :revision))
|
||||
(>= (plist-get payload :revision) 0)
|
||||
(integerp (plist-get payload :diagnostic-journal-id))
|
||||
(> (plist-get payload :diagnostic-journal-id) 0)))
|
||||
|
||||
(defun etaf-condition-postcommit-info (condition)
|
||||
"Return validated postcommit payload from CONDITION, or nil."
|
||||
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
|
||||
(when (and payload
|
||||
(etaf-retirement--valid-payload-p
|
||||
payload etaf-retirement--condition-payload-keys 'postcommit))
|
||||
(copy-tree payload))))
|
||||
|
||||
(defun etaf-data-condition-projection-info (condition)
|
||||
"Return validated v1 Data projection payload from CONDITION, or nil.
|
||||
|
||||
The reader only recognizes the final datum, preserving arbitrary business
|
||||
data and earlier lookalike sentinels."
|
||||
(let ((payload (etaf-retirement--condition-trailer-payload condition)))
|
||||
(when (and payload
|
||||
(etaf-retirement--valid-payload-p
|
||||
payload etaf-retirement--projection-payload-keys 'projection)
|
||||
(memq (plist-get payload :external-commit-certainty)
|
||||
'(committed external-unknown rolled-back))
|
||||
(plist-get payload :reconciliation-token)
|
||||
(plist-get payload :projection-token))
|
||||
(copy-tree payload))))
|
||||
|
||||
(defun etaf-retirement-resignal (condition journal)
|
||||
"Re-signal original CONDITION with JOURNAL's committed trailer appended."
|
||||
(unless (and (consp condition) (symbolp (car condition)))
|
||||
(signal 'wrong-type-argument (list 'error-condition condition)))
|
||||
(if (etaf-condition-postcommit-info condition)
|
||||
(signal (car condition) (cdr condition))
|
||||
(signal (car condition)
|
||||
(append (copy-tree (cdr condition))
|
||||
(list (etaf-retirement-condition-trailer journal))))))
|
||||
|
||||
(provide 'etaf-retirement)
|
||||
|
||||
;;; etaf-retirement.el ends here
|
||||
4850
etaf-runtime.el
4850
etaf-runtime.el
File diff suppressed because it is too large
Load Diff
@ -1,767 +0,0 @@
|
||||
;;; etaf-scheduler.el --- Explicit reactive dispatcher contexts -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Owns ETAF's cross-source dispatch queues. Contexts isolate FIFO and dedupe
|
||||
;; authority, while a short-lived projection coordinates fan-out across every
|
||||
;; context touched by one logical reactive publication.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
|
||||
(define-error 'etaf-scheduler-error "Invalid ETAF scheduler operation")
|
||||
|
||||
(defgroup etaf-scheduler nil
|
||||
"Explicit ETAF reactive dispatcher contexts."
|
||||
:group 'applications
|
||||
:prefix "etaf-scheduler-")
|
||||
|
||||
(defcustom etaf-scheduler-default-step-budget 128
|
||||
"Maximum dispatcher turns one context may run in one projection."
|
||||
:type 'positive-integer
|
||||
:group 'etaf-scheduler)
|
||||
|
||||
(defvar etaf-scheduler--context-id-counter 0)
|
||||
(defvar etaf-scheduler--projection-id-counter 0)
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-scheduler-context
|
||||
(:constructor etaf-scheduler-context--create))
|
||||
"Mutable queues and diagnostics for one isolated dispatcher."
|
||||
id name
|
||||
source-queue source-queue-tail source-set
|
||||
deferred-source-queue deferred-source-queue-tail deferred-source-set
|
||||
delivered-source-set
|
||||
runtime-queue runtime-queue-tail runtime-set
|
||||
effect-set
|
||||
(active-turn-id 0)
|
||||
(projection-epoch 0)
|
||||
(completed-projection-epoch 0)
|
||||
(depth 0)
|
||||
(event-depth 0)
|
||||
(busy-depth 0)
|
||||
phase
|
||||
fixed-point-step-budget
|
||||
fault-state diagnostics
|
||||
(source-enqueue-count 0)
|
||||
(source-dedupe-count 0)
|
||||
(source-delivery-count 0)
|
||||
(subscriber-visit-count 0)
|
||||
(effect-claim-count 0)
|
||||
(effect-evaluation-count 0)
|
||||
(runtime-enqueue-count 0)
|
||||
(runtime-dedupe-count 0)
|
||||
(runtime-execution-count 0)
|
||||
(stale-route-drop-count 0)
|
||||
(projection-fault-count 0)
|
||||
(turn-count 0))
|
||||
|
||||
(cl-defstruct
|
||||
(etaf-scheduler--projection
|
||||
(:constructor etaf-scheduler--projection-create))
|
||||
"One cross-context reactive projection."
|
||||
id all-contexts all-context-set context-before finalizers
|
||||
completion-observers)
|
||||
|
||||
(cl-defun etaf-scheduler-context-create (&key name fixed-point-step-budget)
|
||||
"Create an isolated scheduler context named NAME.
|
||||
FIXED-POINT-STEP-BUDGET is optional diagnostic metadata for its owner."
|
||||
(when (and fixed-point-step-budget
|
||||
(not (and (integerp fixed-point-step-budget)
|
||||
(> fixed-point-step-budget 0))))
|
||||
(signal 'etaf-scheduler-error
|
||||
(list :invalid-fixed-point-step-budget fixed-point-step-budget)))
|
||||
(etaf-scheduler-context--create
|
||||
:id (cl-incf etaf-scheduler--context-id-counter)
|
||||
:name name
|
||||
:source-set (make-hash-table :test #'eq)
|
||||
:deferred-source-set (make-hash-table :test #'eq)
|
||||
:delivered-source-set (make-hash-table :test #'eq)
|
||||
:runtime-set (make-hash-table :test #'eq)
|
||||
:effect-set (make-hash-table :test #'eq)
|
||||
:fixed-point-step-budget
|
||||
(or fixed-point-step-budget etaf-scheduler-default-step-budget)))
|
||||
|
||||
(defvar etaf-scheduler-default-context
|
||||
(etaf-scheduler-context-create :name 'default)
|
||||
"Default scheduler context used by the compatibility facade.")
|
||||
|
||||
(defvar etaf--scheduler-context nil
|
||||
"Dynamically active scheduler context, or nil for the default context.")
|
||||
|
||||
(defvar etaf-scheduler--active-projection nil
|
||||
"Dynamically active cross-context projection.")
|
||||
|
||||
(defvar etaf-scheduler-projection-observer nil
|
||||
"Optional function receiving each completed projection summary.")
|
||||
|
||||
(defun etaf-scheduler-current-context ()
|
||||
"Return the dynamically active scheduler context or the default context."
|
||||
(or etaf--scheduler-context etaf-scheduler-default-context))
|
||||
|
||||
(defun etaf-scheduler-context-resolve (context)
|
||||
"Return validated CONTEXT, defaulting nil to the current context."
|
||||
(setq context (or context (etaf-scheduler-current-context)))
|
||||
(unless (etaf-scheduler-context-p context)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-scheduler-context-p context)))
|
||||
context)
|
||||
|
||||
(defun etaf-scheduler-call-with-context (context function)
|
||||
"Call FUNCTION with CONTEXT as the active scheduler context."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(cl-incf (etaf-scheduler-context-depth context))
|
||||
(let ((etaf--scheduler-context context))
|
||||
(unwind-protect
|
||||
(funcall function)
|
||||
(setf (etaf-scheduler-context-depth context)
|
||||
(max 0 (1- (etaf-scheduler-context-depth context)))))))
|
||||
|
||||
(defun etaf-scheduler-context-event-begin (context)
|
||||
"Increment CONTEXT's logical event nesting depth."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(cl-incf (etaf-scheduler-context-event-depth context))
|
||||
context)
|
||||
|
||||
(defun etaf-scheduler-context-event-end (context)
|
||||
"Decrement CONTEXT's logical event nesting depth."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(setf (etaf-scheduler-context-event-depth context)
|
||||
(max 0 (1- (etaf-scheduler-context-event-depth context))))
|
||||
context)
|
||||
|
||||
(defun etaf-scheduler--append-context (projection context)
|
||||
"Register CONTEXT with PROJECTION once."
|
||||
(unless (gethash context
|
||||
(etaf-scheduler--projection-all-context-set projection))
|
||||
(puthash context t
|
||||
(etaf-scheduler--projection-all-context-set projection))
|
||||
(puthash context (etaf-scheduler-context-metrics context)
|
||||
(etaf-scheduler--projection-context-before projection))
|
||||
(push context (etaf-scheduler--projection-all-contexts projection))))
|
||||
|
||||
(defun etaf-scheduler--append-source (context source)
|
||||
"Append SOURCE to CONTEXT's FIFO in constant time."
|
||||
(let ((cell (list source)))
|
||||
(if (etaf-scheduler-context-source-queue-tail context)
|
||||
(setcdr (etaf-scheduler-context-source-queue-tail context) cell)
|
||||
(setf (etaf-scheduler-context-source-queue context) cell))
|
||||
(setf (etaf-scheduler-context-source-queue-tail context) cell)))
|
||||
|
||||
(defun etaf-scheduler--append-runtime (context runtime)
|
||||
"Append RUNTIME to CONTEXT's FIFO in constant time."
|
||||
(let ((cell (list runtime)))
|
||||
(if (etaf-scheduler-context-runtime-queue-tail context)
|
||||
(setcdr (etaf-scheduler-context-runtime-queue-tail context) cell)
|
||||
(setf (etaf-scheduler-context-runtime-queue context) cell))
|
||||
(setf (etaf-scheduler-context-runtime-queue-tail context) cell)))
|
||||
|
||||
(defun etaf-scheduler--append-deferred-source (context source)
|
||||
"Append SOURCE to CONTEXT's following-turn FIFO."
|
||||
(let ((cell (list source)))
|
||||
(if (etaf-scheduler-context-deferred-source-queue-tail context)
|
||||
(setcdr
|
||||
(etaf-scheduler-context-deferred-source-queue-tail context) cell)
|
||||
(setf (etaf-scheduler-context-deferred-source-queue context) cell))
|
||||
(setf (etaf-scheduler-context-deferred-source-queue-tail context) cell)))
|
||||
|
||||
(defun etaf-scheduler--enqueue-source-now
|
||||
(projection context source delivery)
|
||||
"Enqueue SOURCE and DELIVERY in CONTEXT under PROJECTION."
|
||||
(etaf-scheduler--append-context projection context)
|
||||
(let ((set (etaf-scheduler-context-source-set context))
|
||||
(deferred-set
|
||||
(etaf-scheduler-context-deferred-source-set context)))
|
||||
(cond
|
||||
((or (gethash source set) (gethash source deferred-set))
|
||||
(cl-incf (etaf-scheduler-context-source-dedupe-count context)))
|
||||
((and (eq (etaf-scheduler-context-phase context) 'source)
|
||||
(gethash source
|
||||
(etaf-scheduler-context-delivered-source-set context)))
|
||||
(puthash source delivery deferred-set)
|
||||
(etaf-scheduler--append-deferred-source context source)
|
||||
(cl-incf (etaf-scheduler-context-source-enqueue-count context)))
|
||||
(t
|
||||
(puthash source delivery set)
|
||||
(etaf-scheduler--append-source context source)
|
||||
(cl-incf (etaf-scheduler-context-source-enqueue-count context))))))
|
||||
|
||||
(defun etaf-scheduler--enqueue-runtime-now
|
||||
(projection context runtime function)
|
||||
"Enqueue RUNTIME and FUNCTION in CONTEXT under PROJECTION."
|
||||
(etaf-scheduler--append-context projection context)
|
||||
(let ((set (etaf-scheduler-context-runtime-set context)))
|
||||
(if (gethash runtime set)
|
||||
(cl-incf (etaf-scheduler-context-runtime-dedupe-count context))
|
||||
(puthash runtime function set)
|
||||
(etaf-scheduler--append-runtime context runtime)
|
||||
(cl-incf (etaf-scheduler-context-runtime-enqueue-count context)))))
|
||||
|
||||
(defun etaf-scheduler-enqueue-source (context source delivery)
|
||||
"Queue DELIVERY of SOURCE once in CONTEXT for the active projection.
|
||||
DELIVERY receives CONTEXT, SOURCE, and the projection epoch."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(unless (functionp delivery)
|
||||
(signal 'wrong-type-argument (list 'functionp delivery)))
|
||||
(if etaf-scheduler--active-projection
|
||||
(etaf-scheduler--enqueue-source-now
|
||||
etaf-scheduler--active-projection context source delivery)
|
||||
(etaf-scheduler-call-with-projection
|
||||
(lambda ()
|
||||
(etaf-scheduler--enqueue-source-now
|
||||
etaf-scheduler--active-projection context source delivery))))
|
||||
source)
|
||||
|
||||
(defun etaf-scheduler-enqueue-runtime (context runtime function)
|
||||
"Queue FUNCTION once for RUNTIME in CONTEXT after source delivery."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(if etaf-scheduler--active-projection
|
||||
(etaf-scheduler--enqueue-runtime-now
|
||||
etaf-scheduler--active-projection context runtime function)
|
||||
(etaf-scheduler-call-with-projection
|
||||
(lambda ()
|
||||
(etaf-scheduler--enqueue-runtime-now
|
||||
etaf-scheduler--active-projection context runtime function))))
|
||||
runtime)
|
||||
|
||||
(defun etaf-scheduler-claim-effect (context effect)
|
||||
"Return non-nil after claiming EFFECT once in CONTEXT's projection."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(unless (gethash effect (etaf-scheduler-context-effect-set context))
|
||||
(puthash effect t (etaf-scheduler-context-effect-set context))
|
||||
(cl-incf (etaf-scheduler-context-effect-claim-count context))
|
||||
t))
|
||||
|
||||
(defun etaf-scheduler-record-subscriber-visit (context)
|
||||
"Record one subscriber visit in scheduler CONTEXT."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(when etaf-scheduler--active-projection
|
||||
(etaf-scheduler--append-context
|
||||
etaf-scheduler--active-projection context))
|
||||
(cl-incf (etaf-scheduler-context-subscriber-visit-count context)))
|
||||
|
||||
(defun etaf-scheduler-record-effect-evaluation (context)
|
||||
"Record one reactive effect evaluation in scheduler CONTEXT."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(when etaf-scheduler--active-projection
|
||||
(etaf-scheduler--append-context
|
||||
etaf-scheduler--active-projection context))
|
||||
(cl-incf (etaf-scheduler-context-effect-evaluation-count context)))
|
||||
|
||||
(defun etaf-scheduler-record-stale-route-drop (context)
|
||||
"Record one stale route filtered before fan-out in CONTEXT."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(when etaf-scheduler--active-projection
|
||||
(etaf-scheduler--append-context
|
||||
etaf-scheduler--active-projection context))
|
||||
(cl-incf (etaf-scheduler-context-stale-route-drop-count context)))
|
||||
|
||||
(defun etaf-scheduler-defer-finalizer (function)
|
||||
"Run FUNCTION after the active projection drains, or immediately if idle."
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(if etaf-scheduler--active-projection
|
||||
(push function
|
||||
(etaf-scheduler--projection-finalizers
|
||||
etaf-scheduler--active-projection))
|
||||
(funcall function))
|
||||
function)
|
||||
|
||||
(defun etaf-scheduler-projection-active-p ()
|
||||
"Return non-nil while a scheduler projection is active."
|
||||
(not (null etaf-scheduler--active-projection)))
|
||||
|
||||
(defun etaf-scheduler-on-projection-complete (function)
|
||||
"Call FUNCTION with the active projection summary when it completes."
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(if etaf-scheduler--active-projection
|
||||
(push function
|
||||
(etaf-scheduler--projection-completion-observers
|
||||
etaf-scheduler--active-projection))
|
||||
(funcall function nil))
|
||||
function)
|
||||
|
||||
(defun etaf-scheduler--reset-pending (context)
|
||||
"Discard CONTEXT's pending queues and dedupe membership."
|
||||
(setf (etaf-scheduler-context-source-queue context) nil
|
||||
(etaf-scheduler-context-source-queue-tail context) nil
|
||||
(etaf-scheduler-context-deferred-source-queue context) nil
|
||||
(etaf-scheduler-context-deferred-source-queue-tail context) nil
|
||||
(etaf-scheduler-context-runtime-queue context) nil
|
||||
(etaf-scheduler-context-runtime-queue-tail context) nil
|
||||
(etaf-scheduler-context-phase context) nil)
|
||||
(clrhash (etaf-scheduler-context-source-set context))
|
||||
(clrhash (etaf-scheduler-context-deferred-source-set context))
|
||||
(clrhash (etaf-scheduler-context-delivered-source-set context))
|
||||
(clrhash (etaf-scheduler-context-runtime-set context))
|
||||
context)
|
||||
|
||||
(defun etaf-scheduler--promote-deferred-sources (context)
|
||||
"Move CONTEXT's deferred sources into its following-turn FIFO."
|
||||
(let ((deferred (etaf-scheduler-context-deferred-source-queue context))
|
||||
(deferred-set
|
||||
(etaf-scheduler-context-deferred-source-set context))
|
||||
(source-set (etaf-scheduler-context-source-set context)))
|
||||
(setf (etaf-scheduler-context-deferred-source-queue context) nil
|
||||
(etaf-scheduler-context-deferred-source-queue-tail context) nil)
|
||||
(dolist (source deferred)
|
||||
(let ((delivery (gethash source deferred-set)))
|
||||
(remhash source deferred-set)
|
||||
(unless (gethash source source-set)
|
||||
(puthash source delivery source-set)
|
||||
(etaf-scheduler--append-source context source)))))
|
||||
context)
|
||||
|
||||
(defun etaf-scheduler--projection-contexts (projection)
|
||||
"Return PROJECTION contexts in first-touch order."
|
||||
(nreverse
|
||||
(copy-sequence (etaf-scheduler--projection-all-contexts projection))))
|
||||
|
||||
(defun etaf-scheduler--projection-source-work-p (projection)
|
||||
"Return non-nil when PROJECTION has pending source work."
|
||||
(cl-some #'etaf-scheduler-context-source-queue
|
||||
(etaf-scheduler--projection-contexts projection)))
|
||||
|
||||
(defun etaf-scheduler--projection-work-p (projection)
|
||||
"Return non-nil when PROJECTION has pending source or Runtime work."
|
||||
(cl-some
|
||||
(lambda (context)
|
||||
(or (etaf-scheduler-context-source-queue context)
|
||||
(etaf-scheduler-context-runtime-queue context)))
|
||||
(etaf-scheduler--projection-contexts projection)))
|
||||
|
||||
(defun etaf-scheduler--mark-turn
|
||||
(context projection-id marked-contexts context-steps)
|
||||
"Mark CONTEXT for PROJECTION-ID in MARKED-CONTEXTS and CONTEXT-STEPS."
|
||||
(unless (gethash context marked-contexts)
|
||||
(let* ((steps (1+ (gethash context context-steps 0)))
|
||||
(budget (etaf-scheduler-context-fixed-point-step-budget context)))
|
||||
(when (> steps budget)
|
||||
(signal 'etaf-scheduler-error
|
||||
(list :kind 'fixed-point-step-budget
|
||||
:context-id (etaf-scheduler-context-id context)
|
||||
:projection-id projection-id
|
||||
:steps steps :budget budget)))
|
||||
(puthash context steps context-steps))
|
||||
(puthash context t marked-contexts)
|
||||
(setf (etaf-scheduler-context-projection-epoch context) projection-id)
|
||||
(clrhash (etaf-scheduler-context-delivered-source-set context))
|
||||
(clrhash (etaf-scheduler-context-effect-set context))
|
||||
(cl-incf (etaf-scheduler-context-active-turn-id context))
|
||||
(cl-incf (etaf-scheduler-context-turn-count context))))
|
||||
|
||||
(defun etaf-scheduler--call-context-work (context function)
|
||||
"Call FUNCTION as busy work owned by scheduler CONTEXT."
|
||||
(cl-incf (etaf-scheduler-context-busy-depth context))
|
||||
(unwind-protect
|
||||
(etaf-scheduler-call-with-context context function)
|
||||
(setf (etaf-scheduler-context-busy-depth context)
|
||||
(max 0 (1- (etaf-scheduler-context-busy-depth context))))))
|
||||
|
||||
(defun etaf-scheduler--drain-context-sources (context projection-id)
|
||||
"Drain one CONTEXT source turn and return its first condition.
|
||||
PROJECTION-ID identifies the bounded projection owning the detached turn."
|
||||
(let ((turn (etaf-scheduler-context-source-queue context)) first-condition)
|
||||
;; New sources discovered by TURN belong to the next bounded scheduler
|
||||
;; turn. Detaching the current FIFO prevents a chain of distinct source
|
||||
;; identities from monopolizing one unbudgeted drain.
|
||||
(setf (etaf-scheduler-context-source-queue context) nil
|
||||
(etaf-scheduler-context-source-queue-tail context) nil
|
||||
(etaf-scheduler-context-phase context) 'source)
|
||||
(etaf-scheduler--call-context-work
|
||||
context
|
||||
(lambda ()
|
||||
(dolist (source turn)
|
||||
(let ((delivery
|
||||
(gethash source
|
||||
(etaf-scheduler-context-source-set context))))
|
||||
(remhash source (etaf-scheduler-context-source-set context))
|
||||
(puthash source t
|
||||
(etaf-scheduler-context-delivered-source-set context))
|
||||
(cl-incf (etaf-scheduler-context-source-delivery-count context))
|
||||
(when delivery
|
||||
(condition-case condition
|
||||
(funcall delivery context source projection-id)
|
||||
((error quit)
|
||||
(unless first-condition
|
||||
(setq first-condition condition)))))))))
|
||||
first-condition))
|
||||
|
||||
(defun etaf-scheduler--detach-runtime-turns (projection)
|
||||
"Detach and return PROJECTION's Runtime queues in context order."
|
||||
(let (turns)
|
||||
(dolist (context (etaf-scheduler--projection-contexts projection))
|
||||
(when-let* ((turn (etaf-scheduler-context-runtime-queue context)))
|
||||
(setf (etaf-scheduler-context-runtime-queue context) nil
|
||||
(etaf-scheduler-context-runtime-queue-tail context) nil)
|
||||
(push (cons context turn) turns)))
|
||||
(nreverse turns)))
|
||||
|
||||
(defun etaf-scheduler--run-runtime-turn (context turn)
|
||||
"Run detached Runtime TURN in CONTEXT and return its first condition."
|
||||
(let (first-condition)
|
||||
(setf (etaf-scheduler-context-phase context) 'runtime)
|
||||
(etaf-scheduler--call-context-work
|
||||
context
|
||||
(lambda ()
|
||||
(dolist (runtime turn)
|
||||
(let ((function
|
||||
(gethash runtime
|
||||
(etaf-scheduler-context-runtime-set context))))
|
||||
(remhash runtime (etaf-scheduler-context-runtime-set context))
|
||||
(when function
|
||||
(cl-incf (etaf-scheduler-context-runtime-execution-count context))
|
||||
(condition-case condition
|
||||
(funcall function)
|
||||
((error quit)
|
||||
(unless first-condition
|
||||
(setq first-condition condition)))))))))
|
||||
first-condition))
|
||||
|
||||
(defun etaf-scheduler--record-fault
|
||||
(context projection-id condition &optional phase turn-id)
|
||||
"Record CONTEXT failure CONDITION for PROJECTION-ID.
|
||||
PHASE is optional diagnostic metadata. TURN-ID, when non-nil, preserves the
|
||||
turn where a contained condition originated before delayed quarantine."
|
||||
(setf (etaf-scheduler-context-fault-state context) (copy-tree condition))
|
||||
(cl-incf (etaf-scheduler-context-projection-fault-count context))
|
||||
(push (append (list :projection-epoch projection-id
|
||||
:turn-id
|
||||
(or turn-id
|
||||
(etaf-scheduler-context-active-turn-id context)))
|
||||
(and phase (list :phase phase))
|
||||
(list :condition (copy-tree condition)))
|
||||
(etaf-scheduler-context-diagnostics context))
|
||||
(when (> (length (etaf-scheduler-context-diagnostics context)) 64)
|
||||
(setcdr (nthcdr 63 (etaf-scheduler-context-diagnostics context)) nil))
|
||||
condition)
|
||||
|
||||
(defun etaf-scheduler-record-route-authority-fault (context condition)
|
||||
"Record contained Host route authority CONDITION in scheduler CONTEXT."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(unless (consp condition)
|
||||
(signal 'wrong-type-argument (list 'consp condition)))
|
||||
(when etaf-scheduler--active-projection
|
||||
(etaf-scheduler--append-context etaf-scheduler--active-projection context))
|
||||
(etaf-scheduler--record-fault
|
||||
context
|
||||
(if etaf-scheduler--active-projection
|
||||
(etaf-scheduler--projection-id etaf-scheduler--active-projection)
|
||||
(etaf-scheduler-context-projection-epoch context))
|
||||
condition 'route-authority))
|
||||
|
||||
(defun etaf-scheduler--drain-projection (projection)
|
||||
"Drain PROJECTION source-first and re-signal its first context fault."
|
||||
(let ((projection-id (etaf-scheduler--projection-id projection))
|
||||
(failed-contexts (make-hash-table :test #'eq))
|
||||
(contained-context-conditions (make-hash-table :test #'eq))
|
||||
(context-steps (make-hash-table :test #'eq))
|
||||
first-condition fatal-condition)
|
||||
(while (etaf-scheduler--projection-work-p projection)
|
||||
(let ((marked-contexts (make-hash-table :test #'eq)))
|
||||
;; All source propagation across every context settles before any
|
||||
;; Runtime can observe and publish the resulting reactive state.
|
||||
(while (etaf-scheduler--projection-source-work-p projection)
|
||||
;; Each source wave is one bounded turn. A wave snapshots every
|
||||
;; context's current FIFO, so newly discovered distinct sources
|
||||
;; consume another step and peers get an opportunity to run.
|
||||
(setq marked-contexts (make-hash-table :test #'eq))
|
||||
(dolist (context (etaf-scheduler--projection-contexts projection))
|
||||
(cond
|
||||
((gethash context failed-contexts)
|
||||
(etaf-scheduler--reset-pending context))
|
||||
((etaf-scheduler-context-source-queue context)
|
||||
(condition-case condition
|
||||
(progn
|
||||
(etaf-scheduler--mark-turn
|
||||
context projection-id marked-contexts context-steps)
|
||||
(when-let* ((source-condition
|
||||
(etaf-scheduler--drain-context-sources
|
||||
context projection-id)))
|
||||
(unless (gethash context contained-context-conditions)
|
||||
(puthash context
|
||||
(list
|
||||
:condition source-condition
|
||||
:turn-id
|
||||
(etaf-scheduler-context-active-turn-id
|
||||
context))
|
||||
contained-context-conditions))
|
||||
(unless first-condition
|
||||
(setq first-condition source-condition))))
|
||||
((error quit)
|
||||
(puthash context t failed-contexts)
|
||||
(unless fatal-condition (setq fatal-condition condition))
|
||||
(etaf-scheduler--record-fault
|
||||
context projection-id condition)
|
||||
(etaf-scheduler--reset-pending context)))))))
|
||||
;; Detach every context's Runtime queue before callbacks run. A write
|
||||
;; from one callback therefore belongs to the following scheduler turn.
|
||||
(dolist (entry (etaf-scheduler--detach-runtime-turns projection))
|
||||
(let ((context (car entry)) (turn (cdr entry)))
|
||||
(unless (gethash context failed-contexts)
|
||||
(condition-case condition
|
||||
(progn
|
||||
(etaf-scheduler--mark-turn
|
||||
context projection-id marked-contexts context-steps)
|
||||
(when-let* ((runtime-condition
|
||||
(etaf-scheduler--run-runtime-turn
|
||||
context turn)))
|
||||
(unless (gethash context contained-context-conditions)
|
||||
(puthash context
|
||||
(list
|
||||
:condition runtime-condition
|
||||
:turn-id
|
||||
(etaf-scheduler-context-active-turn-id
|
||||
context))
|
||||
contained-context-conditions))
|
||||
(unless first-condition
|
||||
(setq first-condition runtime-condition))))
|
||||
((error quit)
|
||||
(puthash context t failed-contexts)
|
||||
(unless fatal-condition (setq fatal-condition condition))
|
||||
(etaf-scheduler--record-fault
|
||||
context projection-id condition)
|
||||
(etaf-scheduler--reset-pending context))))))
|
||||
;; Item-level source/subscriber/Runtime faults are reported only after
|
||||
;; the detached Runtime turn has consumed work enqueued by successful
|
||||
;; tail callbacks. Scheduler-control faults above still reset at once.
|
||||
(dolist (context (etaf-scheduler--projection-contexts projection))
|
||||
(when-let* ((contained
|
||||
(gethash context contained-context-conditions))
|
||||
(condition (plist-get contained :condition)))
|
||||
(unless (gethash context failed-contexts)
|
||||
(puthash context t failed-contexts)
|
||||
(etaf-scheduler--record-fault
|
||||
context projection-id condition nil
|
||||
(plist-get contained :turn-id))
|
||||
(etaf-scheduler--reset-pending context))))
|
||||
(dolist (context (etaf-scheduler--projection-contexts projection))
|
||||
(setf (etaf-scheduler-context-phase context) nil)
|
||||
(unless (gethash context failed-contexts)
|
||||
(etaf-scheduler--promote-deferred-sources context)))))
|
||||
(dolist (context (etaf-scheduler--projection-contexts projection))
|
||||
(unless (gethash context failed-contexts)
|
||||
(setf (etaf-scheduler-context-completed-projection-epoch context)
|
||||
projection-id
|
||||
(etaf-scheduler-context-fault-state context) nil)))
|
||||
(when-let* ((condition (or fatal-condition first-condition)))
|
||||
(signal (car condition) (cdr condition)))))
|
||||
|
||||
(defun etaf-scheduler--finish-projection (projection)
|
||||
"Restore PROJECTION invariants and return contained finalizer errors."
|
||||
(let (errors)
|
||||
(dolist (context (etaf-scheduler--projection-all-contexts projection))
|
||||
(when (or (etaf-scheduler-context-source-queue context)
|
||||
(etaf-scheduler-context-deferred-source-queue context)
|
||||
(etaf-scheduler-context-runtime-queue context))
|
||||
(etaf-scheduler--reset-pending context))
|
||||
(setf (etaf-scheduler-context-phase context) nil)
|
||||
(clrhash (etaf-scheduler-context-delivered-source-set context))
|
||||
(clrhash (etaf-scheduler-context-effect-set context)))
|
||||
(let ((etaf-scheduler--active-projection nil))
|
||||
(dolist (finalizer
|
||||
(nreverse (etaf-scheduler--projection-finalizers projection)))
|
||||
(condition-case condition
|
||||
(funcall finalizer)
|
||||
((error quit) (push condition errors)))))
|
||||
(setf (etaf-scheduler--projection-finalizers projection) nil)
|
||||
(nreverse errors)))
|
||||
|
||||
(defun etaf-scheduler--notify-projection-complete (projection summary)
|
||||
"Notify PROJECTION observers with detached SUMMARY, containing failures."
|
||||
(let ((etaf-scheduler--active-projection nil)
|
||||
errors)
|
||||
(when (functionp etaf-scheduler-projection-observer)
|
||||
(condition-case condition
|
||||
(funcall etaf-scheduler-projection-observer (copy-tree summary))
|
||||
((error quit) (push condition errors))))
|
||||
(dolist
|
||||
(observer
|
||||
(nreverse
|
||||
(etaf-scheduler--projection-completion-observers projection)))
|
||||
(condition-case condition
|
||||
(funcall observer (copy-tree summary))
|
||||
((error quit) (push condition errors))))
|
||||
(setf (etaf-scheduler--projection-completion-observers projection) nil)
|
||||
(nreverse errors)))
|
||||
|
||||
(defun etaf-scheduler--metric-delta (before after key)
|
||||
"Return non-negative KEY delta between BEFORE and AFTER metric plists."
|
||||
(max 0 (- (or (plist-get after key) 0)
|
||||
(or (plist-get before key) 0))))
|
||||
|
||||
(defun etaf-scheduler--projection-summary (projection condition)
|
||||
"Return detached PROJECTION metrics with optional failure CONDITION."
|
||||
(let ((before-table
|
||||
(etaf-scheduler--projection-context-before projection))
|
||||
context-summaries
|
||||
(source-enqueues 0) (source-dedupes 0) (source-deliveries 0)
|
||||
(subscriber-visits 0) (effect-claims 0) (effect-evaluations 0)
|
||||
(runtime-enqueues 0) (runtime-dedupes 0) (runtime-executions 0)
|
||||
(stale-route-drops 0) (turns 0) (faults 0))
|
||||
(dolist (context (etaf-scheduler--projection-contexts projection))
|
||||
(let* ((before (gethash context before-table))
|
||||
(after (etaf-scheduler-context-metrics context))
|
||||
(entry
|
||||
(list
|
||||
:context-id (etaf-scheduler-context-id context)
|
||||
:source-enqueues
|
||||
(etaf-scheduler--metric-delta
|
||||
before after :source-enqueues)
|
||||
:source-dedupes
|
||||
(etaf-scheduler--metric-delta before after :source-dedupes)
|
||||
:source-deliveries
|
||||
(etaf-scheduler--metric-delta
|
||||
before after :source-deliveries)
|
||||
:subscriber-visits
|
||||
(etaf-scheduler--metric-delta
|
||||
before after :subscriber-visits)
|
||||
:effect-claims
|
||||
(etaf-scheduler--metric-delta before after :effect-claims)
|
||||
:effect-evaluations
|
||||
(etaf-scheduler--metric-delta
|
||||
before after :effect-evaluations)
|
||||
:runtime-enqueues
|
||||
(etaf-scheduler--metric-delta before after :runtime-enqueues)
|
||||
:runtime-dedupes
|
||||
(etaf-scheduler--metric-delta before after :runtime-dedupes)
|
||||
:runtime-executions
|
||||
(etaf-scheduler--metric-delta
|
||||
before after :runtime-executions)
|
||||
:stale-route-drops
|
||||
(etaf-scheduler--metric-delta
|
||||
before after :stale-route-drops)
|
||||
:turns (etaf-scheduler--metric-delta before after :turn-count)
|
||||
:faults
|
||||
(etaf-scheduler--metric-delta before after :fault-count))))
|
||||
(cl-incf source-enqueues (plist-get entry :source-enqueues))
|
||||
(cl-incf source-dedupes (plist-get entry :source-dedupes))
|
||||
(cl-incf source-deliveries (plist-get entry :source-deliveries))
|
||||
(cl-incf subscriber-visits (plist-get entry :subscriber-visits))
|
||||
(cl-incf effect-claims (plist-get entry :effect-claims))
|
||||
(cl-incf effect-evaluations (plist-get entry :effect-evaluations))
|
||||
(cl-incf runtime-enqueues (plist-get entry :runtime-enqueues))
|
||||
(cl-incf runtime-dedupes (plist-get entry :runtime-dedupes))
|
||||
(cl-incf runtime-executions (plist-get entry :runtime-executions))
|
||||
(cl-incf stale-route-drops (plist-get entry :stale-route-drops))
|
||||
(cl-incf turns (plist-get entry :turns))
|
||||
(cl-incf faults (plist-get entry :faults))
|
||||
(push entry context-summaries)))
|
||||
(list :projection-id (etaf-scheduler--projection-id projection)
|
||||
:completed-p (null condition)
|
||||
:context-count (length context-summaries)
|
||||
:source-enqueues source-enqueues
|
||||
:source-dedupes source-dedupes
|
||||
:source-deliveries source-deliveries
|
||||
:subscriber-visits subscriber-visits
|
||||
:effect-claims effect-claims
|
||||
:effect-evaluations effect-evaluations
|
||||
:runtime-enqueues runtime-enqueues
|
||||
:runtime-dedupes runtime-dedupes
|
||||
:runtime-executions runtime-executions
|
||||
:stale-route-drops stale-route-drops
|
||||
:turns turns :faults faults
|
||||
:condition (and condition (copy-tree condition))
|
||||
:contexts (nreverse context-summaries))))
|
||||
|
||||
(defun etaf-scheduler-call-with-projection (function)
|
||||
"Call FUNCTION and drain all contexts touched by its reactive writes.
|
||||
Nested calls join the active projection. If FUNCTION signals after changing
|
||||
state, queued notifications still drain before the original condition is
|
||||
re-signaled."
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(if etaf-scheduler--active-projection
|
||||
(funcall function)
|
||||
(let* ((projection
|
||||
(etaf-scheduler--projection-create
|
||||
:id (cl-incf etaf-scheduler--projection-id-counter)
|
||||
:all-context-set (make-hash-table :test #'eq)
|
||||
:context-before (make-hash-table :test #'eq)))
|
||||
result primary-condition drain-condition summary finalizer-errors)
|
||||
(let ((etaf-scheduler--active-projection projection))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(condition-case condition
|
||||
(setq result (funcall function))
|
||||
((error quit) (setq primary-condition condition)))
|
||||
(condition-case condition
|
||||
(etaf-scheduler--drain-projection projection)
|
||||
((error quit) (setq drain-condition condition)))
|
||||
(setq summary
|
||||
(etaf-scheduler--projection-summary
|
||||
projection drain-condition)))
|
||||
(setq finalizer-errors
|
||||
(etaf-scheduler--finish-projection projection))
|
||||
(when finalizer-errors
|
||||
(setq summary
|
||||
(plist-put summary :completed-p nil)
|
||||
summary
|
||||
(plist-put summary :finalizer-errors
|
||||
(copy-tree finalizer-errors))))
|
||||
(etaf-scheduler--notify-projection-complete
|
||||
projection summary)))
|
||||
(cond
|
||||
(primary-condition
|
||||
(signal (car primary-condition) (cdr primary-condition)))
|
||||
(drain-condition
|
||||
(signal (car drain-condition) (cdr drain-condition)))
|
||||
(t result)))))
|
||||
|
||||
(defun etaf-scheduler-context-idle-p (context)
|
||||
"Return non-nil when CONTEXT has no queued or running dispatcher work."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(and (null (etaf-scheduler-context-source-queue context))
|
||||
(null (etaf-scheduler-context-deferred-source-queue context))
|
||||
(null (etaf-scheduler-context-runtime-queue context))
|
||||
(zerop (hash-table-count
|
||||
(etaf-scheduler-context-source-set context)))
|
||||
(zerop (hash-table-count
|
||||
(etaf-scheduler-context-runtime-set context)))
|
||||
(zerop (etaf-scheduler-context-busy-depth context))))
|
||||
|
||||
(defun etaf-scheduler-context-metrics (context)
|
||||
"Return a detached metrics plist for scheduler CONTEXT."
|
||||
(setq context (etaf-scheduler-context-resolve context))
|
||||
(list :context-id (etaf-scheduler-context-id context)
|
||||
:projection-epoch (etaf-scheduler-context-projection-epoch context)
|
||||
:completed-projection-epoch
|
||||
(etaf-scheduler-context-completed-projection-epoch context)
|
||||
:active-turn-id (etaf-scheduler-context-active-turn-id context)
|
||||
:turn-count (etaf-scheduler-context-turn-count context)
|
||||
:source-enqueues
|
||||
(etaf-scheduler-context-source-enqueue-count context)
|
||||
:source-dedupes
|
||||
(etaf-scheduler-context-source-dedupe-count context)
|
||||
:source-deliveries
|
||||
(etaf-scheduler-context-source-delivery-count context)
|
||||
:subscriber-visits
|
||||
(etaf-scheduler-context-subscriber-visit-count context)
|
||||
:effect-claims
|
||||
(etaf-scheduler-context-effect-claim-count context)
|
||||
:effect-evaluations
|
||||
(etaf-scheduler-context-effect-evaluation-count context)
|
||||
:runtime-enqueues
|
||||
(etaf-scheduler-context-runtime-enqueue-count context)
|
||||
:runtime-dedupes
|
||||
(etaf-scheduler-context-runtime-dedupe-count context)
|
||||
:runtime-executions
|
||||
(etaf-scheduler-context-runtime-execution-count context)
|
||||
:stale-route-drops
|
||||
(etaf-scheduler-context-stale-route-drop-count context)
|
||||
:fault-count
|
||||
(etaf-scheduler-context-projection-fault-count context)
|
||||
:fault-state
|
||||
(copy-tree (etaf-scheduler-context-fault-state context))))
|
||||
|
||||
(provide 'etaf-scheduler)
|
||||
|
||||
;;; etaf-scheduler.el ends here
|
||||
719
etaf-view.el
719
etaf-view.el
@ -12,7 +12,6 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ebox-style)
|
||||
|
||||
(define-error 'etaf-view-error "Invalid ETAF View")
|
||||
(define-error 'etaf-view-syntax-error "Invalid ETAF View syntax"
|
||||
@ -30,8 +29,7 @@
|
||||
|
||||
(cl-defstruct (etaf--expr
|
||||
(:constructor etaf--expr-create))
|
||||
"Internal executable interpolation or compiler-owned structural program."
|
||||
(kind 'interpolation)
|
||||
"Internal executable child expression."
|
||||
token
|
||||
thunk
|
||||
range-snapshot
|
||||
@ -52,7 +50,6 @@
|
||||
"Internal Component invocation retained until rendering."
|
||||
spec
|
||||
props
|
||||
attrs
|
||||
slots)
|
||||
|
||||
(cl-defstruct (etaf--slot-input
|
||||
@ -68,8 +65,15 @@
|
||||
token
|
||||
fallback)
|
||||
|
||||
(cl-defstruct (etaf--raw-ebox
|
||||
(:constructor etaf--raw-ebox-create))
|
||||
"Explicit escape carrying an already-built public Ebox node."
|
||||
token
|
||||
thunk
|
||||
key-thunk)
|
||||
|
||||
(defconst etaf--host-names
|
||||
'(text box fragment row column flex grid)
|
||||
'(text fragment container row column stack flex grid spacer)
|
||||
"Minimal unstyled Hosts implemented by ETAF core.
|
||||
|
||||
Product Components such as Button belong to `etaf-ui'; they are not added to
|
||||
@ -78,34 +82,6 @@ this list merely to make a demo convenient.")
|
||||
(defconst etaf--host-marker 'etaf--host
|
||||
"Value stored in the View registry for a built-in Host.")
|
||||
|
||||
(defconst etaf--directive-properties '(:if :else-if :else :for)
|
||||
"Compiler-owned DSL properties rejected by ordinary node construction.")
|
||||
|
||||
(defconst etaf--semantic-props
|
||||
'(:class :id :role :disabled :tab-index :ref :use)
|
||||
"ETAF Host metadata outside the Ebox style schema.")
|
||||
|
||||
(defun etaf--aria-property-p (property)
|
||||
"Return non-nil when PROPERTY is in the ETAF aria namespace."
|
||||
(and (keywordp property)
|
||||
(string-prefix-p ":aria-" (symbol-name property))))
|
||||
|
||||
(defun etaf--event-property-p (property)
|
||||
"Return non-nil when PROPERTY is an ETAF event callback property."
|
||||
(and (keywordp property)
|
||||
(string-prefix-p ":on-" (symbol-name property))))
|
||||
|
||||
(defun etaf--semantic-property-p (property)
|
||||
"Return non-nil when PROPERTY belongs to ETAF Runtime metadata."
|
||||
(or (memq property etaf--semantic-props)
|
||||
(etaf--aria-property-p property)
|
||||
(etaf--event-property-p property)))
|
||||
|
||||
(defun etaf--host-attribute-p (property)
|
||||
"Return non-nil when PROPERTY belongs to the shared Host attribute domain."
|
||||
(or (ebox-style-schema-id property)
|
||||
(etaf--semantic-property-p property)))
|
||||
|
||||
(defconst etaf--ordinary-elisp-heads
|
||||
'(and or not if when unless cond case pcase
|
||||
let let* letrec letrec* prog prog1 prog2 progn
|
||||
@ -136,9 +112,6 @@ disposing the old Runtime.")
|
||||
(defvar etaf--current-component-instance nil
|
||||
"Dynamic Component instance currently being evaluated.")
|
||||
|
||||
(defvar etaf--compiling-component-props nil
|
||||
"Component prop names visible to the current DSL macro expansion.")
|
||||
|
||||
(defun etaf--syntax-error (format-string &rest arguments)
|
||||
"Signal a View syntax error formatted from FORMAT-STRING and ARGUMENTS."
|
||||
(signal 'etaf-view-syntax-error
|
||||
@ -153,8 +126,25 @@ disposing the old Runtime.")
|
||||
"Return the property keyword corresponding to symbol NAME."
|
||||
(intern (concat ":" (symbol-name name))))
|
||||
|
||||
(defun etaf--component-alias (name)
|
||||
"Return the public View alias for canonical Component NAME, or nil.
|
||||
|
||||
Canonical names may carry the `etaf-' package prefix. The prefix is omitted
|
||||
in View syntax unless doing so would collide with an Elisp function, special
|
||||
form, or core Host. A collision receives a semantic `-view' alias."
|
||||
(when (and (symbolp name)
|
||||
(string-prefix-p "etaf-" (symbol-name name)))
|
||||
(let* ((suffix (substring (symbol-name name) (length "etaf-")))
|
||||
(candidate (intern suffix)))
|
||||
(cond
|
||||
((or (memq candidate etaf--host-names)
|
||||
(special-form-p candidate)
|
||||
(fboundp candidate))
|
||||
(intern (concat suffix "-view")))
|
||||
(t candidate)))))
|
||||
|
||||
(defun etaf--register-component (name spec)
|
||||
"Register Component SPEC under exact registry NAME."
|
||||
"Register Component SPEC under canonical NAME and its public alias."
|
||||
(unless (and (symbolp name) (etaf--component-spec-p spec))
|
||||
(signal 'wrong-type-argument (list 'etaf--component-spec-p spec)))
|
||||
(let ((existing (gethash name etaf--view-registry)))
|
||||
@ -167,14 +157,34 @@ disposing the old Runtime.")
|
||||
(etaf--component-error
|
||||
"Component %S is already registered" name)))
|
||||
(puthash name spec etaf--view-registry)
|
||||
(when-let* ((alias (etaf--component-alias name)))
|
||||
(let ((existing (gethash alias etaf--view-registry)))
|
||||
(when (and existing (not (eq existing spec))
|
||||
(not etaf--allow-component-redefinition))
|
||||
(etaf--component-error
|
||||
"Component alias %S is already registered" alias)))
|
||||
(puthash alias spec etaf--view-registry))
|
||||
(when (fboundp 'etaf-compiler-note-registry-change)
|
||||
(etaf-compiler-note-registry-change))
|
||||
spec)
|
||||
|
||||
(defun etaf--register-core-hosts ()
|
||||
"Register the exact core Host names."
|
||||
"Register the core Host names and explicit prefixed spellings."
|
||||
(dolist (name etaf--host-names)
|
||||
(puthash name etaf--host-marker etaf--view-registry)))
|
||||
(puthash name etaf--host-marker etaf--view-registry)
|
||||
(puthash (intern (concat "etaf-" (symbol-name name)))
|
||||
etaf--host-marker
|
||||
etaf--view-registry)))
|
||||
|
||||
(defun etaf--canonical-host-name (name)
|
||||
"Return the unprefixed renderer name for Host NAME."
|
||||
(if (and (symbolp name)
|
||||
(string-prefix-p "etaf-" (symbol-name name)))
|
||||
(let ((short-name (intern (substring (symbol-name name) 5))))
|
||||
(if (memq short-name etaf--host-names)
|
||||
short-name
|
||||
name))
|
||||
name))
|
||||
|
||||
(etaf--register-core-hosts)
|
||||
|
||||
@ -214,191 +224,6 @@ disposing the old Runtime.")
|
||||
(push (etaf--resolve-property-value (pop tail)) copy))
|
||||
(nreverse copy)))
|
||||
|
||||
(defun etaf--property-domain-key (property)
|
||||
"Return PROPERTY's canonical Host-domain key."
|
||||
(or (ebox-style-canonical-name property) property))
|
||||
|
||||
(defun etaf--plist-set (props key value)
|
||||
"Return PROPS with KEY set to VALUE while preserving source order."
|
||||
(if (plist-member props key)
|
||||
(let ((copy (copy-sequence props)))
|
||||
(plist-put copy key value)
|
||||
copy)
|
||||
(append props (list key value))))
|
||||
|
||||
(defun etaf--plist-remove-domain (props property)
|
||||
"Return PROPS without any alias in PROPERTY's canonical domain."
|
||||
(let ((domain (etaf--property-domain-key property)))
|
||||
(cl-loop for (key value) on props by #'cddr
|
||||
unless (eq (etaf--property-domain-key key) domain)
|
||||
append (list key value))))
|
||||
|
||||
(defun etaf--class-tokens (value)
|
||||
"Return normalized class tokens from resolved VALUE."
|
||||
(cond
|
||||
((null value) nil)
|
||||
((stringp value) (split-string value "[[:space:]]+" t))
|
||||
((symbolp value) (list (symbol-name value)))
|
||||
((proper-list-p value)
|
||||
(cl-mapcan #'etaf--class-tokens value))
|
||||
(t
|
||||
(etaf--component-error "Invalid class value: %S" value))))
|
||||
|
||||
(defun etaf--merge-class-values (root-value caller-value)
|
||||
"Return stable union of ROOT-VALUE and CALLER-VALUE class tokens."
|
||||
(let (seen result)
|
||||
(dolist (token (append (etaf--class-tokens root-value)
|
||||
(etaf--class-tokens caller-value)))
|
||||
(unless (member token seen)
|
||||
(push token seen)
|
||||
(push token result)))
|
||||
(nreverse result)))
|
||||
|
||||
(defun etaf--merge-class-input (root-value caller-value)
|
||||
"Return a class value merging possibly lazy ROOT-VALUE and CALLER-VALUE."
|
||||
(etaf--merge-class-values
|
||||
(etaf--resolve-property-value root-value)
|
||||
(etaf--resolve-property-value caller-value)))
|
||||
|
||||
(defun etaf--compose-event-callbacks (primary secondary)
|
||||
"Compose PRIMARY then SECONDARY, preserving the primary return value.
|
||||
An error stops the chain. This shared value operation lives with View
|
||||
composition so pure render and Runtime Behavior use the same contract."
|
||||
(dolist (callback (list primary secondary))
|
||||
(unless (or (null callback) (functionp callback))
|
||||
(etaf--component-error "Event callback must be a function or nil: %S"
|
||||
callback)))
|
||||
(cond
|
||||
((null primary) secondary)
|
||||
((null secondary) primary)
|
||||
(t
|
||||
(lambda (&rest arguments)
|
||||
(prog1 (apply primary arguments)
|
||||
(apply secondary arguments))))))
|
||||
|
||||
(defun etaf--owned-semantic-property-p (property)
|
||||
"Return non-nil when fallthrough PROPERTY must preserve root semantics."
|
||||
(or (eq property :role)
|
||||
(and (etaf--aria-property-p property)
|
||||
(not (memq property '(:aria-label :aria-description))))))
|
||||
|
||||
(defun etaf--merge-use-input (root-value caller-value)
|
||||
"Concatenate possibly lazy ROOT-VALUE and CALLER-VALUE Behavior sources.
|
||||
Runtime validates all names before installing any resources."
|
||||
(let ((root (etaf--resolve-property-value root-value))
|
||||
(caller (etaf--resolve-property-value caller-value)))
|
||||
(append (if (proper-list-p root) root (list root))
|
||||
(if (proper-list-p caller) caller (list caller)))))
|
||||
|
||||
(defun etaf--merge-host-attrs (props attrs &optional tag component-name)
|
||||
"Merge caller ATTRS into root Host PROPS for TAG.
|
||||
Non-nil visual attributes override defaults; class and Behavior sources merge.
|
||||
Callbacks append, disabled combines with OR, and owned semantic conflicts
|
||||
are rejected. COMPONENT-NAME labels diagnostics."
|
||||
(let ((result (copy-sequence props))
|
||||
(tail attrs))
|
||||
(while tail
|
||||
(let* ((key (pop tail))
|
||||
(value (pop tail))
|
||||
(style-p (not (null (ebox-style-schema-id key)))))
|
||||
(when (and tag style-p
|
||||
(not (ebox-style-property-accepted-p tag key)))
|
||||
(etaf--component-error
|
||||
"Component %S root Host %S rejects attribute %S"
|
||||
component-name tag key))
|
||||
(cond
|
||||
((eq key :class)
|
||||
(setq result
|
||||
(etaf--plist-set
|
||||
result :class
|
||||
(etaf--merge-class-input (plist-get result :class) value))))
|
||||
((etaf--event-property-p key)
|
||||
(setq result
|
||||
(etaf--plist-set
|
||||
result key
|
||||
(etaf--compose-event-callbacks
|
||||
(etaf--resolve-property-value (plist-get result key))
|
||||
(etaf--resolve-property-value value)))))
|
||||
((eq key :use)
|
||||
(setq result
|
||||
(etaf--plist-set
|
||||
result key (etaf--merge-use-input (plist-get result key) value))))
|
||||
((eq key :disabled)
|
||||
(let ((inner (etaf--resolve-property-value (plist-get result key)))
|
||||
(outer (etaf--resolve-property-value value)))
|
||||
(unless (and (memq inner '(nil t)) (memq outer '(nil t)))
|
||||
(etaf--component-error "Component %S :disabled must be boolean"
|
||||
component-name))
|
||||
(setq result (etaf--plist-set result key (or inner outer)))))
|
||||
(style-p
|
||||
(when (etaf--resolve-property-value value)
|
||||
(setq result
|
||||
(append (etaf--plist-remove-domain result key)
|
||||
(list key value)))))
|
||||
((and (etaf--owned-semantic-property-p key)
|
||||
(plist-member result key)
|
||||
(not (equal (etaf--resolve-property-value (plist-get result key))
|
||||
(etaf--resolve-property-value value))))
|
||||
(etaf--component-error
|
||||
"Component %S root Host %S owns %S; conflicting fallthrough value %S"
|
||||
component-name tag key value))
|
||||
((plist-member result key)
|
||||
(setq result (etaf--plist-set result key value)))
|
||||
(t
|
||||
(setq result (append result (list key value)))))))
|
||||
result))
|
||||
|
||||
(defun etaf--forward-component-attrs (call attrs component-name)
|
||||
"Return copied root Component CALL receiving caller ATTRS.
|
||||
COMPONENT-NAME identifies the forwarding owner for diagnostics."
|
||||
(let* ((copy (copy-sequence call))
|
||||
(spec (etaf--component-call-spec call))
|
||||
(declared (mapcar #'etaf--component-prop-key
|
||||
(etaf--component-spec-props spec)))
|
||||
(props (copy-sequence (etaf--component-call-props call)))
|
||||
(forwarded (copy-sequence (etaf--component-call-attrs call)))
|
||||
(tail attrs))
|
||||
(while tail
|
||||
(let ((key (pop tail))
|
||||
(value (pop tail)))
|
||||
(if (memq key declared)
|
||||
;; Consuming a declared prop must retain the inner declaration
|
||||
;; and the outer subscription, and must not forward either twice.
|
||||
(setq props
|
||||
(etaf--merge-host-attrs props (list key value)
|
||||
nil component-name))
|
||||
(setq forwarded
|
||||
(etaf--merge-host-attrs
|
||||
forwarded (list key value) nil component-name)))))
|
||||
(setf (etaf--component-call-props copy) props
|
||||
(etaf--component-call-attrs copy) forwarded)
|
||||
copy))
|
||||
|
||||
(defun etaf--apply-component-attrs (value attrs component-name)
|
||||
"Apply resolved fallthrough ATTRS to COMPONENT-NAME root VALUE."
|
||||
(if (null attrs)
|
||||
value
|
||||
(cond
|
||||
((stringp value)
|
||||
(etaf--view-node-create
|
||||
:name 'text :props (copy-sequence attrs) :children (list value)))
|
||||
((etaf--view-node-p value)
|
||||
(when (eq (etaf--view-node-name value) 'fragment)
|
||||
(etaf--component-error
|
||||
"Component %S has multiple roots; Host attrs have no target"
|
||||
component-name))
|
||||
(let ((copy (copy-sequence value)))
|
||||
(setf (etaf--view-node-props copy)
|
||||
(etaf--merge-host-attrs
|
||||
(etaf--view-node-props value) attrs
|
||||
(etaf--view-node-name value) component-name))
|
||||
copy))
|
||||
((etaf--component-call-p value)
|
||||
(etaf--forward-component-attrs value attrs component-name))
|
||||
(t
|
||||
(etaf--component-error
|
||||
"Component %S cannot apply Host attrs to %S" component-name value)))))
|
||||
|
||||
(defun etaf--compile-property-value (form)
|
||||
"Compile property FORM as a constant or a render-time thunk."
|
||||
(if (or (null form) (numberp form) (stringp form) (characterp form)
|
||||
@ -419,11 +244,12 @@ COMPONENT-NAME identifies the forwarding owner for diagnostics."
|
||||
compiled))
|
||||
|
||||
(defun etaf--validate-key (key)
|
||||
"Validate identity KEY and return its immutable boundary value."
|
||||
(unless (and key (or (symbolp key) (stringp key) (integerp key)))
|
||||
"Validate a Host identity KEY and return it."
|
||||
(unless (or (null key) (symbolp key) (stringp key)
|
||||
(integerp key) (floatp key))
|
||||
(etaf--component-error
|
||||
"View keys must be non-nil symbols, integers, or strings: %S" key))
|
||||
(if (stringp key) (copy-sequence key) key))
|
||||
"View keys must be immutable scalar values: %S" key))
|
||||
key)
|
||||
|
||||
(defun etaf--parse-attributes-and-children (items)
|
||||
"Split structural ITEMS into `(PROPS . CHILDREN)'.
|
||||
@ -454,10 +280,18 @@ the generated code."
|
||||
(cons (nreverse props) (nreverse children))))
|
||||
|
||||
(defun etaf--parse-expr-form (items)
|
||||
"Return the sole ordinary Elisp form from interpolation ITEMS."
|
||||
(unless (= (length items) 1)
|
||||
(etaf--syntax-error "Expr accepts exactly one form: (expr FORM)"))
|
||||
(car items))
|
||||
"Return the value form from an `expr' child with ITEMS.
|
||||
|
||||
`expr' intentionally has one property, `:value', and no children."
|
||||
(let ((parts (etaf--parse-attributes-and-children items)))
|
||||
(when (cdr parts)
|
||||
(etaf--syntax-error "Expr accepts :value and no children"))
|
||||
(let ((props (car parts)))
|
||||
(unless (and (= (length props) 2)
|
||||
(eq (car props) :value))
|
||||
(etaf--syntax-error
|
||||
"Expr accepts exactly one attribute: :value"))
|
||||
(cadr props))))
|
||||
|
||||
(defun etaf--constant-slot-name (form)
|
||||
"Return the static slot symbol represented by FORM, or signal an error."
|
||||
@ -516,231 +350,9 @@ belong to the anonymous `default' slot."
|
||||
"Compile an `expr' form with ITEMS into an executable View value."
|
||||
(let ((token (gensym "etaf-expr-site-")))
|
||||
`(etaf--expr-create
|
||||
:kind 'interpolation
|
||||
:token ',token
|
||||
:thunk (lambda () ,(etaf--parse-expr-form items)))))
|
||||
|
||||
(defun etaf--structural-program-p (value)
|
||||
"Return non-nil when VALUE is a compiler-owned structural program."
|
||||
(and (etaf--expr-p value)
|
||||
(memq (etaf--expr-kind value) '(branch keyed-list))))
|
||||
|
||||
(defun etaf--keyed-program-snapshot (program)
|
||||
"Evaluate and validate one compiler-owned keyed-list PROGRAM snapshot."
|
||||
(unless (and (etaf--expr-p program)
|
||||
(eq (etaf--expr-kind program) 'keyed-list)
|
||||
(functionp (etaf--expr-range-snapshot program))
|
||||
(functionp (etaf--expr-range-item program)))
|
||||
(etaf--component-error "Invalid keyed-list program: %S" program))
|
||||
(let* ((snapshot (funcall (etaf--expr-range-snapshot program)))
|
||||
(items (and (proper-list-p snapshot) (plist-get snapshot :items)))
|
||||
(keys (and (proper-list-p snapshot) (plist-get snapshot :keys))))
|
||||
(unless (and (proper-list-p items) (proper-list-p keys)
|
||||
(= (length items) (length keys)))
|
||||
(etaf--component-error "Invalid keyed-list snapshot: %S" snapshot))
|
||||
(let ((seen (make-hash-table :test #'equal))
|
||||
validated)
|
||||
(dolist (key keys)
|
||||
(setq key (etaf--validate-key key))
|
||||
(when (gethash key seen)
|
||||
(etaf--component-error "Duplicate keyed-list key: %S" key))
|
||||
(puthash key t seen)
|
||||
(push key validated))
|
||||
(let ((copy (copy-sequence snapshot)))
|
||||
(plist-put copy :items (copy-sequence items))
|
||||
(plist-put copy :keys (nreverse validated))
|
||||
copy))))
|
||||
|
||||
(defun etaf--keyed-program-outputs (program snapshot)
|
||||
"Return PROGRAM outputs for already validated keyed SNAPSHOT."
|
||||
(let ((renderer (etaf--expr-range-item program))
|
||||
(context (plist-get snapshot :context)))
|
||||
(mapcar (lambda (item) (funcall renderer item context))
|
||||
(plist-get snapshot :items))))
|
||||
|
||||
(defun etaf--view-form-parts (form)
|
||||
"Return parsed `(TAG PROPS CHILDREN)' for directive-capable FORM."
|
||||
(unless (and (consp form) (symbolp (car form))
|
||||
(not (memq (car form) '(expr slot))))
|
||||
(etaf--syntax-error "Directive requires a View node: %S" form))
|
||||
(let ((parts (etaf--parse-attributes-and-children (cdr form))))
|
||||
(list (car form) (car parts) (cdr parts))))
|
||||
|
||||
(defun etaf--view-directive-properties (props)
|
||||
"Return directive entries present in raw PROPS."
|
||||
(cl-loop for (key value) on props by #'cddr
|
||||
when (memq key etaf--directive-properties)
|
||||
append (list key value)))
|
||||
|
||||
(defun etaf--validate-directive-set (directives)
|
||||
"Validate one node's raw DIRECTIVES and return them."
|
||||
(let ((branch-count
|
||||
(cl-count-if (lambda (key) (plist-member directives key))
|
||||
'(:if :else-if :else))))
|
||||
(when (> branch-count 1)
|
||||
(etaf--syntax-error "A View node accepts one branch directive"))
|
||||
(when (and (> branch-count 0) (plist-member directives :for))
|
||||
(etaf--syntax-error "Branch directives cannot share a node with :for"))
|
||||
(when (and (plist-member directives :else)
|
||||
(not (eq (plist-get directives :else) t)))
|
||||
(etaf--syntax-error ":else requires literal t")))
|
||||
directives)
|
||||
|
||||
(defun etaf--view-without-directives (form)
|
||||
"Return raw View FORM without compiler directive properties."
|
||||
(pcase-let ((`(,tag ,props ,children) (etaf--view-form-parts form)))
|
||||
(cons tag
|
||||
(append
|
||||
(cl-loop for (key value) on props by #'cddr
|
||||
unless (memq key etaf--directive-properties)
|
||||
append (list key value))
|
||||
children))))
|
||||
|
||||
(defun etaf--compile-branch-children (first rest slot-mode)
|
||||
"Compile branch FIRST and adjacent arms from REST under SLOT-MODE.
|
||||
Return `(COMPILED . REMAINING)' for one compiler-owned Range program."
|
||||
(let ((arms nil)
|
||||
(remaining rest)
|
||||
(saw-else nil)
|
||||
done)
|
||||
(cl-labels
|
||||
((add-arm
|
||||
(form kind condition)
|
||||
(let ((parts (etaf--view-form-parts form)))
|
||||
(etaf--validate-directive-set
|
||||
(etaf--view-directive-properties (nth 1 parts)))
|
||||
(push (list kind condition
|
||||
(etaf--compile-view-form
|
||||
(etaf--view-without-directives form) slot-mode))
|
||||
arms))))
|
||||
(let* ((directives
|
||||
(etaf--view-directive-properties
|
||||
(nth 1 (etaf--view-form-parts first)))))
|
||||
(add-arm first :if (plist-get directives :if)))
|
||||
(while (and remaining (not done))
|
||||
(let* ((candidate (car remaining))
|
||||
(parts (and (consp candidate) (symbolp (car candidate))
|
||||
(not (memq (car candidate) '(expr slot)))
|
||||
(etaf--view-form-parts candidate)))
|
||||
(directives (and parts
|
||||
(etaf--view-directive-properties
|
||||
(nth 1 parts)))))
|
||||
(cond
|
||||
((and directives (plist-member directives :else-if))
|
||||
(when saw-else
|
||||
(etaf--syntax-error ":else-if cannot follow :else"))
|
||||
(add-arm candidate :else-if (plist-get directives :else-if))
|
||||
(setq remaining (cdr remaining)))
|
||||
((and directives (plist-member directives :else))
|
||||
(when saw-else
|
||||
(etaf--syntax-error "A branch chain accepts one :else"))
|
||||
(setq saw-else t)
|
||||
(add-arm candidate :else (plist-get directives :else))
|
||||
(setq remaining (cdr remaining)))
|
||||
(t (setq done t))))))
|
||||
(let ((token (gensym "etaf-branch-site-"))
|
||||
(ordered (nreverse arms)))
|
||||
(cons
|
||||
`(etaf--expr-create
|
||||
:kind 'branch
|
||||
:token ',token
|
||||
:thunk
|
||||
(lambda ()
|
||||
(cond
|
||||
,@(mapcar
|
||||
(lambda (arm)
|
||||
(pcase (car arm)
|
||||
(:else `(t ,(nth 2 arm)))
|
||||
(_ `(,(nth 1 arm) ,(nth 2 arm)))))
|
||||
ordered))))
|
||||
remaining))))
|
||||
|
||||
(defun etaf--compile-for-child (form slot-mode)
|
||||
"Compile one keyed `:for' View FORM for SLOT-MODE."
|
||||
(pcase-let* ((`(,_tag ,props ,_children) (etaf--view-form-parts form))
|
||||
(directives
|
||||
(etaf--validate-directive-set
|
||||
(etaf--view-directive-properties props)))
|
||||
(for-form (plist-get directives :for)))
|
||||
(when (cl-some (lambda (key) (plist-member directives key))
|
||||
'(:if :else-if :else))
|
||||
(etaf--syntax-error "Branch directives cannot share a node with :for"))
|
||||
(unless (and (proper-list-p for-form) (= (length for-form) 2)
|
||||
(symbolp (car for-form))
|
||||
(not (keywordp (car for-form)))
|
||||
(not (memq (car for-form) '(nil t))))
|
||||
(etaf--syntax-error ":for must be (ITEM ITEMS): %S" for-form))
|
||||
(when (memq (car for-form) etaf--compiling-component-props)
|
||||
(etaf--syntax-error ":for item %S conflicts with a Component prop"
|
||||
(car for-form)))
|
||||
(unless (plist-member props :key)
|
||||
(etaf--syntax-error ":for requires an explicit :key"))
|
||||
(let* ((item (car for-form))
|
||||
(items-form (cadr for-form))
|
||||
(key-form (plist-get props :key))
|
||||
(compiled (etaf--compile-view-form
|
||||
(etaf--view-without-directives form) slot-mode))
|
||||
(token (gensym "etaf-keyed-list-site-"))
|
||||
(snapshot (gensym "etaf-keyed-snapshot-"))
|
||||
(item-renderer (gensym "etaf-keyed-item-")))
|
||||
`(let ((,snapshot
|
||||
(lambda ()
|
||||
(let ((items ,items-form))
|
||||
(unless (proper-list-p items)
|
||||
(etaf--component-error
|
||||
":for collection must be a proper list: %S" items))
|
||||
(list :items (copy-sequence items)
|
||||
:keys
|
||||
(mapcar
|
||||
(lambda (,item) (etaf--validate-key ,key-form))
|
||||
items)
|
||||
:context nil))))
|
||||
(,item-renderer
|
||||
(lambda (,item _etaf-keyed-context) ,compiled)))
|
||||
(etaf--expr-create
|
||||
:kind 'keyed-list
|
||||
:token ',token
|
||||
:thunk
|
||||
(lambda ()
|
||||
(let* ((program (funcall ,snapshot))
|
||||
(items (plist-get program :items)))
|
||||
(mapcar (lambda (,item)
|
||||
(funcall ,item-renderer ,item nil))
|
||||
items)))
|
||||
:range-snapshot ,snapshot
|
||||
:range-item ,item-renderer)))))
|
||||
|
||||
(defun etaf--compile-child-sequence (children slot-mode)
|
||||
"Compile sibling CHILDREN with branch and keyed-list SLOT-MODE structure."
|
||||
(let (compiled)
|
||||
(while children
|
||||
(let* ((form (car children))
|
||||
(parts (and (consp form) (symbolp (car form))
|
||||
(not (memq (car form) '(expr slot)))
|
||||
(etaf--view-form-parts form)))
|
||||
(directives
|
||||
(and parts
|
||||
(etaf--validate-directive-set
|
||||
(etaf--view-directive-properties (nth 1 parts))))))
|
||||
(cond
|
||||
((and directives (plist-member directives :if))
|
||||
(pcase-let ((`(,value . ,remaining)
|
||||
(etaf--compile-branch-children
|
||||
form (cdr children) slot-mode)))
|
||||
(push value compiled)
|
||||
(setq children remaining)))
|
||||
((and directives (plist-member directives :for))
|
||||
(push (etaf--compile-for-child form slot-mode) compiled)
|
||||
(setq children (cdr children)))
|
||||
((and directives
|
||||
(or (plist-member directives :else-if)
|
||||
(plist-member directives :else)))
|
||||
(etaf--syntax-error "Orphan branch arm: %S" form))
|
||||
(t
|
||||
(push (etaf--compile-child-form form slot-mode) compiled)
|
||||
(setq children (cdr children))))))
|
||||
(nreverse compiled)))
|
||||
|
||||
(defun etaf--compile-child-form (form &optional slot-mode)
|
||||
"Compile structural child FORM into code returning a View value.
|
||||
|
||||
@ -752,11 +364,12 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
|
||||
(etaf--compile-expr-form (cdr form)))
|
||||
((and (consp form) (eq (car form) 'slot))
|
||||
(etaf--compile-slot-form (cdr form) slot-mode))
|
||||
((and (consp form) (eq (car form) 'raw-ebox))
|
||||
(etaf--compile-view-form form slot-mode))
|
||||
((and (consp form) (symbolp (car form)))
|
||||
(when (and (null (gethash (car form) etaf--view-registry))
|
||||
(etaf--ordinary-expression-head-p (car form)))
|
||||
(when (etaf--ordinary-expression-head-p (car form))
|
||||
(etaf--syntax-error
|
||||
"Elisp expression %S must be inside (expr FORM)" (car form)))
|
||||
"Elisp expression %S must be inside (expr :value ...)" (car form)))
|
||||
(etaf--compile-view-form form slot-mode))
|
||||
((consp form)
|
||||
(etaf--syntax-error "Invalid View child form: %S" form))
|
||||
@ -771,7 +384,7 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
|
||||
SLOT-MODE distinguishes Component-owned projections from call-site inputs."
|
||||
(cond
|
||||
((null form) nil)
|
||||
((stringp form) `(etaf--text-view-from-string ,form))
|
||||
((stringp form) `(quote ,form))
|
||||
((not (and (consp form) (symbolp (car form))))
|
||||
(etaf--syntax-error "View form must start with a symbol: %S" form))
|
||||
((eq (car form) 'expr)
|
||||
@ -781,6 +394,24 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
|
||||
;; the Component definition macro, so the public macro defaults to
|
||||
;; projection mode. An unowned projection simply uses its fallback.
|
||||
(etaf--compile-slot-form (cdr form) slot-mode))
|
||||
((eq (car form) 'raw-ebox)
|
||||
(let ((parts (etaf--parse-attributes-and-children (cdr form))))
|
||||
(when (cdr parts)
|
||||
(etaf--syntax-error "Raw-ebox accepts :value, optional :key, and no children"))
|
||||
(let ((props (car parts)))
|
||||
(unless (and (plist-member props :value)
|
||||
(cl-every #'keywordp (cl-loop for (key _value) on props by #'cddr collect key)))
|
||||
(etaf--syntax-error "Raw-ebox requires :value"))
|
||||
(let ((allowed '(:value :key))
|
||||
(token (gensym "etaf-raw-site-")))
|
||||
(dolist (key (cl-loop for (key _value) on props by #'cddr collect key))
|
||||
(unless (memq key allowed)
|
||||
(etaf--syntax-error "Raw-ebox does not accept %S" key)))
|
||||
`(etaf--raw-ebox-create
|
||||
:token ',token
|
||||
:thunk (lambda () ,(plist-get props :value))
|
||||
:key-thunk ,(when (plist-member props :key)
|
||||
`(lambda () ,(plist-get props :key))))))))
|
||||
(t
|
||||
(let* ((parts (etaf--parse-attributes-and-children (cdr form)))
|
||||
(props (car parts))
|
||||
@ -792,8 +423,10 @@ SLOT-MODE distinguishes Component-owned projections from call-site inputs."
|
||||
(gensym "etaf-fragment-site-"))))
|
||||
`(etaf--view-call ',(car form)
|
||||
(list ,@(etaf--compile-property-plist props))
|
||||
(list ,@(etaf--compile-child-sequence
|
||||
children child-slot-mode))
|
||||
(list ,@(mapcar (lambda (child)
|
||||
(etaf--compile-child-form
|
||||
child child-slot-mode))
|
||||
children))
|
||||
,(and token `',token)))))))
|
||||
|
||||
;;;###autoload
|
||||
@ -805,9 +438,8 @@ 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. 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."
|
||||
ordinary Elisp expressions. `expr' is the only computation bridge in the
|
||||
child region and accepts only `:value'."
|
||||
(declare (indent 1) (debug (form)))
|
||||
(if (fboundp 'etaf-compiler-expand-view)
|
||||
(etaf-compiler-expand-view form :projection)
|
||||
@ -819,162 +451,40 @@ Inside a `text' Host, an expression must return one string."
|
||||
name
|
||||
(etaf--keyword-for-name name)))
|
||||
|
||||
(defun etaf--partition-component-input (spec props)
|
||||
"Partition SPEC input PROPS into business props and Host attrs.
|
||||
Return `(BUSINESS ATTRS)'. `:key' remains framework-owned input metadata."
|
||||
(let ((declared (mapcar #'etaf--component-prop-key
|
||||
(etaf--component-spec-props spec)))
|
||||
(tail (etaf--validate-property-plist props))
|
||||
(attr-domains (make-hash-table :test #'eq))
|
||||
business
|
||||
attrs)
|
||||
(defun etaf--validate-component-props (spec props)
|
||||
"Validate Component SPEC against evaluated property PLIST PROPS."
|
||||
(let ((allowed (append '(:key)
|
||||
(mapcar #'etaf--component-prop-key
|
||||
(etaf--component-spec-props spec))))
|
||||
(tail (etaf--validate-property-plist props)))
|
||||
(while tail
|
||||
(let ((key (pop tail))
|
||||
(value (pop tail)))
|
||||
(cond
|
||||
((or (eq key :key) (memq key declared))
|
||||
(setq business (append business (list key value))))
|
||||
((etaf--host-attribute-p key)
|
||||
(let ((domain (etaf--property-domain-key key)))
|
||||
(when (gethash domain attr-domains)
|
||||
(etaf--component-error
|
||||
"Duplicate Component Host attribute domain: %S" key))
|
||||
(puthash domain t attr-domains)
|
||||
(setq attrs (append attrs (list domain value)))))
|
||||
(t
|
||||
(let ((key (pop tail)))
|
||||
(pop tail)
|
||||
(unless (memq key allowed)
|
||||
(etaf--component-error
|
||||
"Unknown prop or Host attribute %S for Component %S"
|
||||
key (etaf--component-spec-name spec))))))
|
||||
(list business attrs)))
|
||||
|
||||
(defun etaf--component-business-props (call)
|
||||
"Return CALL's declared business props without framework `:key'."
|
||||
(cl-loop for (key value) on (etaf--component-call-props call) by #'cddr
|
||||
unless (eq key :key)
|
||||
append (list key value)))
|
||||
|
||||
(defun etaf--typed-view-child-p (value)
|
||||
"Return non-nil when VALUE is one already validated View child."
|
||||
(or (null value)
|
||||
(stringp value)
|
||||
;; Code-mode setup may retain a structural program (for example, a
|
||||
;; direct Range expression) and pass that opaque value to `etaf-node'.
|
||||
;; It is still validated and interpreted only at the renderer boundary;
|
||||
;; arbitrary lists remain rejected here.
|
||||
(etaf--expr-p value)
|
||||
(etaf--view-node-p value)
|
||||
(etaf--component-call-p value)
|
||||
(etaf--slot-projection-p value)))
|
||||
|
||||
(defun etaf--validate-component-render-result (value component-name)
|
||||
"Return typed VALUE or reject COMPONENT-NAME's ambiguous render result."
|
||||
(unless (etaf--typed-view-child-p value)
|
||||
(etaf--component-error
|
||||
"Component %S must render nil, a string, or one typed View; got %S"
|
||||
component-name value))
|
||||
value)
|
||||
|
||||
(defun etaf--validate-code-children (children context)
|
||||
"Return a detached CHILDREN spine after typed validation for CONTEXT."
|
||||
(unless (proper-list-p children)
|
||||
(etaf--component-error "%s children must be a proper list: %S"
|
||||
context children))
|
||||
(dolist (child children)
|
||||
(unless (etaf--typed-view-child-p child)
|
||||
(etaf--component-error
|
||||
"%s child must be nil, string, or typed View: %S" context child)))
|
||||
(copy-sequence children))
|
||||
|
||||
(defun etaf--validate-code-slots (slots)
|
||||
"Return typed named SLOTS as internal slot inputs."
|
||||
(unless (proper-list-p slots)
|
||||
(etaf--component-error "Named slots must be a proper alist: %S" slots))
|
||||
(let (seen result)
|
||||
(dolist (entry slots (nreverse result))
|
||||
(unless (and (consp entry)
|
||||
(symbolp (car entry))
|
||||
(not (keywordp (car entry)))
|
||||
(not (memq (car entry) '(nil t))))
|
||||
(etaf--component-error "Invalid named slot entry: %S" entry))
|
||||
(when (memq (car entry) seen)
|
||||
(etaf--component-error "Duplicate Component slot %S" (car entry)))
|
||||
(push (car entry) seen)
|
||||
(push (etaf--slot-input-create
|
||||
:name (car entry)
|
||||
:children (etaf--validate-code-children
|
||||
(cdr entry) (format "Slot %S" (car entry))))
|
||||
result))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-node (tag props children &optional named-slots)
|
||||
"Construct one typed View node from evaluated ordinary Elisp values.
|
||||
TAG is an exact Host or Component registry symbol. PROPS is a keyword plist,
|
||||
CHILDREN is a list of typed View children, and NAMED-SLOTS is a Component-only
|
||||
alist from stable slot symbols to typed child lists."
|
||||
(unless (symbolp tag)
|
||||
(etaf--component-error "Node tag must be a symbol: %S" tag))
|
||||
(setq props (etaf--validate-property-plist props))
|
||||
(dolist (directive etaf--directive-properties)
|
||||
(when (plist-member props directive)
|
||||
(etaf--component-error
|
||||
"Code node %S rejects DSL directive %S" tag directive)))
|
||||
(when (plist-member props :key)
|
||||
(setq props
|
||||
(plist-put props :key
|
||||
(etaf--validate-key (plist-get props :key)))))
|
||||
(let* ((entry (gethash tag etaf--view-registry))
|
||||
(children (etaf--validate-code-children children
|
||||
(format "Node %S" tag)))
|
||||
(slot-inputs (etaf--validate-code-slots named-slots)))
|
||||
(when (and slot-inputs (eq entry etaf--host-marker))
|
||||
(etaf--component-error "Host %S does not accept named slots" tag))
|
||||
(etaf--view-call tag props (append children slot-inputs))))
|
||||
|
||||
(defun etaf--text-view-from-string (value)
|
||||
"Return one normalized Text View containing string VALUE."
|
||||
(etaf--view-node-create :name 'text :props nil :children (list value)))
|
||||
|
||||
(defun etaf--normalize-structural-child (child)
|
||||
"Normalize static structural CHILD without evaluating expressions."
|
||||
(cond
|
||||
((stringp child) (etaf--text-view-from-string child))
|
||||
((etaf--slot-input-p child)
|
||||
(let ((copy (copy-sequence child)))
|
||||
(setf (etaf--slot-input-children copy)
|
||||
(mapcar #'etaf--normalize-structural-child
|
||||
(etaf--slot-input-children child)))
|
||||
copy))
|
||||
(t child)))
|
||||
"Unknown prop %S for Component %S"
|
||||
key (etaf--component-spec-name spec)))))
|
||||
props))
|
||||
|
||||
(defun etaf--view-call (name props children &optional token)
|
||||
"Construct NAME from PROPS and CHILDREN, retaining optional site TOKEN."
|
||||
(unless (symbolp name)
|
||||
(etaf--syntax-error "View name must be a symbol: %S" name))
|
||||
(setq props (etaf--validate-property-plist props))
|
||||
(let* ((entry (gethash name etaf--view-registry))
|
||||
(host-name (and (eq entry etaf--host-marker)
|
||||
name))
|
||||
(children
|
||||
(if (eq host-name 'text)
|
||||
children
|
||||
(mapcar #'etaf--normalize-structural-child children))))
|
||||
(let ((entry (gethash name etaf--view-registry)))
|
||||
(cond
|
||||
((eq entry etaf--host-marker)
|
||||
(when (and (eq host-name 'text) (/= (length children) 1))
|
||||
(etaf--syntax-error
|
||||
"Text requires exactly one string or expr payload"))
|
||||
(when (plist-member props :key)
|
||||
(etaf--validate-key
|
||||
(etaf--resolve-property-value (plist-get props :key))))
|
||||
(etaf--view-node-create
|
||||
:name host-name
|
||||
(etaf--view-node-create
|
||||
:name (etaf--canonical-host-name name)
|
||||
:token token
|
||||
:props props
|
||||
:children children))
|
||||
((etaf--component-spec-p entry)
|
||||
(pcase-let* ((`(,business-props ,attrs)
|
||||
(etaf--partition-component-input entry props)))
|
||||
(let (default-children named-slots)
|
||||
(etaf--validate-component-props entry props)
|
||||
(let (default-children named-slots)
|
||||
(dolist (child children)
|
||||
(if (etaf--slot-input-p child)
|
||||
(progn
|
||||
@ -992,11 +502,10 @@ alist from stable slot symbols to typed child lists."
|
||||
"Component default slot has both children and an explicit input"))
|
||||
(etaf--component-call-create
|
||||
:spec entry
|
||||
:props business-props
|
||||
:attrs attrs
|
||||
:props props
|
||||
:slots (if default-children
|
||||
(cons (cons 'default default-children) named-slots)
|
||||
named-slots)))))
|
||||
named-slots))))
|
||||
(t
|
||||
(etaf--component-error "Unknown ETAF Host or Component: %S" name)))))
|
||||
|
||||
|
||||
11
etaf.el
11
etaf.el
@ -3,8 +3,8 @@
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;; Author: ETAF contributors
|
||||
;; Version: 0.2.1
|
||||
;; Package-Requires: ((emacs "29.1") (ebox "3.0.0") (tp "2.0.0"))
|
||||
;; Version: 0.1.0
|
||||
;; Package-Requires: ((emacs "29.1") (ebox "2.0.0"))
|
||||
;; Keywords: ui, tools, convenience
|
||||
;; URL: https://github.com/ginqi7/etaf
|
||||
|
||||
@ -30,22 +30,17 @@
|
||||
(require 'etaf-view)
|
||||
(require 'etaf-compiler)
|
||||
(require 'etaf-component)
|
||||
(require 'etaf-scheduler)
|
||||
(require 'etaf-reactive)
|
||||
(require 'etaf-observer)
|
||||
(require 'etaf-context)
|
||||
(require 'etaf-resource)
|
||||
(require 'etaf-data)
|
||||
(require 'etaf-generation)
|
||||
(require 'etaf-host)
|
||||
(require 'etaf-retirement)
|
||||
(require 'etaf-render-port)
|
||||
(require 'etaf-renderer)
|
||||
(etaf--prefer-local-files)
|
||||
(require 'etaf-runtime)
|
||||
(require 'etaf-behavior)
|
||||
(require 'etaf-actions)
|
||||
(require 'etaf-events)
|
||||
(require 'etaf-performance)
|
||||
|
||||
(unless (fboundp 'ebox-call-with-render-burst)
|
||||
(error "ETAF requires an Ebox build with framework render-burst support"))
|
||||
|
||||
@ -25,25 +25,66 @@
|
||||
('reset 0)
|
||||
(_ (user-error "Unknown counter operation: %S" operation)))))
|
||||
|
||||
(etaf-define-component etaf-counter-example-action
|
||||
(&key count label operation)
|
||||
"Render one semantic counter action."
|
||||
:view
|
||||
(box :class "action" :role 'button :use (list (etaf-focusable))
|
||||
:on-press
|
||||
(let ((cell count) (next-operation operation))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-counter-example-update
|
||||
cell next-operation)))
|
||||
(text (expr label)))
|
||||
:styles
|
||||
(styles
|
||||
("&" :flex-grow 1 :flex-shrink 1 :flex-basis (160)
|
||||
:min-width (140) :padding (1 (12)) :border "#4E7890"
|
||||
:bgcolor "#D9EAF2" :text-align center :font-weight bold)))
|
||||
(defun etaf-counter-example--header (title)
|
||||
"Return the counter header for TITLE."
|
||||
(etaf-view
|
||||
(column :class "hero"
|
||||
(text :class "eyebrow" "BEST PRACTICE / RETAINED STATE")
|
||||
(text :face 'bold (expr :value title))
|
||||
(text :color "#66706A"
|
||||
"State belongs to setup; rendering only reads it."))))
|
||||
|
||||
(defun etaf-counter-example--metrics (count double status)
|
||||
"Return metric cards for COUNT, DOUBLE, and STATUS."
|
||||
(etaf-view
|
||||
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
|
||||
(text :class "metric"
|
||||
(expr :value (format "COUNT %d" (etaf-value count))))
|
||||
(text :class "metric"
|
||||
(expr :value (format "DOUBLE %d" (etaf-value double))))
|
||||
(text :class "metric"
|
||||
(expr :value (format "STATE %s" (etaf-value status)))))))
|
||||
|
||||
(defun etaf-counter-example--action (count label host-ref operation)
|
||||
"Return one COUNT action named LABEL using HOST-REF and OPERATION."
|
||||
(etaf-view
|
||||
(text :class "action" :ref host-ref :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-counter-example-update
|
||||
count operation))
|
||||
(expr :value label))))
|
||||
|
||||
(defun etaf-counter-example--actions (count)
|
||||
"Return the action group for COUNT."
|
||||
(etaf-view
|
||||
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
|
||||
(expr :value
|
||||
(etaf-counter-example--action
|
||||
count "− DECREMENT" 'counter-decrement 'decrement))
|
||||
(expr :value
|
||||
(etaf-counter-example--action
|
||||
count "RESET" 'counter-reset 'reset))
|
||||
(expr :value
|
||||
(etaf-counter-example--action
|
||||
count "+ INCREMENT" 'counter-increment 'increment)))))
|
||||
|
||||
(etaf-define-component etaf-counter-example-card (&key title initial-value)
|
||||
"Render a retained counter named TITLE starting at INITIAL-VALUE."
|
||||
:styles
|
||||
(styles
|
||||
("&" :width (680) :color "#252A2E" :bgcolor "#F8F5EE")
|
||||
(".hero" :width (680) :padding (1 (18)) :border "#8F432F"
|
||||
:bgcolor "#FFFDF8" :text-align center)
|
||||
(".eyebrow" :color "#8F432F" :face bold)
|
||||
(".metric" :flex-grow 1 :flex-shrink 1 :flex-basis (200)
|
||||
:min-width (180) :padding (1 (14)) :border "#6D8A73"
|
||||
:bgcolor "#DCEBDD" :text-align center)
|
||||
(".action" :flex-grow 1 :flex-shrink 1 :flex-basis (160)
|
||||
:min-width (140) :padding (1 (12)) :border "#4E7890"
|
||||
:bgcolor "#D9EAF2" :text-align center :face bold)
|
||||
(".note" :width (680) :padding (1 (16)) :border "#8D887F"
|
||||
:color "#4D5651" :bgcolor "#EEEAE2"))
|
||||
:setup
|
||||
(let* ((count (etaf-ref (or initial-value 0) :name 'counter))
|
||||
(double (etaf-computed
|
||||
@ -53,57 +94,18 @@
|
||||
(lambda ()
|
||||
(if (zerop (etaf-value count)) "READY" "ACTIVE"))
|
||||
:name 'counter-status)))
|
||||
(list :count count :double double :status status))
|
||||
:view
|
||||
(column
|
||||
(box :class "hero"
|
||||
(column
|
||||
(text :class "eyebrow" "BEST PRACTICE / RETAINED STATE")
|
||||
(text :font-weight 'bold (expr title))
|
||||
(text :color "#66706A"
|
||||
"State belongs to setup; rendering only reads it.")))
|
||||
(box :height 1)
|
||||
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
|
||||
(box :class "metric"
|
||||
(text (expr
|
||||
(format "COUNT %d"
|
||||
(etaf-value (plist-get (etaf-state) :count))))))
|
||||
(box :class "metric"
|
||||
(text (expr
|
||||
(format "DOUBLE %d"
|
||||
(etaf-value (plist-get (etaf-state) :double))))))
|
||||
(box :class "metric"
|
||||
(text (expr
|
||||
(format "STATE %s"
|
||||
(etaf-value (plist-get (etaf-state) :status)))))))
|
||||
(box :height 1)
|
||||
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
|
||||
(etaf-counter-example-action
|
||||
:ref 'counter-decrement
|
||||
:count (plist-get (etaf-state) :count)
|
||||
:label "− DECREMENT" :operation 'decrement)
|
||||
(etaf-counter-example-action
|
||||
:ref 'counter-reset
|
||||
:count (plist-get (etaf-state) :count)
|
||||
:label "RESET" :operation 'reset)
|
||||
(etaf-counter-example-action
|
||||
:ref 'counter-increment
|
||||
:count (plist-get (etaf-state) :count)
|
||||
:label "+ INCREMENT" :operation 'increment))
|
||||
(box :height 1)
|
||||
(box :class "note"
|
||||
(text "Public path: Event → Action → Ref → Computed → Runtime commit")))
|
||||
:styles
|
||||
(styles
|
||||
("&" :width (680) :color "#252A2E" :bgcolor "#F8F5EE")
|
||||
(".hero" :width (680) :padding (1 (18)) :border "#8F432F"
|
||||
:bgcolor "#FFFDF8" :text-align center)
|
||||
(".eyebrow" :color "#8F432F" :font-weight bold)
|
||||
(".metric" :flex-grow 1 :flex-shrink 1 :flex-basis (200)
|
||||
:min-width (180) :padding (1 (14)) :border "#6D8A73"
|
||||
:bgcolor "#DCEBDD" :text-align center)
|
||||
(".note" :width (680) :padding (1 (16)) :border "#8D887F"
|
||||
:color "#4D5651" :bgcolor "#EEEAE2")))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(column
|
||||
(expr :value (etaf-counter-example--header title))
|
||||
(spacer :height 1)
|
||||
(expr :value
|
||||
(etaf-counter-example--metrics count double status))
|
||||
(spacer :height 1)
|
||||
(expr :value (etaf-counter-example--actions count))
|
||||
(spacer :height 1)
|
||||
(text :class "note"
|
||||
"Public path: Event → Action → Ref → Computed → Runtime commit"))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-counter-example-view ()
|
||||
|
||||
@ -45,53 +45,106 @@
|
||||
(etaf-data-set-query controller query)
|
||||
(etaf-data-load controller))
|
||||
|
||||
(etaf-define-component etaf-data-example-row (&key controller task)
|
||||
"Render one retained TASK row from CONTROLLER."
|
||||
:view
|
||||
(flex :width '(718) :flex-flow '(row nowrap) :gap '(0 (10))
|
||||
:padding '(1 (12)) :border "#6D8A73"
|
||||
:bgcolor
|
||||
(if (etaf-value
|
||||
(etaf-data-selected-ref controller (plist-get task :id)))
|
||||
"#DCEBDD" "#FFFDF8")
|
||||
:role 'button :use (list (etaf-focusable))
|
||||
:on-press
|
||||
(let ((data-controller controller)
|
||||
(identity (plist-get task :id)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-data-example-toggle
|
||||
data-controller identity)))
|
||||
(box :width '(36) :font-weight 'bold
|
||||
:color
|
||||
(if (etaf-value
|
||||
(etaf-data-selected-ref controller (plist-get task :id)))
|
||||
"#2F6B43" "#8D887F")
|
||||
(text
|
||||
(expr
|
||||
(if (etaf-value
|
||||
(etaf-data-selected-ref controller (plist-get task :id)))
|
||||
"●" "○"))))
|
||||
(box :flex-grow 1 :flex-shrink 1 :flex-basis '(390)
|
||||
:min-width '(280)
|
||||
(text (expr (plist-get task :title))))
|
||||
(box :width '(96) :color "#66706A"
|
||||
(text (expr (plist-get task :owner))))
|
||||
(box :width '(84) :font-weight 'bold :text-align 'right
|
||||
:color (if (eq (plist-get task :status) 'done)
|
||||
"#2F6B43" "#9B4A34")
|
||||
(text (expr (upcase (symbol-name (plist-get task :status))))))))
|
||||
(defun etaf-data-example--row (controller task)
|
||||
"Return one TASK row bound to CONTROLLER."
|
||||
(let* ((identity (plist-get task :id))
|
||||
(selected (etaf-data-selected-p controller identity))
|
||||
(status (plist-get task :status))
|
||||
(host-ref (intern (format "data-task-%d" identity))))
|
||||
(etaf-view
|
||||
(flex :width '(718) :flex-flow '(row nowrap) :gap '(0 (10))
|
||||
:padding '(1 (12)) :border "#6D8A73"
|
||||
:bgcolor (if selected "#DCEBDD" "#FFFDF8")
|
||||
:ref host-ref :role 'button :use (list (etaf-focusable))
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-data-example-toggle
|
||||
controller identity))
|
||||
(text :width '(36) :face 'bold
|
||||
:color (if selected "#2F6B43" "#8D887F")
|
||||
(expr :value (if selected "●" "○")))
|
||||
(text :flex-grow 1 :flex-shrink 1 :flex-basis '(390)
|
||||
:min-width '(280)
|
||||
(expr :value (plist-get task :title)))
|
||||
(text :width '(96) :color "#66706A"
|
||||
(expr :value (plist-get task :owner)))
|
||||
(text :width '(84) :face 'bold :text-align 'right
|
||||
:color (if (eq status 'done) "#2F6B43" "#9B4A34")
|
||||
(expr :value (upcase (symbol-name status))))))))
|
||||
|
||||
(etaf-define-component etaf-data-example-filter
|
||||
(&key controller label query border background)
|
||||
"Render one query filter for CONTROLLER."
|
||||
:view
|
||||
(box :padding '(1 (12)) :border border :bgcolor background
|
||||
:font-weight 'bold :role 'button :use (list (etaf-focusable))
|
||||
:on-press
|
||||
(let ((data-controller controller) (next-query query))
|
||||
(lambda ()
|
||||
(etaf-data-example--filter data-controller next-query)))
|
||||
(text (expr label))))
|
||||
(defun etaf-data-example--header (controller)
|
||||
"Return the summary header for CONTROLLER."
|
||||
(let ((total (etaf-value (etaf-data-total controller)))
|
||||
(selection (etaf-value (etaf-data-selection controller))))
|
||||
(etaf-view
|
||||
(column :width '(720) :padding '(1 (18)) :border "#8F432F"
|
||||
:bgcolor "#FFFDF8" :text-align 'center
|
||||
(text :color "#8F432F" :face 'bold
|
||||
"BEST PRACTICE / DATA OWNERSHIP")
|
||||
(text :face 'bold "Task controller")
|
||||
(text :color "#66706A"
|
||||
(expr :value
|
||||
(format "%d records · %d selected" total
|
||||
(length selection))))))))
|
||||
|
||||
(defun etaf-data-example--filter-control
|
||||
(controller label host-ref query border background)
|
||||
"Return a filter LABEL for CONTROLLER using HOST-REF and QUERY.
|
||||
Use BORDER and BACKGROUND for its semantic color family."
|
||||
(etaf-view
|
||||
(text :padding '(1 (12)) :border border :bgcolor background
|
||||
:face 'bold :ref host-ref :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press (lambda ()
|
||||
(etaf-data-example--filter controller query))
|
||||
(expr :value label))))
|
||||
|
||||
(defun etaf-data-example--toolbar (controller next-id)
|
||||
"Return the action toolbar for CONTROLLER and NEXT-ID."
|
||||
(etaf-view
|
||||
(flex :width '(720) :flex-flow '(row wrap) :gap '(1 (10))
|
||||
(expr :value (etaf-data-example--filter-control
|
||||
controller "ALL" 'data-filter-all nil
|
||||
"#4E7890" "#D9EAF2"))
|
||||
(expr :value (etaf-data-example--filter-control
|
||||
controller "OPEN" 'data-filter-open '(:status open)
|
||||
"#C97252" "#F1D4C9"))
|
||||
(expr :value (etaf-data-example--filter-control
|
||||
controller "DONE" 'data-filter-done '(:status done)
|
||||
"#6D8A73" "#DCEBDD"))
|
||||
(text :padding '(1 (12)) :border "#7A6B95" :bgcolor "#E7E2F1"
|
||||
:face 'bold :ref 'data-add :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-data-example-add
|
||||
controller next-id))
|
||||
"+ ADD TASK"))))
|
||||
|
||||
(defun etaf-data-example--rows (controller)
|
||||
"Return the loaded task rows for CONTROLLER."
|
||||
(let ((items (etaf-value (etaf-data-items controller))))
|
||||
(if items
|
||||
(mapcar (lambda (task)
|
||||
(etaf-data-example--row controller task))
|
||||
items)
|
||||
(etaf-view
|
||||
(text :width '(720) :padding '(2 (16))
|
||||
:border "#8D887F" :bgcolor "#EEEAE2"
|
||||
:text-align 'center "No matching tasks.")))))
|
||||
|
||||
(defun etaf-data-example--view (controller next-id)
|
||||
"Return the Data example View for CONTROLLER and NEXT-ID."
|
||||
(etaf-view
|
||||
(column :width '(720) :color "#252A2E" :bgcolor "#F8F5EE"
|
||||
(expr :value (etaf-data-example--header controller))
|
||||
(spacer :height 1)
|
||||
(expr :value (etaf-data-example--toolbar controller next-id))
|
||||
(spacer :height 1)
|
||||
(column :width '(720)
|
||||
(expr :value (etaf-data-example--rows controller)))
|
||||
(spacer :height 1)
|
||||
(text :width '(720) :padding '(1 (16)) :border "#8D887F"
|
||||
:color "#4D5651" :bgcolor "#EEEAE2"
|
||||
"Owner rule: create in setup, mutate through Data, stop on unmount"))))
|
||||
|
||||
(etaf-define-component etaf-data-example-app ()
|
||||
"Render a memory-backed task application with owned cleanup."
|
||||
@ -105,70 +158,7 @@
|
||||
(next-id (etaf-ref 6 :name 'etaf-data-example-next-id)))
|
||||
(etaf-on-mounted (lambda () (etaf-data-load controller)))
|
||||
(etaf-on-unmounted (lambda () (etaf-data-stop controller)))
|
||||
(list :controller controller :next-id next-id))
|
||||
:view
|
||||
(column :width '(720) :color "#252A2E" :bgcolor "#F8F5EE"
|
||||
(box :width '(720) :padding '(1 (18)) :border "#8F432F"
|
||||
:bgcolor "#FFFDF8" :text-align 'center
|
||||
(column
|
||||
(text :color "#8F432F" :font-weight 'bold
|
||||
"BEST PRACTICE / DATA OWNERSHIP")
|
||||
(text :font-weight 'bold "Task controller")
|
||||
(text :color "#66706A"
|
||||
(expr
|
||||
(format
|
||||
"%d records · %d selected"
|
||||
(etaf-value
|
||||
(etaf-data-total (plist-get (etaf-state) :controller)))
|
||||
(length
|
||||
(etaf-value
|
||||
(etaf-data-selection (plist-get (etaf-state) :controller)))))))))
|
||||
(box :height 1)
|
||||
(flex :width '(720) :flex-flow '(row wrap) :gap '(1 (10))
|
||||
(etaf-data-example-filter
|
||||
:ref 'data-filter-all
|
||||
:controller (plist-get (etaf-state) :controller)
|
||||
:label "ALL" :query nil :border "#4E7890" :background "#D9EAF2")
|
||||
(etaf-data-example-filter
|
||||
:ref 'data-filter-open
|
||||
:controller (plist-get (etaf-state) :controller)
|
||||
:label "OPEN" :query '(:status open)
|
||||
:border "#C97252" :background "#F1D4C9")
|
||||
(etaf-data-example-filter
|
||||
:ref 'data-filter-done
|
||||
:controller (plist-get (etaf-state) :controller)
|
||||
:label "DONE" :query '(:status done)
|
||||
:border "#6D8A73" :background "#DCEBDD")
|
||||
(box :padding '(1 (12)) :border "#7A6B95" :bgcolor "#E7E2F1"
|
||||
:font-weight 'bold :ref 'data-add :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press
|
||||
(let ((controller (plist-get (etaf-state) :controller))
|
||||
(next-id (plist-get (etaf-state) :next-id)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-data-example-add controller next-id)))
|
||||
(text "+ ADD TASK")))
|
||||
(box :height 1)
|
||||
(column :width '(720)
|
||||
(box :if
|
||||
(null
|
||||
(etaf-value
|
||||
(etaf-data-items (plist-get (etaf-state) :controller))))
|
||||
:width '(720) :padding '(2 (16))
|
||||
:border "#8D887F" :bgcolor "#EEEAE2" :text-align 'center
|
||||
(text "No matching tasks."))
|
||||
(etaf-data-example-row
|
||||
:for (task
|
||||
(etaf-value
|
||||
(etaf-data-items (plist-get (etaf-state) :controller))))
|
||||
:key (plist-get task :id)
|
||||
:ref (intern (format "data-task-%d" (plist-get task :id)))
|
||||
:controller (plist-get (etaf-state) :controller)
|
||||
:task task))
|
||||
(box :height 1)
|
||||
(box :width '(720) :padding '(1 (16)) :border "#8D887F"
|
||||
:color "#4D5651" :bgcolor "#EEEAE2"
|
||||
(text "Owner rule: create in setup, mutate through Data, stop on unmount"))))
|
||||
(lambda () (etaf-data-example--view controller next-id))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-data-example-view ()
|
||||
|
||||
@ -22,6 +22,70 @@
|
||||
('loading "Loading service snapshot…")
|
||||
(_ "Resource has not loaded.")))
|
||||
|
||||
(defun etaf-resource-example--header ()
|
||||
"Return the Resource example header."
|
||||
(etaf-view
|
||||
(column :width '(680) :padding '(1 (18)) :border "#8F432F"
|
||||
:bgcolor "#FFFDF8" :text-align 'center
|
||||
(text :color "#8F432F" :face 'bold
|
||||
"BEST PRACTICE / RESOURCE LIFECYCLE")
|
||||
(text :face 'bold "Service health")
|
||||
(text :color "#66706A"
|
||||
"Loader errors become explicit state; cleanup stays scoped."))))
|
||||
|
||||
(defun etaf-resource-example--status (resource cleanup-count)
|
||||
"Return the status card for RESOURCE and CLEANUP-COUNT."
|
||||
(let* ((status (etaf-resource-status resource))
|
||||
(success (eq status 'success))
|
||||
(surface (if success "#DCEBDD" "#F1D4C9"))
|
||||
(border (if success "#6D8A73" "#C97252"))
|
||||
(ink (if success "#24422D" "#6B3020")))
|
||||
(etaf-view
|
||||
(column :width '(680) :padding '(2 (18)) :border border
|
||||
:bgcolor surface :color ink :text-align 'center
|
||||
(text :face 'bold
|
||||
(expr :value (upcase (symbol-name status))))
|
||||
(text (expr :value (etaf-resource-example--message resource)))
|
||||
(text :color "#66706A"
|
||||
(expr :value
|
||||
(format "CLEANUPS %d" (etaf-value cleanup-count))))))))
|
||||
|
||||
(defun etaf-resource-example--actions (resource fail-next)
|
||||
"Return action controls for RESOURCE and FAIL-NEXT."
|
||||
(etaf-view
|
||||
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
|
||||
(text :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
|
||||
:min-width '(180) :padding '(1 (12))
|
||||
:border "#4E7890" :bgcolor "#D9EAF2" :face 'bold
|
||||
:text-align 'center :ref 'resource-reload :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press (lambda () (etaf-resource-load resource))
|
||||
"RELOAD")
|
||||
(text :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
|
||||
:min-width '(180) :padding '(1 (12))
|
||||
:border "#C97252" :bgcolor "#F1D4C9" :face 'bold
|
||||
:text-align 'center :ref 'resource-fail :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press (lambda ()
|
||||
(etaf-set-value fail-next t)
|
||||
(etaf-resource-load resource))
|
||||
"SIMULATE FAILURE"))))
|
||||
|
||||
(defun etaf-resource-example--view (resource fail-next cleanup-count)
|
||||
"Return the example View for RESOURCE, FAIL-NEXT, and CLEANUP-COUNT."
|
||||
(etaf-view
|
||||
(column :width '(680) :color "#252A2E" :bgcolor "#F8F5EE"
|
||||
(expr :value (etaf-resource-example--header))
|
||||
(spacer :height 1)
|
||||
(expr :value
|
||||
(etaf-resource-example--status resource cleanup-count))
|
||||
(spacer :height 1)
|
||||
(expr :value (etaf-resource-example--actions resource fail-next))
|
||||
(spacer :height 1)
|
||||
(text :width '(680) :padding '(1 (16)) :border "#8D887F"
|
||||
:color "#4D5651" :bgcolor "#EEEAE2"
|
||||
"Scope rule: reload releases the old value; unmount releases the last one"))))
|
||||
|
||||
(etaf-define-component etaf-resource-example-app ()
|
||||
"Render a reloadable Resource with visible cleanup and error state."
|
||||
:setup
|
||||
@ -47,75 +111,8 @@
|
||||
:immediate nil
|
||||
:name 'etaf-resource-example))
|
||||
(etaf-on-mounted (lambda () (etaf-resource-load resource)))
|
||||
(list :resource resource :fail-next fail-next
|
||||
:cleanup-count cleanup-count))
|
||||
:view
|
||||
(column :width '(680) :color "#252A2E" :bgcolor "#F8F5EE"
|
||||
(box :width '(680) :padding '(1 (18)) :border "#8F432F"
|
||||
:bgcolor "#FFFDF8" :text-align 'center
|
||||
(column
|
||||
(text :color "#8F432F" :font-weight 'bold
|
||||
"BEST PRACTICE / RESOURCE LIFECYCLE")
|
||||
(text :font-weight 'bold "Service health")
|
||||
(text :color "#66706A"
|
||||
"Loader errors become explicit state; cleanup stays scoped.")))
|
||||
(box :height 1)
|
||||
(box :width '(680) :padding '(2 (18))
|
||||
:border
|
||||
(if (eq (etaf-resource-status
|
||||
(plist-get (etaf-state) :resource)) 'success)
|
||||
"#6D8A73" "#C97252")
|
||||
:bgcolor
|
||||
(if (eq (etaf-resource-status
|
||||
(plist-get (etaf-state) :resource)) 'success)
|
||||
"#DCEBDD" "#F1D4C9")
|
||||
:color
|
||||
(if (eq (etaf-resource-status
|
||||
(plist-get (etaf-state) :resource)) 'success)
|
||||
"#24422D" "#6B3020")
|
||||
:text-align 'center
|
||||
(column
|
||||
(text :font-weight 'bold
|
||||
(expr
|
||||
(upcase
|
||||
(symbol-name
|
||||
(etaf-resource-status (plist-get (etaf-state) :resource))))))
|
||||
(text
|
||||
(expr
|
||||
(etaf-resource-example--message
|
||||
(plist-get (etaf-state) :resource))))
|
||||
(text :color "#66706A"
|
||||
(expr
|
||||
(format "CLEANUPS %d"
|
||||
(etaf-value (plist-get (etaf-state) :cleanup-count)))))))
|
||||
(box :height 1)
|
||||
(flex :width '(680) :flex-flow '(row wrap) :gap '(1 (12))
|
||||
(box :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
|
||||
:min-width '(180) :padding '(1 (12))
|
||||
:border "#4E7890" :bgcolor "#D9EAF2" :font-weight 'bold
|
||||
:text-align 'center :ref 'resource-reload :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press
|
||||
(let ((resource (plist-get (etaf-state) :resource)))
|
||||
(lambda () (etaf-resource-load resource)))
|
||||
(text "RELOAD"))
|
||||
(box :flex-grow 1 :flex-shrink 1 :flex-basis '(200)
|
||||
:min-width '(180) :padding '(1 (12))
|
||||
:border "#C97252" :bgcolor "#F1D4C9" :font-weight 'bold
|
||||
:text-align 'center :ref 'resource-fail :role 'button
|
||||
:use (list (etaf-focusable))
|
||||
:on-press
|
||||
(let ((resource (plist-get (etaf-state) :resource))
|
||||
(fail-next (plist-get (etaf-state) :fail-next)))
|
||||
(lambda ()
|
||||
(etaf-set-value fail-next t)
|
||||
(etaf-resource-load resource)))
|
||||
(text "SIMULATE FAILURE")))
|
||||
(box :height 1)
|
||||
(box :width '(680) :padding '(1 (16)) :border "#8D887F"
|
||||
:color "#4D5651" :bgcolor "#EEEAE2"
|
||||
(text
|
||||
"Scope rule: reload releases the old value; unmount releases the last one"))))
|
||||
(lambda ()
|
||||
(etaf-resource-example--view resource fail-next cleanup-count))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-resource-example-view ()
|
||||
|
||||
@ -1,29 +0,0 @@
|
||||
# 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.
|
||||
@ -1,175 +0,0 @@
|
||||
# Generic Emacs GUI verification
|
||||
|
||||
For an already running Emacs, use its existing server through `emacsclient`.
|
||||
Load the checkout and call the example entry point in an explicit buffer, show
|
||||
that buffer in the existing graphical frame, and capture only that owned
|
||||
window. Preserve the user's font and chrome. Do not start another daemon or
|
||||
frame for this workflow. Preserve application focus so the user can keep working
|
||||
in other apps. The `emacsclient-render-capture` skill supplies buffer selection
|
||||
without activation and before/after target guards.
|
||||
|
||||
This directory also owns reusable verification mechanisms; application
|
||||
scenarios live in their respective example repositories:
|
||||
|
||||
- `emacs-gui-verifier.el` defines `Scenario`, ordered `Action`, run-local
|
||||
`Context`, checkpoint sequencing, assertions, completion, and fail-closed
|
||||
evidence finalization. Its `etaf-gui-verifier-measure-action` entry records
|
||||
callback wall/CPU/GC time and GUI conditions without taking application focus.
|
||||
- `benchmark-ebox-resize.el` drives continuous pixel-width sweeps of any
|
||||
existing mounted Ebox buffer, including ETAF apps, without taking over its
|
||||
observer. See the existing-server entry below.
|
||||
- The legacy isolated runner `run-emacs-gui-verification.sh` owns one named daemon, explicit load paths,
|
||||
external application activation, recorder lifecycle, driver loading, report
|
||||
generation, and exact cleanup.
|
||||
- `record-emacs-window.swift` uses macOS 15 ScreenCaptureKit to record only the
|
||||
frame owned by the supplied Emacs PID. It follows replacement window IDs and
|
||||
rejects changed pixel mappings. Its desktop-independent window filter works
|
||||
without activating Emacs. Its canvas is fixed at recording start:
|
||||
when the scenario includes resize, prepare the largest tested frame before
|
||||
starting the recorder. Smaller windows retain native pixels with padding;
|
||||
a window larger than the original canvas invalidates the recording.
|
||||
- `capture-emacs-window.sh` supplies window-only checkpoint screenshots and
|
||||
rejects missing, ambiguous, or changing frame identities without activating
|
||||
Emacs. The runner compiles
|
||||
the video helper using the system Swift compiler; no package install is needed.
|
||||
|
||||
Concrete repositories provide adapter files that construct a Scenario and an
|
||||
entry function. They can run through the existing server. The following command
|
||||
instead starts the legacy isolated environment; use it only when that separate
|
||||
environment is explicitly intended:
|
||||
|
||||
```sh
|
||||
scripts/run-emacs-gui-verification.sh run ADAPTER.el ENTRY \
|
||||
--load-path /path/to/provider \
|
||||
--run-dir /private/tmp/my-gui-run
|
||||
```
|
||||
|
||||
In that isolated runner, fresh captures remain `INCOMPLETE` until their selected images
|
||||
and contact sheet are reviewed. Finalize the same evidence directory with:
|
||||
|
||||
```sh
|
||||
scripts/run-emacs-gui-verification.sh review /private/tmp/my-gui-run
|
||||
```
|
||||
|
||||
Only `VERDICT=PASS` completes that runner's evidence bundle. An existing-server
|
||||
run reports its actual interaction assertions and inspected screenshots
|
||||
separately. A failed recorder is never evidence of continuous capture, and
|
||||
neither screenshots nor recording establish an operation latency bound.
|
||||
|
||||
For an existing server, take a background screenshot with the observed process ID:
|
||||
|
||||
```sh
|
||||
ETAF_GUI_CAPTURE_PID=12345 scripts/capture-emacs-window.sh -x /tmp/app-checkpoint.png
|
||||
```
|
||||
|
||||
Keep the target frame open and non-minimized. Validate a known content change in
|
||||
before/after pixels to establish fresh background rendering. Hidden, minimized,
|
||||
off-Space and locked-session behavior is not covered by this procedure. Background
|
||||
Lisp callbacks and runtime timing do not require application activation; report
|
||||
them as background measurements, separately from foreground input-to-display
|
||||
latency. Use Emacs-local operations while another app is active, not global input.
|
||||
|
||||
## Measuring an existing GUI action
|
||||
|
||||
Reuse `etaf-gui-verifier-measure-action` with the adapter's Context and Action:
|
||||
|
||||
```elisp
|
||||
;; Prepare the target control and fixture before entering the measured callback.
|
||||
(etaf-gui-verifier-measure-action context action t)
|
||||
(car (etaf-gui-verifier-context-measurements context))
|
||||
```
|
||||
|
||||
The final `t` requires an already selected foreground target. It rejects a
|
||||
background, hidden, unknown or wrong target before running the action, and
|
||||
invalidates a sample if focus, target, font or geometry changes. It never raises
|
||||
Emacs. Omit that argument for background functional work; those samples are
|
||||
explicitly labeled and must not be reported as foreground latency.
|
||||
|
||||
Timing covers exactly `Action.execute`, excluding target inspection,
|
||||
checkpoints and the verifier's intentional settle waits. Keep fixture setup,
|
||||
control lookup and focus navigation outside an activation measurement. If the
|
||||
chosen boundary includes an explicit `redisplay`, put that call in `execute`
|
||||
and describe the boundary accordingly. Returning from redisplay still does not
|
||||
prove compositor presentation. Each record says `presentation_measured=nil`.
|
||||
|
||||
Context retains every measurement, including first use, warmups, failures and
|
||||
rejections. Failed callbacks retain their own timing and original condition;
|
||||
rejections have no duration. Checkpoints export only the most recent record.
|
||||
Report the full sample count and all-sample maximum as well as any explicitly
|
||||
labeled steady-state statistics. Compare identical payload/page size, viewport,
|
||||
loaded code, recording mode and foreground class; do not discard a slow group
|
||||
because another run is faster. The historical `.omx/component-api-implementation/
|
||||
current-workbench-sample.el` probe is superseded by this measurement boundary.
|
||||
|
||||
For provider traces, scope `etaf-performance-records` by its numeric observer
|
||||
runtime ID, not buffer name, which can be reused after unmount. Pass the selected
|
||||
records explicitly to summary/export functions: an empty selection stays empty.
|
||||
Check operation IDs/counts as well as runtime ID when sampling the same mounted
|
||||
instance again; the recorder's bounded history is not a per-run sample store.
|
||||
|
||||
## Continuous resize on the existing server
|
||||
|
||||
Use this entry for resize performance investigations instead of copying the
|
||||
historical `.omx/component-api-implementation/*continuous-resize*.el` probes.
|
||||
First show the intended buffer in the user's existing foreground GUI frame.
|
||||
Preserve its font and chrome. Compile changed product modules before loading
|
||||
them; `make compile` in this repository also compiles the benchmark tool.
|
||||
|
||||
```sh
|
||||
emacsclient --eval '(progn
|
||||
(load "/path/to/etaf/scripts/benchmark-ebox-resize.elc" nil t t)
|
||||
(ebox-resize-benchmark-start "*Your app*" 480 1400
|
||||
:step 32 :rounds 3 :output "/tmp/resize-run-1.eldata"))'
|
||||
```
|
||||
|
||||
The bounds are outer-frame pixels. Every round goes from narrow to wide and
|
||||
back, including both endpoints even when the step does not divide the range.
|
||||
The last measured request returns to the initial width. Consecutive equal
|
||||
widths are omitted because they request no resize; no warmup or slow sample is
|
||||
dropped. The function returns immediately. Poll or cancel this owned run with:
|
||||
|
||||
```elisp
|
||||
(ebox-resize-benchmark-status)
|
||||
(ebox-resize-benchmark-cancel)
|
||||
```
|
||||
|
||||
`:delay` (default 0.01 seconds) runs between completed publications;
|
||||
`:timeout` (default 5 seconds) bounds startup, publication and final settling.
|
||||
The tool waits for a preceding render's GC lease to end before recording the
|
||||
baseline, and for its own run's lease to end before accepting the final result.
|
||||
Unsupported sizes,
|
||||
changed targets/focus/font/height, publication failures and cancellation produce
|
||||
invalid/incomplete evidence. Advice and timers are removed on success, error,
|
||||
quit and timeout. Failure leaves the last applied width; it does not fight a
|
||||
user's subsequent window changes. No server, frame, application buffer, observer, profiler
|
||||
or GC policy is created/replaced to make the benchmark pass.
|
||||
|
||||
Use a **new output path** each time. UTF-8 `.eldata` reports retain all requests,
|
||||
all completed samples, actual published dimensions, node/text counts, GC,
|
||||
per-operation CPU time, code origins and hashes. Optional `:phases '(FUNCTIONS…)`
|
||||
records inclusive phase durations for loaded `ebox-`, `tp-` and `etaf-` provider
|
||||
functions. The driver and outer publication boundary cannot be selected as
|
||||
phases; nested durations must not be summed.
|
||||
Publication timing ends when the real public Ebox viewport call returns.
|
||||
Request→publication also includes event-loop delivery. Neither metric proves
|
||||
compositor presentation, absence of flicker, or every interaction's correctness;
|
||||
use the existing visual scenario/capture tools for those claims.
|
||||
|
||||
`:valid t` requires complete correctly attributed publication coverage.
|
||||
`:within-limit t` additionally requires **every** request→publication sample to
|
||||
meet `:limit-ms` (default 50). Inspect p95 **and** max, including GC samples.
|
||||
Compare payload counts at matching widths before making speedup claims. A
|
||||
different page size/content or loaded version is a different baseline.
|
||||
|
||||
Code origins and disk hashes alone cannot establish when a running function was
|
||||
loaded. After recompilation, `:reload-files '("/checkout/ebox/ebox-viewport.elc" …)`
|
||||
explicitly loads the chosen fresh bytecode before instrumentation. `:code`
|
||||
contains every explicitly loaded file's canonical path, source/bytecode hashes
|
||||
and load result, plus observed core function and benchmark driver origins;
|
||||
matching origins are marked `:reloaded t`. Choose the affected modules; do not reload
|
||||
application component declarations blindly. Without this option, report code
|
||||
origin observations separately from independent evidence of a fresh GUI load.
|
||||
|
||||
Run the tool's regression checks with `make resize-benchmark-tests`; they also
|
||||
run in the full `make check` gate. Application-specific data setup and interaction
|
||||
assertions remain in the example repositories, not this resize driver.
|
||||
@ -1,497 +0,0 @@
|
||||
;;; 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 MINIMUM–MAXIMUM 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 narrow→wide→narrow 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 request→publication 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
|
||||
@ -1,142 +0,0 @@
|
||||
;;; benchmark-scheduler-context.el --- ETAF dispatcher microbenchmark -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Runs the M3a T6 fixed scheduler scenario: 40 changed sources fan out to one
|
||||
;; Effect in each of four isolated contexts. Five warmups precede thirty timed
|
||||
;; samples. Exact work counters and a 50 ms p95/max gate make the result useful
|
||||
;; as a small dispatcher regression baseline; product GUI performance is a
|
||||
;; separate end-to-end gate.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf)
|
||||
|
||||
(defconst etaf-scheduler-benchmark-warmups 5)
|
||||
(defconst etaf-scheduler-benchmark-samples 30)
|
||||
(defconst etaf-scheduler-benchmark-source-count 40)
|
||||
(defconst etaf-scheduler-benchmark-context-count 4)
|
||||
(defconst etaf-scheduler-benchmark-limit-ms 50.0)
|
||||
|
||||
(defun etaf-scheduler-benchmark--percentile (values percentile)
|
||||
"Return nearest-rank PERCENTILE from numeric VALUES."
|
||||
(let* ((ordered (sort (copy-sequence values) #'<))
|
||||
(rank (max 1 (ceiling (* percentile (length ordered))))))
|
||||
(nth (1- rank) ordered)))
|
||||
|
||||
(defun etaf-scheduler-benchmark--metric-total (contexts key)
|
||||
"Return the sum of metric KEY across scheduler CONTEXTS."
|
||||
(cl-loop for context in contexts
|
||||
sum (or (plist-get (etaf-scheduler-context-metrics context) key)
|
||||
0)))
|
||||
|
||||
(defun etaf-scheduler-benchmark--iteration (sources iteration)
|
||||
"Publish ITERATION through all reactive SOURCES once."
|
||||
(etaf-reactive-call-with-batch
|
||||
(lambda ()
|
||||
(cl-loop for source in sources
|
||||
for index from 0
|
||||
do (setf (etaf-value source)
|
||||
(+ (* iteration 1000) index))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-scheduler-benchmark-run ()
|
||||
"Run the fixed scheduler benchmark, print its result, and return it."
|
||||
(let* ((contexts
|
||||
(cl-loop for index below etaf-scheduler-benchmark-context-count
|
||||
collect
|
||||
(etaf-scheduler-context-create
|
||||
:name (list 'benchmark index))))
|
||||
(sources
|
||||
(cl-loop repeat etaf-scheduler-benchmark-source-count
|
||||
collect (etaf-ref 0)))
|
||||
effects durations result)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(dolist (context contexts)
|
||||
(let ((effect
|
||||
(etaf-scheduler-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(etaf-reactive-effect-create
|
||||
(lambda () (mapcar #'etaf-value sources)))))))
|
||||
(push effect effects)
|
||||
(etaf-reactive-effect-run effect)))
|
||||
(dotimes (index etaf-scheduler-benchmark-warmups)
|
||||
(etaf-scheduler-benchmark--iteration sources (1+ index)))
|
||||
(let ((source-before
|
||||
(etaf-scheduler-benchmark--metric-total
|
||||
contexts :source-enqueues))
|
||||
(visit-before
|
||||
(etaf-scheduler-benchmark--metric-total
|
||||
contexts :subscriber-visits))
|
||||
(effect-before
|
||||
(etaf-scheduler-benchmark--metric-total
|
||||
contexts :effect-evaluations))
|
||||
(turn-before
|
||||
(etaf-scheduler-benchmark--metric-total
|
||||
contexts :turn-count)))
|
||||
(dotimes (index etaf-scheduler-benchmark-samples)
|
||||
(let ((started (float-time)))
|
||||
(etaf-scheduler-benchmark--iteration
|
||||
sources (+ etaf-scheduler-benchmark-warmups index 1))
|
||||
(push (* 1000.0 (- (float-time) started)) durations)))
|
||||
(setq durations (nreverse durations))
|
||||
(let* ((expected-source-work
|
||||
(* etaf-scheduler-benchmark-samples
|
||||
etaf-scheduler-benchmark-source-count
|
||||
etaf-scheduler-benchmark-context-count))
|
||||
(expected-context-work
|
||||
(* etaf-scheduler-benchmark-samples
|
||||
etaf-scheduler-benchmark-context-count))
|
||||
(source-work
|
||||
(- (etaf-scheduler-benchmark--metric-total
|
||||
contexts :source-enqueues)
|
||||
source-before))
|
||||
(subscriber-visits
|
||||
(- (etaf-scheduler-benchmark--metric-total
|
||||
contexts :subscriber-visits)
|
||||
visit-before))
|
||||
(effect-work
|
||||
(- (etaf-scheduler-benchmark--metric-total
|
||||
contexts :effect-evaluations)
|
||||
effect-before))
|
||||
(turn-work
|
||||
(- (etaf-scheduler-benchmark--metric-total
|
||||
contexts :turn-count)
|
||||
turn-before))
|
||||
(p95
|
||||
(etaf-scheduler-benchmark--percentile durations 0.95))
|
||||
(maximum (apply #'max durations)))
|
||||
(unless (and (= source-work expected-source-work)
|
||||
(= subscriber-visits expected-source-work)
|
||||
(= effect-work expected-context-work)
|
||||
(= turn-work expected-context-work))
|
||||
(error "Scheduler work counters diverged: %S"
|
||||
(list source-work subscriber-visits
|
||||
effect-work turn-work)))
|
||||
(setq result
|
||||
(list
|
||||
:scenario 'scheduler-40-sources-4-contexts
|
||||
:warmups etaf-scheduler-benchmark-warmups
|
||||
:samples etaf-scheduler-benchmark-samples
|
||||
:p95-ms p95 :max-ms maximum
|
||||
:source-enqueues source-work
|
||||
:subscriber-visits subscriber-visits
|
||||
:effect-evaluations effect-work
|
||||
:turns turn-work))
|
||||
(when (or (> p95 etaf-scheduler-benchmark-limit-ms)
|
||||
(> maximum etaf-scheduler-benchmark-limit-ms))
|
||||
(error "Scheduler benchmark exceeds %.1f ms: %S"
|
||||
etaf-scheduler-benchmark-limit-ms result)))))
|
||||
(dolist (effect effects) (etaf--stop-effect effect)))
|
||||
(prin1 result)
|
||||
(terpri)
|
||||
result))
|
||||
|
||||
(provide 'benchmark-scheduler-context)
|
||||
|
||||
;;; benchmark-scheduler-context.el ends here
|
||||
@ -1,69 +0,0 @@
|
||||
#!/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
|
||||
@ -1,329 +0,0 @@
|
||||
;;; emacs-gui-verifier.el --- Generic temporal GUI scenario engine -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This developer tool executes declarative GUI scenarios against any Emacs
|
||||
;; buffer. It owns action ordering, checkpoint phases, target-buffer guards,
|
||||
;; completion, and evidence lifecycle. It does not know ETAF Runtime, Ebox,
|
||||
;; Playground, or any concrete example; adapters supply those facts through
|
||||
;; callbacks and opaque context data.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
|
||||
(declare-function emacs-dynamic-ui-verification-start
|
||||
"capture-checkpoint" (directory run-id claim required-phases))
|
||||
(declare-function emacs-dynamic-ui-verification-checkpoint
|
||||
"capture-checkpoint"
|
||||
(action-id phase adapter assertions screenshot))
|
||||
(declare-function emacs-dynamic-ui-verification-finish
|
||||
"capture-checkpoint" (completed adapter))
|
||||
|
||||
(cl-defstruct (etaf-gui-verifier-action
|
||||
(:constructor etaf-gui-verifier-action-create))
|
||||
"One ordered GUI action and its postcondition callback."
|
||||
id execute assertions screenshot settled-p
|
||||
(settle-timeout 5.0) (settle-interval 0.05))
|
||||
|
||||
(cl-defstruct (etaf-gui-verifier-scenario
|
||||
(:constructor etaf-gui-verifier-scenario-create))
|
||||
"One reusable GUI scenario assembled by an adapter."
|
||||
name claim initialize actions invariants adapter completion)
|
||||
|
||||
(cl-defstruct (etaf-gui-verifier-context
|
||||
(:constructor etaf-gui-verifier--context-create))
|
||||
"Mutable execution state owned only by one verifier run."
|
||||
scenario target-buffer data (action-count 0) (last-duration-ms 0.0)
|
||||
measurements)
|
||||
|
||||
(defun etaf-gui-verifier-context-put (context key value)
|
||||
"Store adapter VALUE for KEY in CONTEXT and return VALUE."
|
||||
(setf (alist-get key (etaf-gui-verifier-context-data context)) value)
|
||||
value)
|
||||
|
||||
(defun etaf-gui-verifier-context-get (context key &optional default)
|
||||
"Return CONTEXT adapter value KEY, or DEFAULT when absent."
|
||||
(alist-get key (etaf-gui-verifier-context-data context) default))
|
||||
|
||||
(defun etaf-gui-verifier--measurement-state (context)
|
||||
"Return CONTEXT's live identities followed by JSON-safe GUI facts."
|
||||
(let* ((frame (selected-frame))
|
||||
(window (selected-window))
|
||||
(target (etaf-gui-verifier-context-target-buffer context))
|
||||
(selected-buffer (window-buffer window))
|
||||
(focus (frame-focus-state frame)))
|
||||
(cons
|
||||
(list frame window target selected-buffer)
|
||||
`((graphic . ,(and (display-graphic-p frame) t))
|
||||
(focus . ,(cond ((eq focus t) "foreground")
|
||||
((null focus) "background")
|
||||
(t "unknown")))
|
||||
(frame_name . ,(frame-parameter frame 'name))
|
||||
(frame_window_id . ,(frame-parameter frame 'window-id))
|
||||
(frame_visible . ,(pcase (frame-visible-p frame)
|
||||
('t "visible") ('icon "icon") (_ "hidden")))
|
||||
(target_buffer . ,(and (buffer-live-p target) (buffer-name target)))
|
||||
(selected_buffer . ,(buffer-name selected-buffer))
|
||||
(target_selected . ,(and (buffer-live-p target)
|
||||
(eq target selected-buffer)))
|
||||
(font . ,(format "%s" (frame-parameter frame 'font)))
|
||||
(frame_width_px . ,(frame-pixel-width frame))
|
||||
(frame_height_px . ,(frame-pixel-height frame))
|
||||
(window_edges_px . ,(vconcat (window-pixel-edges window)))
|
||||
(inhibit_quit . ,(and inhibit-quit t))
|
||||
(inhibit_redisplay . ,(and inhibit-redisplay t))
|
||||
(noninteractive . ,(and noninteractive t))))))
|
||||
|
||||
(defun etaf-gui-verifier-measure-action (context action &optional require-foreground)
|
||||
"Measure ACTION's execute callback once with CONTEXT; return its exact result.
|
||||
Retain a JSON-safe measurement in CONTEXT's measurements, newest first,
|
||||
including failed or quit callbacks, and update the legacy last duration.
|
||||
Wall/CPU/GC timing covers only the callback, excluding GUI-state snapshots and
|
||||
the verifier's later checkpoints, redisplay, and settling. Calls made inside
|
||||
the callback are included. No focus or execution bindings change.
|
||||
|
||||
With REQUIRE-FOREGROUND, reject a non-graphical, unfocused, unknown, hidden,
|
||||
or unselected target before invoking the callback. Rejection retains an
|
||||
untimed record and clears the legacy duration. Changes to frame/window/buffer
|
||||
identities, graphical display, focus, visibility, native window ID, target
|
||||
selection, font, frame pixel size, or window pixel edges invalidate the record
|
||||
and, when foreground is required, signal after a successful callback. Frame
|
||||
and buffer names and execution bindings are diagnostic observations, not
|
||||
identity guards. Callback errors and quits propagate with their original data.
|
||||
A closing snapshot quit is recorded and propagated after a successful callback,
|
||||
but never replaces an existing callback error or quit.
|
||||
|
||||
Background callbacks are allowed by default and labeled accordingly. A
|
||||
valid record requires a successful callback with a live selected target in
|
||||
an unchanged environment; even a foreground record does not certify
|
||||
input-to-presentation latency."
|
||||
(let* ((before (etaf-gui-verifier--measurement-state context))
|
||||
(facts (cdr before))
|
||||
(foreground (if (alist-get 'graphic facts)
|
||||
(alist-get 'focus facts)
|
||||
"unknown"))
|
||||
(status "rejected")
|
||||
started cpu-start gc-start gcs-start result changed snapshot-quit)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(when (and require-foreground
|
||||
(not (and (equal foreground "foreground")
|
||||
(equal (alist-get 'frame_visible facts) "visible")
|
||||
(alist-get 'target_selected facts))))
|
||||
(error "GUI action requires a selected foreground target: %s"
|
||||
(etaf-gui-verifier-action-id action)))
|
||||
(setq cpu-start (current-cpu-time)
|
||||
gc-start gc-elapsed
|
||||
gcs-start gcs-done
|
||||
started (float-time))
|
||||
(condition-case condition
|
||||
(progn
|
||||
(setq result
|
||||
(funcall (etaf-gui-verifier-action-execute action) context)
|
||||
status "success"))
|
||||
((error quit)
|
||||
(setq status (if (eq (car condition) 'quit) "quit" "error"))
|
||||
(signal (car condition) (cdr condition)))))
|
||||
(let* ((finished (and started (float-time)))
|
||||
(cpu-end (and started (current-cpu-time)))
|
||||
(gc-end gc-elapsed)
|
||||
(gcs-end gcs-done)
|
||||
(wall-ms (and started (* 1000.0 (- finished started))))
|
||||
;; Snapshot failure must not replace an action's error or quit.
|
||||
(after (and started
|
||||
(condition-case condition
|
||||
(etaf-gui-verifier--measurement-state context)
|
||||
(quit (setq snapshot-quit condition) nil)
|
||||
(error nil)))))
|
||||
(setq changed
|
||||
(and started
|
||||
(or (not (equal (car before) (car after)))
|
||||
(cl-some
|
||||
(lambda (key)
|
||||
(not (equal (alist-get key facts)
|
||||
(alist-get key (cdr after)))))
|
||||
'(graphic focus frame_visible frame_window_id
|
||||
target_selected font frame_width_px frame_height_px
|
||||
window_edges_px)))))
|
||||
(when (and snapshot-quit (equal status "success"))
|
||||
(setq status "quit"))
|
||||
(when (and changed require-foreground (equal status "success"))
|
||||
(setq status "invalid"))
|
||||
(setf (etaf-gui-verifier-context-last-duration-ms context) wall-ms)
|
||||
(push
|
||||
`((action_id . ,(etaf-gui-verifier-action-id action))
|
||||
(boundary . "action.execute callback")
|
||||
(presentation_measured . nil)
|
||||
(status . ,status)
|
||||
(valid . ,(and (equal status "success") (not changed)
|
||||
(alist-get 'target_selected facts)))
|
||||
(foreground . ,(if changed "changed" foreground))
|
||||
(foreground_required . ,(and require-foreground t))
|
||||
(wall_ms . ,wall-ms)
|
||||
(cpu_ms . ,(and cpu-end
|
||||
(* 1000.0
|
||||
(- (/ (float (car cpu-end)) (cdr cpu-end))
|
||||
(/ (float (car cpu-start)) (cdr cpu-start))))))
|
||||
(gc_count . ,(and started (- gcs-end gcs-start)))
|
||||
(gc_ms . ,(and started (* 1000.0 (- gc-end gc-start))))
|
||||
(before . ,facts)
|
||||
(after . ,(cdr after)))
|
||||
(etaf-gui-verifier-context-measurements context))))
|
||||
;; An action's nonlocal failure bypasses this point and keeps precedence.
|
||||
(when snapshot-quit
|
||||
(signal (car snapshot-quit) (cdr snapshot-quit)))
|
||||
(when (equal status "invalid")
|
||||
(error "GUI action environment changed during callback: %s"
|
||||
(etaf-gui-verifier-action-id action)))
|
||||
result))
|
||||
|
||||
(defun etaf-gui-verifier-context-select-buffer (context buffer)
|
||||
"Select live BUFFER as CONTEXT's single-window target."
|
||||
(unless (buffer-live-p buffer)
|
||||
(error "GUI verifier target buffer is not live"))
|
||||
(setf (etaf-gui-verifier-context-target-buffer context) buffer)
|
||||
(switch-to-buffer buffer)
|
||||
(delete-other-windows)
|
||||
buffer)
|
||||
|
||||
(defun etaf-gui-verifier-assert (name passed &optional detail)
|
||||
"Return one normalized assertion NAME for PASSED and optional DETAIL."
|
||||
(append (list (cons 'name name) (cons 'passed (and passed t)))
|
||||
(when detail (list (cons 'detail detail)))))
|
||||
|
||||
(defun etaf-gui-verifier--target-assertions (context)
|
||||
"Return generic selected-target assertions for CONTEXT."
|
||||
(let ((buffer (etaf-gui-verifier-context-target-buffer context)))
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"target-buffer-selected"
|
||||
(and (buffer-live-p buffer)
|
||||
(eq (window-buffer (selected-window)) buffer))))))
|
||||
|
||||
(defun etaf-gui-verifier--scenario-assertions (context)
|
||||
"Return generic and adapter assertions for CONTEXT."
|
||||
(let* ((scenario (etaf-gui-verifier-context-scenario context))
|
||||
(function (etaf-gui-verifier-scenario-invariants scenario)))
|
||||
(append
|
||||
(etaf-gui-verifier--target-assertions context)
|
||||
(and function (funcall function context)))))
|
||||
|
||||
(defun etaf-gui-verifier--adapter-data (context)
|
||||
"Return generic and adapter JSON data for CONTEXT."
|
||||
(let* ((scenario (etaf-gui-verifier-context-scenario context))
|
||||
(function (etaf-gui-verifier-scenario-adapter scenario)))
|
||||
(append
|
||||
(list
|
||||
(cons 'scenario (etaf-gui-verifier-scenario-name scenario))
|
||||
(cons 'action_count
|
||||
(etaf-gui-verifier-context-action-count context))
|
||||
(cons 'duration_ms
|
||||
(etaf-gui-verifier-context-last-duration-ms context))
|
||||
(cons 'last_measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(and function (funcall function context)))))
|
||||
|
||||
(defun etaf-gui-verifier--checkpoint
|
||||
(context action-id phase screenshot &optional extra)
|
||||
"Capture CONTEXT ACTION-ID PHASE with SCREENSHOT and EXTRA assertions."
|
||||
(emacs-dynamic-ui-verification-checkpoint
|
||||
action-id phase
|
||||
(etaf-gui-verifier--adapter-data context)
|
||||
(append (etaf-gui-verifier--scenario-assertions context) extra)
|
||||
screenshot))
|
||||
|
||||
(defun etaf-gui-verifier--settle-action (context action)
|
||||
"Wait until ACTION's visible result is settled in CONTEXT."
|
||||
(let ((settled-p (etaf-gui-verifier-action-settled-p action))
|
||||
(timeout (etaf-gui-verifier-action-settle-timeout action))
|
||||
(interval (etaf-gui-verifier-action-settle-interval action)))
|
||||
(unless settled-p
|
||||
(error "GUI action has no settle predicate: %s"
|
||||
(etaf-gui-verifier-action-id action)))
|
||||
(unless (and (numberp timeout) (> timeout 0))
|
||||
(error "GUI action settle timeout must be positive: %s"
|
||||
(etaf-gui-verifier-action-id action)))
|
||||
(unless (and (numberp interval) (> interval 0))
|
||||
(error "GUI action settle interval must be positive: %s"
|
||||
(etaf-gui-verifier-action-id action)))
|
||||
;; Always complete at least one redisplay before accepting a predicate.
|
||||
;; A predicate proves adapter state, not that Emacs painted that state.
|
||||
(redisplay t)
|
||||
(sit-for 0)
|
||||
(let ((deadline
|
||||
(+ (float-time) timeout))
|
||||
settled)
|
||||
(while (not settled)
|
||||
(when (>= (float-time) deadline)
|
||||
(error "GUI action did not settle before timeout: %s"
|
||||
(etaf-gui-verifier-action-id action)))
|
||||
(if (funcall settled-p context)
|
||||
;; Require the same postcondition across one event/paint turn.
|
||||
;; Runtime state can be synchronous while the GUI compositor still
|
||||
;; presents the preceding frame.
|
||||
(progn
|
||||
(sit-for interval)
|
||||
(redisplay t)
|
||||
(setq settled (funcall settled-p context)))
|
||||
(sit-for interval)
|
||||
(redisplay t))))))
|
||||
|
||||
(defun etaf-gui-verifier--run-action (context action)
|
||||
"Execute ACTION once inside CONTEXT's ordered checkpoint protocol."
|
||||
(let ((action-id (etaf-gui-verifier-action-id action))
|
||||
(assertions (etaf-gui-verifier-action-assertions action)))
|
||||
(etaf-gui-verifier--checkpoint
|
||||
context action-id "before-action" nil)
|
||||
(etaf-gui-verifier-measure-action context action)
|
||||
(cl-incf (etaf-gui-verifier-context-action-count context))
|
||||
(etaf-gui-verifier--checkpoint
|
||||
context action-id "after-action" nil)
|
||||
(etaf-gui-verifier--settle-action context action)
|
||||
(etaf-gui-verifier--checkpoint
|
||||
context action-id "after-redisplay"
|
||||
(etaf-gui-verifier-action-screenshot action)
|
||||
(and assertions (funcall assertions context)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-gui-verifier-run (scenario run-directory)
|
||||
"Execute generic SCENARIO and write temporal evidence to RUN-DIRECTORY."
|
||||
(unless (etaf-gui-verifier-scenario-p scenario)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-gui-verifier-scenario-p scenario)))
|
||||
(let* ((context
|
||||
(etaf-gui-verifier--context-create :scenario scenario))
|
||||
(initialize (etaf-gui-verifier-scenario-initialize scenario))
|
||||
(completion (etaf-gui-verifier-scenario-completion scenario))
|
||||
finished-p)
|
||||
(emacs-dynamic-ui-verification-start
|
||||
run-directory
|
||||
(etaf-gui-verifier-scenario-name scenario)
|
||||
(etaf-gui-verifier-scenario-claim scenario)
|
||||
'("before-action" "after-action" "after-redisplay"))
|
||||
(condition-case error-data
|
||||
(progn
|
||||
(when initialize (funcall initialize context))
|
||||
(dolist (action (etaf-gui-verifier-scenario-actions scenario))
|
||||
(etaf-gui-verifier--run-action context action))
|
||||
(let ((completed (if completion
|
||||
(funcall completion context)
|
||||
t)))
|
||||
(emacs-dynamic-ui-verification-finish
|
||||
completed (etaf-gui-verifier--adapter-data context))
|
||||
(setq finished-p t)
|
||||
(unless completed
|
||||
(error "GUI scenario completion predicate failed")))
|
||||
context)
|
||||
((error quit)
|
||||
(unless finished-p
|
||||
(condition-case finish-error
|
||||
(emacs-dynamic-ui-verification-finish
|
||||
nil (etaf-gui-verifier--adapter-data context))
|
||||
(error
|
||||
(message "GUI verifier could not record failed completion: %s"
|
||||
(error-message-string finish-error)))))
|
||||
(signal (car error-data) (cdr error-data))))))
|
||||
|
||||
(provide 'emacs-gui-verifier)
|
||||
;;; emacs-gui-verifier.el ends here
|
||||
@ -1,315 +0,0 @@
|
||||
;;; etaf-m0a-inventory.el --- M0a current-contract inventory -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This is a read-only M0a inventory surface. It records current contracts,
|
||||
;; known pre-activation baselines, and the condition handlers present in ETAF
|
||||
;; source files. It intentionally does not turn future architecture targets
|
||||
;; into passing assertions.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf)
|
||||
(require 'json)
|
||||
(require 'macroexp)
|
||||
|
||||
(defconst etaf-m0a-package-root
|
||||
(file-name-directory
|
||||
(directory-file-name
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"Absolute ETAF package root inferred when this inventory is loaded.")
|
||||
|
||||
(defconst etaf-m0a-current-contract-inventory
|
||||
'((:id component-definition
|
||||
:evidence-mode current-contract
|
||||
:summary ":view or :render is required; :setup/:styles are optional"
|
||||
:tests (etaf-component-frontends-definition-boundary-is-strict
|
||||
etaf-component-definition-keywords-have-one-owner))
|
||||
(:id host-attrs
|
||||
:evidence-mode current-contract
|
||||
:summary "undeclared Host attrs fall through a single-root Component chain"
|
||||
:tests (etaf-component-host-attrs-fall-through-one-root-chain
|
||||
etaf-component-host-attrs-reject-ambiguous-or-invalid-targets
|
||||
etaf-component-host-attrs-rollback-root-shape-failure))
|
||||
(:id slots-key-lifecycle-rollback
|
||||
:evidence-mode current-contract
|
||||
:summary "slots retain caller ownership; key is framework-owned; lifecycle and rollback are ordered"
|
||||
:tests (etaf-component-frontends-project-default-and-named-slots
|
||||
etaf-component-key-is-framework-owned-and-render-result-is-typed
|
||||
etaf-component-lifecycle-and-scope-cleanup-are-ordered
|
||||
etaf-component-render-side-effect-rolls-back-completely))
|
||||
(:id action-registration
|
||||
:evidence-mode observed-baseline
|
||||
:activation-milestone M0b
|
||||
:owner etaf-actions
|
||||
:summary "registering an existing Action name replaces the current spec"
|
||||
:tests (etaf-m0a-action-registration-replaces-current-definition))
|
||||
(:id behavior-duplicates
|
||||
:evidence-mode observed-baseline
|
||||
:activation-milestone M0b
|
||||
:owner etaf-runtime
|
||||
:summary "same-name Behaviors are currently processed in declaration order; no pre-install duplicate gate exists"
|
||||
:tests (etaf-runtime-composes-host-and-behavior-events-in-order
|
||||
etaf-behavior-replacement-disposes-previous-installer))
|
||||
(:id event-rules
|
||||
:evidence-mode current-contract
|
||||
:summary "event names normalize keyword/symbol/string on-* spellings; Host callback precedes Behavior callback"
|
||||
:tests (etaf-m0a-event-kind-normalizes-current-spellings
|
||||
etaf-runtime-composes-host-and-behavior-events-in-order))
|
||||
(:id dependency-only-publication
|
||||
:evidence-mode current-contract
|
||||
:summary "semantic generation advances without Ebox commit or TP surface revision"
|
||||
:tests (etaf-m0a-dependency-only-skips-ebox-and-tp-publication))
|
||||
(:id initial-attach
|
||||
:evidence-mode current-contract
|
||||
:summary "initial observed publication reports TP, Ebox, then ETAF"
|
||||
:tests (etaf-runtime-observer-covers-initial-publication))
|
||||
(:id unmount-kill
|
||||
:evidence-mode current-contract
|
||||
:summary "unmount disposes lifecycle before scope cleanup; kill follows unmount; repeated public unmount signals"
|
||||
:tests (etaf-component-lifecycle-and-scope-cleanup-are-ordered
|
||||
etaf-runtime-killed-buffer-unmounts-owned-scope
|
||||
etaf-m0a-repeated-public-unmount-signals-runtime-error))
|
||||
(:id condition-trailer
|
||||
:evidence-mode current-contract
|
||||
:activation-milestone M3a
|
||||
:owner etaf-runtime
|
||||
:summary "postcommit errors preserve the raw condition symbol/data prefix and append the v1 committed trailer"
|
||||
:tests (etaf-m0a-public-update-preserves-raw-condition-symbol-and-data))
|
||||
(:id document-examples
|
||||
:evidence-mode observed-baseline
|
||||
:activation-milestone M0b
|
||||
:owner etaf-documentation
|
||||
:summary "all user-facing fenced Elisp blocks have reviewed read, macroexpand, load-safety, and drift outcomes"
|
||||
:tests (etaf-m0a-document-example-inventory-matches-reviewed-golden)))
|
||||
"Machine-readable M0a ledger for ETAF current behavior and future gates.")
|
||||
|
||||
(defconst etaf-m0a-document-example-files
|
||||
'("README.md"
|
||||
"README.zh-CN.md"
|
||||
"examples/README.md"
|
||||
"examples/README.zh-CN.md"
|
||||
"docs/architecture.en.md"
|
||||
"docs/architecture.zh.md"
|
||||
"docs/user-guide.en.md"
|
||||
"docs/user-guide.zh.md"
|
||||
"docs/implementation-plan.en.md"
|
||||
"docs/implementation-plan.zh.md")
|
||||
"User-facing documents whose fenced Elisp blocks belong to M0a inventory.")
|
||||
|
||||
(defun etaf-m0a--condition-handler-symbols (clause)
|
||||
"Return the condition symbols handled by `condition-case' CLAUSE."
|
||||
(let ((head (car-safe clause)))
|
||||
(cond
|
||||
((symbolp head) (list head))
|
||||
((proper-list-p head) (cl-remove-if-not #'symbolp head))
|
||||
(t nil))))
|
||||
|
||||
(defun etaf-m0a--condition-policy (conditions)
|
||||
"Return the current handling policy for CONDITIONS."
|
||||
(if (cl-every (lambda (condition) (memq condition '(error quit))) conditions)
|
||||
'generic-containment
|
||||
'specific-compatibility))
|
||||
|
||||
(defun etaf-m0a--walk-condition-consumers (form file line)
|
||||
"Return condition consumer records below FORM from FILE at LINE."
|
||||
(let (records)
|
||||
(when (consp form)
|
||||
(unless (memq (car form) '(quote function))
|
||||
(when (memq (car form) '(condition-case condition-case-unless-debug))
|
||||
(dolist (clause (cdddr form))
|
||||
(let ((conditions (etaf-m0a--condition-handler-symbols clause)))
|
||||
(when conditions
|
||||
(push (list :file file :line line :form (car form)
|
||||
:conditions conditions
|
||||
:owner (intern (file-name-base file))
|
||||
:policy (etaf-m0a--condition-policy conditions))
|
||||
records)))))
|
||||
(setq records
|
||||
(nconc records
|
||||
(etaf-m0a--walk-condition-consumers
|
||||
(car form) file line)
|
||||
(etaf-m0a--walk-condition-consumers
|
||||
(cdr form) file line)))))
|
||||
records))
|
||||
|
||||
(defun etaf-m0a-condition-consumer-inventory (&optional directory)
|
||||
"Return condition consumers in top-level ETAF sources under DIRECTORY.
|
||||
|
||||
DIRECTORY defaults to the package root inferred from this script. Test and
|
||||
example files are excluded so this inventory describes product consumers."
|
||||
(let* ((root (file-name-as-directory
|
||||
(expand-file-name
|
||||
(or directory etaf-m0a-package-root))))
|
||||
(files (sort (directory-files root t "\\`etaf-.*\\.el\\'")
|
||||
#'string<))
|
||||
records)
|
||||
(dolist (file files)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(goto-char (point-min))
|
||||
(condition-case nil
|
||||
(while t
|
||||
(let ((line (line-number-at-pos))
|
||||
(form (read (current-buffer))))
|
||||
(setq records
|
||||
(nconc records
|
||||
(etaf-m0a--walk-condition-consumers
|
||||
form (file-relative-name file root) line)))))
|
||||
(end-of-file nil))))
|
||||
(sort records
|
||||
(lambda (left right)
|
||||
(or (string< (plist-get left :file) (plist-get right :file))
|
||||
(and (equal (plist-get left :file) (plist-get right :file))
|
||||
(< (plist-get left :line) (plist-get right :line))))))))
|
||||
|
||||
(defun etaf-m0a-condition-consumer-signatures (&optional directory)
|
||||
"Return stable golden signatures for source consumers under DIRECTORY.
|
||||
|
||||
Line numbers remain available in the diagnostic inventory but are excluded
|
||||
from this signature so unrelated line movement does not rewrite the golden."
|
||||
(mapcar
|
||||
(lambda (entry)
|
||||
(list :file (plist-get entry :file)
|
||||
:form (plist-get entry :form)
|
||||
:conditions (plist-get entry :conditions)
|
||||
:owner (plist-get entry :owner)
|
||||
:policy (plist-get entry :policy)))
|
||||
(etaf-m0a-condition-consumer-inventory directory)))
|
||||
|
||||
(defun etaf-m0a--document-elisp-blocks (file root)
|
||||
"Return fenced Elisp blocks from FILE below ROOT."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents (expand-file-name file root))
|
||||
(goto-char (point-min))
|
||||
(let ((index 0) blocks)
|
||||
(while (re-search-forward "^```elisp[[:space:]]*$" nil t)
|
||||
(let ((line (line-number-at-pos))
|
||||
(start (line-beginning-position 2)))
|
||||
(unless (re-search-forward "^```[[:space:]]*$" nil t)
|
||||
(error "Unclosed Elisp block in %s" file))
|
||||
(cl-incf index)
|
||||
(push (list :index index :line line
|
||||
:source (buffer-substring-no-properties
|
||||
start (match-beginning 0)))
|
||||
blocks)))
|
||||
(nreverse blocks))))
|
||||
|
||||
(defun etaf-m0a--read-document-forms (source)
|
||||
"Read all forms from documentation SOURCE and return a result plist."
|
||||
(with-temp-buffer
|
||||
(emacs-lisp-mode)
|
||||
(insert source)
|
||||
(goto-char (point-min))
|
||||
(let (forms failure)
|
||||
(condition-case condition
|
||||
(while (progn
|
||||
(skip-chars-forward " \t\r\n")
|
||||
(< (point) (point-max)))
|
||||
(push (read (current-buffer)) forms))
|
||||
(error (setq failure (car condition))))
|
||||
(if failure
|
||||
(list :status 'error :detail failure :forms nil)
|
||||
(list :status 'ok :detail (length forms) :forms (nreverse forms))))))
|
||||
|
||||
(defun etaf-m0a--macroexpand-document-forms (forms)
|
||||
"Macroexpand FORMS and return a stable outcome plist."
|
||||
(condition-case condition
|
||||
(progn
|
||||
(mapc #'macroexpand-all forms)
|
||||
(list :status 'ok :detail (length forms)))
|
||||
(error (list :status 'error :detail (car condition)))))
|
||||
|
||||
(defun etaf-m0a-document-example-inventory (&optional directory)
|
||||
"Return current read/macroexpand/load outcomes for user documentation.
|
||||
|
||||
DIRECTORY defaults to `etaf-m0a-package-root'.
|
||||
Arbitrary documentation code is never evaluated in the agent process: it may
|
||||
mount buffers, mutate files, start async work, or depend on user state. Every
|
||||
block therefore has an explicit skipped load outcome and safety reason."
|
||||
(let ((root (file-name-as-directory
|
||||
(expand-file-name (or directory etaf-m0a-package-root)))))
|
||||
(mapcar
|
||||
(lambda (file)
|
||||
(list
|
||||
:file file
|
||||
:blocks
|
||||
(mapcar
|
||||
(lambda (block)
|
||||
(let* ((source (plist-get block :source))
|
||||
(read-result (etaf-m0a--read-document-forms source))
|
||||
(macro-result
|
||||
(if (eq 'ok (plist-get read-result :status))
|
||||
(etaf-m0a--macroexpand-document-forms
|
||||
(plist-get read-result :forms))
|
||||
(list :status 'skipped :detail 'read-failed)))
|
||||
(drift
|
||||
(cond
|
||||
((eq 'error (plist-get read-result :status)) 'read-error)
|
||||
((eq 'error (plist-get macro-result :status))
|
||||
'macroexpand-error)
|
||||
(t 'none))))
|
||||
(list :index (plist-get block :index)
|
||||
:line (plist-get block :line)
|
||||
:sha256 (secure-hash 'sha256 source)
|
||||
:read-status (plist-get read-result :status)
|
||||
:read-detail (plist-get read-result :detail)
|
||||
:macroexpand-status (plist-get macro-result :status)
|
||||
:macroexpand-detail (plist-get macro-result :detail)
|
||||
:load-status 'skipped-unsafe
|
||||
:load-reason 'arbitrary-document-code
|
||||
:drift drift)))
|
||||
(etaf-m0a--document-elisp-blocks file root))))
|
||||
etaf-m0a-document-example-files)))
|
||||
|
||||
(defun etaf-m0a-document-example-signatures (&optional directory)
|
||||
"Return stable golden signatures for documentation under DIRECTORY."
|
||||
(mapcar
|
||||
(lambda (file-entry)
|
||||
(list
|
||||
:file (plist-get file-entry :file)
|
||||
:blocks
|
||||
(mapcar
|
||||
(lambda (block)
|
||||
(list (plist-get block :index)
|
||||
(plist-get block :sha256)
|
||||
(plist-get block :read-status)
|
||||
(plist-get block :read-detail)
|
||||
(plist-get block :macroexpand-status)
|
||||
(plist-get block :macroexpand-detail)
|
||||
(plist-get block :load-status)
|
||||
(plist-get block :load-reason)
|
||||
(plist-get block :drift)))
|
||||
(plist-get file-entry :blocks))))
|
||||
(etaf-m0a-document-example-inventory directory)))
|
||||
|
||||
(defun etaf-m0a-inventory-json (&optional directory)
|
||||
"Return the current M0a ledger and condition inventory as JSON.
|
||||
|
||||
DIRECTORY is forwarded to `etaf-m0a-condition-consumer-inventory'."
|
||||
(json-encode
|
||||
(list :schema-version 1
|
||||
:contract-inventory (vconcat etaf-m0a-current-contract-inventory)
|
||||
:condition-consumers
|
||||
(vconcat (etaf-m0a-condition-consumer-inventory directory))
|
||||
:document-examples
|
||||
(vconcat
|
||||
(mapcar
|
||||
(lambda (entry)
|
||||
(let ((copy (copy-sequence entry)))
|
||||
(plist-put copy :blocks
|
||||
(vconcat (plist-get copy :blocks)))))
|
||||
(etaf-m0a-document-example-inventory directory))))))
|
||||
|
||||
(when noninteractive
|
||||
(when (member "--etaf-m0a-print-inventory" command-line-args-left)
|
||||
(setq command-line-args-left
|
||||
(delete "--etaf-m0a-print-inventory" command-line-args-left))
|
||||
(princ (etaf-m0a-inventory-json))
|
||||
(terpri)))
|
||||
|
||||
(provide 'etaf-m0a-inventory)
|
||||
;;; etaf-m0a-inventory.el ends here
|
||||
@ -1,111 +0,0 @@
|
||||
;;; etaf-m0b-component-manifest.el --- Observed Component contract manifest -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Emit a machine-readable M0b manifest that keeps Component business props,
|
||||
;; forwarded Host attributes, and the single-root forwarding guarantee in
|
||||
;; separate fields. The manifest is emitted only after a real mounted probe.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'json)
|
||||
(require 'etaf)
|
||||
|
||||
(defconst etaf-m0b-component-manifest--dsl-name
|
||||
'etaf-m0b-manifest-dsl-card)
|
||||
|
||||
(defconst etaf-m0b-component-manifest--render-name
|
||||
'etaf-m0b-manifest-render-card)
|
||||
|
||||
(defun etaf-m0b-component-manifest--define-fixtures ()
|
||||
"Define the two manifest probe Components through the public authoring API."
|
||||
(etaf-component-redefine-run
|
||||
(lambda ()
|
||||
(eval
|
||||
'(etaf-define-component etaf-m0b-manifest-dsl-card (&key title)
|
||||
:view
|
||||
(box :class "definition" (text (expr title)))))
|
||||
(eval
|
||||
'(etaf-define-component etaf-m0b-manifest-render-card (&key label)
|
||||
:render
|
||||
(etaf-node 'box (list :class "definition")
|
||||
(list (etaf-node 'text nil (list label)))))))))
|
||||
|
||||
(defun etaf-m0b-component-manifest--spec-props (name)
|
||||
"Return declared business props for Component NAME."
|
||||
(let ((spec (gethash name etaf--view-registry)))
|
||||
(unless (etaf--component-spec-p spec)
|
||||
(error "Manifest fixture is not a Component: %S" name))
|
||||
(mapcar #'symbol-name (etaf--component-spec-props spec))))
|
||||
|
||||
(defun etaf-m0b-component-manifest--mounted-probe (name prop value ref text)
|
||||
"Mount NAME with PROP VALUE and verify forwarded attrs at REF and TEXT."
|
||||
(let ((buffer (generate-new-buffer-name " *etaf-m0b-manifest*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-node name
|
||||
(list prop value :class "caller"
|
||||
:aria-label "manifest-probe" :ref ref)
|
||||
nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(props (etaf-runtime-host-props-for runtime ref)))
|
||||
(unless (and (string-match-p (regexp-quote text)
|
||||
(with-current-buffer buffer
|
||||
(buffer-string)))
|
||||
(member "caller" (plist-get props :class))
|
||||
(equal "manifest-probe"
|
||||
(plist-get props :aria-label)))
|
||||
(error "Mounted Component forwarding probe failed: %S" name)))
|
||||
t)
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer)))
|
||||
(kill-buffer live)))))
|
||||
|
||||
(defun etaf-m0b-component-manifest-data ()
|
||||
"Return the observed M0b Component manifest as an alist."
|
||||
(etaf-m0b-component-manifest--define-fixtures)
|
||||
(let ((dsl-ok
|
||||
(etaf-m0b-component-manifest--mounted-probe
|
||||
etaf-m0b-component-manifest--dsl-name :title "DSL" 'manifest-dsl
|
||||
"DSL"))
|
||||
(render-ok
|
||||
(etaf-m0b-component-manifest--mounted-probe
|
||||
etaf-m0b-component-manifest--render-name :label "Render"
|
||||
'manifest-render "Render"))
|
||||
(attrs '("class" "style/presentation" "layout" "ref"
|
||||
"role/tab-index" "aria-*" "on-*" "use")))
|
||||
`((schema-version . 1)
|
||||
(evidence-mode . "observed")
|
||||
(components
|
||||
. (((name . ,(symbol-name etaf-m0b-component-manifest--dsl-name))
|
||||
(frontend . "view")
|
||||
(declared-business-props
|
||||
. ,(etaf-m0b-component-manifest--spec-props
|
||||
etaf-m0b-component-manifest--dsl-name))
|
||||
(forwarded-host-attrs . ,attrs)
|
||||
(root-shape-forwarding-guarantee
|
||||
. "single attr-capable root only; fragment, text, and multi-root results reject forwarded attrs")
|
||||
(mounted-validation . ,dsl-ok))
|
||||
((name . ,(symbol-name etaf-m0b-component-manifest--render-name))
|
||||
(frontend . "render")
|
||||
(declared-business-props
|
||||
. ,(etaf-m0b-component-manifest--spec-props
|
||||
etaf-m0b-component-manifest--render-name))
|
||||
(forwarded-host-attrs . ,attrs)
|
||||
(root-shape-forwarding-guarantee
|
||||
. "single attr-capable root only; fragment, text, and multi-root results reject forwarded attrs")
|
||||
(mounted-validation . ,render-ok)))))))
|
||||
|
||||
(defun etaf-m0b-component-manifest-write-json ()
|
||||
"Write the observed M0b Component manifest as JSON."
|
||||
(princ (json-encode (etaf-m0b-component-manifest-data))))
|
||||
|
||||
(provide 'etaf-m0b-component-manifest)
|
||||
|
||||
;;; etaf-m0b-component-manifest.el ends here
|
||||
@ -1,322 +0,0 @@
|
||||
// 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)
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -1,335 +0,0 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -eu
|
||||
|
||||
GUI_CORE_SCRIPT_DIR=$(CDPATH= cd "$(dirname "$0")" && pwd)
|
||||
GUI_ENGINE="$GUI_CORE_SCRIPT_DIR/emacs-gui-verifier.el"
|
||||
GUI_RECORDER_SOURCE="$GUI_CORE_SCRIPT_DIR/record-emacs-window.swift"
|
||||
GUI_CAPTURE="$GUI_CORE_SCRIPT_DIR/capture-emacs-window.sh"
|
||||
GUI_EMACS_APP=${EMACS_APP:-/Applications/Emacs.app}
|
||||
GUI_EMACS_BIN="$GUI_EMACS_APP/Contents/MacOS/Emacs"
|
||||
GUI_EMACSCLIENT="$GUI_EMACS_APP/Contents/MacOS/bin/emacsclient"
|
||||
GUI_CODEX_ROOT=${CODEX_HOME:-${HOME}/.codex}
|
||||
GUI_DYNAMIC_SKILL=${EMACS_DYNAMIC_UI_SKILL_DIR:-$GUI_CODEX_ROOT/skills/emacs-dynamic-ui-verification}
|
||||
GUI_CHECKPOINT_EL="$GUI_DYNAMIC_SKILL/scripts/capture-checkpoint.el"
|
||||
GUI_EVIDENCE_PY="$GUI_DYNAMIC_SKILL/scripts/evidence.py"
|
||||
|
||||
usage() {
|
||||
echo "usage:" >&2
|
||||
echo " $0 doctor" >&2
|
||||
echo " $0 review RUN_DIR" >&2
|
||||
echo " $0 run ADAPTER_EL ENTRY_FUNCTION [--initialize-function FUNCTION] [--run-dir DIR] [--load-path DIR]..." >&2
|
||||
exit 2
|
||||
}
|
||||
|
||||
require_file() {
|
||||
[ -f "$1" ] || {
|
||||
echo "required file is missing: $1" >&2
|
||||
exit 1
|
||||
}
|
||||
}
|
||||
|
||||
doctor() {
|
||||
require_file "$GUI_EMACS_BIN"
|
||||
require_file "$GUI_EMACSCLIENT"
|
||||
require_file "$GUI_ENGINE"
|
||||
require_file "$GUI_RECORDER_SOURCE"
|
||||
require_file "$GUI_CAPTURE"
|
||||
require_file "$GUI_CHECKPOINT_EL"
|
||||
require_file "$GUI_EVIDENCE_PY"
|
||||
command -v osascript >/dev/null 2>&1
|
||||
xcrun --find swiftc >/dev/null 2>&1
|
||||
command -v ffmpeg >/dev/null 2>&1
|
||||
command -v python3 >/dev/null 2>&1
|
||||
echo "EMACS-GUI-VERIFIER DOCTOR PASS"
|
||||
}
|
||||
|
||||
review_run() {
|
||||
[ "$#" -eq 1 ] || usage
|
||||
GUI_REVIEW_DIR=$1
|
||||
require_file "$GUI_REVIEW_DIR/manifest.jsonl"
|
||||
require_file "$GUI_REVIEW_DIR/recording.mov"
|
||||
python3 "$GUI_EVIDENCE_PY" finalize \
|
||||
--run-dir "$GUI_REVIEW_DIR" --temporal-reviewed
|
||||
}
|
||||
|
||||
GUI_DAEMON=""
|
||||
GUI_DAEMON_PID=""
|
||||
GUI_RECORDER_PID=""
|
||||
GUI_DAEMON_STARTED=false
|
||||
|
||||
valid_pid() {
|
||||
case $1 in
|
||||
''|*[!0-9]*) return 1 ;;
|
||||
*) [ "$1" -gt 1 ] ;;
|
||||
esac
|
||||
}
|
||||
|
||||
process_alive() {
|
||||
valid_pid "$1" && kill -0 "$1" 2>/dev/null
|
||||
}
|
||||
|
||||
wait_for_exit() {
|
||||
GUI_WAIT_PID=$1
|
||||
GUI_WAIT_LIMIT=$2
|
||||
GUI_WAIT_ATTEMPT=0
|
||||
while process_alive "$GUI_WAIT_PID"; do
|
||||
[ "$GUI_WAIT_ATTEMPT" -lt "$GUI_WAIT_LIMIT" ] || return 1
|
||||
sleep 0.1
|
||||
GUI_WAIT_ATTEMPT=$((GUI_WAIT_ATTEMPT + 1))
|
||||
done
|
||||
}
|
||||
|
||||
force_owned_exit() {
|
||||
GUI_FORCE_PID=$1
|
||||
GUI_FORCE_LABEL=$2
|
||||
process_alive "$GUI_FORCE_PID" || return 0
|
||||
echo "forcing owned $GUI_FORCE_LABEL process to exit: $GUI_FORCE_PID" >&2
|
||||
kill -TERM "$GUI_FORCE_PID" 2>/dev/null || return 1
|
||||
if ! wait_for_exit "$GUI_FORCE_PID" 20; then
|
||||
kill -KILL "$GUI_FORCE_PID" 2>/dev/null || return 1
|
||||
wait_for_exit "$GUI_FORCE_PID" 10 || return 1
|
||||
fi
|
||||
return 0
|
||||
}
|
||||
|
||||
stop_recorder() {
|
||||
[ -n "$GUI_RECORDER_PID" ] || return 0
|
||||
GUI_RECORDER_STOP_FAILED=0
|
||||
if process_alive "$GUI_RECORDER_PID"; then
|
||||
if ! kill -TERM "$GUI_RECORDER_PID"; then
|
||||
GUI_RECORDER_STOP_FAILED=1
|
||||
elif ! wait_for_exit "$GUI_RECORDER_PID" 50; then
|
||||
GUI_RECORDER_STOP_FAILED=1
|
||||
if ! force_owned_exit "$GUI_RECORDER_PID" "window recorder"; then
|
||||
GUI_RECORDER_STOP_FAILED=1
|
||||
fi
|
||||
fi
|
||||
fi
|
||||
if ! wait "$GUI_RECORDER_PID" 2>/dev/null; then
|
||||
GUI_RECORDER_STOP_FAILED=1
|
||||
fi
|
||||
GUI_RECORDER_PID=""
|
||||
[ "$GUI_RECORDER_STOP_FAILED" -eq 0 ]
|
||||
}
|
||||
|
||||
stop_daemon() {
|
||||
[ "$GUI_DAEMON_STARTED" = true ] || return 0
|
||||
GUI_DAEMON_STOP_FAILED=0
|
||||
if ! "$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -e '(kill-emacs 0)' \
|
||||
>"$GUI_RUN_DIR/daemon-shutdown.log" 2>&1; then
|
||||
GUI_DAEMON_STOP_FAILED=1
|
||||
fi
|
||||
if ! wait_for_exit "$GUI_DAEMON_PID" 50; then
|
||||
GUI_DAEMON_STOP_FAILED=1
|
||||
if ! force_owned_exit "$GUI_DAEMON_PID" "Emacs daemon"; then
|
||||
GUI_DAEMON_STOP_FAILED=1
|
||||
fi
|
||||
fi
|
||||
GUI_DAEMON_STARTED=false
|
||||
GUI_DAEMON_PID=""
|
||||
GUI_DAEMON=""
|
||||
[ "$GUI_DAEMON_STOP_FAILED" -eq 0 ]
|
||||
}
|
||||
|
||||
cleanup() {
|
||||
GUI_CLEANUP_FAILED=0
|
||||
if ! stop_recorder; then
|
||||
echo "GUI recorder cleanup failed" >&2
|
||||
GUI_CLEANUP_FAILED=1
|
||||
fi
|
||||
if ! stop_daemon; then
|
||||
echo "GUI daemon cleanup failed" >&2
|
||||
GUI_CLEANUP_FAILED=1
|
||||
fi
|
||||
[ "$GUI_CLEANUP_FAILED" -eq 0 ]
|
||||
}
|
||||
|
||||
on_exit() {
|
||||
GUI_MAIN_STATUS=$?
|
||||
trap - EXIT HUP INT TERM
|
||||
if ! cleanup; then
|
||||
[ "$GUI_MAIN_STATUS" -ne 0 ] || GUI_MAIN_STATUS=1
|
||||
fi
|
||||
exit "$GUI_MAIN_STATUS"
|
||||
}
|
||||
|
||||
trap on_exit EXIT
|
||||
trap 'exit 130' HUP INT TERM
|
||||
|
||||
activate_emacs() {
|
||||
osascript -e "tell application \"System Events\" to set frontmost of first application process whose unix id is $GUI_DAEMON_PID to true"
|
||||
GUI_ACTIVATE_ATTEMPTS=0
|
||||
while [ "$GUI_ACTIVATE_ATTEMPTS" -lt 30 ]; do
|
||||
GUI_FRONTMOST=$(osascript -e \
|
||||
'tell application "System Events" to get unix id of first application process whose frontmost is true')
|
||||
if [ "$GUI_FRONTMOST" = "$GUI_DAEMON_PID" ]; then
|
||||
# macOS fullscreen/Space animations continue after focus changes.
|
||||
sleep 1
|
||||
return 0
|
||||
fi
|
||||
sleep 0.1
|
||||
GUI_ACTIVATE_ATTEMPTS=$((GUI_ACTIVATE_ATTEMPTS + 1))
|
||||
done
|
||||
echo "Emacs did not become the frontmost application" >&2
|
||||
exit 1
|
||||
}
|
||||
|
||||
start_recorder() {
|
||||
"$GUI_RECORDER" "$GUI_DAEMON_PID" "$GUI_RUN_DIR/recording.mov" \
|
||||
"$GUI_RUN_DIR/recorder.ready" \
|
||||
>"$GUI_RUN_DIR/recorder.log" 2>&1 &
|
||||
GUI_RECORDER_PID=$!
|
||||
GUI_RECORDER_ATTEMPTS=0
|
||||
while [ "$GUI_RECORDER_ATTEMPTS" -lt 150 ]; do
|
||||
if ! kill -0 "$GUI_RECORDER_PID" 2>/dev/null; then
|
||||
echo "screen recorder exited before the scenario started" >&2
|
||||
exit 1
|
||||
fi
|
||||
if [ -s "$GUI_RUN_DIR/recorder.ready" ]; then
|
||||
return 0
|
||||
fi
|
||||
sleep 0.1
|
||||
GUI_RECORDER_ATTEMPTS=$((GUI_RECORDER_ATTEMPTS + 1))
|
||||
done
|
||||
echo "window recorder did not produce a verified frame" >&2
|
||||
exit 1
|
||||
}
|
||||
|
||||
parse_run_arguments() {
|
||||
[ "$#" -ge 2 ] || usage
|
||||
GUI_ADAPTER=$1
|
||||
GUI_ENTRY=$2
|
||||
shift 2
|
||||
GUI_RUN_DIR=""
|
||||
GUI_LOAD_PATHS=""
|
||||
GUI_INITIALIZE_FUNCTION=""
|
||||
while [ "$#" -gt 0 ]; do
|
||||
case $1 in
|
||||
--initialize-function)
|
||||
[ "$#" -ge 2 ] || usage
|
||||
GUI_INITIALIZE_FUNCTION=$2
|
||||
shift 2
|
||||
;;
|
||||
--run-dir)
|
||||
[ "$#" -ge 2 ] || usage
|
||||
GUI_RUN_DIR=$2
|
||||
shift 2
|
||||
;;
|
||||
--load-path)
|
||||
[ "$#" -ge 2 ] || usage
|
||||
case $2 in *:*)
|
||||
echo "load path cannot contain a colon: $2" >&2
|
||||
exit 1
|
||||
;;
|
||||
esac
|
||||
if [ -n "$GUI_LOAD_PATHS" ]; then
|
||||
GUI_LOAD_PATHS="$GUI_LOAD_PATHS:$2"
|
||||
else
|
||||
GUI_LOAD_PATHS=$2
|
||||
fi
|
||||
shift 2
|
||||
;;
|
||||
*) usage ;;
|
||||
esac
|
||||
done
|
||||
require_file "$GUI_ADAPTER"
|
||||
if [ -z "$GUI_RUN_DIR" ]; then
|
||||
GUI_RUN_DIR=$(mktemp -d /private/tmp/emacs-gui-verification.XXXXXX)
|
||||
else
|
||||
mkdir -p "$GUI_RUN_DIR"
|
||||
fi
|
||||
if [ -e "$GUI_RUN_DIR/manifest.jsonl" ] || [ -e "$GUI_RUN_DIR/recording.mov" ]; then
|
||||
echo "run directory already contains GUI evidence: $GUI_RUN_DIR" >&2
|
||||
exit 1
|
||||
fi
|
||||
}
|
||||
|
||||
run_adapter() {
|
||||
doctor >/dev/null
|
||||
GUI_RECORDER="$GUI_RUN_DIR/record-emacs-window"
|
||||
xcrun swiftc -parse-as-library -warnings-as-errors -O \
|
||||
"$GUI_RECORDER_SOURCE" -o "$GUI_RECORDER"
|
||||
export ETAF_GUI_RUN_DIR="$GUI_RUN_DIR"
|
||||
export ETAF_GUI_LOAD_PATHS="$GUI_LOAD_PATHS"
|
||||
export ETAF_GUI_ENTRY="$GUI_ENTRY"
|
||||
export ETAF_GUI_INITIALIZE_FUNCTION="$GUI_INITIALIZE_FUNCTION"
|
||||
export SCREENCAPTURE="$GUI_CAPTURE"
|
||||
GUI_DAEMON="emacs-gui-verify-$$"
|
||||
"$GUI_EMACS_BIN" -Q --daemon="$GUI_DAEMON" \
|
||||
--eval '(setq native-comp-jit-compilation nil load-prefer-newer t)'
|
||||
GUI_DAEMON_STARTED=true
|
||||
GUI_DAEMON_PID=$(
|
||||
"$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -e '(emacs-pid)'
|
||||
)
|
||||
valid_pid "$GUI_DAEMON_PID" || {
|
||||
echo "Emacs daemon returned an invalid process id: $GUI_DAEMON_PID" >&2
|
||||
exit 1
|
||||
}
|
||||
"$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -c -e \
|
||||
"(progn
|
||||
(dolist (path (split-string (or (getenv \"ETAF_GUI_LOAD_PATHS\") \"\") path-separator t))
|
||||
(add-to-list 'load-path path))
|
||||
(load \"$GUI_CHECKPOINT_EL\" nil nil t)
|
||||
(load \"$GUI_ENGINE\" nil nil t)
|
||||
(load \"$GUI_ADAPTER\" nil nil t)
|
||||
(when (fboundp 'tool-bar-mode) (tool-bar-mode -1))
|
||||
(when (fboundp 'menu-bar-mode) (menu-bar-mode -1))
|
||||
(when (fboundp 'scroll-bar-mode) (scroll-bar-mode -1))
|
||||
(setenv \"ETAF_GUI_CAPTURE_PID\" (number-to-string (emacs-pid)))
|
||||
(set-frame-parameter nil 'fullscreen 'fullboth)
|
||||
(when-let* ((initialize (getenv \"ETAF_GUI_INITIALIZE_FUNCTION\"))
|
||||
((> (length initialize) 0)))
|
||||
(funcall (intern initialize)))
|
||||
(select-frame-set-input-focus (selected-frame))
|
||||
(message nil)
|
||||
(redisplay t)
|
||||
t)" >"$GUI_RUN_DIR/bootstrap.out"
|
||||
activate_emacs
|
||||
start_recorder
|
||||
"$GUI_EMACSCLIENT" -n -s "$GUI_DAEMON" -e \
|
||||
'(funcall (intern (getenv "ETAF_GUI_ENTRY")))' \
|
||||
>"$GUI_RUN_DIR/scenario.out"
|
||||
stop_recorder
|
||||
require_file "$GUI_RUN_DIR/recording.mov"
|
||||
[ -s "$GUI_RUN_DIR/recording.mov" ] || {
|
||||
echo "screen recording is empty" >&2
|
||||
exit 1
|
||||
}
|
||||
stop_daemon
|
||||
|
||||
set +e
|
||||
python3 "$GUI_EVIDENCE_PY" finalize --run-dir "$GUI_RUN_DIR" \
|
||||
>"$GUI_RUN_DIR/finalize.out" 2>&1
|
||||
GUI_FINALIZE_STATUS=$?
|
||||
set -e
|
||||
cat "$GUI_RUN_DIR/finalize.out"
|
||||
if [ "$GUI_FINALIZE_STATUS" -eq 1 ]; then
|
||||
echo "GUI verification assertions failed: $GUI_RUN_DIR" >&2
|
||||
exit 1
|
||||
fi
|
||||
if [ "$GUI_FINALIZE_STATUS" -ne 2 ]; then
|
||||
echo "fresh capture unexpectedly bypassed temporal review" >&2
|
||||
exit 1
|
||||
fi
|
||||
echo "EMACS-GUI-VERIFIER CAPTURE COMPLETE verdict=INCOMPLETE entry=$GUI_ENTRY run-dir=$GUI_RUN_DIR"
|
||||
}
|
||||
|
||||
[ "$#" -ge 1 ] || usage
|
||||
GUI_COMMAND=$1
|
||||
shift
|
||||
|
||||
case $GUI_COMMAND in
|
||||
doctor)
|
||||
[ "$#" -eq 0 ] || usage
|
||||
doctor
|
||||
;;
|
||||
review)
|
||||
review_run "$@"
|
||||
;;
|
||||
run)
|
||||
parse_run_arguments "$@"
|
||||
run_adapter
|
||||
;;
|
||||
*) usage ;;
|
||||
esac
|
||||
@ -5,6 +5,10 @@
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
|
||||
(defmacro etaf-compiler-test--legacy-view (form)
|
||||
"Construct FORM through the pre-compiler View expansion for comparison."
|
||||
(etaf--compile-view-form form :projection))
|
||||
|
||||
(defun etaf-compiler-test--canonical (value)
|
||||
"Return VALUE as comparable View data, resolving lazy holes once."
|
||||
(cond
|
||||
@ -23,31 +27,42 @@
|
||||
((null value) nil)
|
||||
(t value)))
|
||||
|
||||
(defun etaf-compiler-test--interpreted (color text)
|
||||
"Return an interpreted fixture using COLOR and TEXT."
|
||||
(etaf-compiler-test--legacy-view
|
||||
(column :color color
|
||||
(column :padding '(1 2)
|
||||
(text "static"))
|
||||
(text (expr :value text)))))
|
||||
|
||||
(defun etaf-compiler-test--lowered (color text)
|
||||
"Return an automatically lowered fixture using COLOR and TEXT."
|
||||
(etaf-view
|
||||
(column :color color
|
||||
(column :padding '(1 2)
|
||||
(text "static"))
|
||||
(text (expr text)))))
|
||||
(text (expr :value text)))))
|
||||
|
||||
(defun etaf-compiler-test--slot-view ()
|
||||
"Return a blueprint-backed View containing a slot projection."
|
||||
(defun etaf-compiler-test--fallback-view ()
|
||||
"Return a View containing unsupported slot grammar."
|
||||
(etaf-view
|
||||
(column (slot (text "fallback")))))
|
||||
|
||||
(ert-deftest etaf-automatic-view-slot-uses-current-blueprint-abi ()
|
||||
"Slot projection is a `/2' block and never takes a compatibility path."
|
||||
(let* ((before (plist-get (etaf-compiler-statistics) :instantiations))
|
||||
(view (etaf-compiler-test--slot-view))
|
||||
(after (etaf-compiler-statistics))
|
||||
(root (plist-get etaf-compiler--last-blueprint :root)))
|
||||
(should (etaf--slot-projection-p
|
||||
(car (etaf--view-node-children view))))
|
||||
(should (eq 'slot
|
||||
(plist-get (car (plist-get root :children)) :kind)))
|
||||
(should (= (1+ before) (plist-get after :instantiations)))
|
||||
(should-not (plist-member after :fallbacks))))
|
||||
(defun etaf-compiler-test--fallback-reference ()
|
||||
"Return the interpreted reference for `etaf-compiler-test--fallback-view'."
|
||||
(etaf-compiler-test--legacy-view
|
||||
(column (slot (text "fallback")))))
|
||||
|
||||
(ert-deftest etaf-automatic-view-fallback-is-exact ()
|
||||
"An unsupported slot keeps the existing View semantics."
|
||||
(let ((before (plist-get (etaf-compiler-statistics) :fallbacks)))
|
||||
(should
|
||||
(equal (etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--fallback-view))
|
||||
(etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--fallback-reference))))
|
||||
(should (= (1+ before)
|
||||
(plist-get (etaf-compiler-statistics) :fallbacks)))))
|
||||
|
||||
(defun etaf-compiler-test--lowered-supported (color)
|
||||
"Return a supported automatically lowered fixture using COLOR."
|
||||
@ -58,18 +73,22 @@
|
||||
(text "static-b"))
|
||||
(text :color "blue" "tail"))))
|
||||
|
||||
(defun etaf-compiler-test--interpreted-supported (color)
|
||||
"Return the matching interpreted fixture using COLOR."
|
||||
(etaf-compiler-test--legacy-view
|
||||
(column :color color
|
||||
(column :padding '(1 2)
|
||||
(text "static-a")
|
||||
(text "static-b"))
|
||||
(text :color "blue" "tail"))))
|
||||
|
||||
(ert-deftest etaf-automatic-view-supported-output-is-exact ()
|
||||
"A blueprint produces the exact normalized typed View data."
|
||||
"A supported blueprint produces the same normalized View data."
|
||||
(should
|
||||
(equal (etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--lowered-supported "green"))
|
||||
'(:host column :props (:color "green")
|
||||
:children
|
||||
((:host column :props (:padding (1 2))
|
||||
:children
|
||||
((:host text :props nil :children ("static-a"))
|
||||
(:host text :props nil :children ("static-b"))))
|
||||
(:host text :props (:color "blue") :children ("tail")))))))
|
||||
(etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--interpreted-supported "green")))))
|
||||
|
||||
(ert-deftest etaf-automatic-view-reuses-static-subtrees ()
|
||||
"Repeated instantiation reuses a static child while rebuilding its root."
|
||||
@ -92,7 +111,14 @@
|
||||
(cl-incf calls)
|
||||
(apply original arguments))))
|
||||
(etaf-compiler-test--lowered-supported "next"))
|
||||
(should (= calls 1))))
|
||||
(should (= calls 1))
|
||||
(setq calls 0)
|
||||
(cl-letf (((symbol-function 'etaf--view-call)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf calls)
|
||||
(apply original arguments))))
|
||||
(etaf-compiler-test--interpreted-supported "next"))
|
||||
(should (> calls 1))))
|
||||
|
||||
(ert-deftest etaf-automatic-view-exposes-blueprint-coverage ()
|
||||
"The compiler reports static nodes, dynamic paths, and holes."
|
||||
@ -113,7 +139,7 @@
|
||||
"Expr becomes one dynamic child program without forcing root fallback."
|
||||
(pcase-let* ((`(,blueprint . ,programs)
|
||||
(etaf-compiler--compile
|
||||
'(column (text (expr value)))))
|
||||
'(column (text (expr :value value)))))
|
||||
(root (plist-get blueprint :root))
|
||||
(text-block (car (plist-get root :children)))
|
||||
(expr-block (car (plist-get text-block :children))))
|
||||
@ -121,29 +147,5 @@
|
||||
(should-not (plist-get root :static-p))
|
||||
(should (= (length programs) 1))))
|
||||
|
||||
(ert-deftest etaf-automatic-view-directives-are-blueprint-blocks ()
|
||||
"Branch and keyed list topology are represented inside the `/2' blueprint."
|
||||
(pcase-let* ((`(,blueprint . ,programs)
|
||||
(etaf-compiler--compile
|
||||
'(column
|
||||
(text :if selected "selected")
|
||||
(text :else t "empty")
|
||||
(row :for (item items) :key (car item)
|
||||
(text (expr (cdr item)))))))
|
||||
(children (plist-get (plist-get blueprint :root) :children)))
|
||||
(should (equal '(branch keyed-list)
|
||||
(mapcar (lambda (block) (plist-get block :kind)) children)))
|
||||
(should (= 2 (length programs)))
|
||||
(should (= 2 (plist-get blueprint :hole-count)))))
|
||||
|
||||
(ert-deftest etaf-automatic-view-rejects-stale-blueprint-abi ()
|
||||
"A stale View IR requests a clean rebuild instead of compatibility."
|
||||
(let ((blueprint
|
||||
(list :kind 'etaf/view-blueprint
|
||||
:abi "etaf-view-blueprint/1"
|
||||
:id "stale" :root nil :hole-count 0)))
|
||||
(should-error (etaf-compiler-instantiate blueprint [])
|
||||
:type 'error)))
|
||||
|
||||
(provide 'etaf-compiler-tests)
|
||||
;;; etaf-compiler-tests.el ends here
|
||||
|
||||
@ -1,715 +0,0 @@
|
||||
;;; etaf-component-frontends-tests.el --- Component frontend contract -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
|
||||
(defvar etaf-test-g6b-dsl-setup-count 0)
|
||||
(defvar etaf-test-g6b-code-setup-count 0)
|
||||
(defvar etaf-test-g6b-lifecycle nil)
|
||||
|
||||
(etaf-define-component etaf-test-g6b-dsl-counter (&key initial)
|
||||
:setup
|
||||
(progn
|
||||
(cl-incf etaf-test-g6b-dsl-setup-count)
|
||||
(etaf-ref (or initial 0)))
|
||||
:view
|
||||
(column :background-color "#102030" :padding-inline 1
|
||||
(text :font-weight 'bold
|
||||
(expr (format "Count %d" (etaf-value (etaf-state)))))
|
||||
(box :ref 'g6b-dsl-increment
|
||||
:on-press
|
||||
(let ((count (etaf-state)))
|
||||
(lambda ()
|
||||
(setf (etaf-value count) (1+ (etaf-value count)))))
|
||||
"Increment")))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-code-counter (&key initial)
|
||||
:setup
|
||||
(progn
|
||||
(cl-incf etaf-test-g6b-code-setup-count)
|
||||
(etaf-ref (or initial 0)))
|
||||
:render
|
||||
(let ((count (etaf-state)))
|
||||
(etaf-node
|
||||
'column (list :background-color "#102030" :padding-inline 1)
|
||||
(list
|
||||
(etaf-node 'text (list :font-weight 'bold)
|
||||
(list (format "Count %d" (etaf-value count))))
|
||||
(etaf-node
|
||||
'box
|
||||
(list :ref 'g6b-code-increment
|
||||
:on-press
|
||||
(lambda ()
|
||||
(setf (etaf-value count) (1+ (etaf-value count)))))
|
||||
(list "Increment"))))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-nil-state ()
|
||||
:setup nil
|
||||
:view (text (expr (if (null (etaf-state)) "nil-state" "bad-state"))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-directives (&key selected items)
|
||||
:view
|
||||
(column
|
||||
(text :if selected :key 'selected (expr selected))
|
||||
(text :else t :key 'empty "No selection")
|
||||
(row :for (item items) :key (car item)
|
||||
(text (expr (cdr item))))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-pair (&key item)
|
||||
:view
|
||||
(fragment
|
||||
(text (expr (format "%s-1" (cdr item))))
|
||||
(text (expr (format "%s-2" (cdr item))))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-component-loop (&key items)
|
||||
:view
|
||||
(column
|
||||
(etaf-test-g6b-pair :for (item items) :key (car item) :item item)))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-key-boundary (&key value)
|
||||
:setup
|
||||
(list :framework-key (etaf-current-prop 'key) :initial value)
|
||||
:view
|
||||
(text
|
||||
(expr
|
||||
(format "%s/%s"
|
||||
(plist-get (etaf-state) :initial)
|
||||
(or (plist-get (etaf-state) :framework-key) "no-key")))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-invalid-list-result ()
|
||||
:render
|
||||
(list (etaf-node 'text nil (list "ambiguous"))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-rollback (&key fail)
|
||||
:setup (etaf-ref 7)
|
||||
:render
|
||||
(let ((state (etaf-state)))
|
||||
(when fail
|
||||
(setf (etaf-value state) 99))
|
||||
(etaf-node 'text nil (list (format "Stable %d" (etaf-value state))))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-lifecycle (&key label)
|
||||
:setup
|
||||
(progn
|
||||
(etaf-on-mounted
|
||||
(lambda ()
|
||||
(setq etaf-test-g6b-lifecycle
|
||||
(append etaf-test-g6b-lifecycle '(mounted)))))
|
||||
(etaf-on-updated
|
||||
(lambda ()
|
||||
(setq etaf-test-g6b-lifecycle
|
||||
(append etaf-test-g6b-lifecycle '(updated)))))
|
||||
(etaf-on-unmounted
|
||||
(lambda ()
|
||||
(setq etaf-test-g6b-lifecycle
|
||||
(append etaf-test-g6b-lifecycle '(unmounted)))))
|
||||
(etaf-on-scope-dispose
|
||||
(lambda ()
|
||||
(setq etaf-test-g6b-lifecycle
|
||||
(append etaf-test-g6b-lifecycle '(cleanup)))))
|
||||
nil)
|
||||
:view (text (expr label)))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-provider (&key count on-press)
|
||||
:setup
|
||||
(progn
|
||||
(etaf-provide 'g6b-message "Context")
|
||||
(etaf-theme-provide '(:color "#34D399"))
|
||||
nil)
|
||||
:view (column (etaf-test-g6b-context-action :count count :on-press on-press)))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-context-action (&key count on-press)
|
||||
:render
|
||||
(etaf-node
|
||||
'box
|
||||
(list :class '(g6b-context-action)
|
||||
:ref 'g6b-context-action
|
||||
:use (etaf-focusable)
|
||||
:on-press on-press)
|
||||
(list (format "%s %d" (etaf-inject 'g6b-message "missing") count)))
|
||||
:styles
|
||||
(styles
|
||||
(".g6b-context-action" :background-color "#1F2937")))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-attr-leaf (&key label)
|
||||
:view
|
||||
(box :class '(leaf base) :color "#111111"
|
||||
(text (expr label))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-attr-wrapper (&key label)
|
||||
:view
|
||||
(etaf-test-g6b-attr-leaf :label label))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-attr-fragment ()
|
||||
:view
|
||||
(fragment (text "One") (text "Two")))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-attr-text ()
|
||||
:view (text "Text"))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-attr-role ()
|
||||
:view (box :role 'button "Role"))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-attr-shape (&key split)
|
||||
:render
|
||||
(if split
|
||||
(etaf-node 'fragment nil
|
||||
(list (etaf-node 'text nil (list "One"))
|
||||
(etaf-node 'text nil (list "Two"))))
|
||||
(etaf-node 'box nil (list "Stable"))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-dsl-panel ()
|
||||
:view
|
||||
(column :background-color "#203040" :padding-inline 1
|
||||
(row :class 'header (slot :name 'header))
|
||||
(box (slot))
|
||||
(row :class 'actions (slot :name 'actions))))
|
||||
|
||||
(etaf-define-component etaf-test-g6b-code-panel ()
|
||||
:render
|
||||
(etaf-node
|
||||
'column (list :background-color "#203040" :padding-inline 1)
|
||||
(list
|
||||
(etaf-node 'row (list :class 'header)
|
||||
(etaf-current-slot 'header))
|
||||
(etaf-node 'box nil (etaf-current-slot 'default))
|
||||
(etaf-node 'row (list :class 'actions)
|
||||
(etaf-current-slot 'actions)))))
|
||||
|
||||
(defun etaf-test-g6b-dsl-counter (&rest _arguments)
|
||||
"Ordinary Elisp function colliding with a Component registry name."
|
||||
'ordinary-function)
|
||||
|
||||
(defun etaf-test-g6b--text (buffer)
|
||||
"Return BUFFER text without properties."
|
||||
(with-current-buffer buffer
|
||||
(substring-no-properties (buffer-string))))
|
||||
|
||||
(defun etaf-test-g6b--face-at (buffer regexp)
|
||||
"Return BUFFER face at the first REGEXP match."
|
||||
(with-current-buffer buffer
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(re-search-forward regexp)
|
||||
(get-text-property (match-beginning 0) 'face))))
|
||||
|
||||
(defun etaf-test-g6b--face-value (face property)
|
||||
"Return PROPERTY from anonymous FACE values."
|
||||
(cond
|
||||
((and (listp face) (keywordp (car-safe face)))
|
||||
(plist-get face property))
|
||||
((listp face)
|
||||
(cl-loop for entry in face
|
||||
when (and (listp entry) (keywordp (car-safe entry))
|
||||
(plist-member entry property))
|
||||
return (plist-get entry property)))))
|
||||
|
||||
(ert-deftest etaf-component-frontends-definition-boundary-is-strict ()
|
||||
"Definitions choose one frontend and keep exact registry names."
|
||||
(should (etaf--component-spec-p
|
||||
(gethash 'etaf-test-g6b-dsl-counter etaf--view-registry)))
|
||||
(should-not (gethash 'test-g6b-dsl-counter etaf--view-registry))
|
||||
(should (eq 'ordinary-function (etaf-test-g6b-dsl-counter)))
|
||||
(dolist
|
||||
(definition
|
||||
'((etaf-define-component invalid-both ()
|
||||
:view (box) :render (etaf-node 'box nil nil))
|
||||
(etaf-define-component invalid-neither () :setup nil)
|
||||
(etaf-define-component invalid-reserved (&key key) :view (box))
|
||||
(etaf-define-component invalid-setup-view ()
|
||||
:setup (etaf-node 'box nil nil) :view (box))))
|
||||
(should-error (macroexpand definition)
|
||||
:type 'etaf-component-definition-error)))
|
||||
|
||||
(ert-deftest etaf-node-validates-code-mode-structure ()
|
||||
"Code nodes accept typed values and reject DSL or raw-list ambiguity."
|
||||
(should (etaf--view-node-p
|
||||
(etaf-node 'box (list :padding 1) (list "A"))))
|
||||
(should (etaf--component-call-p
|
||||
(etaf-node 'etaf-test-g6b-dsl-counter
|
||||
(list :initial 1) nil)))
|
||||
(should-error (etaf-node 'box (list :if t) nil)
|
||||
:type 'etaf-component-call-error)
|
||||
(should-error (etaf-node 'box nil '((text "raw")))
|
||||
:type 'etaf-component-call-error)
|
||||
(should-error (etaf-node 'box nil nil '((header . ("H"))))
|
||||
:type 'etaf-component-call-error)
|
||||
(should-error (etaf-node 'box (list :key nil) nil)
|
||||
:type 'etaf-component-call-error))
|
||||
|
||||
(ert-deftest etaf-component-directives-validate-branch-and-loop-grammar ()
|
||||
"DSL directives reject ambiguous structure during macro expansion."
|
||||
(dolist
|
||||
(form
|
||||
'((etaf-view (column (text :else t "orphan")))
|
||||
(etaf-view
|
||||
(column (text :if t :for (item '(1)) :key item "bad")))
|
||||
(etaf-view (column (text :for (item '(1)) "missing key")))
|
||||
(etaf-view
|
||||
(column (text :if nil "a") (text :else maybe "b")))))
|
||||
(should-error (macroexpand form) :type 'etaf-view-syntax-error)))
|
||||
|
||||
(ert-deftest etaf-component-directives-render-and-retain-keyed-identity ()
|
||||
"Branch changes and keyed reorder publish locally with stable item ids."
|
||||
(let ((buffer " *etaf-g6b-directives*")
|
||||
(selected (etaf-ref nil))
|
||||
(items (etaf-ref '((a . "A") (b . "B")))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-g6b-directives
|
||||
:selected (etaf-value selected)
|
||||
:items (etaf-value items)))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(range
|
||||
(cl-loop for _identity being the hash-keys of
|
||||
(etaf-generation-identity-index generation)
|
||||
using (hash-values semantic-id)
|
||||
for semantic = (etaf--pvec-get
|
||||
(etaf-generation-semantic-nodes
|
||||
generation)
|
||||
semantic-id)
|
||||
when (and (etaf--semantic-range-p semantic)
|
||||
(etaf--semantic-range-keyed-key-order
|
||||
semantic))
|
||||
return semantic))
|
||||
(a-roots
|
||||
(gethash
|
||||
'a
|
||||
(etaf--semantic-range-keyed-item-root-id-index range)))
|
||||
(b-roots
|
||||
(gethash
|
||||
'b
|
||||
(etaf--semantic-range-keyed-item-root-id-index range))))
|
||||
(should (string-match-p "No selection"
|
||||
(etaf-test-g6b--text buffer)))
|
||||
(should (string-match-p "A[[:space:]]+B"
|
||||
(etaf-test-g6b--text buffer)))
|
||||
(setf (etaf-value selected) "Selected")
|
||||
(setf (etaf-value items) '((b . "B2") (a . "A")))
|
||||
(should (string-match-p "Selected"
|
||||
(etaf-test-g6b--text buffer)))
|
||||
(should (string-match-p "B2[[:space:]]+A"
|
||||
(etaf-test-g6b--text buffer)))
|
||||
(let* ((generation (etaf-runtime-current-generation runtime))
|
||||
(next (etaf--pvec-get
|
||||
(etaf-generation-semantic-nodes generation)
|
||||
(etaf--semantic-range-semantic-id range))))
|
||||
(should
|
||||
(equal
|
||||
a-roots
|
||||
(gethash
|
||||
'a
|
||||
(etaf--semantic-range-keyed-item-root-id-index next))))
|
||||
(should
|
||||
(equal
|
||||
b-roots
|
||||
(gethash
|
||||
'b
|
||||
(etaf--semantic-range-keyed-item-root-id-index next)))))
|
||||
(let ((generation (etaf-runtime-current-generation runtime))
|
||||
(text (with-current-buffer buffer (buffer-string))))
|
||||
(should-error
|
||||
(setf (etaf-value items) '((a . "A") (a . "duplicate")))
|
||||
:type 'etaf-component-call-error)
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (equal-including-properties
|
||||
text (with-current-buffer buffer (buffer-string)))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-keyed-loop-owns-transparent-component-spans ()
|
||||
"A keyed item may be a transparent multi-root Component without a fake Box."
|
||||
(let ((buffer " *etaf-g6b-component-spans*")
|
||||
(items (etaf-ref '((a . "A") (b . "B")))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-g6b-component-loop :items (etaf-value items)))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(range
|
||||
(cl-loop for _identity being the hash-keys of
|
||||
(etaf-generation-identity-index generation)
|
||||
using (hash-values semantic-id)
|
||||
for semantic =
|
||||
(etaf--pvec-get
|
||||
(etaf-generation-semantic-nodes generation)
|
||||
semantic-id)
|
||||
when (and (etaf--semantic-range-p semantic)
|
||||
(equal
|
||||
'(a b)
|
||||
(etaf--semantic-range-keyed-key-order
|
||||
semantic)))
|
||||
return semantic))
|
||||
(root-index
|
||||
(etaf--semantic-range-keyed-item-root-id-index range))
|
||||
(a-roots (copy-sequence (gethash 'a root-index)))
|
||||
(b-roots (copy-sequence (gethash 'b root-index))))
|
||||
(should (string-match-p
|
||||
"A-1[[:space:]]+A-2[[:space:]]+B-1[[:space:]]+B-2"
|
||||
(etaf-test-g6b--text buffer)))
|
||||
(should (= 1 (length a-roots)))
|
||||
(should (= 1 (length b-roots)))
|
||||
(should
|
||||
(etaf--semantic-component-p
|
||||
(etaf--pvec-get
|
||||
(etaf-generation-semantic-nodes generation) (car a-roots))))
|
||||
(setf (etaf-value items) '((b . "B2") (a . "A")))
|
||||
(setq generation (etaf-runtime-current-generation runtime)
|
||||
range
|
||||
(etaf--pvec-get
|
||||
(etaf-generation-semantic-nodes generation)
|
||||
(etaf--semantic-range-semantic-id range))
|
||||
root-index
|
||||
(etaf--semantic-range-keyed-item-root-id-index range))
|
||||
(should (string-match-p
|
||||
"B2-1[[:space:]]+B2-2[[:space:]]+A-1[[:space:]]+A-2"
|
||||
(etaf-test-g6b--text buffer)))
|
||||
(should (equal a-roots (gethash 'a root-index)))
|
||||
(should (equal b-roots (gethash 'b root-index)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-frontends-project-default-and-named-slots ()
|
||||
"DSL and code Components preserve caller-owned slot order and styling."
|
||||
(let ((dsl-buffer " *etaf-g6b-dsl-slots*")
|
||||
(code-buffer " *etaf-g6b-code-slots*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
dsl-buffer
|
||||
(etaf-view
|
||||
(etaf-test-g6b-dsl-panel
|
||||
(slot :name 'header (text :font-weight 'bold "Header"))
|
||||
(slot :name 'actions "Actions")
|
||||
"Body")))
|
||||
(etaf-mount
|
||||
code-buffer
|
||||
(etaf-node
|
||||
'etaf-test-g6b-code-panel nil (list "Body")
|
||||
(list
|
||||
(cons 'header
|
||||
(list (etaf-node 'text (list :font-weight 'bold)
|
||||
(list "Header"))))
|
||||
(cons 'actions (list "Actions")))))
|
||||
(dolist (buffer (list dsl-buffer code-buffer))
|
||||
(let ((text (etaf-test-g6b--text buffer)))
|
||||
(should (string-match-p
|
||||
"Header[[:space:]]+Body[[:space:]]+Actions" text)))
|
||||
(should (eq 'bold
|
||||
(etaf-test-g6b--face-value
|
||||
(etaf-test-g6b--face-at buffer "Header")
|
||||
:weight)))))
|
||||
(dolist (buffer-name (list dsl-buffer code-buffer))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(ert-deftest etaf-component-frontends-render-state-layout-style-and-events ()
|
||||
"DSL and code Components mount equivalent stateful interactive surfaces."
|
||||
(setq etaf-test-g6b-dsl-setup-count 0
|
||||
etaf-test-g6b-code-setup-count 0)
|
||||
(let ((dsl-buffer " *etaf-g6b-dsl*")
|
||||
(code-buffer " *etaf-g6b-code*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount dsl-buffer
|
||||
(etaf-view
|
||||
(etaf-test-g6b-dsl-counter :initial 1)))
|
||||
(etaf-mount code-buffer
|
||||
(etaf-node 'etaf-test-g6b-code-counter
|
||||
(list :initial 1) nil))
|
||||
(should (= 1 etaf-test-g6b-dsl-setup-count))
|
||||
(should (= 1 etaf-test-g6b-code-setup-count))
|
||||
(dolist (buffer (list dsl-buffer code-buffer))
|
||||
(let ((text (etaf-test-g6b--text buffer)))
|
||||
(should (string-match-p "Count 1" text))
|
||||
(should (string-match-p "Increment" text))
|
||||
(should (= 2 (length (split-string text "\n" t)))))
|
||||
(should (eq 'bold
|
||||
(etaf-test-g6b--face-value
|
||||
(etaf-test-g6b--face-at buffer "Count 1")
|
||||
:weight))))
|
||||
(let* ((dsl-runtime (etaf-runtime-for-buffer dsl-buffer))
|
||||
(code-runtime (etaf-runtime-for-buffer code-buffer))
|
||||
(dsl-instance
|
||||
(car (hash-table-values (etaf-runtime-instances dsl-runtime))))
|
||||
(code-instance
|
||||
(car (hash-table-values (etaf-runtime-instances code-runtime)))))
|
||||
(etaf-dispatch-event dsl-runtime 'g6b-dsl-increment 'press)
|
||||
(etaf-dispatch-event code-runtime 'g6b-code-increment 'press)
|
||||
(should (string-match-p "Count 2"
|
||||
(etaf-test-g6b--text dsl-buffer)))
|
||||
(should (string-match-p "Count 2"
|
||||
(etaf-test-g6b--text code-buffer)))
|
||||
(should (= 1 etaf-test-g6b-dsl-setup-count))
|
||||
(should (= 1 etaf-test-g6b-code-setup-count))
|
||||
(should (eq dsl-instance
|
||||
(car (hash-table-values
|
||||
(etaf-runtime-instances dsl-runtime)))))
|
||||
(should (eq code-instance
|
||||
(car (hash-table-values
|
||||
(etaf-runtime-instances code-runtime)))))))
|
||||
(dolist (buffer-name (list dsl-buffer code-buffer))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(ert-deftest etaf-component-state-distinguishes-nil-from-no-setup ()
|
||||
"A completed setup may return nil without becoming setup absence."
|
||||
(let ((buffer " *etaf-g6b-nil-state*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer (etaf-view (etaf-test-g6b-nil-state)))
|
||||
(should (equal "nil-state" (etaf-test-g6b--text buffer))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live))))
|
||||
(should-error (etaf-state) :type 'etaf-component-definition-error))
|
||||
|
||||
(ert-deftest etaf-component-key-is-framework-owned-and-render-result-is-typed ()
|
||||
"Identity metadata stays outside business props and node lists stay invalid."
|
||||
(let ((buffer " *etaf-g6b-key-boundary*")
|
||||
(invalid-buffer " *etaf-g6b-invalid-result*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(etaf-test-g6b-key-boundary :key 'stable :value "Business")))
|
||||
(should (string-match-p "Business/no-key"
|
||||
(etaf-test-g6b--text buffer)))
|
||||
(should-error
|
||||
(etaf-mount
|
||||
invalid-buffer
|
||||
(etaf-view (etaf-test-g6b-invalid-list-result)))
|
||||
:type 'etaf-component-call-error))
|
||||
(dolist (buffer-name (list buffer invalid-buffer))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer-name))) (kill-buffer live))))))
|
||||
|
||||
(ert-deftest etaf-component-render-side-effect-rolls-back-completely ()
|
||||
"A detectable render mutation preserves the published generation and state."
|
||||
(let ((buffer " *etaf-g6b-render-rollback*")
|
||||
(fail (etaf-ref nil)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-g6b-rollback :fail (etaf-value fail)))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(published (with-current-buffer buffer (buffer-string)))
|
||||
(instance
|
||||
(car (hash-table-values (etaf-runtime-instances runtime))))
|
||||
(state (etaf--component-instance-state instance)))
|
||||
(should-error (setf (etaf-value fail) t)
|
||||
:type 'etaf-render-write-error)
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (equal-including-properties
|
||||
published (with-current-buffer buffer (buffer-string))))
|
||||
(should (= 7 (etaf-value state)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-lifecycle-and-scope-cleanup-are-ordered ()
|
||||
"Mount, update, removal, and Scope cleanup each run once in order."
|
||||
(let ((buffer " *etaf-g6b-lifecycle*")
|
||||
(label (etaf-ref "A")))
|
||||
(setq etaf-test-g6b-lifecycle nil)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-g6b-lifecycle :label (etaf-value label)))))
|
||||
(should (equal '(mounted) etaf-test-g6b-lifecycle))
|
||||
(setf (etaf-value label) "B")
|
||||
(should (equal '(mounted updated) etaf-test-g6b-lifecycle))
|
||||
(should (string-match-p "B" (etaf-test-g6b--text buffer)))
|
||||
(etaf-unmount (etaf-runtime-for-buffer buffer))
|
||||
(should (equal '(mounted updated unmounted cleanup)
|
||||
etaf-test-g6b-lifecycle)))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-frontends-compose-context-theme-style-and-behavior ()
|
||||
"Test child inheritance and composition; separate tests cover slot authors."
|
||||
(let ((buffer " *etaf-g6b-composition*")
|
||||
(count (etaf-ref 0)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-g6b-provider
|
||||
:count (etaf-value count)
|
||||
:on-press
|
||||
(let ((source count))
|
||||
(lambda ()
|
||||
(setf (etaf-value source)
|
||||
(1+ (etaf-value source)))))))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(face (etaf-test-g6b--face-at buffer "Context 0"))
|
||||
(props
|
||||
(etaf-runtime-host-props-for
|
||||
runtime 'g6b-context-action)))
|
||||
(should (equal "#34D399"
|
||||
(etaf-test-g6b--face-value face :foreground)))
|
||||
(should (equal "#1F2937"
|
||||
(etaf-test-g6b--face-value face :background)))
|
||||
(should (= 0 (plist-get props :tab-index)))
|
||||
(etaf-dispatch-event runtime 'g6b-context-action 'press)
|
||||
(should (string-match-p "Context 1"
|
||||
(etaf-test-g6b--text buffer)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-host-attrs-fall-through-one-root-chain ()
|
||||
"Undeclared Host attrs cross a root Component chain without entering props."
|
||||
(let ((buffer " *etaf-g6b-attrs*")
|
||||
(color (etaf-ref "#224466")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-g6b-attr-wrapper
|
||||
:label "Leaf" :class '(caller base)
|
||||
:color (etaf-value color) :padding-inline 2
|
||||
:ref 'g6b-attr-root))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(instances (hash-table-values
|
||||
(etaf-runtime-instances runtime)))
|
||||
(props (etaf-runtime-host-props-for
|
||||
runtime 'g6b-attr-root)))
|
||||
(should (equal '("leaf" "base" "caller")
|
||||
(plist-get props :class)))
|
||||
(should (equal "#224466" (plist-get props :color)))
|
||||
(should (equal "#224466"
|
||||
(etaf-test-g6b--face-value
|
||||
(etaf-test-g6b--face-at buffer "Leaf")
|
||||
:foreground)))
|
||||
(should (= 2 (plist-get props :padding-inline)))
|
||||
(setf (etaf-value color) "#335577")
|
||||
(setq props (etaf-runtime-host-props-for
|
||||
runtime 'g6b-attr-root))
|
||||
(should (equal "#335577" (plist-get props :color)))
|
||||
(should (equal "#335577"
|
||||
(etaf-test-g6b--face-value
|
||||
(etaf-test-g6b--face-at buffer "Leaf")
|
||||
:foreground)))
|
||||
(should
|
||||
(cl-every
|
||||
(lambda (instance)
|
||||
(memq instance (hash-table-values
|
||||
(etaf-runtime-instances runtime))))
|
||||
instances))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-host-attrs-reject-ambiguous-or-invalid-targets ()
|
||||
"Fallthrough fails closed for unknown, duplicate, conflicting, and multi-root input."
|
||||
(should-error
|
||||
(etaf-node 'etaf-test-g6b-attr-leaf (list :unknown-attr 1) nil)
|
||||
:type 'etaf-component-call-error)
|
||||
(should-error
|
||||
(etaf-node 'etaf-test-g6b-attr-leaf
|
||||
(list :bgcolor "red" :background-color "blue") nil)
|
||||
:type 'etaf-component-call-error)
|
||||
(dolist
|
||||
(entry
|
||||
`((" *etaf-g6b-attrs-fragment*"
|
||||
,(etaf-view (etaf-test-g6b-attr-fragment :color "red")))
|
||||
(" *etaf-g6b-attrs-text*"
|
||||
,(etaf-view (etaf-test-g6b-attr-text :padding 1)))))
|
||||
(let ((buffer (car entry)))
|
||||
(unwind-protect
|
||||
(should-error (etaf-mount buffer (cadr entry))
|
||||
:type 'etaf-component-call-error)
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
(let ((buffer " *etaf-g6b-attrs-role*"))
|
||||
(unwind-protect
|
||||
(should-error
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(etaf-test-g6b-attr-role
|
||||
:role 'navigation :ref 'g6b-attrs-role)))
|
||||
:type 'etaf-component-call-error)
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-host-attrs-rollback-root-shape-failure ()
|
||||
"A later multi-root result cannot publish or retire the previous root."
|
||||
(let ((buffer " *etaf-g6b-attrs-rollback*")
|
||||
(split (etaf-ref nil)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-g6b-attr-shape
|
||||
:split (etaf-value split) :color "#224466"))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(published (with-current-buffer buffer (buffer-string))))
|
||||
(should-error (setf (etaf-value split) t)
|
||||
:type 'etaf-component-call-error)
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (equal-including-properties
|
||||
published (with-current-buffer buffer (buffer-string))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(ert-deftest etaf-component-compiled-host-sites-are-instance-scoped ()
|
||||
"Two instances of one compiled Component never share generated Host refs."
|
||||
(let ((buffer " *etaf-g6b-instance-sites*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(column
|
||||
(etaf-test-g6b-attr-leaf :key 'one :label "One")
|
||||
(etaf-test-g6b-attr-leaf :key 'two :label "Two"))))
|
||||
(should (string-match-p
|
||||
"One[[:space:]]+Two" (etaf-test-g6b--text buffer))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((live (get-buffer buffer))) (kill-buffer live)))))
|
||||
|
||||
(provide 'etaf-component-frontends-tests)
|
||||
;;; etaf-component-frontends-tests.el ends here
|
||||
@ -6,7 +6,6 @@
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf-data)
|
||||
(require 'etaf-observer)
|
||||
|
||||
(defconst etaf-data-test-records
|
||||
'((:id 1 :name "Ada" :group "compiler")
|
||||
@ -63,22 +62,17 @@
|
||||
|
||||
(ert-deftest etaf-data-loading-state-is-visible-to-source-boundary ()
|
||||
"Publish loading before invoking the source load capability."
|
||||
(let (controller seen candidate-kinds)
|
||||
(let (controller seen)
|
||||
(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)))))
|
||||
@ -190,444 +184,6 @@
|
||||
(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
|
||||
@ -769,94 +325,4 @@
|
||||
(should-error (etaf-data-set-page controller 2)
|
||||
:type 'etaf-data-stopped-error)))
|
||||
|
||||
(ert-deftest etaf-data-observes-source-capabilities-once-in-call-order ()
|
||||
"Report source load and mutation without timing controller publication."
|
||||
(let* ((source (etaf-data-memory-source '((:id 1)) :id-key :id))
|
||||
(controller (etaf-data-controller source))
|
||||
reports
|
||||
diagnostics
|
||||
(context
|
||||
(etaf--observer-context-create
|
||||
:sink (lambda (report) (push report reports))
|
||||
:operation-id 41
|
||||
:runtime-id 7
|
||||
:buffer-name nil
|
||||
:diagnostic (lambda (diagnostic) (push diagnostic diagnostics)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(etaf-data-load controller)
|
||||
(etaf-data-mutate controller 'insert '(:id 2))))
|
||||
(setq reports (nreverse reports))
|
||||
(should-not diagnostics)
|
||||
(should (equal '(load mutate load)
|
||||
(mapcar (lambda (report)
|
||||
(plist-get report :stage))
|
||||
reports)))
|
||||
(should (equal '(memory memory memory)
|
||||
(mapcar (lambda (report)
|
||||
(plist-get report :provider))
|
||||
reports)))
|
||||
(should (equal '(1 nil 1)
|
||||
(mapcar (lambda (report)
|
||||
(plist-get report :page))
|
||||
reports)))
|
||||
(should (eq 'insert (plist-get (cadr reports) :operation)))
|
||||
(should (equal '((:id 1) (:id 2))
|
||||
(etaf-value (etaf-data-items controller))))
|
||||
(should (eq 'success (etaf-value
|
||||
(etaf-data-status controller)))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-observed-source-error-preserves-controller-state ()
|
||||
"Report a source error and preserve the ordinary Data error contract."
|
||||
(let* ((source (etaf-data-source
|
||||
:load (lambda (&rest _args) (error "unavailable"))))
|
||||
(controller (etaf-data-controller source))
|
||||
reports
|
||||
(context
|
||||
(etaf--observer-context-create
|
||||
:sink (lambda (report) (push report reports))
|
||||
:operation-id 42
|
||||
:runtime-id 7
|
||||
:buffer-name nil
|
||||
:diagnostic #'ignore)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(should-error
|
||||
(etaf--observer-call-with-context
|
||||
context (lambda () (etaf-data-load controller)))
|
||||
:type 'error)
|
||||
(should (= 1 (length reports)))
|
||||
(should (eq 'data (plist-get (car reports) :provider)))
|
||||
(should (eq 'load (plist-get (car reports) :stage)))
|
||||
(should (eq 'error (plist-get (car reports) :status)))
|
||||
(should (eq 'error (etaf-value (etaf-data-status controller))))
|
||||
(should (string-match-p
|
||||
"unavailable"
|
||||
(cadr (etaf-value (etaf-data-error controller))))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-source-rejects-invalid-observation-provider ()
|
||||
"Require an explicit source provider to be a non-nil symbol."
|
||||
(should-error
|
||||
(etaf-data-source :provider nil
|
||||
:load (lambda (&rest _args) (list :items nil)))
|
||||
:type 'wrong-type-argument)
|
||||
(should-error
|
||||
(etaf-data-source :provider 7
|
||||
:load (lambda (&rest _args) (list :items nil)))
|
||||
:type 'wrong-type-argument))
|
||||
|
||||
(ert-deftest etaf-data-unobserved-source-call-bypasses-stage-runtime ()
|
||||
"Keep the standalone source path free of observation work."
|
||||
(let ((source (etaf-data-memory-source '((:id 1)) :id-key :id)))
|
||||
(cl-letf (((symbol-function 'etaf--observer-call-stage)
|
||||
(lambda (&rest _args)
|
||||
(ert-fail "unobserved Data call entered stage runtime"))))
|
||||
(should (equal '((:id 1))
|
||||
(plist-get (etaf-data-source-load-page source) :items))))))
|
||||
|
||||
;;; etaf-data-tests.el ends here
|
||||
|
||||
@ -6,12 +6,6 @@
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
(require 'json)
|
||||
(require 'macroexp)
|
||||
(require 'etaf)
|
||||
|
||||
(declare-function etaf-m0b-component-manifest-write-json
|
||||
"etaf-m0b-component-manifest" ())
|
||||
|
||||
(defconst etaf-docs-test--root
|
||||
(file-name-directory
|
||||
@ -36,7 +30,7 @@
|
||||
(unless (re-search-forward "^```[[:space:]]*$" nil t)
|
||||
(error "Unclosed Elisp documentation block"))
|
||||
(push (buffer-substring-no-properties start
|
||||
(match-beginning 0))
|
||||
(line-beginning-position))
|
||||
blocks))))
|
||||
(nreverse blocks)))
|
||||
|
||||
@ -53,159 +47,6 @@
|
||||
(end-of-file count)
|
||||
(error (error "Cannot read documentation form: %S" err))))))
|
||||
|
||||
(defun etaf-docs-test--forms (source)
|
||||
"Read and return every form in documentation SOURCE."
|
||||
(with-temp-buffer
|
||||
(insert source)
|
||||
(goto-char (point-min))
|
||||
(let (forms)
|
||||
(condition-case nil
|
||||
(while t (push (read (current-buffer)) forms))
|
||||
(end-of-file (nreverse forms))))))
|
||||
|
||||
(defun etaf-docs-test--marked-examples (contents)
|
||||
"Extract named executable documentation examples from CONTENTS."
|
||||
(with-temp-buffer
|
||||
(insert contents)
|
||||
(goto-char (point-min))
|
||||
(let (examples)
|
||||
(while (re-search-forward
|
||||
"^<!-- etaf-example: \\([^ ]+\\) -->\n```elisp\n" nil t)
|
||||
(let ((name (match-string 1))
|
||||
(start (point)))
|
||||
(unless (re-search-forward "^```$" nil t)
|
||||
(error "Unclosed executable example %s" name))
|
||||
(push (cons name (buffer-substring-no-properties
|
||||
start (match-beginning 0)))
|
||||
examples)))
|
||||
(nreverse examples))))
|
||||
|
||||
(defun etaf-docs-test--run-fresh (source assertions)
|
||||
"Run exact example SOURCE and ASSERTIONS in a fresh core-only Emacs."
|
||||
(let ((script (make-temp-file "etaf-readme-" nil ".el")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-temp-file script
|
||||
(insert source "\n")
|
||||
(prin1 assertions (current-buffer))
|
||||
(insert "\n(should-not (featurep 'etaf-ui))\n"
|
||||
"(should-not (featurep 'etaf-playground))\n"))
|
||||
(with-temp-buffer
|
||||
(let ((status
|
||||
(apply #'call-process
|
||||
(expand-file-name invocation-name invocation-directory)
|
||||
nil (current-buffer) nil "-Q" "--batch"
|
||||
(append
|
||||
(cl-loop for directory in '("." "../ebox" "../tp"
|
||||
"../ecss")
|
||||
append (list "-L" (expand-file-name
|
||||
directory
|
||||
etaf-docs-test--root)))
|
||||
(list "--eval"
|
||||
(prin1-to-string
|
||||
'(progn
|
||||
(require 'ert)
|
||||
(require 'jka-compr)
|
||||
(setq load-suffixes '(".el" ".elc")
|
||||
load-prefer-newer t)))
|
||||
"-l" script)))))
|
||||
(unless (equal status 0)
|
||||
(ert-fail (format "Documentation child exited %S:\n%s"
|
||||
status (buffer-string)))))))
|
||||
(delete-file script))))
|
||||
|
||||
(ert-deftest etaf-docs-readme-examples-mount-and-dispatch-in-fresh-emacs ()
|
||||
"Both READMEs must work from their exact requires in isolated processes."
|
||||
(dolist (file '("README.md" "README.zh-CN.md"))
|
||||
(let ((examples (etaf-docs-test--marked-examples
|
||||
(etaf-docs-test--read file))))
|
||||
(should (equal '("hello" "card" "counter") (mapcar #'car examples)))
|
||||
(dolist (example examples)
|
||||
(etaf-docs-test--run-fresh
|
||||
(cdr example)
|
||||
(pcase (car example)
|
||||
("hello"
|
||||
'(let ((runtime (etaf-runtime-for-buffer "*etaf-hello*")))
|
||||
(should runtime)
|
||||
(should (equal "Hello ETAF"
|
||||
(etaf-dispatch-event runtime 'hello 'press)))
|
||||
(etaf-unmount runtime)))
|
||||
("card"
|
||||
'(let ((runtime (etaf-runtime-for-buffer "*etaf-card*")))
|
||||
(should runtime)
|
||||
(with-current-buffer "*etaf-card*"
|
||||
(should (string-match-p
|
||||
"Account[[:space:]]+Connected[[:space:]]+Footer"
|
||||
(buffer-string))))
|
||||
(etaf-unmount runtime)))
|
||||
("counter"
|
||||
'(let ((runtime (etaf-runtime-for-buffer "*etaf-counter*")))
|
||||
(should runtime)
|
||||
(etaf-dispatch-event runtime 'increment 'press)
|
||||
(with-current-buffer "*etaf-counter*"
|
||||
(should (string-match-p "Count: 1" (buffer-string))))
|
||||
(etaf-unmount runtime)))))))))
|
||||
|
||||
(ert-deftest etaf-docs-context-and-theme-examples-mount-in-fresh-emacs ()
|
||||
"Run exact Context and Theme examples without prior definitions or imports."
|
||||
(dolist (file '("docs/user-guide.en.md" "docs/user-guide.zh.md"
|
||||
"docs/architecture.en.md" "docs/architecture.zh.md"))
|
||||
(let ((examples (etaf-docs-test--marked-examples
|
||||
(etaf-docs-test--read file))))
|
||||
(should (equal '("context" "theme")
|
||||
(sort (mapcar #'car examples) #'string<)))
|
||||
(dolist (example examples)
|
||||
(etaf-docs-test--run-fresh
|
||||
(cdr example)
|
||||
(pcase (car example)
|
||||
("context"
|
||||
'(let ((runtime (etaf-runtime-for-buffer "*etaf-context*")))
|
||||
(should runtime)
|
||||
(with-current-buffer "*etaf-context*"
|
||||
(should (string-match-p "Service: demo-service"
|
||||
(buffer-string))))
|
||||
(etaf-unmount runtime)))
|
||||
("theme"
|
||||
'(let* ((runtime (etaf-runtime-for-buffer "*etaf-theme*"))
|
||||
(props (gethash 'themed-content
|
||||
(etaf-runtime-host-props runtime))))
|
||||
(should runtime)
|
||||
(should (equal "#F4F6FB" (plist-get props :color)))
|
||||
(should (equal "#202634" (plist-get props :background-color)))
|
||||
(with-current-buffer "*etaf-theme*"
|
||||
(goto-char (point-min))
|
||||
(should (search-forward "Themed content" nil t))
|
||||
(let ((face (get-text-property (1- (point)) 'face)))
|
||||
(should (string-match-p "#F4F6FB" (format "%S" face)))
|
||||
(should (string-match-p "#202634" (format "%S" face)))))
|
||||
(etaf-unmount runtime)))))))))
|
||||
|
||||
(defun etaf-docs-test--mounted-collection-probe (forms)
|
||||
"Load exact documentation FORMS and mount the collection composition."
|
||||
(etaf-component-redefine-run
|
||||
(lambda ()
|
||||
(dolist (form forms)
|
||||
(eval form t))))
|
||||
(let ((buffer (generate-new-buffer " *etaf-docs-m0b*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(let ((view
|
||||
(eval
|
||||
'(etaf-view
|
||||
(etaf-docs-collection-card
|
||||
:items '((1 . "One") (2 . "Two"))
|
||||
:footer-view (etaf-view (text "Dynamic"))
|
||||
(slot :name 'footer (text "Footer"))))
|
||||
t)))
|
||||
(etaf-mount buffer view))
|
||||
(let ((text (with-current-buffer buffer (buffer-string))))
|
||||
(dolist (expected '("One" "Two" "Dynamic" "Footer"))
|
||||
(should (string-match-p expected text)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when (buffer-live-p buffer)
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-docs-have-paired-long-lived-files ()
|
||||
"Keep the public architecture, guide, and plan in both languages."
|
||||
(dolist (file '("README.md"
|
||||
@ -220,8 +61,6 @@
|
||||
"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)))))
|
||||
@ -237,12 +76,7 @@
|
||||
(let ((contents (etaf-docs-test--read file)))
|
||||
(should-not
|
||||
(string-match-p
|
||||
(regexp-opt '("etaf-template" "etaf-create-app" "expr :value"
|
||||
"ETAF also registers the short alias"
|
||||
"registry assigns a semantic"
|
||||
"ETAF 也会注册短 alias"
|
||||
"注册表会分配语义明确的"))
|
||||
contents))
|
||||
(regexp-opt '("etaf-template" "etaf-create-app")) 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"
|
||||
@ -261,142 +95,8 @@
|
||||
(etaf-docs-test--read file)))
|
||||
(should (> (etaf-docs-test--read-all block) 0)))))
|
||||
|
||||
(ert-deftest etaf-docs-component-contract-is-current ()
|
||||
"Keep public Component prose aligned with the authoritative macro contract."
|
||||
(dolist (file '("docs/architecture.en.md" "docs/architecture.zh.md"
|
||||
"docs/user-guide.en.md" "docs/user-guide.zh.md"
|
||||
"docs/implementation-plan.en.md"
|
||||
"docs/implementation-plan.zh.md"))
|
||||
(let ((contents (etaf-docs-test--read file)))
|
||||
(should (string-match-p (regexp-quote ":view") contents))
|
||||
(should (string-match-p (regexp-quote ":render") contents))
|
||||
(should (string-match-p (regexp-quote ":setup") contents))
|
||||
(should (string-match-p (regexp-opt '("opaque state" "opaque 状态"))
|
||||
contents))
|
||||
(should-not
|
||||
(string-match-p
|
||||
(regexp-opt '("setup returns a zero-argument render function"
|
||||
":setup` runs once per retained identity and returns a zero-argument render function"
|
||||
":setup` runs once for a retained Component instance and must return a zero-argument render function"
|
||||
"返回零参数 render 函数"
|
||||
"必须返回零参数 render 函数"))
|
||||
contents)))))
|
||||
|
||||
(ert-deftest etaf-docs-data-grid-selection-contract-is-current ()
|
||||
"Document only selection inputs actually declared by `etaf-data-grid'."
|
||||
(dolist (file '("docs/user-guide.en.md" "docs/user-guide.zh.md"))
|
||||
(let ((contents (etaf-docs-test--read file)))
|
||||
(should (string-match-p (regexp-quote ":row-selected-p") contents))
|
||||
(should-not (string-match-p (regexp-quote ":selected-key") contents)))))
|
||||
|
||||
(ert-deftest etaf-docs-superseded-proposals-not-current-contract ()
|
||||
"Keep the old Component proposal explicitly historical."
|
||||
(let ((contents
|
||||
(etaf-docs-test--read "docs/proposals/component-definition.zh.md")))
|
||||
(should (string-match-p "SUPERSEDED" contents))
|
||||
(should (string-match-p "historical" contents))
|
||||
(should (string-match-p (regexp-quote "docs/architecture.zh.md") contents))
|
||||
(should-not (string-match-p "尚未实现" contents))))
|
||||
|
||||
(ert-deftest etaf-docs-module-boundaries-target-vocabulary-is-paired ()
|
||||
"Keep the English and Chinese target Component vocabulary equivalent."
|
||||
(dolist (file '("docs/proposals/module-boundaries.en.md"
|
||||
"docs/proposals/module-boundaries.zh.md"))
|
||||
(let ((contents (etaf-docs-test--read file)))
|
||||
(dolist (token '(":view" ":render" ":setup" "etaf-state" "etaf-node"
|
||||
"opaque"))
|
||||
(should (string-match-p (regexp-quote token) contents))))))
|
||||
|
||||
(ert-deftest etaf-docs-interaction-contract-is-current ()
|
||||
"Keep the public Action/Behavior/event composition contract explicit."
|
||||
(dolist (file '("docs/architecture.en.md" "docs/architecture.zh.md"
|
||||
"docs/user-guide.en.md" "docs/user-guide.zh.md"))
|
||||
(let ((contents (etaf-docs-test--read file)))
|
||||
(dolist (token '("Host" "Behavior" "short-circuit" "first"
|
||||
"capture" "bubble" "application" "feature"
|
||||
"etaf-action-redefine-run" "dispatch"))
|
||||
(should (string-match-p (regexp-quote token) contents))))))
|
||||
|
||||
(ert-deftest etaf-docs-component-manifest-is-machine-readable ()
|
||||
"Validate the three-column Component manifest and observed evidence."
|
||||
(let* ((script (expand-file-name "scripts/etaf-m0b-component-manifest.el"
|
||||
etaf-docs-test--root))
|
||||
(json-object-type 'alist)
|
||||
(json-array-type 'list)
|
||||
(manifest
|
||||
(with-temp-buffer
|
||||
(let ((standard-output (current-buffer)))
|
||||
(load script nil t)
|
||||
(etaf-m0b-component-manifest-write-json))
|
||||
(goto-char (point-min))
|
||||
(json-read))))
|
||||
(should (equal 1 (alist-get 'schema-version manifest)))
|
||||
(should (equal "observed" (alist-get 'evidence-mode manifest)))
|
||||
(dolist (entry (alist-get 'components manifest))
|
||||
(should (alist-get 'declared-business-props entry))
|
||||
(should (alist-get 'forwarded-host-attrs entry))
|
||||
(should (alist-get 'root-shape-forwarding-guarantee entry))
|
||||
(should (eq t (alist-get 'mounted-validation entry))))))
|
||||
|
||||
(defun etaf-docs-test--snapshot-probe (forms)
|
||||
"Run exact snapshot FORMS after one local publication in the documented app."
|
||||
(let ((label (etaf-ref "Before"))
|
||||
(buffer-name "*etaf-hello*"))
|
||||
(should-not (get-buffer buffer-name))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-view (text (expr (etaf-value label)))))
|
||||
(setf (etaf-value label) "Current")
|
||||
(let ((result (eval (cons 'progn forms) t)))
|
||||
(should (= 3 (length result)))
|
||||
(should (and (integerp (nth 0 result)) (> (nth 0 result) 0)))
|
||||
(should (integerp (nth 1 result)))
|
||||
(should (equal "Current" (substring-no-properties (nth 2 result))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-docs-executable-suite-is-fail-closed ()
|
||||
"Classify exact blocks before macroexpansion, loading, or mounted smoke."
|
||||
(let ((fixture (expand-file-name
|
||||
"tests/fixtures/etaf-m0b-doc-examples.sexp"
|
||||
etaf-docs-test--root)))
|
||||
(should (file-readable-p fixture))
|
||||
(let ((records (with-temp-buffer
|
||||
(insert-file-contents fixture)
|
||||
(goto-char (point-min))
|
||||
(read (current-buffer)))))
|
||||
(should records)
|
||||
(dolist (record records)
|
||||
(let* ((file (plist-get record :file))
|
||||
(index (plist-get record :block))
|
||||
(classification (plist-get record :classification))
|
||||
(blocks (etaf-docs-test--elisp-blocks
|
||||
(etaf-docs-test--read file)))
|
||||
(source (nth (1- index) blocks)))
|
||||
(should source)
|
||||
(should (equal (secure-hash 'sha256 source)
|
||||
(plist-get record :sha256)))
|
||||
(should (memq classification
|
||||
'(macroexpand-only load-safe mounted-smoke)))
|
||||
(pcase classification
|
||||
('macroexpand-only
|
||||
(should (> (etaf-docs-test--read-all source) 0)))
|
||||
((or 'load-safe 'mounted-smoke)
|
||||
(let ((forms (etaf-docs-test--forms source)))
|
||||
(dolist (form forms)
|
||||
(should (macroexpand-all (copy-tree form))))
|
||||
(pcase (plist-get record :probe)
|
||||
('collection-composition
|
||||
(etaf-docs-test--mounted-collection-probe forms))
|
||||
('runtime-snapshot
|
||||
(etaf-docs-test--snapshot-probe forms))
|
||||
('nil (dolist (form forms) (eval form t)))
|
||||
(_ (ert-fail "Unknown safe documentation probe")))))))))))
|
||||
|
||||
(ert-deftest etaf-source-uses-only-public-ebox-names ()
|
||||
"Reject Ebox private functions, fields and dynamic construction context."
|
||||
"Keep the ETAF implementation independent of Ebox private functions."
|
||||
(dolist (file
|
||||
(append
|
||||
(directory-files etaf-docs-test--root t "\\.el\\'")
|
||||
@ -405,9 +105,7 @@
|
||||
t "\\.el\\'")))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
;; 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)))))
|
||||
(should-not (re-search-forward "ebox--" 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
@ -1,789 +0,0 @@
|
||||
;;; 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
|
||||
@ -1,852 +0,0 @@
|
||||
;;; 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
|
||||
@ -1,454 +0,0 @@
|
||||
;;; etaf-generation-tests.el --- M3a generation authority gates -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
(require 'etaf-generation)
|
||||
|
||||
(etaf-define-component etaf-generation-test-dependency-only (&key source)
|
||||
"Track SOURCE while producing an equal Ebox artifact."
|
||||
:view
|
||||
(text (expr (progn (etaf-value source) "same"))))
|
||||
|
||||
(etaf-define-component etaf-generation-test-visible (&key source)
|
||||
"Render SOURCE as visible text for semantic conflict tests."
|
||||
:view
|
||||
(text (expr (format "value=%s" (etaf-value source)))))
|
||||
|
||||
(defun etaf-generation-test--view (visible)
|
||||
"Return a root View selected by reactive VISIBLE."
|
||||
(if (etaf-value visible)
|
||||
(etaf-view
|
||||
(text :ref 'generation-target :role 'button
|
||||
:on-press #'ignore "visible"))
|
||||
(etaf-view (text :ref 'generation-other "other"))))
|
||||
|
||||
(ert-deftest etaf-generation-authority-is-runtime-single-source ()
|
||||
"Runtime compatibility access reads and writes one authority object."
|
||||
(let* ((runtime (etaf--runtime-create))
|
||||
(first (etaf--generation-create :generation-id 1))
|
||||
(second (etaf--generation-create :generation-id 2)))
|
||||
(should-not (etaf-runtime-current-generation runtime))
|
||||
(setf (etaf-runtime-current-generation runtime) first)
|
||||
(let ((authority (etaf-runtime-generation-authority runtime)))
|
||||
(should (etaf-generation-authority-p authority))
|
||||
(should (eq first (etaf-generation-authority-current authority)))
|
||||
(should (eq first (etaf-runtime-current-generation runtime)))
|
||||
(setf (etaf-runtime-current-generation runtime) second)
|
||||
(should (eq authority (etaf-runtime-generation-authority runtime)))
|
||||
(should (eq second (etaf-runtime-current-generation runtime)))
|
||||
(should (zerop (etaf-generation-authority-token authority))))))
|
||||
|
||||
(ert-deftest etaf-generation-projection-is-detached-and-rejects-duplicates ()
|
||||
"Compatibility projections copy facts and reject ambiguous keys."
|
||||
(let* ((handlers '((host . ((press . callback)))))
|
||||
(projection
|
||||
(etaf-generation-project-mirrors handlers '((host :role button))))
|
||||
(handler-table (plist-get projection :handlers))
|
||||
(props-table (plist-get projection :host-props)))
|
||||
(setcdr (car handlers) 'mutated)
|
||||
(should (equal (gethash 'host handler-table) '((press . callback))))
|
||||
(should (equal (gethash 'host props-table) '(:role button)))
|
||||
(should-error
|
||||
(etaf-generation-project-mirror '((host . one) (host . two)))
|
||||
:type 'etaf-generation-error)))
|
||||
|
||||
(ert-deftest etaf-generation-mirrors-follow-committed-generation ()
|
||||
"Every commit projects exact mirrors and removes stale Host facts."
|
||||
(let ((buffer-name " *etaf-generation-mirror-test*")
|
||||
(visible (etaf-ref t)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(lambda () (etaf-generation-test--view visible)))
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
|
||||
(should (etaf-runtime-handler-for runtime 'generation-target))
|
||||
(should (gethash 'generation-target
|
||||
(etaf-runtime-handlers runtime)))
|
||||
(setf (etaf-value visible) nil)
|
||||
(should (etaf-runtime-generation-mirrors-consistent-p runtime))
|
||||
(should-not (etaf-runtime-handler-for runtime 'generation-target))
|
||||
(should-not (gethash 'generation-target
|
||||
(etaf-runtime-handlers runtime)))
|
||||
(should (gethash 'generation-other
|
||||
(etaf-runtime-host-props runtime)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-generation-query-ignores-compatibility-mirror-drift ()
|
||||
"Corrupting a mirror never changes committed generation queries."
|
||||
(let ((buffer-name " *etaf-generation-query-test*")
|
||||
(visible (etaf-ref t)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(lambda () (etaf-generation-test--view visible)))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(committed
|
||||
(copy-tree
|
||||
(etaf-runtime-handler-for runtime 'generation-target))))
|
||||
(puthash 'generation-target 'corrupt
|
||||
(etaf-runtime-handlers runtime))
|
||||
(should-not (etaf-runtime-generation-mirrors-consistent-p runtime))
|
||||
(should (equal committed
|
||||
(etaf-runtime-handler-for
|
||||
runtime 'generation-target)))
|
||||
(setf (etaf-value visible) nil)
|
||||
(setf (etaf-value visible) t)
|
||||
(should (etaf-runtime-generation-mirrors-consistent-p runtime))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-generation-shadow-route-proves-legacy-equivalence ()
|
||||
"The shadow route accepts a legacy projection only when facts are equal."
|
||||
(let ((buffer-name " *etaf-generation-shadow-test*")
|
||||
(visible (etaf-ref t))
|
||||
(etaf-generation-mirror-route 'shadow))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(lambda () (etaf-generation-test--view visible)))
|
||||
(setf (etaf-value visible) nil)
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(should (etaf-runtime-generation-mirrors-consistent-p runtime))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-generation-rejects-unknown-mirror-route ()
|
||||
"An unknown compatibility route cannot silently publish mirrors."
|
||||
(let ((runtime (etaf--runtime-create
|
||||
:generation-authority
|
||||
(etaf-generation-authority-create)))
|
||||
(etaf-generation-mirror-route 'unknown))
|
||||
(should-error
|
||||
(etaf--runtime-install-generation-mirrors runtime nil t)
|
||||
:type 'etaf-generation-error)))
|
||||
|
||||
(ert-deftest etaf-semantic-candidate-cas-and-rollback-are-exactly-once ()
|
||||
"CAS stages generation/token/versions together and rollback restores all."
|
||||
(let* ((old (list 'old-generation))
|
||||
(next (list 'next-generation))
|
||||
(authority (etaf-generation-authority-create old))
|
||||
(candidate
|
||||
(etaf-semantic-candidate-create
|
||||
authority next 7 11 13 17)))
|
||||
(etaf-semantic-candidate-stage candidate)
|
||||
(should (eq next (etaf-generation-authority-current authority)))
|
||||
(should (= (etaf-generation-authority-token authority) 1))
|
||||
(should
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
(etaf-semantic-candidate-candidate-store-versions candidate)))
|
||||
(should-error (etaf-semantic-candidate-stage candidate)
|
||||
:type 'etaf-generation-error)
|
||||
(etaf-semantic-candidate-rollback candidate)
|
||||
(should (eq old (etaf-generation-authority-current authority)))
|
||||
(should (zerop (etaf-generation-authority-token authority)))
|
||||
(should
|
||||
(equal (etaf-generation-authority-store-versions authority)
|
||||
(etaf-semantic-candidate-expected-store-versions candidate)))
|
||||
(etaf-semantic-candidate-rollback candidate)
|
||||
(should-error (etaf-semantic-candidate-commit candidate)
|
||||
:type 'etaf-generation-error)))
|
||||
|
||||
(ert-deftest etaf-semantic-candidate-rejects-stale-authority-snapshots ()
|
||||
"Generation, token, and store-version conflicts fail before authority swap."
|
||||
(dolist (kind '(generation token stores))
|
||||
(let* ((old (list 'old-generation))
|
||||
(next (list 'next-generation))
|
||||
(authority (etaf-generation-authority-create old))
|
||||
(candidate
|
||||
(etaf-semantic-candidate-create authority next 1 2 3 4)))
|
||||
(pcase kind
|
||||
('generation
|
||||
(etaf-generation-authority-set-current authority (list 'foreign)))
|
||||
('token
|
||||
(setf (etaf-generation-authority-token authority) 9))
|
||||
('stores
|
||||
(setf (etaf-generation-authority-store-versions authority)
|
||||
(etaf-generation-store-versions-next
|
||||
(etaf-generation-authority-store-versions authority)))))
|
||||
(should-error (etaf-semantic-candidate-stage candidate)
|
||||
:type 'etaf-generation-conflict)
|
||||
(should (eq (etaf-semantic-candidate-state candidate) 'prepared)))))
|
||||
|
||||
(ert-deftest etaf-semantic-candidate-commit-is-terminal ()
|
||||
"A committed semantic candidate cannot rollback or commit twice."
|
||||
(let* ((authority (etaf-generation-authority-create 'old))
|
||||
(candidate
|
||||
(etaf-semantic-candidate-create authority 'next 1 2 3 4)))
|
||||
(etaf-semantic-candidate-stage candidate)
|
||||
(etaf-semantic-candidate-commit candidate)
|
||||
(should (eq (etaf-semantic-candidate-state candidate) 'committed))
|
||||
(should-error (etaf-semantic-candidate-commit candidate)
|
||||
:type 'etaf-generation-error)
|
||||
(should-error (etaf-semantic-candidate-rollback candidate)
|
||||
:type 'etaf-generation-error)
|
||||
(should (eq (etaf-generation-authority-current authority) 'next))))
|
||||
|
||||
(ert-deftest etaf-semantic-only-commit-advances-token-without-ebox-or-tp ()
|
||||
"Equal output commits semantic token/version only, with no surface revision."
|
||||
(let ((buffer-name " *etaf-semantic-token-test*")
|
||||
(source (etaf-ref 0))
|
||||
(ebox-updates 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-dependency-only
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(surface (with-current-buffer buffer-name
|
||||
(car tp--buffer-surfaces)))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(versions (etaf-runtime-store-versions runtime))
|
||||
(revision (tp-surface-revision surface))
|
||||
(original
|
||||
(symbol-function 'etaf-render-port-update)))
|
||||
(cl-letf (((symbol-function 'etaf-render-port-update)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf ebox-updates)
|
||||
(apply original arguments))))
|
||||
(setf (etaf-value source) 1))
|
||||
(should (= (1+ generation)
|
||||
(etaf-runtime-generation runtime)))
|
||||
(should (= (1+ token)
|
||||
(etaf-runtime-generation-token runtime)))
|
||||
(should
|
||||
(equal (etaf-generation-store-versions-next versions)
|
||||
(etaf-runtime-store-versions runtime)))
|
||||
(should (zerop ebox-updates))
|
||||
(should (= revision (tp-surface-revision surface)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-semantic-store-conflict-restores-and-retries ()
|
||||
"A stale store version leaves generation/buffer old and a fresh retry wins."
|
||||
(let ((buffer-name " *etaf-semantic-conflict-test*")
|
||||
(source (etaf-ref 0)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-visible
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(authority (etaf-runtime-generation-authority runtime))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(versions (etaf-runtime-store-versions runtime))
|
||||
(original
|
||||
(symbol-function 'etaf--runtime-participant-publish)))
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-participant-publish)
|
||||
(lambda (participant)
|
||||
(setf (etaf-generation-authority-store-versions authority)
|
||||
(etaf-generation-store-versions-next versions))
|
||||
(funcall original participant))))
|
||||
(should-error (setf (etaf-value source) 1)
|
||||
:type 'etaf-generation-conflict))
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (= token (etaf-runtime-generation-token runtime)))
|
||||
(should (equal "value=0"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))
|
||||
(etaf-runtime-flush runtime)
|
||||
(should (= (1+ token) (etaf-runtime-generation-token runtime)))
|
||||
(should (equal "value=1"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-semantic-postcommit-mirror-failure-keeps-token-committed ()
|
||||
"A postcommit mirror error cannot reverse generation/token or TP facts."
|
||||
(let ((buffer-name " *etaf-semantic-postcommit-test*")
|
||||
(source (etaf-ref 0))
|
||||
captured
|
||||
(rollback-count 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-dependency-only
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(surface (with-current-buffer buffer-name
|
||||
(car tp--buffer-surfaces)))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(revision (tp-surface-revision surface))
|
||||
(original-rollback
|
||||
(symbol-function 'etaf-semantic-candidate-rollback)))
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-install-generation-mirrors)
|
||||
(lambda (&rest _arguments)
|
||||
(error "injected postcommit mirror failure")))
|
||||
((symbol-function 'etaf-semantic-candidate-rollback)
|
||||
(lambda (candidate)
|
||||
(cl-incf rollback-count)
|
||||
(funcall original-rollback candidate))))
|
||||
(condition-case condition
|
||||
(setf (etaf-value source) 1)
|
||||
(error (setq captured condition))))
|
||||
(should captured)
|
||||
(should (eq (car captured) 'error))
|
||||
(should
|
||||
(equal (butlast (cdr captured))
|
||||
'("injected postcommit mirror failure")))
|
||||
(should (etaf-condition-postcommit-info captured))
|
||||
(should (zerop rollback-count))
|
||||
(should (= (1+ generation)
|
||||
(etaf-runtime-generation runtime)))
|
||||
(should (= (1+ token)
|
||||
(etaf-runtime-generation-token runtime)))
|
||||
(should (= revision (tp-surface-revision surface)))
|
||||
(should (equal "same"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-semantic-ebox-report-finalization-fault-does-not-rollback ()
|
||||
"A postaccept Ebox report fault still commits ETAF generation and buffer."
|
||||
(let ((buffer-name " *etaf-ebox-report-postaccept-test*")
|
||||
(source (etaf-ref 0))
|
||||
(rollback-count 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-visible
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(original-rollback
|
||||
(symbol-function 'etaf-semantic-candidate-rollback)))
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-surface--participant-complete)
|
||||
(lambda (&rest _arguments)
|
||||
(error "injected Ebox report finalization fault")))
|
||||
((symbol-function 'etaf-semantic-candidate-rollback)
|
||||
(lambda (candidate)
|
||||
(cl-incf rollback-count)
|
||||
(funcall original-rollback candidate))))
|
||||
(setf (etaf-value source) 1))
|
||||
(should (zerop rollback-count))
|
||||
(should (= (1+ generation)
|
||||
(etaf-runtime-generation runtime)))
|
||||
(should (equal "value=1"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-semantic-render-rollback-restores-all-authority-in-callback ()
|
||||
"Framework rollback restores token, stores, and journals before TP returns."
|
||||
(let ((buffer-name " *etaf-semantic-render-rollback-test*")
|
||||
(source (etaf-ref 0))
|
||||
rollback-evidence)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-visible
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime))
|
||||
(versions (etaf-runtime-store-versions runtime))
|
||||
(original-precommit
|
||||
(symbol-function 'tp--run-transaction-precommit-functions))
|
||||
(original-rollback
|
||||
(symbol-function 'etaf--runtime-participant-rollback)))
|
||||
(cl-letf
|
||||
(((symbol-function 'tp--run-transaction-precommit-functions)
|
||||
(lambda ()
|
||||
(funcall original-precommit)
|
||||
(error "injected precommit failure")))
|
||||
((symbol-function 'etaf--runtime-participant-rollback)
|
||||
(lambda (participant)
|
||||
(prog1 (funcall original-rollback participant)
|
||||
(let* ((semantic
|
||||
(etaf--generation-participant-semantic-candidate
|
||||
participant))
|
||||
(inverse
|
||||
(etaf-semantic-candidate-inverse-journal semantic)))
|
||||
(setq rollback-evidence
|
||||
(list
|
||||
:generation
|
||||
(eq generation
|
||||
(etaf-runtime-current-generation runtime))
|
||||
:token
|
||||
(= token (etaf-runtime-generation-token runtime))
|
||||
:versions
|
||||
(equal versions
|
||||
(etaf-runtime-store-versions runtime))
|
||||
:candidate-state
|
||||
(etaf-semantic-candidate-state semantic)
|
||||
:journal-state
|
||||
(plist-get inverse :state))))))))
|
||||
(should-error (setf (etaf-value source) 1) :type 'error))
|
||||
(should
|
||||
(equal rollback-evidence
|
||||
'(:generation t :token t :versions t
|
||||
:candidate-state rolled-back
|
||||
:journal-state rolled-back)))
|
||||
(should (equal "value=0"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))
|
||||
(etaf-runtime-flush runtime)
|
||||
(should (equal "value=1"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-semantic-legacy-and-shadow-routes-remain-recoverable ()
|
||||
"Legacy keeps its token while shadow validates and advances the CAS token."
|
||||
(dolist (route '(legacy shadow))
|
||||
(let ((buffer-name
|
||||
(format " *etaf-semantic-%s-route-test*" route))
|
||||
(source (etaf-ref 0))
|
||||
(etaf-semantic-commit-route route))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-generation-test-visible
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime)))
|
||||
(setf (etaf-value source) 1)
|
||||
(should (= (1+ generation)
|
||||
(etaf-runtime-generation runtime)))
|
||||
(should (= (etaf-runtime-generation-token runtime)
|
||||
(if (eq route 'legacy) token (1+ token))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(provide 'etaf-generation-tests)
|
||||
|
||||
;;; etaf-generation-tests.el ends here
|
||||
@ -1,590 +0,0 @@
|
||||
;;; etaf-gui-verifier-tests.el --- Generic GUI scenario engine tests -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
(require 'json)
|
||||
(require 'emacs-gui-verifier)
|
||||
|
||||
(ert-deftest etaf-gui-verifier-measures-success-and-original-failure ()
|
||||
"Each callback retains its own timing, result, and error condition."
|
||||
(let* ((scenario (etaf-gui-verifier-scenario-create :name "measurement"))
|
||||
(context (etaf-gui-verifier--context-create :scenario scenario))
|
||||
(result (list 'exact-result))
|
||||
(error-data (list "original failure" result))
|
||||
(wall-times '(1.0 1.002 10.0 10.03))
|
||||
(cpu-times '((1000 . 1000) (1004 . 1000)
|
||||
(2000 . 1000) (2010 . 1000)))
|
||||
(gcs-done 5) (gc-elapsed 0.1)
|
||||
(calls 0))
|
||||
(cl-letf (((symbol-function 'float-time)
|
||||
(lambda (&optional _time) (pop wall-times)))
|
||||
((symbol-function 'current-cpu-time)
|
||||
(lambda () (pop cpu-times))))
|
||||
(should
|
||||
(eq result
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "success"
|
||||
:execute (lambda (current)
|
||||
(should (eq current context))
|
||||
(cl-incf calls)
|
||||
result)))))
|
||||
(should
|
||||
(equal (cons 'error error-data)
|
||||
(should-error
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "failure"
|
||||
:execute (lambda (_current)
|
||||
(cl-incf calls)
|
||||
(cl-incf gcs-done 2)
|
||||
(cl-incf gc-elapsed 0.003)
|
||||
(signal 'error error-data))))))))
|
||||
(should (= calls 2))
|
||||
(let* ((measurements (etaf-gui-verifier-context-measurements context))
|
||||
(failed (car measurements))
|
||||
(succeeded (cadr measurements))
|
||||
(adapter (etaf-gui-verifier--adapter-data context)))
|
||||
(should (= (length measurements) 2))
|
||||
(should (equal (alist-get 'status succeeded) "success"))
|
||||
(should (equal (alist-get 'status failed) "error"))
|
||||
(should (equal (alist-get 'action_id failed) "failure"))
|
||||
(should-not (alist-get 'valid failed))
|
||||
(should (< (abs (- (alist-get 'wall_ms failed) 30.0)) 0.001))
|
||||
(should (< (abs (- (alist-get 'wall_ms succeeded) 2.0)) 0.001))
|
||||
(should (< (abs (- (alist-get 'cpu_ms failed) 10.0)) 0.001))
|
||||
(should (= (alist-get 'gc_count failed) 2))
|
||||
(should (< (abs (- (alist-get 'gc_ms failed) 3.0)) 0.001))
|
||||
(should (= (alist-get 'duration_ms adapter)
|
||||
(alist-get 'wall_ms failed)))
|
||||
(should (eq (alist-get 'last_measurement adapter) failed))
|
||||
(should-not (assq 'measurements adapter)))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-labels-callback-context-without-changing-it ()
|
||||
"Foreground, background, and unknown callbacks keep their execution context."
|
||||
(let* ((focus t) (calls 0)
|
||||
(inhibit-quit t) (inhibit-redisplay t)
|
||||
(threshold gc-cons-threshold) (percentage gc-cons-percentage)
|
||||
(context
|
||||
(etaf-gui-verifier--context-create
|
||||
:target-buffer (window-buffer (selected-window)))))
|
||||
(cl-letf (((symbol-function 'display-graphic-p)
|
||||
(lambda (&optional _frame) t))
|
||||
((symbol-function 'frame-focus-state)
|
||||
(lambda (&optional _frame) focus))
|
||||
((symbol-function 'redisplay)
|
||||
(lambda (&rest _arguments) (ert-fail "Forced redisplay")))
|
||||
((symbol-function 'sit-for)
|
||||
(lambda (&rest _arguments) (ert-fail "Waited for display")))
|
||||
((symbol-function 'garbage-collect)
|
||||
(lambda () (ert-fail "Forced GC"))))
|
||||
(dolist (state '((t "foreground") (nil "background") (unknown "unknown")))
|
||||
(setq focus (car state))
|
||||
(should
|
||||
(eq 'exact-result
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "context"
|
||||
:execute (lambda (_context)
|
||||
(cl-incf calls)
|
||||
(should inhibit-quit)
|
||||
(should inhibit-redisplay)
|
||||
(should (= gc-cons-threshold threshold))
|
||||
(should (= gc-cons-percentage percentage))
|
||||
'exact-result))
|
||||
(eq focus t))))
|
||||
(let* ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context)))
|
||||
(before (alist-get 'before measurement)))
|
||||
(should (equal (alist-get 'foreground measurement) (cadr state)))
|
||||
(should (equal (alist-get 'status measurement) "success"))
|
||||
(should (alist-get 'valid measurement))
|
||||
(should (alist-get 'inhibit_quit before))
|
||||
(should (alist-get 'inhibit_redisplay before))
|
||||
(should (eq (alist-get 'noninteractive before) noninteractive))
|
||||
(should (stringp (json-serialize measurement))))))
|
||||
(should (= calls 3))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-unselected-target-runs-with-invalid-timing ()
|
||||
"An unchanged unselected target permits the callback but invalidates timing."
|
||||
(let* ((target (generate-new-buffer " *etaf-gui-unselected-target*"))
|
||||
(context (etaf-gui-verifier--context-create :target-buffer target))
|
||||
(result (list 'exact-result))
|
||||
(calls 0))
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'display-graphic-p)
|
||||
(lambda (&optional _frame) t))
|
||||
((symbol-function 'frame-focus-state)
|
||||
(lambda (&optional _frame) nil)))
|
||||
(should
|
||||
(eq result
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "unselected-target"
|
||||
:execute (lambda (_context)
|
||||
(cl-incf calls)
|
||||
result)))))
|
||||
(should (= calls 1))
|
||||
(let ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(should (equal (alist-get 'status measurement) "success"))
|
||||
(should (equal (alist-get 'foreground measurement) "background"))
|
||||
(should (equal (alist-get 'before measurement)
|
||||
(alist-get 'after measurement)))
|
||||
(should-not (alist-get 'target_selected
|
||||
(alist-get 'before measurement)))
|
||||
(should-not (alist-get 'valid measurement))
|
||||
(should (numberp (alist-get 'wall_ms measurement)))))
|
||||
(kill-buffer target))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-foreground-rejection-does-not-execute-or-focus ()
|
||||
"Foreground requirements reject absent focus or targets before execution."
|
||||
(let ((focus t) (graphic t) (calls 0)
|
||||
(context (etaf-gui-verifier--context-create)))
|
||||
(cl-letf (((symbol-function 'display-graphic-p)
|
||||
(lambda (&optional _frame) graphic))
|
||||
((symbol-function 'frame-focus-state)
|
||||
(lambda (&optional _frame) focus))
|
||||
((symbol-function 'raise-frame)
|
||||
(lambda (&rest _arguments) (ert-fail "Raised frame")))
|
||||
((symbol-function 'select-frame-set-input-focus)
|
||||
(lambda (&rest _arguments) (ert-fail "Changed focus")))
|
||||
((symbol-function 'x-focus-frame)
|
||||
(lambda (&rest _arguments) (ert-fail "Focused frame"))))
|
||||
(dolist (state '((nil t t) (unknown t t) (t nil t) (t t nil)))
|
||||
(setq focus (nth 0 state) graphic (nth 1 state))
|
||||
(setf (etaf-gui-verifier-context-target-buffer context)
|
||||
(and (nth 2 state) (window-buffer (selected-window))))
|
||||
(should-error
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "foreground-only" :execute (lambda (_context) (cl-incf calls)))
|
||||
t))
|
||||
(let ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(should (equal (alist-get 'status measurement) "rejected"))
|
||||
(should-not (alist-get 'valid measurement))
|
||||
(should-not (alist-get 'wall_ms measurement)))))
|
||||
(should (zerop calls))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-retains-valid-timing-when-frame-title-changes ()
|
||||
"A GC count in the frame title must not invalidate a stable target."
|
||||
(let* ((gcs-done 713)
|
||||
(calls 0)
|
||||
(result (list 'exact-result))
|
||||
(frame-parameter-function (symbol-function 'frame-parameter))
|
||||
(context
|
||||
(etaf-gui-verifier--context-create
|
||||
:target-buffer (window-buffer (selected-window)))))
|
||||
(cl-letf (((symbol-function 'display-graphic-p)
|
||||
(lambda (&optional _frame) t))
|
||||
((symbol-function 'frame-focus-state)
|
||||
(lambda (&optional _frame) t))
|
||||
((symbol-function 'frame-parameter)
|
||||
(lambda (frame parameter)
|
||||
(if (eq parameter 'name) (format "GC%d" gcs-done)
|
||||
(funcall frame-parameter-function frame parameter)))))
|
||||
(should
|
||||
(eq result
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "title-update"
|
||||
:execute (lambda (_context)
|
||||
(cl-incf calls)
|
||||
(cl-incf gcs-done)
|
||||
result))
|
||||
t))))
|
||||
(should (= calls 1))
|
||||
(let ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(should (equal (alist-get 'status measurement) "success"))
|
||||
(should (equal (alist-get 'foreground measurement) "foreground"))
|
||||
(should (alist-get 'valid measurement))
|
||||
(should (= (alist-get 'gc_count measurement) 1))
|
||||
(should (equal (alist-get 'frame_name (alist-get 'before measurement))
|
||||
"GC713"))
|
||||
(should (equal (alist-get 'frame_name (alist-get 'after measurement))
|
||||
"GC714")))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-invalidates-replaced-selected-target ()
|
||||
"A different live selected buffer remains an identity change."
|
||||
(let ((target (generate-new-buffer " *etaf-gui-original-target*"))
|
||||
(replacement (generate-new-buffer " *etaf-gui-replacement-target*"))
|
||||
(calls 0))
|
||||
(unwind-protect
|
||||
(save-window-excursion
|
||||
(switch-to-buffer target)
|
||||
(let ((context (etaf-gui-verifier--context-create :target-buffer target)))
|
||||
(cl-letf (((symbol-function 'display-graphic-p)
|
||||
(lambda (&optional _frame) t))
|
||||
((symbol-function 'frame-focus-state)
|
||||
(lambda (&optional _frame) t)))
|
||||
(should-error
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "replace-selected-target"
|
||||
:execute (lambda (_context)
|
||||
(cl-incf calls)
|
||||
(setf (etaf-gui-verifier-context-target-buffer context)
|
||||
replacement)
|
||||
(set-window-buffer (selected-window) replacement)))
|
||||
t)))
|
||||
(should (= calls 1))
|
||||
(let ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(should (alist-get 'target_selected
|
||||
(alist-get 'before measurement)))
|
||||
(should (alist-get 'target_selected
|
||||
(alist-get 'after measurement)))
|
||||
(should (equal (alist-get 'status measurement) "invalid"))
|
||||
(should-not (alist-get 'valid measurement)))))
|
||||
(kill-buffer target)
|
||||
(kill-buffer replacement))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-invalidates-changed-foreground-environment ()
|
||||
"Changed focus, target, font, or dimensions invalidate strict timing."
|
||||
(let ((focus t) (width 800) (font "original-font") (calls 0)
|
||||
(frame-parameter-function (symbol-function 'frame-parameter))
|
||||
(context (etaf-gui-verifier--context-create)))
|
||||
(cl-letf (((symbol-function 'display-graphic-p)
|
||||
(lambda (&optional _frame) t))
|
||||
((symbol-function 'frame-focus-state)
|
||||
(lambda (&optional _frame) focus))
|
||||
((symbol-function 'frame-pixel-width)
|
||||
(lambda (&optional _frame) width))
|
||||
((symbol-function 'frame-parameter)
|
||||
(lambda (frame parameter)
|
||||
(if (eq parameter 'font) font
|
||||
(funcall frame-parameter-function frame parameter)))))
|
||||
(dolist (change '(focus target font dimensions))
|
||||
(setq focus t width 800 font "original-font")
|
||||
(setf (etaf-gui-verifier-context-target-buffer context)
|
||||
(window-buffer (selected-window)))
|
||||
(should-error
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id (symbol-name change)
|
||||
:execute
|
||||
(lambda (_context)
|
||||
(cl-incf calls)
|
||||
(pcase change
|
||||
('focus (setq focus nil))
|
||||
('target
|
||||
(setf (etaf-gui-verifier-context-target-buffer context) nil))
|
||||
('font (setq font "changed-font"))
|
||||
('dimensions (setq width 900)))))
|
||||
t))
|
||||
(let ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(should (equal (alist-get 'status measurement) "invalid"))
|
||||
(should (equal (alist-get 'foreground measurement) "changed"))
|
||||
(should-not (alist-get 'valid measurement))
|
||||
(should (numberp (alist-get 'wall_ms measurement))))))
|
||||
(should (= calls 4))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-preserves-quit-despite-focus-change ()
|
||||
"A quit keeps its exact data even if strict environment checks also fail."
|
||||
(let* ((focus t)
|
||||
(quit-data (list 'original-quit))
|
||||
(context
|
||||
(etaf-gui-verifier--context-create
|
||||
:target-buffer (window-buffer (selected-window)))))
|
||||
(cl-letf (((symbol-function 'display-graphic-p)
|
||||
(lambda (&optional _frame) t))
|
||||
((symbol-function 'frame-focus-state)
|
||||
(lambda (&optional _frame) focus)))
|
||||
(should
|
||||
(equal (cons 'quit quit-data)
|
||||
(condition-case condition
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "quit"
|
||||
:execute (lambda (_context)
|
||||
(setq focus nil)
|
||||
(signal 'quit quit-data)))
|
||||
t)
|
||||
(quit condition)))))
|
||||
(let ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(should (equal (alist-get 'status measurement) "quit"))
|
||||
(should (equal (alist-get 'foreground measurement) "changed"))
|
||||
(should-not (alist-get 'valid measurement))
|
||||
(should (numberp (alist-get 'wall_ms measurement))))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-retains-timing-despite-closing-snapshot-failure ()
|
||||
"Snapshot errors and quits preserve action failures and retain fresh timing."
|
||||
(dolist (action-outcome '(error quit success))
|
||||
(dolist (snapshot-outcome '(error quit))
|
||||
(let* ((context
|
||||
(etaf-gui-verifier--context-create
|
||||
:target-buffer (window-buffer (selected-window))
|
||||
:last-duration-ms 999.0))
|
||||
(before (etaf-gui-verifier--measurement-state context))
|
||||
(result (list 'exact-result))
|
||||
(action-data (list "original-action-failure" result))
|
||||
(snapshot-data (list "snapshot-interrupted" result))
|
||||
(wall-times '(1.0 1.025))
|
||||
(calls 0) (snapshots 0) observed-condition returned)
|
||||
(cl-letf (((symbol-function 'float-time)
|
||||
(lambda (&optional _time) (pop wall-times)))
|
||||
((symbol-function 'etaf-gui-verifier--measurement-state)
|
||||
(lambda (_context)
|
||||
(if (= (cl-incf snapshots) 1) before
|
||||
(signal snapshot-outcome snapshot-data)))))
|
||||
(setq returned
|
||||
(condition-case condition
|
||||
(etaf-gui-verifier-measure-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "snapshot-failure"
|
||||
:execute (lambda (_context)
|
||||
(cl-incf calls)
|
||||
(if (eq action-outcome 'success) result
|
||||
(signal action-outcome action-data)))))
|
||||
((error quit)
|
||||
(setq observed-condition condition)
|
||||
nil))))
|
||||
(should (= calls 1))
|
||||
(should (= snapshots 2))
|
||||
(cond
|
||||
((not (eq action-outcome 'success))
|
||||
(should (eq (car observed-condition) action-outcome))
|
||||
(should (eq (cdr observed-condition) action-data)))
|
||||
((eq snapshot-outcome 'quit)
|
||||
(should (eq (car observed-condition) 'quit))
|
||||
(should (eq (cdr observed-condition) snapshot-data)))
|
||||
(t
|
||||
(should-not observed-condition)
|
||||
(should (eq returned result))))
|
||||
(let* ((measurements (etaf-gui-verifier-context-measurements context))
|
||||
(measurement (car measurements)))
|
||||
(should (= (length measurements) 1))
|
||||
(should-not (alist-get 'valid measurement))
|
||||
(should-not (alist-get 'after measurement))
|
||||
(should
|
||||
(equal (alist-get 'status measurement)
|
||||
(symbol-name
|
||||
(if (and (eq action-outcome 'success)
|
||||
(eq snapshot-outcome 'quit))
|
||||
'quit action-outcome))))
|
||||
(should (< (abs (- (alist-get 'wall_ms measurement) 25.0)) 0.001))
|
||||
(should (= (etaf-gui-verifier-context-last-duration-ms context)
|
||||
(alist-get 'wall_ms measurement))))))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-measures-callback-without-settle-or-checkpoints ()
|
||||
"The action callback is timed separately from checkpoints and settling."
|
||||
(let ((context (etaf-gui-verifier--context-create))
|
||||
(clock 0.0) events)
|
||||
(cl-letf (((symbol-function 'float-time)
|
||||
(lambda (&optional _time) clock))
|
||||
((symbol-function 'etaf-gui-verifier--checkpoint)
|
||||
(lambda (_context _id phase _screenshot &optional _extra)
|
||||
(cl-incf clock 1.0)
|
||||
(push phase events)))
|
||||
((symbol-function 'etaf-gui-verifier--settle-action)
|
||||
(lambda (_context _action)
|
||||
(cl-incf clock 2.0)
|
||||
(push 'settle events))))
|
||||
(etaf-gui-verifier--run-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "callback-only"
|
||||
:execute (lambda (_context)
|
||||
(cl-incf clock 0.025)
|
||||
(push 'execute events)))))
|
||||
(should (< (abs (- (etaf-gui-verifier-context-last-duration-ms context)
|
||||
25.0))
|
||||
0.001))
|
||||
(should (equal (nreverse events)
|
||||
'("before-action" execute "after-action"
|
||||
settle "after-redisplay")))
|
||||
(let ((measurement
|
||||
(car (etaf-gui-verifier-context-measurements context))))
|
||||
(should (equal (alist-get 'boundary measurement) "action.execute callback"))
|
||||
(should-not (alist-get 'presentation_measured measurement)))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-runs-and-settles-without-raising-frame ()
|
||||
"Actions and settled checkpoints must complete without raising Emacs."
|
||||
(let ((context (etaf-gui-verifier--context-create))
|
||||
(settle-checks 0)
|
||||
events)
|
||||
(cl-letf (((symbol-function 'raise-frame)
|
||||
(lambda (&rest _arguments)
|
||||
(error "GUI verifier must preserve application focus")))
|
||||
((symbol-function 'etaf-gui-verifier--checkpoint)
|
||||
(lambda (_context _action-id phase _screenshot &optional _extra)
|
||||
(push phase events))))
|
||||
(etaf-gui-verifier--run-action
|
||||
context
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "background-action" :settle-interval 0.001
|
||||
:execute
|
||||
(lambda (current)
|
||||
(etaf-gui-verifier-context-put current 'executed t)
|
||||
(push 'execute events))
|
||||
:settled-p
|
||||
(lambda (current)
|
||||
(should (etaf-gui-verifier-context-get current 'executed))
|
||||
(cl-incf settle-checks)
|
||||
(push 'settle events)
|
||||
t)
|
||||
:assertions
|
||||
(lambda (_current)
|
||||
(push 'assertions events)
|
||||
(list (etaf-gui-verifier-assert "action-settled" t))))))
|
||||
(should (= 1 (etaf-gui-verifier-context-action-count context)))
|
||||
(should (= 2 settle-checks))
|
||||
(should
|
||||
(equal '("before-action" execute "after-action" settle settle
|
||||
assertions "after-redisplay")
|
||||
(nreverse events)))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-composes-generic-scenario-actions ()
|
||||
"The engine should own ordering while adapters own actions and assertions."
|
||||
(let ((buffer (generate-new-buffer " *etaf-gui-verifier-test*"))
|
||||
events checkpoints finished (settle-checks 0))
|
||||
(unwind-protect
|
||||
(cl-letf
|
||||
(((symbol-function 'emacs-dynamic-ui-verification-start)
|
||||
(lambda (_directory run-id _claim phases)
|
||||
(push (list 'start run-id phases) events)))
|
||||
((symbol-function 'emacs-dynamic-ui-verification-checkpoint)
|
||||
(lambda (action phase adapter assertions screenshot)
|
||||
(push (list action phase adapter assertions screenshot)
|
||||
checkpoints)))
|
||||
((symbol-function 'emacs-dynamic-ui-verification-finish)
|
||||
(lambda (completed adapter)
|
||||
(setq finished (list completed adapter)))))
|
||||
(let* ((scenario
|
||||
(etaf-gui-verifier-scenario-create
|
||||
:name "generic"
|
||||
:claim "generic claim"
|
||||
:initialize
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-select-buffer context buffer))
|
||||
:invariants
|
||||
(lambda (context)
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"buffer-live"
|
||||
(buffer-live-p
|
||||
(etaf-gui-verifier-context-target-buffer context)))))
|
||||
:adapter
|
||||
(lambda (context)
|
||||
(list
|
||||
(cons 'size
|
||||
(with-current-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context)
|
||||
(buffer-size)))))
|
||||
:actions
|
||||
(list
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "insert-a" :settle-interval 0.001
|
||||
:execute
|
||||
(lambda (context)
|
||||
(with-current-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context)
|
||||
(insert "A")))
|
||||
:settled-p
|
||||
(lambda (_context)
|
||||
(>= (cl-incf settle-checks) 2))
|
||||
:assertions
|
||||
(lambda (context)
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"one-character"
|
||||
(= 1
|
||||
(with-current-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context)
|
||||
(buffer-size))))))
|
||||
:screenshot t)
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "insert-b"
|
||||
:execute
|
||||
(lambda (context)
|
||||
(with-current-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context)
|
||||
(insert "B")))
|
||||
:settled-p (lambda (_context) t)))
|
||||
:completion
|
||||
(lambda (context)
|
||||
(= 2 (etaf-gui-verifier-context-action-count context)))))
|
||||
(context (etaf-gui-verifier-run scenario "/tmp/generic")))
|
||||
(should (= 2 (etaf-gui-verifier-context-action-count context)))
|
||||
(should (equal "AB" (with-current-buffer buffer (buffer-string))))
|
||||
(should (car finished))
|
||||
(should (= settle-checks 3))
|
||||
(should (= 6 (length checkpoints)))
|
||||
(should
|
||||
(equal
|
||||
'("before-action" "after-action" "after-redisplay"
|
||||
"before-action" "after-action" "after-redisplay")
|
||||
(mapcar #'cadr (nreverse checkpoints))))))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-rejects-invalid-settle-contracts ()
|
||||
"Every action should have a bounded, non-busy settle contract."
|
||||
(let ((context (etaf-gui-verifier--context-create)))
|
||||
(dolist
|
||||
(action
|
||||
(list
|
||||
(etaf-gui-verifier-action-create :id "missing")
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "timeout" :settled-p (lambda (_context) t)
|
||||
:settle-timeout 0)
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "interval" :settled-p (lambda (_context) t)
|
||||
:settle-interval 0)))
|
||||
(should-error (etaf-gui-verifier--settle-action context action)))))
|
||||
|
||||
(ert-deftest etaf-gui-verifier-timeout-finishes-false-and-propagates ()
|
||||
"A settle timeout should finish incomplete and preserve its error."
|
||||
(let ((buffer (generate-new-buffer " *etaf-gui-timeout-test*"))
|
||||
finished)
|
||||
(unwind-protect
|
||||
(cl-letf
|
||||
(((symbol-function 'emacs-dynamic-ui-verification-start)
|
||||
(lambda (&rest _arguments) nil))
|
||||
((symbol-function 'emacs-dynamic-ui-verification-checkpoint)
|
||||
(lambda (&rest _arguments) nil))
|
||||
((symbol-function 'emacs-dynamic-ui-verification-finish)
|
||||
(lambda (completed adapter)
|
||||
(setq finished (list completed adapter)))))
|
||||
(let* ((scenario
|
||||
(etaf-gui-verifier-scenario-create
|
||||
:name "timeout"
|
||||
:claim "timeout must fail closed"
|
||||
:initialize
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-select-buffer context buffer))
|
||||
:actions
|
||||
(list
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "never-settles"
|
||||
:execute (lambda (_context) nil)
|
||||
:settled-p (lambda (_context) nil)
|
||||
:settle-timeout 0.003
|
||||
:settle-interval 0.001))))
|
||||
(error-data
|
||||
(should-error
|
||||
(etaf-gui-verifier-run scenario "/tmp/timeout"))))
|
||||
(should
|
||||
(string-match-p
|
||||
"did not settle" (error-message-string error-data)))
|
||||
(should finished)
|
||||
(should-not (car finished))))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(provide 'etaf-gui-verifier-tests)
|
||||
;;; etaf-gui-verifier-tests.el ends here
|
||||
@ -1,215 +0,0 @@
|
||||
;;; etaf-host-tests.el --- M3a Host authority gates -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
(require 'tp-transaction)
|
||||
|
||||
(defvar etaf-host-test-unmount-error-p nil)
|
||||
|
||||
(etaf-define-component etaf-host-test-component (&key source fail-unmount)
|
||||
"Render SOURCE and optionally fail the public unmounted hook."
|
||||
:setup
|
||||
(progn
|
||||
(etaf-on-unmounted
|
||||
(lambda ()
|
||||
(when (or fail-unmount etaf-host-test-unmount-error-p)
|
||||
(error "injected Host retirement failure"))))
|
||||
nil)
|
||||
:view
|
||||
(text :ref 'host-value (expr (format "host=%s" (etaf-value source)))))
|
||||
|
||||
(ert-deftest etaf-host-initial-marker-attaches-on-final-accept-only ()
|
||||
"Initial v2 mount uses one marker; ordinary update uses zero markers."
|
||||
(let ((buffer-name " *etaf-host-marker-test*")
|
||||
(source (etaf-ref 0))
|
||||
lookup-during-stage
|
||||
(original-stage (symbol-function 'etaf-host-authority-stage-attach)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(cl-letf (((symbol-function 'etaf-host-authority-stage-attach)
|
||||
(lambda (authority)
|
||||
(setq lookup-during-stage
|
||||
(etaf-runtime-for-buffer buffer-name))
|
||||
(funcall original-stage authority))))
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-host-test-component
|
||||
(list :source source) nil)))
|
||||
(should-not lookup-during-stage)
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(authority (etaf-runtime-host-authority runtime)))
|
||||
(should (etaf-host-authority-attached-p authority))
|
||||
(should (= (etaf-host-authority-version authority) 1))
|
||||
(should (= (tp-committed-success-outcome-marker-count
|
||||
tp--last-transaction-outcome)
|
||||
1))
|
||||
(setf (etaf-value source) 1)
|
||||
(should (= (tp-committed-success-outcome-marker-count
|
||||
tp--last-transaction-outcome)
|
||||
0))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-host-initial-faults-restore-detached-authority ()
|
||||
"Precommit and final-accept faults restore Host and Ebox initial state."
|
||||
(dolist (phase '(precommit final-accept))
|
||||
(let ((buffer-name
|
||||
(format " *etaf-host-%s-fault-test*" phase))
|
||||
captured-authority
|
||||
(source (etaf-ref 0))
|
||||
(original-create (symbol-function 'etaf-host-authority-create))
|
||||
(original-precommit
|
||||
(symbol-function 'tp--run-transaction-precommit-functions))
|
||||
(original-accept (symbol-function 'accept-change-group)))
|
||||
(unwind-protect
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf-host-authority-create)
|
||||
(lambda (&rest arguments)
|
||||
(setq captured-authority (apply original-create arguments))))
|
||||
((symbol-function 'tp--run-transaction-precommit-functions)
|
||||
(if (eq phase 'precommit)
|
||||
(lambda ()
|
||||
(funcall original-precommit)
|
||||
(error "injected Host precommit failure"))
|
||||
original-precommit))
|
||||
((symbol-function 'accept-change-group)
|
||||
(if (eq phase 'final-accept)
|
||||
(lambda (_group)
|
||||
(error "injected Host final-accept failure"))
|
||||
original-accept)))
|
||||
(should-error
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-host-test-component
|
||||
(list :source source) nil))
|
||||
:type 'error)
|
||||
(should (etaf-host-authority-p captured-authority))
|
||||
(should (eq (etaf-host-authority-state captured-authority)
|
||||
'detached))
|
||||
(should (zerop
|
||||
(etaf-host-authority-version captured-authority)))
|
||||
(should-not (etaf-runtime-for-buffer buffer-name))
|
||||
(should-not
|
||||
(ebox-surface-buffer-mounted-p (get-buffer buffer-name))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(ert-deftest etaf-host-postaccept-report-fault-still-finishes-attach ()
|
||||
"Ebox report-finalization failure cannot roll back an accepted Host."
|
||||
(let ((buffer-name " *etaf-host-report-postaccept-test*")
|
||||
(source (etaf-ref 0))
|
||||
(rollback-count 0)
|
||||
(original-rollback
|
||||
(symbol-function 'etaf-semantic-candidate-rollback)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-surface--participant-complete)
|
||||
(lambda (&rest _arguments)
|
||||
(error "injected initial report finalization fault")))
|
||||
((symbol-function 'etaf-semantic-candidate-rollback)
|
||||
(lambda (candidate)
|
||||
(cl-incf rollback-count)
|
||||
(funcall original-rollback candidate))))
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-host-test-component
|
||||
(list :source source) nil)))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(authority (etaf-runtime-host-authority runtime)))
|
||||
(should runtime)
|
||||
(should (etaf-host-authority-attached-p authority))
|
||||
(should (zerop rollback-count))
|
||||
(should (ebox-surface-buffer-mounted-p
|
||||
(get-buffer buffer-name)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-host-unmount-invalidates-before-component-cleanup ()
|
||||
"Explicit unmount invalidates Host token before any Component hook runs."
|
||||
(let ((buffer-name " *etaf-host-unmount-boundary-test*")
|
||||
(source (etaf-ref 0))
|
||||
checked)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-host-test-component
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(authority (etaf-runtime-host-authority runtime))
|
||||
(original
|
||||
(symbol-function 'etaf--runtime-dispose-instance)))
|
||||
(cl-letf (((symbol-function 'etaf--runtime-dispose-instance)
|
||||
(lambda (&rest arguments)
|
||||
(should-not (etaf-host-authority-token authority))
|
||||
(should (eq (etaf-host-authority-state authority)
|
||||
'detached-retiring))
|
||||
(setq checked t)
|
||||
(apply original arguments))))
|
||||
(etaf-unmount runtime))
|
||||
(should checked)
|
||||
(should (eq (etaf-host-authority-state authority) 'terminal))
|
||||
(should-not (etaf-runtime-for-buffer buffer-name))
|
||||
(should (eq (etaf--runtime-unmount-now runtime) runtime))
|
||||
(should-error (etaf-unmount runtime) :type 'etaf-runtime-error)))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-host-kill-contains-user-cleanup-failure ()
|
||||
"Buffer kill never rethrows user cleanup after Host authority invalidation."
|
||||
(let ((buffer-name " *etaf-host-kill-contained-test*")
|
||||
(source (etaf-ref 0))
|
||||
runtime authority)
|
||||
(setq etaf-host-test-unmount-error-p nil)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-host-test-component
|
||||
(list :source source :fail-unmount t) nil))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name)
|
||||
authority (etaf-runtime-host-authority runtime))
|
||||
(kill-buffer (get-buffer buffer-name))
|
||||
(should (eq (etaf-host-authority-state authority) 'terminal))
|
||||
(should-not (etaf-runtime-mounted-p runtime))
|
||||
(should-not (gethash (etaf-runtime-mount-epoch runtime)
|
||||
etaf--runtime-route-registry)))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-host-detach-makes-route-token-stale ()
|
||||
"A detached Host route cannot schedule later source changes."
|
||||
(let ((buffer-name " *etaf-host-stale-route-test*")
|
||||
(source (etaf-ref 0))
|
||||
runtime route)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-host-test-component
|
||||
(list :source source) nil))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name)
|
||||
route (etaf-runtime-route-token runtime))
|
||||
(etaf-unmount runtime)
|
||||
(should-not
|
||||
(etaf-host-authority-accepts-token-p
|
||||
(etaf-runtime-host-authority runtime)
|
||||
(etaf-runtime-route-authority-token route)))
|
||||
(setf (etaf-value source) 1)
|
||||
(should-not (etaf-runtime-pending-p runtime)))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(provide 'etaf-host-tests)
|
||||
|
||||
;;; etaf-host-tests.el ends here
|
||||
@ -1,284 +0,0 @@
|
||||
;;; etaf-interaction-contract-tests.el --- Interaction contract tests -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Lock the M0b Action, Behavior, and local event composition contract.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
|
||||
(defun etaf-interaction-test--dispose-buffer (buffer-name)
|
||||
"Unmount and kill BUFFER-NAME when either still exists."
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))
|
||||
|
||||
(ert-deftest etaf-interaction-duplicate-behavior-fails-before-install ()
|
||||
"Reject duplicate names on one Host without running either installer."
|
||||
(let ((buffer-name " *etaf-duplicate-behavior-contract*")
|
||||
(installs 0))
|
||||
(unwind-protect
|
||||
(let ((first
|
||||
(etaf-behavior-create
|
||||
'duplicate
|
||||
:install (lambda () (cl-incf installs) #'ignore)))
|
||||
(second
|
||||
(etaf-behavior-create
|
||||
'duplicate
|
||||
:install (lambda () (cl-incf installs) #'ignore))))
|
||||
(should-error
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'text (list :ref 'target :use (list first second))
|
||||
(list "target"))))
|
||||
:type 'etaf-behavior-error)
|
||||
(should (zerop installs)))
|
||||
(etaf-interaction-test--dispose-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-interaction-behaviors-compose-in-declaration-order ()
|
||||
"Preserve installer/event order, first-wins props, and one cleanup each."
|
||||
(let ((buffer-name " *etaf-behavior-order-contract*")
|
||||
install-order event-order cleanup-counts)
|
||||
(unwind-protect
|
||||
(let* ((first
|
||||
(etaf-behavior-create
|
||||
'first
|
||||
:class "first"
|
||||
:on-press (lambda () (setq event-order
|
||||
(append event-order '(first))))
|
||||
:install (lambda ()
|
||||
(setq install-order (append install-order '(first)))
|
||||
(lambda () (push 'first cleanup-counts)))))
|
||||
(second
|
||||
(etaf-behavior-create
|
||||
'second
|
||||
:class "second"
|
||||
:on-press (lambda () (setq event-order
|
||||
(append event-order '(second))))
|
||||
:install (lambda ()
|
||||
(setq install-order (append install-order '(second)))
|
||||
(lambda () (push 'second cleanup-counts))))))
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'text
|
||||
(list :ref 'target :use (list first second)
|
||||
:on-press
|
||||
(lambda () (setq event-order (append event-order '(host)))))
|
||||
(list "target"))))
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(should (equal install-order '(first second)))
|
||||
(should (equal (plist-get
|
||||
(etaf-runtime-host-props-for runtime 'target)
|
||||
:class)
|
||||
"first"))
|
||||
(etaf-dispatch-event runtime 'target 'press)
|
||||
(should (equal event-order '(host first second)))
|
||||
(etaf-unmount runtime))
|
||||
(should (= 1 (cl-count 'first cleanup-counts)))
|
||||
(should (= 1 (cl-count 'second cleanup-counts))))
|
||||
(etaf-interaction-test--dispose-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-interaction-callback-failure-short-circuits-behaviors ()
|
||||
"Stop Behavior callbacks after an earlier callback signals."
|
||||
(let ((buffer-name " *etaf-behavior-failure-contract*") trace)
|
||||
(unwind-protect
|
||||
(let ((first
|
||||
(etaf-behavior-create
|
||||
'first :on-press
|
||||
(lambda () (push 'first trace) (error "first failed"))))
|
||||
(second
|
||||
(etaf-behavior-create
|
||||
'second :on-press (lambda () (push 'second trace)))))
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'text
|
||||
(list :ref 'target :use (list first second)
|
||||
:on-press (lambda () (push 'host trace) (error "host failed")))
|
||||
(list "target"))))
|
||||
(should-error
|
||||
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
||||
'target 'press))
|
||||
(should (equal trace '(host)))
|
||||
(etaf-unmount (etaf-runtime-for-buffer buffer-name))
|
||||
(setq trace nil)
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'text
|
||||
(list :ref 'target :use (list first second)
|
||||
:on-press (lambda () (push 'host trace)))
|
||||
(list "target"))))
|
||||
(should-error
|
||||
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
||||
'target 'press))
|
||||
(should (equal trace '(first host))))
|
||||
(etaf-interaction-test--dispose-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-interaction-stable-installer-identity-cleans-up-once ()
|
||||
"Reuse an identical installer and run its cleanup exactly once."
|
||||
(let ((buffer-name " *etaf-behavior-identity-contract*")
|
||||
(trigger (etaf-ref 0))
|
||||
(installs 0)
|
||||
(cleanups 0))
|
||||
(unwind-protect
|
||||
(let* ((installer
|
||||
(lambda ()
|
||||
(cl-incf installs)
|
||||
(lambda () (cl-incf cleanups))))
|
||||
(behavior
|
||||
(etaf-behavior-create 'stable :install installer)))
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'text
|
||||
(list :ref 'target :use behavior
|
||||
:aria-label (format "version-%d" (etaf-value trigger)))
|
||||
(list "target"))))
|
||||
(should (= installs 1))
|
||||
(setf (etaf-value trigger) 1)
|
||||
(should (= installs 1))
|
||||
(should (zerop cleanups))
|
||||
(etaf-unmount (etaf-runtime-for-buffer buffer-name))
|
||||
(should (= cleanups 1)))
|
||||
(etaf-interaction-test--dispose-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-interaction-events-do-not-capture-or-bubble ()
|
||||
"Dispatch only the callback owned by the exact Host reference."
|
||||
(let ((buffer-name " *etaf-local-event-contract*") trace)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'column
|
||||
(list :ref 'parent :on-press (lambda () (push 'parent trace)))
|
||||
(list
|
||||
(etaf--view-call
|
||||
'text
|
||||
(list :ref 'child :on-press (lambda () (push 'child trace)))
|
||||
(list "child"))))))
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-dispatch-event runtime 'child 'press)
|
||||
(should (equal trace '(child)))
|
||||
(setq trace nil)
|
||||
(etaf-dispatch-event runtime 'parent 'press)
|
||||
(should (equal trace '(parent)))))
|
||||
(etaf-interaction-test--dispose-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-action-duplicate-registration-errors-by-default ()
|
||||
"Keep the first Action when another application claims the same name."
|
||||
(let ((name 'etaf-interaction-test-cross-app-action)
|
||||
(first (lambda (_runtime) 'first))
|
||||
(second (lambda (_runtime) 'second)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-action-register name first)
|
||||
(should-error (etaf-action-register name second)
|
||||
:type 'etaf-action-error)
|
||||
(should (eq first
|
||||
(etaf-action-spec-function
|
||||
(gethash name etaf--action-registry)))))
|
||||
(etaf-action-undefine name))))
|
||||
|
||||
(ert-deftest etaf-action-redefine-boundary-affects-only-future-dispatch ()
|
||||
"Replace name lookup explicitly without flushing a mounted Runtime."
|
||||
(let ((buffer-name " *etaf-action-redefine-contract*")
|
||||
(name 'etaf-interaction-test-future-action)
|
||||
(first-calls 0)
|
||||
(second-calls 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-action-register
|
||||
name (lambda (_runtime) (cl-incf first-calls)))
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'text
|
||||
(list :ref 'target
|
||||
:on-press (lambda () (etaf-dispatch name)))
|
||||
(list "target"))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-current-generation runtime)))
|
||||
(etaf-dispatch-event runtime 'target 'press)
|
||||
(should (= first-calls 1))
|
||||
(etaf-action-redefine-run
|
||||
(lambda ()
|
||||
(etaf-action-register
|
||||
name (lambda (_runtime) (cl-incf second-calls)))))
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (= first-calls 1))
|
||||
(should (zerop second-calls))
|
||||
(etaf-dispatch-event runtime 'target 'press)
|
||||
(should (= second-calls 1))))
|
||||
(etaf-action-undefine name)
|
||||
(etaf-interaction-test--dispose-buffer buffer-name))))
|
||||
|
||||
(ert-deftest etaf-action-reload-requires-explicit-redefine-boundary ()
|
||||
"Make repeated authoring definitions explicit and dynamically scoped."
|
||||
(let ((name 'etaf-interaction-test-reload-action)
|
||||
(function-symbol 'etaf-interaction-test-reload-action--etaf-action))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
||||
(_runtime)
|
||||
'first)
|
||||
t)
|
||||
(should-error
|
||||
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
||||
(_runtime)
|
||||
'unintended)
|
||||
t)
|
||||
:type 'etaf-action-error)
|
||||
(should
|
||||
(eq 'first
|
||||
(funcall
|
||||
(etaf-action-spec-function
|
||||
(gethash name etaf--action-registry))
|
||||
nil)))
|
||||
(etaf-action-redefine-run
|
||||
(lambda ()
|
||||
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
||||
(_runtime)
|
||||
'second)
|
||||
t)))
|
||||
(should
|
||||
(eq 'second
|
||||
(funcall
|
||||
(etaf-action-spec-function
|
||||
(gethash name etaf--action-registry))
|
||||
nil)))
|
||||
(should-error
|
||||
(eval '(etaf-action-define etaf-interaction-test-reload-action
|
||||
(_runtime)
|
||||
'unintended)
|
||||
t)
|
||||
:type 'etaf-action-error)
|
||||
(should
|
||||
(eq 'second
|
||||
(funcall
|
||||
(etaf-action-spec-function
|
||||
(gethash name etaf--action-registry))
|
||||
nil))))
|
||||
(etaf-action-undefine name)
|
||||
(when (fboundp function-symbol)
|
||||
(fmakunbound function-symbol)))))
|
||||
|
||||
(provide 'etaf-interaction-contract-tests)
|
||||
|
||||
;;; etaf-interaction-contract-tests.el ends here
|
||||
@ -1,203 +0,0 @@
|
||||
;;; etaf-m0a-current-characterization-tests.el --- M0a ETAF baseline -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
(require 'etaf-m0a-inventory)
|
||||
|
||||
(define-error 'etaf-test-m0a-lifecycle-condition
|
||||
"M0a lifecycle characterization condition")
|
||||
|
||||
(defconst etaf-test-m0a-condition-data
|
||||
'(:phase updated
|
||||
:payload ((account-id . 42) (tags alpha beta))
|
||||
:retryable nil)
|
||||
"Non-trivial raw condition data used by the M0a public update probe.")
|
||||
|
||||
(etaf-define-component etaf-test-m0a-dependency-only (&key source)
|
||||
"Observe SOURCE while retaining equal rendered output."
|
||||
:view (text (expr (progn (etaf-value source) "same"))))
|
||||
|
||||
(etaf-define-component etaf-test-m0a-lifecycle-failure (&key label)
|
||||
"Publish LABEL, then signal a custom condition from the update lifecycle."
|
||||
:setup
|
||||
(progn
|
||||
(etaf-on-updated
|
||||
(lambda ()
|
||||
(signal 'etaf-test-m0a-lifecycle-condition
|
||||
etaf-test-m0a-condition-data)))
|
||||
nil)
|
||||
:view (text (expr label)))
|
||||
|
||||
(ert-deftest etaf-m0a-action-registration-requires-explicit-redefinition ()
|
||||
"Duplicate Action registration fails outside the authoring boundary."
|
||||
(let* ((name (make-symbol "etaf-m0a-action"))
|
||||
(first (lambda (_runtime) 'first))
|
||||
(second (lambda (_runtime) 'second)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-action-register name first)
|
||||
(should-error (etaf-action-register name second)
|
||||
:type 'etaf-action-error)
|
||||
(should (eq first
|
||||
(etaf-action-spec-function
|
||||
(gethash name etaf--action-registry))))
|
||||
(etaf-action-redefine-run
|
||||
(lambda () (etaf-action-register name second)))
|
||||
(should (eq second
|
||||
(etaf-action-spec-function
|
||||
(gethash name etaf--action-registry)))))
|
||||
(etaf-action-undefine name))))
|
||||
|
||||
(ert-deftest etaf-m0a-event-kind-normalizes-current-spellings ()
|
||||
"Keyword, symbol, and string event spellings normalize to one symbol."
|
||||
(dolist (spelling '(:press press on-press "press" "on-press"))
|
||||
(should (eq 'press (etaf-event-kind spelling)))))
|
||||
|
||||
(ert-deftest etaf-m0a-dependency-only-skips-ebox-and-tp-publication ()
|
||||
"An equal-output dependency update advances ETAF only, not Ebox or TP."
|
||||
(let ((buffer-name " *etaf-m0a-dependency-only*")
|
||||
(source (etaf-ref 0))
|
||||
(ebox-commits 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view (etaf-test-m0a-dependency-only :source source)))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(surface (with-current-buffer buffer-name
|
||||
(car tp--buffer-surfaces)))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(revision (tp-surface-revision surface))
|
||||
(original-ebox-commit (symbol-function 'ebox-commit)))
|
||||
(cl-letf (((symbol-function 'ebox-commit)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf ebox-commits)
|
||||
(apply original-ebox-commit arguments))))
|
||||
(setf (etaf-value source) 1))
|
||||
(should (= (1+ generation) (etaf-runtime-generation runtime)))
|
||||
(should (zerop ebox-commits))
|
||||
(should (= revision (tp-surface-revision surface)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-m0a-repeated-public-unmount-signals-runtime-error ()
|
||||
"Calling the public unmount boundary twice signals runtime error."
|
||||
(let ((buffer-name " *etaf-m0a-repeated-unmount*") runtime)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-view (text "mounted")))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(etaf-unmount runtime)
|
||||
(should-error (etaf-unmount runtime) :type 'etaf-runtime-error))
|
||||
(when (and runtime (etaf-runtime-mounted-p runtime))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-m0a-public-update-preserves-raw-condition-symbol-and-data ()
|
||||
"A public update exposes the exact lifecycle condition symbol and payload."
|
||||
(let ((buffer-name " *etaf-m0a-lifecycle-condition*")
|
||||
(label (etaf-ref "A"))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(etaf-test-m0a-lifecycle-failure
|
||||
:label (etaf-value label)))))
|
||||
(condition-case condition
|
||||
(setf (etaf-value label) "B")
|
||||
(etaf-test-m0a-lifecycle-condition
|
||||
(setq captured condition)))
|
||||
(should
|
||||
(eq (car captured) 'etaf-test-m0a-lifecycle-condition))
|
||||
(should (equal (butlast (cdr captured))
|
||||
etaf-test-m0a-condition-data))
|
||||
(should (etaf-condition-postcommit-info captured))
|
||||
(should (equal "B"
|
||||
(with-current-buffer buffer-name
|
||||
(buffer-string)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-m0a-condition-consumer-inventory-is-machine-readable ()
|
||||
"The source consumer inventory exactly matches its reviewed golden."
|
||||
(let ((consumers (etaf-m0a-condition-consumer-inventory))
|
||||
(golden-file
|
||||
(expand-file-name "tests/fixtures/etaf-m0a-condition-consumers.sexp"
|
||||
etaf-m0a-package-root)))
|
||||
(should consumers)
|
||||
(should (cl-find "etaf-runtime.el" consumers
|
||||
:key (lambda (entry) (plist-get entry :file))
|
||||
:test #'equal))
|
||||
(should (cl-every (lambda (entry)
|
||||
(and (stringp (plist-get entry :file))
|
||||
(integerp (plist-get entry :line))
|
||||
(symbolp (plist-get entry :form))
|
||||
(proper-list-p (plist-get entry :conditions))
|
||||
(symbolp (plist-get entry :owner))
|
||||
(memq (plist-get entry :policy)
|
||||
'(generic-containment
|
||||
specific-compatibility))))
|
||||
consumers))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents golden-file)
|
||||
(should (equal (read (current-buffer))
|
||||
(etaf-m0a-condition-consumer-signatures)))
|
||||
(skip-chars-forward " \t\r\n")
|
||||
(should (eobp)))
|
||||
(should (cl-find 'observed-baseline
|
||||
etaf-m0a-current-contract-inventory
|
||||
:key (lambda (entry)
|
||||
(plist-get entry :evidence-mode))))
|
||||
(let ((json (json-parse-string (etaf-m0a-inventory-json))))
|
||||
(should (= 1 (gethash "schema-version" json)))
|
||||
(should (= (length etaf-m0a-current-contract-inventory)
|
||||
(length (gethash "contract-inventory" json))))
|
||||
(should (= (length consumers)
|
||||
(length (gethash "condition-consumers" json))))
|
||||
(should (= (length etaf-m0a-document-example-files)
|
||||
(length (gethash "document-examples" json)))))))
|
||||
|
||||
(ert-deftest etaf-m0a-document-example-inventory-matches-reviewed-golden ()
|
||||
"Every user documentation block matches its reviewed M0a outcome."
|
||||
(let* ((golden-file
|
||||
(expand-file-name "tests/fixtures/etaf-m0a-document-examples.sexp"
|
||||
etaf-m0a-package-root))
|
||||
(inventory (etaf-m0a-document-example-inventory))
|
||||
(blocks (apply #'append
|
||||
(mapcar (lambda (entry)
|
||||
(plist-get entry :blocks))
|
||||
inventory)))
|
||||
golden)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents golden-file)
|
||||
(setq golden (read (current-buffer)))
|
||||
(skip-chars-forward " \t\r\n")
|
||||
(should (eobp)))
|
||||
(should (equal golden (etaf-m0a-document-example-signatures)))
|
||||
(should (= 124 (length blocks)))
|
||||
(should (= 0 (cl-count 'read-error blocks
|
||||
:key (lambda (entry)
|
||||
(plist-get entry :drift)))))
|
||||
;; Canonical README expressions no longer carry the four baseline errors.
|
||||
(should (= 0 (cl-count 'macroexpand-error blocks
|
||||
:key (lambda (entry)
|
||||
(plist-get entry :drift)))))
|
||||
(should (cl-every
|
||||
(lambda (entry)
|
||||
(and (eq 'skipped-unsafe (plist-get entry :load-status))
|
||||
(eq 'arbitrary-document-code
|
||||
(plist-get entry :load-reason))))
|
||||
blocks))))
|
||||
|
||||
(provide 'etaf-m0a-current-characterization-tests)
|
||||
;;; etaf-m0a-current-characterization-tests.el ends here
|
||||
@ -1,26 +0,0 @@
|
||||
;;; etaf-m0b-component-manifest-tests.el --- M0b manifest probes -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf-m0b-component-manifest)
|
||||
|
||||
(ert-deftest etaf-m0b-component-manifest-is-derived-and-mounted ()
|
||||
"Derive business props and prove Host-attribute forwarding by mounting."
|
||||
(let* ((manifest (etaf-m0b-component-manifest-data))
|
||||
(components (alist-get 'components manifest)))
|
||||
(should (= 2 (length components)))
|
||||
(should (equal '("title")
|
||||
(alist-get 'declared-business-props (car components))))
|
||||
(should (equal '("label")
|
||||
(alist-get 'declared-business-props (cadr components))))
|
||||
(dolist (entry components)
|
||||
(should (alist-get 'forwarded-host-attrs entry))
|
||||
(should (string-match-p "single attr-capable root"
|
||||
(alist-get 'root-shape-forwarding-guarantee
|
||||
entry)))
|
||||
(should (eq t (alist-get 'mounted-validation entry))))))
|
||||
|
||||
;;; etaf-m0b-component-manifest-tests.el ends here
|
||||
@ -1,168 +0,0 @@
|
||||
;;; etaf-observer-tests.el --- Scoped observer port tests -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Tests for the dynamically scoped ETAF observer port.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-observer)
|
||||
|
||||
(defun etaf-test-observer-context (sink &optional diagnostic)
|
||||
"Return a test observer context using SINK and DIAGNOSTIC."
|
||||
(etaf--observer-context-create
|
||||
:sink sink
|
||||
:operation-id 41
|
||||
:runtime-id 9
|
||||
:buffer-name "*etaf-test*"
|
||||
:diagnostic (or diagnostic #'ignore)))
|
||||
|
||||
(ert-deftest etaf-observer-stage-preserves-success-and-metadata ()
|
||||
"Observed stages preserve results and emit required flat metadata."
|
||||
(let (reports)
|
||||
(should
|
||||
(eq 'result
|
||||
(etaf--observer-call-with-context
|
||||
(etaf-test-observer-context
|
||||
(lambda (report) (push report reports)))
|
||||
(lambda ()
|
||||
(etaf-observer-with-stage ('etaf 'render :detail "root")
|
||||
'result)))))
|
||||
(let ((report (car reports)))
|
||||
(should (= 1 (length reports)))
|
||||
(should (= etaf-observer-report-format-version
|
||||
(plist-get report :format-version)))
|
||||
(should (eq 'etaf (plist-get report :provider)))
|
||||
(should (eq 'render (plist-get report :stage)))
|
||||
(should (= 41 (plist-get report :operation-id)))
|
||||
(should (= 1 (plist-get report :sequence)))
|
||||
(should (= 9 (plist-get report :runtime-id)))
|
||||
(should (equal "*etaf-test*" (plist-get report :buffer-name)))
|
||||
(should (eq 'success (plist-get report :status)))
|
||||
(should (equal "root" (plist-get report :detail)))
|
||||
(should (>= (plist-get report :duration-ms) 0.0)))))
|
||||
|
||||
(ert-deftest etaf-observer-stage-preserves-error-and-quit ()
|
||||
"Observed failures are reported and re-signaled without translation."
|
||||
(let (reports error-condition quit-condition)
|
||||
(let ((context
|
||||
(etaf-test-observer-context
|
||||
(lambda (report) (push report reports)))))
|
||||
(setq error-condition
|
||||
(condition-case condition
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(etaf-observer-with-stage ('etaf 'render)
|
||||
(signal 'wrong-type-argument '(integerp bad)))))
|
||||
(error condition)))
|
||||
(setq quit-condition
|
||||
(condition-case condition
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(etaf-observer-with-stage ('ebox 'commit)
|
||||
(signal 'quit '(requested)))))
|
||||
(quit condition))))
|
||||
(should (equal '(wrong-type-argument integerp bad) error-condition))
|
||||
(should (equal '(quit requested) quit-condition))
|
||||
(setq reports (nreverse reports))
|
||||
(should (equal '(error quit)
|
||||
(mapcar (lambda (report) (plist-get report :status))
|
||||
reports)))
|
||||
(should (equal '(1 2)
|
||||
(mapcar (lambda (report) (plist-get report :sequence))
|
||||
reports)))))
|
||||
|
||||
(ert-deftest etaf-observer-emits-defensive-flat-copy ()
|
||||
"Observer mutation cannot alter the producer's report snapshot."
|
||||
(let* ((detail (copy-sequence "producer"))
|
||||
(report (list :provider 'ebox :stage 'commit
|
||||
:status 'success :duration-ms 1.0
|
||||
:detail (list detail)))
|
||||
(original (copy-tree report)))
|
||||
(etaf--observer-call-with-context
|
||||
(etaf-test-observer-context
|
||||
(lambda (delivered)
|
||||
(setcar delivered :mutated)
|
||||
(setcar (cdr delivered) 99)
|
||||
(aset (car (plist-get delivered :detail)) 0 ?!)))
|
||||
(lambda () (etaf-observer-emit report)))
|
||||
(should (equal original report))
|
||||
(should (equal "producer" detail))))
|
||||
|
||||
(ert-deftest etaf-observer-contains-observer-failures-and-invalid-reports ()
|
||||
"Observer and validation failures are diagnostics, not product failures."
|
||||
(let (diagnostics failure)
|
||||
(let ((context
|
||||
(etaf-test-observer-context
|
||||
(lambda (_report)
|
||||
(if (eq failure 'error)
|
||||
(error "Observer error")
|
||||
(signal 'quit '(observer-quit))))
|
||||
(lambda (diagnostic) (push diagnostic diagnostics)))))
|
||||
(setq failure 'error)
|
||||
(should
|
||||
(eq 'product-result
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(prog1 'product-result
|
||||
(etaf-observer-emit
|
||||
'(:provider etaf :stage render
|
||||
:status success :duration-ms 0.0)))))))
|
||||
(setq failure 'quit)
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(etaf-observer-emit
|
||||
'(:provider etaf :stage commit
|
||||
:status success :duration-ms 0.0))))
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(etaf-observer-emit '(:provider etaf :nested (not flat))))))
|
||||
(should (equal '(observer-failure observer-failure invalid-report)
|
||||
(mapcar (lambda (diagnostic)
|
||||
(plist-get diagnostic :kind))
|
||||
(nreverse diagnostics))))))
|
||||
|
||||
(ert-deftest etaf-observer-clears-context-during-reentrant-delivery ()
|
||||
"Observer reentry sees no active observation context."
|
||||
(let (context-seen reports)
|
||||
(etaf--observer-call-with-context
|
||||
(etaf-test-observer-context
|
||||
(lambda (report)
|
||||
(push report reports)
|
||||
(setq context-seen etaf--observer-context)
|
||||
(etaf-observer-with-stage ('etaf 'reentrant) 'ignored)))
|
||||
(lambda ()
|
||||
(etaf-observer-with-stage ('etaf 'outer) 'done)))
|
||||
(should-not context-seen)
|
||||
(should (= 1 (length reports)))
|
||||
(should (eq 'outer (plist-get (car reports) :stage)))))
|
||||
|
||||
(ert-deftest etaf-observer-nil-path-does-zero-instrumentation ()
|
||||
"The unobserved path does not time, allocate delivery, or inspect GC state."
|
||||
(let ((body-count 0)
|
||||
(etaf--observer-context nil))
|
||||
(cl-letf (((symbol-function 'float-time)
|
||||
(lambda (&optional _time) (error "Unexpected clock read")))
|
||||
((symbol-function 'etaf--observer-call-stage)
|
||||
(lambda (&rest _arguments) (error "Unexpected stage wrapper")))
|
||||
((symbol-function 'etaf-observer-emit)
|
||||
(lambda (&rest _arguments) (error "Unexpected report"))))
|
||||
(should
|
||||
(eq 'plain-result
|
||||
(etaf-observer-with-stage ('etaf 'render)
|
||||
(setq body-count (1+ body-count))
|
||||
'plain-result))))
|
||||
(should (= 1 body-count))))
|
||||
|
||||
(provide 'etaf-observer-tests)
|
||||
|
||||
;;; etaf-observer-tests.el ends here
|
||||
@ -6,427 +6,445 @@
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
(defconst etaf-performance-test--facade-loaded-recorder-p
|
||||
(featurep 'etaf-performance)
|
||||
"Whether loading the ETAF facade eagerly loaded the optional recorder.")
|
||||
(require 'etaf-performance)
|
||||
|
||||
(ert-deftest etaf-performance-is-not-an-etaf-facade-dependency ()
|
||||
"The optional recorder must be loaded explicitly."
|
||||
(should-not etaf-performance-test--facade-loaded-recorder-p))
|
||||
|
||||
(defmacro etaf-performance-test--isolated (&rest body)
|
||||
"Run BODY with isolated recorder state."
|
||||
"Run BODY with isolated performance recorder state."
|
||||
(declare (indent 0) (debug t))
|
||||
`(let ((etaf-performance--record-ring nil)
|
||||
(etaf-performance--pending (make-hash-table :test #'equal))
|
||||
(etaf-performance--attachments (make-hash-table :test #'eq)))
|
||||
,@body))
|
||||
`(unwind-protect
|
||||
(progn
|
||||
(etaf-performance-mode -1)
|
||||
(etaf-performance-clear)
|
||||
,@body)
|
||||
(etaf-performance-mode -1)
|
||||
(etaf-performance-clear)))
|
||||
|
||||
(cl-defmacro etaf-performance-test--with-runtime
|
||||
((runtime buffer-name) &rest body)
|
||||
"Mount RUNTIME in BUFFER-NAME, evaluate BODY, then clean up."
|
||||
(declare (indent 1) (debug ((symbolp symbolp) body)))
|
||||
`(let ((,buffer-name (generate-new-buffer-name " *etaf-performance-test*"))
|
||||
,runtime)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount ,buffer-name (etaf-view (box "Performance")))
|
||||
(setq ,runtime (etaf-runtime-for-buffer ,buffer-name))
|
||||
,@body)
|
||||
(when ,runtime
|
||||
(etaf-performance-stop ,runtime)
|
||||
(when (etaf-runtime-mounted-p ,runtime)
|
||||
(etaf-unmount ,runtime)))
|
||||
(when-let* ((buffer (get-buffer ,buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-performance-start-stop-own-exact-runtime-sink ()
|
||||
"Attach idempotently and remove only this recorder's exact sink."
|
||||
(ert-deftest etaf-performance-records-success-result-and-error ()
|
||||
"Recording preserves successful results and original error data."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(should (eq runtime (etaf-performance-start runtime)))
|
||||
(let* ((attachment
|
||||
(gethash runtime etaf-performance--attachments))
|
||||
(sink (etaf-performance--attachment-sink attachment)))
|
||||
(should (functionp sink))
|
||||
(should (etaf-runtime-compare-and-set-observer runtime sink sink))
|
||||
(should (eq runtime (etaf-performance-start runtime)))
|
||||
(should (eq runtime (etaf-performance-stop runtime)))
|
||||
(should (etaf-runtime-compare-and-set-observer runtime nil nil))))))
|
||||
(etaf-performance-mode 1)
|
||||
(should (equal 42
|
||||
(etaf-performance--call-operation
|
||||
(lambda () 42) 'test-success 'test nil)))
|
||||
(let ((condition
|
||||
(condition-case error-data
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda ()
|
||||
(signal 'args-out-of-range '(source 1 2)))
|
||||
'failing-stage 'test 'failure nil))
|
||||
'test-error 'test nil)
|
||||
(args-out-of-range error-data))))
|
||||
(should (equal condition '(args-out-of-range source 1 2))))
|
||||
(let ((records (etaf-performance-records)))
|
||||
(should (= 2 (length records)))
|
||||
(should (eq 'error
|
||||
(etaf-performance-operation-status (car records))))
|
||||
(should (eq 'error
|
||||
(etaf-performance-stage-status
|
||||
(car (etaf-performance-operation-stages
|
||||
(car records))))))
|
||||
(should (eq 'success
|
||||
(etaf-performance-operation-status (cadr records)))))))
|
||||
|
||||
(ert-deftest etaf-performance-start-rejects-foreign-observer ()
|
||||
"Never replace an observer owned by another consumer."
|
||||
(ert-deftest etaf-performance-records-preserve-quit ()
|
||||
"Recording marks and re-signals a quit without changing its data."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(let ((foreign #'ignore))
|
||||
(etaf-runtime-set-observer runtime foreign)
|
||||
(should-error (etaf-performance-start runtime))
|
||||
(should (etaf-runtime-compare-and-set-observer
|
||||
runtime foreign foreign))
|
||||
(etaf-runtime-set-observer runtime nil)))))
|
||||
(etaf-performance-mode 1)
|
||||
(let ((condition
|
||||
(condition-case quit-data
|
||||
(etaf-performance--call-operation
|
||||
(lambda () (signal 'quit '(performance-test)))
|
||||
'test-quit 'test nil)
|
||||
(quit quit-data))))
|
||||
(should (equal condition '(quit performance-test)))
|
||||
(should (eq 'quit
|
||||
(etaf-performance-operation-status
|
||||
(car (etaf-performance-records))))))))
|
||||
|
||||
(ert-deftest etaf-performance-stop-preserves-replacement-observer ()
|
||||
"A later foreign replacement is not detached by recorder stop."
|
||||
(ert-deftest etaf-performance-public-operation-wrapper-is-generic ()
|
||||
"The public operation API records arbitrary code and preserves its result."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(etaf-performance-start runtime)
|
||||
(let ((foreign #'ignore))
|
||||
(etaf-runtime-set-observer runtime foreign)
|
||||
(etaf-performance-stop runtime)
|
||||
(should (etaf-runtime-compare-and-set-observer
|
||||
runtime foreign foreign))
|
||||
(etaf-runtime-set-observer runtime nil)))))
|
||||
(etaf-performance-mode 1)
|
||||
(should
|
||||
(equal '(generic result)
|
||||
(etaf-performance-with-operation ('command "generic fixture")
|
||||
'(generic result))))
|
||||
(let ((operation (car (etaf-performance-records))))
|
||||
(should (eq 'command
|
||||
(etaf-performance-operation-kind operation)))
|
||||
(should (equal "generic fixture"
|
||||
(etaf-performance-operation-label operation))))))
|
||||
|
||||
(ert-deftest etaf-performance-mode-is-current-buffer-convenience ()
|
||||
"The local mode attaches only the Runtime in its current buffer."
|
||||
(ert-deftest etaf-performance-stage-registration-is-load-order-safe ()
|
||||
"Third-party stages may register before their function is defined."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(with-current-buffer buffer-name
|
||||
(etaf-performance-mode 1)
|
||||
(should etaf-performance-mode)
|
||||
(should (eq runtime etaf-performance--mode-runtime))
|
||||
(let* ((attachment
|
||||
(gethash runtime etaf-performance--attachments))
|
||||
(sink (etaf-performance--attachment-sink attachment)))
|
||||
(should (functionp sink))
|
||||
(should (etaf-runtime-compare-and-set-observer
|
||||
runtime sink sink)))
|
||||
(etaf-performance-mode -1)
|
||||
(should-not etaf-performance-mode)
|
||||
(should (etaf-runtime-compare-and-set-observer runtime nil nil))))))
|
||||
|
||||
(ert-deftest etaf-performance-mode-rejects-non-runtime-buffer ()
|
||||
"The buffer-local convenience requires a mounted Runtime."
|
||||
(with-temp-buffer
|
||||
(should-error (etaf-performance-mode 1))
|
||||
(should-not etaf-performance-mode)))
|
||||
|
||||
(ert-deftest etaf-performance-unmount-records-and-releases-attachment ()
|
||||
"Record unmount before the Runtime detaches this recorder."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((buffer-name (generate-new-buffer-name " *etaf-performance-unmount*"))
|
||||
runtime)
|
||||
(let ((function (make-symbol "etaf-performance-generic-stage")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-view (box "Unmount")))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-unmount runtime)
|
||||
(should-not (gethash runtime etaf-performance--attachments))
|
||||
(let ((operation (car (etaf-performance-records))))
|
||||
(should (eq 'unmount
|
||||
(etaf-performance-operation-kind operation)))
|
||||
(should (eq 'success
|
||||
(etaf-performance-operation-status operation))))
|
||||
(should (eq runtime (etaf-performance-stop runtime))))
|
||||
(etaf-performance-register-stage function 'extension 'prepare)
|
||||
(etaf-performance-mode 1)
|
||||
(should-not (assq function etaf-performance--installed-advices))
|
||||
(fset function (lambda () 'extension-result))
|
||||
(etaf-performance--install-loaded-advices)
|
||||
(should (assq function etaf-performance--installed-advices))
|
||||
(should (eq 'extension-result
|
||||
(etaf-performance-call-operation
|
||||
'extension "registered stage"
|
||||
(lambda () (funcall function)))))
|
||||
(let ((stage
|
||||
(car (etaf-performance-operation-stages
|
||||
(car (etaf-performance-records))))))
|
||||
(should (eq function
|
||||
(etaf-performance-stage-function stage)))
|
||||
(should (eq 'extension
|
||||
(etaf-performance-stage-category stage)))))
|
||||
(etaf-performance-unregister-stage function)
|
||||
(when (fboundp function)
|
||||
(fmakunbound function))))))
|
||||
|
||||
(ert-deftest etaf-performance-default-registry-keeps-per-node-probes-opt-in ()
|
||||
"High-frequency per-node probes must not distort default operation timing."
|
||||
(dolist (function '(ebox-incremental--candidate-local-changed-keys
|
||||
ebox-tree-node-local-source-signature))
|
||||
(should-not (assq function etaf-performance--stage-functions))))
|
||||
|
||||
(ert-deftest etaf-performance-stage-advice-survives-package-reload ()
|
||||
"Reattach the tracked stage closure after its function is redefined."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((function (make-symbol "etaf-performance-reloaded-stage")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fset function (lambda () 'first))
|
||||
(etaf-performance-register-stage function 'extension 'reload)
|
||||
(etaf-performance-mode 1)
|
||||
(let ((entry (assq function
|
||||
etaf-performance--installed-advices)))
|
||||
(should (advice-member-p (cdr entry) function))
|
||||
(fset function (lambda () 'second))
|
||||
(should-not (advice-member-p (cdr entry) function))
|
||||
(etaf-performance--install-loaded-advices)
|
||||
(should (advice-member-p (cdr entry) function)))
|
||||
(etaf-performance-clear)
|
||||
(should (eq 'second
|
||||
(etaf-performance-call-operation
|
||||
'reload "package reload"
|
||||
(lambda () (funcall function)))))
|
||||
(should (= 1
|
||||
(length
|
||||
(etaf-performance-operation-stages
|
||||
(car (etaf-performance-records)))))))
|
||||
(etaf-performance-unregister-stage function)
|
||||
(when (fboundp function) (fmakunbound function))))))
|
||||
|
||||
(ert-deftest etaf-performance-stage-registration-rejects-operation-collision ()
|
||||
"A detail stage must not replace a public operation boundary advice."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(let* ((function 'etaf-data-load)
|
||||
(entry (assq function etaf-performance--installed-advices)))
|
||||
(should entry)
|
||||
(should-error
|
||||
(etaf-performance-register-stage function 'data 'nested-load))
|
||||
(should-error (etaf-performance-unregister-stage function))
|
||||
(should (eq entry (assq function etaf-performance--installed-advices)))
|
||||
(should (advice-member-p (cdr entry) function)))))
|
||||
|
||||
(ert-deftest etaf-performance-public-data-resource-and-viewport-boundaries ()
|
||||
"Public cross-package operations are boundaries, never duplicate stages."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((functions '(etaf-data-load etaf-data-source-load-page
|
||||
etaf-data-mutate etaf-resource-load
|
||||
ebox-surface-update-buffer-viewport
|
||||
ebox-rerender-buffer-with-context)))
|
||||
(dolist (function functions)
|
||||
(should (assq function etaf-performance--operation-functions))
|
||||
(should-not (assq function etaf-performance--stage-functions)))
|
||||
(etaf-performance-mode 1)
|
||||
(dolist (function functions)
|
||||
(when (fboundp function)
|
||||
(should (assq function etaf-performance--installed-advices))))
|
||||
(let* ((source (etaf-data-memory-source
|
||||
'((:id 1 :name "one")) :id-key :id))
|
||||
(controller (etaf-data-controller source))
|
||||
(resource (etaf-resource (lambda () 'loaded) :immediate nil)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-data-load controller)
|
||||
(etaf-data-source-load-page source nil 1 20)
|
||||
(etaf-data-mutate controller 'insert '(:id 2 :name "two"))
|
||||
(etaf-resource-load resource)
|
||||
(let ((kinds
|
||||
(mapcar #'etaf-performance-operation-kind
|
||||
(etaf-performance-records))))
|
||||
(should (memq 'data-load kinds))
|
||||
(should (memq 'data-prepare kinds))
|
||||
(should (memq 'data-mutate kinds))
|
||||
(should (memq 'resource-load kinds))))
|
||||
(etaf-data-stop controller)
|
||||
(etaf-resource-dispose resource))))))
|
||||
|
||||
(ert-deftest etaf-performance-records-nested-stage-exclusive-time ()
|
||||
"Nested stages retain depth and subtract child inclusive time."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda ()
|
||||
(sleep-for 0.002)
|
||||
(etaf-performance--call-stage
|
||||
(lambda () (sleep-for 0.002) 'inner-result)
|
||||
'inner-stage 'inner 'work nil)
|
||||
(sleep-for 0.002))
|
||||
'outer-stage 'outer 'work nil))
|
||||
'nested-operation 'test nil)
|
||||
(let* ((operation (car (etaf-performance-records)))
|
||||
(stages (etaf-performance-operation-stages operation))
|
||||
(outer (car stages))
|
||||
(inner (cadr stages)))
|
||||
(should (= 2 (length stages)))
|
||||
(should (= 0 (etaf-performance-stage-depth outer)))
|
||||
(should (= 1 (etaf-performance-stage-depth inner)))
|
||||
(should (>= (etaf-performance-stage-inclusive outer)
|
||||
(etaf-performance-stage-inclusive inner)))
|
||||
(should (< (abs (- (etaf-performance-stage-exclusive outer)
|
||||
(- (etaf-performance-stage-inclusive outer)
|
||||
(etaf-performance-stage-inclusive inner))))
|
||||
0.001)))))
|
||||
|
||||
(ert-deftest etaf-performance-records-are-bounded ()
|
||||
"Only the configured number of newest operations is retained."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((etaf-performance-max-records 2))
|
||||
(etaf-performance-mode 1)
|
||||
(dotimes (index 4)
|
||||
(etaf-performance--call-operation
|
||||
(lambda () index) 'bounded 'test nil))
|
||||
(let* ((records (etaf-performance-records))
|
||||
(ids (mapcar #'etaf-performance-operation-id records)))
|
||||
(should (= 2 (length records)))
|
||||
(should (= 1 (- (car ids) (cadr ids))))))))
|
||||
|
||||
(ert-deftest etaf-performance-clear-keeps-correlation-ids-monotonic ()
|
||||
"Clearing history inside an operation must not reuse its ID."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-call-operation
|
||||
'outer "clear inside" (lambda () (etaf-performance-clear)))
|
||||
(etaf-performance-call-operation 'next "after clear" #'ignore)
|
||||
(let ((ids (mapcar #'etaf-performance-operation-id
|
||||
(etaf-performance-records))))
|
||||
(should (= 2 (length (delete-dups (copy-sequence ids)))))
|
||||
(should (= 1 (- (car ids) (cadr ids)))))))
|
||||
|
||||
(ert-deftest etaf-performance-summaries-aggregate-off-the-hot-path ()
|
||||
"Summarize operation percentiles and non-overlapping category self time."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(dolist (delay '(0.001 0.002 0.003))
|
||||
(etaf-performance-call-operation
|
||||
'summary "generic"
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda () (sleep-for delay)) 'summary-stage 'application 'work nil))))
|
||||
(let* ((records (etaf-performance-records))
|
||||
(summary (car (etaf-performance-summary records)))
|
||||
(stage-summary
|
||||
(car (etaf-performance-operation-stage-summary (car records)))))
|
||||
(should (= 3 (plist-get summary :count)))
|
||||
(should (<= (plist-get summary :min-ms)
|
||||
(plist-get summary :p50-ms)
|
||||
(plist-get summary :p95-ms)
|
||||
(plist-get summary :max-ms)))
|
||||
(should (eq 'application (plist-get stage-summary :category)))
|
||||
(should (= 1 (plist-get stage-summary :count)))
|
||||
(should (<= (plist-get stage-summary :exclusive-ms)
|
||||
(plist-get stage-summary :inclusive-ms))))))
|
||||
|
||||
(ert-deftest etaf-performance-records-real-event-and-runtime-stages ()
|
||||
"A real mounted event creates an event operation and runtime stages."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((buffer-name " *etaf-performance-event-test*")
|
||||
(calls 0)
|
||||
runtime-holder)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(text :ref 'button
|
||||
:on-press (lambda ()
|
||||
(cl-incf calls)
|
||||
(etaf-runtime-flush runtime-holder))
|
||||
"Press")))
|
||||
(etaf-performance-clear)
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(setq runtime-holder runtime)
|
||||
(etaf-dispatch-event runtime 'button 'press)
|
||||
(should (= calls 1))
|
||||
(let ((operation
|
||||
(cl-find 'event (etaf-performance-records)
|
||||
:key #'etaf-performance-operation-kind)))
|
||||
(should (eq 'event
|
||||
(etaf-performance-operation-kind operation)))
|
||||
(should (= (etaf-runtime-mount-epoch runtime)
|
||||
(etaf-performance-operation-runtime-id operation)))
|
||||
(should (equal buffer-name
|
||||
(etaf-performance-operation-buffer-name
|
||||
operation)))
|
||||
(should (numberp
|
||||
(etaf-performance-operation-generation-before
|
||||
operation)))
|
||||
(should
|
||||
(cl-some
|
||||
(lambda (record)
|
||||
(cl-some
|
||||
(lambda (stage)
|
||||
(memq (etaf-performance-stage-category stage)
|
||||
'(runtime reactive ebox tp)))
|
||||
(etaf-performance-operation-stages record)))
|
||||
(etaf-performance-records))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(ert-deftest etaf-performance-killed-buffer-releases-runtime-attachment ()
|
||||
"Direct buffer death unmounts Runtime and releases recorder ownership."
|
||||
(ert-deftest etaf-performance-panel-has-operation-and-stage-entries ()
|
||||
"The tabulated panel expands one operation into its stage rows."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((buffer-name (generate-new-buffer-name " *etaf-performance-kill*"))
|
||||
runtime buffer)
|
||||
(etaf-mount buffer-name (etaf-view (box "Kill")))
|
||||
(setq buffer (get-buffer buffer-name)
|
||||
runtime (etaf-runtime-for-buffer buffer))
|
||||
(etaf-performance-start runtime)
|
||||
(should (gethash runtime etaf-performance--attachments))
|
||||
(kill-buffer buffer)
|
||||
(should-not (buffer-live-p buffer))
|
||||
(should-not (etaf-runtime-mounted-p runtime))
|
||||
(should-not (gethash runtime etaf-performance--attachments))
|
||||
(should-error (etaf-performance-start runtime)
|
||||
:type 'etaf-runtime-error))))
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda () 'ok) 'panel-stage 'panel 'detail nil))
|
||||
'panel-operation 'test nil)
|
||||
(let ((entries (etaf-performance--tabulated-entries)))
|
||||
(should (= 2 (length entries)))
|
||||
(should (equal "operation" (aref (cadr (car entries)) 4)))
|
||||
(should (equal "stage" (aref (cadr (cadr entries)) 2))))
|
||||
(with-temp-buffer
|
||||
(etaf-performance-panel-mode)
|
||||
(tabulated-list-print t)
|
||||
(should (string-match-p "panel-operation" (buffer-string)))
|
||||
(should (string-match-p "panel-stage" (buffer-string))))))
|
||||
|
||||
(ert-deftest etaf-performance-groups-flat-reports-in-sequence-order ()
|
||||
"One ETAF final report retains one ordered, categorized operation."
|
||||
(ert-deftest etaf-performance-report-is-portable-and-copyable ()
|
||||
"The shareable report contains environment, operation, and stage data."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(etaf-performance-start runtime)
|
||||
(should
|
||||
(equal
|
||||
'result
|
||||
(etaf-performance-call-operation
|
||||
runtime 'command "flat fixture"
|
||||
(lambda ()
|
||||
(etaf-observer-emit
|
||||
'(:provider data :stage load :duration-ms 2.0 :rows 4))
|
||||
(etaf-observer-emit
|
||||
'(:provider ebox :stage commit :duration-ms 3.0 :patches 2))
|
||||
'result))))
|
||||
(let* ((records (etaf-performance-records))
|
||||
(operation (car records))
|
||||
(stages (etaf-performance-operation-stages operation)))
|
||||
(should (= 1 (length records)))
|
||||
(should (eq 'command (etaf-performance-operation-kind operation)))
|
||||
(should (equal "flat fixture"
|
||||
(etaf-performance-operation-label operation)))
|
||||
(should (equal '(1 2 3)
|
||||
(mapcar #'etaf-performance-stage-sequence stages)))
|
||||
(should (equal '(data ebox etaf)
|
||||
(mapcar #'etaf-performance-stage-provider stages)))
|
||||
(should (equal '(data ebox runtime)
|
||||
(mapcar #'etaf-performance-stage-category stages)))
|
||||
(should (eq 'runtime-operation
|
||||
(etaf-performance-stage-name (car (last stages)))))
|
||||
(should (= 4 (plist-get
|
||||
(etaf-performance-stage-metadata (car stages))
|
||||
:rows)))))))
|
||||
|
||||
(ert-deftest etaf-performance-operation-wrapper-preserves-errors ()
|
||||
"The public wrapper delegates result, timing, and failure to Runtime."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(etaf-performance-start runtime)
|
||||
(let ((condition
|
||||
(condition-case data
|
||||
(etaf-performance-with-operation
|
||||
(runtime 'command "failure")
|
||||
(signal 'args-out-of-range '(source 1 2)))
|
||||
(args-out-of-range data))))
|
||||
(should (equal condition '(args-out-of-range source 1 2))))
|
||||
(let ((operation (car (etaf-performance-records))))
|
||||
(should (eq 'error (etaf-performance-operation-status operation)))
|
||||
(should (eq 'error
|
||||
(etaf-performance-stage-status
|
||||
(car (last
|
||||
(etaf-performance-operation-stages operation))))))))))
|
||||
|
||||
(ert-deftest etaf-performance-record-ring-is-bounded ()
|
||||
"Retain only the configured number of newest operations."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((etaf-performance-max-records 2))
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(etaf-performance-start runtime)
|
||||
(dotimes (index 4)
|
||||
(etaf-performance-call-operation
|
||||
runtime 'bounded (format "operation %d" index) #'ignore))
|
||||
(let ((records (etaf-performance-records)))
|
||||
(should (= 2 (length records)))
|
||||
(should (> (etaf-performance-operation-id (car records))
|
||||
(etaf-performance-operation-id (cadr records)))))))))
|
||||
|
||||
(ert-deftest etaf-performance-records-return-deep-snapshots ()
|
||||
"Caller mutation cannot alter retained operations or stages."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-performance-call-operation
|
||||
runtime 'snapshot "stable label"
|
||||
(lambda ()
|
||||
(etaf-observer-emit
|
||||
'(:provider data :stage load :duration-ms 1.0
|
||||
:detail ("stable")))
|
||||
'result))
|
||||
(let* ((operation (car (etaf-performance-records)))
|
||||
(stage (car (etaf-performance-operation-stages operation)))
|
||||
(detail (car (plist-get
|
||||
(etaf-performance-stage-metadata stage) :detail))))
|
||||
(setf (etaf-performance-operation-label operation) "changed"
|
||||
(etaf-performance-stage-name stage) 'changed)
|
||||
(aset detail 0 ?X))
|
||||
(let* ((operation (car (etaf-performance-records)))
|
||||
(stage (car (etaf-performance-operation-stages operation))))
|
||||
(should (equal "stable label"
|
||||
(etaf-performance-operation-label operation)))
|
||||
(should (eq 'load (etaf-performance-stage-name stage)))
|
||||
(should (equal '("stable")
|
||||
(plist-get (etaf-performance-stage-metadata stage)
|
||||
:detail)))))))
|
||||
|
||||
(ert-deftest etaf-performance-records-filter-by-runtime-report-identity ()
|
||||
"Select isolated history by report identity when buffer names are reused."
|
||||
(etaf-performance-test--isolated
|
||||
(dolist (entry '((1 101 "first mount")
|
||||
(1 202 "second mount")
|
||||
(2 101 "first unmount")))
|
||||
(etaf-performance--retain
|
||||
(etaf-performance--operation-create
|
||||
:id (nth 0 entry) :runtime-id (nth 1 entry) :label (nth 2 entry)
|
||||
:buffer-name " *reused performance buffer*"
|
||||
:metadata '(:detail ("stable")))))
|
||||
(should (= 3 (length (etaf-performance-records))))
|
||||
(should (equal (etaf-performance-records)
|
||||
(etaf-performance-records nil)))
|
||||
(let ((first (etaf-performance-records 101))
|
||||
(second (etaf-performance-records 202)))
|
||||
(should (equal '("first unmount" "first mount")
|
||||
(mapcar #'etaf-performance-operation-label first)))
|
||||
(should (equal '("second mount")
|
||||
(mapcar #'etaf-performance-operation-label second)))
|
||||
(setf (etaf-performance-operation-label (car first)) "changed")
|
||||
(setcar (plist-get (etaf-performance-operation-metadata (car first))
|
||||
:detail)
|
||||
"changed")
|
||||
(let ((retained (car (etaf-performance-records 101))))
|
||||
(should (equal "first unmount"
|
||||
(etaf-performance-operation-label retained)))
|
||||
(should (equal '("stable")
|
||||
(plist-get (etaf-performance-operation-metadata retained)
|
||||
:detail)))))
|
||||
(should-not (etaf-performance-records 303))
|
||||
(should-error (etaf-performance-records "101")
|
||||
:type 'wrong-type-argument)))
|
||||
|
||||
(ert-deftest etaf-performance-summary-keeps-explicit-empty-selection ()
|
||||
"An omitted selection summarizes all records; an explicit nil stays empty."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance--retain
|
||||
(etaf-performance--operation-create
|
||||
:kind 'report :label "retained fixture" :elapsed 1.0))
|
||||
(should (= 1 (length (etaf-performance-summary))))
|
||||
(should-not (etaf-performance-summary nil))))
|
||||
|
||||
(ert-deftest etaf-performance-report-data-keeps-explicit-empty-selection ()
|
||||
"An empty data export cannot fall back to previously retained records."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance--retain
|
||||
(etaf-performance--operation-create
|
||||
:kind 'report :label "retained fixture" :elapsed 1.0))
|
||||
(let ((all (etaf-performance-report-data))
|
||||
(empty (etaf-performance-report-data nil)))
|
||||
(should (= 1 (length (plist-get all :summary))))
|
||||
(should (= 1 (length (plist-get all :operations))))
|
||||
(should-not (plist-get empty :summary))
|
||||
(should-not (plist-get empty :operations)))))
|
||||
|
||||
(ert-deftest etaf-performance-report-string-keeps-explicit-empty-selection ()
|
||||
"Report strings preserve both omitted and explicitly empty selections."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance--retain
|
||||
(etaf-performance--operation-create
|
||||
:kind 'report :label "retained fixture" :elapsed 1.0))
|
||||
(let ((all (read (etaf-performance-report-string)))
|
||||
(empty (read (etaf-performance-report-string nil))))
|
||||
(should (= 1 (length (plist-get all :summary))))
|
||||
(should (= 1 (length (plist-get all :operations))))
|
||||
(should-not (plist-get empty :summary))
|
||||
(should-not (plist-get empty :operations)))))
|
||||
|
||||
(ert-deftest etaf-performance-reports-keep-empty-runtime-selection ()
|
||||
"An unmatched runtime report identity produces empty summary and exports."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance--retain
|
||||
(etaf-performance--operation-create
|
||||
:runtime-id 101 :kind 'report :label "retained fixture" :elapsed 1.0))
|
||||
(let ((records (etaf-performance-records 202)))
|
||||
(should-not records)
|
||||
(should-not (etaf-performance-summary records))
|
||||
(dolist (report (list (etaf-performance-report-data records)
|
||||
(read (etaf-performance-report-string records))))
|
||||
(should-not (plist-get report :summary))
|
||||
(should-not (plist-get report :operations))))))
|
||||
|
||||
(ert-deftest etaf-performance-summary-uses-flat-duration ()
|
||||
"Summaries expose percentiles and overlapping provider durations honestly."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(etaf-performance-start runtime)
|
||||
(dotimes (_ 3)
|
||||
(etaf-performance-call-operation
|
||||
runtime 'summary "fixture"
|
||||
(lambda ()
|
||||
(etaf-observer-emit
|
||||
'(:provider tp :stage publish :duration-ms 2.5)))))
|
||||
(let* ((operation (car (etaf-performance-records)))
|
||||
(summary (car (etaf-performance-summary)))
|
||||
(stage-summary
|
||||
(etaf-performance-operation-stage-summary operation))
|
||||
(tp-summary
|
||||
(cl-find 'tp stage-summary :key
|
||||
(lambda (entry) (plist-get entry :category)))))
|
||||
(should (= 3 (plist-get summary :count)))
|
||||
(should (<= (plist-get summary :min-ms)
|
||||
(plist-get summary :p50-ms)
|
||||
(plist-get summary :p95-ms)
|
||||
(plist-get summary :max-ms)))
|
||||
(should (= 1 (plist-get tp-summary :count)))
|
||||
(should (= 2.5 (plist-get tp-summary :duration-ms)))
|
||||
(should-not (plist-member tp-summary :exclusive-ms))))))
|
||||
|
||||
(ert-deftest etaf-performance-report-panel-copy-and-export-remain-usable ()
|
||||
"Portable reports, the panel, copy, and export consume flat records."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-test--with-runtime (runtime buffer-name)
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-performance-call-operation
|
||||
runtime 'report "portable fixture"
|
||||
(lambda ()
|
||||
(etaf-observer-emit
|
||||
'(:provider tp :stage publish :duration-ms 1.25))))
|
||||
(let* ((data (etaf-performance-report-data))
|
||||
(operation (car (plist-get data :operations)))
|
||||
(stage (car (plist-get operation :stages)))
|
||||
(kill-ring nil)
|
||||
(kill-ring-yank-pointer nil)
|
||||
(copied (etaf-performance-copy-report))
|
||||
(file (make-temp-file "etaf-performance-" nil ".eld")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(delete-file file)
|
||||
(should (= 2 (plist-get data :format-version)))
|
||||
(should (equal "portable fixture"
|
||||
(plist-get operation :label)))
|
||||
(should (eq 'tp (plist-get stage :provider)))
|
||||
(should (equal copied (current-kill 0 t)))
|
||||
(should (equal file (etaf-performance-export file)))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(should (string-match-p "portable fixture"
|
||||
(buffer-string)))))
|
||||
(when (file-exists-p file)
|
||||
(delete-file file))))
|
||||
(let ((entries (etaf-performance--tabulated-entries)))
|
||||
(should (= 3 (length entries))))
|
||||
(with-temp-buffer
|
||||
(etaf-performance-panel-mode)
|
||||
(tabulated-list-print t)
|
||||
(should (string-match-p "portable fixture" (buffer-string)))
|
||||
(should (string-match-p "publish" (buffer-string)))))))
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-call-operation
|
||||
'report "copy fixture"
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda () 'ok) 'report-stage 'fixture 'work nil)))
|
||||
(let* ((data (etaf-performance-report-data))
|
||||
(operations (plist-get data :operations))
|
||||
(operation (car operations))
|
||||
(stage (car (plist-get operation :stages)))
|
||||
(kill-ring nil)
|
||||
(kill-ring-yank-pointer nil)
|
||||
(report (etaf-performance-copy-report)))
|
||||
(should (= etaf-performance-report-format-version
|
||||
(plist-get data :format-version)))
|
||||
(should (equal emacs-version
|
||||
(plist-get (plist-get data :environment)
|
||||
:emacs-version)))
|
||||
(should (equal "copy fixture" (plist-get operation :label)))
|
||||
(should (eq 'report-stage (plist-get stage :function)))
|
||||
(should (equal report (current-kill 0 t)))
|
||||
(should (string-match-p "ETAF performance report" report)))))
|
||||
|
||||
(ert-deftest etaf-performance-environment-normalizes-darwin-power-state ()
|
||||
"Reports distinguish AC, battery low-power, and unknown power states."
|
||||
(should
|
||||
(equal '(:source battery :low-power-mode on)
|
||||
(etaf-performance--parse-darwin-power-state
|
||||
"Now drawing from 'Battery Power'\n"
|
||||
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
|
||||
(equal
|
||||
'(:source battery :low-power-mode on)
|
||||
(etaf-performance--parse-darwin-power-state
|
||||
"Now drawing from 'Battery Power'\n"
|
||||
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
|
||||
(should
|
||||
(equal '(:source ac :low-power-mode off)
|
||||
(etaf-performance--parse-darwin-power-state
|
||||
"Now drawing from 'AC Power'\n"
|
||||
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
|
||||
(equal
|
||||
'(:source ac :low-power-mode off)
|
||||
(etaf-performance--parse-darwin-power-state
|
||||
"Now drawing from 'AC Power'\n"
|
||||
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
|
||||
(should
|
||||
(equal '(:source unknown :low-power-mode unknown)
|
||||
(etaf-performance--parse-darwin-power-state "" ""))))
|
||||
(equal
|
||||
'(:source unknown :low-power-mode unknown)
|
||||
(etaf-performance--parse-darwin-power-state "" ""))))
|
||||
|
||||
(ert-deftest etaf-performance-environment-reports-native-jit-state ()
|
||||
"Expose background JIT state beside absolute latency records."
|
||||
(let ((native-comp-jit-compilation t))
|
||||
(should (eq t (plist-get (etaf-performance-environment-data)
|
||||
:native-comp-jit-compilation))))
|
||||
(let ((native-comp-jit-compilation nil))
|
||||
(should-not (plist-get (etaf-performance-environment-data)
|
||||
:native-comp-jit-compilation))))
|
||||
(ert-deftest etaf-performance-panel-exposes-power-and-load-context ()
|
||||
"The visible panel explains system-wide latency shifts."
|
||||
(let ((line
|
||||
(etaf-performance--panel-environment-line
|
||||
'(:emacs-version "31.1"
|
||||
:power-state (:source battery :low-power-mode on)
|
||||
:load-average (2.5 2.0 1.5)))))
|
||||
(should (string-match-p "Emacs 31.1" line))
|
||||
(should (string-match-p "power battery/low:on" line))
|
||||
(should (string-match-p "load 2.50" line))))
|
||||
|
||||
(ert-deftest etaf-performance-source-has-no-advice-or-private-provider-registry ()
|
||||
"Recorder source depends only on the public Runtime observation boundary."
|
||||
(let ((source
|
||||
(with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name
|
||||
"etaf-performance.el"
|
||||
(file-name-directory (locate-library "etaf-performance"))))
|
||||
(buffer-string))))
|
||||
(dolist (pattern '("advice-add" "advice-remove" "after-load-functions"
|
||||
"operation-functions" "stage-functions"
|
||||
"etaf-runtime-mount-epoch"
|
||||
"etaf-runtime-observer runtime"
|
||||
"etaf-runtime-mounted-p"
|
||||
"ebox--" "tp--" "etaf-sqlite--"))
|
||||
(should-not (string-match-p (regexp-quote pattern) source)))))
|
||||
(ert-deftest etaf-performance-export-writes-readable-report ()
|
||||
"The interactive export payload is a readable plain-data report."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-call-operation 'export "file fixture" #'ignore)
|
||||
(let ((file (concat (make-temp-name
|
||||
(expand-file-name "etaf-performance-test-"
|
||||
temporary-file-directory))
|
||||
".eld")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(should (equal file (etaf-performance-export file)))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(should (string-match-p "ETAF performance report"
|
||||
(buffer-string)))
|
||||
(should (string-match-p "file fixture" (buffer-string)))))
|
||||
(when (file-exists-p file)
|
||||
(delete-file file))))))
|
||||
|
||||
(ert-deftest etaf-performance-captures-public-ebox-report-metadata ()
|
||||
"Attach compact public Ebox report facts to the active operation."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda ()
|
||||
'(:strategy mixed-owner-reflow
|
||||
:projection-kind mixed-owner-reflow
|
||||
:dirty-count 8 :owner-ids (1 2 3) :patch-count 3
|
||||
:tp-scope-count 3 :tp-text-operations 12
|
||||
:tp-property-operations 111 :tp-full-root nil
|
||||
:tp-scope-fallback nil))
|
||||
'ebox-commit 'ebox 'commit nil))
|
||||
'report-operation 'test nil)
|
||||
(let* ((operation (car (etaf-performance-records)))
|
||||
(report (plist-get
|
||||
(etaf-performance-operation-metadata operation) :ebox)))
|
||||
(should (eq 'mixed-owner-reflow (plist-get report :strategy)))
|
||||
(should (= 3 (plist-get report :owner-count)))
|
||||
(should (= 111 (plist-get report :tp-property-operations)))
|
||||
(should (string-match-p "mixed-owner-reflow"
|
||||
(etaf-performance--format-report operation))))))
|
||||
|
||||
(ert-deftest etaf-performance-mode-uninstalls-all-advices ()
|
||||
"Disabling recording removes operation, stage, and after-load hooks."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(let ((installed (copy-sequence etaf-performance--installed-advices)))
|
||||
(should installed)
|
||||
(dolist (entry installed)
|
||||
(should (advice-member-p (cdr entry) (car entry))))
|
||||
(etaf-performance-mode -1)
|
||||
(should-not etaf-performance--installed-advices)
|
||||
(should-not (memq #'etaf-performance--install-loaded-advices
|
||||
after-load-functions))
|
||||
(dolist (entry installed)
|
||||
(should-not (advice-member-p (cdr entry) (car entry)))))))
|
||||
|
||||
(provide 'etaf-performance-tests)
|
||||
|
||||
|
||||
@ -1,620 +0,0 @@
|
||||
;;; etaf-render-port-tests.el --- M3a renderer-port gates -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'etaf-render-port)
|
||||
|
||||
(defconst etaf-render-port-test--root
|
||||
(file-name-directory
|
||||
(directory-file-name
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"ETAF package root used by static bootstrap-owner checks.")
|
||||
|
||||
(ert-deftest etaf-render-port-package-metadata-requires-final-v2-stack ()
|
||||
"ETAF 0.2.1 declares the Ebox 3 and TP 2 runtime requirements."
|
||||
(require 'package)
|
||||
(with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name "etaf.el" etaf-render-port-test--root))
|
||||
(let ((description (package-buffer-info)))
|
||||
(should (equal (package-desc-version description) '(0 2 1)))
|
||||
(should
|
||||
(equal (package-desc-reqs description)
|
||||
'((emacs (29 1)) (ebox (3 0 0)) (tp (2 0 0))))))))
|
||||
|
||||
(ert-deftest etaf-render-port-selects-valid-v2-immutably ()
|
||||
"A valid provider produces one immutable v2 selected port."
|
||||
(let* ((port (etaf-render-port--bootstrap))
|
||||
(capabilities (etaf-render-port-capabilities port)))
|
||||
(should (etaf-render-port-p port))
|
||||
(should (eq (etaf-render-port-route port) 'v2))
|
||||
(should (= (etaf-render-port-spi-version port) 2))
|
||||
(should (eq (etaf-render-port-schema-version port)
|
||||
'ebox-framework-spi-schema/v2))
|
||||
(should (memq (etaf-render-port-tp-protocol port)
|
||||
etaf-render-port--accepted-tp-protocols))
|
||||
(should (eq (etaf-render-port-initial-function port)
|
||||
'ebox-framework-spi-initial))
|
||||
(should (eq (etaf-render-port-update-function port)
|
||||
'ebox-framework-spi-update))
|
||||
(should (eq (etaf-render-port-revision-function port)
|
||||
'ebox-surface-buffer-revision))
|
||||
(should (eq (etaf-render-port-snapshot-function port)
|
||||
'ebox-surface-buffer-snapshot))
|
||||
(should (eq (etaf-render-port-bootstrap-outcome port)
|
||||
'valid-v2-selected))
|
||||
(setcar capabilities 'mutated)
|
||||
(should (eq (car (etaf-render-port-capabilities port))
|
||||
'initial-paired-stage-rollback))
|
||||
(should-error
|
||||
(eval `(setf (etaf-render-port--route ',port) 'broken)))))
|
||||
|
||||
(ert-deftest etaf-render-port-requires-public-snapshot-query ()
|
||||
"An otherwise valid v2 provider cannot omit the public snapshot query."
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot) nil))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error)))
|
||||
|
||||
(ert-deftest etaf-render-port-snapshot-forwards-owned-export-once ()
|
||||
"The port forwards one Ebox-owned export without copying or publishing it."
|
||||
(let* ((snapshot (list :input (ebox-build '(box "snapshot"))
|
||||
:revision 7 :mount-id 23))
|
||||
(calls 0))
|
||||
(with-temp-buffer
|
||||
(let ((buffer (current-buffer)))
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot)
|
||||
(lambda (target)
|
||||
(should (eq target buffer))
|
||||
(cl-incf calls)
|
||||
snapshot))
|
||||
((symbol-function 'etaf-render-port-update)
|
||||
(lambda (&rest _) (error "Snapshot published"))))
|
||||
(should (eq snapshot (etaf-render-port-snapshot buffer)))
|
||||
(should (= calls 1)))))))
|
||||
|
||||
(ert-deftest etaf-render-port-snapshot-rejects-malformed-export ()
|
||||
"The adapter checks the public envelope without probing private state."
|
||||
(dolist (snapshot (list nil '(:input wrong :revision 7 :mount-id 23)
|
||||
(list :input (ebox-build '(box "snapshot"))
|
||||
:revision "7" :mount-id 23)
|
||||
(list :input (ebox-build '(box "snapshot"))
|
||||
:revision 7 :mount-id nil)))
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot)
|
||||
(lambda (_buffer) snapshot)))
|
||||
(should-error (etaf-render-port-snapshot (current-buffer)) :type 'error))))
|
||||
|
||||
(ert-deftest etaf-render-port-snapshot-preserves-query-errors ()
|
||||
"An Ebox rejection remains visible and never triggers a render fallback."
|
||||
(let ((condition '(user-error "snapshot is unavailable in this transaction")))
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-snapshot)
|
||||
(lambda (_buffer) (signal (car condition) (cdr condition)))))
|
||||
(should (equal condition
|
||||
(should-error (etaf-render-port-snapshot (current-buffer))
|
||||
:type 'user-error))))))
|
||||
|
||||
(ert-deftest etaf-runtime-flush-returns-revision-without-export ()
|
||||
"Explicit flush requests a drain and returns a cheap committed revision."
|
||||
(require 'etaf)
|
||||
(let* ((runtime (etaf--runtime-create :buffer (current-buffer)))
|
||||
trace)
|
||||
(cl-letf (((symbol-function 'etaf-runtime-require-mounted)
|
||||
(lambda (target) (should (eq target runtime)) runtime))
|
||||
((symbol-function 'etaf--runtime-request-flush)
|
||||
(lambda (target) (should (eq target runtime)) (push 'drain trace)))
|
||||
((symbol-function 'etaf-render-port-revision)
|
||||
(lambda (buffer)
|
||||
(should (eq buffer (current-buffer)))
|
||||
(push 'revision trace)
|
||||
13))
|
||||
((symbol-function 'etaf-runtime-snapshot)
|
||||
(lambda (&rest _) (error "Flush exported a whole tree")))
|
||||
((symbol-function 'etaf--runtime-render-root-turn)
|
||||
(lambda (&rest _) (error "Flush forced a Root rebuild"))))
|
||||
(should (= 13 (etaf-runtime-flush runtime)))
|
||||
(should (equal '(drain revision) (nreverse trace))))))
|
||||
|
||||
(ert-deftest etaf-runtime-flush-rejects-transaction-before-drain ()
|
||||
"Public flush never drains work or exposes a provisional TP revision."
|
||||
(require 'etaf)
|
||||
(let ((runtime (etaf--runtime-create :buffer (current-buffer))) trace)
|
||||
(cl-letf (((symbol-function 'etaf-runtime-require-mounted)
|
||||
(lambda (_target) runtime))
|
||||
((symbol-function 'etaf--runtime-request-flush)
|
||||
(lambda (&rest _) (push 'drain trace)))
|
||||
((symbol-function 'etaf-render-port-revision)
|
||||
(lambda (&rest _) (push 'revision trace) 99)))
|
||||
(tp-with-transaction
|
||||
(should-error (etaf-runtime-flush runtime) :type 'etaf-runtime-error))
|
||||
(should-not trace))))
|
||||
|
||||
(ert-deftest etaf-runtime-obsolete-root-getter-compiles-as-snapshot-query ()
|
||||
"Compiled compatibility reads query current input, not the reserved slot."
|
||||
(require 'etaf)
|
||||
(require 'bytecomp)
|
||||
(let* ((runtime (etaf--runtime-create :reserved-root-node 'stale-root))
|
||||
(snapshot (list :input (ebox-build '(box "Current"))
|
||||
:revision 7 :mount-id 23))
|
||||
(getter (let ((byte-compile-warnings '(not obsolete)))
|
||||
(byte-compile '(lambda (runtime)
|
||||
(etaf-runtime-root-node runtime)))))
|
||||
(calls 0))
|
||||
(should (= 3 (cl-struct-slot-offset 'etaf-runtime 'reserved-root-node)))
|
||||
(should (= 4 (cl-struct-slot-offset 'etaf-runtime 'scope)))
|
||||
(should-not (get 'etaf-runtime-root-node 'compiler-macro))
|
||||
(should-not (get 'etaf-runtime-root-node 'side-effect-free))
|
||||
(cl-letf (((symbol-function 'etaf-runtime-snapshot)
|
||||
(lambda (target)
|
||||
(should (eq target runtime))
|
||||
(cl-incf calls)
|
||||
snapshot)))
|
||||
(should (eq (car (ebox-canonical-input-roots (plist-get snapshot :input)))
|
||||
(funcall getter runtime)))
|
||||
(should (= 1 calls)))))
|
||||
|
||||
(ert-deftest etaf-render-port-requires-v2-provider ()
|
||||
"Complete provider absence fails closed instead of selecting a legacy port."
|
||||
(let ((original-featurep (symbol-function 'featurep)))
|
||||
(cl-letf (((symbol-function 'featurep)
|
||||
(lambda (feature)
|
||||
(and (not (eq feature 'ebox-framework-spi-v2))
|
||||
(funcall original-featurep feature))))
|
||||
((symbol-function 'ebox-framework-spi-capabilities) nil))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error))))
|
||||
|
||||
(ert-deftest etaf-render-port-accepts-each-v2-capable-tp-manifest ()
|
||||
"Both transitional dual-capability and final v2-only providers are valid."
|
||||
(let ((provider (ebox-framework-spi-capabilities)))
|
||||
(dolist (protocol '(tp-transaction-protocol-v1+v2
|
||||
tp-transaction-protocol-v2))
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () provider))
|
||||
((symbol-function 'ebox-framework-spi-provider-tp-protocol)
|
||||
(lambda (_provider) protocol)))
|
||||
(should (eq (etaf-render-port-tp-protocol
|
||||
(etaf-render-port--bootstrap))
|
||||
protocol))))))
|
||||
|
||||
(ert-deftest etaf-render-port-rejects-half-present-v2 ()
|
||||
"Feature-only and predicate-only providers fail instead of downgrading."
|
||||
(cl-letf (((symbol-function 'ebox-framework-spi-capabilities) nil))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error))
|
||||
(let ((original-featurep (symbol-function 'featurep)))
|
||||
(cl-letf (((symbol-function 'featurep)
|
||||
(lambda (feature)
|
||||
(and (not (eq feature 'ebox-framework-spi-v2))
|
||||
(funcall original-featurep feature)))))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error))))
|
||||
|
||||
(ert-deftest etaf-render-port-rejects-broken-v2-provider ()
|
||||
"Throwing, non-record, and malformed providers fail closed."
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () (error "injected provider failure"))))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error))
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () 'not-a-provider)))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error))
|
||||
(let ((provider (ebox-framework-spi-capabilities)))
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () provider))
|
||||
((symbol-function 'ebox-framework-spi-provider-capabilities)
|
||||
(lambda (_provider) "not-a-capability-list")))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-bootstrap-error))))
|
||||
|
||||
(ert-deftest etaf-render-port-rejects-incompatible-v2-provider ()
|
||||
"Version, required-capability, and TP protocol mismatches are incompatible."
|
||||
(let ((provider (ebox-framework-spi-capabilities)))
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () provider))
|
||||
((symbol-function 'ebox-framework-spi-provider-spi-version)
|
||||
(lambda (_provider) 99)))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-incompatible-error))
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () provider))
|
||||
((symbol-function 'ebox-framework-spi-provider-capabilities)
|
||||
(lambda (_provider)
|
||||
'(initial-paired-stage-rollback
|
||||
update-paired-stage-rollback
|
||||
same-object-legacy-report))))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-incompatible-error))
|
||||
(cl-letf
|
||||
(((symbol-function 'ebox-framework-spi-capabilities)
|
||||
(lambda () provider))
|
||||
((symbol-function 'ebox-framework-spi-provider-tp-protocol)
|
||||
(lambda (_provider) 'tp-transaction-protocol-v0)))
|
||||
(should-error (etaf-render-port--bootstrap)
|
||||
:type 'etaf-spi-incompatible-error))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-initial-delegates-paired-rollback ()
|
||||
"The selected SPI operation owns stage failure and paired rollback."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v2-paired-rollback*")) trace)
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'ebox-framework-spi-initial)
|
||||
(lambda (_buffer _input stage rollback)
|
||||
(push 'render trace)
|
||||
(condition-case condition
|
||||
(funcall stage nil)
|
||||
(error
|
||||
(funcall rollback nil)
|
||||
(signal (car condition) (cdr condition)))))))
|
||||
(should-error
|
||||
(etaf-render-port-initial
|
||||
buffer 'input
|
||||
(lambda (_report)
|
||||
(push 'stage trace)
|
||||
(error "injected v2 initial failure"))
|
||||
(lambda (_report) (push 'rollback trace))))
|
||||
(should (equal (nreverse trace) '(render stage rollback))))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-initial-restores-real-ebox-surface ()
|
||||
"A failed SPI stage removes Ebox authority and restores buffer content."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v2-real-cleanup*"))
|
||||
(input (ebox-build '(box "committed")))
|
||||
(rollback-count 0)
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer (insert "sentinel"))
|
||||
(condition-case condition
|
||||
(etaf-render-port-initial
|
||||
buffer input
|
||||
(lambda (_report)
|
||||
(error "injected real v2 stage failure"))
|
||||
(lambda (_report) (cl-incf rollback-count)))
|
||||
(error (setq captured condition)))
|
||||
(should (equal captured '(error "injected real v2 stage failure")))
|
||||
(should (= rollback-count 1))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should-not (ebox-surface-buffer-observer buffer))
|
||||
(should (equal "sentinel"
|
||||
(with-current-buffer buffer (buffer-string)))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-failure-restores-exact-editor-custody ()
|
||||
"SPI stage rollback preserves Emacs-owned editor identities and undo."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v2-editor-custody*"))
|
||||
(input (ebox-build '(box "committed")))
|
||||
overlay left-marker right-marker snapshot captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer
|
||||
(buffer-enable-undo)
|
||||
(insert (propertize "sentinel" 'face 'bold))
|
||||
(undo-boundary)
|
||||
(goto-char 4)
|
||||
(set-mark 2)
|
||||
(setq mark-active t)
|
||||
(setq overlay (make-overlay 2 6 buffer t t)
|
||||
left-marker (copy-marker 3 nil)
|
||||
right-marker (copy-marker 5 t))
|
||||
(overlay-put overlay 'etaf-test-property '(owned value))
|
||||
(narrow-to-region 2 7)
|
||||
(set-buffer-modified-p nil)
|
||||
(setq snapshot
|
||||
(list
|
||||
:contents
|
||||
(save-restriction
|
||||
(widen)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
:point (point)
|
||||
:mark-marker (mark-marker)
|
||||
:mark-position (mark t)
|
||||
:mark-insertion-type
|
||||
(marker-insertion-type (mark-marker))
|
||||
:mark-active mark-active
|
||||
:narrow-start (point-min)
|
||||
:narrow-end (point-max)
|
||||
:overlay-start (overlay-start overlay)
|
||||
:overlay-end (overlay-end overlay)
|
||||
:overlay-properties (overlay-properties overlay)
|
||||
:left-position (marker-position left-marker)
|
||||
:left-insertion-type (marker-insertion-type left-marker)
|
||||
:right-position (marker-position right-marker)
|
||||
:right-insertion-type (marker-insertion-type right-marker)
|
||||
:undo-list (copy-tree buffer-undo-list)
|
||||
:modified-p (buffer-modified-p))))
|
||||
(condition-case condition
|
||||
(etaf-render-port-initial
|
||||
buffer input
|
||||
(lambda (_report) (error "editor custody primary"))
|
||||
#'ignore)
|
||||
(error (setq captured condition)))
|
||||
(should (equal captured '(error "editor custody primary")))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should-not (ebox-surface-buffer-observer buffer))
|
||||
(with-current-buffer buffer
|
||||
(should
|
||||
(equal (save-restriction
|
||||
(widen)
|
||||
(buffer-substring (point-min) (point-max)))
|
||||
(plist-get snapshot :contents)))
|
||||
(should (= (point) (plist-get snapshot :point)))
|
||||
(should (eq (mark-marker) (plist-get snapshot :mark-marker)))
|
||||
(should (= (mark t) (plist-get snapshot :mark-position)))
|
||||
(should
|
||||
(eq (marker-insertion-type (mark-marker))
|
||||
(plist-get snapshot :mark-insertion-type)))
|
||||
(should (eq mark-active (plist-get snapshot :mark-active)))
|
||||
(should (= (point-min) (plist-get snapshot :narrow-start)))
|
||||
(should (= (point-max) (plist-get snapshot :narrow-end)))
|
||||
(should (overlayp overlay))
|
||||
(should (eq (overlay-buffer overlay) buffer))
|
||||
(should (= (overlay-start overlay)
|
||||
(plist-get snapshot :overlay-start)))
|
||||
(should (= (overlay-end overlay)
|
||||
(plist-get snapshot :overlay-end)))
|
||||
(should (equal (overlay-properties overlay)
|
||||
(plist-get snapshot :overlay-properties)))
|
||||
(should (eq (marker-buffer left-marker) buffer))
|
||||
(should (= (marker-position left-marker)
|
||||
(plist-get snapshot :left-position)))
|
||||
(should
|
||||
(eq (marker-insertion-type left-marker)
|
||||
(plist-get snapshot :left-insertion-type)))
|
||||
(should (eq (marker-buffer right-marker) buffer))
|
||||
(should (= (marker-position right-marker)
|
||||
(plist-get snapshot :right-position)))
|
||||
(should
|
||||
(eq (marker-insertion-type right-marker)
|
||||
(plist-get snapshot :right-insertion-type)))
|
||||
(should (equal buffer-undo-list (plist-get snapshot :undo-list)))
|
||||
(should (eq (buffer-modified-p)
|
||||
(plist-get snapshot :modified-p)))))
|
||||
(when (overlayp overlay) (delete-overlay overlay))
|
||||
(when (markerp left-marker) (set-marker left-marker nil))
|
||||
(when (markerp right-marker) (set-marker right-marker nil))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-nonlocal-exit-runs-exact-cleanup ()
|
||||
"A SPI stage throw cannot escape with mounted or editor state retained."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v2-nonlocal-cleanup*"))
|
||||
(input (ebox-build '(box "committed")))
|
||||
(rollback-count 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer (insert "before"))
|
||||
(should
|
||||
(eq
|
||||
(catch 'etaf-v2-test-escape
|
||||
(etaf-render-port-initial
|
||||
buffer input
|
||||
(lambda (_report)
|
||||
(throw 'etaf-v2-test-escape 'escaped))
|
||||
(lambda (_report) (cl-incf rollback-count)))
|
||||
'not-escaped)
|
||||
'escaped))
|
||||
(should (= rollback-count 1))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should-not (ebox-surface-buffer-observer buffer))
|
||||
(should (equal "before"
|
||||
(with-current-buffer buffer (buffer-string)))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-precondition-keeps-existing-mount ()
|
||||
"Rejecting an already mounted target must not clean up foreign authority."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v1-existing-mount*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(ebox-render-to-buffer buffer (ebox-build '(box "existing")))
|
||||
(let ((revision (ebox-surface-buffer-revision buffer)))
|
||||
(should-error
|
||||
(etaf-render-port-initial
|
||||
buffer (ebox-build '(box "replacement")) #'ignore #'ignore)
|
||||
:type 'error)
|
||||
(should (ebox-surface-buffer-mounted-p buffer))
|
||||
(should (= revision (ebox-surface-buffer-revision buffer)))
|
||||
(should (equal "existing"
|
||||
(with-current-buffer buffer (buffer-string))))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-rollback-throw-cannot-stop-cleanup-tail ()
|
||||
"A framework rollback throw propagates only after SPI cleanup completes."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v2-rollback-throw*"))
|
||||
(input (ebox-build '(box "committed"))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer (insert "before"))
|
||||
(should
|
||||
(eq
|
||||
(catch 'etaf-v2-rollback-escape
|
||||
(etaf-render-port-initial
|
||||
buffer input
|
||||
(lambda (_report) (error "primary before rollback throw"))
|
||||
(lambda (_report)
|
||||
(throw 'etaf-v2-rollback-escape 'rollback-escaped)))
|
||||
'not-escaped)
|
||||
'rollback-escaped))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should-not (ebox-surface-buffer-observer buffer))
|
||||
(should (equal "before"
|
||||
(with-current-buffer buffer (buffer-string)))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-cleanup-fault-keeps-primary-and-continues ()
|
||||
"A secondary rollback fault is contained while Ebox cleanup continues."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v2-cleanup-fault*"))
|
||||
(input (ebox-build '(box "committed")))
|
||||
captured)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer (insert "before"))
|
||||
(condition-case condition
|
||||
(etaf-render-port-initial
|
||||
buffer input
|
||||
(lambda (_report) (error "primary stage failure"))
|
||||
(lambda (_report) (error "secondary rollback failure")))
|
||||
(error (setq captured condition)))
|
||||
(should (equal captured '(error "primary stage failure")))
|
||||
(should-not (ebox-surface-buffer-mounted-p buffer))
|
||||
(should (equal "before"
|
||||
(with-current-buffer buffer (buffer-string)))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-revision-fails-closed-for-mounted-surface ()
|
||||
"Revision is zero only without a mount; mounted lookup errors stay visible."
|
||||
(let ((buffer (generate-new-buffer " *etaf-revision-contract*")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(should (zerop (etaf-render-port-revision buffer)))
|
||||
(ebox-render-to-buffer buffer (ebox-build '(box "mounted")))
|
||||
(should (> (etaf-render-port-revision buffer) 0))
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
|
||||
(lambda (_buffer) (error "injected report failure"))))
|
||||
(should-error (etaf-render-port-revision buffer) :type 'error))
|
||||
(cl-letf (((symbol-function 'ebox-surface-buffer-revision)
|
||||
(lambda (_buffer) 0)))
|
||||
(should-error (etaf-render-port-revision buffer) :type 'error))
|
||||
(etaf-render-port-unmount buffer)
|
||||
(should (buffer-live-p buffer))
|
||||
(should-not (etaf-render-port-mounted-p buffer))
|
||||
(should (zerop (etaf-render-port-revision buffer))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-v2-preserves-provider-report-identity ()
|
||||
"Initial and update return the exact report seen by framework staging."
|
||||
(let ((buffer (generate-new-buffer " *etaf-v2-report-identity*"))
|
||||
initial-stage-report update-stage-report)
|
||||
(unwind-protect
|
||||
(let ((initial-report
|
||||
(etaf-render-port-initial
|
||||
buffer (ebox-build '(box "one"))
|
||||
(lambda (report) (setq initial-stage-report report))
|
||||
#'ignore)))
|
||||
(should (eq initial-report initial-stage-report))
|
||||
(let ((update-report
|
||||
(etaf-render-port-update
|
||||
buffer (ebox-build '(box "two"))
|
||||
(lambda (report) (setq update-stage-report report))
|
||||
#'ignore)))
|
||||
(should (eq update-report update-stage-report))
|
||||
(should (= (etaf-render-port-revision buffer)
|
||||
(plist-get update-report :surface-revision)))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-is-the-only-protocol-probe-owner ()
|
||||
"No downstream ETAF module probes Ebox framework SPI protocol state."
|
||||
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
|
||||
(unless (string= (file-name-nondirectory file) "etaf-render-port.el")
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(let ((source (buffer-string)))
|
||||
(should-not (string-match-p "ebox-framework-spi" source))
|
||||
(should-not (string-match-p "ebox-framework-spi-v2" source)))))))
|
||||
|
||||
(ert-deftest etaf-render-port-owns-runtime-update-routing ()
|
||||
"Runtime updates use the selected port instead of calling Ebox directly."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name "etaf-runtime.el" etaf-render-port-test--root))
|
||||
(let ((source (buffer-string)))
|
||||
(should (string-match-p "(etaf-render-port-update" source))
|
||||
(should-not (string-match-p "(ebox-commit" source)))))
|
||||
|
||||
(ert-deftest etaf-render-port-owns-all-live-publication-routing ()
|
||||
"No ETAF module except the selected-port owner publishes directly to Ebox."
|
||||
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
|
||||
(unless (string= (file-name-nondirectory file) "etaf-render-port.el")
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(let ((source (buffer-string)))
|
||||
(dolist (call '("(ebox-render-to-buffer"
|
||||
"(ebox-commit"
|
||||
"(ebox-surface-"))
|
||||
(should-not (string-match-p (regexp-quote call) source))))))))
|
||||
|
||||
(ert-deftest etaf-render-port-production-has-no-v1-render-route ()
|
||||
"Production ETAF contains no retired render-port policy or v1 helper."
|
||||
(dolist (file (directory-files etaf-render-port-test--root t "\\.el\\'"))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(let ((source (buffer-string)))
|
||||
(should-not (string-match-p "etaf-render-port-selection-policy" source))
|
||||
(should-not (string-match-p "etaf-render-port--v1" source))))))
|
||||
|
||||
(ert-deftest etaf-render-port-routes-standalone-renderer-mount ()
|
||||
"The no-Runtime compatibility mount uses the immutable selected port."
|
||||
(require 'etaf-renderer)
|
||||
(let ((buffer (generate-new-buffer " *etaf-standalone-port-mount*"))
|
||||
seen-input seen-viewport)
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'etaf-runtime-mount) nil)
|
||||
((symbol-function 'etaf-render-port-initial)
|
||||
(lambda (target input framework-stage framework-rollback
|
||||
&optional _observer)
|
||||
(setq seen-input input
|
||||
seen-viewport
|
||||
(list ebox-viewport-width ebox-viewport-height))
|
||||
(funcall framework-stage nil)
|
||||
(ignore framework-rollback)
|
||||
(list :status 'success :buffer target))))
|
||||
(should
|
||||
(eq (etaf-mount
|
||||
buffer (etaf-view (text "standalone"))
|
||||
'(:viewport-width 91 :viewport-height 17))
|
||||
buffer))
|
||||
(should (ebox-canonical-input-p seen-input))
|
||||
(should (equal seen-viewport '(91 17))))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-unmount-buffer buffer))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-render-port-standalone-render-failure-creates-no-buffer ()
|
||||
"Pure lowering must fail before standalone mount allocates its target buffer."
|
||||
(require 'etaf-renderer)
|
||||
(let ((name " *etaf-standalone-render-failure*"))
|
||||
(when-let* ((buffer (get-buffer name))) (kill-buffer buffer))
|
||||
(cl-letf (((symbol-function 'etaf-runtime-mount) nil))
|
||||
(should-error (etaf-mount name 'invalid-etaf-view)
|
||||
:type 'etaf-renderer-error))
|
||||
(should-not (get-buffer name))))
|
||||
|
||||
(ert-deftest etaf-render-port-selected-port-is-process-stable ()
|
||||
"Every downstream read returns the one bootstrap-selected port identity."
|
||||
(let ((selected (etaf-render-port-selected)))
|
||||
(should (eq selected (etaf-render-port-selected)))
|
||||
(should (eq (etaf-render-port-route selected) 'v2))))
|
||||
|
||||
(provide 'etaf-render-port-tests)
|
||||
|
||||
;;; etaf-render-port-tests.el ends here
|
||||
@ -1,293 +0,0 @@
|
||||
;;; 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
|
||||
@ -1,337 +0,0 @@
|
||||
;;; 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
|
||||
@ -5,7 +5,6 @@
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf-observer)
|
||||
(require 'etaf-resource)
|
||||
|
||||
(ert-deftest etaf-resource-loads-synchronous-value ()
|
||||
@ -109,84 +108,4 @@
|
||||
(lambda (_condition) (error "handler")))
|
||||
:type 'error))
|
||||
|
||||
(ert-deftest etaf-resource-observes-only-loader-execution ()
|
||||
"Report Resource loads while preserving replacement cleanup semantics."
|
||||
(let* ((loads 0)
|
||||
(cleanups 0)
|
||||
reports
|
||||
resource
|
||||
(context
|
||||
(etaf--observer-context-create
|
||||
:sink (lambda (report) (push report reports))
|
||||
:operation-id 51
|
||||
:runtime-id 8
|
||||
:buffer-name nil
|
||||
:diagnostic #'ignore)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(setq resource
|
||||
(etaf-resource
|
||||
(lambda ()
|
||||
(etaf-resource-result
|
||||
(cl-incf loads)
|
||||
:cleanup (lambda () (cl-incf cleanups))))))
|
||||
(etaf-resource-load resource)))
|
||||
(setq reports (nreverse reports))
|
||||
(should (equal '(resource resource)
|
||||
(mapcar (lambda (report)
|
||||
(plist-get report :provider))
|
||||
reports)))
|
||||
(should (equal '(load load)
|
||||
(mapcar (lambda (report)
|
||||
(plist-get report :stage))
|
||||
reports)))
|
||||
(should (equal '(success success)
|
||||
(mapcar (lambda (report)
|
||||
(plist-get report :status))
|
||||
reports)))
|
||||
(should (= 2 (etaf-resource-value resource)))
|
||||
(should (= 1 cleanups))
|
||||
(etaf-resource-dispose resource)
|
||||
(should (= 2 cleanups)))
|
||||
(when resource
|
||||
(etaf-resource-dispose resource)))))
|
||||
|
||||
(ert-deftest etaf-resource-observed-error-keeps-captured-error-contract ()
|
||||
"Report loader failure without changing Resource error containment."
|
||||
(let* (reports resource
|
||||
(context
|
||||
(etaf--observer-context-create
|
||||
:sink (lambda (report) (push report reports))
|
||||
:operation-id 52
|
||||
:runtime-id 8
|
||||
:buffer-name nil
|
||||
:diagnostic #'ignore)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf--observer-call-with-context
|
||||
context
|
||||
(lambda ()
|
||||
(setq resource (etaf-resource (lambda () (error "boom"))))))
|
||||
(should (= 1 (length reports)))
|
||||
(should (eq 'error (plist-get (car reports) :status)))
|
||||
(should (eq 'error (etaf-resource-status resource)))
|
||||
(should (string-match-p "boom" (cadr (etaf-resource-error resource)))))
|
||||
(when resource
|
||||
(etaf-resource-dispose resource)))))
|
||||
|
||||
(ert-deftest etaf-resource-unobserved-load-bypasses-stage-runtime ()
|
||||
"Keep standalone Resource loading free of observation work."
|
||||
(let (resource)
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'etaf--observer-call-stage)
|
||||
(lambda (&rest _args)
|
||||
(ert-fail "unobserved Resource entered stage runtime"))))
|
||||
(setq resource (etaf-resource (lambda () "ready")))
|
||||
(should (equal "ready" (etaf-resource-value resource))))
|
||||
(when resource
|
||||
(etaf-resource-dispose resource)))))
|
||||
|
||||
;;; etaf-resource-tests.el ends here
|
||||
|
||||
@ -1,279 +0,0 @@
|
||||
;;; etaf-retirement-tests.el --- M3a retirement gates -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
(require 'etaf-retirement)
|
||||
|
||||
(define-error 'etaf-retirement-test-condition
|
||||
"ETAF retirement test condition")
|
||||
|
||||
(defvar etaf-retirement-test-update-fail-p nil)
|
||||
(defvar etaf-retirement-test-update-count 0)
|
||||
(defvar etaf-retirement-test-unmount-first-count 0)
|
||||
(defvar etaf-retirement-test-unmount-second-count 0)
|
||||
(defvar etaf-retirement-test-scope-cleanup-count 0)
|
||||
|
||||
(etaf-define-component etaf-retirement-test-updated (&key source)
|
||||
"Render SOURCE and expose a failing updated lifecycle entry."
|
||||
:setup
|
||||
(progn
|
||||
(etaf-on-updated
|
||||
(lambda ()
|
||||
(cl-incf etaf-retirement-test-update-count)
|
||||
(when etaf-retirement-test-update-fail-p
|
||||
(signal 'etaf-retirement-test-condition
|
||||
'("update failed" :payload update)))))
|
||||
nil)
|
||||
:view
|
||||
(text (expr (format "updated=%s" (etaf-value source)))))
|
||||
|
||||
(etaf-define-component etaf-retirement-test-unmounted ()
|
||||
"Expose ordered unmounted hooks and structural scope cleanup."
|
||||
:setup
|
||||
(progn
|
||||
(etaf-on-unmounted
|
||||
(lambda ()
|
||||
(cl-incf etaf-retirement-test-unmount-first-count)
|
||||
(signal 'etaf-retirement-test-condition
|
||||
'("unmount failed" :payload unmount))))
|
||||
(etaf-on-unmounted
|
||||
(lambda () (cl-incf etaf-retirement-test-unmount-second-count)))
|
||||
(etaf-on-scope-dispose
|
||||
(lambda () (cl-incf etaf-retirement-test-scope-cleanup-count)))
|
||||
nil)
|
||||
:view (text "retire"))
|
||||
|
||||
(ert-deftest etaf-retirement-drain-stops-public-and-continues-structure ()
|
||||
"First public failure abandons later hooks but retries structural cleanup."
|
||||
(let ((journal
|
||||
(etaf-retirement-journal-create
|
||||
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4))
|
||||
(attempts 0)
|
||||
trace)
|
||||
(etaf-retirement-enqueue
|
||||
journal :owner 'first :kind 'updated
|
||||
:payload (lambda ()
|
||||
(push 'first trace)
|
||||
(signal 'etaf-retirement-test-condition '("first")))
|
||||
:ordering-key 1 :policy 'run-once-public :max-attempts 1)
|
||||
(etaf-retirement-enqueue
|
||||
journal :owner 'second :kind 'updated
|
||||
:payload (lambda () (push 'second trace))
|
||||
:ordering-key 2 :policy 'run-once-public :max-attempts 1)
|
||||
(etaf-retirement-enqueue
|
||||
journal :owner 'structure :kind 'route-cleanup
|
||||
:payload (lambda ()
|
||||
(cl-incf attempts)
|
||||
(push 'structure trace)
|
||||
(when (= attempts 1) (error "retry")))
|
||||
:ordering-key 3 :policy 'retryable-idempotent :max-attempts 2)
|
||||
(let ((condition (etaf-retirement-drain journal)))
|
||||
(should (eq (car condition) 'etaf-retirement-test-condition))
|
||||
(should (equal (nreverse trace) '(first structure structure)))
|
||||
(should (= attempts 2))
|
||||
(should
|
||||
(equal (mapcar #'etaf-retirement-entry-state
|
||||
(etaf-retirement-journal-entries journal))
|
||||
'(failed-contained abandoned-contained completed))))))
|
||||
|
||||
(ert-deftest etaf-retirement-ordering-keys-sort-structurally ()
|
||||
"Numeric ordering remains correct after single-digit entry counts."
|
||||
(let ((journal
|
||||
(etaf-retirement-journal-create
|
||||
:operation-id 4 :outcome-id 5 :generation-id 6 :revision 7))
|
||||
trace)
|
||||
(dolist (key '((2 10 0) (2 2 0) (1 12 0) (1 3 0)))
|
||||
(let ((captured-key key))
|
||||
(etaf-retirement-enqueue
|
||||
journal :owner captured-key :kind 'ordering
|
||||
:payload (lambda () (push captured-key trace))
|
||||
:ordering-key captured-key :policy 'contained-once :max-attempts 1)))
|
||||
(should-not (etaf-retirement-drain journal))
|
||||
(should (equal (nreverse trace)
|
||||
'((1 3 0) (1 12 0) (2 2 0) (2 10 0))))))
|
||||
|
||||
(ert-deftest etaf-retirement-condition-trailer-is-cause-compatible ()
|
||||
"Re-signal keeps symbol/data prefix and the reader rejects lookalikes."
|
||||
(let* ((journal
|
||||
(etaf-retirement-journal-create
|
||||
:operation-id 7 :outcome-id 8 :generation-id 9 :revision 10))
|
||||
captured)
|
||||
(condition-case condition
|
||||
(etaf-retirement-resignal
|
||||
'(etaf-retirement-test-condition "original" (:business t))
|
||||
journal)
|
||||
(etaf-retirement-test-condition (setq captured condition)))
|
||||
(should (eq (car captured) 'etaf-retirement-test-condition))
|
||||
(should (equal (butlast (cdr captured))
|
||||
'("original" (:business t))))
|
||||
(should
|
||||
(equal (etaf-condition-postcommit-info captured)
|
||||
(list :kind 'postcommit :committed-p t :operation-id 7
|
||||
:outcome-id 8 :generation-id 9 :revision 10
|
||||
:diagnostic-journal-id
|
||||
(etaf-retirement-journal-id journal))))
|
||||
(should-not
|
||||
(etaf-condition-postcommit-info
|
||||
'(error (:etaf-condition-trailer/v1 (:kind postcommit)) business)))
|
||||
(should-not
|
||||
(etaf-condition-postcommit-info
|
||||
'(error business
|
||||
(:etaf-condition-trailer/v2
|
||||
(:kind postcommit :committed-p t)))))
|
||||
(dolist
|
||||
(malformed
|
||||
'((:kind postcommit :committed-p t :operation-id 1
|
||||
:outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5 :unexpected accepted)
|
||||
(:kind postcommit :committed-p t :operation-id 1
|
||||
:outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5 :operation-id 6)
|
||||
(:kind postcommit :committed-p t :operation-id 1
|
||||
:outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id)
|
||||
(:kind postcommit :committed-p t :operation-id -1
|
||||
:outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5)))
|
||||
(should-not
|
||||
(etaf-condition-postcommit-info
|
||||
(list 'error
|
||||
(list :etaf-condition-trailer/v1 malformed)))))
|
||||
(let (decorated)
|
||||
(condition-case condition
|
||||
(etaf-retirement-resignal
|
||||
'(etaf-retirement-test-condition
|
||||
"business"
|
||||
(:etaf-condition-trailer/v1
|
||||
(:kind postcommit :committed-p t :operation-id 1
|
||||
:outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5 :unexpected accepted)))
|
||||
journal)
|
||||
(etaf-retirement-test-condition (setq decorated condition)))
|
||||
(should decorated)
|
||||
(should (etaf-condition-postcommit-info decorated))
|
||||
(should (= 3 (length (cdr decorated)))))))
|
||||
|
||||
(ert-deftest etaf-retirement-data-projection-trailer-reader ()
|
||||
"Projection trailers are readable while preserving the condition prefix."
|
||||
(let* ((journal (etaf-retirement-journal-create
|
||||
:operation-id 11 :outcome-id 12 :generation-id 13
|
||||
:revision 14))
|
||||
(trailer (etaf-retirement-condition-trailer
|
||||
journal 'projection
|
||||
:external-commit-certainty 'committed
|
||||
:reconciliation-token 'reconcile-1
|
||||
:projection-token 'projection-1
|
||||
:result 'mutation-result))
|
||||
(condition (append '(etaf-retirement-test-condition "business"
|
||||
(:cause original)) (list trailer)))
|
||||
(info (etaf-data-condition-projection-info condition)))
|
||||
(should info)
|
||||
(should (equal (butlast (cdr condition))
|
||||
'("business" (:cause original))))
|
||||
(should (equal info
|
||||
(list :kind 'projection :committed-p t
|
||||
:external-commit-certainty 'committed
|
||||
:reconciliation-token 'reconcile-1
|
||||
:projection-token 'projection-1
|
||||
:result 'mutation-result
|
||||
:operation-id 11 :outcome-id 12
|
||||
:generation-id 13 :revision 14
|
||||
:diagnostic-journal-id
|
||||
(etaf-retirement-journal-id journal))))
|
||||
(should-not (etaf-condition-postcommit-info condition))
|
||||
;; Unknown versions, malformed payloads, and non-final lookalikes are inert.
|
||||
(should-not
|
||||
(etaf-data-condition-projection-info
|
||||
'(error (:etaf-condition-trailer/v2 (:kind projection)))))
|
||||
(should-not
|
||||
(etaf-data-condition-projection-info
|
||||
'(error (:etaf-condition-trailer/v1
|
||||
(:kind projection :committed-p t
|
||||
:external-commit-certainty committed
|
||||
:reconciliation-token r :projection-token p
|
||||
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5 :unexpected x)))))
|
||||
(should
|
||||
(etaf-data-condition-projection-info
|
||||
(list 'error
|
||||
'(:etaf-condition-trailer/v1
|
||||
(:kind projection :committed-p t
|
||||
:external-commit-certainty committed
|
||||
:reconciliation-token r :projection-token p :result result
|
||||
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 5))
|
||||
'(:etaf-condition-trailer/v1
|
||||
(:kind projection :committed-p t
|
||||
:external-commit-certainty committed
|
||||
:reconciliation-token r :projection-token p :result result
|
||||
:operation-id 1 :outcome-id 2 :generation-id 3 :revision 4
|
||||
:diagnostic-journal-id 6)))))))
|
||||
|
||||
(ert-deftest etaf-retirement-updated-error-is-committed-and-not-rerun ()
|
||||
"Updated hook error carries a trailer while generation and buffer stay new."
|
||||
(let ((buffer-name " *etaf-retirement-update-test*")
|
||||
(source (etaf-ref "A"))
|
||||
captured)
|
||||
(setq etaf-retirement-test-update-count 0
|
||||
etaf-retirement-test-update-fail-p nil)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf--view-call 'etaf-retirement-test-updated
|
||||
(list :source source) nil))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(token (etaf-runtime-generation-token runtime)))
|
||||
(setq etaf-retirement-test-update-fail-p t)
|
||||
(condition-case condition
|
||||
(setf (etaf-value source) "B")
|
||||
(etaf-retirement-test-condition (setq captured condition)))
|
||||
(should captured)
|
||||
(should (equal (butlast (cdr captured))
|
||||
'("update failed" :payload update)))
|
||||
(should (etaf-condition-postcommit-info captured))
|
||||
(should (= (1+ generation) (etaf-runtime-generation runtime)))
|
||||
(should (= (1+ token) (etaf-runtime-generation-token runtime)))
|
||||
(should (= etaf-retirement-test-update-count 1))
|
||||
(should (equal "updated=B"
|
||||
(with-current-buffer buffer-name (buffer-string))))
|
||||
(setq etaf-retirement-test-update-fail-p nil)
|
||||
(setf (etaf-value source) "C")
|
||||
(should (= etaf-retirement-test-update-count 2))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-retirement-unmount-error-drains-structure-before-resignal ()
|
||||
"Explicit unmount remains detached, abandons later hooks, and cleans scope."
|
||||
(let ((buffer-name " *etaf-retirement-unmount-test*") runtime authority captured)
|
||||
(setq etaf-retirement-test-unmount-first-count 0
|
||||
etaf-retirement-test-unmount-second-count 0
|
||||
etaf-retirement-test-scope-cleanup-count 0)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-view (etaf-retirement-test-unmounted)))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name)
|
||||
authority (etaf-runtime-host-authority runtime))
|
||||
(condition-case condition
|
||||
(etaf-unmount runtime)
|
||||
(etaf-retirement-test-condition (setq captured condition)))
|
||||
(should captured)
|
||||
(should (etaf-condition-postcommit-info captured))
|
||||
(should (= etaf-retirement-test-unmount-first-count 1))
|
||||
(should (zerop etaf-retirement-test-unmount-second-count))
|
||||
(should (= etaf-retirement-test-scope-cleanup-count 1))
|
||||
(should-not (etaf-runtime-mounted-p runtime))
|
||||
(should (eq (etaf-host-authority-state authority) 'terminal))
|
||||
(should-not (etaf-render-port-mounted-p (get-buffer buffer-name))))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(provide 'etaf-retirement-tests)
|
||||
|
||||
;;; etaf-retirement-tests.el ends here
|
||||
File diff suppressed because it is too large
Load Diff
2086
tests/etaf-tests.el
2086
tests/etaf-tests.el
File diff suppressed because it is too large
Load Diff
35
tests/fixtures/etaf-m0a-condition-consumers.sexp
vendored
35
tests/fixtures/etaf-m0a-condition-consumers.sexp
vendored
@ -1,35 +0,0 @@
|
||||
((:file "etaf-data.el" :form condition-case :conditions (error) :owner etaf-data :policy generic-containment)
|
||||
(:file "etaf-data.el" :form condition-case :conditions (error) :owner etaf-data :policy generic-containment)
|
||||
(:file "etaf-observer.el" :form condition-case :conditions (error quit) :owner etaf-observer :policy generic-containment)
|
||||
(:file "etaf-observer.el" :form condition-case :conditions (error quit) :owner etaf-observer :policy generic-containment)
|
||||
(:file "etaf-observer.el" :form condition-case :conditions (error) :owner etaf-observer :policy generic-containment)
|
||||
(:file "etaf-observer.el" :form condition-case :conditions (quit) :owner etaf-observer :policy generic-containment)
|
||||
(:file "etaf-performance.el" :form condition-case :conditions (etaf-runtime-error) :owner etaf-performance :policy specific-compatibility)
|
||||
(:file "etaf-performance.el" :form condition-case :conditions (error) :owner etaf-performance :policy generic-containment)
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-reactive.el" :form condition-case :conditions (error quit) :owner etaf-reactive :policy generic-containment)
|
||||
(:file "etaf-render-port.el" :form condition-case :conditions (error quit) :owner etaf-render-port :policy generic-containment)
|
||||
(:file "etaf-render-port.el" :form condition-case :conditions (etaf-spi-incompatible-error etaf-spi-bootstrap-error) :owner etaf-render-port :policy specific-compatibility)
|
||||
(:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment)
|
||||
(:file "etaf-resource.el" :form condition-case :conditions (error) :owner etaf-resource :policy generic-containment)
|
||||
(:file "etaf-retirement.el" :form condition-case :conditions (error quit) :owner etaf-retirement :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-runtime.el" :form condition-case :conditions (error quit) :owner etaf-runtime :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment)
|
||||
(:file "etaf-scheduler.el" :form condition-case :conditions (error quit) :owner etaf-scheduler :policy generic-containment))
|
||||
File diff suppressed because one or more lines are too long
15
tests/fixtures/etaf-m0b-doc-examples.sexp
vendored
15
tests/fixtures/etaf-m0b-doc-examples.sexp
vendored
@ -1,15 +0,0 @@
|
||||
((:file "docs/user-guide.en.md"
|
||||
:block 19
|
||||
:sha256 "79390863a3fdf604969cc4f424b36a9a466e569bd0ac740e61c580b2518cb2da"
|
||||
:classification mounted-smoke
|
||||
:probe collection-composition)
|
||||
(:file "docs/user-guide.en.md"
|
||||
:block 8
|
||||
:sha256 "5e7b4088abd90a8ff9a5676d8ac98a2534ef43b79e927f14b4a67fe1189a9c11"
|
||||
:classification mounted-smoke
|
||||
:probe runtime-snapshot)
|
||||
(:file "docs/user-guide.zh.md"
|
||||
:block 8
|
||||
:sha256 "5e7b4088abd90a8ff9a5676d8ac98a2534ef43b79e927f14b4a67fe1189a9c11"
|
||||
:classification mounted-smoke
|
||||
:probe runtime-snapshot))
|
||||
@ -1,382 +0,0 @@
|
||||
"""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()
|
||||
Loading…
Reference in New Issue
Block a user