Compare commits

...

8 Commits

Author SHA1 Message Date
Kinneyzhang
cb5d719330 chore: ignore Emacs backup files 2026-09-08 21:33:13 +08:00
Kinneyzhang
591e2a2ead feat: support reusable table cells and adaptive columns 2026-09-06 11:24:19 +08:00
Kinneyzhang
a3647665c7 test: cover private component autoload wrapper 2026-09-01 17:26:02 +08:00
Kinneyzhang
6a1d816292 fix: make component catalog package reload-safe 2026-09-01 17:07:28 +08:00
Kinneyzhang
4d0d63bbb3 perf: simplify retained data grid rows 2026-08-31 16:06:09 +08:00
Kinneyzhang
a4181d0db1 perf: flatten fixed-width table headers 2026-08-31 15:26:41 +08:00
Kinneyzhang
a35b3dc469 fix: close M0b DataGrid publication contract 2026-08-31 15:17:30 +08:00
Kinneyzhang
46617cc8b2 feat: migrate DataGrid to public keyed range DSL 2026-08-31 13:43:49 +08:00
19 changed files with 3686 additions and 1152 deletions

3
.gitignore vendored
View File

@ -1,2 +1,5 @@
*.elc
tests/*.elc
# Emacs backup files.
*~

View File

@ -1,25 +1,34 @@
EMACS ?= emacs
LOAD_PATH = -L . -L ../etaf -L ../ebox -L ../ecss -L ../tp
SOURCES = etaf-ui-style.el etaf-ui-basic.el etaf-ui-table.el etaf-ui-data.el etaf-ui.el
.PHONY: all compile test check checkdoc load clean
TEST_FILES := $(wildcard tests/*-tests.el)
.PHONY: all compile test m0a-inventory check checkdoc load clean
all: check
compile:
rm -f *.elc tests/*.elc
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
--eval '(load-file "etaf-ui.el")' --eval '(byte-compile-file "etaf-ui.el")'
$(EMACS) -Q --batch $(LOAD_PATH) \
--eval '(setq load-prefer-newer t byte-compile-error-on-warn t)' \
--eval '(require (quote cl-lib))' \
--eval '(unless (cl-every (function byte-compile-file) (quote ($(foreach file,$(SOURCES),"$(file)")))) (kill-emacs 1))'
test: compile
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
-l tests/etaf-ui-tests.el -f ert-run-tests-batch-and-exit
$(foreach test,$(TEST_FILES),-l $(test)) -f ert-run-tests-batch-and-exit
m0a-inventory:
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
-l scripts/etaf-ui-m0a-inventory.el -f etaf-ui-m0a-inventory-batch
load: compile
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(require (quote etaf-ui))' \
--eval '(princ "etaf-ui load OK\n")'
checkdoc:
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (directory-files "." t)) (when (string-suffix-p ".el" file) (checkdoc-file file))))'
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (directory-files "." t "\\.el$$") (directory-files-recursively "tests" "\\.el$$") (directory-files-recursively "scripts" "\\.el$$"))) (checkdoc-file file)))'
check: checkdoc compile test

158
README.md
View File

@ -2,27 +2,43 @@
`etaf-ui` is the official ETAF Component catalog. It is a normal optional package above `etaf`; it does not add a second Control or Widget model. Button, Checkbox, Label, Panel, and DataGrid are all ordinary Components with the same View, props, slots, events, and Data contracts.
Use the exact registered names `etaf-panel`, `etaf-label`, `etaf-button`, and
`etaf-checkbox` in every View. Evaluate this complete example in a lexical-binding
`.el` file, then switch to `*etaf-preferences*` to use its controls.
<!-- etaf-example: preferences -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf-ui)
(let ((done (etaf-ref nil)))
(etaf-view
(panel :title "Account"
(slot :name 'header
(button :label "Save" :ref 'save-button
:on-press (lambda () (message "saved"))))
(label :text "Preferences")
(checkbox :checked (etaf-value done) :label "Done"
:ref 'done-checkbox
:on-change (lambda (next)
(setf (etaf-value done) next))))))
(etaf-define-component demo-preferences ()
:setup (list (etaf-ref nil) (etaf-ref "Unsaved"))
:render
(let* ((state (etaf-state))
(done (car state))
(saved (cadr state)))
(etaf-view
(etaf-panel :title "Account"
(slot :name 'header
(etaf-button :label "Save" :ref 'save-button
:on-press (lambda ()
(setf (etaf-value saved) "Saved"))))
(etaf-label :text (etaf-value saved))
(etaf-checkbox :checked (etaf-value done) :label "Done"
:ref 'done-checkbox
:on-change (lambda (next)
(setf (etaf-value done) next)))
(text (expr (if (etaf-value done) "Complete" "Pending")))))))
(etaf-mount "*etaf-preferences*" (etaf-view (demo-preferences)))
```
In `.etaf` files use the short registered tags (`panel`, `label`, `button`,
`checkbox`, and `data-grid`) for structure. The companion `.el` file owns
reactive values, Actions, Behaviors, and callbacks; keep the `etaf-view` tree
made from those same short tags. Canonical `etaf-*` names remain the Elisp
definition and API names.
Core does not automatically load `.etaf` files. The optional Playground reads
inert structural source and explicitly loads its registered Elisp companion;
that file format does not create shorter Component aliases. Local callbacks
need no named Action. Components receive props and slots through the same API
as application-defined Components.
Button and Checkbox are controlled Components. `etaf-button` accepts `:label`,
`:on-press`, `:disabled`, `:ref`, and the small presentation set
@ -67,9 +83,25 @@ no callback, pointer activation, or tab stop. The Runtime owns composition of
an explicit `:on-*` callback with a Behavior callback; the UI package only
declares the control and its visual state.
Spacing is owned by the parent layout, not by Button. Put adjacent controls in
a `row`/`flex` with an explicit horizontal `:gap`; this keeps each control's
mouse-face and hit range semantically separate.
The parent owns spacing: use `(row :item-gap 1 ...)` or
`(column :item-gap 1 ...)`; `flex` and `grid` use `:gap`. In particular, migrate
`row :gap` to `row :item-gap`. Keep an explicit gap between adjacent controls
so each has a separate hover and hit range.
Root event forwarding appends the business action, inner-to-outer wrapper
callbacks, then Behaviors in declaration order. For Checkbox, adding
`:on-press` does not replace its `:on-change` conversion. Errors stop the chain;
each declaration runs once. Wrapper `:use` lists concatenate and duplicate
Behavior names are rejected before installation.
Disabled inputs combine with OR; outer nil cannot enable an internally disabled
control. Disabled dispatch and focus signal `etaf-event-error`; disabled cell
controls block pointer activation from falling through to their parent row.
Disabled input Behaviors are not installed. A conflicting fallthrough `:role`
or owned aria state, such as `:aria-checked`, is an input error; accessible
`:aria-label` and `:aria-description` remain caller-overridable. See the
[interaction and migration rules](../etaf/docs/user-guide.en.md#interaction-migration)
for the complete contract.
`etaf-label` accepts `:text`, `:class`, `:color`, `:bgcolor`, `:font-weight`,
`:width`, `:border`, `:padding`, and `:ref`.
@ -90,7 +122,7 @@ separate from forwarded Host attributes:
| `etaf-number-input` | `:value`, `:label`, `:on-change`, `:disabled`, `:min`, `:max` |
| `etaf-table` | `:columns`, `:rows`, `:row-key`, `:row-ref`, `:on-row-press`, `:row-selected-p` |
| `etaf-data-grid` | `:controller`, `:columns`, `:row-key`, `:on-row-press`, `:row-ref`, `:row-selected-p`, `:loading-label`, `:error-label`, `:empty-label` |
| `etaf-pagination` | `:controller`, `:previous-ref`, `:next-ref`, `:class`, `:color`, `:bgcolor`, `:border`, `:padding`, `:aria-label` |
| `etaf-pagination` | `:controller`, `:previous-ref`, `:next-ref`, `:previous-label`, `:next-label`, `:class`, `:color`, `:bgcolor`, `:border`, `:padding`, `:aria-label` |
<!-- M0b1: single-host-root -->
Every public catalog Component mounts exactly one Host root. All valid Host
@ -104,23 +136,97 @@ optional `:loading-label`, `:error-label`, `:empty-label`, or function-valued
interactive button with role `button` and tab index `0`; the callback receives
the row. Without `:on-row-press`, rows have no callback or tab stop.
Interactive `etaf-table` rows may also omit `:row-ref`; the framework supplies
stable references scoped to the retained Table instance. Supply refs only for
external focus, tests, or integration addresses; do not derive global symbols
from row labels. Row keys identify data; refs identify interactive Hosts.
<!-- M0b1: row-ref-optional -->
`:row-ref` is optional for DataGrid. When it is omitted on an interactive
grid, DataGrid derives a stable internal Host reference from the row identity
owned by the controller. When it is supplied, the callback owns that identity
and must return a non-nil stable Host reference for every row. `:row-key`
owned by the controller. Fallback refs are uninterned and scoped to each
retained DataGrid instance, so separate grids may share row identities without
colliding. When `:row-ref` is supplied, the callback owns that identity and
must return a non-nil stable Host reference for every row. `:row-key`
remains a required non-nil stable scalar identity for retained rows. DataGrid
retains one action closure per row key, so selection or Data Range updates do
not recreate handlers for unchanged rows.
An integer column `:width` is readable character capacity, not a raw pixel
value. DataGrid passes Ebox's native character unit through and reserves one
native character between non-final tracks.
native character between non-final tracks. Use `:width '(fr 1)` to let a column
fill the remaining width; multiple fractional columns share that space by
their positive weights. For example, `(:key :title :width (fr 1))` next to
`(:key :actions :width 22 :cell render-actions)` lets the title adapt while
reserving room for the action controls. Headers and rows use the same tracks
and gap. Fractional cells clip to their allocation without widening neighboring
columns. Fixed tracks still reserve their declared space, so the containing
layout must provide enough width for those controls and gaps.
Changing a custom cell's column width between fixed and fractional values does
not replace its Component state. All-fixed text-only tables retain their compact
text rendering path.
### Custom cells and column migration
Table and DataGrid share the column contract. Every column needs a unique,
non-nil `:key` (symbol, integer, or string), including presentation-only columns.
The default cell reads that field as text. A `:cell` function receives one row
and returns nil, a string, a typed Host or Component View, or a proper sequence
of those values. Table owns cell width and clips overflow; text-only tables
keep their existing compact representation.
The example repeats the `:name` field with two distinct column keys and puts an
ordinary Button in a third column. Select the row or activate Open independently:
<!-- etaf-example: cells -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf-ui)
(etaf-mount
"*etaf-cell-demo*"
(etaf-view
(etaf-table
:rows '((:id 1 :name "Ada"))
:row-key (lambda (row) (plist-get row :id))
:on-row-press (lambda (row) (message "Select %s" (plist-get row :name)))
:columns
(list
'(:key :name :label "Name" :width 12)
(list :key :name-upper :label "Uppercase" :width 12
:cell (lambda (row) (upcase (plist-get row :name))))
(list :key :open :label "Action" :width 10
:cell
(lambda (row)
(etaf-view
(etaf-button
:label "Open"
:on-press (lambda ()
(message "Open %s" (plist-get row :name)))))))))))
```
To migrate duplicate field columns, keep one `:key :name`, give the other a
unique key such as `:name-upper`, and use `:cell` to read the original `:name`
field. Missing or duplicate column keys are errors. Row and column keys retain
cell identity across reordering; changing a key replaces that cell instance.
Cell functions use their row argument and normal lexical captures. Their
Context is the consuming Table/Grid location; they do not recover the author's
props, `etaf-state`, or private styles. Return an ordinary Component when a
cell needs its own state, styles, or lifecycle, and create persistent refs and
watches in that Component's `:setup`. Capture an author's stable ref before
building a callback when sharing it is intentional. Do not create persistent
state on each cell-function call.
`etaf-pagination` is a controlled Data Component. It accepts a Data controller
plus stable `:previous-ref` and `:next-ref` values, renders readable `←`/`→`
controls and a `Page N / M` summary, and disables the boundary action while a
plus stable `:previous-ref` and `:next-ref` values, renders padded secondary
Buttons (` Previous` / `Next `) around a centered `Page N / M` and item-count
summary, and disables the boundary action while a
page is loading or already at the first/last page. It owns no page state and
uses the same Button interaction contract.
uses the same Button interaction contract and Theme tokens. Narrow allocations
wrap the complete controls and summary. Optional `:previous-label` and
`:next-label` replace the complete captions, for example `" 上一页"` and
`"下一页 "`; the stable English accessibility labels remain unchanged.
Keyboard focus uses ETAF's public runtime ports: call
`(etaf-focus-next runtime)` to move through visible Hosts with a numeric

View File

@ -2,26 +2,41 @@
`etaf-ui` 是 ETAF 的官方 Component 目录,是建立在 `etaf` 之上的可选独立包。它不增加第二套 Control 或 Widget 模型Button、Checkbox、Label、Panel、DataGrid 都是使用同一套 View、属性、slot、事件和 Data 契约的普通 Component。
所有 View 都使用准确的注册名称:`etaf-panel`、`etaf-label`、`etaf-button` 和
`etaf-checkbox`。把下面完整例子放进启用 lexical-binding 的 `.el` 文件求值,
再切换到 `*etaf-preferences*` 使用控件。
<!-- etaf-example: preferences -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf-ui)
(let ((done (etaf-ref nil)))
(etaf-view
(panel :title "Account"
(slot :name 'header
(button :label "Save" :ref 'save-button
:on-press (lambda () (message "saved"))))
(label :text "Preferences")
(checkbox :checked (etaf-value done) :label "Done"
:ref 'done-checkbox
:on-change (lambda (next)
(setf (etaf-value done) next))))))
(etaf-define-component demo-preferences ()
:setup (list (etaf-ref nil) (etaf-ref "Unsaved"))
:render
(let* ((state (etaf-state))
(done (car state))
(saved (cadr state)))
(etaf-view
(etaf-panel :title "Account"
(slot :name 'header
(etaf-button :label "Save" :ref 'save-button
:on-press (lambda ()
(setf (etaf-value saved) "Saved"))))
(etaf-label :text (etaf-value saved))
(etaf-checkbox :checked (etaf-value done) :label "Done"
:ref 'done-checkbox
:on-change (lambda (next)
(setf (etaf-value done) next)))
(text (expr (if (etaf-value done) "Complete" "Pending")))))))
(etaf-mount "*etaf-preferences*" (etaf-view (demo-preferences)))
```
`.etaf` 文件的结构使用已注册的短标签(`panel`、`label`、`button`、
`checkbox`、`data-grid`)。配套 `.el` 文件负责响应式值、Action、Behavior
和回调;其中 `etaf-view` 也使用同一组短标签。Elisp 定义和 API 文档仍使用
规范的 `etaf-*` 名称。
Core 不会自动加载 `.etaf`。可选的 Playground 读取 inert 结构源,并显式加载
已注册的 Elisp companion这个文件格式不会生成更短的 Component alias。
普通本地回调不需要命名 Action目录组件与应用自己定义的组件使用相同的 props 和 slot API。
Button 和 Checkbox 都是受控组件。`etaf-button` 支持 `:label`
`:on-press`、`:disabled`、`:ref`,以及最小 presentation 属性
@ -59,8 +74,20 @@ Component 的 `:styles` 声明负责默认外观。调用者提供的非 nil pre
显式 `:on-*` 回调和 Behavior 回调的组合由 Runtime 负责UI 包只声明控件和
视觉状态。
间距由父布局负责,而不是由 Button 偷塞。相邻控件应放在带明确横向 `:gap`
`row`/`flex` 中,这样每个控件的 mouse-face 和命中范围才保持语义独立。
间距由父布局负责:`row` 和 `column` 使用 `:item-gap`,例如
`(row :item-gap 1 ...)``flex` 和 `grid` 使用 `:gap`。尤其需要将 `row :gap`
迁移为 `row :item-gap`。相邻控件保留明确间距,让 hover 和命中范围各自独立。
根事件透传按顺序追加:业务动作、由内到外的 wrapper callback、最后按声明顺序
运行的 Behavior。给 Checkbox 增加 `:on-press` 不会替换它的 `:on-change` 转换。
每个声明执行一次错误会中断后续回调。wrapper 的 `:use` 列表顺序连接,重复
Behavior name 在安装前报错。
禁用输入取 OR外层 nil 不能启用内部已经禁用的控件。禁用时 dispatch 和 focus
抛出 `etaf-event-error`,禁用 cell 控件会阻止指针激活落到父行,输入 Behavior
也不会安装。透传 `:role``:aria-checked` 等组件所有的 aria 状态时,冲突值会
导致输入错误;调用方仍可覆盖 `:aria-label``:aria-description`。完整规则见
[交互与迁移说明](../etaf/docs/user-guide.zh.md#interaction-migration)。
`etaf-label` 支持 `:text`、`:class`、`:color`、`:bgcolor`、`:font-weight`、
`:width`、`:border`、`:padding` 和 `:ref`
@ -79,7 +106,7 @@ surface presentation 属性,并投影命名的 `header` slot 和默认 slot。
| `etaf-number-input` | `:value`、`:label`、`:on-change`、`:disabled`、`:min`、`:max` |
| `etaf-table` | `:columns`、`:rows`、`:row-key`、`:row-ref`、`:on-row-press`、`:row-selected-p` |
| `etaf-data-grid` | `:controller`、`:columns`、`:row-key`、`:on-row-press`、`:row-ref`、`:row-selected-p`、`:loading-label`、`:error-label`、`:empty-label` |
| `etaf-pagination` | `:controller`、`:previous-ref`、`:next-ref`、`:class`、`:color`、`:bgcolor`、`:border`、`:padding`、`:aria-label` |
| `etaf-pagination` | `:controller`、`:previous-ref`、`:next-ref`、`:previous-label`、`:next-label`、`:class`、`:color`、`:bgcolor`、`:border`、`:padding`、`:aria-label` |
<!-- M0b1: single-host-root -->
目录中的每个公共 Component 都只挂载一个 Host root。未被作为 business prop
@ -92,20 +119,86 @@ DataGrid 支持列描述、函数型 `:row-key`,以及可选的
`tab-index 0` 的可交互 button且回调接收该行没有 `:on-row-press` 时,行
没有回调或 tab stop。
`etaf-table` 的交互行也可省略 `:row-ref`,框架会提供属于当前保留实例的稳定引用。
只有外部 focus、测试或集成需要直接寻址时才提供 ref不要根据行文字拼接全局
symbol。row key 负责数据身份ref 负责交互 Host 地址。
<!-- M0b1: row-ref-optional -->
DataGrid 的 `:row-ref` 是可选项。交互式 grid 省略它时DataGrid 会根据
controller 持有的 row identity 派生稳定的内部 Host ref显式提供它时
该回调拥有 identity并且必须为每一行返回非 nil 的稳定 Host ref。
controller 持有的 row identity 派生稳定的内部 Host ref。fallback ref 不会
进入全局 symbol table并按每个 retained DataGrid instance 隔离,因此多个 grid
可以安全复用相同行 identity显式提供它时该回调拥有 identity并且必须为
每一行返回非 nil 的稳定 Host ref。
`:row-key` 仍然是 retained row 必须具备的非 nil 稳定标量 identity。
DataGrid 按 row key 保留唯一 action closure因此 selection 或 Data Range
更新不会为未变化的行重建 handler。
整数列 `:width` 表示可读字符容量不是裸像素DataGrid 原样使用 Ebox 原生字符单位,
并在非末列之间保留一个原生字符间距。
并在非末列之间保留一个原生字符间距。使用 `:width '(fr 1)` 让列填充剩余宽度;
多个 fractional 列按正数权重分配这部分空间。例如让
`(:key :title :width (fr 1))`
`(:key :actions :width 22 :cell render-actions)` 配合,可以在保留操作控件空间的
同时自适应标题宽度。表头和数据行使用相同的轨道及间距。自适应 cell 按分配的
宽度裁剪,不会挤宽相邻列。固定列仍保留声明的空间,父布局需要容纳这些控件
及列间距。
自定义 cell 的列宽在固定值与 fractional 值之间切换时,其 Component 状态保持。
全固定列的纯文本表格仍保留紧凑的文本渲染路径。
### 自定义 cell 与列迁移
Table 与 DataGrid 共用列契约。每一列都必须有唯一且非 nil 的 `:key`
symbol、整数或字符串纯展示列也一样。默认 cell 将该字段显示为文字。
`:cell` 函数接收一个 row返回 nil、字符串、typed Host 或 Component View
或这些值组成的 proper sequence。Table 拥有 cell 宽度并裁剪溢出;纯文本表格
继续使用原有的紧凑表示。
下面将 `:name` 字段用两个不同的 column key 展示,并在第三列放入普通 Button。
行选择与 Open 按钮分别执行自己的动作:
<!-- etaf-example: cells -->
```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf-ui)
(etaf-mount
"*etaf-cell-demo*"
(etaf-view
(etaf-table
:rows '((:id 1 :name "Ada"))
:row-key (lambda (row) (plist-get row :id))
:on-row-press (lambda (row) (message "Select %s" (plist-get row :name)))
:columns
(list
'(:key :name :label "Name" :width 12)
(list :key :name-upper :label "Uppercase" :width 12
:cell (lambda (row) (upcase (plist-get row :name))))
(list :key :open :label "Action" :width 10
:cell
(lambda (row)
(etaf-view
(etaf-button
:label "Open"
:on-press (lambda ()
(message "Open %s" (plist-get row :name)))))))))))
```
迁移重复字段列时,保留一列的 `:key :name`,为另一列指定 `:name-upper` 等唯一
key再通过 `:cell` 读取原来的 `:name` 字段。缺失或重复 column key 都会报错。
row key 与 column key 让 cell 身份在重排时保留;改变 key 会替换该 cell 实例。
cell 函数使用 row 参数与普通词法捕获Context 来自消费它的 Table/Grid 挂载
位置,不会恢复作者的 props、`etaf-state` 或私有样式。cell 需要自己的状态、样式
或生命周期时,返回普通 Component在它的 `:setup` 中创建持久 ref 和 watch。
若有意共享作者的 ref应在创建回调前捕获稳定句柄不要在每次 cell 函数调用时
创建持久状态。
`etaf-pagination` 是受控 Data Component。它接收 Data controller 以及稳定的
`:previous-ref`、`:next-ref`,显示易读的 `←`/`→` 控件和 `Page N / M` 摘要;
加载中或已经位于首/末页时会禁用对应动作。它不拥有页码状态,并复用 Button
的交互契约。
`:previous-ref`、`:next-ref`,使用带内边距的 secondary Button` Previous` /
`Next `),中间显示 `Page N / M` 与条数摘要。空间不足时,完整控件和摘要
自然换行。加载中或已经位于首/末页时会禁用对应动作。它不拥有页码状态,
并复用 Button 的交互契约和 Theme token。可选的 `:previous-label`
`:next-label` 替换完整按钮文案,例如 `" 上一页"`、`"下一页 "`;稳定的英文
无障碍标签保持不变。
键盘焦点使用 ETAF 的公共 Runtime 端口:用
`(etaf-focus-next runtime)` 在带数值且非负 `:tab-index` 的可见 Host 之间

225
etaf-ui-basic.el Normal file
View File

@ -0,0 +1,225 @@
;;; etaf-ui-basic.el --- Basic reusable ETAF UI Components -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Label, Button, Checkbox, and Panel are the catalog's small semantic
;; building blocks. NumberInput is the first compound Component and composes
;; Button instead of duplicating its interaction contract.
;;; Code:
(require 'cl-lib)
(require 'etaf-ui-style)
(defun etaf-ui--class-value (base state custom)
"Return BASE and STATE classes with optional CUSTOM classes."
(let ((custom (cond ((null custom) nil)
((listp custom) custom)
(t (list custom)))))
(mapconcat
(lambda (class) (format "%s" class))
(cl-remove-if
(lambda (class) (or (null class) (equal class "")))
(append (list base state) custom))
" ")))
(defun etaf-ui--reactive-value (value)
"Return VALUE, reading it when it is an ETAF reactive source."
(if (or (etaf-ref-p value) (etaf-computed-p value))
(etaf-value value)
value))
(defun etaf-ui--text-value (value)
"Return VALUE as a Text payload without discarding string properties."
(setq value (etaf-ui--reactive-value value))
(cond ((null value) "")
((stringp value) value)
(t (format "%s" value))))
(defun etaf-ui--label-presentation (variant)
"Return semantic presentation for Label VARIANT."
(let* ((variant (or variant 'default))
(color-key
(pcase variant
('muted :ui-muted-fg)
('danger :ui-danger-fg)
('success :ui-success-fg)
(_ :ui-fg)))
(theme (etaf-ui--style-tokens color-key)))
(list :variant variant
:color (plist-get theme color-key)
:font-weight (when (memq variant '(strong heading)) 'bold))))
(etaf-ui--define-component etaf-label (&key text variant)
"Render TEXT as a semantic Label."
:view
(text
:class (let ((presentation (etaf-ui--label-presentation variant)))
(etaf-ui--class-value
"etaf-label"
(symbol-name (plist-get presentation :variant)) nil))
:color (plist-get (etaf-ui--label-presentation variant) :color)
:font-weight
(plist-get (etaf-ui--label-presentation variant) :font-weight)
(expr (etaf-ui--text-value text))))
(defun etaf-ui--button-variant-values (variant disabled)
"Return themed presentation defaults for Button VARIANT and DISABLED."
(let* ((fg (cond (disabled :ui-disabled-fg)
((eq variant 'secondary) :ui-button-secondary-fg)
((eq variant 'ghost) :ui-button-ghost-fg)
(t :ui-button-primary-fg)))
(bg (cond (disabled :ui-disabled-bg)
((eq variant 'secondary) :ui-button-secondary-bg)
((eq variant 'ghost) :ui-button-ghost-bg)
(t :ui-button-primary-bg)))
(border-key
(cond (disabled :ui-disabled-border)
((eq variant 'secondary) :ui-button-secondary-border)
((eq variant 'ghost) :ui-button-ghost-border)
(t :ui-button-primary-border)))
(theme (etaf-ui--style-tokens fg bg border-key)))
(list :color (plist-get theme fg)
:bgcolor (plist-get theme bg)
:border (etaf-ui--style-border (plist-get theme border-key))
:font-weight (if (or disabled (eq variant 'ghost)) 'normal 'bold))))
(etaf-ui--define-component etaf-button
(&key label on-press disabled ref class color bgcolor border padding
font-weight tab-index aria-label use variant)
"Render a standard pressable Button with a committed callback.
DISABLED removes the callback and default focus tab index. Presentation props
remain caller-overridable. Runtime publishes ON-PRESS with the visible Button,
so a failed render keeps the previous callback and its captured values."
:render
(let* ((label (etaf-ui--text-value label))
(variant-values
(etaf-ui--button-variant-values
(and (not disabled) variant) disabled)))
(etaf-node
'box
(list
:class (etaf-ui--class-value
"etaf-button"
(if disabled "disabled" "enabled")
class)
:ref ref :role 'button :disabled disabled
:tab-index (unless disabled (or tab-index 0))
:aria-label (or aria-label label)
:color (or color (plist-get variant-values :color))
:background-color (or bgcolor (plist-get variant-values :bgcolor))
:border (or border (plist-get variant-values :border))
:padding padding
:font-weight (or font-weight (plist-get variant-values :font-weight))
:use use
:on-press (and (not disabled) on-press))
(list (etaf-node 'text nil (list label)))))
:styles
(styles
("&" :width max-content)
("&.disabled" :padding (0 1) :font-weight normal)
("&.enabled" :padding (0 1) :font-weight bold)))
(defun etaf-ui--checkbox-variant-values (disabled)
"Return semantic Theme presentation for a DISABLED Checkbox."
(let* ((prefix (if disabled "disabled" "enabled"))
(fg (intern (format ":ui-checkbox-%s-fg" prefix)))
(bg (intern (format ":ui-checkbox-%s-bg" prefix)))
(border-key (intern (format ":ui-checkbox-%s-border" prefix)))
(theme (etaf-ui--style-tokens fg bg border-key)))
(list :color (plist-get theme fg)
:bgcolor (plist-get theme bg)
:border (etaf-ui--style-border (plist-get theme border-key)))))
(etaf-ui--define-component etaf-checkbox
(&key checked label on-change disabled)
"Render a controlled Checkbox whose next value is sent to ON-CHANGE."
:view
(row
:class (etaf-ui--class-value
"etaf-checkbox" (if disabled "disabled" "enabled") nil)
:role 'checkbox :disabled disabled
:aria-label (etaf-ui--text-value label)
:tab-index (unless disabled 0)
:color (plist-get (etaf-ui--checkbox-variant-values disabled) :color)
:background-color
(plist-get (etaf-ui--checkbox-variant-values disabled) :bgcolor)
:border (plist-get (etaf-ui--checkbox-variant-values disabled) :border)
:on-press
(and (not disabled) on-change
(let ((callback on-change)
(source checked))
(lambda ()
(funcall callback (not (etaf-ui--reactive-value source))))))
(box :class "etaf-checkbox-mark"
(text (expr (if (etaf-ui--reactive-value checked) "" ""))))
(text (expr
(let ((value (etaf-ui--text-value label)))
(if (string-empty-p value) "" (concat " " value))))))
:styles
(styles
("&" :width max-content)
("&.disabled" :padding (0 1))
("&.enabled" :padding (0 1))
(".etaf-checkbox-mark" :font-weight bold :width 1)))
(etaf-ui--define-component etaf-panel (&key title variant)
"Render a titled Panel with named header and default slots."
:render
(let ((theme (etaf-ui--style-tokens
:ui-panel-fg :ui-panel-bg :ui-panel-border)))
(etaf-node
'column
(list :class (etaf-ui--class-value
"etaf-panel" (symbol-name (or variant 'default)) nil)
:color (plist-get theme :ui-panel-fg)
:background-color
(unless (eq variant 'flat) (plist-get theme :ui-panel-bg))
:border
(unless (eq variant 'flat)
(etaf-ui--style-border (plist-get theme :ui-panel-border))))
(append
(when title
(list (etaf-node
'etaf-label
(list :class "etaf-panel-title" :text title :variant 'strong)
nil)))
(etaf-current-slot 'header)
(etaf-current-slot 'default))))
:styles
(styles
("&" :padding (1 2))
(".etaf-panel-title" :font-weight bold)))
(etaf-ui--define-component etaf-number-input
(&key value label on-change disabled min max)
"Render a controlled minibuffer-backed NumberInput using Button."
:render
(let ((label (or label "Value"))
(callback on-change)
(current-value value)
(minimum min)
(maximum max))
(etaf-node
'etaf-button
(list
:label (format "%s %s ✎" label (or current-value ""))
:disabled disabled :variant 'ghost
:on-press
(unless disabled
(lambda ()
(let ((next (read-number
(format "%s: " label) (or current-value 0))))
(unless (and (integerp next)
(or (null minimum) (>= next minimum))
(or (null maximum) (<= next maximum)))
(user-error "%s must be an integer from %s to %s"
label (or minimum "") (or maximum "")))
(when callback (funcall callback next))))))
nil)))
(provide 'etaf-ui-basic)
;;; etaf-ui-basic.el ends here

393
etaf-ui-data.el Normal file
View File

@ -0,0 +1,393 @@
;;; etaf-ui-data.el --- Data-aware ETAF UI Components -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; DataGrid and Pagination adapt ETAF Data Controller state onto basic
;; Components. They do not duplicate Table or Button behavior.
;;; Code:
(require 'etaf-ui-table)
(declare-function etaf-data-status "etaf-data" (controller))
(declare-function etaf-data-items "etaf-data" (controller))
(declare-function etaf-data-page "etaf-data" (controller))
(declare-function etaf-data-page-size "etaf-data" (controller))
(declare-function etaf-data-total "etaf-data" (controller))
(declare-function etaf-data-previous-page "etaf-data" (controller))
(declare-function etaf-data-next-page "etaf-data" (controller))
(declare-function etaf-data-selected-ref "etaf-data" (controller identity))
(declare-function etaf-data-item-identity "etaf-data" (controller item))
(defun etaf-ui--data-grid-default-row-ref (state controller row)
"Return STATE's stable internal Host reference for CONTROLLER and ROW.
The controller's validated item identity is the row input. Like Table's
retained row references, per-instance uninterned symbols prevent cross-grid
collisions and avoid process-global symbol-table growth."
(let* ((identity (etaf-data-item-identity controller row))
(cache (plist-get state :row-refs))
(stage (plist-get state :row-ref-stage))
(ref (or (gethash identity cache)
(and (hash-table-p stage) (gethash identity stage)))))
(unless ref
(unless (hash-table-p stage)
(error "ETAF DataGrid row ref changed outside a keyed candidate"))
(setq ref (make-symbol (format "etaf-data-grid-row-%s" identity)))
(puthash identity ref stage))
ref))
(defun etaf-ui--data-grid-row-ref
(state row-ref on-row-press controller row)
"Return a validated stable Host reference for interactive ROW.
An explicit ROW-REF remains caller-owned. Interactive grids without one use
STATE's CONTROLLER identity fallback; when ON-ROW-PRESS is nil, rows have no
Host reference."
(when on-row-press
(let ((ref (if row-ref
(funcall row-ref row)
(etaf-ui--data-grid-default-row-ref
state controller row))))
(unless ref
(error "ETAF DataGrid :row-ref must return a non-nil stable ref"))
ref)))
(defun etaf-ui--data-grid-row-action-entry ()
"Return one committed-state cell and stable DataGrid handler."
(let (entry)
(setq entry (vector nil nil nil))
(aset entry 2
(lambda ()
(let ((current (aref entry 1)))
(when current
(funcall current (aref entry 0))))))
entry))
(defun etaf-ui--data-grid-row-action (state key row callback)
"Return STATE's stable action for row KEY, staging ROW and CALLBACK.
Committed handlers read only committed cells. Candidate rendering writes a
private stage that lifecycle hooks promote after successful publication."
(let* ((cache (plist-get state :row-actions))
(stage (plist-get state :row-action-stage))
(committed (gethash key cache)))
(if (and committed
(equal-including-properties row (aref committed 0))
(eq callback (aref committed 1)))
(aref committed 2)
(unless (hash-table-p stage)
(error "ETAF DataGrid handler changed outside a keyed candidate"))
(let* ((proposal (gethash key stage))
(entry (or committed (and proposal (aref proposal 0))
(etaf-ui--data-grid-row-action-entry))))
(puthash key (vector entry row callback) stage)
(aref entry 2)))))
(defun etaf-ui--data-grid-promote-row-actions (state)
"Promote STATE's staged row actions/refs and prune non-live keys."
(let ((stage (plist-get state :row-action-stage))
(live (plist-get state :row-action-live-keys))
(cache (plist-get state :row-actions))
(prune-p (plist-get state :row-cache-prune-p)))
(when (and (hash-table-p stage) (hash-table-p live))
(maphash
(lambda (key proposal)
(let ((entry (aref proposal 0)))
(aset entry 0 (aref proposal 1))
(aset entry 1 (aref proposal 2))
(puthash key entry cache)))
stage)
(when prune-p
(let (removed)
(maphash (lambda (key _entry)
(unless (gethash key live) (push key removed)))
cache)
(dolist (key removed) (remhash key cache))))
(setf (plist-get state :row-action-stage) nil
(plist-get state :row-action-live-keys) nil)))
(let ((stage (plist-get state :row-ref-stage))
(live (plist-get state :row-ref-live-identities))
(cache (plist-get state :row-refs))
(prune-p (plist-get state :row-cache-prune-p)))
(when (and (hash-table-p stage) (hash-table-p live))
(maphash (lambda (identity ref) (puthash identity ref cache)) stage)
(when prune-p
(let (removed)
(maphash (lambda (identity _ref)
(unless (gethash identity live)
(push identity removed)))
cache)
(dolist (identity removed) (remhash identity cache))))
(setf (plist-get state :row-ref-stage) nil
(plist-get state :row-ref-live-identities) nil
(plist-get state :row-cache-prune-p) nil)))
state)
(defun etaf-ui--data-grid-dispose-row-actions (state)
"Release all committed and staged row actions in STATE."
(clrhash (plist-get state :row-actions))
(clrhash (plist-get state :row-refs))
(setf (plist-get state :row-action-stage) nil
(plist-get state :row-action-live-keys) nil
(plist-get state :row-ref-stage) nil
(plist-get state :row-ref-live-identities) nil
(plist-get state :row-cache-prune-p) nil)
state)
(defun etaf-ui--data-grid-row-selected-p (controller row row-selected-p)
"Return whether ROW is selected in CONTROLLER or by ROW-SELECTED-P."
(or (and row-selected-p (funcall row-selected-p row))
(etaf-value
(etaf-data-selected-ref
controller (etaf-data-item-identity controller row)))))
(defun etaf-ui--data-grid-row
(state controller entry columns row-ref on-row-press row-selected-p theme)
"Return one retained DataGrid row for keyed ENTRY.
CONTROLLER owns selection identity; ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P
define the interaction contract. STATE retains callback identity and stages
candidate values; THEME is the resolved table-paint snapshot for this item."
(let* ((key (car entry))
(row (cdr entry))
(border-color (plist-get theme :ui-table-border))
(selected-p
(etaf-ui--data-grid-row-selected-p
controller row row-selected-p)))
(unless key
(error "ETAF DataGrid row-key must return a non-nil stable scalar"))
(etaf-node
'row
(list :key key
:class (concat "etaf-table-row" (when selected-p " selected"))
:ref (etaf-ui--data-grid-row-ref
state row-ref on-row-press controller row)
:role (when on-row-press 'button)
:tab-index (when on-row-press 0)
:color (when selected-p
(plist-get theme :ui-table-selected-fg))
:background-color (when selected-p
(plist-get theme :ui-table-selected-bg))
:border-bottom-width 1
:border-bottom-style 'solid
:border-bottom-color border-color
:on-press
(and on-row-press
(etaf-ui--data-grid-row-action
state key row on-row-press)))
(etaf-ui--table-row-children row columns))))
(defun etaf-ui--data-grid-state-label (key text &optional class color)
"Return TEXT as a non-row DataGrid state label identified by KEY.
CLASS and COLOR optionally style the label."
(etaf-node 'etaf-label
(list :key key :text text :class class :color color)
nil))
(defun etaf-ui--data-grid-body-entries
(state controller row-key on-row-press row-ref
loading-label error-label empty-label)
"Return keyed Range entries and begin STATE's candidate action stage.
CONTROLLER and ROW-KEY identify successful rows. ON-ROW-PRESS and ROW-REF
determine which current keys retain committed handlers and fallback refs.
LOADING-LABEL, ERROR-LABEL, and EMPTY-LABEL override the state text."
(let* ((status (etaf-value (etaf-data-status controller)))
(items (etaf-value (etaf-data-items controller)))
(entries
(cond
((eq status 'loading)
(list (cons 'loading
(list :etaf-data-grid-state 'loading
:text (or loading-label "Loading...")))))
((eq status 'error)
(list (cons 'error
(list :etaf-data-grid-state 'error
:text (or error-label
"Unable to load data.")))))
(items (etaf-ui--table-entries items row-key))
(t
(list (cons 'empty
(list :etaf-data-grid-state 'empty
:text (or empty-label "No data.")))))))
(stage (make-hash-table :test #'equal))
(live (make-hash-table :test #'equal))
(ref-stage (make-hash-table :test #'equal))
(ref-live (make-hash-table :test #'equal)))
(when (and on-row-press items (not (memq status '(loading error))))
(dolist (entry entries) (puthash (car entry) t live))
(unless row-ref
(dolist (row items)
(puthash (etaf-data-item-identity controller row) t ref-live))))
(setf (plist-get state :row-action-stage) stage
(plist-get state :row-action-live-keys) live
(plist-get state :row-ref-stage) ref-stage
(plist-get state :row-ref-live-identities) ref-live
(plist-get state :row-cache-prune-p)
(not (memq status '(loading error))))
entries))
(defun etaf-ui--data-grid-state-entry-node (entry)
"Return the state label View represented by keyed ENTRY."
(let* ((state (cdr entry))
(kind (plist-get state :etaf-data-grid-state))
(theme (and (eq kind 'error)
(etaf-ui--style-tokens :ui-data-grid-error-fg))))
(etaf-ui--data-grid-state-label
kind (plist-get state :text)
(when (eq kind 'error) "etaf-data-grid-error")
(and theme (plist-get theme :ui-data-grid-error-fg)))))
(etaf-ui--define-component etaf-ui--data-grid-body-item
(&key controller entry columns row-ref on-row-press row-selected-p
grid-state)
"Render one retained keyed DataGrid ENTRY with a cached row action."
:render
(if (plist-get (cdr entry) :etaf-data-grid-state)
(etaf-ui--data-grid-state-entry-node entry)
(etaf-ui--data-grid-row
grid-state controller entry columns row-ref on-row-press row-selected-p
(etaf-ui--style-tokens
:ui-table-border :ui-table-selected-fg :ui-table-selected-bg))))
(etaf-ui--define-component etaf-data-grid
(&key controller columns row-key on-row-press row-ref row-selected-p
loading-label error-label empty-label)
"Render DATA CONTROLLER state through the public Component DSL.
DataGrid owns loading, error, empty, and controller-selection adaptation.
Its keyed Range retains row identity across insert, reorder, and update.
Setup state owns per-instance fallback refs plus commit-staged stable row
actions; failed candidates cannot mutate committed handler inputs. COLUMNS
use Table's unique keys and optional `:cell' row-to-View functions."
:setup
(let ((state
(list :row-actions (make-hash-table :test #'equal)
:row-action-stage nil
:row-action-live-keys nil
:row-refs (make-hash-table :test #'equal)
:row-ref-stage nil
:row-ref-live-identities nil
:row-cache-prune-p nil)))
(etaf-on-mounted
(lambda () (etaf-ui--data-grid-promote-row-actions state)))
(etaf-on-updated
(lambda () (etaf-ui--data-grid-promote-row-actions state)))
(etaf-on-unmounted
(lambda () (etaf-ui--data-grid-dispose-row-actions state)))
state)
:view
(column
:class "etaf-data-grid etaf-table"
:color (plist-get (etaf-ui--style-tokens :ui-fg) :ui-fg)
(etaf-ui--table-header :columns columns)
(column
:class "etaf-table-body"
(etaf-ui--data-grid-body-item
:for (entry
(etaf-ui--data-grid-body-entries
(etaf-state) controller row-key on-row-press row-ref
loading-label error-label empty-label))
:key (car entry)
:controller controller :entry entry :columns columns
:row-ref row-ref :on-row-press on-row-press
:row-selected-p row-selected-p
:grid-state (etaf-state)))
(slot :name 'footer)))
(etaf-ui--define-component etaf-pagination
(&key controller previous-ref next-ref previous-label next-label
class color bgcolor border padding aria-label)
"Render a controlled pager whose callbacks follow its committed CONTROLLER.
PREVIOUS-LABEL and NEXT-LABEL override the complete Button captions.
Each Button captures its render's Controller; Runtime publishes that callback
together with the visible control after a successful render."
:render
(let ((controller-value controller))
(let* ((theme (etaf-ui--style-tokens
:ui-fg :ui-bg :ui-pagination-muted-fg))
(parent-color (or color (plist-get theme :ui-fg)))
(parent-bgcolor (or bgcolor (plist-get theme :ui-bg)))
(page (max 1 (or (and controller-value
(etaf-value (etaf-data-page controller-value)))
1)))
(page-size
(max 1 (or (and controller-value
(etaf-value (etaf-data-page-size controller-value)))
1)))
(total (max 0 (or (and controller-value
(etaf-value (etaf-data-total controller-value)))
0)))
(pages (max 1 (ceiling (/ (float total) page-size))))
(loading-p (and controller-value
(eq (etaf-value (etaf-data-status controller-value))
'loading)))
(previous-disabled (or loading-p (<= page 1)))
(next-disabled (or loading-p (>= page pages)))
(first-item (if (zerop total) 0
(1+ (* (1- page) page-size))))
(last-item (min total (* page page-size))))
(etaf-node
'flex
(list :class (etaf-ui--class-value "etaf-pagination" nil class)
:width 'stretch :flex-direction 'row :align-items 'center
:flex-wrap 'wrap :justify-content 'center
:role 'navigation :aria-label (or aria-label "Pagination")
:color parent-color :background-color parent-bgcolor
:box-sizing 'border-box :padding (or padding '(0 1))
:gap '(1 (16)))
(list
(etaf-node
'column
(list :width 'max-content
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto)
(list
(etaf-node
'etaf-button
(list :label (or previous-label " Previous") :ref previous-ref
:aria-label "Previous page"
:disabled previous-disabled :padding '(0 2)
:variant 'secondary :border border
:color (and (not previous-disabled) color) :bgcolor bgcolor
:on-press
(lambda () (etaf-data-previous-page controller-value)))
nil)))
(etaf-node
'column
(list :width 'max-content
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto)
(list
(etaf-node
'box
(list :class "etaf-pagination-label" :text-align 'center
:wrap-mode 'none :min-width 'max-content)
(list (format "Page %d / %d" page pages)))
(etaf-node
'box
(list :class "etaf-pagination-summary" :text-align 'center
:color (plist-get theme :ui-pagination-muted-fg)
:wrap-mode 'none :min-width 'max-content)
(list (format "%d%d of %d" first-item last-item total)))))
(etaf-node
'column
(list :width 'max-content
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto)
(list
(etaf-node
'etaf-button
(list :label (or next-label "Next ") :ref next-ref
:aria-label "Next page"
:disabled next-disabled :padding '(0 2)
:variant 'secondary :border border
:color (and (not next-disabled) color) :bgcolor bgcolor
:on-press
(lambda () (etaf-data-next-page controller-value)))
nil)))))))
:styles
(styles
("&" :width stretch)
(".etaf-pagination-label" :font-weight bold)))
(provide 'etaf-ui-data)
;;; etaf-ui-data.el ends here

94
etaf-ui-style.el Normal file
View File

@ -0,0 +1,94 @@
;;; etaf-ui-style.el --- Internal styling for ETAF UI Components -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Private catalog styling. ETAF owns Theme; this module only supplies
;; fallback values for the semantic tokens consumed by official Components.
;;; Code:
(require 'cl-lib)
(require 'etaf)
(defvar etaf-ui--component-definition-signatures
(make-hash-table :test #'eq)
"Exact catalog definitions already installed in the current process.")
(defmacro etaf-ui--define-component (name arguments &rest clauses)
"Define catalog Component NAME once for exact ARGUMENTS and CLAUSES.
`package.el' may reload dependency files after byte compilation. Identical
catalog definitions are idempotent across that reload, while a changed
definition still reaches `etaf-define-component' and therefore requires the
public `etaf-component-redefine-run' boundary."
(declare (indent 2) (debug defun))
(let ((signature
(secure-hash 'sha256
(prin1-to-string (list name arguments clauses)))))
`(unless (equal
(gethash ',name etaf-ui--component-definition-signatures)
,signature)
(prog1
(etaf-define-component ,name ,arguments ,@clauses)
(puthash ',name ,signature
etaf-ui--component-definition-signatures)))))
(defconst etaf-ui--style-palette
'(:ui-fg "#252A2E"
:ui-bg "#FFFDF8"
:ui-border "#687386"
:ui-muted-fg "#526174"
:ui-danger-fg "#FF6B6B"
:ui-success-fg "#2F6B43"
:ui-disabled-fg "#687386"
:ui-disabled-bg "#E5E7EB"
:ui-disabled-border "#9CA3AF"
:ui-button-primary-fg "#FFFFFF"
:ui-button-primary-bg "#2F6B43"
:ui-button-primary-border "#2F6B43"
:ui-button-secondary-fg "#142235"
:ui-button-secondary-bg "#D9EEEA"
:ui-button-secondary-border "#2E8B83"
:ui-button-ghost-fg "#142235"
:ui-button-ghost-bg "#FFFDF8"
:ui-button-ghost-border "#C8C1B6"
:ui-checkbox-enabled-fg "#252A2E"
:ui-checkbox-enabled-bg "#DCEBDD"
:ui-checkbox-enabled-border "#6D8A73"
:ui-checkbox-disabled-fg "#6B7280"
:ui-checkbox-disabled-bg "#EEEAE2"
:ui-checkbox-disabled-border "#9CA3AF"
:ui-table-border "#687386"
:ui-table-selected-fg "#2F6B43"
:ui-table-selected-bg "#DCEBDD"
:ui-data-grid-error-fg "#FF6B6B"
:ui-pagination-muted-fg "#526174"
:ui-panel-fg "#252A2E"
:ui-panel-bg "#FFFDF8"
:ui-panel-border "#687386")
"Fallback values for semantic tokens used by ETAF UI Components.")
(defun etaf-ui--style-tokens (&rest keys)
"Return deferred ETAF Theme values for private catalog token KEYS."
(let (result)
(dolist (key keys result)
(setq result
(plist-put
result key
(etaf-theme-token key (plist-get etaf-ui--style-palette key)))))))
(defun etaf-ui--style-border (value)
"Return canonical border VALUE from a semantic ETAF Theme value."
(cond
((etaf-theme-token-p value)
(etaf-theme-token (nth 1 value) (nth 2 value)
#'etaf-ui--style-border))
((and (stringp value)
(string-match-p "\\`#[[:xdigit:]]+\\'" value))
(list 1 'solid value))
(t value)))
(provide 'etaf-ui-style)
;;; etaf-ui-style.el ends here

291
etaf-ui-table.el Normal file
View File

@ -0,0 +1,291 @@
;;; etaf-ui-table.el --- Presentational Table Component for ETAF UI -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Table renders ordinary rows and columns. It owns no loading, database,
;; pagination, or selection state; callers provide optional controlled row
;; interaction. DataGrid adapts ETAF Data onto this Component.
;;; Code:
(require 'cl-lib)
(require 'etaf-ui-basic)
(defun etaf-ui--column-value (column key)
"Return KEY from COLUMN, accepting a plist or alist descriptor."
(if (and (listp column) (keywordp (car column)))
(plist-get column key)
(alist-get key column)))
(defun etaf-ui--table-validate-columns (columns)
"Return COLUMNS after checking stable identities and optional cell functions."
(unless (proper-list-p columns)
(error "ETAF Table :columns must be a proper list"))
(let ((seen (make-hash-table :test #'equal)))
(cl-loop for column in columns for index from 1 do
(let ((key (etaf-ui--column-value column :key))
(cell (etaf-ui--column-value column :cell))
(width (etaf-ui--column-value column :width)))
(unless (and key (or (symbolp key) (stringp key) (integerp key)))
(error "ETAF Table column %d :key must be a non-nil symbol, integer, or string; got %S"
index key))
(when (gethash key seen)
(error "ETAF Table column %d duplicates :key %S; use a unique key and :cell to repeat a field"
index key))
(puthash key t seen)
(when (and cell (not (functionp cell)))
(error "ETAF Table column %d (%S) :cell must be a function of one row; got %S"
index key cell))
(when (and (consp width) (eq (car width) 'fr)
(not (and (proper-list-p width) (= (length width) 2)
(numberp (cadr width)) (> (cadr width) 0))))
(error "ETAF Table column %d (%S) :width must use (fr POSITIVE-WEIGHT); got %S"
index key width)))))
columns)
(defun etaf-ui--table-cell-value (row key)
"Return KEY from ROW, accepting a plist, alist, or hash table."
(cond
((hash-table-p row) (gethash key row))
((and (proper-list-p row)
(zerop (% (length row) 2))
(keywordp (car row)))
(plist-get row key))
((listp row) (alist-get key row nil nil #'equal))
(t nil)))
(defun etaf-ui--table-fit-text (value column)
"Return VALUE fitted to COLUMN's declared character capacity."
(let* ((value (format "%s" (or value "")))
(width (etaf-ui--column-value column :width)))
(if (and (integerp width) (> width 0)
(> (string-width value) width))
(truncate-string-to-width value width 0 nil "")
value)))
(defun etaf-ui--table-fixed-text-columns-p (columns)
"Return non-nil when COLUMNS can share the compact fixed-text path."
(and columns
(cl-every
(lambda (column)
(let ((width (etaf-ui--column-value column :width)))
(and (not (etaf-ui--column-value column :cell))
(integerp width) (> width 0))))
columns)))
(defun etaf-ui--table-grid (columns cells)
"Allocate CELLS with shared COLUMNS tracks and one character between them."
(etaf-node
'grid
(list :width 'stretch
:grid-template-columns
(mapcar (lambda (column)
(or (etaf-ui--column-value column :width) 'max-content))
columns)
:column-gap 1)
cells))
(defun etaf-ui--table-header-cell (column)
"Return one header for COLUMN inside its allocated Grid track."
(etaf-node
'box
(list :class "etaf-table-header-cell"
:width 'stretch :overflow 'hidden
:wrap-mode 'none)
(list
(etaf-node
'text nil
(list
(etaf-ui--table-fit-text
(or (etaf-ui--column-value column :label)
(etaf-ui--column-value column :key))
column))))))
(defun etaf-ui--table-fixed-header-text (columns)
"Return one fixed-width header string for COLUMNS, or nil."
(when (etaf-ui--table-fixed-text-columns-p columns)
(mapconcat
(lambda (column)
(let* ((width (etaf-ui--column-value column :width))
(value
(etaf-ui--table-fit-text
(or (etaf-ui--column-value column :label)
(etaf-ui--column-value column :key))
column)))
(concat value
(make-string (max 0 (- width (string-width value))) ?\s))))
columns " ")))
(defun etaf-ui--table-header (columns)
"Return a Table header row for COLUMNS."
(etaf-ui--table-validate-columns columns)
(let ((theme (etaf-ui--style-tokens :ui-table-border))
(fixed-text (etaf-ui--table-fixed-header-text columns)))
(etaf-node
'row
(append
(unless fixed-text '(:padding (0 0)))
(list :class "etaf-table-header"
:border-bottom-width 1 :border-bottom-style 'solid
:border-bottom-color (plist-get theme :ui-table-border)))
(if fixed-text
(list (etaf-node 'text nil (list fixed-text)))
(list (etaf-ui--table-grid
columns (mapcar #'etaf-ui--table-header-cell columns)))))))
(defun etaf-ui--table-cell (row column)
"Return COLUMN's ordinary View cell for ROW inside its allocated track.
Custom cell functions run at this consuming position; Component output owns
its usual Context, styles, state, and lifecycle."
(etaf-node
'box
(list :key (etaf-ui--column-value column :key)
:class "etaf-table-cell"
:width 'stretch
:overflow 'hidden
:wrap-mode 'none)
(list
(if-let* ((cell (etaf-ui--column-value column :cell)))
(etaf-view (expr (funcall cell row)))
(etaf-node
'text nil
(list
(etaf-ui--table-fit-text
(etaf-ui--table-cell-value
row (etaf-ui--column-value column :key))
column)))))))
(defun etaf-ui--table-cells (row columns)
"Return cell Components for ROW using COLUMNS."
(cl-loop for column in columns
collect
(etaf-ui--table-cell row column)))
(defun etaf-ui--table-fixed-row-text (row columns)
"Return one fixed-width ROW string for COLUMNS, or nil when not applicable."
(when (etaf-ui--table-fixed-text-columns-p columns)
(mapconcat
(lambda (column)
(let* ((width (etaf-ui--column-value column :width))
(value
(etaf-ui--table-fit-text
(etaf-ui--table-cell-value
row (etaf-ui--column-value column :key))
column)))
(concat value
(make-string (max 0 (- width (string-width value))) ?\s))))
columns " ")))
(defun etaf-ui--table-row-children (row columns)
"Return the smallest presentation-equivalent child list for ROW.
COLUMNS with fixed positive character widths use one padded Text Host.
Other cells always share a Grid parent, preserving their identity when column
widths change between fixed and fractional tracks."
(if-let* ((text (etaf-ui--table-fixed-row-text row columns)))
(list (etaf-node 'text nil (list text)))
(list (etaf-ui--table-grid columns (etaf-ui--table-cells row columns)))))
(defun etaf-ui--table-entries (rows row-key)
"Return `(KEY . ROW)' entries for ROWS using ROW-KEY.
ETAF validates keys and uniqueness."
(unless (functionp row-key)
(error "ETAF Table requires a function-valued :row-key"))
(mapcar (lambda (row) (cons (funcall row-key row) row)) rows))
(defun etaf-ui--table-row-node
(row identity columns row-ref on-row-press row-selected-p)
"Return one canonical row Host for ROW and stable IDENTITY.
The retained Table row shares its cell construction with DataGrid's keyed
hot path. COLUMNS define the visible cells;
ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P define optional interaction.
Without ROW-REF the Host receives ETAF's usual instance-local reference."
(let* ((callback on-row-press)
(row-value row)
(interactive-p (not (null callback)))
(selected-p
(progn
(when (and row-selected-p (not (functionp row-selected-p)))
(error "ETAF Table :row-selected-p must be a function"))
(and row-selected-p (funcall row-selected-p row))))
(host-ref nil)
(theme (etaf-ui--style-tokens
:ui-table-border :ui-table-selected-fg
:ui-table-selected-bg)))
(when interactive-p
(unless (functionp on-row-press)
(error "ETAF Table :on-row-press must be a function"))
(when (and row-ref (not (functionp row-ref)))
(error "ETAF Table :row-ref must be a function"))
(when row-ref
(setq host-ref (funcall row-ref row))
(unless host-ref
(error "ETAF Table :row-ref must return a non-nil stable ref"))))
(etaf-node
'row
(append
(unless (etaf-ui--table-fixed-text-columns-p columns) '(:padding (0 0)))
(list :key identity
:class (concat "etaf-table-row" (if selected-p " selected" ""))
:ref host-ref :role (when interactive-p 'button)
:tab-index (when interactive-p 0)
:color
(when selected-p (plist-get theme :ui-table-selected-fg))
:background-color
(when selected-p (plist-get theme :ui-table-selected-bg))
:border-bottom-width 1 :border-bottom-style 'solid
:border-bottom-color (plist-get theme :ui-table-border)
:on-press
(when interactive-p
(lambda () (funcall callback row-value)))))
(etaf-ui--table-row-children row columns))))
(etaf-ui--define-component etaf-ui--table-header (&key columns)
"Render one retained Table header."
:render (etaf-ui--table-header columns)
:styles
(styles
(".etaf-table-header" :font-weight bold :padding (0 1))
(".etaf-table-header-cell" :font-weight bold)))
(etaf-ui--define-component etaf-ui--table-row
(&key row identity columns row-ref on-row-press row-selected-p)
"Render one retained Table ROW with stable IDENTITY."
:render
(etaf-ui--table-row-node
row identity columns row-ref on-row-press row-selected-p)
:styles
(styles
(".etaf-table-row" :padding (0 1))))
(etaf-ui--define-component etaf-table
(&key columns rows row-key row-ref on-row-press row-selected-p)
"Render ordinary ROWS as a presentational Table.
COLUMNS contain a unique non-nil `:key', optional `:label', `:width',
and `:cell' function accepting one row and returning ordinary View content.
Integer widths are character capacities; `(fr N)' shares the remaining width
by positive weight N.
Without `:cell', the key reads a text field from the row. Cell state belongs
in a returned Component, whose Context comes from the consuming Table.
ROW-KEY supplies stable identity. ROW-REF is only needed for caller-owned
addresses; interactive rows otherwise receive instance-local references.
Interaction and selection are controlled optional inputs; Table never owns
application or Data Controller state."
:view
(column
:class "etaf-table"
:color (plist-get (etaf-ui--style-tokens :ui-fg) :ui-fg)
(etaf-ui--table-header :columns columns)
(column :class "etaf-table-body"
(etaf-ui--table-row
:for (entry (etaf-ui--table-entries rows row-key))
:key (car entry)
:row (cdr entry) :identity (car entry) :columns columns
:row-ref row-ref :on-row-press on-row-press
:row-selected-p row-selected-p))))
(provide 'etaf-ui-table)
;;; etaf-ui-table.el ends here

View File

@ -8,967 +8,14 @@
;;; Commentary:
;; The official ETAF catalog is one ordinary Component library. It does not
;; expose a parallel Control/Widget taxonomy: a DataGrid is a compound
;; Component built from the same View, props, slots, events, and Data APIs.
;; Public facade for Components defined with ETAF. The catalog exposes no
;; second Widget runtime, Theme system, data store, or layout engine.
;;; Code:
(require 'cl-lib)
(require 'etaf)
(declare-function etaf-data-status "etaf-data" (controller))
(declare-function etaf-data-items "etaf-data" (controller))
(declare-function etaf-data-page "etaf-data" (controller))
(declare-function etaf-data-page-size "etaf-data" (controller))
(declare-function etaf-data-total "etaf-data" (controller))
(declare-function etaf-data-previous-page "etaf-data" (controller))
(declare-function etaf-data-next-page "etaf-data" (controller))
(declare-function etaf-data-selected-ref "etaf-data" (controller identity))
(declare-function etaf-theme-defaults "etaf-context" (&optional default))
(declare-function text "etaf-view" (&rest arguments))
(declare-function box "etaf-view" (&rest arguments))
(declare-function expr "etaf-view" (&rest arguments))
(declare-function slot "etaf-view" (&rest arguments))
(defconst etaf-ui--default-theme-palette
'(:ui-fg "#252A2E"
:ui-bg "#FFFDF8"
:ui-border "#687386"
:ui-muted-fg "#526174"
:ui-danger-fg "#FF6B6B"
:ui-success-fg "#2F6B43"
:ui-disabled-fg "#687386"
:ui-disabled-bg "#E5E7EB"
:ui-disabled-border "#9CA3AF"
:ui-button-primary-fg "#FFFFFF"
:ui-button-primary-bg "#2F6B43"
:ui-button-primary-border "#2F6B43"
:ui-button-secondary-fg "#142235"
:ui-button-secondary-bg "#D9EEEA"
:ui-button-secondary-border "#2E8B83"
:ui-button-ghost-fg "#142235"
:ui-button-ghost-bg "#FFFDF8"
:ui-button-ghost-border "#C8C1B6"
:ui-checkbox-enabled-fg "#252A2E"
:ui-checkbox-enabled-bg "#DCEBDD"
:ui-checkbox-enabled-border "#6D8A73"
:ui-checkbox-disabled-fg "#6B7280"
:ui-checkbox-disabled-bg "#EEEAE2"
:ui-checkbox-disabled-border "#9CA3AF"
:ui-grid-border "#687386"
:ui-grid-selected-fg "#2F6B43"
:ui-grid-selected-bg "#DCEBDD"
:ui-grid-error-fg "#FF6B6B"
:ui-pagination-muted-fg "#526174"
:ui-panel-fg "#252A2E"
:ui-panel-bg "#FFFDF8"
:ui-panel-border "#687386")
"Default semantic UI palette, centralized outside Component definitions.
Applications normally override these tokens through ETAF Theme. Keeping the
fallback palette here gives the catalog a useful standalone appearance while
ensuring every Component reads one shared semantic vocabulary.")
(defconst etaf-ui--legacy-theme-aliases
'((:ui-fg :color)
(:ui-bg :bgcolor)
(:ui-border :border)
(:ui-button-primary-fg :ui-button-color)
(:ui-button-primary-bg :ui-button-bgcolor)
(:ui-button-primary-border :ui-button-border)
(:ui-button-secondary-fg :ui-button-secondary-color)
(:ui-button-secondary-bg :ui-button-secondary-bgcolor)
(:ui-button-secondary-border :ui-button-secondary-border)
(:ui-button-ghost-fg :ui-button-ghost-color)
(:ui-button-ghost-bg :ui-button-ghost-bgcolor)
(:ui-button-ghost-border :ui-button-ghost-border)
(:ui-disabled-fg :ui-button-disabled-color)
(:ui-disabled-bg :ui-button-disabled-bgcolor)
(:ui-disabled-border :ui-button-disabled-border))
"Compatibility aliases for the first ETAF UI Theme token spelling.")
;;;###autoload
(defun etaf-ui-theme-values (&rest requested)
"Return merged semantic UI Theme values for REQUESTED tokens.
Inherited application tokens win, legacy aliases remain readable, and the
central catalog palette fills only omitted values. This is the boundary
between generic ETAF Theme Context and etaf-ui's product-independent visual
semantics; individual Components do not own separate color systems. When
REQUESTED is nil, return the complete catalog token map."
(let* ((inherited (etaf-theme-defaults))
(defaults etaf-ui--default-theme-palette)
;; Callers that request a subset only need that semantic subset.
;; Keeping the full inherited plist is useful for the no-argument
;; catalog query, but copying it for every Button/Panel/DataGrid
;; render needlessly scales Theme work with application token count.
(result (unless requested (copy-sequence inherited)))
(keys (or requested
(cl-loop for (key _spec) on defaults by #'cddr
collect key))))
(dolist (key keys)
(let ((found
(cond
((plist-member inherited key)
(cons t (plist-get inherited key)))
(t
(cl-loop for alias in etaf-ui--legacy-theme-aliases
when (and (eq (car alias) key)
(plist-member inherited (cadr alias)))
return
(cons t (plist-get inherited (cadr alias))))))))
(setq result
(plist-put result key
(if found (cdr found) (plist-get defaults key)))))
)
result))
(defun etaf-ui-theme-tokens (&rest requested)
"Return deferred semantic Theme tokens for REQUESTED UI keys.
Catalog defaults and legacy aliases are encoded as nested token fallbacks, so
Host lowering can update paint properties without making the current
Component render depend on the Theme source."
(let ((keys (or requested
(cl-loop for (key _spec) on etaf-ui--default-theme-palette
by #'cddr collect key)))
result)
(dolist (key keys result)
(let* ((default (plist-get etaf-ui--default-theme-palette key))
(alias (cadr (assq key etaf-ui--legacy-theme-aliases)))
(fallback (if alias (etaf-theme-token alias default) default)))
(setq result
(plist-put result key (etaf-theme-token key fallback)))))))
(defun etaf-ui--theme-border (value)
"Return Ebox border VALUE, preserving complete caller-owned specs.
Semantic Theme border tokens conventionally contain a color string. The
catalog turns a hex color into a one-pixel solid border; an existing canonical
border value remains unchanged."
(cond
((etaf-theme-token-p value)
(etaf-theme-token (nth 1 value) (nth 2 value)
#'etaf-ui--theme-border))
((and (stringp value)
(string-match-p "\\`#[[:xdigit:]]+\\'" value))
(list 1 'solid value))
(t value)))
(defun etaf-ui--class-value (base state custom)
"Return BASE and STATE classes with optional CUSTOM classes."
(let ((custom (cond
((null custom) nil)
((listp custom) custom)
(t (list custom)))))
(mapconcat (lambda (class) (format "%s" class))
(cl-remove-if (lambda (class)
(or (null class) (equal class "")))
(append (list base state) custom))
" ")))
(defun etaf-ui--reactive-value (value)
"Return VALUE, reading it when it is an ETAF reactive source."
(if (or (etaf-ref-p value) (etaf-computed-p value))
(etaf-value value)
value))
(defun etaf-ui--button-variant-values (variant disabled)
"Return themed presentation defaults for Button VARIANT and DISABLED."
(let* ((fg (cond (disabled :ui-disabled-fg)
((eq variant 'secondary) :ui-button-secondary-fg)
((eq variant 'ghost) :ui-button-ghost-fg)
(t :ui-button-primary-fg)))
(bg (cond (disabled :ui-disabled-bg)
((eq variant 'secondary) :ui-button-secondary-bg)
((eq variant 'ghost) :ui-button-ghost-bg)
(t :ui-button-primary-bg)))
(border (cond (disabled :ui-disabled-border)
((eq variant 'secondary) :ui-button-secondary-border)
((eq variant 'ghost) :ui-button-ghost-border)
(t :ui-button-primary-border)))
(theme (etaf-ui-theme-tokens fg bg border)))
(list :color (plist-get theme fg)
:bgcolor (plist-get theme bg)
:border (etaf-ui--theme-border (plist-get theme border))
:font-weight (if (or disabled (eq variant 'ghost)) 'normal 'bold))))
(defun etaf-ui--button-view
(label on-press disabled ref class color bgcolor border padding font-weight
tab-index aria-label use)
"Return a Button Host showing LABEL.
ON-PRESS and USE provide callbacks and Behaviors. DISABLED controls whether
the Host is interactive. REF, CLASS, COLOR, BGCOLOR, BORDER, PADDING,
FONT-WEIGHT,
TAB-INDEX, and ARIA-LABEL provide Host identity and presentation."
(let ((class-value (etaf-ui--class-value
"etaf-button"
(if disabled "disabled" "enabled")
class))
(tab-value (unless disabled (or tab-index 0)))
(label-value (or aria-label label)))
(if on-press
(etaf-view
(box :class class-value :role 'button :ref ref :disabled disabled
:tab-index tab-value :aria-label label-value
:color color :bgcolor bgcolor :border border
:padding padding :font-weight font-weight
:use (unless disabled use) :on-press on-press
(text (expr :value label))))
(etaf-view
(box :class class-value :role 'button :ref ref :disabled disabled
:tab-index tab-value :aria-label label-value
:color color :bgcolor bgcolor :border border
:padding padding :font-weight font-weight
:use (unless disabled use)
(text (expr :value label)))))))
(defun etaf-ui--checkbox-variant-values (theme disabled)
"Return semantic Theme values from THEME for DISABLED Checkbox state."
(let ((prefix (if disabled "disabled" "enabled")))
(list :color (plist-get theme
(intern (format ":ui-checkbox-%s-fg" prefix)))
:bgcolor (plist-get theme
(intern (format ":ui-checkbox-%s-bg" prefix)))
:border
(etaf-ui--theme-border
(plist-get theme
(intern (format ":ui-checkbox-%s-border" prefix)))))))
(defun etaf-ui--column-value (column key)
"Return KEY from COLUMN, accepting a plist or alist descriptor."
(if (and (listp column) (keywordp (car column)))
(plist-get column key)
(alist-get key column)))
(defun etaf-ui--grid-cell-value (row key)
"Return KEY from data ROW, accepting a plist, alist, or hash table."
(cond
((hash-table-p row) (gethash key row))
((and (proper-list-p row)
(zerop (% (length row) 2))
(keywordp (car row)))
(plist-get row key))
((listp row) (alist-get key row))
(t nil)))
(defun etaf-ui--grid-fit-text (value column)
"Return VALUE fitted to COLUMN's declared character capacity."
(let* ((value (format "%s" (or value "")))
(width (etaf-ui--column-value column :width)))
(if (and (integerp width) (> width 0)
(> (string-width value) width))
(truncate-string-to-width value width 0 nil "")
value)))
(defun etaf-ui--grid-display-value (row column)
"Return one single-line display value for ROW and COLUMN.
DataGrid columns are tabular tracks, not prose paragraphs. Keep each cell on
one visual line and use an ellipsis when a fixed character-width descriptor is
too small; the original ROW remains intact for selection and callbacks."
(etaf-ui--grid-fit-text
(etaf-ui--grid-cell-value row (etaf-ui--column-value column :key))
column))
(defun etaf-ui--grid-track-width (column gap-p)
"Return COLUMN width with one native-character gap when GAP-P is non-nil."
(let ((width (etaf-ui--column-value column :width)))
(if (and gap-p (integerp width) (> width 0))
(1+ width)
width)))
(defun etaf-ui--grid-header-cell (column gap-p)
"Return one header View for COLUMN, adding air when GAP-P is non-nil."
(etaf--view-call
'box
(list :class "etaf-data-grid-header-cell"
:width (etaf-ui--grid-track-width column gap-p))
(list
(etaf--view-call
'text nil
(list
(etaf-ui--grid-fit-text
(or (etaf-ui--column-value column :label)
(etaf-ui--column-value column :key))
column))))))
(defun etaf-ui--grid-header (columns theme)
"Return a View header row for COLUMNS using semantic THEME colors."
(etaf-view
(row :class "etaf-data-grid-header"
:border (etaf-ui--theme-border
(plist-get theme :ui-grid-border))
(expr :value
(cl-loop for column in columns
for tail on columns
collect (etaf-ui--grid-header-cell
column (cdr tail)))))))
(defun etaf-ui--grid-cell (row column gap-p host-ref)
"Return one data cell View for ROW and COLUMN using HOST-REF and GAP-P."
(etaf--view-call
'box
(list :ref host-ref :width (etaf-ui--grid-track-width column gap-p))
(list
(etaf--view-call
'text nil (list (etaf-ui--grid-display-value row column))))))
(defun etaf-ui--grid-cells (row columns cell-refs)
"Return data cell Views for ROW and COLUMNS using stable CELL-REFS."
(cl-loop for column in columns
for tail on columns
for index from 0
collect
(etaf-ui--grid-cell
row column (cdr tail)
(or (gethash index cell-refs)
(puthash index (gensym "etaf-data-grid-cell-")
cell-refs)))))
(defun etaf-ui--grid-selected-p
(row key selected-key row-selected-p selected-ref)
"Return whether ROW with KEY is selected.
ROW-SELECTED-P and SELECTED-KEY preserve custom controlled selection;
SELECTED-REF supplies the controller-backed keyed default."
(or (and row-selected-p (funcall row-selected-p row))
(and selected-key (equal key selected-key))
(and selected-ref (etaf-value selected-ref))))
(defun etaf-ui--grid-row-action (cache key row callback)
"Return CACHE's stable row action for KEY, refreshing ROW and CALLBACK."
(let ((entry (gethash key cache)))
(unless entry
(setq entry (vector row callback nil))
(aset entry 2
(lambda ()
(let ((current (aref entry 1)))
(when current
(funcall current (aref entry 0))))))
(puthash key entry cache))
(aset entry 0 row)
(aset entry 1 callback)
(aref entry 2)))
(defun etaf-ui--grid-row
(row key columns row-ref on-row-press selected-key row-selected-p
selected-ref row-actions theme internal-row-ref cell-refs)
"Return a View row for ROW and COLUMNS using THEME and the DataGrid contract.
KEY is ROW's stable identity; ROW-REF returns the interactive reference;
ON-ROW-PRESS, SELECTED-KEY, ROW-SELECTED-P, and SELECTED-REF control state.
ROW-ACTIONS owns stable keyed callbacks across body reevaluation."
(let* ((interactive-p (not (null on-row-press)))
(selected-p
(lambda ()
(etaf-ui--grid-selected-p
row key selected-key row-selected-p selected-ref)))
(host-ref internal-row-ref))
(unless key
(error "ETAF DataGrid row-key must return a non-nil stable scalar"))
(when interactive-p
(unless (functionp row-ref)
(error "ETAF DataGrid requires :row-ref for interactive rows"))
(setq host-ref (funcall row-ref row))
(unless host-ref
(error "ETAF DataGrid :row-ref must return a non-nil stable ref")))
(etaf--view-call
'row
(list :key key
:class
(etaf--expr-create
:thunk (lambda ()
(concat "etaf-data-grid-row"
(if (funcall selected-p) " selected" ""))))
:ref host-ref
:role (when interactive-p 'button)
:tab-index (when interactive-p 0)
:border-bottom-width 1
:border-bottom-style 'solid
:border-bottom-color (plist-get theme :ui-grid-border)
:on-press (when interactive-p
(etaf-ui--grid-row-action
row-actions key row on-row-press))
:bgcolor
(etaf--expr-create
:thunk (lambda ()
(when (funcall selected-p)
(plist-get theme :ui-grid-selected-bg)))))
(etaf-ui--grid-cells row columns cell-refs))))
(defun etaf-ui--grid-row-state (states key)
"Return STATES' retained internal row and cell refs for KEY."
(or (gethash key states)
(let ((state (cons (gensym "etaf-data-grid-row-")
(make-hash-table :test #'eql))))
(puthash key state states)
state)))
(defun etaf-ui--grid-keyed-items
(items row-key row-actions row-states)
"Return validated `(KEY . ITEM)' entries and prune retained row caches."
(let ((seen (make-hash-table :test #'equal)) entries)
(dolist (item items)
(let ((key (funcall row-key item)))
(unless key
(error "ETAF DataGrid row-key must return a non-nil stable scalar"))
(when (gethash key seen)
(error "ETAF DataGrid row-key must be unique: %S" key))
(puthash key t seen)
(push (cons key item) entries)))
(maphash
(lambda (key _entry)
(unless (gethash key seen)
(remhash key row-actions)
(remhash key row-states)))
row-actions)
(nreverse entries)))
(defun etaf-ui--grid-rows
(controller items columns row-key row-ref on-row-press selected-key
row-selected-p row-actions row-states &optional theme)
"Return keyed Host rows and prune caches outside current ITEMS.
CONTROLLER owns keyed default selection refs. COLUMNS and ROW-KEY describe
cells and identity. ROW-REF, ON-ROW-PRESS, SELECTED-KEY, and ROW-SELECTED-P
provide interaction state. ROW-ACTIONS and ROW-STATES retain callback and
internal Host identities. THEME optionally supplies resolved colors."
(let* ((theme (or theme
;; Resolve Theme once in the retained DataGrid owner
;; of doing it independently in every row Component.
(etaf-ui-theme-tokens :ui-grid-border
:ui-grid-selected-fg
:ui-grid-selected-bg)))
(entries
(etaf-ui--grid-keyed-items
items row-key row-actions row-states)))
(mapcar
(lambda (entry)
(let* ((key (car entry))
(item (cdr entry))
(state (etaf-ui--grid-row-state row-states key)))
(etaf-ui--grid-row
item key columns row-ref on-row-press selected-key row-selected-p
(unless (or row-selected-p selected-key)
(etaf-data-selected-ref controller key))
row-actions theme (car state) (cdr state))))
entries)))
(defun etaf-ui--grid-body-items
(controller status items columns row-key row-ref on-row-press selected-key
row-selected-p row-actions row-states theme loading-label
error-label empty-label)
"Return CONTROLLER DataGrid body items for STATUS and ITEMS.
COLUMNS and ROW-KEY describe rows; ROW-REF and ON-ROW-PRESS add interaction.
SELECTED-KEY, ROW-SELECTED-P, and ROW-ACTIONS preserve controlled behavior.
THEME supplies colors, while LOADING-LABEL, ERROR-LABEL, and EMPTY-LABEL
customize state messages. The parent Component directly owns the result."
(unless (functionp row-key)
(error "ETAF DataGrid requires a function-valued :row-key"))
(when (and on-row-press (not (functionp on-row-press)))
(error "ETAF DataGrid :on-row-press must be a function"))
(when (and on-row-press (not (functionp row-ref)))
(error "ETAF DataGrid requires :row-ref for interactive rows"))
(when (and row-selected-p (not (functionp row-selected-p)))
(error "ETAF DataGrid :row-selected-p must be a function"))
(cond
((eq status 'loading)
(list (etaf--view-call 'text nil
(list (or loading-label "Loading...")))))
((eq status 'error)
(list
(etaf--view-call
'text
(list :class "etaf-data-grid-error"
:color (plist-get (etaf-ui-theme-tokens :ui-grid-error-fg)
:ui-grid-error-fg))
(list (or error-label "Unable to load data.")))))
((null items)
(list (etaf--view-call 'text nil
(list (or empty-label "No data.")))))
(t
(etaf-ui--grid-rows
controller items columns row-key row-ref on-row-press selected-key
row-selected-p row-actions row-states theme))))
(defun etaf-ui--button-setup ()
"Create the retained renderer for one Button instance."
(let* ((current-callback nil)
(current-press-p nil)
(press nil))
(setq press
(lambda ()
(when current-press-p
(when current-callback
(funcall current-callback)))))
(lambda ()
(let* ((label (etaf-current-prop :label))
(callback (etaf-current-prop :on-press))
(disabled (etaf-current-prop :disabled))
(use (etaf-current-prop :use))
(press-p (and (not disabled) (or callback use))))
(setq current-callback callback
current-press-p press-p)
(let* ((variant (and (not disabled) (etaf-current-prop :variant)))
(variant-values
(etaf-ui--button-variant-values variant disabled)))
(etaf-ui--button-view
label (and press-p press) disabled (etaf-current-prop :ref)
(etaf-current-prop :class)
(or (etaf-current-prop :color)
(plist-get variant-values :color))
(or (etaf-current-prop :bgcolor)
(plist-get variant-values :bgcolor))
(or (etaf-current-prop :border)
(plist-get variant-values :border))
(etaf-current-prop :padding)
(or (etaf-current-prop :font-weight)
(plist-get variant-values :font-weight))
(etaf-current-prop :tab-index)
(etaf-current-prop :aria-label)
use))))))
;;;###autoload
(etaf-define-component etaf-button
(&key label on-press disabled ref class color bgcolor border padding font-weight
tab-index aria-label use variant)
"Render a standard pressable button with LABEL and ON-PRESS.
DISABLED removes the callback and the default focus tab index. Product
appearance is controlled by VARIANT and the shared interactive surface
contract; callers can still override presentation with the ordinary props."
:styles
(styles
("&" :width max-content)
;; State classes carry semantic state only. Resolved presentation props
;; above remain authoritative, so a themed disabled Button cannot inherit
;; the catalog's light default surface.
("&.disabled" :padding (0 1) :font-weight normal)
("&.enabled" :padding (0 1) :font-weight bold))
:setup
(etaf-ui--button-setup))
(etaf-define-component etaf-number-input
(&key value label on-change ref disabled min max aria-label)
"Render a controlled minibuffer-backed numeric input.
VALUE is displayed as a Button. Activating it reads a number through
Emacs's native minibuffer, validates optional MIN and MAX bounds, and calls
ON-CHANGE with the accepted integer. The Component owns prompting and
validation; the caller owns the value and subsequent state write."
:setup
(let ((callback (etaf-current-prop :on-change)))
(lambda ()
(let* ((value (etaf-current-prop :value))
(label (or (etaf-current-prop :label) "Value"))
(min-value (etaf-current-prop :min))
(max-value (etaf-current-prop :max))
(disabled (etaf-current-prop :disabled))
(ref (etaf-current-prop :ref))
(aria-label (etaf-current-prop :aria-label)))
(etaf-view
(button
:label (format "%s %s ✎" label (or value ""))
:ref ref :disabled disabled
:aria-label (or aria-label label)
:variant 'ghost
:on-press
(unless disabled
(lambda ()
(let ((next (read-number
(format "%s: " label) (or value 0))))
(unless (and (integerp next)
(or (null min-value) (>= next min-value))
(or (null max-value) (<= next max-value)))
(user-error "%s must be an integer from %s to %s"
label (or min-value "") (or max-value "")))
(when callback (funcall callback next)))))))))))
(defun etaf-ui--checkbox-view
(checked label on-change ref disabled class color bgcolor border padding
font-weight tab-index aria-label)
"Return LABEL checkbox View with captured CHECKED and ON-PRESS.
REF, DISABLED, CLASS, COLOR, BGCOLOR, BORDER, PADDING, FACE, TAB-INDEX, and
ARIA-LABEL provide its semantic and presentation properties."
(etaf-view
(row
:class (etaf-ui--class-value
"etaf-checkbox" (if disabled "disabled" "enabled") class)
:role 'checkbox :ref ref :disabled disabled
:aria-label (or aria-label label)
:tab-index (unless disabled (or tab-index 0))
:color color :bgcolor bgcolor :border border :padding padding :font-weight font-weight
:on-press on-change
(box :class "etaf-checkbox-mark"
(text (expr :value
(if (etaf-ui--reactive-value checked) "" ""))))
(text (expr :value (if label (concat " " label) ""))))))
;;;###autoload
(etaf-define-component etaf-checkbox
(&key checked label on-change ref disabled class color bgcolor border padding
font-weight tab-index aria-label)
"Render a controlled checkbox with CHECKED, LABEL, and ON-CHANGE.
CHECKED may be a boolean or an ETAF reactive source. ON-CHANGE receives the
next boolean value. State ownership stays with the caller, so the Component
works with local refs or Data-backed forms."
:styles
(styles
("&" :width max-content)
;; Color, background, and border are resolved through the shared semantic
;; Theme map in :setup; styles keep only geometry defaults.
("&.disabled" :padding (0 1))
("&.enabled" :padding (0 1))
(".etaf-checkbox-mark" :font-weight bold :width 1))
:setup
(let* ((current-checked nil)
(current-callback nil)
(press
(lambda ()
(when current-callback
(funcall current-callback
(not (etaf-ui--reactive-value current-checked)))))))
(lambda ()
(let* ((theme (etaf-ui-theme-tokens :ui-fg :ui-bg
:ui-checkbox-enabled-fg
:ui-checkbox-enabled-bg
:ui-checkbox-enabled-border
:ui-checkbox-disabled-fg
:ui-checkbox-disabled-bg
:ui-checkbox-disabled-border))
(variant-values
(etaf-ui--checkbox-variant-values
theme (etaf-current-prop :disabled))))
(setq current-checked (etaf-current-prop :checked)
current-callback
(when (and (not (etaf-current-prop :disabled))
(etaf-current-prop :on-change))
(etaf-current-prop :on-change)))
(etaf-ui--checkbox-view
current-checked (etaf-current-prop :label)
(and current-callback press)
(etaf-current-prop :ref) (etaf-current-prop :disabled)
(etaf-current-prop :class)
(or (etaf-current-prop :color)
(plist-get variant-values :color))
(or (etaf-current-prop :bgcolor)
(plist-get variant-values :bgcolor))
(or (etaf-current-prop :border)
(plist-get variant-values :border))
(etaf-current-prop :padding) (etaf-current-prop :font-weight)
(etaf-current-prop :tab-index) (etaf-current-prop :aria-label))))))
;;;###autoload
(etaf-define-component etaf-label
(&key text font-weight class color bgcolor border padding ref width)
"Render TEXT as a semantic label with presentation properties.
TEXT may be an ordinary value or an ETAF reactive source."
:view
(expr
:value
(if (or border padding width)
(etaf-view
(box :class class :font-weight font-weight :color color
:bgcolor bgcolor :border border :padding padding
:ref ref :width width
(text (expr :value (etaf-ui--reactive-value text)))))
(etaf-view
(text :class class :font-weight font-weight :color color
:bgcolor bgcolor :ref ref
(expr :value (etaf-ui--reactive-value text)))))))
(defun etaf-ui--panel-view (title class color bgcolor border padding ref)
"Render a themed Panel View.
Arguments are TITLE, CLASS, COLOR, BGCOLOR, BORDER, PADDING, and REF."
(let ((theme (etaf-ui-theme-tokens :ui-panel-fg :ui-panel-bg
:ui-panel-border)))
(etaf-view
(column
:class (etaf-ui--class-value "etaf-panel" nil class)
:color (or color (plist-get theme :ui-panel-fg))
:bgcolor (or bgcolor (plist-get theme :ui-panel-bg))
:border (or border
(etaf-ui--theme-border
(plist-get theme :ui-panel-border)))
:padding padding :ref ref
(expr
:value
(when title
(etaf-view (text :class "etaf-panel-title"
(expr :value title)))))
(slot :name 'header)
(slot)))))
;;;###autoload
(etaf-define-component etaf-panel
(&key title class color bgcolor border padding ref)
"Render a titled panel with header and default slot projections."
:styles
(styles
("&" :padding (1 2))
(".etaf-panel-title" :font-weight bold))
:view
(expr :value
(etaf-ui--panel-view title class color bgcolor border padding ref)))
;;;###autoload
(etaf-define-component etaf-data-grid
(&key controller columns row-key on-row-press
row-ref selected-key row-selected-p loading-label error-label
empty-label)
"Render rows from reactive DATA CONTROLLER and COLUMNS.
COLUMNS is a list of descriptors such as `(:key :name :label NAME)'. ROW-KEY
receives each row and must return a stable scalar identity. Data owns loading,
errors, pagination, mutation, and selection; this Component only projects
those values into ordinary Hosts. Interactive rows require ROW-REF to return
a stable Host reference."
:styles
(styles
(".etaf-data-grid-header" :font-weight bold :padding (0 1))
(".etaf-data-grid-header-cell" :font-weight bold)
(".etaf-data-grid-row" :padding (0 1))
;; Selection color and error color are dynamic semantic props below, so
;; this Component style scope contains geometry only.
)
:setup
(let ((row-actions (make-hash-table :test #'equal))
(row-states (make-hash-table :test #'equal))
current-controller current-columns current-row-key current-row-ref
current-on-row-press current-selected-key current-row-selected-p
current-loading-label current-error-label current-empty-label
body-config body-expr body-thunk body-range-snapshot body-range-item)
(setq
body-thunk
(lambda ()
(let* ((status
(etaf-value (etaf-data-status current-controller)))
(items
(etaf-value (etaf-data-items current-controller)))
(theme
(etaf-ui-theme-tokens :ui-grid-border
:ui-grid-selected-bg)))
(etaf-ui--grid-body-items
current-controller status items current-columns current-row-key
current-row-ref current-on-row-press current-selected-key
current-row-selected-p row-actions row-states theme
current-loading-label current-error-label current-empty-label))))
(setq
body-range-snapshot
(lambda ()
(let ((status (etaf-value (etaf-data-status current-controller)))
(items (etaf-value (etaf-data-items current-controller))))
(when (and (eq status 'success) items)
(let ((theme
(etaf-ui-theme-tokens :ui-grid-border
:ui-grid-selected-bg)))
(list
:items
(etaf-ui--grid-keyed-items
items current-row-key row-actions row-states)
:context theme))))))
(setq
body-range-item
(lambda (entry theme)
(let* ((key (car entry))
(item (cdr entry))
(state (etaf-ui--grid-row-state row-states key)))
(etaf-ui--grid-row
item key current-columns current-row-ref current-on-row-press
current-selected-key current-row-selected-p
(unless (or current-row-selected-p current-selected-key)
(etaf-data-selected-ref current-controller key))
row-actions theme (car state) (cdr state)))))
(lambda ()
(let* ((controller (etaf-current-prop :controller))
(columns (etaf-current-prop :columns))
(row-key (etaf-current-prop :row-key))
(row-ref (etaf-current-prop :row-ref))
(on-row-press (etaf-current-prop :on-row-press))
(selected-key (etaf-current-prop :selected-key))
(row-selected-p (etaf-current-prop :row-selected-p))
(loading-label (etaf-current-prop :loading-label))
(error-label (etaf-current-prop :error-label))
(empty-label (etaf-current-prop :empty-label))
(config
(list controller columns row-key row-ref on-row-press
selected-key row-selected-p loading-label error-label
empty-label))
(theme (etaf-ui-theme-tokens :ui-fg :ui-grid-border))
(theme-color (plist-get theme :ui-fg)))
(unless (eq controller current-controller)
(clrhash row-actions)
(clrhash row-states))
(setq current-controller controller
current-columns columns
current-row-key row-key
current-row-ref row-ref
current-on-row-press on-row-press
current-selected-key selected-key
current-row-selected-p row-selected-p
current-loading-label loading-label
current-error-label error-label
current-empty-label empty-label)
(unless (equal-including-properties config body-config)
(setq body-config (copy-tree config)
body-expr
(etaf--expr-create
:token (gensym "etaf-data-grid-body-")
:thunk body-thunk
:range-snapshot body-range-snapshot
:range-key #'car
:range-item body-range-item)))
(etaf--view-call
'column
(list :class "etaf-data-grid" :color theme-color)
(list
(etaf-ui--grid-header columns theme)
(etaf--view-call
'column (list :class "etaf-data-grid-body")
(list body-expr))
(etaf--slot-projection-create
:name 'footer :token 'etaf-ui-data-grid-footer :fallback nil)))))))
;;;###autoload
(etaf-define-component etaf-pagination
(&key controller previous-ref next-ref class color bgcolor border padding
aria-label)
"Render a compact, accessible pager for DATA CONTROLLER.
The pager owns no data state: page, page-size, total, loading, and error stay
with CONTROLLER. PREVIOUS-REF and NEXT-REF should be stable public refs when
the pager participates in keyboard/mouse interaction. The visible glyphs
(`' and `') are paired with labels and help text so the compact control is
readable in both GUI and text review."
:styles
(styles
("&" :width stretch)
(".etaf-pagination-label" :font-weight bold))
:setup
(let* ((current-controller nil)
(current-parent-color nil)
(current-parent-bgcolor nil)
(page-value
(lambda ()
(max 1 (or (etaf-value
(etaf-data-page current-controller))
1))))
(page-size-value
(lambda ()
(max 1 (or (etaf-value
(etaf-data-page-size current-controller))
1))))
(total-value
(lambda ()
(max 0 (or (etaf-value
(etaf-data-total current-controller))
0))))
(pages-value
(lambda ()
(max 1 (ceiling (/ (float (funcall total-value))
(funcall page-size-value))))))
(loading-p
(lambda ()
(eq (etaf-value (etaf-data-status current-controller))
'loading)))
(previous-disabled
(lambda ()
(or (funcall loading-p) (<= (funcall page-value) 1))))
(next-disabled
(lambda ()
(or (funcall loading-p)
(>= (funcall page-value) (funcall pages-value)))))
(previous
(lambda ()
(when (and current-controller
(not (funcall previous-disabled)))
(etaf-data-previous-page current-controller))))
(next
(lambda ()
(when (and current-controller
(not (funcall next-disabled)))
(etaf-data-next-page current-controller)))))
(lambda ()
(let* ((controller-value (etaf-current-prop :controller))
(theme (etaf-ui-theme-tokens :ui-fg :ui-bg
:ui-disabled-fg
:ui-pagination-muted-fg))
(parent-color (or (etaf-current-prop :color)
(plist-get theme :ui-fg)))
(parent-bgcolor (or (etaf-current-prop :bgcolor)
(plist-get theme :ui-bg)))
(arrow-border '(0 solid "transparent")))
(setq current-controller controller-value
current-parent-color parent-color
current-parent-bgcolor parent-bgcolor)
(etaf-view
(flex
:class (etaf-ui--class-value "etaf-pagination" nil
(etaf-current-prop :class))
:width 'stretch
:flex-direction 'row
:align-items 'center
:role 'navigation
:aria-label (or (etaf-current-prop :aria-label) "Pagination")
:color parent-color
:bgcolor parent-bgcolor
:border (etaf-current-prop :border)
:box-sizing 'border-box
:padding (or (etaf-current-prop :padding) '(0 1))
:gap '(0 (1))
(column :width 'max-content
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto
(button :label "" :ref (etaf-current-prop :previous-ref)
:aria-label "Previous page"
:disabled (funcall previous-disabled)
:padding '(0 0)
:border arrow-border
:color (if (funcall previous-disabled)
(plist-get theme :ui-disabled-fg)
current-parent-color)
:bgcolor current-parent-bgcolor
:font-weight 'bold
:on-press previous))
(column
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
(box :class "etaf-pagination-label" :text-align 'center
:wrap-mode 'none :min-width 'max-content
(text
(expr :value
(format "Page %d / %d"
(funcall page-value)
(funcall pages-value)))))
(box :class "etaf-pagination-summary" :text-align 'center
:color (plist-get theme :ui-pagination-muted-fg)
:wrap-mode 'none :min-width 'max-content
(text
(expr :value
(let* ((page (funcall page-value))
(page-size (funcall page-size-value))
(total (funcall total-value))
(first-item
(if (zerop total)
0
(1+ (* (1- page) page-size))))
(last-item (min total (* page page-size))))
(format "%d%d of %d"
first-item last-item total))))))
(column :width 'max-content
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto
(button :label "" :ref (etaf-current-prop :next-ref)
:aria-label "Next page"
:disabled (funcall next-disabled)
:padding '(0 0)
:border arrow-border
:color (if (funcall next-disabled)
(plist-get theme :ui-disabled-fg)
current-parent-color)
:bgcolor current-parent-bgcolor
:font-weight 'bold
:on-press next))))))))
(require 'etaf-ui-basic)
(require 'etaf-ui-table)
(require 'etaf-ui-data)
(provide 'etaf-ui)
;;; etaf-ui.el ends here

View File

@ -0,0 +1,273 @@
;;; etaf-ui-m0a-inventory.el --- M0a Component inventory -*- lexical-binding: t; -*-
;;; Commentary:
;; Machine-readable current-behavior inventory. This file deliberately
;; records private consumers as drift; M0a does not turn the M0b target into a
;; failing current gate.
;;; Code:
(require 'cl-lib)
(require 'seq)
(defconst etaf-ui-m0a--package-root
(file-name-directory
(directory-file-name
(file-name-directory (or load-file-name buffer-file-name))))
"Absolute etaf-ui package root used by the inventory.")
(defconst etaf-ui-m0a-public-component-contracts
'((:name etaf-label
:business-props (text variant)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-basic.el")
(:name etaf-button
:business-props (label on-press disabled ref class color bgcolor border
padding font-weight tab-index aria-label use variant)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-basic.el")
(:name etaf-checkbox
:business-props (checked label on-change disabled)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-basic.el")
(:name etaf-panel
:business-props (title variant)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-basic.el")
(:name etaf-number-input
:business-props (value label on-change disabled min max)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-basic.el")
(:name etaf-table
:business-props (columns rows row-key row-ref on-row-press row-selected-p)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-table.el")
(:name etaf-data-grid
:business-props (controller columns row-key on-row-press row-ref
row-selected-p loading-label error-label
empty-label)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-data.el")
(:name etaf-pagination
:business-props (controller previous-ref next-ref previous-label next-label
class color bgcolor border padding aria-label)
:forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root
:definition "etaf-ui-data.el"))
"Observed contracts of the eight public etaf-ui Components.
`all-valid-host-attrs' names the core single-root Component forwarding rule;
it is not a claim that every attribute is a declared business prop.")
(defconst etaf-ui-m0a-private-production-callsites
'((:symbol etaf--expr-create :scope production
:file "etaf-ui-data.el" :line 93)
(:symbol etaf--expr-create :scope production
:file "etaf-ui-data.el" :line 106)
(:symbol etaf--expr-create :scope production
:file "etaf-ui-data.el" :line 114)
(:symbol etaf--expr-create :scope production
:file "etaf-ui-data.el" :line 234)
(:symbol etaf--view-call :scope production
:file "etaf-ui-data.el" :line 278)
(:symbol etaf--view-call :scope production
:file "etaf-ui-data.el" :line 284)
(:symbol etaf--slot-projection-create :scope production
:file "etaf-ui-data.el" :line 286))
"Exact M0a baseline of production calls into private ETAF functions.")
(defconst etaf-ui-m0b-private-production-callsites nil
"M0b target and current production calls into private ETAF functions.")
(defun etaf-ui-m0a--read-top-level-forms (file)
"Return top-level forms and source lines read from FILE."
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(let (forms form start)
(condition-case nil
(while t
(setq start (point)
form (read (current-buffer)))
(push (list :form form :line (line-number-at-pos start)) forms))
(end-of-file nil))
(nreverse forms))))
(defun etaf-ui-m0a--component-definitions ()
"Return public Component definitions observed in package product files."
(let (result)
(dolist (file (directory-files etaf-ui-m0a--package-root t
"\\`etaf-ui-.*\\.el\\'"))
(dolist (entry (etaf-ui-m0a--read-top-level-forms file))
(let ((form (plist-get entry :form)))
(when (and (memq (car-safe form)
'(etaf-define-component
etaf-ui--define-component))
(symbolp (cadr form))
(not (string-prefix-p "etaf-ui--"
(symbol-name (cadr form)))))
(let ((arguments (nth 2 form)))
(push (list :name (cadr form)
:business-props
(seq-filter #'symbolp
(cdr (memq '&key arguments)))
:definition
(file-relative-name file etaf-ui-m0a--package-root)
:line (plist-get entry :line))
result))))))
(sort result (lambda (left right)
(string< (symbol-name (plist-get left :name))
(symbol-name (plist-get right :name)))))))
(defun etaf-ui-m0a-component-inventory ()
"Return the current eight-Component contract with observed source lines."
(let ((definitions (etaf-ui-m0a--component-definitions)))
(mapcar
(lambda (contract)
(let* ((name (plist-get contract :name))
(observed (seq-find
(lambda (entry) (eq name (plist-get entry :name)))
definitions)))
(append (copy-sequence contract)
(list :observed-business-props
(plist-get observed :business-props)
:observed-definition (plist-get observed :definition)
:line (plist-get observed :line)
:drift
(unless (and observed
(equal (plist-get contract :business-props)
(plist-get observed :business-props))
(equal (plist-get contract :definition)
(plist-get observed :definition)))
'contract-mismatch)))))
etaf-ui-m0a-public-component-contracts)))
(defun etaf-ui-m0a--private-occurrences-in-file (file scope root call-only)
"Return active private occurrences in FILE under SCOPE and ROOT.
When CALL-ONLY is non-nil, record only symbols in function-call position.
The linear scanner excludes strings and both line and block comments."
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(let ((block-depth 0)
in-string
escaped
result)
(while (< (point) (point-max))
(cond
((> block-depth 0)
(cond ((looking-at "#|")
(setq block-depth (1+ block-depth))
(forward-char 2))
((looking-at "|#")
(setq block-depth (1- block-depth))
(forward-char 2))
(t (forward-char 1))))
(in-string
(let ((character (char-after)))
(forward-char 1)
(cond (escaped (setq escaped nil))
((eq character ?\\) (setq escaped t))
((eq character ?\") (setq in-string nil)))))
((looking-at "#|")
(setq block-depth 1)
(forward-char 2))
((eq (char-after) ?\;)
(forward-line 1))
((eq (char-after) ?\")
(setq in-string t)
(forward-char 1))
((eq (char-after) ??)
;; Skip an Emacs Lisp character literal, including ?\\X.
(forward-char (min (if (eq (char-after (1+ (point))) ?\\) 3 2)
(- (point-max) (point)))))
((and call-only (eq (char-after) ?\())
(forward-char 1)
(skip-chars-forward " \t\r\n")
(when (looking-at "\\(etaf--[[:alnum:]-]+\\)\\_>")
(push (list :symbol (intern (match-string-no-properties 1))
:scope scope
:file (file-relative-name file root)
:line (line-number-at-pos (point)))
result)))
((and (not call-only)
(looking-at "\\_<\\(etaf--[[:alnum:]-]+\\)\\_>"))
(push (list :symbol (intern (match-string-no-properties 1))
:scope scope
:file (file-relative-name file root)
:line (line-number-at-pos (point)))
result)
(goto-char (match-end 1)))
(t (forward-char 1))))
(nreverse result))))
(defun etaf-ui-m0a-private-consumers (&optional root)
"Return active core-private consumers below ROOT.
ROOT defaults to the etaf-ui package root."
(let* ((root (file-name-as-directory
(or root etaf-ui-m0a--package-root)))
(tests-directory (expand-file-name "tests" root))
(files (append
(directory-files root t
"\\`etaf-ui-.*\\.el\\'")
(when (file-directory-p tests-directory)
(directory-files tests-directory t "\\.el\\'"))))
result)
(dolist (file files)
;; The inventory's own expectation literals are evidence vocabulary,
;; not calls into the private API under inventory.
(unless (string-suffix-p "etaf-ui-m0a-inventory-tests.el" file)
(setq result
(nconc result
(if (string-match-p "/tests/" file)
(etaf-ui-m0a--private-occurrences-in-file
file 'test root nil)
(etaf-ui-m0a--private-occurrences-in-file
file 'production root t))))))
result))
(defun etaf-ui-m0a-private-consumer-drift (&optional root)
"Return current M0b production private-call drift below optional ROOT."
(let ((observed
(seq-filter
(lambda (entry) (eq 'production (plist-get entry :scope)))
(etaf-ui-m0a-private-consumers root))))
(list :expected etaf-ui-m0b-private-production-callsites
:observed observed
:missing (seq-remove (lambda (entry) (member entry observed))
etaf-ui-m0b-private-production-callsites)
:unexpected
(seq-remove (lambda (entry)
(member entry etaf-ui-m0b-private-production-callsites))
observed))))
(defun etaf-ui-m0a-inventory ()
"Return the complete machine-readable etaf-ui M0a inventory."
(list :schema-version 1
:milestone 'M0b
:evidence-mode 'migrated-public-extension-seam
:datagrid-contract
'(:handler-publication postcommit-promoted
:fallback-ref instance-scoped-uninterned
:fixed-width-row single-text-host)
:components (etaf-ui-m0a-component-inventory)
:m0a-private-production-baseline
etaf-ui-m0a-private-production-callsites
:private-consumers (etaf-ui-m0a-private-consumers)
:private-production-drift (etaf-ui-m0a-private-consumer-drift)))
(defun etaf-ui-m0a-inventory-batch ()
"Print `etaf-ui-m0a-inventory' for a batch evidence run."
(prin1 (etaf-ui-m0a-inventory))
(terpri))
(provide 'etaf-ui-m0a-inventory)
;;; etaf-ui-m0a-inventory.el ends here

View File

@ -0,0 +1,76 @@
;;; etaf-ui-button-commit-tests.el --- Button callback publication -*- lexical-binding: t; -*-
;;; Commentary:
;; Public Button callbacks follow the same commit boundary as their visible UI.
;;; Code:
(require 'ert)
(require 'etaf-ui)
(ert-deftest etaf-ui-button-callback-uses-only-committed-props ()
"A later sibling failure cannot replace the live Button callback."
(let ((label (etaf-ref "A"))
(buffer (generate-new-buffer " *button-commit*"))
events)
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(let ((caption (etaf-value label)))
(etaf-view
(column
(etaf-button :ref 'button-commit :label caption
:on-press (lambda () (push caption events)))
(text (expr (if (equal (etaf-value label) "Rejected")
(error "Rejected sibling")
"Sibling"))))))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-dispatch-event runtime 'button-commit 'press)
(setf (etaf-value label) "B")
(etaf-dispatch-event runtime 'button-commit 'press)
(let ((published (with-current-buffer buffer (buffer-string)))
(generation (etaf-runtime-current-generation runtime)))
(should-error (setf (etaf-value label) "Rejected"))
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (equal-including-properties
published (with-current-buffer buffer (buffer-string)))))
(etaf-dispatch-event runtime 'button-commit 'press)
(should (equal '("B" "B" "A") events))
(setf (etaf-value label) "C")
(etaf-dispatch-event runtime 'button-commit 'press)
(should (equal '("C" "B" "B" "A") events))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(kill-buffer buffer))))
(ert-deftest etaf-ui-button-stable-callback-keeps-handler-identity ()
"An unchanged caller callback remains stable through presentation updates."
(let ((label (etaf-ref "A"))
(callback #'ignore)
(buffer (generate-new-buffer " *button-stable-callback*")))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-button :ref 'button-stable :label (etaf-value label)
:on-press callback))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(handler (cdr (assq 'press
(etaf-runtime-handler-for
runtime 'button-stable)))))
(setf (etaf-value label) "B")
(should (eq handler
(cdr (assq 'press
(etaf-runtime-handler-for
runtime 'button-stable)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(kill-buffer buffer))))
(provide 'etaf-ui-button-commit-tests)
;;; etaf-ui-button-commit-tests.el ends here

706
tests/etaf-ui-cell-tests.el Normal file
View File

@ -0,0 +1,706 @@
;;; etaf-ui-cell-tests.el --- Reusable Table cell contracts -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'etaf-ui)
(defvar etaf-ui-cell-test--states nil)
(defvar etaf-ui-cell-test--removed nil)
(defvar etaf-ui-cell-test--calls nil)
(defvar etaf-ui-cell-test--disposed nil)
(defvar etaf-ui-cell-test--mounted nil)
(defvar etaf-ui-cell-test--observed nil)
(defun etaf-ui-cell-test--row-key (row)
"Return ROW's stable identity."
(plist-get row :id))
(defun etaf-ui-cell-test--name (row)
"Return ROW's name, recording factory evaluation for locality assertions."
(push (plist-get row :id) etaf-ui-cell-test--calls)
(plist-get row :name))
(defun etaf-ui-cell-test--hosts (buffer class)
"Return reference/property pairs for Hosts with CLASS in BUFFER."
(let (hosts)
(maphash
(lambda (ref props)
(when (member class (split-string (or (plist-get props :class) "")))
(push (cons ref props) hosts)))
(etaf-runtime-host-props (etaf-runtime-for-buffer buffer)))
hosts))
(defmacro etaf-ui-cell-test--with-buffer (name &rest body)
"Execute BODY with a temporary mounted buffer bound to NAME."
(declare (indent 1) (debug (symbolp body)))
`(let ((,name (generate-new-buffer " *etaf-ui-cells*")))
(unwind-protect (progn ,@body)
(when-let* ((runtime (etaf-runtime-for-buffer ,name)))
(etaf-unmount runtime))
(when (buffer-live-p ,name) (kill-buffer ,name)))))
(etaf-define-component etaf-ui-cell-test-counter (&key row field value)
"Retain one independent counter at the consuming row/column position."
:setup
(let* ((id (list (plist-get row :id) field))
(count (etaf-ref 0))
(ref (make-symbol "etaf-cell-counter")))
(push (list id count ref) etaf-ui-cell-test--states)
(etaf-on-unmounted (lambda () (push id etaf-ui-cell-test--removed)))
(list count ref))
:render
(let* ((state (etaf-state))
(count (car state)))
(etaf-node
'etaf-button
(list :label (format "%s:%s:%s%s" (plist-get row :id) field
(etaf-value count) (if value (concat ":" value) ""))
:ref (cadr state)
:on-press (lambda () (cl-incf (etaf-value count))))
nil)))
(etaf-define-component etaf-ui-cell-test-resource (&key row pulse)
"Expose public lifecycle and subscription observations for one cell."
:setup
(let ((id (plist-get row :id))
(count (etaf-ref 0))
(ref (make-symbol "etaf-cell-resource")))
(push (list id count ref) etaf-ui-cell-test--states)
(etaf-on-scope-dispose
(lambda () (push ref etaf-ui-cell-test--disposed)))
(etaf-on-mounted (lambda () (push ref etaf-ui-cell-test--mounted)))
(etaf-on-unmounted (lambda () (push ref etaf-ui-cell-test--removed)))
(etaf-watch pulse
(lambda (value _old)
(push (cons ref value) etaf-ui-cell-test--observed)))
(list count ref))
:render
(let ((count (car (etaf-state))) (ref (cadr (etaf-state))))
(etaf-node
'etaf-button
(list :label (format "%s:%d" (plist-get row :id) (etaf-value count))
:ref ref :on-press (lambda () (cl-incf (etaf-value count))))
nil)))
(defun etaf-ui-cell-test--counter-column (field)
"Return a custom FIELD column containing independent state."
(list :key field :label (symbol-name field) :width 12
:cell (lambda (row)
(etaf-node 'etaf-ui-cell-test-counter
(list :row row :field field) nil))))
(etaf-define-component etaf-ui-cell-test-context (&key shared)
"Consume Context and Theme where this reusable cell is mounted."
:setup (etaf-inject 'etaf-ui-cell-test-context nil t)
:view
(text :class "cell-context" :color (etaf-theme-token :cell-color)
(expr (format "%s:%d" (etaf-state) (etaf-value shared))))
:styles (styles (".cell-context" :font-weight bold)))
(etaf-define-component etaf-ui-cell-test-provider
(&key label color columns controller)
"Provide a local LABEL and COLOR around Table or CONTROLLER's Grid."
:setup
(progn
(etaf-provide 'etaf-ui-cell-test-context label)
(etaf-theme-provide (list :cell-color color))
nil)
:render
(if controller
(etaf-node 'etaf-data-grid
(list :controller controller :columns columns
:row-key #'etaf-ui-cell-test--row-key) nil)
(etaf-node 'etaf-table
(list :rows '((:id 1)) :columns columns
:row-key #'etaf-ui-cell-test--row-key) nil)))
(etaf-define-component etaf-ui-cell-test-factory-author
(&key shared controller secret)
"Author one ordinary factory reused under two consumer Contexts."
:setup
(progn
(etaf-provide 'etaf-ui-cell-test-context "Author")
(etaf-theme-provide '(:cell-color "magenta"))
(list shared 'author-private-state))
:render
(let* ((captured (car (etaf-state)))
(factory
(lambda (_row)
(let ((context (etaf-inject 'etaf-ui-cell-test-context nil t)))
(push (list context
(condition-case nil (etaf-state)
(etaf-component-definition-error 'unavailable))
(etaf-current-prop 'secret))
etaf-ui-cell-test--calls)
(etaf-node
'text
(list :class "cell-author-private cell-factory-consumer"
:color (etaf-theme-token :cell-color))
(list (format "%s:%d" context (etaf-value captured)))))))
(columns (list (list :key :name :width 18 :cell factory))))
(etaf-node
'column nil
(list
(etaf-node 'text '(:class "cell-author-private cell-author-local")
(list secret))
(etaf-node 'etaf-ui-cell-test-provider
(list :label "Table" :color "red" :columns columns) nil)
(etaf-node 'etaf-ui-cell-test-provider
(list :label "Grid" :color "blue" :columns columns
:controller controller) nil))))
:styles
(styles (".cell-author-private" :font-weight bold :font-style italic)))
(ert-deftest etaf-ui-cell-columns-require-unique-non-nil-keys ()
"Reject ambiguous column identity with its index and offending key."
(dolist (columns '(((:label "Missing"))
((:key :name) (:key :name))))
(etaf-ui-cell-test--with-buffer buffer
(let ((message
(error-message-string
(should-error
(etaf-mount
buffer
(etaf-view
(etaf-table :columns columns :rows nil
:row-key #'etaf-ui-cell-test--row-key)))))))
(should (string-match-p "column" message))
(should (string-match-p (if (= (length columns) 1) "1" "2")
message))
(should (string-match-p (if (= (length columns) 1) "nil" ":name")
message))))))
(ert-deftest etaf-ui-cell-custom-factory-bypasses-fixed-text ()
"Custom fixed-width columns mount their controls as ordinary Views."
(let ((columns (list (list :key :action :width 12 :label "Action"
:cell (lambda (row)
(etaf-node 'text nil
(list (plist-get row :name))))))))
(should-not (etaf-ui--table-fixed-row-text '(:name "Ada") columns))
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :columns columns :rows '((:id 1 :name "Ada"))
:row-key #'etaf-ui-cell-test--row-key)))
(with-current-buffer buffer
(should (string-match-p "Ada" (buffer-string)))))))
(ert-deftest etaf-ui-cell-stateless-table-keeps-pure-render-support ()
"Automatic row references do not introduce setup state into plain Tables."
(dolist (columns '(((:key :name :width 12))
((:key :name :width 12 :cell etaf-ui-cell-test--name))))
(should
(ebox-canonical-input-p
(etaf-render
(etaf-view
(etaf-table :columns columns :rows '((:id 1 :name "Ada"))
:row-key #'etaf-ui-cell-test--row-key)))))))
(ert-deftest etaf-ui-cell-shares-factory-with-consumer-context-and-theme ()
"One factory uses each Table/Grid's Context and an explicitly shared ref."
(let* ((shared (etaf-ref 0))
(columns
(list (list :key :context :width 18
:cell (lambda (_row)
(etaf-node 'etaf-ui-cell-test-context
(list :shared shared) nil)))))
(source (etaf-data-memory-source '((:id 1)) :id-key :id))
(controller (etaf-data-controller source :auto-load t)))
(unwind-protect
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(column
(etaf-ui-cell-test-provider :label "Table" :color "red"
:columns columns)
(etaf-ui-cell-test-provider :label "Grid" :color "blue"
:columns columns :controller controller))))
(setf (etaf-value shared) 7)
(with-current-buffer buffer
(should (string-match-p "Table:7" (buffer-string)))
(should (string-match-p "Grid:7" (buffer-string))))
(let ((hosts (etaf-ui-cell-test--hosts buffer "cell-context")))
(should (= 2 (length hosts)))
(should (equal '("blue" "red")
(sort (mapcar (lambda (host)
(plist-get (cdr host) :color))
hosts)
#'string<)))
(dolist (host hosts)
(should (eq 'bold (plist-get (cdr host) :font-weight))))))
(etaf-data-stop controller))))
(ert-deftest etaf-ui-cell-ordinary-output-and-text-mode-switch ()
"Accept nil/string/Host/fragment/sequences and return to compact text rows."
(let* ((columns (etaf-ref '((:key :name :label "Name" :width 12))))
(rows '((:id 1 :name "Default")))
(factory
(lambda (_row)
(list nil "prefix" (etaf-node 'text nil '("host"))
(etaf-node 'fragment nil '("fragment"))))))
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :rows rows :columns (etaf-value columns)
:row-key #'etaf-ui-cell-test--row-key)))
(should-not (etaf-ui-cell-test--hosts buffer "etaf-table-cell"))
(setf (etaf-value columns)
(list (list :key :name :label "Name" :width 30 :cell factory)))
(with-current-buffer buffer
(dolist (word '("prefix" "host" "fragment"))
(should (string-match-p word (buffer-string)))))
(should (= 1 (length (etaf-ui-cell-test--hosts buffer "etaf-table-cell"))))
(setf (etaf-value columns) '((:key :name :label "Name" :width 12)))
(with-current-buffer buffer
(should (string-match-p "Default" (buffer-string))))
(should-not (etaf-ui-cell-test--hosts buffer "etaf-table-cell")))))
(ert-deftest etaf-ui-cell-factory-uses-consumer-context-without-author-scope ()
"Ordinary factories consume Context directly and capture business refs only."
(let* ((etaf-ui-cell-test--calls nil)
(shared (etaf-ref 0))
(source (etaf-data-memory-source '((:id 1)) :id-key :id))
(controller (etaf-data-controller source :auto-load t)))
(unwind-protect
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-ui-cell-test-factory-author
:shared shared :controller controller :secret "Author secret")))
(setf (etaf-value shared) 7)
(with-current-buffer buffer
(should (string-match-p "Table:7" (buffer-string)))
(should (string-match-p "Grid:7" (buffer-string))))
(should
(equal '("Grid" "Table")
(sort (delete-dups (mapcar #'car etaf-ui-cell-test--calls))
#'string<)))
(dolist (call etaf-ui-cell-test--calls)
(should-not (equal (nth 1 call) (list shared 'author-private-state)))
(should-not (nth 2 call)))
(let ((local (etaf-ui-cell-test--hosts buffer "cell-author-local"))
(cells (etaf-ui-cell-test--hosts buffer "cell-factory-consumer")))
;; The author stylesheet is active, so its absence from cells is
;; evidence of ownership rather than an unloaded stylesheet.
(should (= 1 (length local)))
(should (eq 'bold (plist-get (cdar local) :font-weight)))
(should (eq 'italic (plist-get (cdar local) :font-style)))
(should (= 2 (length cells)))
(should (equal '("blue" "red")
(sort (mapcar (lambda (cell)
(plist-get (cdr cell) :color))
cells)
#'string<)))
(dolist (cell cells)
(should-not (eq 'bold (plist-get (cdr cell) :font-weight)))
(should-not (eq 'italic (plist-get (cdr cell) :font-style))))))
(etaf-data-stop controller))))
(ert-deftest etaf-ui-cell-factory-rejects-ref-and-watch-creation ()
"A factory cannot allocate persistent state or subscriptions during render."
(dolist (operation '(create-ref watch watch-effect))
(let* ((source (etaf-ref 0))
(calls 0)
(columns
(list
(list :key :illegal :width 12
:cell
(lambda (_row)
(pcase operation
('create-ref (etaf-ref 0))
('watch
(etaf-watch source (lambda (&rest _) (cl-incf calls))
:immediate t))
('watch-effect
(etaf-watch-effect
(lambda () (etaf-value source) (cl-incf calls)))))
"Unreachable")))))
(etaf-ui-cell-test--with-buffer buffer
(let ((failure
(should-error
(etaf-mount
buffer
(etaf-view
(etaf-table :rows '((:id 1)) :columns columns
:row-key #'etaf-ui-cell-test--row-key)))
:type 'etaf-render-side-effect-error)))
(should (equal (cdr failure) (list operation))))
(should-not (etaf-runtime-for-buffer buffer))
(setf (etaf-value source) 1)
(should (zerop calls))))))
(ert-deftest etaf-ui-cell-table-default-row-refs-are-instance-local ()
"Two Tables omit row-ref while retaining distinct, callable row addresses."
(let (pressed)
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(column
(etaf-table :columns '((:key :name :label "Name"))
:rows '((:id 1 :name "Left"))
:row-key #'etaf-ui-cell-test--row-key
:on-row-press (lambda (row) (push row pressed)))
(etaf-table :columns '((:key :name :label "Name"))
:rows '((:id 1 :name "Right"))
:row-key #'etaf-ui-cell-test--row-key
:on-row-press (lambda (row) (push row pressed))))))
(let ((hosts (etaf-ui-cell-test--hosts buffer "etaf-table-row")))
(should (= 2 (length hosts)))
(should-not (equal (caar hosts) (caadr hosts)))
(dolist (host hosts)
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) (car host) 'press))
(should (equal '("Left" "Right")
(sort (mapcar (lambda (row) (plist-get row :name))
pressed)
#'string<)))))))
(ert-deftest etaf-ui-cell-table-default-row-ref-follows-key ()
"An automatic row address survives reorder and reads the committed row."
(let ((rows (etaf-ref '((:id 1 :name "Old") (:id 2 :name "Second"))))
pressed)
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :columns '((:key :name :width 12))
:rows (etaf-value rows)
:row-key #'etaf-ui-cell-test--row-key
:on-row-press (lambda (row) (setq pressed row)))))
(let* ((hosts (etaf-ui-cell-test--hosts buffer "etaf-table-row"))
(ref (car (cl-find 1 hosts
:key (lambda (host)
(plist-get (cdr host) :key))))))
(should ref)
(setf (etaf-value rows) '((:id 2 :name "Second") (:id 1 :name "New")))
(should (assoc ref (etaf-ui-cell-test--hosts buffer "etaf-table-row")))
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) ref 'press)
(should (equal '(:id 1 :name "New") pressed))))))
(ert-deftest etaf-ui-cell-row-and-column-reorder-retain-state ()
"Counter state follows row and column keys, with one cleanup on deletion."
(let* ((etaf-ui-cell-test--states nil)
(etaf-ui-cell-test--removed nil)
(rows (etaf-ref '((:id 1) (:id 2))))
(columns (etaf-ref (list (etaf-ui-cell-test--counter-column :a)
(etaf-ui-cell-test--counter-column :b)))))
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :columns (etaf-value columns) :rows (etaf-value rows)
:row-key #'etaf-ui-cell-test--row-key)))
(should (= 4 (length etaf-ui-cell-test--states)))
(let* ((state (assoc '(1 :a) etaf-ui-cell-test--states))
(ref (nth 2 state)))
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) ref 'press)
(setf (etaf-value columns) (reverse (etaf-value columns)))
(setf (etaf-value rows) (reverse (etaf-value rows)))
(should (= 4 (length etaf-ui-cell-test--states)))
(should-not etaf-ui-cell-test--removed)
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) ref 'press)
(should (= 2 (etaf-value (cadr state))))
(with-current-buffer buffer
(should (string-match-p "1::a:2" (buffer-string)))))
(setf (etaf-value rows) '((:id 2)))
(should (= 2 (length etaf-ui-cell-test--removed)))
(should (member '(1 :a) etaf-ui-cell-test--removed))
(should (member '(1 :b) etaf-ui-cell-test--removed)))))
(ert-deftest etaf-ui-cell-grid-reorders-without-remounting-cells ()
"DataGrid uses the same retained custom cells while preserving row identity."
(let* ((etaf-ui-cell-test--states nil)
(etaf-ui-cell-test--removed nil)
(source (etaf-data-memory-source '((:id 1) (:id 2)) :id-key :id))
(controller (etaf-data-controller source :auto-load t))
(columns (etaf-ref (list (etaf-ui-cell-test--counter-column :a)
(etaf-ui-cell-test--counter-column :b)))))
(unwind-protect
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-data-grid :controller controller :columns (etaf-value columns)
:row-key #'etaf-ui-cell-test--row-key)))
(let* ((state (assoc '(1 :a) etaf-ui-cell-test--states))
(ref (nth 2 state)))
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) ref 'press)
(setf (etaf-value columns) (reverse (etaf-value columns)))
(setf (etaf-value (etaf-data-items controller)) '((:id 2) (:id 1)))
(should (= 4 (length etaf-ui-cell-test--states)))
(should-not etaf-ui-cell-test--removed)
(etaf-dispatch-event (etaf-runtime-for-buffer buffer) ref 'press)
(should (= 2 (etaf-value (cadr state))))
(with-current-buffer buffer
(should (string-match-p "1::a:2" (buffer-string)))))
(setf (etaf-value (etaf-data-items controller)) '((:id 2)))
(should (= 2 (length etaf-ui-cell-test--removed))))
(etaf-data-stop controller))))
(ert-deftest etaf-ui-cell-duplicate-field-migration-retains-distinct-state ()
"Name and Uppercase read the same field but retain distinct column identities."
(let* ((etaf-ui-cell-test--states nil)
(etaf-ui-cell-test--removed nil)
(rows (etaf-ref '((:id 1 :name "Ada") (:id 2 :name "Lin"))))
(columns
(etaf-ref
(mapcar
(lambda (entry)
(let ((key (car entry)) (transform (cdr entry)))
(list :key key :label (if (eq key :name) "Name" "Uppercase")
:width 24
:cell
(lambda (row)
(etaf-node 'etaf-ui-cell-test-counter
(list :row row :field key
:value (funcall transform
(plist-get row :name)))
nil)))))
'((:name . identity) (:name-upper . upcase))))))
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :rows (etaf-value rows) :columns (etaf-value columns)
:row-key #'etaf-ui-cell-test--row-key)))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(name (assoc '(1 :name) etaf-ui-cell-test--states))
(upper (assoc '(1 :name-upper) etaf-ui-cell-test--states))
(other-name (assoc '(2 :name) etaf-ui-cell-test--states))
(other-upper (assoc '(2 :name-upper) etaf-ui-cell-test--states)))
(should (= 4 (length etaf-ui-cell-test--states)))
(should-not (eq (cadr name) (cadr upper)))
(should-not (eq (nth 2 name) (nth 2 upper)))
(etaf-dispatch-event runtime (nth 2 name) 'press)
(etaf-dispatch-event runtime (nth 2 upper) 'press)
(etaf-dispatch-event runtime (nth 2 upper) 'press)
(setf (etaf-value rows) '((:id 2 :name "Lin") (:id 1 :name "Grace")))
(setf (etaf-value columns) (reverse (etaf-value columns)))
(should (= 4 (length etaf-ui-cell-test--states)))
(should-not etaf-ui-cell-test--removed)
(etaf-dispatch-event runtime (nth 2 name) 'press)
(etaf-dispatch-event runtime (nth 2 upper) 'press)
(should (= 2 (etaf-value (cadr name))))
(should (= 3 (etaf-value (cadr upper))))
(should (zerop (etaf-value (cadr other-name))))
(should (zerop (etaf-value (cadr other-upper))))
(with-current-buffer buffer
(dolist (label '("1::name:2:Grace" "1::name-upper:3:GRACE"
"2::name:0:Lin" "2::name-upper:0:LIN"))
(should (string-match-p (regexp-quote label) (buffer-string)))))))))
(ert-deftest etaf-ui-cell-insert-delete-failure-preserves-scopes-and-handlers ()
"Failed replacement disposes only new cells and keeps retired candidates live."
(let* ((etaf-ui-cell-test--states nil)
(etaf-ui-cell-test--removed nil)
(etaf-ui-cell-test--disposed nil)
(etaf-ui-cell-test--mounted nil)
(etaf-ui-cell-test--observed nil)
(initial '((:id 1) (:id 2)))
(rows (etaf-ref initial))
(pulse (etaf-ref 0))
(columns
(list
(list :key :action :width 12
:cell
(lambda (row)
(when (plist-get row :fail) (error "Reject replacement cell"))
(etaf-node 'etaf-ui-cell-test-resource
(list :row row :pulse pulse) nil))))))
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :rows (etaf-value rows) :columns columns
:row-key #'etaf-ui-cell-test--row-key)))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(first (assoc 1 etaf-ui-cell-test--states))
(second (assoc 2 etaf-ui-cell-test--states))
(first-ref (nth 2 first))
(second-ref (nth 2 second)))
(etaf-dispatch-event runtime first-ref 'press)
(let ((generation (etaf-runtime-current-generation runtime))
(text (with-current-buffer buffer (buffer-string))))
;; Row 3 has completed setup before row 2 rejects the candidate;
;; row 1 is absent from that same candidate and must not retire yet.
(should-error
(setf (etaf-value rows) '((:id 3) (:id 2 :fail t)))
:type 'error)
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (equal-including-properties
text (with-current-buffer buffer (buffer-string)))))
(should (= 3 (length etaf-ui-cell-test--states)))
(let ((failed-ref (nth 2 (assoc 3 etaf-ui-cell-test--states))))
(should failed-ref)
(should (equal (list failed-ref) etaf-ui-cell-test--disposed))
(should-not (memq failed-ref etaf-ui-cell-test--mounted))
(should-not etaf-ui-cell-test--removed)
;; Restore the business source before dispatch can legitimately
;; retry its still-invalid value at the ordinary batch boundary.
(setf (etaf-value rows) initial)
(should (= 3 (length etaf-ui-cell-test--states)))
(etaf-dispatch-event runtime first-ref 'press)
(etaf-dispatch-event runtime second-ref 'press)
(should (= 2 (etaf-value (cadr first))))
(should (= 1 (etaf-value (cadr second))))
(setf (etaf-value pulse) 1)
(should (= 2 (length etaf-ui-cell-test--observed)))
(should (assoc first-ref etaf-ui-cell-test--observed))
(should (assoc second-ref etaf-ui-cell-test--observed))
(should-not (assoc failed-ref etaf-ui-cell-test--observed))
(setf (etaf-value rows) '((:id 3) (:id 2)))
(should (= 4 (length etaf-ui-cell-test--states)))
(let ((new-ref (nth 2 (assoc 3 etaf-ui-cell-test--states))))
(should-not (eq failed-ref new-ref))
(should (equal (list first-ref) etaf-ui-cell-test--removed))
(should (= 3 (length etaf-ui-cell-test--mounted)))
(should (memq new-ref etaf-ui-cell-test--mounted))
(setq etaf-ui-cell-test--observed nil)
(setf (etaf-value pulse) 2)
(should (= 2 (length etaf-ui-cell-test--observed)))
(should (assoc second-ref etaf-ui-cell-test--observed))
(should (assoc new-ref etaf-ui-cell-test--observed))
(etaf-unmount runtime)
(should (= 4 (length etaf-ui-cell-test--disposed)))
(dolist (ref (list first-ref second-ref failed-ref new-ref))
(should (= 1 (cl-count ref etaf-ui-cell-test--disposed))))
(should (= 3 (length etaf-ui-cell-test--removed)))
(dolist (ref (list first-ref second-ref new-ref))
(should (= 1 (cl-count ref etaf-ui-cell-test--removed))))
(setq etaf-ui-cell-test--observed nil)
(setf (etaf-value pulse) 3)
(should-not etaf-ui-cell-test--observed)))))))
(ert-deftest etaf-ui-cell-later-factory-error-retains-committed-handler ()
"A failed later cell cannot replace an earlier cell's committed callback."
(let* ((rows (etaf-ref '((:id 1 :name "Committed") (:id 2 :name "Later"))))
(first-ref (make-symbol "etaf-cell-first"))
pressed
(columns
(list
(list :key :action :width 16
:cell
(lambda (row)
(when (plist-get row :fail) (error "Late cell failure"))
(let ((name (plist-get row :name)))
(etaf-node 'box
(list :ref (when (= 1 (plist-get row :id))
first-ref)
:on-press (lambda () (setq pressed name)))
(list name))))))))
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :rows (etaf-value rows) :columns columns
:row-key #'etaf-ui-cell-test--row-key)))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(text (with-current-buffer buffer (buffer-string))))
(should-error
(setf (etaf-value rows)
'((:id 1 :name "Candidate") (:id 2 :name "Failure" :fail t))))
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (equal-including-properties
text (with-current-buffer buffer (buffer-string))))
(etaf-dispatch-event runtime first-ref 'press)
(should (equal "Committed" pressed))
(setf (etaf-value rows) '((:id 1 :name "Published") (:id 2)))
(etaf-dispatch-event runtime first-ref 'press)
(should (equal "Published" pressed))))))
(ert-deftest etaf-ui-cell-grid-content-update-stays-row-local ()
"An item update evaluates one custom cell; selection visits only its delta."
(let* ((etaf-ui-cell-test--calls nil)
(rows (cl-loop for id from 1 to 12
collect (list :id id :name (format "Row %d" id))))
(source (etaf-data-memory-source rows :id-key :id))
(controller (etaf-data-controller source :page-size 12 :auto-load t))
(columns '((:key :name :width 12 :cell etaf-ui-cell-test--name))))
(unwind-protect
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-data-grid :controller controller :columns columns
:row-key #'etaf-ui-cell-test--row-key)))
(setq etaf-ui-cell-test--calls nil)
(setf (etaf-value (etaf-data-items controller))
(mapcar (lambda (row)
(if (= 6 (plist-get row :id))
'(:id 6 :name "Changed")
row))
rows))
(should (equal '(6) etaf-ui-cell-test--calls))
(etaf-data-select-one controller 1)
(setq etaf-ui-cell-test--calls nil)
(etaf-data-select-one controller 2)
(should (cl-every (lambda (id) (memq id '(1 2)))
etaf-ui-cell-test--calls))
(should (<= (length etaf-ui-cell-test--calls) 2)))
(etaf-data-stop controller))))
(ert-deftest etaf-ui-cell-button-owns-clipped-row-interaction ()
"A clipped official Button owns its hit area even while disabled."
(let* ((disabled (etaf-ref t))
(button-ref (make-symbol "etaf-clipped-cell-button"))
(button-presses 0)
(row-presses 0)
(columns
(list '(:key :name :label "Name" :width 8)
(list :key :action :label "Action" :width 5
:cell (lambda (_row)
(etaf-node
'etaf-button
(list :label "ABCDEFGHIJK" :ref button-ref
:disabled (etaf-value disabled)
:on-press (lambda () (cl-incf button-presses)))
nil)))
'(:key :tail :label "Tail" :width 6))))
(etaf-ui-cell-test--with-buffer buffer
(etaf-mount
buffer
(etaf-view
(etaf-table :columns columns :rows '((:id 1 :name "ITEM" :tail "TAIL"))
:row-key #'etaf-ui-cell-test--row-key
:on-row-press (lambda (_row) (cl-incf row-presses)))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(cell-ref
(car (cl-find :action
(etaf-ui-cell-test--hosts buffer "etaf-table-cell")
:key (lambda (host) (plist-get (cdr host) :key))))))
(should cell-ref)
(let ((button-bounds (ebox-host-ref-bounds buffer button-ref))
(cell-bounds (ebox-host-ref-bounds buffer cell-ref)))
(should button-bounds)
(should (<= (car cell-bounds) (car button-bounds)))
(should (<= (cdr button-bounds) (cdr cell-bounds))))
(with-current-buffer buffer
(goto-char (etaf-host-ref-position runtime button-ref))
(should-error (etaf-activate runtime) :type 'user-error))
(should-error (etaf-dispatch-event runtime button-ref 'press)
:type 'etaf-event-error)
(should (zerop button-presses))
(should (zerop row-presses))
(setf (etaf-value disabled) nil)
(with-current-buffer buffer
(goto-char (etaf-host-ref-position runtime button-ref))
(etaf-activate runtime))
(should (= 1 button-presses))
(should (zerop row-presses))
(with-current-buffer buffer
(goto-char (point-min))
(search-forward "ITEM")
(backward-char)
(etaf-activate runtime)
(should (search-forward "TAIL" nil t)))
(should (= 1 row-presses))))))
(provide 'etaf-ui-cell-tests)
;;; etaf-ui-cell-tests.el ends here

View File

@ -0,0 +1,85 @@
;;; etaf-ui-docs-tests.el --- Executable catalog entry docs -*- lexical-binding: t; -*-
;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Commentary:
;; Execute exact README snippets without preloading the UI or a Playground.
;;; Code:
(require 'ert)
(require 'cl-lib)
(defconst etaf-ui-docs-test--root
(file-name-directory
(directory-file-name (file-name-directory (or load-file-name
buffer-file-name))))
"Absolute path of the UI repository under test.")
(defun etaf-ui-docs-test--example (file)
"Extract the complete marked preferences example from README FILE."
(with-temp-buffer
(insert-file-contents (expand-file-name file etaf-ui-docs-test--root))
(goto-char (point-min))
(should (search-forward
"<!-- etaf-example: preferences -->\n```elisp\n" nil t))
(let ((start (point)))
(should (re-search-forward "^```$" nil t))
(buffer-substring-no-properties start (match-beginning 0)))))
(defun etaf-ui-docs-test--run-fresh (source)
"Mount exact README SOURCE and exercise its controls in a fresh Emacs."
(let ((script (make-temp-file "etaf-ui-readme-" nil ".el")))
(unwind-protect
(progn
(with-temp-file script
(insert source "\n")
(prin1
'(let ((runtime (etaf-runtime-for-buffer "*etaf-preferences*")))
(should runtime)
(with-current-buffer "*etaf-preferences*"
(should (string-match-p "Pending" (buffer-string)))
(should (string-match-p "Unsaved" (buffer-string))))
(etaf-dispatch-event runtime 'done-checkbox 'press)
(etaf-dispatch-event runtime 'save-button 'press)
(with-current-buffer "*etaf-preferences*"
(should (string-match-p "Complete" (buffer-string)))
(should (string-match-p "Saved" (buffer-string))))
(etaf-dispatch-event runtime 'done-checkbox 'press)
(with-current-buffer "*etaf-preferences*"
(should (string-match-p "Pending" (buffer-string))))
(should-not (featurep 'etaf-playground))
(etaf-unmount runtime))
(current-buffer)))
(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 '("." "../etaf" "../ebox"
"../tp" "../ecss")
append (list "-L" (expand-file-name
directory
etaf-ui-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 "UI README child exited %S:\n%s"
status (buffer-string)))))))
(delete-file script))))
(ert-deftest etaf-ui-docs-readmes-mount-and-dispatch-in-fresh-emacs ()
"Both catalog READMEs use real names and complete mounted interactions."
(dolist (file '("README.md" "README.zh-CN.md"))
(etaf-ui-docs-test--run-fresh (etaf-ui-docs-test--example file))))
(provide 'etaf-ui-docs-tests)
;;; etaf-ui-docs-tests.el ends here

View File

@ -0,0 +1,187 @@
;;; etaf-ui-m0a-inventory-tests.el --- M0a inventory tests -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'seq)
(require 'etaf-ui)
(declare-function etaf-ui-m0a-component-inventory
"../scripts/etaf-ui-m0a-inventory")
(declare-function etaf-ui-m0a-private-consumers
"../scripts/etaf-ui-m0a-inventory")
(declare-function etaf-ui-m0a-private-consumer-drift
"../scripts/etaf-ui-m0a-inventory")
(declare-function etaf-ui-m0a-inventory
"../scripts/etaf-ui-m0a-inventory")
(load-file (expand-file-name "scripts/etaf-ui-m0a-inventory.el"
default-directory))
(ert-deftest etaf-ui-m0a-inventory-records-eight-public-components ()
"Record exactly the eight current public etaf-ui Components."
(let ((components (etaf-ui-m0a-component-inventory)))
(should (= 8 (length components)))
(should
(equal '(etaf-button etaf-checkbox etaf-data-grid etaf-label
etaf-number-input etaf-pagination etaf-panel etaf-table)
(sort (mapcar (lambda (entry) (plist-get entry :name)) components)
(lambda (left right)
(string< (symbol-name left) (symbol-name right))))))))
(ert-deftest etaf-ui-m0a-inventory-matches-current-business-props ()
"Match each declared business prop list to its source definition."
(dolist (component (etaf-ui-m0a-component-inventory))
(should (equal (plist-get component :business-props)
(plist-get component :observed-business-props)))
(should-not (plist-get component :drift))))
(ert-deftest etaf-ui-m0a-inventory-separates-host-forwarding-from-props ()
"Record Host forwarding and single-root guarantees separately from props."
(dolist (component (etaf-ui-m0a-component-inventory))
(should (eq 'all-valid-host-attrs
(plist-get component :forwarded-host-attrs)))
(should (eq 'single-host-root
(plist-get component :root-guarantee)))))
(ert-deftest etaf-ui-m0a-components-forward-host-attrs-to-one-mounted-root ()
"Forward ref, class, and aria-label through every public Component root."
(let* ((source (etaf-data-memory-source
'((:id 1 :name "Ada")) :id-key :id))
(controller (etaf-data-controller source :auto-load t))
(buffer (generate-new-buffer-name " *etaf-ui-m0a-forwarding*"))
(components (etaf-ui-m0a-component-inventory)))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(column
(etaf-label :text "Label" :ref 'm0a-label
:class "m0a-forwarded" :aria-label "m0a-label")
(etaf-button :label "Button" :ref 'm0a-button
:class "m0a-forwarded" :aria-label "m0a-button")
(etaf-checkbox :checked nil :label "Checkbox"
:ref 'm0a-checkbox :class "m0a-forwarded"
:aria-label "m0a-checkbox")
(etaf-panel :title "Panel" :ref 'm0a-panel
:class "m0a-forwarded" :aria-label "m0a-panel"
(etaf-label :text "Nested"))
(etaf-number-input :value 1 :label "Number"
:ref 'm0a-number-input
:class "m0a-forwarded"
:aria-label "m0a-number-input")
(etaf-table :columns '((:key :name :label "Name"))
:rows '((:id 1 :name "Ada"))
:row-key (lambda (row) (plist-get row :id))
:ref 'm0a-table :class "m0a-forwarded"
:aria-label "m0a-table")
(etaf-data-grid
:controller controller
:columns '((:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:ref 'm0a-data-grid :class "m0a-forwarded"
:aria-label "m0a-data-grid")
(etaf-pagination :controller controller
:ref 'm0a-pagination
:class "m0a-forwarded"
:aria-label "m0a-pagination"))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(should (= 8 (length components)))
(dolist (component components)
(let* ((name (plist-get component :name))
(suffix (string-remove-prefix "etaf-"
(symbol-name name)))
(ref (intern (concat "m0a-" suffix)))
(props (etaf-runtime-host-props-for runtime ref)))
(should props)
(should (eq ref (plist-get props :ref)))
(should (member "m0a-forwarded"
(etaf--class-tokens
(plist-get props :class))))
(should (equal (symbol-name ref)
(plist-get props :aria-label)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when (get-buffer buffer) (kill-buffer buffer))
(etaf-data-stop controller))))
(ert-deftest etaf-ui-m0b-inventory-records-private-production-closure ()
"Record zero current production private consumers and retain M0a history."
(let* ((entries (seq-filter
(lambda (entry) (eq 'production (plist-get entry :scope)))
(etaf-ui-m0a-private-consumers)))
(symbols (delete-dups
(mapcar (lambda (entry) (plist-get entry :symbol)) entries))))
(should-not entries)
(should-not symbols)
(should (cl-every (lambda (entry)
(and (stringp (plist-get entry :file))
(integerp (plist-get entry :line))))
entries))
(let ((drift (etaf-ui-m0a-private-consumer-drift)))
(should-not (plist-get drift :missing))
(should-not (plist-get drift :unexpected)))
(should (= 7 (length etaf-ui-m0a-private-production-callsites)))))
(ert-deftest etaf-ui-m0a-inventory-rejects-an-undeclared-production-callsite ()
"Report a newly added private production call even when its symbol is known."
(let ((temporary-root (make-temp-file "etaf-ui-m0a-private-" t)))
(unwind-protect
(progn
(copy-file (expand-file-name "etaf-ui-data.el" default-directory)
(expand-file-name "etaf-ui-data.el" temporary-root))
(with-temp-buffer
(insert "\n(etaf--expr-create 'undeclared-callsite)\n")
(append-to-file (point-min) (point-max)
(expand-file-name "etaf-ui-data.el"
temporary-root)))
(should (plist-get
(etaf-ui-m0a-private-consumer-drift temporary-root)
:unexpected)))
(delete-directory temporary-root t))))
(ert-deftest etaf-ui-m0a-inventory-records-current-test-consumers ()
"Record existing private test consumers without counting inventory data."
(let* ((entries (seq-filter
(lambda (entry) (eq 'test (plist-get entry :scope)))
(etaf-ui-m0a-private-consumers)))
(symbols (delete-dups
(mapcar (lambda (entry) (plist-get entry :symbol)) entries))))
(should (= 10 (length entries)))
(should (= 2 (cl-count 'etaf--class-tokens entries
:key (lambda (entry)
(plist-get entry :symbol)))))
(should (= 4 (cl-count 'etaf--runtime-render-dirty-component entries
:key (lambda (entry)
(plist-get entry :symbol)))))
(should (= 2 (cl-count 'etaf--ebox-box-node entries
:key (lambda (entry)
(plist-get entry :symbol)))))
(should (= 2 (cl-count 'etaf--ebox-text-node entries
:key (lambda (entry)
(plist-get entry :symbol)))))
(should (equal '(etaf--class-tokens etaf--ebox-box-node
etaf--ebox-text-node
etaf--runtime-render-dirty-component)
(sort symbols (lambda (left right)
(string< (symbol-name left)
(symbol-name right))))))))
(ert-deftest etaf-ui-m0b-inventory-labels-public-seam-migration ()
"Label the zero-private-consumer state as the completed M0b migration."
(let ((inventory (etaf-ui-m0a-inventory)))
(should (eq 'M0b (plist-get inventory :milestone)))
(should (eq 'migrated-public-extension-seam
(plist-get inventory :evidence-mode)))
(should
(equal '(:handler-publication postcommit-promoted
:fallback-ref instance-scoped-uninterned
:fixed-width-row single-text-host)
(plist-get inventory :datagrid-contract)))
(should (= 7 (length (plist-get inventory
:m0a-private-production-baseline))))
(should-not
(seq-filter
(lambda (entry) (eq 'production (plist-get entry :scope)))
(plist-get inventory :private-consumers)))))
(provide 'etaf-ui-m0a-inventory-tests)
;;; etaf-ui-m0a-inventory-tests.el ends here

View File

@ -0,0 +1,377 @@
;;; etaf-ui-m0b-extension-tests.el --- M0b public extension seam -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'etaf-ui)
(defconst etaf-ui-m0b--data-source-file
(expand-file-name "../etaf-ui-data.el"
(file-name-directory (or load-file-name buffer-file-name)))
"DataGrid production source inspected by the M0b seam tests.")
(defun etaf-ui-m0b--walk (form predicate)
"Return non-nil when PREDICATE matches FORM or one of its children."
(or (funcall predicate form)
(and (consp form)
(or (etaf-ui-m0b--walk (car form) predicate)
(etaf-ui-m0b--walk (cdr form) predicate)))))
(defun etaf-ui-m0b--source-forms (file)
"Read and return every Lisp form in FILE."
(with-temp-buffer
(insert-file-contents file)
(let (forms form)
(condition-case nil
(while t
(setq form (read (current-buffer)))
(push form forms))
(end-of-file (nreverse forms))))))
(ert-deftest etaf-ui-m0b-data-grid-production-uses-public-extension-seam ()
"DataGrid production code contains no ETAF private API call."
(let ((private
(cl-loop for form in (etaf-ui-m0b--source-forms
etaf-ui-m0b--data-source-file)
when (etaf-ui-m0b--walk
form
(lambda (node)
(and (symbolp node)
(string-prefix-p "etaf--" (symbol-name node)))))
collect form)))
(should-not private)))
(ert-deftest etaf-ui-m0b-data-grid-public-range-retains-handler-and-root ()
"Insert/reorder/update retain handlers and avoid a root replacement."
(let* ((rows (cl-loop for id from 1 to 12
collect (list :id id :name (format "Row %d" id))))
(source (etaf-data-memory-source rows :id-key :id))
(controller (etaf-data-controller source :page-size 120 :auto-load t))
(buffer-name " *etaf-ui-m0b-grid-retention*")
(root-replacements 0)
(materialized 0)
update-materialized
pressed)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID")
(:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:row-ref (lambda (row)
(intern (format "m0b-row-%d" (plist-get row :id))))
:on-row-press (lambda (row) (setq pressed row)))))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(handler
(cdr (assq 'press
(etaf-runtime-handler-for runtime 'm0b-row-6))))
(old-root (symbol-function 'ebox-candidate-replace-root))
(old-box (symbol-function 'etaf--ebox-box-node))
(old-text (symbol-function 'etaf--ebox-text-node)))
(cl-letf (((symbol-function 'ebox-candidate-replace-root)
(lambda (&rest arguments)
(cl-incf root-replacements)
(apply old-root arguments)))
((symbol-function 'etaf--ebox-box-node)
(lambda (&rest arguments)
(cl-incf materialized)
(apply old-box arguments)))
((symbol-function 'etaf--ebox-text-node)
(lambda (&rest arguments)
(cl-incf materialized)
(apply old-text arguments))))
(setf (etaf-value (etaf-data-items controller))
(cl-loop for row in rows
if (= 6 (plist-get row :id))
collect '(:id 6 :name "Row six updated")
else collect row))
(setq update-materialized materialized)
(etaf-data-mutate controller 'insert
'(:id 13 :name "Row 13"))
(etaf-data-mutate controller 'update
'(:id 6 :name "Row six updated")))
(should (zerop root-replacements))
;; One local update stays well below materializing all 12 rows and
;; their two cells (at least 60 Ebox nodes).
(should (< update-materialized 30))
(should (eq handler
(cdr (assq
'press
(etaf-runtime-handler-for runtime 'm0b-row-6)))))
(etaf-dispatch-event runtime 'm0b-row-6 'press)
(should (equal "Row six updated" (plist-get pressed :name)))
(should (string-match-p
"Row six updated"
(with-current-buffer buffer-name
(substring-no-properties (buffer-string)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-m0b-data-grid-enumerates-120-items-once-per-turn ()
"A 120-row update enumerates the public Range once and stays item-local."
(let* ((row-key-calls 0)
(rows (cl-loop for id from 1 to 120
collect (list :id id :name (format "Row %d" id))))
(source (etaf-data-memory-source rows :id-key :id))
(controller (etaf-data-controller source :page-size 120 :auto-load t))
(buffer-name " *etaf-ui-m0b-grid-scale*"))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID"))
:row-key (lambda (row)
(cl-incf row-key-calls)
(plist-get row :id)))))
(setq row-key-calls 0)
(etaf-data-mutate controller 'update
'(:id 60 :name "Changed"))
(should (= 120 row-key-calls)))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-m0b-data-grid-footer-reorder-and-key-rollback ()
"Public slot projection and keyed rollback preserve the committed grid."
(let* ((rows '((:id 1 :name "Ada") (:id 2 :name "Grace")))
(source (etaf-data-memory-source rows :id-key :id))
(controller (etaf-data-controller source :page-size 10 :auto-load t))
(buffer-name " *etaf-ui-m0b-grid-footer*")
pressed)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(etaf-data-grid
:controller controller
:columns '((:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:row-ref (lambda (row)
(intern (format "m0b-footer-row-%d"
(plist-get row :id))))
:on-row-press (lambda (row) (setq pressed row))
(slot :name 'footer (etaf-label :text "Grid footer")))))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(handler
(cdr (assq 'press
(etaf-runtime-handler-for
runtime 'm0b-footer-row-1)))))
(should (string-match-p
"Grid footer"
(with-current-buffer buffer-name
(substring-no-properties (buffer-string)))))
(setf (etaf-value (etaf-data-items controller))
(reverse rows))
(should (eq handler
(cdr (assq
'press
(etaf-runtime-handler-for
runtime 'm0b-footer-row-1)))))
(etaf-dispatch-event runtime 'm0b-footer-row-1 'press)
(should (= 1 (plist-get pressed :id)))
(let ((generation (etaf-runtime-current-generation runtime))
(text (with-current-buffer buffer-name (buffer-string))))
(should-error
(setf (etaf-value (etaf-data-items controller))
'((:id 1 :name "A") (:id 1 :name "duplicate")))
:type 'etaf-component-call-error)
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (equal-including-properties
text (with-current-buffer buffer-name
(buffer-string)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-m0b-data-grid-late-row-failure-keeps-committed-handler ()
"Do not leak an early candidate row when a later row fails rendering."
(let* ((old-rows '((:id 1 :name "Committed") (:id 2 :name "Stable")))
(new-rows '((:id 1 :name "UNCOMMITTED")
(:id 2 :name "Late failure")))
(source (etaf-data-memory-source old-rows :id-key :id))
(controller (etaf-data-controller source :page-size 10 :auto-load t))
(buffer-name " *etaf-ui-m0b-grid-late-failure*")
fail-late pressed)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(etaf-data-grid
:controller controller
:columns '((:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:row-ref
(lambda (row)
(unless (and fail-late (= 2 (plist-get row :id)))
(intern (format "late-row-%s" (plist-get row :id)))))
:on-row-press (lambda (row) (setq pressed row)))))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(generation (etaf-runtime-current-generation runtime))
(text (with-current-buffer buffer-name (buffer-string)))
(handler
(cdr (assq 'press
(etaf-runtime-handler-for runtime 'late-row-1)))))
(setq fail-late t)
(should-error
(setf (etaf-value (etaf-data-items controller)) new-rows))
(should (eq generation
(etaf-runtime-current-generation runtime)))
(should (equal-including-properties
text (with-current-buffer buffer-name (buffer-string))))
(should (eq handler
(cdr (assq
'press
(etaf-runtime-handler-for runtime 'late-row-1)))))
(etaf-dispatch-event runtime 'late-row-1 'press)
(should (equal "Committed" (plist-get pressed :name)))
(setq fail-late nil)
(setf (etaf-value (etaf-data-items controller)) old-rows)
(setf (etaf-value (etaf-data-items controller)) new-rows)
(should (eq handler
(cdr (assq
'press
(etaf-runtime-handler-for runtime 'late-row-1)))))
(etaf-dispatch-event runtime 'late-row-1 'press)
(should (equal "UNCOMMITTED" (plist-get pressed :name)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-m0b-data-grid-prunes-committed-handler-cache ()
"Bound the stable handler cache to currently retained interactive keys."
(let* ((rows-a '((:id 1 :name "A") (:id 2 :name "B")
(:id 3 :name "C")))
(rows-b '((:id 4 :name "D") (:id 5 :name "E")
(:id 6 :name "F")))
(source (etaf-data-memory-source rows-a :id-key :id))
(controller (etaf-data-controller source :page-size 10 :auto-load t))
(buffer-name " *etaf-ui-m0b-grid-handler-prune*")
state)
(unwind-protect
(progn
(let ((promote
(symbol-function 'etaf-ui--data-grid-promote-row-actions)))
(cl-letf
(((symbol-function 'etaf-ui--data-grid-promote-row-actions)
(lambda (candidate-state)
(setq state candidate-state)
(funcall promote candidate-state))))
(etaf-mount
buffer-name
(etaf-view
(etaf-data-grid
:controller controller
:columns '((:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:row-ref (lambda (row)
(intern (format "prune-row-%s"
(plist-get row :id))))
:on-row-press #'ignore)))))
(should state)
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(cache (plist-get state :row-actions)))
(should (= 3 (hash-table-count cache)))
(dolist (key '(1 2 3))
(etaf-data-mutate controller 'delete key))
(dolist (row rows-b)
(etaf-data-mutate controller 'insert row))
(should (= 3 (hash-table-count cache)))
(dolist (key '(1 2 3)) (should-not (gethash key cache)))
(dolist (key '(4 5 6)) (should (gethash key cache)))
(dolist (key '(4 5 6))
(etaf-data-mutate controller 'delete key))
(should (zerop (hash-table-count cache)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-m0b-data-grid-default-refs-are-instance-scoped ()
"Keep fallback refs distinct across grids and typed row identities."
(let* ((rows '((:id foo :name "Symbol") (:id "foo" :name "String")))
(source (etaf-data-memory-source rows :id-key :id))
(controller (etaf-data-controller source :page-size 10 :auto-load t))
(buffer-name " *etaf-ui-m0b-grid-default-ref-scope*"))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(column
(etaf-data-grid
:controller controller
:columns '((:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:on-row-press #'ignore)
(etaf-data-grid
:controller controller
:columns '((:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:on-row-press #'ignore))))
(let (refs)
(maphash
(lambda (ref props)
(when (member (plist-get props :key) '(foo "foo"))
(push ref refs)))
(etaf-runtime-host-props
(etaf-runtime-for-buffer buffer-name)))
(should (= 4 (length refs)))
(should (= 4 (length (delete-dups (copy-sequence refs)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-m0b-data-grid-error-status-beats-retained-items ()
"Show the error state when a failed reload retains previously loaded rows."
(let* ((rows '((:id 1 :name "Existing")))
(source (etaf-data-memory-source rows :id-key :id))
(controller (etaf-data-controller source :page-size 10 :auto-load t))
(buffer-name " *etaf-ui-m0b-grid-retained-error*"))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(etaf-data-grid
:controller controller
:columns '((:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:error-label "Retained load failed"
:empty-label "EMPTY-LABEL")))
(setf (etaf-value (etaf-data-status controller)) 'error)
(let ((text (with-current-buffer buffer-name
(substring-no-properties (buffer-string)))))
(should (string-match-p "Retained load failed" text))
(should-not (string-match-p "EMPTY-LABEL" text))
(should-not (string-match-p "Existing" text))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(provide 'etaf-ui-m0b-extension-tests)
;;; etaf-ui-m0b-extension-tests.el ends here

View File

@ -30,6 +30,25 @@ Use Chinese punctuation when CHINESE-P is non-nil."
(plist-get component :observed-business-props)
(if chinese-p "" ", "))))
(ert-deftest etaf-ui-package-autoloads-never-register-components ()
"Keep package activation from executing Component registration forms."
(dolist (file (directory-files default-directory t "\\.el\\'"))
(with-temp-buffer
(insert-file-contents file)
(goto-char (point-min))
(while (re-search-forward "^;;;###autoload[[:space:]]*$" nil t)
(forward-comment (point-max))
(should-not
(memq (car-safe (read (current-buffer)))
'(etaf-define-component etaf-ui--define-component)))))))
(ert-deftest etaf-ui-package-reload-keeps-identical-catalog-definitions ()
"Allow package.el to reload exact catalog files without duplicate owners."
(let ((before (etaf-ui-m0a-component-inventory)))
(dolist (file '("etaf-ui-basic.el" "etaf-ui-table.el" "etaf-ui-data.el"))
(load-file (expand-file-name file default-directory)))
(should (equal before (etaf-ui-m0a-component-inventory)))))
(ert-deftest etaf-ui-m0b1-readmes-match-runtime-component-manifest ()
"Keep the README contract aligned with the runtime-derived inventory."
(let* ((components (etaf-ui-m0a-component-inventory))

View File

@ -0,0 +1,241 @@
;;; etaf-ui-pagination-commit-tests.el --- Pager callback publication -*- lexical-binding: t; -*-
;;; Commentary:
;; A controlled pager must operate on the Controller whose UI was committed.
;; A rejected sibling cannot redirect retained buttons to candidate props.
;;; Code:
(require 'ert)
(require 'etaf-ui)
(defun etaf-ui-pagination-test--controller ()
"Return an independently loaded three-page Controller."
(etaf-data-controller
(etaf-data-memory-source '((:id 1) (:id 2) (:id 3)) :id-key :id)
:page-size 1 :auto-load t))
(ert-deftest etaf-ui-pagination-failed-controller-swap-keeps-live-callbacks ()
"A rejected A-to-B render leaves both pager buttons bound to A."
(dolist (case '((next . 3) (previous . 1)))
(let* ((first (etaf-ui-pagination-test--controller))
(second (etaf-ui-pagination-test--controller))
(selected (etaf-ref first))
(reject t)
(buffer (generate-new-buffer " *pagination-commit*")))
(unwind-protect
(progn
(etaf-data-set-page first 2)
(etaf-data-set-page second 2)
(etaf-mount
buffer
(lambda ()
(etaf-view
(column
(etaf-pagination :controller (etaf-value selected)
:previous-ref 'previous :next-ref 'next)
(text (expr (if (and reject (eq (etaf-value selected) second))
(error "Rejected pager sibling")
"Accepted sibling")))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(generation (etaf-runtime-current-generation runtime))
(published (with-current-buffer buffer (buffer-string)))
(next-handler (cdr (assq 'press
(etaf-runtime-handler-for runtime 'next)))))
(should-error (setf (etaf-value selected) second))
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (equal-including-properties
published (with-current-buffer buffer (buffer-string))))
(should (eq next-handler
(cdr (assq 'press (etaf-runtime-handler-for runtime 'next)))))
;; Let the event's later render recover. This ordinary flag does
;; not render or replace the committed callback before the press.
(setq reject nil)
(etaf-dispatch-event runtime (car case) 'press)
(should (= (etaf-value (etaf-data-page first)) (cdr case)))
(should (= (etaf-value (etaf-data-page second)) 2))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(etaf-data-stop first)
(etaf-data-stop second)
(kill-buffer buffer)))))
(ert-deftest etaf-ui-pagination-successful-controller-swap-replaces-callbacks ()
"A successful controller swap publishes its current values and callbacks."
(let* ((first (etaf-ui-pagination-test--controller))
(second (etaf-ui-pagination-test--controller))
(selected (etaf-ref first))
(caption (etaf-ref "Sibling A"))
(buffer (generate-new-buffer " *pagination-controller-swap*")))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(column
(etaf-pagination :controller (etaf-value selected)
:previous-ref 'previous :next-ref 'next)
(text (expr (etaf-value caption)))))))
(let* ((runtime (etaf-runtime-for-buffer buffer))
(next-handler (cdr (assq 'press
(etaf-runtime-handler-for runtime 'next))))
(next-bounds (etaf-host-ref-bounds runtime 'next)))
(setf (etaf-value caption) "Sibling B")
(should (eq next-handler
(cdr (assq 'press (etaf-runtime-handler-for runtime 'next)))))
(should (equal next-bounds (etaf-host-ref-bounds runtime 'next)))
(etaf-dispatch-event runtime 'next 'press)
(should (= (etaf-value (etaf-data-page first)) 2))
(setf (etaf-value selected) second)
(should (string-match-p "Page 1 / 3"
(with-current-buffer buffer (buffer-string))))
(should-error (etaf-dispatch-event runtime 'previous 'press)
:type 'etaf-event-error)
(etaf-dispatch-event runtime 'next 'press)
(should (= (etaf-value (etaf-data-page second)) 2))
(should (= (etaf-value (etaf-data-page first)) 2))
(etaf-dispatch-event runtime 'previous 'press)
(should (= (etaf-value (etaf-data-page second)) 1))
(should (= (etaf-value (etaf-data-page first)) 2))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(etaf-data-stop first)
(etaf-data-stop second)
(kill-buffer buffer))))
(ert-deftest etaf-ui-pagination-labels-retain-hit-areas-and-disabled-states ()
"Localized labels keep complete Button hit areas and boundary semantics."
(let* ((controller (etaf-ui-pagination-test--controller))
(empty (etaf-data-controller
(etaf-data-memory-source nil :id-key :id)
:page-size 1 :auto-load t))
(selected (etaf-ref controller))
(buffer (generate-new-buffer " *pagination-labels*")))
(unwind-protect
(progn
(etaf-mount
buffer
(lambda ()
(etaf-view
(etaf-pagination :controller (etaf-value selected)
:previous-ref 'previous :next-ref 'next
:previous-label " 上一页" :next-label "下一页 "))))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(dolist (case '((previous " 上一页" "Previous page")
(next "下一页 " "Next page")))
(let* ((ref (car case))
(bounds (etaf-host-ref-bounds runtime ref))
(props (gethash ref (etaf-runtime-host-props runtime))))
(should bounds)
(should (equal (plist-get props :aria-label) (nth 2 case)))
(with-current-buffer buffer
(let ((text (buffer-substring-no-properties
(car bounds) (cdr bounds))))
(should (string-match-p (regexp-quote (nth 1 case)) text))
;; The clickable Host includes padding on both sides.
(should (> (string-width text)
(string-width (nth 1 case))))))))
(should-error (etaf-dispatch-event runtime 'previous 'press)
:type 'etaf-event-error)
(etaf-data-set-page controller 3)
(should-error (etaf-dispatch-event runtime 'next 'press)
:type 'etaf-event-error)
(etaf-dispatch-event runtime 'previous 'press)
(should (= (etaf-value (etaf-data-page controller)) 2))
(setf (etaf-value (etaf-data-status controller)) 'loading)
(dolist (ref '(previous next))
(should-error (etaf-dispatch-event runtime ref 'press)
:type 'etaf-event-error))
(setf (etaf-value selected) empty)
(should (string-match-p "00 of 0"
(with-current-buffer buffer (buffer-string))))
(dolist (ref '(previous next))
(should-error (etaf-dispatch-event runtime ref 'press)
:type 'etaf-event-error))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(etaf-data-stop empty)
(kill-buffer buffer))))
(ert-deftest etaf-ui-pagination-wraps-complete-controls-in-narrow-space ()
"A narrow allocation wraps whole controls without clipping page text."
(let ((controller (etaf-ui-pagination-test--controller))
(buffer (generate-new-buffer " *pagination-narrow*")))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-pagination :controller controller
:previous-ref 'previous :next-ref 'next)))
(dolist (width '(280 180 140))
(ebox-surface-update-buffer-viewport buffer width 30)
(with-current-buffer buffer
(let ((text (buffer-string)))
(dolist (label '(" Previous" "Next " "Page 1 / 3" "11 of 3"))
(should (string-match-p (regexp-quote label) text))))
(goto-char (point-min))
(while (< (point) (point-max))
(should (<= (ebox-string-pixel-width
(buffer-substring (line-beginning-position)
(line-end-position)))
(+ width 2)))
(forward-line 1)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(kill-buffer buffer))))
(ert-deftest etaf-ui-pagination-keeps-explicit-colors-and-semantic-defaults ()
"Explicit colors remain effective without replacing omitted variant defaults."
(dolist (styles '(nil (:color "#F01234" :bgcolor "#123456"
:border (1 solid "#ABCDEF"))))
(let ((controller (etaf-ui-pagination-test--controller)))
(with-temp-buffer
(unwind-protect
(progn
(etaf-data-set-page controller 2)
(etaf-mount
(current-buffer)
(etaf-node
'column nil
(list (etaf-node 'etaf-button
'(:label "Reference" :ref reference
:variant secondary) nil)
(etaf-node 'etaf-button
'(:label "Disabled" :ref disabled :disabled t) nil)
(etaf-node 'etaf-pagination
(append (list :controller controller
:previous-ref 'previous :next-ref 'next)
styles)
nil))))
(let* ((runtime (etaf-runtime-for-buffer (current-buffer)))
(reference (etaf-runtime-host-props-for runtime 'reference))
(disabled (etaf-runtime-host-props-for runtime 'disabled)))
(dolist (ref '(previous next))
(let ((props (etaf-runtime-host-props-for runtime ref)))
(should (equal (plist-get props :color)
(or (plist-get styles :color)
(plist-get reference :color))))
(should (equal (plist-get props :background-color)
(or (plist-get styles :bgcolor)
(plist-get reference :background-color))))
(when styles
(should (equal (plist-get props :border)
(plist-get styles :border))))))
(etaf-dispatch-event runtime 'previous 'press)
(let ((props (etaf-runtime-host-props-for runtime 'previous)))
(should (plist-get props :disabled))
(should (equal (plist-get props :color) (plist-get disabled :color)))
(should (equal (plist-get props :background-color)
(or (plist-get styles :bgcolor)
(plist-get disabled :background-color)))))))
(when-let* ((runtime (etaf-runtime-for-buffer (current-buffer))))
(etaf-unmount runtime))
(etaf-data-stop controller))))))
(provide 'etaf-ui-pagination-commit-tests)
;;; etaf-ui-pagination-commit-tests.el ends here

View File

@ -0,0 +1,274 @@
;;; etaf-ui-table-adaptive-tests.el --- Adaptive Table tracks -*- lexical-binding: t; -*-
;;; Commentary:
;; Mixed character and fractional columns share one header/row allocation.
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'etaf-ui)
(defvar etaf-ui-adaptive-test--states nil)
(defvar etaf-ui-adaptive-test--removed nil)
(etaf-define-component etaf-ui-adaptive-test-actions (&key row)
"Keep independent action state in ROW's adaptive table cell."
:setup
(let ((state (list (plist-get row :id) (etaf-ref 0)
(etaf-inject 'adaptive-table-context nil t))))
(push state etaf-ui-adaptive-test--states)
(etaf-on-unmounted
(lambda () (push (car state) etaf-ui-adaptive-test--removed)))
state)
:render
(let ((count (cadr (etaf-state)))
(id (plist-get row :id)))
(etaf-view
(row :item-gap 1
(etaf-button :label "Complete"
:ref (intern (format "adaptive-complete-%s" id))
:on-press (lambda () (cl-incf (etaf-value count))))
(etaf-button :label "Delete"
:ref (intern (format "adaptive-delete-%s" id))
:on-press #'ignore)))))
(defun etaf-ui-adaptive-test--action-cell (row)
"Build ROW's action cell, rejecting explicit bad candidates."
(when (plist-get row :fail) (error "Rejected adaptive cell"))
(etaf-node 'etaf-ui-adaptive-test-actions (list :row row) nil))
(etaf-define-component etaf-ui-adaptive-test-provider
(&key rows columns controller theme selected)
"Render a Table or CONTROLLER's DataGrid in the same themed environment."
:setup
(progn
(etaf-provide 'adaptive-table-context "consumer-context")
(etaf-theme-provide theme)
nil)
:render
(let ((selection selected))
(etaf-node
(if controller 'etaf-data-grid 'etaf-table)
(append
(list :columns columns :row-key (lambda (row) (plist-get row :id))
:row-ref (lambda (row) (intern (format "adaptive-row-%s" (plist-get row :id))))
:on-row-press (lambda (row) (setf (etaf-value selection) (plist-get row :id)))
:row-selected-p (lambda (row) (equal (etaf-value selection) (plist-get row :id))))
(if controller (list :controller controller) (list :rows rows)))
nil)))
(defun etaf-ui-adaptive-test--columns ()
"Return an expanding title and a fixed character action track."
(list '(:key :title :label "Task" :width (fr 1))
'(:key :actions :label "Actions" :width 22
:cell etaf-ui-adaptive-test--action-cell)))
(defun etaf-ui-adaptive-test--x (buffer position)
"Return POSITION's rendered horizontal pixel offset in BUFFER."
(with-current-buffer buffer
(save-excursion
(goto-char position)
(ebox-string-pixel-width
(buffer-substring (line-beginning-position) (point))))))
(defun etaf-ui-adaptive-test--background (runtime ref)
"Return the resolved background of RUNTIME's REF, including live paint."
(let ((value (plist-get (gethash ref (etaf-runtime-host-props runtime))
:background-color)))
(if (tp-paint-slot-p value)
(plist-get (tp-paint-slot-spec value) :background)
value)))
(defun etaf-ui-adaptive-test--assert-layout (buffer width)
"Check BUFFER's WIDTH, header alignment, and complete action hit targets."
(let* ((runtime (etaf-runtime-for-buffer buffer))
(header-x
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(search-forward "Actions")
(etaf-ui-adaptive-test--x buffer (- (point) (length "Actions")))))))
(dolist (id '(1 2))
(let* ((ref (intern (format "adaptive-complete-%s" id)))
(bounds (etaf-host-ref-bounds runtime ref))
(row-bounds (etaf-host-ref-bounds runtime (intern (format "adaptive-row-%s" id)))))
(should bounds)
(should (<= (car row-bounds) (car bounds)))
(should (<= (cdr bounds) (cdr row-bounds)))
(should (= header-x (etaf-ui-adaptive-test--x buffer (car bounds))))
(dolist (control '(complete delete))
(let* ((button (intern (format "adaptive-%s-%s" control id)))
(button-bounds (etaf-host-ref-bounds runtime button)))
(should button-bounds)
(with-current-buffer buffer
(should (string-match-p
(if (eq control 'complete) "Complete" "Delete")
(buffer-substring-no-properties
(car button-bounds) (cdr button-bounds)))))))))
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(while (< (point) (point-max))
(should (<= (ebox-string-pixel-width
(buffer-substring (line-beginning-position) (line-end-position)))
(+ width 2)))
(forward-line 1))))))
(ert-deftest etaf-ui-adaptive-columns-reject-invalid-fractional-weights ()
"Invalid fractional tracks identify the offending column before mounting."
(dolist (width '((fr) (fr 0) (fr -1) (fr "wide") (fr 1 extra)))
(let ((message
(error-message-string
(should-error
(etaf-render
(etaf-view
(etaf-table
:columns (list (list :key :title :width width))
:rows nil :row-key #'identity)))))))
(should (string-match-p "column 1 (:title)" message))
(should (string-match-p "POSITIVE-WEIGHT" message)))))
(ert-deftest etaf-ui-adaptive-columns-align-and-preserve-actions-on-resize ()
"Table and DataGrid allocate matching adaptive tracks through live updates."
(dolist (grid-p '(nil t))
(let* ((etaf-ui-adaptive-test--states nil)
(etaf-ui-adaptive-test--removed nil)
(rows '((:id 1 :title "A long task title that must fit its assigned track without moving actions")
(:id 2 :title "Short task")))
(controller (and grid-p (etaf-data-controller
(etaf-data-memory-source rows :id-key :id)
:page-size 10 :auto-load t)))
(selected (etaf-ref nil))
(theme (etaf-ref '(:ui-fg "#152030" :ui-table-border "#CBD5E1"
:ui-table-selected-bg "#DBEAFE")))
(buffer (generate-new-buffer " *adaptive-table*")))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-ui-adaptive-test-provider
:rows rows :columns (etaf-ui-adaptive-test--columns)
:controller controller :theme theme :selected selected)))
(let ((runtime (etaf-runtime-for-buffer buffer)) previous-x)
(dolist (width '(420 760 280 420))
(ebox-surface-update-buffer-viewport buffer width 30)
(etaf-ui-adaptive-test--assert-layout buffer width)
(let* ((bounds (etaf-host-ref-bounds runtime 'adaptive-complete-1))
(x (etaf-ui-adaptive-test--x buffer (car bounds))))
(when (= width 760) (should (> x previous-x)))
(setq previous-x x))
(etaf-dispatch-event runtime 'adaptive-complete-1 'press)
(let* ((id (if (equal (etaf-value selected) 2) 1 2))
(ref (intern (format "adaptive-row-%s" id))))
(etaf-dispatch-event runtime ref 'press)
(should (= (etaf-value selected) id))
(should (equal "#DBEAFE"
(etaf-ui-adaptive-test--background runtime ref)))))
(let ((bounds (etaf-host-ref-bounds runtime 'adaptive-complete-1))
(selected-ref (intern (format "adaptive-row-%s" (etaf-value selected)))))
(setf (etaf-value theme)
'(:ui-fg "#F1F5F9" :ui-table-border "#475569"
:ui-table-selected-bg "#334155"
:ui-button-primary-bg "#2563EB"))
(etaf-ui-adaptive-test--assert-layout buffer 420)
(should (equal bounds (etaf-host-ref-bounds runtime 'adaptive-complete-1)))
(should (equal "#334155" (etaf-ui-adaptive-test--background
runtime selected-ref)))
(should (equal "#2563EB" (etaf-ui-adaptive-test--background
runtime 'adaptive-complete-1))))
(should (= 2 (length etaf-ui-adaptive-test--states)))
(should-not etaf-ui-adaptive-test--removed)
(should (= 4 (etaf-value (cadr (assq 1 etaf-ui-adaptive-test--states)))))
(dolist (state etaf-ui-adaptive-test--states)
(should (equal "consumer-context" (nth 2 state))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer))) (etaf-unmount runtime))
(when controller (etaf-data-stop controller))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-adaptive-cells-retain-identity-and-failed-candidates ()
"Adaptive row/column reorders preserve local state and rollback ownership."
(let* ((etaf-ui-adaptive-test--states nil)
(etaf-ui-adaptive-test--removed nil)
(rows (etaf-ref '((:id 1 :title "First") (:id 2 :title "Second"))))
(columns (etaf-ref (etaf-ui-adaptive-test--columns)))
(theme (etaf-ref nil))
(selected (etaf-ref nil))
(buffer (generate-new-buffer " *adaptive-retention*")))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-view
(etaf-ui-adaptive-test-provider
:rows (etaf-value rows) :columns (etaf-value columns)
:theme theme :selected selected)))
(let ((runtime (etaf-runtime-for-buffer buffer)))
(ebox-surface-update-buffer-viewport buffer 420 30)
(etaf-dispatch-event runtime 'adaptive-complete-1 'press)
;; Width is geometry, not cell ownership. Keep the same keys and
;; action Component through both fixed-to-fr and fr-to-fixed paths.
(dolist (width '(18 (fr 1) 26 (fr 2)))
(setf (etaf-value columns)
(list (list :key :title :label "Task" :width width)
(cadr (etaf-ui-adaptive-test--columns))))
(should (= 2 (length etaf-ui-adaptive-test--states)))
(should-not etaf-ui-adaptive-test--removed)
(should (= 1 (etaf-value (cadr (assq 1 etaf-ui-adaptive-test--states))))))
(setf (etaf-value columns) (reverse (etaf-value columns))
(etaf-value rows) (reverse (etaf-value rows)))
(should (= 2 (length etaf-ui-adaptive-test--states)))
(should-not etaf-ui-adaptive-test--removed)
(let ((text (with-current-buffer buffer (buffer-string)))
(generation (etaf-runtime-current-generation runtime)))
(should-error
(setf (etaf-value rows)
'((:id 1 :title "Candidate") (:id 2 :title "Rejected" :fail t))))
(should (eq generation (etaf-runtime-current-generation runtime)))
(should (equal-including-properties text (with-current-buffer buffer (buffer-string)))))
(etaf-dispatch-event runtime 'adaptive-complete-1 'press)
(should (= 2 (etaf-value (cadr (assq 1 etaf-ui-adaptive-test--states)))))
(setf (etaf-value rows) '((:id 1 :title "Recovered")))
(should (equal '(2) etaf-ui-adaptive-test--removed))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer))) (etaf-unmount runtime))
(kill-buffer buffer))))
(ert-deftest etaf-ui-table-string-column-keys-read-equal-alist-keys ()
"Table and DataGrid read string keys in both fixed and adaptive cells."
(dolist (grid-p '(nil t))
(dolist (width '(12 (fr 1)))
(let* ((column-key (copy-sequence "name"))
(row-key (copy-sequence "name"))
(rows (list (list (cons :id 1) (cons row-key "Ada"))))
(controller
(and grid-p
(etaf-data-controller
(etaf-data-memory-source rows :id-key :id)
:page-size 10 :auto-load t)))
(buffer (generate-new-buffer " *string-column-key*")))
(should (equal column-key row-key))
(should-not (eq column-key row-key))
(unwind-protect
(progn
(etaf-mount
buffer
(etaf-node
(if grid-p 'etaf-data-grid 'etaf-table)
(append
(list :columns (list (list :key column-key :label "Name"
:width width))
:row-key (lambda (row) (alist-get :id row)))
(if grid-p (list :controller controller) (list :rows rows)))
nil)
'(:viewport-width 300 :viewport-height 10))
(should (string-match-p "Ada" (with-current-buffer buffer
(buffer-string)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-unmount runtime))
(when controller (etaf-data-stop controller))
(kill-buffer buffer))))))
(provide 'etaf-ui-table-adaptive-tests)
;;; etaf-ui-table-adaptive-tests.el ends here

View File

@ -1,5 +1,7 @@
;;; etaf-ui-tests.el --- Official ETAF Component tests -*- lexical-binding: t; -*-
;;; Code:
(require 'ert)
(require 'etaf-ui)
@ -29,11 +31,15 @@
(let (found)
(maphash
(lambda (_ref props)
(when (equal (plist-get props :class) class)
(when (member class (etaf--class-tokens (plist-get props :class)))
(setq found props)))
(etaf-runtime-host-props (etaf-runtime-for-buffer buffer-name)))
found))
(defun etaf-ui-test--has-class-p (props class)
"Return non-nil when PROPS contain CLASS."
(member class (etaf--class-tokens (plist-get props :class))))
(defun etaf-ui-test--paint-color (value property)
"Return effective paint color from VALUE for Ebox PROPERTY."
(if (not (tp-paint-slot-p value))
@ -63,49 +69,50 @@
:setup
(progn
(etaf-theme-provide '(:color "theme-color"
:bgcolor "theme-bg"
:background-color "theme-bg"
:padding (9 9)))
(lambda ()
(etaf-view
(row
(button :label "Styled" :ref 'styled-button)
(button :label "Custom" :ref 'custom-button
nil)
:view
(row
(etaf-button :label "Styled" :ref 'styled-button)
(etaf-button :label "Custom" :ref 'custom-button
:color "explicit-color")
(label :text "Themed" :ref 'themed-label
(etaf-label :text "Themed" :ref 'themed-label
:color nil :bgcolor nil)
(panel :title "Styled panel" :ref 'styled-panel))))))
(text :ref 'themed-host :color nil :bgcolor nil "Theme defaults")
(etaf-panel :title "Styled panel" :ref 'styled-panel)))
(etaf-define-component etaf-ui-test-token-theme-fixture ()
"Provide explicit UI Button tokens through ETAF Theme."
:setup
(progn
(etaf-theme-provide
'(:ui-button-color "token-fg"
:ui-button-bgcolor "token-bg"
:ui-button-border "token-border"
:ui-button-secondary-color "secondary-fg"
:ui-button-secondary-bgcolor "secondary-bg"
'(:ui-button-primary-fg "token-fg"
:ui-button-primary-bg "token-bg"
:ui-button-primary-border "token-border"
:ui-button-secondary-fg "secondary-fg"
:ui-button-secondary-bg "secondary-bg"
:ui-button-secondary-border "secondary-border"))
(lambda ()
(etaf-view
(row
(button :label "Token" :ref 'token-button)
(button :label "Secondary" :ref 'token-secondary
:variant 'secondary))))))
nil)
:view
(row
(etaf-button :label "Token" :ref 'token-button)
(etaf-button :label "Secondary" :ref 'token-secondary
:variant 'secondary)))
(etaf-define-component etaf-ui-test-grid-theme-fixture
(&key controller theme)
"Provide a reactive Theme around one DataGrid for palette tests."
:setup
(progn
(etaf-theme-provide (etaf-current-prop :theme))
(lambda ()
(etaf-view
(data-grid
:controller (etaf-current-prop :controller)
:columns '((:key :id :label "ID") (:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:selected-key 1)))))
(etaf-theme-provide theme)
nil)
:view
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID") (:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:row-selected-p (lambda (row) (= (plist-get row :id) 1))))
(ert-deftest etaf-ui-button-use-behavior-dispatches-through-host ()
"Install Button `:use' Behavior and dispatch its merged callback."
@ -116,7 +123,7 @@
(etaf-mount
buffer-name
(etaf-view
(button :label "Behavior" :ref 'behavior-button
(etaf-button :label "Behavior" :ref 'behavior-button
:use (list (etaf-ui-test-press-behavior)))))
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
'behavior-button 'press)
@ -132,21 +139,26 @@
(unwind-protect
(progn
(etaf-mount buffer-name
(etaf-view (ui-test-theme-fixture)))
(etaf-view (etaf-ui-test-theme-fixture)))
(let ((styled (etaf-ui-test--props buffer-name 'styled-button))
(custom (etaf-ui-test--props buffer-name 'custom-button))
(themed (etaf-ui-test--props buffer-name 'themed-label))
(host (etaf-ui-test--props buffer-name 'themed-host))
(panel (etaf-ui-test--props buffer-name 'styled-panel)))
(should (equal (plist-get styled :color) "#FFFFFF"))
(should (equal (plist-get styled :bgcolor) "#2F6B43"))
(should (equal (plist-get styled :background-color) "#2F6B43"))
(should (equal (plist-get styled :padding) '(0 1)))
(should (equal (plist-get custom :color) "explicit-color"))
(should (equal (plist-get custom :bgcolor) "#2F6B43"))
(should (equal (plist-get themed :color) "theme-color"))
(should (equal (plist-get themed :bgcolor) "theme-bg"))
(should (equal (plist-get custom :background-color) "#2F6B43"))
;; Nil fallthrough omits an override; it does not erase Label's
;; explicit presentation. An omitted Host value uses Theme.
(should (equal (plist-get themed :color) "#252A2E"))
(should (equal (plist-get themed :background-color) "theme-bg"))
(should (equal (plist-get host :color) "theme-color"))
(should (equal (plist-get host :background-color) "theme-bg"))
(should-not (plist-get themed :padding))
(should (equal (plist-get panel :color) "#252A2E"))
(should (equal (plist-get panel :bgcolor) "#FFFDF8"))
(should (equal (plist-get panel :background-color) "#FFFDF8"))
(should (equal (plist-get panel :padding) '(1 2)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
@ -159,14 +171,15 @@
(unwind-protect
(progn
(etaf-mount buffer-name
(etaf-view (ui-test-token-theme-fixture)))
(etaf-view (etaf-ui-test-token-theme-fixture)))
(let ((token (etaf-ui-test--props buffer-name 'token-button))
(secondary (etaf-ui-test--props buffer-name 'token-secondary)))
(should (equal "token-fg" (plist-get token :color)))
(should (equal "token-bg" (plist-get token :bgcolor)))
(should (equal "token-bg" (plist-get token :background-color)))
(should (equal "token-border" (plist-get token :border)))
(should (equal "secondary-fg" (plist-get secondary :color)))
(should (equal "secondary-bg" (plist-get secondary :bgcolor)))
(should (equal "secondary-bg"
(plist-get secondary :background-color)))
(should (equal "secondary-border"
(plist-get secondary :border)))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
@ -183,7 +196,7 @@
(etaf-mount
buffer-name
(etaf-view
(number-input :label "Rows" :value value :ref 'rows
(etaf-number-input :label "Rows" :value value :ref 'rows
:min 1 :max 10
:on-change (lambda (next) (setq value next)))))
(cl-letf (((symbol-function 'read-number)
@ -204,7 +217,7 @@
(progn
(etaf-mount buffer-name
(etaf-view
(button :label "Save" :ref 'save
(etaf-button :label "Save" :ref 'save
:class "primary"
:color "#FFFFFF"
:bgcolor "#2F6B43"
@ -221,11 +234,11 @@
(should (equal (plist-get props :tab-index) 3))
(should (equal (plist-get props :aria-label) "Save changes"))
(should (equal (plist-get props :color) "#FFFFFF"))
(should (equal (plist-get props :bgcolor) "#2F6B43"))
(should (equal (plist-get props :background-color) "#2F6B43"))
(should (equal (plist-get props :border) "#2F6B43"))
(should (equal (plist-get props :padding) '(0 2)))
(should (equal (plist-get props :font-weight) 'bold))
(should (string-match-p "primary" (plist-get props :class))))
(should (etaf-ui-test--has-class-p props "primary")))
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
'save 'press)
(should (= presses 1)))
@ -244,22 +257,22 @@
(etaf-mount buffer-name
(etaf-view
(row
(button :label "Save" :ref 'enabled-save
(etaf-button :label "Save" :ref 'enabled-save
:on-press (lambda () (cl-incf presses)))
(button :label "Delete" :ref 'disabled-delete
(etaf-button :label "Delete" :ref 'disabled-delete
:disabled t
:use (list (etaf-ui-test-press-behavior))
:on-press (lambda () (cl-incf presses))))))
(let ((props (etaf-ui-test--props buffer-name 'enabled-save)))
(should (equal (plist-get props :color) "#FFFFFF"))
(should (equal (plist-get props :bgcolor) "#2F6B43"))
(should (equal (plist-get props :background-color) "#2F6B43"))
(should (equal (plist-get props :padding) '(0 1)))
(should (equal (plist-get props :font-weight) 'bold)))
(let ((props (etaf-ui-test--props buffer-name 'disabled-delete)))
(should (eq (plist-get props :disabled) t))
(should-not (plist-get props :tab-index))
(should (equal (plist-get props :bgcolor) "#E5E7EB"))
(should (string-match-p "disabled" (plist-get props :class))))
(should (equal (plist-get props :background-color) "#E5E7EB"))
(should (etaf-ui-test--has-class-p props "disabled")))
(should-error
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
'disabled-delete 'press)
@ -283,7 +296,7 @@
(etaf-mount
buffer-name
(etaf-view
(button :label "Unavailable" :ref 'themed-disabled
(etaf-button :label "Unavailable" :ref 'themed-disabled
:disabled t :color "#F4F7FF" :bgcolor "#202C42"
:border "#34435A")))
(let ((position
@ -294,11 +307,11 @@
(with-current-buffer buffer-name
(let ((face (get-text-property position 'face)))
(should (string-match-p "#202C42" (format "%S" face)))
(should (string-match-p "#F4F7FF" (format "%S" face))))))
(should (string-match-p "#F4F7FF" (format "%S" face)))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-button-dispatches-without-retained-press-state ()
"Buttons dispatch through semantic Host state without local press state."
@ -309,12 +322,12 @@
(etaf-mount
buffer-name
(etaf-view
(button :label "Run health check" :ref 'health
(etaf-button :label "Run health check" :ref 'health
:variant 'secondary
:on-press (lambda () (cl-incf presses)))))
(let ((props (etaf-ui-test--props buffer-name 'health)))
(should (equal (plist-get props :color) "#142235"))
(should (equal (plist-get props :bgcolor) "#D9EEEA")))
(should (equal (plist-get props :background-color) "#D9EEEA")))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(before (cdr (assq 'press
(etaf-runtime-handler-for runtime 'health)))))
@ -347,7 +360,7 @@
(progn
(etaf-mount buffer-name
(etaf-view
(checkbox :label "Done" :ref 'done
(etaf-checkbox :label "Done" :ref 'done
:checked (etaf-value checked)
:on-change (lambda (value)
(setq next value)
@ -382,7 +395,7 @@
(etaf-mount
buffer-name
(etaf-view
(checkbox :label "Live" :ref 'live-checkbox :checked checked
(etaf-checkbox :label "Live" :ref 'live-checkbox :checked checked
:on-change (lambda (value)
(setf (etaf-value checked) value)))))
(let ((render (symbol-function
@ -410,7 +423,7 @@
(unwind-protect
(progn
(etaf-mount buffer-name
(etaf-view (label :text text :ref 'live-label)))
(etaf-view (etaf-label :text text :ref 'live-label)))
(let ((render (symbol-function
'etaf--runtime-render-dirty-component)))
(cl-letf (((symbol-function 'etaf--runtime-render-dirty-component)
@ -434,18 +447,18 @@
(etaf-mount buffer-name
(etaf-view
(row
(checkbox :label "Open" :ref 'open-box
(etaf-checkbox :label "Open" :ref 'open-box
:on-change (lambda (_value)
(cl-incf changes)))
(checkbox :label "Closed" :ref 'closed-box
(etaf-checkbox :label "Closed" :ref 'closed-box
:disabled t
:on-change (lambda (_value)
(cl-incf changes))))))
(let ((props (etaf-ui-test--props buffer-name 'closed-box)))
(should (eq (plist-get props :disabled) t))
(should-not (plist-get props :tab-index))
(should (equal (plist-get props :bgcolor) "#EEEAE2"))
(should (string-match-p "disabled" (plist-get props :class))))
(should (equal (plist-get props :background-color) "#EEEAE2"))
(should (etaf-ui-test--has-class-p props "disabled")))
(should-error
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
'closed-box 'press)
@ -468,25 +481,28 @@
(etaf-mount
buffer-name
(etaf-view
(panel :title "Account" :ref 'account-panel
:class "surface" :color "#252A2E" :bgcolor "#FFFDF8"
(etaf-panel :title "Account" :ref 'account-panel
:class "surface" :color "#252A2E"
:background-color "#FFFDF8"
:border "#687386" :padding '(1 2)
(slot :name 'header
(label :text "Settings" :ref 'settings-label
:class "eyebrow" :color "#66706A"
:font-weight 'bold :width 12))
(label :text "Body"))))
(box :width 12 :ref 'settings-cell
(etaf-label :text "Settings" :ref 'settings-label
:class "eyebrow" :color "#66706A"
:font-weight 'bold)))
(etaf-label :text "Body"))))
(let ((panel (etaf-ui-test--props buffer-name 'account-panel))
(label (etaf-ui-test--props buffer-name 'settings-label)))
(should (string-match-p "surface" (plist-get panel :class)))
(label (etaf-ui-test--props buffer-name 'settings-label))
(cell (etaf-ui-test--props buffer-name 'settings-cell)))
(should (etaf-ui-test--has-class-p panel "surface"))
(should (equal (plist-get panel :color) "#252A2E"))
(should (equal (plist-get panel :bgcolor) "#FFFDF8"))
(should (equal (plist-get panel :background-color) "#FFFDF8"))
(should (equal (plist-get panel :border) "#687386"))
(should (equal (plist-get panel :padding) '(1 2)))
(should (string-match-p "eyebrow" (plist-get label :class)))
(should (etaf-ui-test--has-class-p label "eyebrow"))
(should (equal (plist-get label :color) "#66706A"))
(should (equal (plist-get label :font-weight) 'bold))
(should (equal (plist-get label :width) 12)))
(should (equal (plist-get cell :width) 12)))
(dolist (label '("Account" "Settings" "Body"))
(should (string-match-p (regexp-quote label)
(etaf-ui-test--text buffer-name)))))
@ -508,14 +524,14 @@
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID")
(:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:row-ref (lambda (row)
(intern (format "row-%d" (plist-get row :id))))
:selected-key 2
:row-selected-p (lambda (row) (= (plist-get row :id) 2))
:on-row-press (lambda (row) (setq pressed row)))))
(should (string-match-p "Ada" (etaf-ui-test--text buffer-name)))
(let ((first (etaf-ui-test--props buffer-name 'row-1))
@ -524,10 +540,8 @@
(should (equal (plist-get first :tab-index) 0))
(should (equal (plist-get second :role) 'button))
(should (equal (plist-get second :tab-index) 0))
(should (string-match-p
"selected" (or (plist-get second :class) "")))
(should-not (string-match-p
"selected" (or (plist-get first :class) ""))))
(should (etaf-ui-test--has-class-p second "selected"))
(should-not (etaf-ui-test--has-class-p first "selected")))
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(handler (cdr (assq 'press
(etaf-runtime-handler-for runtime
@ -557,15 +571,13 @@
:id-key :id))
(controller (etaf-data-controller source :auto-load t))
(buffer-name " *etaf-ui-grid-keyed-selection-test*")
(row-renders (make-hash-table :test #'eql))
(body-renders 0)
host-updates)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID")
(:key :name :label "Name"))
@ -581,23 +593,11 @@
(third-handler
(cdr (assq 'press
(etaf-runtime-handler-for runtime 'keyed-row-3))))
(old-grid-row (symbol-function 'etaf-ui--grid-row))
(old-grid-rows (symbol-function 'etaf-ui--grid-rows))
(old-host
(symbol-function 'ebox-candidate-replace-host-ref))
(old-paint
(symbol-function 'ebox-candidate-patch-host-paint)))
(cl-letf (((symbol-function 'etaf-ui--grid-row)
(lambda (&rest args)
(let ((key (nth 1 args)))
(puthash key (1+ (gethash key row-renders 0))
row-renders))
(apply old-grid-row args)))
((symbol-function 'etaf-ui--grid-rows)
(lambda (&rest args)
(cl-incf body-renders)
(apply old-grid-rows args)))
((symbol-function 'ebox-candidate-replace-host-ref)
(cl-letf (((symbol-function 'ebox-candidate-replace-host-ref)
(lambda (candidate ref node)
(push ref host-updates)
(funcall old-host candidate ref node)))
@ -608,11 +608,6 @@
;; Prove direct public selection ref writes use the same keyed
;; invalidation path as the selection helpers.
(setf (etaf-value (etaf-data-selection controller)) '(2)))
(should (zerop (gethash 1 row-renders 0)))
(should (zerop (gethash 2 row-renders 0)))
(should (zerop (gethash 3 row-renders 0)))
(should (zerop (hash-table-count row-renders)))
(should (zerop body-renders))
(should (member 'keyed-row-1 host-updates))
(should (member 'keyed-row-2 host-updates))
(should-not (member 'keyed-row-3 host-updates))
@ -642,10 +637,10 @@
(ert-deftest etaf-ui-data-grid-follows-inherited-theme-color ()
"Re-render DataGrid rows when only inherited Theme color changes."
(let* ((theme (etaf-ref '(:color "light-ink"
:ui-grid-border "light-grid-border"
:ui-grid-selected-fg "light-selected"
:ui-grid-selected-bg "light-selected-bg")))
(let* ((theme (etaf-ref '(:ui-fg "light-ink"
:ui-table-border "light-grid-border"
:ui-table-selected-fg "light-selected"
:ui-table-selected-bg "light-selected-bg")))
(source (etaf-data-memory-source
'((:id 1 :name "Ada") (:id 2 :name "Grace")) :id-key :id))
(controller (etaf-data-controller source :auto-load t))
@ -655,27 +650,36 @@
(etaf-mount
buffer-name
(etaf-view
(ui-test-grid-theme-fixture :controller controller :theme theme)))
(etaf-ui-test-grid-theme-fixture
:controller controller :theme theme)))
(let* ((props (etaf-ui-test--props-with-key buffer-name 1))
(background-slot (plist-get props :bgcolor))
(foreground-slot (plist-get props :color))
(background-slot (plist-get props :background-color))
(border-slot (plist-get props :border-bottom-color)))
(should (equal "light-selected"
(etaf-ui-test--paint-color
foreground-slot :color)))
(should (equal "light-selected-bg"
(etaf-ui-test--paint-color
background-slot :bgcolor)))
(should (equal "light-grid-border"
(etaf-ui-test--paint-color
border-slot :border-bottom-color)))
(let ((row-props
(etaf-ui-test--props-with-key buffer-name 1)))
(should (= (plist-get row-props :border-bottom-width) 1))
(should (eq (plist-get row-props :border-bottom-style) 'solid)))
(setf (etaf-value theme) '(:color "dark-ink"
:ui-grid-border "dark-grid-border"
:ui-grid-selected-fg "dark-selected"
:ui-grid-selected-bg "dark-selected-bg"))
(should (= (plist-get props :border-bottom-width) 1))
(should (eq (plist-get props :border-bottom-style) 'solid))
(setf (etaf-value theme) '(:ui-fg "dark-ink"
:ui-table-border "dark-grid-border"
:ui-table-selected-fg "dark-selected"
:ui-table-selected-bg "dark-selected-bg"))
(let ((next (etaf-ui-test--props-with-key buffer-name 1)))
(should (eq background-slot (plist-get next :bgcolor)))
(should (eq border-slot (plist-get next :border-bottom-color)))
(should (eq background-slot
(plist-get next :background-color)))
(should (eq border-slot
(plist-get next :border-bottom-color)))
(should (eq foreground-slot (plist-get next :color)))
(should (equal "dark-selected"
(etaf-ui-test--paint-color
foreground-slot :color)))
(should (equal "dark-selected-bg"
(etaf-ui-test--paint-color
background-slot :bgcolor)))
@ -689,7 +693,7 @@
(kill-buffer buffer)))))
(ert-deftest etaf-ui-pagination-is-readable-and-boundary-safe ()
"Pagination renders Unicode controls, stable refs, and page boundaries."
"Pagination renders labeled controls, stable refs, and page boundaries."
(let* ((source (etaf-data-memory-source
'((:id 1) (:id 2) (:id 3) (:id 4) (:id 5))
:id-key :id))
@ -700,12 +704,12 @@
(etaf-mount
buffer-name
(etaf-view
(pagination :controller controller
(etaf-pagination :controller controller
:previous-ref 'page-previous
:next-ref 'page-next)))
(should (string-match-p "Page 1 / 3" (etaf-ui-test--text buffer-name)))
(should (string-match-p "" (etaf-ui-test--text buffer-name)))
(should (string-match-p "" (etaf-ui-test--text buffer-name)))
(should (string-match-p " Previous" (etaf-ui-test--text buffer-name)))
(should (string-match-p "Next " (etaf-ui-test--text buffer-name)))
;; Live Ebox windows reserve two pixels for the exclusive display
;; boundary; the pager must stay inside the corresponding 360px row.
(ebox-surface-update-buffer-viewport (get-buffer buffer-name) 358 20)
@ -750,7 +754,7 @@
(text "Left")
(column
:width 'stretch :padding '(0 2) :border "#CBD5E1"
(pagination :controller controller
(etaf-pagination :controller controller
:previous-ref 'nested-page-previous
:next-ref 'nested-page-next))
(text "Right"))))
@ -780,7 +784,7 @@
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :title :label "Title" :width 22))
:row-key (lambda (row) (plist-get row :id)))))
@ -804,7 +808,7 @@
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :progress :label "Progress" :width 8)
(:key :kind :label "Kind" :width 7))
@ -817,6 +821,26 @@
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-table-fixed-row-text-is-exact-and-fail-closed ()
"Pad fixed-width rows exactly and retain the general path otherwise."
(should
(equal "Ada Essay "
(etaf-ui--table-fixed-row-text
'(:name "Ada" :kind "Essay")
'((:key :name :width 5) (:key :kind :width 7)))))
(should-not
(etaf-ui--table-fixed-row-text
'(:name "Ada" :kind "Essay")
'((:key :name :width 5) (:key :kind))))
(should
(equal "Name Kind "
(etaf-ui--table-fixed-header-text
'((:key :name :label "Name" :width 5)
(:key :kind :label "Kind" :width 7)))))
(should-not
(etaf-ui--table-fixed-header-text
'((:key :name :width 5) (:key :kind)))))
(ert-deftest etaf-ui-data-grid-noninteractive-rows-have-no-focus-contract ()
"Rows without ON-ROW-PRESS have no role, ref callback, or tab stop."
(let* ((source (etaf-data-memory-source '((:id 1 :name "Ada"))
@ -828,7 +852,7 @@
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID"))
:row-key (lambda (row) (plist-get row :id)))))
@ -841,22 +865,34 @@
(when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-data-grid-requires-row-ref-for-interaction ()
"Reject an interactive DataGrid without a row-ref callback."
(ert-deftest etaf-ui-data-grid-owns-default-interaction-ref ()
"Dispatch an interactive DataGrid row through its internal stable ref."
(let* ((source (etaf-data-memory-source '((:id 1 :name "Ada"))
:id-key :id))
(controller (etaf-data-controller source :auto-load t))
(buffer-name " *etaf-ui-grid-row-ref-test*"))
(buffer-name " *etaf-ui-grid-row-ref-test*")
pressed)
(unwind-protect
(should-error
(etaf-mount
buffer-name
(etaf-view
(data-grid
:controller controller
:columns '((:key :id :label "ID"))
:row-key (lambda (row) (plist-get row :id))
:on-row-press (lambda (_row) t)))))
(progn
(etaf-mount
buffer-name
(etaf-view
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID"))
:row-key (lambda (row) (plist-get row :id))
:on-row-press (lambda (row) (setq pressed row)))))
(let (host-ref)
(maphash
(lambda (ref props)
(when (equal (plist-get props :key) 1)
(setq host-ref ref)))
(etaf-runtime-host-props
(etaf-runtime-for-buffer buffer-name)))
(should host-ref)
(etaf-dispatch-event
(etaf-runtime-for-buffer buffer-name) host-ref 'press)
(should (equal (plist-get pressed :id) 1))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
@ -874,7 +910,7 @@
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID"))
:row-key (lambda (row) (plist-get row :id))
@ -899,12 +935,11 @@
(progn
(setf (etaf-value (etaf-data-status controller))
(car case))
(setf (etaf-value (etaf-data-items controller))
(when (eq (car case) 'empty) nil))
(setf (etaf-value (etaf-data-items controller)) nil)
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID"))
:row-key (lambda (row) (plist-get row :id))
@ -934,7 +969,7 @@
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID"))))))
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
@ -955,7 +990,7 @@
(etaf-mount
buffer-name
(etaf-view
(data-grid
(etaf-data-grid
:controller controller
:columns '((:key :id :label "ID"))
:row-key (lambda (_row) nil)))))