geekinney/etaf-ui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat: support reusable table cells and adaptive columns

Browse Source
This commit is contained in:
Kinneyzhang 2026-09-06 11:24:19 +08:00
parent a3647665c7
commit 591e2a2ead
12 changed files with 1807 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
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. `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 ```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf-ui) (require 'etaf-ui)
(let ((done (etaf-ref nil))) (etaf-define-component demo-preferences ()
(etaf-view :setup (list (etaf-ref nil) (etaf-ref "Unsaved"))
(panel :title "Account" :render
(slot :name 'header (let* ((state (etaf-state))
(button :label "Save" :ref 'save-button (done (car state))
:on-press (lambda () (message "saved")))) (saved (cadr state)))
(label :text "Preferences") (etaf-view
(checkbox :checked (etaf-value done) :label "Done" (etaf-panel :title "Account"
:ref 'done-checkbox (slot :name 'header
:on-change (lambda (next) (etaf-button :label "Save" :ref 'save-button
(setf (etaf-value done) next)))))) :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`, Core does not automatically load `.etaf` files. The optional Playground reads
`checkbox`, and `data-grid`) for structure. The companion `.el` file owns inert structural source and explicitly loads its registered Elisp companion;
reactive values, Actions, Behaviors, and callbacks; keep the `etaf-view` tree that file format does not create shorter Component aliases. Local callbacks
made from those same short tags. Canonical `etaf-*` names remain the Elisp need no named Action. Components receive props and slots through the same API
definition and API names. as application-defined Components.
Button and Checkbox are controlled Components. `etaf-button` accepts `:label`, Button and Checkbox are controlled Components. `etaf-button` accepts `:label`,
`:on-press`, `:disabled`, `:ref`, and the small presentation set `: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 an explicit `:on-*` callback with a Behavior callback; the UI package only
declares the control and its visual state. declares the control and its visual state.
Spacing is owned by the parent layout, not by Button. Put adjacent controls in The parent owns spacing: use `(row :item-gap 1 ...)` or
a `row`/`flex` with an explicit horizontal `:gap`; this keeps each control's `(column :item-gap 1 ...)`; `flex` and `grid` use `:gap`. In particular, migrate
mouse-face and hit range semantically separate. `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`, `etaf-label` accepts `:text`, `:class`, `:color`, `:bgcolor`, `:font-weight`,
`:width`, `:border`, `:padding`, and `:ref`. `: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-number-input` | `:value`, `:label`, `:on-change`, `:disabled`, `:min`, `:max` |
| `etaf-table` | `:columns`, `:rows`, `:row-key`, `:row-ref`, `:on-row-press`, `:row-selected-p` | | `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-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 --> <!-- M0b1: single-host-root -->
Every public catalog Component mounts exactly one Host root. All valid Host Every public catalog Component mounts exactly one Host root. All valid Host
@ -104,6 +136,11 @@ optional `:loading-label`, `:error-label`, `:empty-label`, or function-valued
interactive button with role `button` and tab index `0`; the callback receives 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. 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 --> <!-- M0b1: row-ref-optional -->
`:row-ref` is optional for DataGrid. When it is omitted on an interactive `: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 grid, DataGrid derives a stable internal Host reference from the row identity
@ -116,13 +153,80 @@ retains one action closure per row key, so selection or Data Range updates do
not recreate handlers for unchanged rows. not recreate handlers for unchanged rows.
An integer column `:width` is readable character capacity, not a raw pixel An integer column `:width` is readable character capacity, not a raw pixel
value. DataGrid passes Ebox's native character unit through and reserves one 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 `etaf-pagination` is a controlled Data Component. It accepts a Data controller
plus stable `:previous-ref` and `:next-ref` values, renders readable `←`/`→` plus stable `:previous-ref` and `:next-ref` values, renders padded secondary
controls and a `Page N / M` summary, and disables the boundary action while a 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 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 Keyboard focus uses ETAF's public runtime ports: call
`(etaf-focus-next runtime)` to move through visible Hosts with a numeric `(etaf-focus-next runtime)` to move through visible Hosts with a numeric

135
README.zh-CN.md
View File

@ -2,26 +2,41 @@
`etaf-ui` 是 ETAF 的官方 Component 目录，是建立在 `etaf` 之上的可选独立包。它不增加第二套 Control 或 Widget 模型；Button、Checkbox、Label、Panel、DataGrid 都是使用同一套 View、属性、slot、事件和 Data 契约的普通 Component。 `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 ```elisp
;;; -*- lexical-binding: t; -*-
(require 'etaf-ui) (require 'etaf-ui)
(let ((done (etaf-ref nil))) (etaf-define-component demo-preferences ()
(etaf-view :setup (list (etaf-ref nil) (etaf-ref "Unsaved"))
(panel :title "Account" :render
(slot :name 'header (let* ((state (etaf-state))
(button :label "Save" :ref 'save-button (done (car state))
:on-press (lambda () (message "saved")))) (saved (cadr state)))
(label :text "Preferences") (etaf-view
(checkbox :checked (etaf-value done) :label "Done" (etaf-panel :title "Account"
:ref 'done-checkbox (slot :name 'header
:on-change (lambda (next) (etaf-button :label "Save" :ref 'save-button
(setf (etaf-value done) next)))))) :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`、 Core 不会自动加载 `.etaf`。可选的 Playground 读取 inert 结构源，并显式加载
`checkbox`、`data-grid`）。配套 `.el` 文件负责响应式值、Action、Behavior 已注册的 Elisp companion；这个文件格式不会生成更短的 Component alias。
和回调；其中 `etaf-view` 也使用同一组短标签。Elisp 定义和 API 文档仍使用 普通本地回调不需要命名 Action，目录组件与应用自己定义的组件使用相同的 props 和 slot API。
规范的 `etaf-*` 名称。
Button 和 Checkbox 都是受控组件。`etaf-button` 支持 `:label`、 Button 和 Checkbox 都是受控组件。`etaf-button` 支持 `:label`、
`:on-press`、`:disabled`、`:ref`，以及最小 presentation 属性 `:on-press`、`:disabled`、`:ref`，以及最小 presentation 属性
@ -59,8 +74,20 @@ Component 的 `:styles` 声明负责默认外观。调用者提供的非 nil pre
显式 `:on-*` 回调和 Behavior 回调的组合由 Runtime 负责；UI 包只声明控件和 显式 `:on-*` 回调和 Behavior 回调的组合由 Runtime 负责；UI 包只声明控件和
视觉状态。 视觉状态。
间距由父布局负责，而不是由 Button 偷塞。相邻控件应放在带明确横向 `:gap` 间距由父布局负责：`row` 和 `column` 使用 `:item-gap`，例如
的 `row`/`flex` 中，这样每个控件的 mouse-face 和命中范围才保持语义独立。 `(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`、 `etaf-label` 支持 `:text`、`:class`、`:color`、`:bgcolor`、`:font-weight`、
`:width`、`:border`、`:padding` 和 `:ref`。 `:width`、`:border`、`:padding` 和 `:ref`。
@ -79,7 +106,7 @@ surface presentation 属性，并投影命名的 `header` slot 和默认 slot。
| `etaf-number-input` | `:value`、`:label`、`:on-change`、`:disabled`、`:min`、`:max` | | `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-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-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 --> <!-- M0b1: single-host-root -->
目录中的每个公共 Component 都只挂载一个 Host root。未被作为 business prop 目录中的每个公共 Component 都只挂载一个 Host root。未被作为 business prop
@ -92,6 +119,10 @@ DataGrid 支持列描述、函数型 `:row-key`，以及可选的
`tab-index 0` 的可交互 button，且回调接收该行；没有 `:on-row-press` 时，行 `tab-index 0` 的可交互 button，且回调接收该行；没有 `:on-row-press` 时，行
没有回调或 tab stop。 没有回调或 tab stop。
`etaf-table` 的交互行也可省略 `:row-ref`，框架会提供属于当前保留实例的稳定引用。
只有外部 focus、测试或集成需要直接寻址时才提供 ref，不要根据行文字拼接全局
symbol。row key 负责数据身份，ref 负责交互 Host 地址。
<!-- M0b1: row-ref-optional --> <!-- M0b1: row-ref-optional -->
DataGrid 的 `:row-ref` 是可选项。交互式 grid 省略它时，DataGrid 会根据 DataGrid 的 `:row-ref` 是可选项。交互式 grid 省略它时，DataGrid 会根据
controller 持有的 row identity 派生稳定的内部 Host ref。fallback ref 不会 controller 持有的 row identity 派生稳定的内部 Host ref。fallback ref 不会
@ -102,12 +133,72 @@ controller 持有的 row identity 派生稳定的内部 Host ref。fallback ref
DataGrid 按 row key 保留唯一 action closure，因此 selection 或 Data Range DataGrid 按 row key 保留唯一 action closure，因此 selection 或 Data Range
更新不会为未变化的行重建 handler。 更新不会为未变化的行重建 handler。
整数列 `:width` 表示可读字符容量，不是裸像素；DataGrid 原样使用 Ebox 原生字符单位， 整数列 `: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 以及稳定的 `etaf-pagination` 是受控 Data Component。它接收 Data controller 以及稳定的
`:previous-ref`、`:next-ref`，显示易读的 `←`/`→` 控件和 `Page N / M` 摘要； `:previous-ref`、`:next-ref`，使用带内边距的 secondary Button（`‹ Previous` /
加载中或已经位于首/末页时会禁用对应动作。它不拥有页码状态，并复用 Button `Next ›`），中间显示 `Page N / M` 与条数摘要。空间不足时，完整控件和摘要
的交互契约。 自然换行。加载中或已经位于首/末页时会禁用对应动作。它不拥有页码状态，
并复用 Button 的交互契约和 Theme token。可选的 `:previous-label`、
`:next-label` 替换完整按钮文案，例如 `"‹ 上一页"`、`"下一页 ›"`；稳定的英文
无障碍标签保持不变。
键盘焦点使用 ETAF 的公共 Runtime 端口：用 键盘焦点使用 ETAF 的公共 Runtime 端口：用
`(etaf-focus-next runtime)` 在带数值且非负 `:tab-index` 的可见 Host 之间 `(etaf-focus-next runtime)` 在带数值且非负 `:tab-index` 的可见 Host 之间

30
etaf-ui-basic.el
View File

@ -86,37 +86,19 @@
:border (etaf-ui--style-border (plist-get theme border-key)) :border (etaf-ui--style-border (plist-get theme border-key))
:font-weight (if (or disabled (eq variant 'ghost)) 'normal 'bold)))) :font-weight (if (or disabled (eq variant 'ghost)) 'normal 'bold))))
;;;###autoload
(defun etaf-ui--button-setup ()
"Return retained callback state for one Button instance."
(let ((state (list :callback nil :press-p nil)))
(plist-put
state :press
(lambda ()
(when (plist-get state :press-p)
(when-let* ((callback (plist-get state :callback)))
(funcall callback)))))
state))
(etaf-ui--define-component etaf-button (etaf-ui--define-component etaf-button
(&key label on-press disabled ref class color bgcolor border padding (&key label on-press disabled ref class color bgcolor border padding
font-weight tab-index aria-label use variant) font-weight tab-index aria-label use variant)
"Render a standard pressable Button with retained callback identity. "Render a standard pressable Button with a committed callback.
DISABLED removes the callback and default focus tab index. Presentation props DISABLED removes the callback and default focus tab index. Presentation props
remain caller-overridable while the setup state keeps the event closure stable remain caller-overridable. Runtime publishes ON-PRESS with the visible Button,
across parent Component rerenders." so a failed render keeps the previous callback and its captured values."
:setup
(etaf-ui--button-setup)
:render :render
(let* ((state (etaf-state)) (let* ((label (etaf-ui--text-value label))
(label (etaf-ui--text-value label))
(press-p (and (not disabled) (or on-press use)))
(variant-values (variant-values
(etaf-ui--button-variant-values (etaf-ui--button-variant-values
(and (not disabled) variant) disabled))) (and (not disabled) variant) disabled)))
(setf (plist-get state :callback) on-press
(plist-get state :press-p) press-p)
(etaf-node (etaf-node
'box 'box
(list (list
@ -132,8 +114,8 @@ across parent Component rerenders."
:border (or border (plist-get variant-values :border)) :border (or border (plist-get variant-values :border))
:padding padding :padding padding
:font-weight (or font-weight (plist-get variant-values :font-weight)) :font-weight (or font-weight (plist-get variant-values :font-weight))
:use (and (not disabled) use) :use use
:on-press (and press-p (plist-get state :press))) :on-press (and (not disabled) on-press))
(list (etaf-node 'text nil (list label))))) (list (etaf-node 'text nil (list label)))))
:styles :styles
(styles (styles

144
etaf-ui-data.el
View File

@ -24,10 +24,9 @@
(defun etaf-ui--data-grid-default-row-ref (state controller row) (defun etaf-ui--data-grid-default-row-ref (state controller row)
"Return STATE's stable internal Host reference for CONTROLLER and ROW. "Return STATE's stable internal Host reference for CONTROLLER and ROW.
DataGrid owns this fallback so the presentational Table can keep its stricter The controller's validated item identity is the row input. Like Table's
interactive-row contract. The controller's validated item identity is the retained row references, per-instance uninterned symbols prevent cross-grid
row input. Per-instance uninterned symbols prevent cross-grid collisions and collisions and avoid process-global symbol-table growth."
avoid process-global symbol-table growth."
(let* ((identity (etaf-data-item-identity controller row)) (let* ((identity (etaf-data-item-identity controller row))
(cache (plist-get state :row-refs)) (cache (plist-get state :row-refs))
(stage (plist-get state :row-ref-stage)) (stage (plist-get state :row-ref-stage))
@ -260,7 +259,8 @@ LOADING-LABEL, ERROR-LABEL, and EMPTY-LABEL override the state text."
DataGrid owns loading, error, empty, and controller-selection adaptation. DataGrid owns loading, error, empty, and controller-selection adaptation.
Its keyed Range retains row identity across insert, reorder, and update. Its keyed Range retains row identity across insert, reorder, and update.
Setup state owns per-instance fallback refs plus commit-staged stable row Setup state owns per-instance fallback refs plus commit-staged stable row
actions; failed candidates cannot mutate committed handler inputs." actions; failed candidates cannot mutate committed handler inputs. COLUMNS
use Table's unique keys and optional `:cell' row-to-View functions."
:setup :setup
(let ((state (let ((state
(list :row-actions (make-hash-table :test #'equal) (list :row-actions (make-hash-table :test #'equal)
@ -297,86 +297,34 @@ actions; failed candidates cannot mutate committed handler inputs."
(slot :name 'footer))) (slot :name 'footer)))
(etaf-ui--define-component etaf-pagination (etaf-ui--define-component etaf-pagination
(&key controller previous-ref next-ref class color bgcolor border padding (&key controller previous-ref next-ref previous-label next-label
aria-label) class color bgcolor border padding aria-label)
"Render a controlled pager for DATA CONTROLLER with retained controls." "Render a controlled pager whose callbacks follow its committed CONTROLLER.
:setup PREVIOUS-LABEL and NEXT-LABEL override the complete Button captions.
(let* ((state (list :controller nil)) Each Button captures its render's Controller; Runtime publishes that callback
(page-value together with the visible control after a successful render."
(lambda ()
(let ((controller (plist-get state :controller)))
(max 1 (or (and controller
(etaf-value (etaf-data-page controller)))
1)))))
(page-size-value
(lambda ()
(let ((controller (plist-get state :controller)))
(max 1 (or (and controller
(etaf-value (etaf-data-page-size controller)))
1)))))
(total-value
(lambda ()
(let ((controller (plist-get state :controller)))
(max 0 (or (and controller
(etaf-value (etaf-data-total controller)))
0)))))
(pages-value
(lambda ()
(max 1 (ceiling (/ (float (funcall total-value))
(funcall page-size-value))))))
(loading-p
(lambda ()
(let ((controller (plist-get state :controller)))
(and controller
(eq (etaf-value (etaf-data-status 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 ()
(let ((controller (plist-get state :controller)))
(when (and controller
(not (funcall previous-disabled)))
(etaf-data-previous-page controller)))))
(next
(lambda ()
(let ((controller (plist-get state :controller)))
(when (and controller
(not (funcall next-disabled)))
(etaf-data-next-page controller))))))
(plist-put state :page-value page-value)
(plist-put state :page-size-value page-size-value)
(plist-put state :total-value total-value)
(plist-put state :pages-value pages-value)
(plist-put state :loading-p loading-p)
(plist-put state :previous-disabled previous-disabled)
(plist-put state :next-disabled next-disabled)
(plist-put state :previous previous)
(plist-put state :next next)
state)
:render :render
(let* ((state (etaf-state)) (let ((controller-value controller))
(controller-value controller))
(setf (plist-get state :controller) controller-value)
(let* ((theme (etaf-ui--style-tokens (let* ((theme (etaf-ui--style-tokens
:ui-fg :ui-bg :ui-disabled-fg :ui-fg :ui-bg :ui-pagination-muted-fg))
:ui-pagination-muted-fg))
(parent-color (or color (plist-get theme :ui-fg))) (parent-color (or color (plist-get theme :ui-fg)))
(parent-bgcolor (or bgcolor (plist-get theme :ui-bg))) (parent-bgcolor (or bgcolor (plist-get theme :ui-bg)))
(arrow-border (or border '(0 solid "transparent"))) (page (max 1 (or (and controller-value
(page (funcall (plist-get state :page-value))) (etaf-value (etaf-data-page controller-value)))
(page-size (funcall (plist-get state :page-size-value))) 1)))
(total (funcall (plist-get state :total-value))) (page-size
(pages (funcall (plist-get state :pages-value))) (max 1 (or (and controller-value
(previous-disabled (etaf-value (etaf-data-page-size controller-value)))
(funcall (plist-get state :previous-disabled))) 1)))
(next-disabled (total (max 0 (or (and controller-value
(funcall (plist-get state :next-disabled))) (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 (first-item (if (zerop total) 0
(1+ (* (1- page) page-size)))) (1+ (* (1- page) page-size))))
(last-item (min total (* page page-size)))) (last-item (min total (* page page-size))))
@ -384,10 +332,11 @@ actions; failed candidates cannot mutate committed handler inputs."
'flex 'flex
(list :class (etaf-ui--class-value "etaf-pagination" nil class) (list :class (etaf-ui--class-value "etaf-pagination" nil class)
:width 'stretch :flex-direction 'row :align-items 'center :width 'stretch :flex-direction 'row :align-items 'center
:flex-wrap 'wrap :justify-content 'center
:role 'navigation :aria-label (or aria-label "Pagination") :role 'navigation :aria-label (or aria-label "Pagination")
:color parent-color :background-color parent-bgcolor :color parent-color :background-color parent-bgcolor
:box-sizing 'border-box :padding (or padding '(0 1)) :box-sizing 'border-box :padding (or padding '(0 1))
:gap '(0 (1))) :gap '(1 (16)))
(list (list
(etaf-node (etaf-node
'column 'column
@ -396,19 +345,18 @@ actions; failed candidates cannot mutate committed handler inputs."
(list (list
(etaf-node (etaf-node
'etaf-button 'etaf-button
(list :label "←" :ref previous-ref (list :label (or previous-label "‹ Previous") :ref previous-ref
:aria-label "Previous page" :aria-label "Previous page"
:disabled previous-disabled :padding '(0 0) :disabled previous-disabled :padding '(0 2)
:border arrow-border :variant 'secondary :border border
:color (if previous-disabled :color (and (not previous-disabled) color) :bgcolor bgcolor
(plist-get theme :ui-disabled-fg) :on-press
parent-color) (lambda () (etaf-data-previous-page controller-value)))
:background-color parent-bgcolor :font-weight 'bold
:on-press (plist-get state :previous))
nil))) nil)))
(etaf-node (etaf-node
'column 'column
(list :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0) (list :width 'max-content
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto)
(list (list
(etaf-node (etaf-node
'box 'box
@ -428,15 +376,13 @@ actions; failed candidates cannot mutate committed handler inputs."
(list (list
(etaf-node (etaf-node
'etaf-button 'etaf-button
(list :label "→" :ref next-ref (list :label (or next-label "Next ›") :ref next-ref
:aria-label "Next page" :aria-label "Next page"
:disabled next-disabled :padding '(0 0) :disabled next-disabled :padding '(0 2)
:border arrow-border :variant 'secondary :border border
:color (if next-disabled :color (and (not next-disabled) color) :bgcolor bgcolor
(plist-get theme :ui-disabled-fg) :on-press
parent-color) (lambda () (etaf-data-next-page controller-value)))
:background-color parent-bgcolor :font-weight 'bold
:on-press (plist-get state :next))
nil))))))) nil)))))))
:styles :styles
(styles (styles

189
etaf-ui-table.el
View File

@ -19,6 +19,32 @@
(plist-get column key) (plist-get column key)
(alist-get key column))) (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) (defun etaf-ui--table-cell-value (row key)
"Return KEY from ROW, accepting a plist, alist, or hash table." "Return KEY from ROW, accepting a plist, alist, or hash table."
(cond (cond
@ -27,7 +53,7 @@
(zerop (% (length row) 2)) (zerop (% (length row) 2))
(keywordp (car row))) (keywordp (car row)))
(plist-get row key)) (plist-get row key))
((listp row) (alist-get key row)) ((listp row) (alist-get key row nil nil #'equal))
(t nil))) (t nil)))
(defun etaf-ui--table-fit-text (value column) (defun etaf-ui--table-fit-text (value column)
@ -39,19 +65,34 @@
(truncate-string-to-width value width 0 nil "…") (truncate-string-to-width value width 0 nil "…")
value))) value)))
(defun etaf-ui--table-track-width (column gap-p) (defun etaf-ui--table-fixed-text-columns-p (columns)
"Return COLUMN width with one character gap when GAP-P is non-nil." "Return non-nil when COLUMNS can share the compact fixed-text path."
(let ((width (etaf-ui--column-value column :width))) (and columns
(if (and gap-p (integerp width) (> width 0)) (cl-every
(1+ width) (lambda (column)
width))) (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-header-cell (column gap-p) (defun etaf-ui--table-grid (columns cells)
"Return one Label header for COLUMN, adding air when GAP-P is non-nil." "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 (etaf-node
'box 'box
(list :class "etaf-table-header-cell" (list :class "etaf-table-header-cell"
:width (etaf-ui--table-track-width column gap-p) :width 'stretch :overflow 'hidden
:wrap-mode 'none) :wrap-mode 'none)
(list (list
(etaf-node (etaf-node
@ -64,12 +105,7 @@
(defun etaf-ui--table-fixed-header-text (columns) (defun etaf-ui--table-fixed-header-text (columns)
"Return one fixed-width header string for COLUMNS, or nil." "Return one fixed-width header string for COLUMNS, or nil."
(when (and columns (when (etaf-ui--table-fixed-text-columns-p columns)
(cl-every
(lambda (column)
(let ((width (etaf-ui--column-value column :width)))
(and (integerp width) (> width 0))))
columns))
(mapconcat (mapconcat
(lambda (column) (lambda (column)
(let* ((width (etaf-ui--column-value column :width)) (let* ((width (etaf-ui--column-value column :width))
@ -84,51 +120,52 @@
(defun etaf-ui--table-header (columns) (defun etaf-ui--table-header (columns)
"Return a Table header row for COLUMNS." "Return a Table header row for COLUMNS."
(etaf-ui--table-validate-columns columns)
(let ((theme (etaf-ui--style-tokens :ui-table-border)) (let ((theme (etaf-ui--style-tokens :ui-table-border))
(fixed-text (etaf-ui--table-fixed-header-text columns))) (fixed-text (etaf-ui--table-fixed-header-text columns)))
(etaf-node (etaf-node
'row 'row
(list :class "etaf-table-header" (append
:border-bottom-width 1 :border-bottom-style 'solid (unless fixed-text '(:padding (0 0)))
:border-bottom-color (plist-get theme :ui-table-border)) (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 (if fixed-text
(list (etaf-node 'text nil (list fixed-text))) (list (etaf-node 'text nil (list fixed-text)))
(cl-loop for column in columns (list (etaf-ui--table-grid
for tail on columns columns (mapcar #'etaf-ui--table-header-cell columns)))))))
collect
(etaf-ui--table-header-cell column (cdr tail)))))))
(defun etaf-ui--table-cell (row column gap-p) (defun etaf-ui--table-cell (row column)
"Return one Label cell for ROW and COLUMN using GAP-P." "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 (etaf-node
'box 'box
(list :class "etaf-table-cell" (list :key (etaf-ui--column-value column :key)
:width (etaf-ui--table-track-width column gap-p) :class "etaf-table-cell"
:width 'stretch
:overflow 'hidden
:wrap-mode 'none) :wrap-mode 'none)
(list (list
(etaf-node (if-let* ((cell (etaf-ui--column-value column :cell)))
'text nil (etaf-view (expr (funcall cell row)))
(list (etaf-node
(etaf-ui--table-fit-text 'text nil
(etaf-ui--table-cell-value (list
row (etaf-ui--column-value column :key)) (etaf-ui--table-fit-text
column)))))) (etaf-ui--table-cell-value
row (etaf-ui--column-value column :key))
column)))))))
(defun etaf-ui--table-cells (row columns) (defun etaf-ui--table-cells (row columns)
"Return cell Components for ROW using COLUMNS." "Return cell Components for ROW using COLUMNS."
(cl-loop for column in columns (cl-loop for column in columns
for tail on columns
collect collect
(etaf-ui--table-cell row column (cdr tail)))) (etaf-ui--table-cell row column)))
(defun etaf-ui--table-fixed-row-text (row columns) (defun etaf-ui--table-fixed-row-text (row columns)
"Return one fixed-width ROW string for COLUMNS, or nil when not applicable." "Return one fixed-width ROW string for COLUMNS, or nil when not applicable."
(when (and columns (when (etaf-ui--table-fixed-text-columns-p columns)
(cl-every
(lambda (column)
(let ((width (etaf-ui--column-value column :width)))
(and (integerp width) (> width 0))))
columns))
(mapconcat (mapconcat
(lambda (column) (lambda (column)
(let* ((width (etaf-ui--column-value column :width)) (let* ((width (etaf-ui--column-value column :width))
@ -143,11 +180,12 @@
(defun etaf-ui--table-row-children (row columns) (defun etaf-ui--table-row-children (row columns)
"Return the smallest presentation-equivalent child list for ROW. "Return the smallest presentation-equivalent child list for ROW.
COLUMNS with fixed positive character widths use one padded Text Host; COLUMNS with fixed positive character widths use one padded Text Host.
otherwise retain the general per-cell Box path." 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))) (if-let* ((text (etaf-ui--table-fixed-row-text row columns)))
(list (etaf-node 'text nil (list text))) (list (etaf-node 'text nil (list text)))
(etaf-ui--table-cells row columns))) (list (etaf-ui--table-grid columns (etaf-ui--table-cells row columns)))))
(defun etaf-ui--table-entries (rows row-key) (defun etaf-ui--table-entries (rows row-key)
"Return `(KEY . ROW)' entries for ROWS using ROW-KEY. "Return `(KEY . ROW)' entries for ROWS using ROW-KEY.
@ -160,11 +198,10 @@ ETAF validates keys and uniqueness."
(row identity columns row-ref on-row-press row-selected-p) (row identity columns row-ref on-row-press row-selected-p)
"Return one canonical row Host for ROW and stable IDENTITY. "Return one canonical row Host for ROW and stable IDENTITY.
This helper is shared by the retained presentational Table Component and the The retained Table row shares its cell construction with DataGrid's keyed
DataGrid's keyed hot path. Keeping the row itself as a Host avoids creating a hot path. COLUMNS define the visible cells;
second Component boundary for every visible item while preserving the same ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P define optional interaction.
selection, event, and style contract. COLUMNS define the visible cells; Without ROW-REF the Host receives ETAF's usual instance-local reference."
ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P define optional interaction."
(let* ((callback on-row-press) (let* ((callback on-row-press)
(row-value row) (row-value row)
(interactive-p (not (null callback))) (interactive-p (not (null callback)))
@ -180,26 +217,29 @@ ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P define optional interaction."
(when interactive-p (when interactive-p
(unless (functionp on-row-press) (unless (functionp on-row-press)
(error "ETAF Table :on-row-press must be a function")) (error "ETAF Table :on-row-press must be a function"))
(unless (functionp row-ref) (when (and row-ref (not (functionp row-ref)))
(error "ETAF Table requires :row-ref for interactive rows")) (error "ETAF Table :row-ref must be a function"))
(setq host-ref (funcall row-ref row)) (when row-ref
(unless host-ref (setq host-ref (funcall row-ref row))
(error "ETAF Table row reference must be non-nil"))) (unless host-ref
(error "ETAF Table :row-ref must return a non-nil stable ref"))))
(etaf-node (etaf-node
'row 'row
(list :key identity (append
:class (concat "etaf-table-row" (if selected-p " selected" "")) (unless (etaf-ui--table-fixed-text-columns-p columns) '(:padding (0 0)))
:ref host-ref :role (when interactive-p 'button) (list :key identity
:tab-index (when interactive-p 0) :class (concat "etaf-table-row" (if selected-p " selected" ""))
:color :ref host-ref :role (when interactive-p 'button)
(when selected-p (plist-get theme :ui-table-selected-fg)) :tab-index (when interactive-p 0)
:background-color :color
(when selected-p (plist-get theme :ui-table-selected-bg)) (when selected-p (plist-get theme :ui-table-selected-fg))
:border-bottom-width 1 :border-bottom-style 'solid :background-color
:border-bottom-color (plist-get theme :ui-table-border) (when selected-p (plist-get theme :ui-table-selected-bg))
:on-press :border-bottom-width 1 :border-bottom-style 'solid
(when interactive-p :border-bottom-color (plist-get theme :ui-table-border)
(lambda () (funcall callback row-value)))) :on-press
(when interactive-p
(lambda () (funcall callback row-value)))))
(etaf-ui--table-row-children row columns)))) (etaf-ui--table-row-children row columns))))
(etaf-ui--define-component etaf-ui--table-header (&key columns) (etaf-ui--define-component etaf-ui--table-header (&key columns)
@ -224,9 +264,16 @@ ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P define optional interaction."
(&key columns rows row-key row-ref on-row-press row-selected-p) (&key columns rows row-key row-ref on-row-press row-selected-p)
"Render ordinary ROWS as a presentational Table. "Render ordinary ROWS as a presentational Table.
COLUMNS contain `:key', optional `:label', and optional character `:width'. COLUMNS contain a unique non-nil `:key', optional `:label', `:width',
ROW-KEY supplies stable identity. Interaction and selection are controlled and `:cell' function accepting one row and returning ordinary View content.
optional inputs; Table never owns application or Data Controller state." 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 :view
(column (column
:class "etaf-table" :class "etaf-table"

4
scripts/etaf-ui-m0a-inventory.el
View File

@ -55,8 +55,8 @@
:root-guarantee single-host-root :root-guarantee single-host-root
:definition "etaf-ui-data.el") :definition "etaf-ui-data.el")
(:name etaf-pagination (:name etaf-pagination
:business-props (controller previous-ref next-ref class color bgcolor :business-props (controller previous-ref next-ref previous-label next-label
border padding aria-label) class color bgcolor border padding aria-label)
:forwarded-host-attrs all-valid-host-attrs :forwarded-host-attrs all-valid-host-attrs
:root-guarantee single-host-root :root-guarantee single-host-root
:definition "etaf-ui-data.el")) :definition "etaf-ui-data.el"))

76
tests/etaf-ui-button-commit-tests.el Normal file
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

85
tests/etaf-ui-docs-tests.el Normal file
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

241
tests/etaf-ui-pagination-commit-tests.el Normal file
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 "0–0 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" "1–1 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

274
tests/etaf-ui-table-adaptive-tests.el Normal file
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

21
tests/etaf-ui-tests.el
View File

@ -79,6 +79,7 @@
:color "explicit-color") :color "explicit-color")
(etaf-label :text "Themed" :ref 'themed-label (etaf-label :text "Themed" :ref 'themed-label
:color nil :bgcolor nil) :color nil :bgcolor nil)
(text :ref 'themed-host :color nil :bgcolor nil "Theme defaults")
(etaf-panel :title "Styled panel" :ref 'styled-panel))) (etaf-panel :title "Styled panel" :ref 'styled-panel)))
(etaf-define-component etaf-ui-test-token-theme-fixture () (etaf-define-component etaf-ui-test-token-theme-fixture ()
@ -142,14 +143,19 @@
(let ((styled (etaf-ui-test--props buffer-name 'styled-button)) (let ((styled (etaf-ui-test--props buffer-name 'styled-button))
(custom (etaf-ui-test--props buffer-name 'custom-button)) (custom (etaf-ui-test--props buffer-name 'custom-button))
(themed (etaf-ui-test--props buffer-name 'themed-label)) (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))) (panel (etaf-ui-test--props buffer-name 'styled-panel)))
(should (equal (plist-get styled :color) "#FFFFFF")) (should (equal (plist-get styled :color) "#FFFFFF"))
(should (equal (plist-get styled :background-color) "#2F6B43")) (should (equal (plist-get styled :background-color) "#2F6B43"))
(should (equal (plist-get styled :padding) '(0 1))) (should (equal (plist-get styled :padding) '(0 1)))
(should (equal (plist-get custom :color) "explicit-color")) (should (equal (plist-get custom :color) "explicit-color"))
(should (equal (plist-get custom :background-color) "#2F6B43")) (should (equal (plist-get custom :background-color) "#2F6B43"))
(should (equal (plist-get themed :color) "theme-color")) ;; 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 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-not (plist-get themed :padding))
(should (equal (plist-get panel :color) "#252A2E")) (should (equal (plist-get panel :color) "#252A2E"))
(should (equal (plist-get panel :background-color) "#FFFDF8")) (should (equal (plist-get panel :background-color) "#FFFDF8"))
@ -301,11 +307,11 @@
(with-current-buffer buffer-name (with-current-buffer buffer-name
(let ((face (get-text-property position 'face))) (let ((face (get-text-property position 'face)))
(should (string-match-p "#202C42" (format "%S" 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))) (when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime)) (etaf-unmount runtime))
(when-let* ((buffer (get-buffer buffer-name))) (when-let* ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))) (kill-buffer buffer)))))
(ert-deftest etaf-ui-button-dispatches-without-retained-press-state () (ert-deftest etaf-ui-button-dispatches-without-retained-press-state ()
"Buttons dispatch through semantic Host state without local press state." "Buttons dispatch through semantic Host state without local press state."
@ -687,7 +693,7 @@
(kill-buffer buffer))))) (kill-buffer buffer)))))
(ert-deftest etaf-ui-pagination-is-readable-and-boundary-safe () (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 (let* ((source (etaf-data-memory-source
'((:id 1) (:id 2) (:id 3) (:id 4) (:id 5)) '((:id 1) (:id 2) (:id 3) (:id 4) (:id 5))
:id-key :id)) :id-key :id))
@ -702,8 +708,8 @@
:previous-ref 'page-previous :previous-ref 'page-previous
:next-ref 'page-next))) :next-ref 'page-next)))
(should (string-match-p "Page 1 / 3" (etaf-ui-test--text buffer-name))) (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 "‹ Previous" (etaf-ui-test--text buffer-name)))
(should (string-match-p "→" (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 ;; Live Ebox windows reserve two pixels for the exclusive display
;; boundary; the pager must stay inside the corresponding 360px row. ;; boundary; the pager must stay inside the corresponding 360px row.
(ebox-surface-update-buffer-viewport (get-buffer buffer-name) 358 20) (ebox-surface-update-buffer-viewport (get-buffer buffer-name) 358 20)
@ -929,8 +935,7 @@
(progn (progn
(setf (etaf-value (etaf-data-status controller)) (setf (etaf-value (etaf-data-status controller))
(car case)) (car case))
(setf (etaf-value (etaf-data-items controller)) (setf (etaf-value (etaf-data-items controller)) nil)
(when (eq (car case) 'empty) nil))
(etaf-mount (etaf-mount
buffer-name buffer-name
(etaf-view (etaf-view