Compare commits
8 Commits
m0b1-etaf-
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
cb5d719330 | ||
|
|
591e2a2ead | ||
|
|
a3647665c7 | ||
|
|
6a1d816292 | ||
|
|
4d0d63bbb3 | ||
|
|
a4181d0db1 | ||
|
|
a35b3dc469 | ||
|
|
46617cc8b2 |
3
.gitignore
vendored
3
.gitignore
vendored
@ -1,2 +1,5 @@
|
||||
*.elc
|
||||
tests/*.elc
|
||||
|
||||
# Emacs backup files.
|
||||
*~
|
||||
|
||||
19
Makefile
19
Makefile
@ -1,25 +1,34 @@
|
||||
EMACS ?= emacs
|
||||
LOAD_PATH = -L . -L ../etaf -L ../ebox -L ../ecss -L ../tp
|
||||
SOURCES = etaf-ui-style.el etaf-ui-basic.el etaf-ui-table.el etaf-ui-data.el etaf-ui.el
|
||||
|
||||
.PHONY: all compile test check checkdoc load clean
|
||||
TEST_FILES := $(wildcard tests/*-tests.el)
|
||||
|
||||
.PHONY: all compile test m0a-inventory check checkdoc load clean
|
||||
|
||||
all: check
|
||||
|
||||
compile:
|
||||
rm -f *.elc tests/*.elc
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
|
||||
--eval '(load-file "etaf-ui.el")' --eval '(byte-compile-file "etaf-ui.el")'
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) \
|
||||
--eval '(setq load-prefer-newer t byte-compile-error-on-warn t)' \
|
||||
--eval '(require (quote cl-lib))' \
|
||||
--eval '(unless (cl-every (function byte-compile-file) (quote ($(foreach file,$(SOURCES),"$(file)")))) (kill-emacs 1))'
|
||||
|
||||
test: compile
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
|
||||
-l tests/etaf-ui-tests.el -f ert-run-tests-batch-and-exit
|
||||
$(foreach test,$(TEST_FILES),-l $(test)) -f ert-run-tests-batch-and-exit
|
||||
|
||||
m0a-inventory:
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
|
||||
-l scripts/etaf-ui-m0a-inventory.el -f etaf-ui-m0a-inventory-batch
|
||||
|
||||
load: compile
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(require (quote etaf-ui))' \
|
||||
--eval '(princ "etaf-ui load OK\n")'
|
||||
|
||||
checkdoc:
|
||||
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (directory-files "." t)) (when (string-suffix-p ".el" file) (checkdoc-file file))))'
|
||||
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (directory-files "." t "\\.el$$") (directory-files-recursively "tests" "\\.el$$") (directory-files-recursively "scripts" "\\.el$$"))) (checkdoc-file file)))'
|
||||
|
||||
check: checkdoc compile test
|
||||
|
||||
|
||||
158
README.md
158
README.md
@ -2,27 +2,43 @@
|
||||
|
||||
`etaf-ui` is the official ETAF Component catalog. It is a normal optional package above `etaf`; it does not add a second Control or Widget model. Button, Checkbox, Label, Panel, and DataGrid are all ordinary Components with the same View, props, slots, events, and Data contracts.
|
||||
|
||||
|
||||
Use the exact registered names `etaf-panel`, `etaf-label`, `etaf-button`, and
|
||||
`etaf-checkbox` in every View. Evaluate this complete example in a lexical-binding
|
||||
`.el` file, then switch to `*etaf-preferences*` to use its controls.
|
||||
|
||||
<!-- etaf-example: preferences -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf-ui)
|
||||
|
||||
(let ((done (etaf-ref nil)))
|
||||
(etaf-view
|
||||
(panel :title "Account"
|
||||
(slot :name 'header
|
||||
(button :label "Save" :ref 'save-button
|
||||
:on-press (lambda () (message "saved"))))
|
||||
(label :text "Preferences")
|
||||
(checkbox :checked (etaf-value done) :label "Done"
|
||||
:ref 'done-checkbox
|
||||
:on-change (lambda (next)
|
||||
(setf (etaf-value done) next))))))
|
||||
(etaf-define-component demo-preferences ()
|
||||
:setup (list (etaf-ref nil) (etaf-ref "Unsaved"))
|
||||
:render
|
||||
(let* ((state (etaf-state))
|
||||
(done (car state))
|
||||
(saved (cadr state)))
|
||||
(etaf-view
|
||||
(etaf-panel :title "Account"
|
||||
(slot :name 'header
|
||||
(etaf-button :label "Save" :ref 'save-button
|
||||
:on-press (lambda ()
|
||||
(setf (etaf-value saved) "Saved"))))
|
||||
(etaf-label :text (etaf-value saved))
|
||||
(etaf-checkbox :checked (etaf-value done) :label "Done"
|
||||
:ref 'done-checkbox
|
||||
:on-change (lambda (next)
|
||||
(setf (etaf-value done) next)))
|
||||
(text (expr (if (etaf-value done) "Complete" "Pending")))))))
|
||||
|
||||
(etaf-mount "*etaf-preferences*" (etaf-view (demo-preferences)))
|
||||
```
|
||||
|
||||
In `.etaf` files use the short registered tags (`panel`, `label`, `button`,
|
||||
`checkbox`, and `data-grid`) for structure. The companion `.el` file owns
|
||||
reactive values, Actions, Behaviors, and callbacks; keep the `etaf-view` tree
|
||||
made from those same short tags. Canonical `etaf-*` names remain the Elisp
|
||||
definition and API names.
|
||||
Core does not automatically load `.etaf` files. The optional Playground reads
|
||||
inert structural source and explicitly loads its registered Elisp companion;
|
||||
that file format does not create shorter Component aliases. Local callbacks
|
||||
need no named Action. Components receive props and slots through the same API
|
||||
as application-defined Components.
|
||||
|
||||
Button and Checkbox are controlled Components. `etaf-button` accepts `:label`,
|
||||
`:on-press`, `:disabled`, `:ref`, and the small presentation set
|
||||
@ -67,9 +83,25 @@ no callback, pointer activation, or tab stop. The Runtime owns composition of
|
||||
an explicit `:on-*` callback with a Behavior callback; the UI package only
|
||||
declares the control and its visual state.
|
||||
|
||||
Spacing is owned by the parent layout, not by Button. Put adjacent controls in
|
||||
a `row`/`flex` with an explicit horizontal `:gap`; this keeps each control's
|
||||
mouse-face and hit range semantically separate.
|
||||
The parent owns spacing: use `(row :item-gap 1 ...)` or
|
||||
`(column :item-gap 1 ...)`; `flex` and `grid` use `:gap`. In particular, migrate
|
||||
`row :gap` to `row :item-gap`. Keep an explicit gap between adjacent controls
|
||||
so each has a separate hover and hit range.
|
||||
|
||||
Root event forwarding appends the business action, inner-to-outer wrapper
|
||||
callbacks, then Behaviors in declaration order. For Checkbox, adding
|
||||
`:on-press` does not replace its `:on-change` conversion. Errors stop the chain;
|
||||
each declaration runs once. Wrapper `:use` lists concatenate and duplicate
|
||||
Behavior names are rejected before installation.
|
||||
|
||||
Disabled inputs combine with OR; outer nil cannot enable an internally disabled
|
||||
control. Disabled dispatch and focus signal `etaf-event-error`; disabled cell
|
||||
controls block pointer activation from falling through to their parent row.
|
||||
Disabled input Behaviors are not installed. A conflicting fallthrough `:role`
|
||||
or owned aria state, such as `:aria-checked`, is an input error; accessible
|
||||
`:aria-label` and `:aria-description` remain caller-overridable. See the
|
||||
[interaction and migration rules](../etaf/docs/user-guide.en.md#interaction-migration)
|
||||
for the complete contract.
|
||||
|
||||
`etaf-label` accepts `:text`, `:class`, `:color`, `:bgcolor`, `:font-weight`,
|
||||
`:width`, `:border`, `:padding`, and `:ref`.
|
||||
@ -90,7 +122,7 @@ separate from forwarded Host attributes:
|
||||
| `etaf-number-input` | `:value`, `:label`, `:on-change`, `:disabled`, `:min`, `:max` |
|
||||
| `etaf-table` | `:columns`, `:rows`, `:row-key`, `:row-ref`, `:on-row-press`, `:row-selected-p` |
|
||||
| `etaf-data-grid` | `:controller`, `:columns`, `:row-key`, `:on-row-press`, `:row-ref`, `:row-selected-p`, `:loading-label`, `:error-label`, `:empty-label` |
|
||||
| `etaf-pagination` | `:controller`, `:previous-ref`, `:next-ref`, `:class`, `:color`, `:bgcolor`, `:border`, `:padding`, `:aria-label` |
|
||||
| `etaf-pagination` | `:controller`, `:previous-ref`, `:next-ref`, `:previous-label`, `:next-label`, `:class`, `:color`, `:bgcolor`, `:border`, `:padding`, `:aria-label` |
|
||||
|
||||
<!-- M0b1: single-host-root -->
|
||||
Every public catalog Component mounts exactly one Host root. All valid Host
|
||||
@ -104,23 +136,97 @@ optional `:loading-label`, `:error-label`, `:empty-label`, or function-valued
|
||||
interactive button with role `button` and tab index `0`; the callback receives
|
||||
the row. Without `:on-row-press`, rows have no callback or tab stop.
|
||||
|
||||
Interactive `etaf-table` rows may also omit `:row-ref`; the framework supplies
|
||||
stable references scoped to the retained Table instance. Supply refs only for
|
||||
external focus, tests, or integration addresses; do not derive global symbols
|
||||
from row labels. Row keys identify data; refs identify interactive Hosts.
|
||||
|
||||
<!-- M0b1: row-ref-optional -->
|
||||
`:row-ref` is optional for DataGrid. When it is omitted on an interactive
|
||||
grid, DataGrid derives a stable internal Host reference from the row identity
|
||||
owned by the controller. When it is supplied, the callback owns that identity
|
||||
and must return a non-nil stable Host reference for every row. `:row-key`
|
||||
owned by the controller. Fallback refs are uninterned and scoped to each
|
||||
retained DataGrid instance, so separate grids may share row identities without
|
||||
colliding. When `:row-ref` is supplied, the callback owns that identity and
|
||||
must return a non-nil stable Host reference for every row. `:row-key`
|
||||
remains a required non-nil stable scalar identity for retained rows. DataGrid
|
||||
retains one action closure per row key, so selection or Data Range updates do
|
||||
not recreate handlers for unchanged rows.
|
||||
An integer column `:width` is readable character capacity, not a raw pixel
|
||||
value. DataGrid passes Ebox's native character unit through and reserves one
|
||||
native character between non-final tracks.
|
||||
native character between non-final tracks. Use `:width '(fr 1)` to let a column
|
||||
fill the remaining width; multiple fractional columns share that space by
|
||||
their positive weights. For example, `(:key :title :width (fr 1))` next to
|
||||
`(:key :actions :width 22 :cell render-actions)` lets the title adapt while
|
||||
reserving room for the action controls. Headers and rows use the same tracks
|
||||
and gap. Fractional cells clip to their allocation without widening neighboring
|
||||
columns. Fixed tracks still reserve their declared space, so the containing
|
||||
layout must provide enough width for those controls and gaps.
|
||||
|
||||
Changing a custom cell's column width between fixed and fractional values does
|
||||
not replace its Component state. All-fixed text-only tables retain their compact
|
||||
text rendering path.
|
||||
|
||||
### Custom cells and column migration
|
||||
|
||||
Table and DataGrid share the column contract. Every column needs a unique,
|
||||
non-nil `:key` (symbol, integer, or string), including presentation-only columns.
|
||||
The default cell reads that field as text. A `:cell` function receives one row
|
||||
and returns nil, a string, a typed Host or Component View, or a proper sequence
|
||||
of those values. Table owns cell width and clips overflow; text-only tables
|
||||
keep their existing compact representation.
|
||||
|
||||
The example repeats the `:name` field with two distinct column keys and puts an
|
||||
ordinary Button in a third column. Select the row or activate Open independently:
|
||||
|
||||
<!-- etaf-example: cells -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf-ui)
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-cell-demo*"
|
||||
(etaf-view
|
||||
(etaf-table
|
||||
:rows '((:id 1 :name "Ada"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:on-row-press (lambda (row) (message "Select %s" (plist-get row :name)))
|
||||
:columns
|
||||
(list
|
||||
'(:key :name :label "Name" :width 12)
|
||||
(list :key :name-upper :label "Uppercase" :width 12
|
||||
:cell (lambda (row) (upcase (plist-get row :name))))
|
||||
(list :key :open :label "Action" :width 10
|
||||
:cell
|
||||
(lambda (row)
|
||||
(etaf-view
|
||||
(etaf-button
|
||||
:label "Open"
|
||||
:on-press (lambda ()
|
||||
(message "Open %s" (plist-get row :name)))))))))))
|
||||
```
|
||||
|
||||
To migrate duplicate field columns, keep one `:key :name`, give the other a
|
||||
unique key such as `:name-upper`, and use `:cell` to read the original `:name`
|
||||
field. Missing or duplicate column keys are errors. Row and column keys retain
|
||||
cell identity across reordering; changing a key replaces that cell instance.
|
||||
|
||||
Cell functions use their row argument and normal lexical captures. Their
|
||||
Context is the consuming Table/Grid location; they do not recover the author's
|
||||
props, `etaf-state`, or private styles. Return an ordinary Component when a
|
||||
cell needs its own state, styles, or lifecycle, and create persistent refs and
|
||||
watches in that Component's `:setup`. Capture an author's stable ref before
|
||||
building a callback when sharing it is intentional. Do not create persistent
|
||||
state on each cell-function call.
|
||||
|
||||
`etaf-pagination` is a controlled Data Component. It accepts a Data controller
|
||||
plus stable `:previous-ref` and `:next-ref` values, renders readable `←`/`→`
|
||||
controls and a `Page N / M` summary, and disables the boundary action while a
|
||||
plus stable `:previous-ref` and `:next-ref` values, renders padded secondary
|
||||
Buttons (`‹ Previous` / `Next ›`) around a centered `Page N / M` and item-count
|
||||
summary, and disables the boundary action while a
|
||||
page is loading or already at the first/last page. It owns no page state and
|
||||
uses the same Button interaction contract.
|
||||
uses the same Button interaction contract and Theme tokens. Narrow allocations
|
||||
wrap the complete controls and summary. Optional `:previous-label` and
|
||||
`:next-label` replace the complete captions, for example `"‹ 上一页"` and
|
||||
`"下一页 ›"`; the stable English accessibility labels remain unchanged.
|
||||
|
||||
Keyboard focus uses ETAF's public runtime ports: call
|
||||
`(etaf-focus-next runtime)` to move through visible Hosts with a numeric
|
||||
|
||||
141
README.zh-CN.md
141
README.zh-CN.md
@ -2,26 +2,41 @@
|
||||
|
||||
`etaf-ui` 是 ETAF 的官方 Component 目录,是建立在 `etaf` 之上的可选独立包。它不增加第二套 Control 或 Widget 模型;Button、Checkbox、Label、Panel、DataGrid 都是使用同一套 View、属性、slot、事件和 Data 契约的普通 Component。
|
||||
|
||||
|
||||
所有 View 都使用准确的注册名称:`etaf-panel`、`etaf-label`、`etaf-button` 和
|
||||
`etaf-checkbox`。把下面完整例子放进启用 lexical-binding 的 `.el` 文件求值,
|
||||
再切换到 `*etaf-preferences*` 使用控件。
|
||||
|
||||
<!-- etaf-example: preferences -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf-ui)
|
||||
|
||||
(let ((done (etaf-ref nil)))
|
||||
(etaf-view
|
||||
(panel :title "Account"
|
||||
(slot :name 'header
|
||||
(button :label "Save" :ref 'save-button
|
||||
:on-press (lambda () (message "saved"))))
|
||||
(label :text "Preferences")
|
||||
(checkbox :checked (etaf-value done) :label "Done"
|
||||
:ref 'done-checkbox
|
||||
:on-change (lambda (next)
|
||||
(setf (etaf-value done) next))))))
|
||||
(etaf-define-component demo-preferences ()
|
||||
:setup (list (etaf-ref nil) (etaf-ref "Unsaved"))
|
||||
:render
|
||||
(let* ((state (etaf-state))
|
||||
(done (car state))
|
||||
(saved (cadr state)))
|
||||
(etaf-view
|
||||
(etaf-panel :title "Account"
|
||||
(slot :name 'header
|
||||
(etaf-button :label "Save" :ref 'save-button
|
||||
:on-press (lambda ()
|
||||
(setf (etaf-value saved) "Saved"))))
|
||||
(etaf-label :text (etaf-value saved))
|
||||
(etaf-checkbox :checked (etaf-value done) :label "Done"
|
||||
:ref 'done-checkbox
|
||||
:on-change (lambda (next)
|
||||
(setf (etaf-value done) next)))
|
||||
(text (expr (if (etaf-value done) "Complete" "Pending")))))))
|
||||
|
||||
(etaf-mount "*etaf-preferences*" (etaf-view (demo-preferences)))
|
||||
```
|
||||
|
||||
`.etaf` 文件的结构使用已注册的短标签(`panel`、`label`、`button`、
|
||||
`checkbox`、`data-grid`)。配套 `.el` 文件负责响应式值、Action、Behavior
|
||||
和回调;其中 `etaf-view` 也使用同一组短标签。Elisp 定义和 API 文档仍使用
|
||||
规范的 `etaf-*` 名称。
|
||||
Core 不会自动加载 `.etaf`。可选的 Playground 读取 inert 结构源,并显式加载
|
||||
已注册的 Elisp companion;这个文件格式不会生成更短的 Component alias。
|
||||
普通本地回调不需要命名 Action,目录组件与应用自己定义的组件使用相同的 props 和 slot API。
|
||||
|
||||
Button 和 Checkbox 都是受控组件。`etaf-button` 支持 `:label`、
|
||||
`:on-press`、`:disabled`、`:ref`,以及最小 presentation 属性
|
||||
@ -59,8 +74,20 @@ Component 的 `:styles` 声明负责默认外观。调用者提供的非 nil pre
|
||||
显式 `:on-*` 回调和 Behavior 回调的组合由 Runtime 负责;UI 包只声明控件和
|
||||
视觉状态。
|
||||
|
||||
间距由父布局负责,而不是由 Button 偷塞。相邻控件应放在带明确横向 `:gap`
|
||||
的 `row`/`flex` 中,这样每个控件的 mouse-face 和命中范围才保持语义独立。
|
||||
间距由父布局负责:`row` 和 `column` 使用 `:item-gap`,例如
|
||||
`(row :item-gap 1 ...)`;`flex` 和 `grid` 使用 `:gap`。尤其需要将 `row :gap`
|
||||
迁移为 `row :item-gap`。相邻控件保留明确间距,让 hover 和命中范围各自独立。
|
||||
|
||||
根事件透传按顺序追加:业务动作、由内到外的 wrapper callback、最后按声明顺序
|
||||
运行的 Behavior。给 Checkbox 增加 `:on-press` 不会替换它的 `:on-change` 转换。
|
||||
每个声明执行一次,错误会中断后续回调。wrapper 的 `:use` 列表顺序连接,重复
|
||||
Behavior name 在安装前报错。
|
||||
|
||||
禁用输入取 OR,外层 nil 不能启用内部已经禁用的控件。禁用时 dispatch 和 focus
|
||||
抛出 `etaf-event-error`,禁用 cell 控件会阻止指针激活落到父行,输入 Behavior
|
||||
也不会安装。透传 `:role` 或 `:aria-checked` 等组件所有的 aria 状态时,冲突值会
|
||||
导致输入错误;调用方仍可覆盖 `:aria-label` 与 `:aria-description`。完整规则见
|
||||
[交互与迁移说明](../etaf/docs/user-guide.zh.md#interaction-migration)。
|
||||
|
||||
`etaf-label` 支持 `:text`、`:class`、`:color`、`:bgcolor`、`:font-weight`、
|
||||
`:width`、`:border`、`:padding` 和 `:ref`。
|
||||
@ -79,7 +106,7 @@ surface presentation 属性,并投影命名的 `header` slot 和默认 slot。
|
||||
| `etaf-number-input` | `:value`、`:label`、`:on-change`、`:disabled`、`:min`、`:max` |
|
||||
| `etaf-table` | `:columns`、`:rows`、`:row-key`、`:row-ref`、`:on-row-press`、`:row-selected-p` |
|
||||
| `etaf-data-grid` | `:controller`、`:columns`、`:row-key`、`:on-row-press`、`:row-ref`、`:row-selected-p`、`:loading-label`、`:error-label`、`:empty-label` |
|
||||
| `etaf-pagination` | `:controller`、`:previous-ref`、`:next-ref`、`:class`、`:color`、`:bgcolor`、`:border`、`:padding`、`:aria-label` |
|
||||
| `etaf-pagination` | `:controller`、`:previous-ref`、`:next-ref`、`:previous-label`、`:next-label`、`:class`、`:color`、`:bgcolor`、`:border`、`:padding`、`:aria-label` |
|
||||
|
||||
<!-- M0b1: single-host-root -->
|
||||
目录中的每个公共 Component 都只挂载一个 Host root。未被作为 business prop
|
||||
@ -92,20 +119,86 @@ DataGrid 支持列描述、函数型 `:row-key`,以及可选的
|
||||
`tab-index 0` 的可交互 button,且回调接收该行;没有 `:on-row-press` 时,行
|
||||
没有回调或 tab stop。
|
||||
|
||||
`etaf-table` 的交互行也可省略 `:row-ref`,框架会提供属于当前保留实例的稳定引用。
|
||||
只有外部 focus、测试或集成需要直接寻址时才提供 ref,不要根据行文字拼接全局
|
||||
symbol。row key 负责数据身份,ref 负责交互 Host 地址。
|
||||
|
||||
<!-- M0b1: row-ref-optional -->
|
||||
DataGrid 的 `:row-ref` 是可选项。交互式 grid 省略它时,DataGrid 会根据
|
||||
controller 持有的 row identity 派生稳定的内部 Host ref;显式提供它时,
|
||||
该回调拥有 identity,并且必须为每一行返回非 nil 的稳定 Host ref。
|
||||
controller 持有的 row identity 派生稳定的内部 Host ref。fallback ref 不会
|
||||
进入全局 symbol table,并按每个 retained DataGrid instance 隔离,因此多个 grid
|
||||
可以安全复用相同行 identity;显式提供它时,该回调拥有 identity,并且必须为
|
||||
每一行返回非 nil 的稳定 Host ref。
|
||||
`:row-key` 仍然是 retained row 必须具备的非 nil 稳定标量 identity。
|
||||
DataGrid 按 row key 保留唯一 action closure,因此 selection 或 Data Range
|
||||
更新不会为未变化的行重建 handler。
|
||||
整数列 `:width` 表示可读字符容量,不是裸像素;DataGrid 原样使用 Ebox 原生字符单位,
|
||||
并在非末列之间保留一个原生字符间距。
|
||||
并在非末列之间保留一个原生字符间距。使用 `:width '(fr 1)` 让列填充剩余宽度;
|
||||
多个 fractional 列按正数权重分配这部分空间。例如让
|
||||
`(:key :title :width (fr 1))` 与
|
||||
`(:key :actions :width 22 :cell render-actions)` 配合,可以在保留操作控件空间的
|
||||
同时自适应标题宽度。表头和数据行使用相同的轨道及间距。自适应 cell 按分配的
|
||||
宽度裁剪,不会挤宽相邻列。固定列仍保留声明的空间,父布局需要容纳这些控件
|
||||
及列间距。
|
||||
|
||||
自定义 cell 的列宽在固定值与 fractional 值之间切换时,其 Component 状态保持。
|
||||
全固定列的纯文本表格仍保留紧凑的文本渲染路径。
|
||||
|
||||
### 自定义 cell 与列迁移
|
||||
|
||||
Table 与 DataGrid 共用列契约。每一列都必须有唯一且非 nil 的 `:key`
|
||||
(symbol、整数或字符串),纯展示列也一样。默认 cell 将该字段显示为文字。
|
||||
`:cell` 函数接收一个 row,返回 nil、字符串、typed Host 或 Component View,
|
||||
或这些值组成的 proper sequence。Table 拥有 cell 宽度并裁剪溢出;纯文本表格
|
||||
继续使用原有的紧凑表示。
|
||||
|
||||
下面将 `:name` 字段用两个不同的 column key 展示,并在第三列放入普通 Button。
|
||||
行选择与 Open 按钮分别执行自己的动作:
|
||||
|
||||
<!-- etaf-example: cells -->
|
||||
```elisp
|
||||
;;; -*- lexical-binding: t; -*-
|
||||
(require 'etaf-ui)
|
||||
|
||||
(etaf-mount
|
||||
"*etaf-cell-demo*"
|
||||
(etaf-view
|
||||
(etaf-table
|
||||
:rows '((:id 1 :name "Ada"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:on-row-press (lambda (row) (message "Select %s" (plist-get row :name)))
|
||||
:columns
|
||||
(list
|
||||
'(:key :name :label "Name" :width 12)
|
||||
(list :key :name-upper :label "Uppercase" :width 12
|
||||
:cell (lambda (row) (upcase (plist-get row :name))))
|
||||
(list :key :open :label "Action" :width 10
|
||||
:cell
|
||||
(lambda (row)
|
||||
(etaf-view
|
||||
(etaf-button
|
||||
:label "Open"
|
||||
:on-press (lambda ()
|
||||
(message "Open %s" (plist-get row :name)))))))))))
|
||||
```
|
||||
|
||||
迁移重复字段列时,保留一列的 `:key :name`,为另一列指定 `:name-upper` 等唯一
|
||||
key,再通过 `:cell` 读取原来的 `:name` 字段。缺失或重复 column key 都会报错。
|
||||
row key 与 column key 让 cell 身份在重排时保留;改变 key 会替换该 cell 实例。
|
||||
|
||||
cell 函数使用 row 参数与普通词法捕获,Context 来自消费它的 Table/Grid 挂载
|
||||
位置,不会恢复作者的 props、`etaf-state` 或私有样式。cell 需要自己的状态、样式
|
||||
或生命周期时,返回普通 Component,在它的 `:setup` 中创建持久 ref 和 watch。
|
||||
若有意共享作者的 ref,应在创建回调前捕获稳定句柄;不要在每次 cell 函数调用时
|
||||
创建持久状态。
|
||||
|
||||
`etaf-pagination` 是受控 Data Component。它接收 Data controller 以及稳定的
|
||||
`:previous-ref`、`:next-ref`,显示易读的 `←`/`→` 控件和 `Page N / M` 摘要;
|
||||
加载中或已经位于首/末页时会禁用对应动作。它不拥有页码状态,并复用 Button
|
||||
的交互契约。
|
||||
`:previous-ref`、`:next-ref`,使用带内边距的 secondary Button(`‹ Previous` /
|
||||
`Next ›`),中间显示 `Page N / M` 与条数摘要。空间不足时,完整控件和摘要
|
||||
自然换行。加载中或已经位于首/末页时会禁用对应动作。它不拥有页码状态,
|
||||
并复用 Button 的交互契约和 Theme token。可选的 `:previous-label`、
|
||||
`:next-label` 替换完整按钮文案,例如 `"‹ 上一页"`、`"下一页 ›"`;稳定的英文
|
||||
无障碍标签保持不变。
|
||||
|
||||
键盘焦点使用 ETAF 的公共 Runtime 端口:用
|
||||
`(etaf-focus-next runtime)` 在带数值且非负 `:tab-index` 的可见 Host 之间
|
||||
|
||||
225
etaf-ui-basic.el
Normal file
225
etaf-ui-basic.el
Normal file
@ -0,0 +1,225 @@
|
||||
;;; etaf-ui-basic.el --- Basic reusable ETAF UI Components -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Label, Button, Checkbox, and Panel are the catalog's small semantic
|
||||
;; building blocks. NumberInput is the first compound Component and composes
|
||||
;; Button instead of duplicating its interaction contract.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-ui-style)
|
||||
|
||||
(defun etaf-ui--class-value (base state custom)
|
||||
"Return BASE and STATE classes with optional CUSTOM classes."
|
||||
(let ((custom (cond ((null custom) nil)
|
||||
((listp custom) custom)
|
||||
(t (list custom)))))
|
||||
(mapconcat
|
||||
(lambda (class) (format "%s" class))
|
||||
(cl-remove-if
|
||||
(lambda (class) (or (null class) (equal class "")))
|
||||
(append (list base state) custom))
|
||||
" ")))
|
||||
|
||||
(defun etaf-ui--reactive-value (value)
|
||||
"Return VALUE, reading it when it is an ETAF reactive source."
|
||||
(if (or (etaf-ref-p value) (etaf-computed-p value))
|
||||
(etaf-value value)
|
||||
value))
|
||||
|
||||
(defun etaf-ui--text-value (value)
|
||||
"Return VALUE as a Text payload without discarding string properties."
|
||||
(setq value (etaf-ui--reactive-value value))
|
||||
(cond ((null value) "")
|
||||
((stringp value) value)
|
||||
(t (format "%s" value))))
|
||||
|
||||
(defun etaf-ui--label-presentation (variant)
|
||||
"Return semantic presentation for Label VARIANT."
|
||||
(let* ((variant (or variant 'default))
|
||||
(color-key
|
||||
(pcase variant
|
||||
('muted :ui-muted-fg)
|
||||
('danger :ui-danger-fg)
|
||||
('success :ui-success-fg)
|
||||
(_ :ui-fg)))
|
||||
(theme (etaf-ui--style-tokens color-key)))
|
||||
(list :variant variant
|
||||
:color (plist-get theme color-key)
|
||||
:font-weight (when (memq variant '(strong heading)) 'bold))))
|
||||
|
||||
(etaf-ui--define-component etaf-label (&key text variant)
|
||||
"Render TEXT as a semantic Label."
|
||||
:view
|
||||
(text
|
||||
:class (let ((presentation (etaf-ui--label-presentation variant)))
|
||||
(etaf-ui--class-value
|
||||
"etaf-label"
|
||||
(symbol-name (plist-get presentation :variant)) nil))
|
||||
:color (plist-get (etaf-ui--label-presentation variant) :color)
|
||||
:font-weight
|
||||
(plist-get (etaf-ui--label-presentation variant) :font-weight)
|
||||
(expr (etaf-ui--text-value text))))
|
||||
|
||||
(defun etaf-ui--button-variant-values (variant disabled)
|
||||
"Return themed presentation defaults for Button VARIANT and DISABLED."
|
||||
(let* ((fg (cond (disabled :ui-disabled-fg)
|
||||
((eq variant 'secondary) :ui-button-secondary-fg)
|
||||
((eq variant 'ghost) :ui-button-ghost-fg)
|
||||
(t :ui-button-primary-fg)))
|
||||
(bg (cond (disabled :ui-disabled-bg)
|
||||
((eq variant 'secondary) :ui-button-secondary-bg)
|
||||
((eq variant 'ghost) :ui-button-ghost-bg)
|
||||
(t :ui-button-primary-bg)))
|
||||
(border-key
|
||||
(cond (disabled :ui-disabled-border)
|
||||
((eq variant 'secondary) :ui-button-secondary-border)
|
||||
((eq variant 'ghost) :ui-button-ghost-border)
|
||||
(t :ui-button-primary-border)))
|
||||
(theme (etaf-ui--style-tokens fg bg border-key)))
|
||||
(list :color (plist-get theme fg)
|
||||
:bgcolor (plist-get theme bg)
|
||||
:border (etaf-ui--style-border (plist-get theme border-key))
|
||||
:font-weight (if (or disabled (eq variant 'ghost)) 'normal 'bold))))
|
||||
|
||||
(etaf-ui--define-component etaf-button
|
||||
(&key label on-press disabled ref class color bgcolor border padding
|
||||
font-weight tab-index aria-label use variant)
|
||||
"Render a standard pressable Button with a committed callback.
|
||||
|
||||
DISABLED removes the callback and default focus tab index. Presentation props
|
||||
remain caller-overridable. Runtime publishes ON-PRESS with the visible Button,
|
||||
so a failed render keeps the previous callback and its captured values."
|
||||
:render
|
||||
(let* ((label (etaf-ui--text-value label))
|
||||
(variant-values
|
||||
(etaf-ui--button-variant-values
|
||||
(and (not disabled) variant) disabled)))
|
||||
(etaf-node
|
||||
'box
|
||||
(list
|
||||
:class (etaf-ui--class-value
|
||||
"etaf-button"
|
||||
(if disabled "disabled" "enabled")
|
||||
class)
|
||||
:ref ref :role 'button :disabled disabled
|
||||
:tab-index (unless disabled (or tab-index 0))
|
||||
:aria-label (or aria-label label)
|
||||
:color (or color (plist-get variant-values :color))
|
||||
:background-color (or bgcolor (plist-get variant-values :bgcolor))
|
||||
:border (or border (plist-get variant-values :border))
|
||||
:padding padding
|
||||
:font-weight (or font-weight (plist-get variant-values :font-weight))
|
||||
:use use
|
||||
:on-press (and (not disabled) on-press))
|
||||
(list (etaf-node 'text nil (list label)))))
|
||||
:styles
|
||||
(styles
|
||||
("&" :width max-content)
|
||||
("&.disabled" :padding (0 1) :font-weight normal)
|
||||
("&.enabled" :padding (0 1) :font-weight bold)))
|
||||
|
||||
(defun etaf-ui--checkbox-variant-values (disabled)
|
||||
"Return semantic Theme presentation for a DISABLED Checkbox."
|
||||
(let* ((prefix (if disabled "disabled" "enabled"))
|
||||
(fg (intern (format ":ui-checkbox-%s-fg" prefix)))
|
||||
(bg (intern (format ":ui-checkbox-%s-bg" prefix)))
|
||||
(border-key (intern (format ":ui-checkbox-%s-border" prefix)))
|
||||
(theme (etaf-ui--style-tokens fg bg border-key)))
|
||||
(list :color (plist-get theme fg)
|
||||
:bgcolor (plist-get theme bg)
|
||||
:border (etaf-ui--style-border (plist-get theme border-key)))))
|
||||
|
||||
(etaf-ui--define-component etaf-checkbox
|
||||
(&key checked label on-change disabled)
|
||||
"Render a controlled Checkbox whose next value is sent to ON-CHANGE."
|
||||
:view
|
||||
(row
|
||||
:class (etaf-ui--class-value
|
||||
"etaf-checkbox" (if disabled "disabled" "enabled") nil)
|
||||
:role 'checkbox :disabled disabled
|
||||
:aria-label (etaf-ui--text-value label)
|
||||
:tab-index (unless disabled 0)
|
||||
:color (plist-get (etaf-ui--checkbox-variant-values disabled) :color)
|
||||
:background-color
|
||||
(plist-get (etaf-ui--checkbox-variant-values disabled) :bgcolor)
|
||||
:border (plist-get (etaf-ui--checkbox-variant-values disabled) :border)
|
||||
:on-press
|
||||
(and (not disabled) on-change
|
||||
(let ((callback on-change)
|
||||
(source checked))
|
||||
(lambda ()
|
||||
(funcall callback (not (etaf-ui--reactive-value source))))))
|
||||
(box :class "etaf-checkbox-mark"
|
||||
(text (expr (if (etaf-ui--reactive-value checked) "☑" "☐"))))
|
||||
(text (expr
|
||||
(let ((value (etaf-ui--text-value label)))
|
||||
(if (string-empty-p value) "" (concat " " value))))))
|
||||
:styles
|
||||
(styles
|
||||
("&" :width max-content)
|
||||
("&.disabled" :padding (0 1))
|
||||
("&.enabled" :padding (0 1))
|
||||
(".etaf-checkbox-mark" :font-weight bold :width 1)))
|
||||
|
||||
(etaf-ui--define-component etaf-panel (&key title variant)
|
||||
"Render a titled Panel with named header and default slots."
|
||||
:render
|
||||
(let ((theme (etaf-ui--style-tokens
|
||||
:ui-panel-fg :ui-panel-bg :ui-panel-border)))
|
||||
(etaf-node
|
||||
'column
|
||||
(list :class (etaf-ui--class-value
|
||||
"etaf-panel" (symbol-name (or variant 'default)) nil)
|
||||
:color (plist-get theme :ui-panel-fg)
|
||||
:background-color
|
||||
(unless (eq variant 'flat) (plist-get theme :ui-panel-bg))
|
||||
:border
|
||||
(unless (eq variant 'flat)
|
||||
(etaf-ui--style-border (plist-get theme :ui-panel-border))))
|
||||
(append
|
||||
(when title
|
||||
(list (etaf-node
|
||||
'etaf-label
|
||||
(list :class "etaf-panel-title" :text title :variant 'strong)
|
||||
nil)))
|
||||
(etaf-current-slot 'header)
|
||||
(etaf-current-slot 'default))))
|
||||
:styles
|
||||
(styles
|
||||
("&" :padding (1 2))
|
||||
(".etaf-panel-title" :font-weight bold)))
|
||||
|
||||
(etaf-ui--define-component etaf-number-input
|
||||
(&key value label on-change disabled min max)
|
||||
"Render a controlled minibuffer-backed NumberInput using Button."
|
||||
:render
|
||||
(let ((label (or label "Value"))
|
||||
(callback on-change)
|
||||
(current-value value)
|
||||
(minimum min)
|
||||
(maximum max))
|
||||
(etaf-node
|
||||
'etaf-button
|
||||
(list
|
||||
:label (format "%s %s ✎" label (or current-value "—"))
|
||||
:disabled disabled :variant 'ghost
|
||||
:on-press
|
||||
(unless disabled
|
||||
(lambda ()
|
||||
(let ((next (read-number
|
||||
(format "%s: " label) (or current-value 0))))
|
||||
(unless (and (integerp next)
|
||||
(or (null minimum) (>= next minimum))
|
||||
(or (null maximum) (<= next maximum)))
|
||||
(user-error "%s must be an integer from %s to %s"
|
||||
label (or minimum "—") (or maximum "—")))
|
||||
(when callback (funcall callback next))))))
|
||||
nil)))
|
||||
|
||||
(provide 'etaf-ui-basic)
|
||||
;;; etaf-ui-basic.el ends here
|
||||
393
etaf-ui-data.el
Normal file
393
etaf-ui-data.el
Normal file
@ -0,0 +1,393 @@
|
||||
;;; etaf-ui-data.el --- Data-aware ETAF UI Components -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; DataGrid and Pagination adapt ETAF Data Controller state onto basic
|
||||
;; Components. They do not duplicate Table or Button behavior.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'etaf-ui-table)
|
||||
|
||||
(declare-function etaf-data-status "etaf-data" (controller))
|
||||
(declare-function etaf-data-items "etaf-data" (controller))
|
||||
(declare-function etaf-data-page "etaf-data" (controller))
|
||||
(declare-function etaf-data-page-size "etaf-data" (controller))
|
||||
(declare-function etaf-data-total "etaf-data" (controller))
|
||||
(declare-function etaf-data-previous-page "etaf-data" (controller))
|
||||
(declare-function etaf-data-next-page "etaf-data" (controller))
|
||||
(declare-function etaf-data-selected-ref "etaf-data" (controller identity))
|
||||
(declare-function etaf-data-item-identity "etaf-data" (controller item))
|
||||
|
||||
(defun etaf-ui--data-grid-default-row-ref (state controller row)
|
||||
"Return STATE's stable internal Host reference for CONTROLLER and ROW.
|
||||
|
||||
The controller's validated item identity is the row input. Like Table's
|
||||
retained row references, per-instance uninterned symbols prevent cross-grid
|
||||
collisions and avoid process-global symbol-table growth."
|
||||
(let* ((identity (etaf-data-item-identity controller row))
|
||||
(cache (plist-get state :row-refs))
|
||||
(stage (plist-get state :row-ref-stage))
|
||||
(ref (or (gethash identity cache)
|
||||
(and (hash-table-p stage) (gethash identity stage)))))
|
||||
(unless ref
|
||||
(unless (hash-table-p stage)
|
||||
(error "ETAF DataGrid row ref changed outside a keyed candidate"))
|
||||
(setq ref (make-symbol (format "etaf-data-grid-row-%s" identity)))
|
||||
(puthash identity ref stage))
|
||||
ref))
|
||||
|
||||
(defun etaf-ui--data-grid-row-ref
|
||||
(state row-ref on-row-press controller row)
|
||||
"Return a validated stable Host reference for interactive ROW.
|
||||
|
||||
An explicit ROW-REF remains caller-owned. Interactive grids without one use
|
||||
STATE's CONTROLLER identity fallback; when ON-ROW-PRESS is nil, rows have no
|
||||
Host reference."
|
||||
(when on-row-press
|
||||
(let ((ref (if row-ref
|
||||
(funcall row-ref row)
|
||||
(etaf-ui--data-grid-default-row-ref
|
||||
state controller row))))
|
||||
(unless ref
|
||||
(error "ETAF DataGrid :row-ref must return a non-nil stable ref"))
|
||||
ref)))
|
||||
|
||||
(defun etaf-ui--data-grid-row-action-entry ()
|
||||
"Return one committed-state cell and stable DataGrid handler."
|
||||
(let (entry)
|
||||
(setq entry (vector nil nil nil))
|
||||
(aset entry 2
|
||||
(lambda ()
|
||||
(let ((current (aref entry 1)))
|
||||
(when current
|
||||
(funcall current (aref entry 0))))))
|
||||
entry))
|
||||
|
||||
(defun etaf-ui--data-grid-row-action (state key row callback)
|
||||
"Return STATE's stable action for row KEY, staging ROW and CALLBACK.
|
||||
|
||||
Committed handlers read only committed cells. Candidate rendering writes a
|
||||
private stage that lifecycle hooks promote after successful publication."
|
||||
(let* ((cache (plist-get state :row-actions))
|
||||
(stage (plist-get state :row-action-stage))
|
||||
(committed (gethash key cache)))
|
||||
(if (and committed
|
||||
(equal-including-properties row (aref committed 0))
|
||||
(eq callback (aref committed 1)))
|
||||
(aref committed 2)
|
||||
(unless (hash-table-p stage)
|
||||
(error "ETAF DataGrid handler changed outside a keyed candidate"))
|
||||
(let* ((proposal (gethash key stage))
|
||||
(entry (or committed (and proposal (aref proposal 0))
|
||||
(etaf-ui--data-grid-row-action-entry))))
|
||||
(puthash key (vector entry row callback) stage)
|
||||
(aref entry 2)))))
|
||||
|
||||
(defun etaf-ui--data-grid-promote-row-actions (state)
|
||||
"Promote STATE's staged row actions/refs and prune non-live keys."
|
||||
(let ((stage (plist-get state :row-action-stage))
|
||||
(live (plist-get state :row-action-live-keys))
|
||||
(cache (plist-get state :row-actions))
|
||||
(prune-p (plist-get state :row-cache-prune-p)))
|
||||
(when (and (hash-table-p stage) (hash-table-p live))
|
||||
(maphash
|
||||
(lambda (key proposal)
|
||||
(let ((entry (aref proposal 0)))
|
||||
(aset entry 0 (aref proposal 1))
|
||||
(aset entry 1 (aref proposal 2))
|
||||
(puthash key entry cache)))
|
||||
stage)
|
||||
(when prune-p
|
||||
(let (removed)
|
||||
(maphash (lambda (key _entry)
|
||||
(unless (gethash key live) (push key removed)))
|
||||
cache)
|
||||
(dolist (key removed) (remhash key cache))))
|
||||
(setf (plist-get state :row-action-stage) nil
|
||||
(plist-get state :row-action-live-keys) nil)))
|
||||
(let ((stage (plist-get state :row-ref-stage))
|
||||
(live (plist-get state :row-ref-live-identities))
|
||||
(cache (plist-get state :row-refs))
|
||||
(prune-p (plist-get state :row-cache-prune-p)))
|
||||
(when (and (hash-table-p stage) (hash-table-p live))
|
||||
(maphash (lambda (identity ref) (puthash identity ref cache)) stage)
|
||||
(when prune-p
|
||||
(let (removed)
|
||||
(maphash (lambda (identity _ref)
|
||||
(unless (gethash identity live)
|
||||
(push identity removed)))
|
||||
cache)
|
||||
(dolist (identity removed) (remhash identity cache))))
|
||||
(setf (plist-get state :row-ref-stage) nil
|
||||
(plist-get state :row-ref-live-identities) nil
|
||||
(plist-get state :row-cache-prune-p) nil)))
|
||||
state)
|
||||
|
||||
(defun etaf-ui--data-grid-dispose-row-actions (state)
|
||||
"Release all committed and staged row actions in STATE."
|
||||
(clrhash (plist-get state :row-actions))
|
||||
(clrhash (plist-get state :row-refs))
|
||||
(setf (plist-get state :row-action-stage) nil
|
||||
(plist-get state :row-action-live-keys) nil
|
||||
(plist-get state :row-ref-stage) nil
|
||||
(plist-get state :row-ref-live-identities) nil
|
||||
(plist-get state :row-cache-prune-p) nil)
|
||||
state)
|
||||
|
||||
(defun etaf-ui--data-grid-row-selected-p (controller row row-selected-p)
|
||||
"Return whether ROW is selected in CONTROLLER or by ROW-SELECTED-P."
|
||||
(or (and row-selected-p (funcall row-selected-p row))
|
||||
(etaf-value
|
||||
(etaf-data-selected-ref
|
||||
controller (etaf-data-item-identity controller row)))))
|
||||
|
||||
(defun etaf-ui--data-grid-row
|
||||
(state controller entry columns row-ref on-row-press row-selected-p theme)
|
||||
"Return one retained DataGrid row for keyed ENTRY.
|
||||
CONTROLLER owns selection identity; ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P
|
||||
define the interaction contract. STATE retains callback identity and stages
|
||||
candidate values; THEME is the resolved table-paint snapshot for this item."
|
||||
(let* ((key (car entry))
|
||||
(row (cdr entry))
|
||||
(border-color (plist-get theme :ui-table-border))
|
||||
(selected-p
|
||||
(etaf-ui--data-grid-row-selected-p
|
||||
controller row row-selected-p)))
|
||||
(unless key
|
||||
(error "ETAF DataGrid row-key must return a non-nil stable scalar"))
|
||||
(etaf-node
|
||||
'row
|
||||
(list :key key
|
||||
:class (concat "etaf-table-row" (when selected-p " selected"))
|
||||
:ref (etaf-ui--data-grid-row-ref
|
||||
state row-ref on-row-press controller row)
|
||||
:role (when on-row-press 'button)
|
||||
:tab-index (when on-row-press 0)
|
||||
:color (when selected-p
|
||||
(plist-get theme :ui-table-selected-fg))
|
||||
:background-color (when selected-p
|
||||
(plist-get theme :ui-table-selected-bg))
|
||||
:border-bottom-width 1
|
||||
:border-bottom-style 'solid
|
||||
:border-bottom-color border-color
|
||||
:on-press
|
||||
(and on-row-press
|
||||
(etaf-ui--data-grid-row-action
|
||||
state key row on-row-press)))
|
||||
(etaf-ui--table-row-children row columns))))
|
||||
|
||||
(defun etaf-ui--data-grid-state-label (key text &optional class color)
|
||||
"Return TEXT as a non-row DataGrid state label identified by KEY.
|
||||
CLASS and COLOR optionally style the label."
|
||||
(etaf-node 'etaf-label
|
||||
(list :key key :text text :class class :color color)
|
||||
nil))
|
||||
|
||||
(defun etaf-ui--data-grid-body-entries
|
||||
(state controller row-key on-row-press row-ref
|
||||
loading-label error-label empty-label)
|
||||
"Return keyed Range entries and begin STATE's candidate action stage.
|
||||
CONTROLLER and ROW-KEY identify successful rows. ON-ROW-PRESS and ROW-REF
|
||||
determine which current keys retain committed handlers and fallback refs.
|
||||
LOADING-LABEL, ERROR-LABEL, and EMPTY-LABEL override the state text."
|
||||
(let* ((status (etaf-value (etaf-data-status controller)))
|
||||
(items (etaf-value (etaf-data-items controller)))
|
||||
(entries
|
||||
(cond
|
||||
((eq status 'loading)
|
||||
(list (cons 'loading
|
||||
(list :etaf-data-grid-state 'loading
|
||||
:text (or loading-label "Loading...")))))
|
||||
((eq status 'error)
|
||||
(list (cons 'error
|
||||
(list :etaf-data-grid-state 'error
|
||||
:text (or error-label
|
||||
"Unable to load data.")))))
|
||||
(items (etaf-ui--table-entries items row-key))
|
||||
(t
|
||||
(list (cons 'empty
|
||||
(list :etaf-data-grid-state 'empty
|
||||
:text (or empty-label "No data.")))))))
|
||||
(stage (make-hash-table :test #'equal))
|
||||
(live (make-hash-table :test #'equal))
|
||||
(ref-stage (make-hash-table :test #'equal))
|
||||
(ref-live (make-hash-table :test #'equal)))
|
||||
(when (and on-row-press items (not (memq status '(loading error))))
|
||||
(dolist (entry entries) (puthash (car entry) t live))
|
||||
(unless row-ref
|
||||
(dolist (row items)
|
||||
(puthash (etaf-data-item-identity controller row) t ref-live))))
|
||||
(setf (plist-get state :row-action-stage) stage
|
||||
(plist-get state :row-action-live-keys) live
|
||||
(plist-get state :row-ref-stage) ref-stage
|
||||
(plist-get state :row-ref-live-identities) ref-live
|
||||
(plist-get state :row-cache-prune-p)
|
||||
(not (memq status '(loading error))))
|
||||
entries))
|
||||
|
||||
(defun etaf-ui--data-grid-state-entry-node (entry)
|
||||
"Return the state label View represented by keyed ENTRY."
|
||||
(let* ((state (cdr entry))
|
||||
(kind (plist-get state :etaf-data-grid-state))
|
||||
(theme (and (eq kind 'error)
|
||||
(etaf-ui--style-tokens :ui-data-grid-error-fg))))
|
||||
(etaf-ui--data-grid-state-label
|
||||
kind (plist-get state :text)
|
||||
(when (eq kind 'error) "etaf-data-grid-error")
|
||||
(and theme (plist-get theme :ui-data-grid-error-fg)))))
|
||||
|
||||
(etaf-ui--define-component etaf-ui--data-grid-body-item
|
||||
(&key controller entry columns row-ref on-row-press row-selected-p
|
||||
grid-state)
|
||||
"Render one retained keyed DataGrid ENTRY with a cached row action."
|
||||
:render
|
||||
(if (plist-get (cdr entry) :etaf-data-grid-state)
|
||||
(etaf-ui--data-grid-state-entry-node entry)
|
||||
(etaf-ui--data-grid-row
|
||||
grid-state controller entry columns row-ref on-row-press row-selected-p
|
||||
(etaf-ui--style-tokens
|
||||
:ui-table-border :ui-table-selected-fg :ui-table-selected-bg))))
|
||||
|
||||
(etaf-ui--define-component etaf-data-grid
|
||||
(&key controller columns row-key on-row-press row-ref row-selected-p
|
||||
loading-label error-label empty-label)
|
||||
"Render DATA CONTROLLER state through the public Component DSL.
|
||||
|
||||
DataGrid owns loading, error, empty, and controller-selection adaptation.
|
||||
Its keyed Range retains row identity across insert, reorder, and update.
|
||||
Setup state owns per-instance fallback refs plus commit-staged stable row
|
||||
actions; failed candidates cannot mutate committed handler inputs. COLUMNS
|
||||
use Table's unique keys and optional `:cell' row-to-View functions."
|
||||
:setup
|
||||
(let ((state
|
||||
(list :row-actions (make-hash-table :test #'equal)
|
||||
:row-action-stage nil
|
||||
:row-action-live-keys nil
|
||||
:row-refs (make-hash-table :test #'equal)
|
||||
:row-ref-stage nil
|
||||
:row-ref-live-identities nil
|
||||
:row-cache-prune-p nil)))
|
||||
(etaf-on-mounted
|
||||
(lambda () (etaf-ui--data-grid-promote-row-actions state)))
|
||||
(etaf-on-updated
|
||||
(lambda () (etaf-ui--data-grid-promote-row-actions state)))
|
||||
(etaf-on-unmounted
|
||||
(lambda () (etaf-ui--data-grid-dispose-row-actions state)))
|
||||
state)
|
||||
:view
|
||||
(column
|
||||
:class "etaf-data-grid etaf-table"
|
||||
:color (plist-get (etaf-ui--style-tokens :ui-fg) :ui-fg)
|
||||
(etaf-ui--table-header :columns columns)
|
||||
(column
|
||||
:class "etaf-table-body"
|
||||
(etaf-ui--data-grid-body-item
|
||||
:for (entry
|
||||
(etaf-ui--data-grid-body-entries
|
||||
(etaf-state) controller row-key on-row-press row-ref
|
||||
loading-label error-label empty-label))
|
||||
:key (car entry)
|
||||
:controller controller :entry entry :columns columns
|
||||
:row-ref row-ref :on-row-press on-row-press
|
||||
:row-selected-p row-selected-p
|
||||
:grid-state (etaf-state)))
|
||||
(slot :name 'footer)))
|
||||
|
||||
(etaf-ui--define-component etaf-pagination
|
||||
(&key controller previous-ref next-ref previous-label next-label
|
||||
class color bgcolor border padding aria-label)
|
||||
"Render a controlled pager whose callbacks follow its committed CONTROLLER.
|
||||
PREVIOUS-LABEL and NEXT-LABEL override the complete Button captions.
|
||||
Each Button captures its render's Controller; Runtime publishes that callback
|
||||
together with the visible control after a successful render."
|
||||
:render
|
||||
(let ((controller-value controller))
|
||||
(let* ((theme (etaf-ui--style-tokens
|
||||
:ui-fg :ui-bg :ui-pagination-muted-fg))
|
||||
(parent-color (or color (plist-get theme :ui-fg)))
|
||||
(parent-bgcolor (or bgcolor (plist-get theme :ui-bg)))
|
||||
(page (max 1 (or (and controller-value
|
||||
(etaf-value (etaf-data-page controller-value)))
|
||||
1)))
|
||||
(page-size
|
||||
(max 1 (or (and controller-value
|
||||
(etaf-value (etaf-data-page-size controller-value)))
|
||||
1)))
|
||||
(total (max 0 (or (and controller-value
|
||||
(etaf-value (etaf-data-total controller-value)))
|
||||
0)))
|
||||
(pages (max 1 (ceiling (/ (float total) page-size))))
|
||||
(loading-p (and controller-value
|
||||
(eq (etaf-value (etaf-data-status controller-value))
|
||||
'loading)))
|
||||
(previous-disabled (or loading-p (<= page 1)))
|
||||
(next-disabled (or loading-p (>= page pages)))
|
||||
(first-item (if (zerop total) 0
|
||||
(1+ (* (1- page) page-size))))
|
||||
(last-item (min total (* page page-size))))
|
||||
(etaf-node
|
||||
'flex
|
||||
(list :class (etaf-ui--class-value "etaf-pagination" nil class)
|
||||
:width 'stretch :flex-direction 'row :align-items 'center
|
||||
:flex-wrap 'wrap :justify-content 'center
|
||||
:role 'navigation :aria-label (or aria-label "Pagination")
|
||||
:color parent-color :background-color parent-bgcolor
|
||||
:box-sizing 'border-box :padding (or padding '(0 1))
|
||||
:gap '(1 (16)))
|
||||
(list
|
||||
(etaf-node
|
||||
'column
|
||||
(list :width 'max-content
|
||||
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto)
|
||||
(list
|
||||
(etaf-node
|
||||
'etaf-button
|
||||
(list :label (or previous-label "‹ Previous") :ref previous-ref
|
||||
:aria-label "Previous page"
|
||||
:disabled previous-disabled :padding '(0 2)
|
||||
:variant 'secondary :border border
|
||||
:color (and (not previous-disabled) color) :bgcolor bgcolor
|
||||
:on-press
|
||||
(lambda () (etaf-data-previous-page controller-value)))
|
||||
nil)))
|
||||
(etaf-node
|
||||
'column
|
||||
(list :width 'max-content
|
||||
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto)
|
||||
(list
|
||||
(etaf-node
|
||||
'box
|
||||
(list :class "etaf-pagination-label" :text-align 'center
|
||||
:wrap-mode 'none :min-width 'max-content)
|
||||
(list (format "Page %d / %d" page pages)))
|
||||
(etaf-node
|
||||
'box
|
||||
(list :class "etaf-pagination-summary" :text-align 'center
|
||||
:color (plist-get theme :ui-pagination-muted-fg)
|
||||
:wrap-mode 'none :min-width 'max-content)
|
||||
(list (format "%d–%d of %d" first-item last-item total)))))
|
||||
(etaf-node
|
||||
'column
|
||||
(list :width 'max-content
|
||||
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto)
|
||||
(list
|
||||
(etaf-node
|
||||
'etaf-button
|
||||
(list :label (or next-label "Next ›") :ref next-ref
|
||||
:aria-label "Next page"
|
||||
:disabled next-disabled :padding '(0 2)
|
||||
:variant 'secondary :border border
|
||||
:color (and (not next-disabled) color) :bgcolor bgcolor
|
||||
:on-press
|
||||
(lambda () (etaf-data-next-page controller-value)))
|
||||
nil)))))))
|
||||
:styles
|
||||
(styles
|
||||
("&" :width stretch)
|
||||
(".etaf-pagination-label" :font-weight bold)))
|
||||
|
||||
(provide 'etaf-ui-data)
|
||||
;;; etaf-ui-data.el ends here
|
||||
94
etaf-ui-style.el
Normal file
94
etaf-ui-style.el
Normal file
@ -0,0 +1,94 @@
|
||||
;;; etaf-ui-style.el --- Internal styling for ETAF UI Components -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Private catalog styling. ETAF owns Theme; this module only supplies
|
||||
;; fallback values for the semantic tokens consumed by official Components.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf)
|
||||
|
||||
(defvar etaf-ui--component-definition-signatures
|
||||
(make-hash-table :test #'eq)
|
||||
"Exact catalog definitions already installed in the current process.")
|
||||
|
||||
(defmacro etaf-ui--define-component (name arguments &rest clauses)
|
||||
"Define catalog Component NAME once for exact ARGUMENTS and CLAUSES.
|
||||
|
||||
`package.el' may reload dependency files after byte compilation. Identical
|
||||
catalog definitions are idempotent across that reload, while a changed
|
||||
definition still reaches `etaf-define-component' and therefore requires the
|
||||
public `etaf-component-redefine-run' boundary."
|
||||
(declare (indent 2) (debug defun))
|
||||
(let ((signature
|
||||
(secure-hash 'sha256
|
||||
(prin1-to-string (list name arguments clauses)))))
|
||||
`(unless (equal
|
||||
(gethash ',name etaf-ui--component-definition-signatures)
|
||||
,signature)
|
||||
(prog1
|
||||
(etaf-define-component ,name ,arguments ,@clauses)
|
||||
(puthash ',name ,signature
|
||||
etaf-ui--component-definition-signatures)))))
|
||||
|
||||
(defconst etaf-ui--style-palette
|
||||
'(:ui-fg "#252A2E"
|
||||
:ui-bg "#FFFDF8"
|
||||
:ui-border "#687386"
|
||||
:ui-muted-fg "#526174"
|
||||
:ui-danger-fg "#FF6B6B"
|
||||
:ui-success-fg "#2F6B43"
|
||||
:ui-disabled-fg "#687386"
|
||||
:ui-disabled-bg "#E5E7EB"
|
||||
:ui-disabled-border "#9CA3AF"
|
||||
:ui-button-primary-fg "#FFFFFF"
|
||||
:ui-button-primary-bg "#2F6B43"
|
||||
:ui-button-primary-border "#2F6B43"
|
||||
:ui-button-secondary-fg "#142235"
|
||||
:ui-button-secondary-bg "#D9EEEA"
|
||||
:ui-button-secondary-border "#2E8B83"
|
||||
:ui-button-ghost-fg "#142235"
|
||||
:ui-button-ghost-bg "#FFFDF8"
|
||||
:ui-button-ghost-border "#C8C1B6"
|
||||
:ui-checkbox-enabled-fg "#252A2E"
|
||||
:ui-checkbox-enabled-bg "#DCEBDD"
|
||||
:ui-checkbox-enabled-border "#6D8A73"
|
||||
:ui-checkbox-disabled-fg "#6B7280"
|
||||
:ui-checkbox-disabled-bg "#EEEAE2"
|
||||
:ui-checkbox-disabled-border "#9CA3AF"
|
||||
:ui-table-border "#687386"
|
||||
:ui-table-selected-fg "#2F6B43"
|
||||
:ui-table-selected-bg "#DCEBDD"
|
||||
:ui-data-grid-error-fg "#FF6B6B"
|
||||
:ui-pagination-muted-fg "#526174"
|
||||
:ui-panel-fg "#252A2E"
|
||||
:ui-panel-bg "#FFFDF8"
|
||||
:ui-panel-border "#687386")
|
||||
"Fallback values for semantic tokens used by ETAF UI Components.")
|
||||
|
||||
(defun etaf-ui--style-tokens (&rest keys)
|
||||
"Return deferred ETAF Theme values for private catalog token KEYS."
|
||||
(let (result)
|
||||
(dolist (key keys result)
|
||||
(setq result
|
||||
(plist-put
|
||||
result key
|
||||
(etaf-theme-token key (plist-get etaf-ui--style-palette key)))))))
|
||||
|
||||
(defun etaf-ui--style-border (value)
|
||||
"Return canonical border VALUE from a semantic ETAF Theme value."
|
||||
(cond
|
||||
((etaf-theme-token-p value)
|
||||
(etaf-theme-token (nth 1 value) (nth 2 value)
|
||||
#'etaf-ui--style-border))
|
||||
((and (stringp value)
|
||||
(string-match-p "\\`#[[:xdigit:]]+\\'" value))
|
||||
(list 1 'solid value))
|
||||
(t value)))
|
||||
|
||||
(provide 'etaf-ui-style)
|
||||
;;; etaf-ui-style.el ends here
|
||||
291
etaf-ui-table.el
Normal file
291
etaf-ui-table.el
Normal file
@ -0,0 +1,291 @@
|
||||
;;; etaf-ui-table.el --- Presentational Table Component for ETAF UI -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Table renders ordinary rows and columns. It owns no loading, database,
|
||||
;; pagination, or selection state; callers provide optional controlled row
|
||||
;; interaction. DataGrid adapts ETAF Data onto this Component.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-ui-basic)
|
||||
|
||||
(defun etaf-ui--column-value (column key)
|
||||
"Return KEY from COLUMN, accepting a plist or alist descriptor."
|
||||
(if (and (listp column) (keywordp (car column)))
|
||||
(plist-get column key)
|
||||
(alist-get key column)))
|
||||
|
||||
(defun etaf-ui--table-validate-columns (columns)
|
||||
"Return COLUMNS after checking stable identities and optional cell functions."
|
||||
(unless (proper-list-p columns)
|
||||
(error "ETAF Table :columns must be a proper list"))
|
||||
(let ((seen (make-hash-table :test #'equal)))
|
||||
(cl-loop for column in columns for index from 1 do
|
||||
(let ((key (etaf-ui--column-value column :key))
|
||||
(cell (etaf-ui--column-value column :cell))
|
||||
(width (etaf-ui--column-value column :width)))
|
||||
(unless (and key (or (symbolp key) (stringp key) (integerp key)))
|
||||
(error "ETAF Table column %d :key must be a non-nil symbol, integer, or string; got %S"
|
||||
index key))
|
||||
(when (gethash key seen)
|
||||
(error "ETAF Table column %d duplicates :key %S; use a unique key and :cell to repeat a field"
|
||||
index key))
|
||||
(puthash key t seen)
|
||||
(when (and cell (not (functionp cell)))
|
||||
(error "ETAF Table column %d (%S) :cell must be a function of one row; got %S"
|
||||
index key cell))
|
||||
(when (and (consp width) (eq (car width) 'fr)
|
||||
(not (and (proper-list-p width) (= (length width) 2)
|
||||
(numberp (cadr width)) (> (cadr width) 0))))
|
||||
(error "ETAF Table column %d (%S) :width must use (fr POSITIVE-WEIGHT); got %S"
|
||||
index key width)))))
|
||||
columns)
|
||||
|
||||
(defun etaf-ui--table-cell-value (row key)
|
||||
"Return KEY from ROW, accepting a plist, alist, or hash table."
|
||||
(cond
|
||||
((hash-table-p row) (gethash key row))
|
||||
((and (proper-list-p row)
|
||||
(zerop (% (length row) 2))
|
||||
(keywordp (car row)))
|
||||
(plist-get row key))
|
||||
((listp row) (alist-get key row nil nil #'equal))
|
||||
(t nil)))
|
||||
|
||||
(defun etaf-ui--table-fit-text (value column)
|
||||
"Return VALUE fitted to COLUMN's declared character capacity."
|
||||
(let* ((value (format "%s" (or value "")))
|
||||
(width (etaf-ui--column-value column :width)))
|
||||
(if (and (integerp width) (> width 0)
|
||||
(> (string-width value) width))
|
||||
(truncate-string-to-width value width 0 nil "…")
|
||||
value)))
|
||||
|
||||
(defun etaf-ui--table-fixed-text-columns-p (columns)
|
||||
"Return non-nil when COLUMNS can share the compact fixed-text path."
|
||||
(and columns
|
||||
(cl-every
|
||||
(lambda (column)
|
||||
(let ((width (etaf-ui--column-value column :width)))
|
||||
(and (not (etaf-ui--column-value column :cell))
|
||||
(integerp width) (> width 0))))
|
||||
columns)))
|
||||
|
||||
(defun etaf-ui--table-grid (columns cells)
|
||||
"Allocate CELLS with shared COLUMNS tracks and one character between them."
|
||||
(etaf-node
|
||||
'grid
|
||||
(list :width 'stretch
|
||||
:grid-template-columns
|
||||
(mapcar (lambda (column)
|
||||
(or (etaf-ui--column-value column :width) 'max-content))
|
||||
columns)
|
||||
:column-gap 1)
|
||||
cells))
|
||||
|
||||
(defun etaf-ui--table-header-cell (column)
|
||||
"Return one header for COLUMN inside its allocated Grid track."
|
||||
(etaf-node
|
||||
'box
|
||||
(list :class "etaf-table-header-cell"
|
||||
:width 'stretch :overflow 'hidden
|
||||
:wrap-mode 'none)
|
||||
(list
|
||||
(etaf-node
|
||||
'text nil
|
||||
(list
|
||||
(etaf-ui--table-fit-text
|
||||
(or (etaf-ui--column-value column :label)
|
||||
(etaf-ui--column-value column :key))
|
||||
column))))))
|
||||
|
||||
(defun etaf-ui--table-fixed-header-text (columns)
|
||||
"Return one fixed-width header string for COLUMNS, or nil."
|
||||
(when (etaf-ui--table-fixed-text-columns-p columns)
|
||||
(mapconcat
|
||||
(lambda (column)
|
||||
(let* ((width (etaf-ui--column-value column :width))
|
||||
(value
|
||||
(etaf-ui--table-fit-text
|
||||
(or (etaf-ui--column-value column :label)
|
||||
(etaf-ui--column-value column :key))
|
||||
column)))
|
||||
(concat value
|
||||
(make-string (max 0 (- width (string-width value))) ?\s))))
|
||||
columns " ")))
|
||||
|
||||
(defun etaf-ui--table-header (columns)
|
||||
"Return a Table header row for COLUMNS."
|
||||
(etaf-ui--table-validate-columns columns)
|
||||
(let ((theme (etaf-ui--style-tokens :ui-table-border))
|
||||
(fixed-text (etaf-ui--table-fixed-header-text columns)))
|
||||
(etaf-node
|
||||
'row
|
||||
(append
|
||||
(unless fixed-text '(:padding (0 0)))
|
||||
(list :class "etaf-table-header"
|
||||
:border-bottom-width 1 :border-bottom-style 'solid
|
||||
:border-bottom-color (plist-get theme :ui-table-border)))
|
||||
(if fixed-text
|
||||
(list (etaf-node 'text nil (list fixed-text)))
|
||||
(list (etaf-ui--table-grid
|
||||
columns (mapcar #'etaf-ui--table-header-cell columns)))))))
|
||||
|
||||
(defun etaf-ui--table-cell (row column)
|
||||
"Return COLUMN's ordinary View cell for ROW inside its allocated track.
|
||||
Custom cell functions run at this consuming position; Component output owns
|
||||
its usual Context, styles, state, and lifecycle."
|
||||
(etaf-node
|
||||
'box
|
||||
(list :key (etaf-ui--column-value column :key)
|
||||
:class "etaf-table-cell"
|
||||
:width 'stretch
|
||||
:overflow 'hidden
|
||||
:wrap-mode 'none)
|
||||
(list
|
||||
(if-let* ((cell (etaf-ui--column-value column :cell)))
|
||||
(etaf-view (expr (funcall cell row)))
|
||||
(etaf-node
|
||||
'text nil
|
||||
(list
|
||||
(etaf-ui--table-fit-text
|
||||
(etaf-ui--table-cell-value
|
||||
row (etaf-ui--column-value column :key))
|
||||
column)))))))
|
||||
|
||||
(defun etaf-ui--table-cells (row columns)
|
||||
"Return cell Components for ROW using COLUMNS."
|
||||
(cl-loop for column in columns
|
||||
collect
|
||||
(etaf-ui--table-cell row column)))
|
||||
|
||||
(defun etaf-ui--table-fixed-row-text (row columns)
|
||||
"Return one fixed-width ROW string for COLUMNS, or nil when not applicable."
|
||||
(when (etaf-ui--table-fixed-text-columns-p columns)
|
||||
(mapconcat
|
||||
(lambda (column)
|
||||
(let* ((width (etaf-ui--column-value column :width))
|
||||
(value
|
||||
(etaf-ui--table-fit-text
|
||||
(etaf-ui--table-cell-value
|
||||
row (etaf-ui--column-value column :key))
|
||||
column)))
|
||||
(concat value
|
||||
(make-string (max 0 (- width (string-width value))) ?\s))))
|
||||
columns " ")))
|
||||
|
||||
(defun etaf-ui--table-row-children (row columns)
|
||||
"Return the smallest presentation-equivalent child list for ROW.
|
||||
COLUMNS with fixed positive character widths use one padded Text Host.
|
||||
Other cells always share a Grid parent, preserving their identity when column
|
||||
widths change between fixed and fractional tracks."
|
||||
(if-let* ((text (etaf-ui--table-fixed-row-text row columns)))
|
||||
(list (etaf-node 'text nil (list text)))
|
||||
(list (etaf-ui--table-grid columns (etaf-ui--table-cells row columns)))))
|
||||
|
||||
(defun etaf-ui--table-entries (rows row-key)
|
||||
"Return `(KEY . ROW)' entries for ROWS using ROW-KEY.
|
||||
ETAF validates keys and uniqueness."
|
||||
(unless (functionp row-key)
|
||||
(error "ETAF Table requires a function-valued :row-key"))
|
||||
(mapcar (lambda (row) (cons (funcall row-key row) row)) rows))
|
||||
|
||||
(defun etaf-ui--table-row-node
|
||||
(row identity columns row-ref on-row-press row-selected-p)
|
||||
"Return one canonical row Host for ROW and stable IDENTITY.
|
||||
|
||||
The retained Table row shares its cell construction with DataGrid's keyed
|
||||
hot path. COLUMNS define the visible cells;
|
||||
ROW-REF, ON-ROW-PRESS, and ROW-SELECTED-P define optional interaction.
|
||||
Without ROW-REF the Host receives ETAF's usual instance-local reference."
|
||||
(let* ((callback on-row-press)
|
||||
(row-value row)
|
||||
(interactive-p (not (null callback)))
|
||||
(selected-p
|
||||
(progn
|
||||
(when (and row-selected-p (not (functionp row-selected-p)))
|
||||
(error "ETAF Table :row-selected-p must be a function"))
|
||||
(and row-selected-p (funcall row-selected-p row))))
|
||||
(host-ref nil)
|
||||
(theme (etaf-ui--style-tokens
|
||||
:ui-table-border :ui-table-selected-fg
|
||||
:ui-table-selected-bg)))
|
||||
(when interactive-p
|
||||
(unless (functionp on-row-press)
|
||||
(error "ETAF Table :on-row-press must be a function"))
|
||||
(when (and row-ref (not (functionp row-ref)))
|
||||
(error "ETAF Table :row-ref must be a function"))
|
||||
(when row-ref
|
||||
(setq host-ref (funcall row-ref row))
|
||||
(unless host-ref
|
||||
(error "ETAF Table :row-ref must return a non-nil stable ref"))))
|
||||
(etaf-node
|
||||
'row
|
||||
(append
|
||||
(unless (etaf-ui--table-fixed-text-columns-p columns) '(:padding (0 0)))
|
||||
(list :key identity
|
||||
:class (concat "etaf-table-row" (if selected-p " selected" ""))
|
||||
:ref host-ref :role (when interactive-p 'button)
|
||||
:tab-index (when interactive-p 0)
|
||||
:color
|
||||
(when selected-p (plist-get theme :ui-table-selected-fg))
|
||||
:background-color
|
||||
(when selected-p (plist-get theme :ui-table-selected-bg))
|
||||
:border-bottom-width 1 :border-bottom-style 'solid
|
||||
:border-bottom-color (plist-get theme :ui-table-border)
|
||||
:on-press
|
||||
(when interactive-p
|
||||
(lambda () (funcall callback row-value)))))
|
||||
(etaf-ui--table-row-children row columns))))
|
||||
|
||||
(etaf-ui--define-component etaf-ui--table-header (&key columns)
|
||||
"Render one retained Table header."
|
||||
:render (etaf-ui--table-header columns)
|
||||
:styles
|
||||
(styles
|
||||
(".etaf-table-header" :font-weight bold :padding (0 1))
|
||||
(".etaf-table-header-cell" :font-weight bold)))
|
||||
|
||||
(etaf-ui--define-component etaf-ui--table-row
|
||||
(&key row identity columns row-ref on-row-press row-selected-p)
|
||||
"Render one retained Table ROW with stable IDENTITY."
|
||||
:render
|
||||
(etaf-ui--table-row-node
|
||||
row identity columns row-ref on-row-press row-selected-p)
|
||||
:styles
|
||||
(styles
|
||||
(".etaf-table-row" :padding (0 1))))
|
||||
|
||||
(etaf-ui--define-component etaf-table
|
||||
(&key columns rows row-key row-ref on-row-press row-selected-p)
|
||||
"Render ordinary ROWS as a presentational Table.
|
||||
|
||||
COLUMNS contain a unique non-nil `:key', optional `:label', `:width',
|
||||
and `:cell' function accepting one row and returning ordinary View content.
|
||||
Integer widths are character capacities; `(fr N)' shares the remaining width
|
||||
by positive weight N.
|
||||
Without `:cell', the key reads a text field from the row. Cell state belongs
|
||||
in a returned Component, whose Context comes from the consuming Table.
|
||||
ROW-KEY supplies stable identity. ROW-REF is only needed for caller-owned
|
||||
addresses; interactive rows otherwise receive instance-local references.
|
||||
Interaction and selection are controlled optional inputs; Table never owns
|
||||
application or Data Controller state."
|
||||
:view
|
||||
(column
|
||||
:class "etaf-table"
|
||||
:color (plist-get (etaf-ui--style-tokens :ui-fg) :ui-fg)
|
||||
(etaf-ui--table-header :columns columns)
|
||||
(column :class "etaf-table-body"
|
||||
(etaf-ui--table-row
|
||||
:for (entry (etaf-ui--table-entries rows row-key))
|
||||
:key (car entry)
|
||||
:row (cdr entry) :identity (car entry) :columns columns
|
||||
:row-ref row-ref :on-row-press on-row-press
|
||||
:row-selected-p row-selected-p))))
|
||||
|
||||
(provide 'etaf-ui-table)
|
||||
;;; etaf-ui-table.el ends here
|
||||
963
etaf-ui.el
963
etaf-ui.el
@ -8,967 +8,14 @@
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; The official ETAF catalog is one ordinary Component library. It does not
|
||||
;; expose a parallel Control/Widget taxonomy: a DataGrid is a compound
|
||||
;; Component built from the same View, props, slots, events, and Data APIs.
|
||||
;; Public facade for Components defined with ETAF. The catalog exposes no
|
||||
;; second Widget runtime, Theme system, data store, or layout engine.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf)
|
||||
|
||||
(declare-function etaf-data-status "etaf-data" (controller))
|
||||
(declare-function etaf-data-items "etaf-data" (controller))
|
||||
(declare-function etaf-data-page "etaf-data" (controller))
|
||||
(declare-function etaf-data-page-size "etaf-data" (controller))
|
||||
(declare-function etaf-data-total "etaf-data" (controller))
|
||||
(declare-function etaf-data-previous-page "etaf-data" (controller))
|
||||
(declare-function etaf-data-next-page "etaf-data" (controller))
|
||||
(declare-function etaf-data-selected-ref "etaf-data" (controller identity))
|
||||
(declare-function etaf-theme-defaults "etaf-context" (&optional default))
|
||||
(declare-function text "etaf-view" (&rest arguments))
|
||||
(declare-function box "etaf-view" (&rest arguments))
|
||||
(declare-function expr "etaf-view" (&rest arguments))
|
||||
(declare-function slot "etaf-view" (&rest arguments))
|
||||
|
||||
(defconst etaf-ui--default-theme-palette
|
||||
'(:ui-fg "#252A2E"
|
||||
:ui-bg "#FFFDF8"
|
||||
:ui-border "#687386"
|
||||
:ui-muted-fg "#526174"
|
||||
:ui-danger-fg "#FF6B6B"
|
||||
:ui-success-fg "#2F6B43"
|
||||
:ui-disabled-fg "#687386"
|
||||
:ui-disabled-bg "#E5E7EB"
|
||||
:ui-disabled-border "#9CA3AF"
|
||||
:ui-button-primary-fg "#FFFFFF"
|
||||
:ui-button-primary-bg "#2F6B43"
|
||||
:ui-button-primary-border "#2F6B43"
|
||||
:ui-button-secondary-fg "#142235"
|
||||
:ui-button-secondary-bg "#D9EEEA"
|
||||
:ui-button-secondary-border "#2E8B83"
|
||||
:ui-button-ghost-fg "#142235"
|
||||
:ui-button-ghost-bg "#FFFDF8"
|
||||
:ui-button-ghost-border "#C8C1B6"
|
||||
:ui-checkbox-enabled-fg "#252A2E"
|
||||
:ui-checkbox-enabled-bg "#DCEBDD"
|
||||
:ui-checkbox-enabled-border "#6D8A73"
|
||||
:ui-checkbox-disabled-fg "#6B7280"
|
||||
:ui-checkbox-disabled-bg "#EEEAE2"
|
||||
:ui-checkbox-disabled-border "#9CA3AF"
|
||||
:ui-grid-border "#687386"
|
||||
:ui-grid-selected-fg "#2F6B43"
|
||||
:ui-grid-selected-bg "#DCEBDD"
|
||||
:ui-grid-error-fg "#FF6B6B"
|
||||
:ui-pagination-muted-fg "#526174"
|
||||
:ui-panel-fg "#252A2E"
|
||||
:ui-panel-bg "#FFFDF8"
|
||||
:ui-panel-border "#687386")
|
||||
"Default semantic UI palette, centralized outside Component definitions.
|
||||
|
||||
Applications normally override these tokens through ETAF Theme. Keeping the
|
||||
fallback palette here gives the catalog a useful standalone appearance while
|
||||
ensuring every Component reads one shared semantic vocabulary.")
|
||||
|
||||
(defconst etaf-ui--legacy-theme-aliases
|
||||
'((:ui-fg :color)
|
||||
(:ui-bg :bgcolor)
|
||||
(:ui-border :border)
|
||||
(:ui-button-primary-fg :ui-button-color)
|
||||
(:ui-button-primary-bg :ui-button-bgcolor)
|
||||
(:ui-button-primary-border :ui-button-border)
|
||||
(:ui-button-secondary-fg :ui-button-secondary-color)
|
||||
(:ui-button-secondary-bg :ui-button-secondary-bgcolor)
|
||||
(:ui-button-secondary-border :ui-button-secondary-border)
|
||||
(:ui-button-ghost-fg :ui-button-ghost-color)
|
||||
(:ui-button-ghost-bg :ui-button-ghost-bgcolor)
|
||||
(:ui-button-ghost-border :ui-button-ghost-border)
|
||||
(:ui-disabled-fg :ui-button-disabled-color)
|
||||
(:ui-disabled-bg :ui-button-disabled-bgcolor)
|
||||
(:ui-disabled-border :ui-button-disabled-border))
|
||||
"Compatibility aliases for the first ETAF UI Theme token spelling.")
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-ui-theme-values (&rest requested)
|
||||
"Return merged semantic UI Theme values for REQUESTED tokens.
|
||||
|
||||
Inherited application tokens win, legacy aliases remain readable, and the
|
||||
central catalog palette fills only omitted values. This is the boundary
|
||||
between generic ETAF Theme Context and etaf-ui's product-independent visual
|
||||
semantics; individual Components do not own separate color systems. When
|
||||
REQUESTED is nil, return the complete catalog token map."
|
||||
(let* ((inherited (etaf-theme-defaults))
|
||||
(defaults etaf-ui--default-theme-palette)
|
||||
;; Callers that request a subset only need that semantic subset.
|
||||
;; Keeping the full inherited plist is useful for the no-argument
|
||||
;; catalog query, but copying it for every Button/Panel/DataGrid
|
||||
;; render needlessly scales Theme work with application token count.
|
||||
(result (unless requested (copy-sequence inherited)))
|
||||
(keys (or requested
|
||||
(cl-loop for (key _spec) on defaults by #'cddr
|
||||
collect key))))
|
||||
(dolist (key keys)
|
||||
(let ((found
|
||||
(cond
|
||||
((plist-member inherited key)
|
||||
(cons t (plist-get inherited key)))
|
||||
(t
|
||||
(cl-loop for alias in etaf-ui--legacy-theme-aliases
|
||||
when (and (eq (car alias) key)
|
||||
(plist-member inherited (cadr alias)))
|
||||
return
|
||||
(cons t (plist-get inherited (cadr alias))))))))
|
||||
(setq result
|
||||
(plist-put result key
|
||||
(if found (cdr found) (plist-get defaults key)))))
|
||||
)
|
||||
result))
|
||||
|
||||
(defun etaf-ui-theme-tokens (&rest requested)
|
||||
"Return deferred semantic Theme tokens for REQUESTED UI keys.
|
||||
|
||||
Catalog defaults and legacy aliases are encoded as nested token fallbacks, so
|
||||
Host lowering can update paint properties without making the current
|
||||
Component render depend on the Theme source."
|
||||
(let ((keys (or requested
|
||||
(cl-loop for (key _spec) on etaf-ui--default-theme-palette
|
||||
by #'cddr collect key)))
|
||||
result)
|
||||
(dolist (key keys result)
|
||||
(let* ((default (plist-get etaf-ui--default-theme-palette key))
|
||||
(alias (cadr (assq key etaf-ui--legacy-theme-aliases)))
|
||||
(fallback (if alias (etaf-theme-token alias default) default)))
|
||||
(setq result
|
||||
(plist-put result key (etaf-theme-token key fallback)))))))
|
||||
|
||||
(defun etaf-ui--theme-border (value)
|
||||
"Return Ebox border VALUE, preserving complete caller-owned specs.
|
||||
|
||||
Semantic Theme border tokens conventionally contain a color string. The
|
||||
catalog turns a hex color into a one-pixel solid border; an existing canonical
|
||||
border value remains unchanged."
|
||||
(cond
|
||||
((etaf-theme-token-p value)
|
||||
(etaf-theme-token (nth 1 value) (nth 2 value)
|
||||
#'etaf-ui--theme-border))
|
||||
((and (stringp value)
|
||||
(string-match-p "\\`#[[:xdigit:]]+\\'" value))
|
||||
(list 1 'solid value))
|
||||
(t value)))
|
||||
|
||||
(defun etaf-ui--class-value (base state custom)
|
||||
"Return BASE and STATE classes with optional CUSTOM classes."
|
||||
(let ((custom (cond
|
||||
((null custom) nil)
|
||||
((listp custom) custom)
|
||||
(t (list custom)))))
|
||||
(mapconcat (lambda (class) (format "%s" class))
|
||||
(cl-remove-if (lambda (class)
|
||||
(or (null class) (equal class "")))
|
||||
(append (list base state) custom))
|
||||
" ")))
|
||||
|
||||
(defun etaf-ui--reactive-value (value)
|
||||
"Return VALUE, reading it when it is an ETAF reactive source."
|
||||
(if (or (etaf-ref-p value) (etaf-computed-p value))
|
||||
(etaf-value value)
|
||||
value))
|
||||
|
||||
(defun etaf-ui--button-variant-values (variant disabled)
|
||||
"Return themed presentation defaults for Button VARIANT and DISABLED."
|
||||
(let* ((fg (cond (disabled :ui-disabled-fg)
|
||||
((eq variant 'secondary) :ui-button-secondary-fg)
|
||||
((eq variant 'ghost) :ui-button-ghost-fg)
|
||||
(t :ui-button-primary-fg)))
|
||||
(bg (cond (disabled :ui-disabled-bg)
|
||||
((eq variant 'secondary) :ui-button-secondary-bg)
|
||||
((eq variant 'ghost) :ui-button-ghost-bg)
|
||||
(t :ui-button-primary-bg)))
|
||||
(border (cond (disabled :ui-disabled-border)
|
||||
((eq variant 'secondary) :ui-button-secondary-border)
|
||||
((eq variant 'ghost) :ui-button-ghost-border)
|
||||
(t :ui-button-primary-border)))
|
||||
(theme (etaf-ui-theme-tokens fg bg border)))
|
||||
(list :color (plist-get theme fg)
|
||||
:bgcolor (plist-get theme bg)
|
||||
:border (etaf-ui--theme-border (plist-get theme border))
|
||||
:font-weight (if (or disabled (eq variant 'ghost)) 'normal 'bold))))
|
||||
|
||||
(defun etaf-ui--button-view
|
||||
(label on-press disabled ref class color bgcolor border padding font-weight
|
||||
tab-index aria-label use)
|
||||
"Return a Button Host showing LABEL.
|
||||
|
||||
ON-PRESS and USE provide callbacks and Behaviors. DISABLED controls whether
|
||||
the Host is interactive. REF, CLASS, COLOR, BGCOLOR, BORDER, PADDING,
|
||||
FONT-WEIGHT,
|
||||
TAB-INDEX, and ARIA-LABEL provide Host identity and presentation."
|
||||
(let ((class-value (etaf-ui--class-value
|
||||
"etaf-button"
|
||||
(if disabled "disabled" "enabled")
|
||||
class))
|
||||
(tab-value (unless disabled (or tab-index 0)))
|
||||
(label-value (or aria-label label)))
|
||||
(if on-press
|
||||
(etaf-view
|
||||
(box :class class-value :role 'button :ref ref :disabled disabled
|
||||
:tab-index tab-value :aria-label label-value
|
||||
:color color :bgcolor bgcolor :border border
|
||||
:padding padding :font-weight font-weight
|
||||
:use (unless disabled use) :on-press on-press
|
||||
(text (expr :value label))))
|
||||
(etaf-view
|
||||
(box :class class-value :role 'button :ref ref :disabled disabled
|
||||
:tab-index tab-value :aria-label label-value
|
||||
:color color :bgcolor bgcolor :border border
|
||||
:padding padding :font-weight font-weight
|
||||
:use (unless disabled use)
|
||||
(text (expr :value label)))))))
|
||||
|
||||
(defun etaf-ui--checkbox-variant-values (theme disabled)
|
||||
"Return semantic Theme values from THEME for DISABLED Checkbox state."
|
||||
(let ((prefix (if disabled "disabled" "enabled")))
|
||||
(list :color (plist-get theme
|
||||
(intern (format ":ui-checkbox-%s-fg" prefix)))
|
||||
:bgcolor (plist-get theme
|
||||
(intern (format ":ui-checkbox-%s-bg" prefix)))
|
||||
:border
|
||||
(etaf-ui--theme-border
|
||||
(plist-get theme
|
||||
(intern (format ":ui-checkbox-%s-border" prefix)))))))
|
||||
|
||||
(defun etaf-ui--column-value (column key)
|
||||
"Return KEY from COLUMN, accepting a plist or alist descriptor."
|
||||
(if (and (listp column) (keywordp (car column)))
|
||||
(plist-get column key)
|
||||
(alist-get key column)))
|
||||
|
||||
(defun etaf-ui--grid-cell-value (row key)
|
||||
"Return KEY from data ROW, accepting a plist, alist, or hash table."
|
||||
(cond
|
||||
((hash-table-p row) (gethash key row))
|
||||
((and (proper-list-p row)
|
||||
(zerop (% (length row) 2))
|
||||
(keywordp (car row)))
|
||||
(plist-get row key))
|
||||
((listp row) (alist-get key row))
|
||||
(t nil)))
|
||||
|
||||
(defun etaf-ui--grid-fit-text (value column)
|
||||
"Return VALUE fitted to COLUMN's declared character capacity."
|
||||
(let* ((value (format "%s" (or value "")))
|
||||
(width (etaf-ui--column-value column :width)))
|
||||
(if (and (integerp width) (> width 0)
|
||||
(> (string-width value) width))
|
||||
(truncate-string-to-width value width 0 nil "…")
|
||||
value)))
|
||||
|
||||
(defun etaf-ui--grid-display-value (row column)
|
||||
"Return one single-line display value for ROW and COLUMN.
|
||||
|
||||
DataGrid columns are tabular tracks, not prose paragraphs. Keep each cell on
|
||||
one visual line and use an ellipsis when a fixed character-width descriptor is
|
||||
too small; the original ROW remains intact for selection and callbacks."
|
||||
(etaf-ui--grid-fit-text
|
||||
(etaf-ui--grid-cell-value row (etaf-ui--column-value column :key))
|
||||
column))
|
||||
|
||||
(defun etaf-ui--grid-track-width (column gap-p)
|
||||
"Return COLUMN width with one native-character gap when GAP-P is non-nil."
|
||||
(let ((width (etaf-ui--column-value column :width)))
|
||||
(if (and gap-p (integerp width) (> width 0))
|
||||
(1+ width)
|
||||
width)))
|
||||
|
||||
(defun etaf-ui--grid-header-cell (column gap-p)
|
||||
"Return one header View for COLUMN, adding air when GAP-P is non-nil."
|
||||
(etaf--view-call
|
||||
'box
|
||||
(list :class "etaf-data-grid-header-cell"
|
||||
:width (etaf-ui--grid-track-width column gap-p))
|
||||
(list
|
||||
(etaf--view-call
|
||||
'text nil
|
||||
(list
|
||||
(etaf-ui--grid-fit-text
|
||||
(or (etaf-ui--column-value column :label)
|
||||
(etaf-ui--column-value column :key))
|
||||
column))))))
|
||||
|
||||
(defun etaf-ui--grid-header (columns theme)
|
||||
"Return a View header row for COLUMNS using semantic THEME colors."
|
||||
(etaf-view
|
||||
(row :class "etaf-data-grid-header"
|
||||
:border (etaf-ui--theme-border
|
||||
(plist-get theme :ui-grid-border))
|
||||
(expr :value
|
||||
(cl-loop for column in columns
|
||||
for tail on columns
|
||||
collect (etaf-ui--grid-header-cell
|
||||
column (cdr tail)))))))
|
||||
|
||||
(defun etaf-ui--grid-cell (row column gap-p host-ref)
|
||||
"Return one data cell View for ROW and COLUMN using HOST-REF and GAP-P."
|
||||
(etaf--view-call
|
||||
'box
|
||||
(list :ref host-ref :width (etaf-ui--grid-track-width column gap-p))
|
||||
(list
|
||||
(etaf--view-call
|
||||
'text nil (list (etaf-ui--grid-display-value row column))))))
|
||||
|
||||
(defun etaf-ui--grid-cells (row columns cell-refs)
|
||||
"Return data cell Views for ROW and COLUMNS using stable CELL-REFS."
|
||||
(cl-loop for column in columns
|
||||
for tail on columns
|
||||
for index from 0
|
||||
collect
|
||||
(etaf-ui--grid-cell
|
||||
row column (cdr tail)
|
||||
(or (gethash index cell-refs)
|
||||
(puthash index (gensym "etaf-data-grid-cell-")
|
||||
cell-refs)))))
|
||||
|
||||
(defun etaf-ui--grid-selected-p
|
||||
(row key selected-key row-selected-p selected-ref)
|
||||
"Return whether ROW with KEY is selected.
|
||||
ROW-SELECTED-P and SELECTED-KEY preserve custom controlled selection;
|
||||
SELECTED-REF supplies the controller-backed keyed default."
|
||||
(or (and row-selected-p (funcall row-selected-p row))
|
||||
(and selected-key (equal key selected-key))
|
||||
(and selected-ref (etaf-value selected-ref))))
|
||||
|
||||
(defun etaf-ui--grid-row-action (cache key row callback)
|
||||
"Return CACHE's stable row action for KEY, refreshing ROW and CALLBACK."
|
||||
(let ((entry (gethash key cache)))
|
||||
(unless entry
|
||||
(setq entry (vector row callback nil))
|
||||
(aset entry 2
|
||||
(lambda ()
|
||||
(let ((current (aref entry 1)))
|
||||
(when current
|
||||
(funcall current (aref entry 0))))))
|
||||
(puthash key entry cache))
|
||||
(aset entry 0 row)
|
||||
(aset entry 1 callback)
|
||||
(aref entry 2)))
|
||||
|
||||
(defun etaf-ui--grid-row
|
||||
(row key columns row-ref on-row-press selected-key row-selected-p
|
||||
selected-ref row-actions theme internal-row-ref cell-refs)
|
||||
"Return a View row for ROW and COLUMNS using THEME and the DataGrid contract.
|
||||
|
||||
KEY is ROW's stable identity; ROW-REF returns the interactive reference;
|
||||
ON-ROW-PRESS, SELECTED-KEY, ROW-SELECTED-P, and SELECTED-REF control state.
|
||||
ROW-ACTIONS owns stable keyed callbacks across body reevaluation."
|
||||
(let* ((interactive-p (not (null on-row-press)))
|
||||
(selected-p
|
||||
(lambda ()
|
||||
(etaf-ui--grid-selected-p
|
||||
row key selected-key row-selected-p selected-ref)))
|
||||
(host-ref internal-row-ref))
|
||||
(unless key
|
||||
(error "ETAF DataGrid row-key must return a non-nil stable scalar"))
|
||||
(when interactive-p
|
||||
(unless (functionp row-ref)
|
||||
(error "ETAF DataGrid requires :row-ref for interactive rows"))
|
||||
(setq host-ref (funcall row-ref row))
|
||||
(unless host-ref
|
||||
(error "ETAF DataGrid :row-ref must return a non-nil stable ref")))
|
||||
(etaf--view-call
|
||||
'row
|
||||
(list :key key
|
||||
:class
|
||||
(etaf--expr-create
|
||||
:thunk (lambda ()
|
||||
(concat "etaf-data-grid-row"
|
||||
(if (funcall selected-p) " selected" ""))))
|
||||
:ref host-ref
|
||||
:role (when interactive-p 'button)
|
||||
:tab-index (when interactive-p 0)
|
||||
:border-bottom-width 1
|
||||
:border-bottom-style 'solid
|
||||
:border-bottom-color (plist-get theme :ui-grid-border)
|
||||
:on-press (when interactive-p
|
||||
(etaf-ui--grid-row-action
|
||||
row-actions key row on-row-press))
|
||||
:bgcolor
|
||||
(etaf--expr-create
|
||||
:thunk (lambda ()
|
||||
(when (funcall selected-p)
|
||||
(plist-get theme :ui-grid-selected-bg)))))
|
||||
(etaf-ui--grid-cells row columns cell-refs))))
|
||||
|
||||
(defun etaf-ui--grid-row-state (states key)
|
||||
"Return STATES' retained internal row and cell refs for KEY."
|
||||
(or (gethash key states)
|
||||
(let ((state (cons (gensym "etaf-data-grid-row-")
|
||||
(make-hash-table :test #'eql))))
|
||||
(puthash key state states)
|
||||
state)))
|
||||
|
||||
(defun etaf-ui--grid-keyed-items
|
||||
(items row-key row-actions row-states)
|
||||
"Return validated `(KEY . ITEM)' entries and prune retained row caches."
|
||||
(let ((seen (make-hash-table :test #'equal)) entries)
|
||||
(dolist (item items)
|
||||
(let ((key (funcall row-key item)))
|
||||
(unless key
|
||||
(error "ETAF DataGrid row-key must return a non-nil stable scalar"))
|
||||
(when (gethash key seen)
|
||||
(error "ETAF DataGrid row-key must be unique: %S" key))
|
||||
(puthash key t seen)
|
||||
(push (cons key item) entries)))
|
||||
(maphash
|
||||
(lambda (key _entry)
|
||||
(unless (gethash key seen)
|
||||
(remhash key row-actions)
|
||||
(remhash key row-states)))
|
||||
row-actions)
|
||||
(nreverse entries)))
|
||||
|
||||
(defun etaf-ui--grid-rows
|
||||
(controller items columns row-key row-ref on-row-press selected-key
|
||||
row-selected-p row-actions row-states &optional theme)
|
||||
"Return keyed Host rows and prune caches outside current ITEMS.
|
||||
CONTROLLER owns keyed default selection refs. COLUMNS and ROW-KEY describe
|
||||
cells and identity. ROW-REF, ON-ROW-PRESS, SELECTED-KEY, and ROW-SELECTED-P
|
||||
provide interaction state. ROW-ACTIONS and ROW-STATES retain callback and
|
||||
internal Host identities. THEME optionally supplies resolved colors."
|
||||
(let* ((theme (or theme
|
||||
;; Resolve Theme once in the retained DataGrid owner
|
||||
;; of doing it independently in every row Component.
|
||||
(etaf-ui-theme-tokens :ui-grid-border
|
||||
:ui-grid-selected-fg
|
||||
:ui-grid-selected-bg)))
|
||||
(entries
|
||||
(etaf-ui--grid-keyed-items
|
||||
items row-key row-actions row-states)))
|
||||
(mapcar
|
||||
(lambda (entry)
|
||||
(let* ((key (car entry))
|
||||
(item (cdr entry))
|
||||
(state (etaf-ui--grid-row-state row-states key)))
|
||||
(etaf-ui--grid-row
|
||||
item key columns row-ref on-row-press selected-key row-selected-p
|
||||
(unless (or row-selected-p selected-key)
|
||||
(etaf-data-selected-ref controller key))
|
||||
row-actions theme (car state) (cdr state))))
|
||||
entries)))
|
||||
|
||||
(defun etaf-ui--grid-body-items
|
||||
(controller status items columns row-key row-ref on-row-press selected-key
|
||||
row-selected-p row-actions row-states theme loading-label
|
||||
error-label empty-label)
|
||||
"Return CONTROLLER DataGrid body items for STATUS and ITEMS.
|
||||
COLUMNS and ROW-KEY describe rows; ROW-REF and ON-ROW-PRESS add interaction.
|
||||
SELECTED-KEY, ROW-SELECTED-P, and ROW-ACTIONS preserve controlled behavior.
|
||||
THEME supplies colors, while LOADING-LABEL, ERROR-LABEL, and EMPTY-LABEL
|
||||
customize state messages. The parent Component directly owns the result."
|
||||
(unless (functionp row-key)
|
||||
(error "ETAF DataGrid requires a function-valued :row-key"))
|
||||
(when (and on-row-press (not (functionp on-row-press)))
|
||||
(error "ETAF DataGrid :on-row-press must be a function"))
|
||||
(when (and on-row-press (not (functionp row-ref)))
|
||||
(error "ETAF DataGrid requires :row-ref for interactive rows"))
|
||||
(when (and row-selected-p (not (functionp row-selected-p)))
|
||||
(error "ETAF DataGrid :row-selected-p must be a function"))
|
||||
(cond
|
||||
((eq status 'loading)
|
||||
(list (etaf--view-call 'text nil
|
||||
(list (or loading-label "Loading...")))))
|
||||
((eq status 'error)
|
||||
(list
|
||||
(etaf--view-call
|
||||
'text
|
||||
(list :class "etaf-data-grid-error"
|
||||
:color (plist-get (etaf-ui-theme-tokens :ui-grid-error-fg)
|
||||
:ui-grid-error-fg))
|
||||
(list (or error-label "Unable to load data.")))))
|
||||
((null items)
|
||||
(list (etaf--view-call 'text nil
|
||||
(list (or empty-label "No data.")))))
|
||||
(t
|
||||
(etaf-ui--grid-rows
|
||||
controller items columns row-key row-ref on-row-press selected-key
|
||||
row-selected-p row-actions row-states theme))))
|
||||
|
||||
(defun etaf-ui--button-setup ()
|
||||
"Create the retained renderer for one Button instance."
|
||||
(let* ((current-callback nil)
|
||||
(current-press-p nil)
|
||||
(press nil))
|
||||
(setq press
|
||||
(lambda ()
|
||||
(when current-press-p
|
||||
(when current-callback
|
||||
(funcall current-callback)))))
|
||||
(lambda ()
|
||||
(let* ((label (etaf-current-prop :label))
|
||||
(callback (etaf-current-prop :on-press))
|
||||
(disabled (etaf-current-prop :disabled))
|
||||
(use (etaf-current-prop :use))
|
||||
(press-p (and (not disabled) (or callback use))))
|
||||
(setq current-callback callback
|
||||
current-press-p press-p)
|
||||
(let* ((variant (and (not disabled) (etaf-current-prop :variant)))
|
||||
(variant-values
|
||||
(etaf-ui--button-variant-values variant disabled)))
|
||||
(etaf-ui--button-view
|
||||
label (and press-p press) disabled (etaf-current-prop :ref)
|
||||
(etaf-current-prop :class)
|
||||
(or (etaf-current-prop :color)
|
||||
(plist-get variant-values :color))
|
||||
(or (etaf-current-prop :bgcolor)
|
||||
(plist-get variant-values :bgcolor))
|
||||
(or (etaf-current-prop :border)
|
||||
(plist-get variant-values :border))
|
||||
(etaf-current-prop :padding)
|
||||
(or (etaf-current-prop :font-weight)
|
||||
(plist-get variant-values :font-weight))
|
||||
(etaf-current-prop :tab-index)
|
||||
(etaf-current-prop :aria-label)
|
||||
use))))))
|
||||
|
||||
;;;###autoload
|
||||
(etaf-define-component etaf-button
|
||||
(&key label on-press disabled ref class color bgcolor border padding font-weight
|
||||
tab-index aria-label use variant)
|
||||
"Render a standard pressable button with LABEL and ON-PRESS.
|
||||
|
||||
DISABLED removes the callback and the default focus tab index. Product
|
||||
appearance is controlled by VARIANT and the shared interactive surface
|
||||
contract; callers can still override presentation with the ordinary props."
|
||||
:styles
|
||||
(styles
|
||||
("&" :width max-content)
|
||||
;; State classes carry semantic state only. Resolved presentation props
|
||||
;; above remain authoritative, so a themed disabled Button cannot inherit
|
||||
;; the catalog's light default surface.
|
||||
("&.disabled" :padding (0 1) :font-weight normal)
|
||||
("&.enabled" :padding (0 1) :font-weight bold))
|
||||
:setup
|
||||
(etaf-ui--button-setup))
|
||||
|
||||
(etaf-define-component etaf-number-input
|
||||
(&key value label on-change ref disabled min max aria-label)
|
||||
"Render a controlled minibuffer-backed numeric input.
|
||||
|
||||
VALUE is displayed as a Button. Activating it reads a number through
|
||||
Emacs's native minibuffer, validates optional MIN and MAX bounds, and calls
|
||||
ON-CHANGE with the accepted integer. The Component owns prompting and
|
||||
validation; the caller owns the value and subsequent state write."
|
||||
:setup
|
||||
(let ((callback (etaf-current-prop :on-change)))
|
||||
(lambda ()
|
||||
(let* ((value (etaf-current-prop :value))
|
||||
(label (or (etaf-current-prop :label) "Value"))
|
||||
(min-value (etaf-current-prop :min))
|
||||
(max-value (etaf-current-prop :max))
|
||||
(disabled (etaf-current-prop :disabled))
|
||||
(ref (etaf-current-prop :ref))
|
||||
(aria-label (etaf-current-prop :aria-label)))
|
||||
(etaf-view
|
||||
(button
|
||||
:label (format "%s %s ✎" label (or value "—"))
|
||||
:ref ref :disabled disabled
|
||||
:aria-label (or aria-label label)
|
||||
:variant 'ghost
|
||||
:on-press
|
||||
(unless disabled
|
||||
(lambda ()
|
||||
(let ((next (read-number
|
||||
(format "%s: " label) (or value 0))))
|
||||
(unless (and (integerp next)
|
||||
(or (null min-value) (>= next min-value))
|
||||
(or (null max-value) (<= next max-value)))
|
||||
(user-error "%s must be an integer from %s to %s"
|
||||
label (or min-value "—") (or max-value "—")))
|
||||
(when callback (funcall callback next)))))))))))
|
||||
|
||||
(defun etaf-ui--checkbox-view
|
||||
(checked label on-change ref disabled class color bgcolor border padding
|
||||
font-weight tab-index aria-label)
|
||||
"Return LABEL checkbox View with captured CHECKED and ON-PRESS.
|
||||
REF, DISABLED, CLASS, COLOR, BGCOLOR, BORDER, PADDING, FACE, TAB-INDEX, and
|
||||
ARIA-LABEL provide its semantic and presentation properties."
|
||||
(etaf-view
|
||||
(row
|
||||
:class (etaf-ui--class-value
|
||||
"etaf-checkbox" (if disabled "disabled" "enabled") class)
|
||||
:role 'checkbox :ref ref :disabled disabled
|
||||
:aria-label (or aria-label label)
|
||||
:tab-index (unless disabled (or tab-index 0))
|
||||
:color color :bgcolor bgcolor :border border :padding padding :font-weight font-weight
|
||||
:on-press on-change
|
||||
(box :class "etaf-checkbox-mark"
|
||||
(text (expr :value
|
||||
(if (etaf-ui--reactive-value checked) "☑" "☐"))))
|
||||
(text (expr :value (if label (concat " " label) ""))))))
|
||||
|
||||
;;;###autoload
|
||||
(etaf-define-component etaf-checkbox
|
||||
(&key checked label on-change ref disabled class color bgcolor border padding
|
||||
font-weight tab-index aria-label)
|
||||
"Render a controlled checkbox with CHECKED, LABEL, and ON-CHANGE.
|
||||
|
||||
CHECKED may be a boolean or an ETAF reactive source. ON-CHANGE receives the
|
||||
next boolean value. State ownership stays with the caller, so the Component
|
||||
works with local refs or Data-backed forms."
|
||||
:styles
|
||||
(styles
|
||||
("&" :width max-content)
|
||||
;; Color, background, and border are resolved through the shared semantic
|
||||
;; Theme map in :setup; styles keep only geometry defaults.
|
||||
("&.disabled" :padding (0 1))
|
||||
("&.enabled" :padding (0 1))
|
||||
(".etaf-checkbox-mark" :font-weight bold :width 1))
|
||||
:setup
|
||||
(let* ((current-checked nil)
|
||||
(current-callback nil)
|
||||
(press
|
||||
(lambda ()
|
||||
(when current-callback
|
||||
(funcall current-callback
|
||||
(not (etaf-ui--reactive-value current-checked)))))))
|
||||
(lambda ()
|
||||
(let* ((theme (etaf-ui-theme-tokens :ui-fg :ui-bg
|
||||
:ui-checkbox-enabled-fg
|
||||
:ui-checkbox-enabled-bg
|
||||
:ui-checkbox-enabled-border
|
||||
:ui-checkbox-disabled-fg
|
||||
:ui-checkbox-disabled-bg
|
||||
:ui-checkbox-disabled-border))
|
||||
(variant-values
|
||||
(etaf-ui--checkbox-variant-values
|
||||
theme (etaf-current-prop :disabled))))
|
||||
(setq current-checked (etaf-current-prop :checked)
|
||||
current-callback
|
||||
(when (and (not (etaf-current-prop :disabled))
|
||||
(etaf-current-prop :on-change))
|
||||
(etaf-current-prop :on-change)))
|
||||
(etaf-ui--checkbox-view
|
||||
current-checked (etaf-current-prop :label)
|
||||
(and current-callback press)
|
||||
(etaf-current-prop :ref) (etaf-current-prop :disabled)
|
||||
(etaf-current-prop :class)
|
||||
(or (etaf-current-prop :color)
|
||||
(plist-get variant-values :color))
|
||||
(or (etaf-current-prop :bgcolor)
|
||||
(plist-get variant-values :bgcolor))
|
||||
(or (etaf-current-prop :border)
|
||||
(plist-get variant-values :border))
|
||||
(etaf-current-prop :padding) (etaf-current-prop :font-weight)
|
||||
(etaf-current-prop :tab-index) (etaf-current-prop :aria-label))))))
|
||||
|
||||
;;;###autoload
|
||||
(etaf-define-component etaf-label
|
||||
(&key text font-weight class color bgcolor border padding ref width)
|
||||
"Render TEXT as a semantic label with presentation properties.
|
||||
TEXT may be an ordinary value or an ETAF reactive source."
|
||||
:view
|
||||
(expr
|
||||
:value
|
||||
(if (or border padding width)
|
||||
(etaf-view
|
||||
(box :class class :font-weight font-weight :color color
|
||||
:bgcolor bgcolor :border border :padding padding
|
||||
:ref ref :width width
|
||||
(text (expr :value (etaf-ui--reactive-value text)))))
|
||||
(etaf-view
|
||||
(text :class class :font-weight font-weight :color color
|
||||
:bgcolor bgcolor :ref ref
|
||||
(expr :value (etaf-ui--reactive-value text)))))))
|
||||
|
||||
(defun etaf-ui--panel-view (title class color bgcolor border padding ref)
|
||||
"Render a themed Panel View.
|
||||
Arguments are TITLE, CLASS, COLOR, BGCOLOR, BORDER, PADDING, and REF."
|
||||
(let ((theme (etaf-ui-theme-tokens :ui-panel-fg :ui-panel-bg
|
||||
:ui-panel-border)))
|
||||
(etaf-view
|
||||
(column
|
||||
:class (etaf-ui--class-value "etaf-panel" nil class)
|
||||
:color (or color (plist-get theme :ui-panel-fg))
|
||||
:bgcolor (or bgcolor (plist-get theme :ui-panel-bg))
|
||||
:border (or border
|
||||
(etaf-ui--theme-border
|
||||
(plist-get theme :ui-panel-border)))
|
||||
:padding padding :ref ref
|
||||
(expr
|
||||
:value
|
||||
(when title
|
||||
(etaf-view (text :class "etaf-panel-title"
|
||||
(expr :value title)))))
|
||||
(slot :name 'header)
|
||||
(slot)))))
|
||||
|
||||
;;;###autoload
|
||||
(etaf-define-component etaf-panel
|
||||
(&key title class color bgcolor border padding ref)
|
||||
"Render a titled panel with header and default slot projections."
|
||||
:styles
|
||||
(styles
|
||||
("&" :padding (1 2))
|
||||
(".etaf-panel-title" :font-weight bold))
|
||||
:view
|
||||
(expr :value
|
||||
(etaf-ui--panel-view title class color bgcolor border padding ref)))
|
||||
|
||||
;;;###autoload
|
||||
(etaf-define-component etaf-data-grid
|
||||
(&key controller columns row-key on-row-press
|
||||
row-ref selected-key row-selected-p loading-label error-label
|
||||
empty-label)
|
||||
"Render rows from reactive DATA CONTROLLER and COLUMNS.
|
||||
|
||||
COLUMNS is a list of descriptors such as `(:key :name :label NAME)'. ROW-KEY
|
||||
receives each row and must return a stable scalar identity. Data owns loading,
|
||||
errors, pagination, mutation, and selection; this Component only projects
|
||||
those values into ordinary Hosts. Interactive rows require ROW-REF to return
|
||||
a stable Host reference."
|
||||
:styles
|
||||
(styles
|
||||
(".etaf-data-grid-header" :font-weight bold :padding (0 1))
|
||||
(".etaf-data-grid-header-cell" :font-weight bold)
|
||||
(".etaf-data-grid-row" :padding (0 1))
|
||||
;; Selection color and error color are dynamic semantic props below, so
|
||||
;; this Component style scope contains geometry only.
|
||||
)
|
||||
:setup
|
||||
(let ((row-actions (make-hash-table :test #'equal))
|
||||
(row-states (make-hash-table :test #'equal))
|
||||
current-controller current-columns current-row-key current-row-ref
|
||||
current-on-row-press current-selected-key current-row-selected-p
|
||||
current-loading-label current-error-label current-empty-label
|
||||
body-config body-expr body-thunk body-range-snapshot body-range-item)
|
||||
(setq
|
||||
body-thunk
|
||||
(lambda ()
|
||||
(let* ((status
|
||||
(etaf-value (etaf-data-status current-controller)))
|
||||
(items
|
||||
(etaf-value (etaf-data-items current-controller)))
|
||||
(theme
|
||||
(etaf-ui-theme-tokens :ui-grid-border
|
||||
:ui-grid-selected-bg)))
|
||||
(etaf-ui--grid-body-items
|
||||
current-controller status items current-columns current-row-key
|
||||
current-row-ref current-on-row-press current-selected-key
|
||||
current-row-selected-p row-actions row-states theme
|
||||
current-loading-label current-error-label current-empty-label))))
|
||||
(setq
|
||||
body-range-snapshot
|
||||
(lambda ()
|
||||
(let ((status (etaf-value (etaf-data-status current-controller)))
|
||||
(items (etaf-value (etaf-data-items current-controller))))
|
||||
(when (and (eq status 'success) items)
|
||||
(let ((theme
|
||||
(etaf-ui-theme-tokens :ui-grid-border
|
||||
:ui-grid-selected-bg)))
|
||||
(list
|
||||
:items
|
||||
(etaf-ui--grid-keyed-items
|
||||
items current-row-key row-actions row-states)
|
||||
:context theme))))))
|
||||
(setq
|
||||
body-range-item
|
||||
(lambda (entry theme)
|
||||
(let* ((key (car entry))
|
||||
(item (cdr entry))
|
||||
(state (etaf-ui--grid-row-state row-states key)))
|
||||
(etaf-ui--grid-row
|
||||
item key current-columns current-row-ref current-on-row-press
|
||||
current-selected-key current-row-selected-p
|
||||
(unless (or current-row-selected-p current-selected-key)
|
||||
(etaf-data-selected-ref current-controller key))
|
||||
row-actions theme (car state) (cdr state)))))
|
||||
(lambda ()
|
||||
(let* ((controller (etaf-current-prop :controller))
|
||||
(columns (etaf-current-prop :columns))
|
||||
(row-key (etaf-current-prop :row-key))
|
||||
(row-ref (etaf-current-prop :row-ref))
|
||||
(on-row-press (etaf-current-prop :on-row-press))
|
||||
(selected-key (etaf-current-prop :selected-key))
|
||||
(row-selected-p (etaf-current-prop :row-selected-p))
|
||||
(loading-label (etaf-current-prop :loading-label))
|
||||
(error-label (etaf-current-prop :error-label))
|
||||
(empty-label (etaf-current-prop :empty-label))
|
||||
(config
|
||||
(list controller columns row-key row-ref on-row-press
|
||||
selected-key row-selected-p loading-label error-label
|
||||
empty-label))
|
||||
(theme (etaf-ui-theme-tokens :ui-fg :ui-grid-border))
|
||||
(theme-color (plist-get theme :ui-fg)))
|
||||
(unless (eq controller current-controller)
|
||||
(clrhash row-actions)
|
||||
(clrhash row-states))
|
||||
(setq current-controller controller
|
||||
current-columns columns
|
||||
current-row-key row-key
|
||||
current-row-ref row-ref
|
||||
current-on-row-press on-row-press
|
||||
current-selected-key selected-key
|
||||
current-row-selected-p row-selected-p
|
||||
current-loading-label loading-label
|
||||
current-error-label error-label
|
||||
current-empty-label empty-label)
|
||||
(unless (equal-including-properties config body-config)
|
||||
(setq body-config (copy-tree config)
|
||||
body-expr
|
||||
(etaf--expr-create
|
||||
:token (gensym "etaf-data-grid-body-")
|
||||
:thunk body-thunk
|
||||
:range-snapshot body-range-snapshot
|
||||
:range-key #'car
|
||||
:range-item body-range-item)))
|
||||
(etaf--view-call
|
||||
'column
|
||||
(list :class "etaf-data-grid" :color theme-color)
|
||||
(list
|
||||
(etaf-ui--grid-header columns theme)
|
||||
(etaf--view-call
|
||||
'column (list :class "etaf-data-grid-body")
|
||||
(list body-expr))
|
||||
(etaf--slot-projection-create
|
||||
:name 'footer :token 'etaf-ui-data-grid-footer :fallback nil)))))))
|
||||
|
||||
;;;###autoload
|
||||
(etaf-define-component etaf-pagination
|
||||
(&key controller previous-ref next-ref class color bgcolor border padding
|
||||
aria-label)
|
||||
"Render a compact, accessible pager for DATA CONTROLLER.
|
||||
|
||||
The pager owns no data state: page, page-size, total, loading, and error stay
|
||||
with CONTROLLER. PREVIOUS-REF and NEXT-REF should be stable public refs when
|
||||
the pager participates in keyboard/mouse interaction. The visible glyphs
|
||||
(`←' and `→') are paired with labels and help text so the compact control is
|
||||
readable in both GUI and text review."
|
||||
:styles
|
||||
(styles
|
||||
("&" :width stretch)
|
||||
(".etaf-pagination-label" :font-weight bold))
|
||||
:setup
|
||||
(let* ((current-controller nil)
|
||||
(current-parent-color nil)
|
||||
(current-parent-bgcolor nil)
|
||||
(page-value
|
||||
(lambda ()
|
||||
(max 1 (or (etaf-value
|
||||
(etaf-data-page current-controller))
|
||||
1))))
|
||||
(page-size-value
|
||||
(lambda ()
|
||||
(max 1 (or (etaf-value
|
||||
(etaf-data-page-size current-controller))
|
||||
1))))
|
||||
(total-value
|
||||
(lambda ()
|
||||
(max 0 (or (etaf-value
|
||||
(etaf-data-total current-controller))
|
||||
0))))
|
||||
(pages-value
|
||||
(lambda ()
|
||||
(max 1 (ceiling (/ (float (funcall total-value))
|
||||
(funcall page-size-value))))))
|
||||
(loading-p
|
||||
(lambda ()
|
||||
(eq (etaf-value (etaf-data-status current-controller))
|
||||
'loading)))
|
||||
(previous-disabled
|
||||
(lambda ()
|
||||
(or (funcall loading-p) (<= (funcall page-value) 1))))
|
||||
(next-disabled
|
||||
(lambda ()
|
||||
(or (funcall loading-p)
|
||||
(>= (funcall page-value) (funcall pages-value)))))
|
||||
(previous
|
||||
(lambda ()
|
||||
(when (and current-controller
|
||||
(not (funcall previous-disabled)))
|
||||
(etaf-data-previous-page current-controller))))
|
||||
(next
|
||||
(lambda ()
|
||||
(when (and current-controller
|
||||
(not (funcall next-disabled)))
|
||||
(etaf-data-next-page current-controller)))))
|
||||
(lambda ()
|
||||
(let* ((controller-value (etaf-current-prop :controller))
|
||||
(theme (etaf-ui-theme-tokens :ui-fg :ui-bg
|
||||
:ui-disabled-fg
|
||||
:ui-pagination-muted-fg))
|
||||
(parent-color (or (etaf-current-prop :color)
|
||||
(plist-get theme :ui-fg)))
|
||||
(parent-bgcolor (or (etaf-current-prop :bgcolor)
|
||||
(plist-get theme :ui-bg)))
|
||||
(arrow-border '(0 solid "transparent")))
|
||||
(setq current-controller controller-value
|
||||
current-parent-color parent-color
|
||||
current-parent-bgcolor parent-bgcolor)
|
||||
(etaf-view
|
||||
(flex
|
||||
:class (etaf-ui--class-value "etaf-pagination" nil
|
||||
(etaf-current-prop :class))
|
||||
:width 'stretch
|
||||
:flex-direction 'row
|
||||
:align-items 'center
|
||||
:role 'navigation
|
||||
:aria-label (or (etaf-current-prop :aria-label) "Pagination")
|
||||
:color parent-color
|
||||
:bgcolor parent-bgcolor
|
||||
:border (etaf-current-prop :border)
|
||||
:box-sizing 'border-box
|
||||
:padding (or (etaf-current-prop :padding) '(0 1))
|
||||
:gap '(0 (1))
|
||||
(column :width 'max-content
|
||||
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto
|
||||
(button :label "←" :ref (etaf-current-prop :previous-ref)
|
||||
:aria-label "Previous page"
|
||||
:disabled (funcall previous-disabled)
|
||||
:padding '(0 0)
|
||||
:border arrow-border
|
||||
:color (if (funcall previous-disabled)
|
||||
(plist-get theme :ui-disabled-fg)
|
||||
current-parent-color)
|
||||
:bgcolor current-parent-bgcolor
|
||||
:font-weight 'bold
|
||||
:on-press previous))
|
||||
(column
|
||||
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
|
||||
(box :class "etaf-pagination-label" :text-align 'center
|
||||
:wrap-mode 'none :min-width 'max-content
|
||||
(text
|
||||
(expr :value
|
||||
(format "Page %d / %d"
|
||||
(funcall page-value)
|
||||
(funcall pages-value)))))
|
||||
(box :class "etaf-pagination-summary" :text-align 'center
|
||||
:color (plist-get theme :ui-pagination-muted-fg)
|
||||
:wrap-mode 'none :min-width 'max-content
|
||||
(text
|
||||
(expr :value
|
||||
(let* ((page (funcall page-value))
|
||||
(page-size (funcall page-size-value))
|
||||
(total (funcall total-value))
|
||||
(first-item
|
||||
(if (zerop total)
|
||||
0
|
||||
(1+ (* (1- page) page-size))))
|
||||
(last-item (min total (* page page-size))))
|
||||
(format "%d–%d of %d"
|
||||
first-item last-item total))))))
|
||||
(column :width 'max-content
|
||||
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto
|
||||
(button :label "→" :ref (etaf-current-prop :next-ref)
|
||||
:aria-label "Next page"
|
||||
:disabled (funcall next-disabled)
|
||||
:padding '(0 0)
|
||||
:border arrow-border
|
||||
:color (if (funcall next-disabled)
|
||||
(plist-get theme :ui-disabled-fg)
|
||||
current-parent-color)
|
||||
:bgcolor current-parent-bgcolor
|
||||
:font-weight 'bold
|
||||
:on-press next))))))))
|
||||
(require 'etaf-ui-basic)
|
||||
(require 'etaf-ui-table)
|
||||
(require 'etaf-ui-data)
|
||||
|
||||
(provide 'etaf-ui)
|
||||
|
||||
;;; etaf-ui.el ends here
|
||||
|
||||
273
scripts/etaf-ui-m0a-inventory.el
Normal file
273
scripts/etaf-ui-m0a-inventory.el
Normal file
@ -0,0 +1,273 @@
|
||||
;;; etaf-ui-m0a-inventory.el --- M0a Component inventory -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
;; Machine-readable current-behavior inventory. This file deliberately
|
||||
;; records private consumers as drift; M0a does not turn the M0b target into a
|
||||
;; failing current gate.
|
||||
|
||||
;;; Code:
|
||||
(require 'cl-lib)
|
||||
(require 'seq)
|
||||
|
||||
(defconst etaf-ui-m0a--package-root
|
||||
(file-name-directory
|
||||
(directory-file-name
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"Absolute etaf-ui package root used by the inventory.")
|
||||
|
||||
(defconst etaf-ui-m0a-public-component-contracts
|
||||
'((:name etaf-label
|
||||
:business-props (text variant)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-basic.el")
|
||||
(:name etaf-button
|
||||
:business-props (label on-press disabled ref class color bgcolor border
|
||||
padding font-weight tab-index aria-label use variant)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-basic.el")
|
||||
(:name etaf-checkbox
|
||||
:business-props (checked label on-change disabled)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-basic.el")
|
||||
(:name etaf-panel
|
||||
:business-props (title variant)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-basic.el")
|
||||
(:name etaf-number-input
|
||||
:business-props (value label on-change disabled min max)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-basic.el")
|
||||
(:name etaf-table
|
||||
:business-props (columns rows row-key row-ref on-row-press row-selected-p)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-table.el")
|
||||
(:name etaf-data-grid
|
||||
:business-props (controller columns row-key on-row-press row-ref
|
||||
row-selected-p loading-label error-label
|
||||
empty-label)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-data.el")
|
||||
(:name etaf-pagination
|
||||
:business-props (controller previous-ref next-ref previous-label next-label
|
||||
class color bgcolor border padding aria-label)
|
||||
:forwarded-host-attrs all-valid-host-attrs
|
||||
:root-guarantee single-host-root
|
||||
:definition "etaf-ui-data.el"))
|
||||
"Observed contracts of the eight public etaf-ui Components.
|
||||
|
||||
`all-valid-host-attrs' names the core single-root Component forwarding rule;
|
||||
it is not a claim that every attribute is a declared business prop.")
|
||||
|
||||
(defconst etaf-ui-m0a-private-production-callsites
|
||||
'((:symbol etaf--expr-create :scope production
|
||||
:file "etaf-ui-data.el" :line 93)
|
||||
(:symbol etaf--expr-create :scope production
|
||||
:file "etaf-ui-data.el" :line 106)
|
||||
(:symbol etaf--expr-create :scope production
|
||||
:file "etaf-ui-data.el" :line 114)
|
||||
(:symbol etaf--expr-create :scope production
|
||||
:file "etaf-ui-data.el" :line 234)
|
||||
(:symbol etaf--view-call :scope production
|
||||
:file "etaf-ui-data.el" :line 278)
|
||||
(:symbol etaf--view-call :scope production
|
||||
:file "etaf-ui-data.el" :line 284)
|
||||
(:symbol etaf--slot-projection-create :scope production
|
||||
:file "etaf-ui-data.el" :line 286))
|
||||
"Exact M0a baseline of production calls into private ETAF functions.")
|
||||
|
||||
(defconst etaf-ui-m0b-private-production-callsites nil
|
||||
"M0b target and current production calls into private ETAF functions.")
|
||||
|
||||
(defun etaf-ui-m0a--read-top-level-forms (file)
|
||||
"Return top-level forms and source lines read from FILE."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(goto-char (point-min))
|
||||
(let (forms form start)
|
||||
(condition-case nil
|
||||
(while t
|
||||
(setq start (point)
|
||||
form (read (current-buffer)))
|
||||
(push (list :form form :line (line-number-at-pos start)) forms))
|
||||
(end-of-file nil))
|
||||
(nreverse forms))))
|
||||
|
||||
(defun etaf-ui-m0a--component-definitions ()
|
||||
"Return public Component definitions observed in package product files."
|
||||
(let (result)
|
||||
(dolist (file (directory-files etaf-ui-m0a--package-root t
|
||||
"\\`etaf-ui-.*\\.el\\'"))
|
||||
(dolist (entry (etaf-ui-m0a--read-top-level-forms file))
|
||||
(let ((form (plist-get entry :form)))
|
||||
(when (and (memq (car-safe form)
|
||||
'(etaf-define-component
|
||||
etaf-ui--define-component))
|
||||
(symbolp (cadr form))
|
||||
(not (string-prefix-p "etaf-ui--"
|
||||
(symbol-name (cadr form)))))
|
||||
(let ((arguments (nth 2 form)))
|
||||
(push (list :name (cadr form)
|
||||
:business-props
|
||||
(seq-filter #'symbolp
|
||||
(cdr (memq '&key arguments)))
|
||||
:definition
|
||||
(file-relative-name file etaf-ui-m0a--package-root)
|
||||
:line (plist-get entry :line))
|
||||
result))))))
|
||||
(sort result (lambda (left right)
|
||||
(string< (symbol-name (plist-get left :name))
|
||||
(symbol-name (plist-get right :name)))))))
|
||||
|
||||
(defun etaf-ui-m0a-component-inventory ()
|
||||
"Return the current eight-Component contract with observed source lines."
|
||||
(let ((definitions (etaf-ui-m0a--component-definitions)))
|
||||
(mapcar
|
||||
(lambda (contract)
|
||||
(let* ((name (plist-get contract :name))
|
||||
(observed (seq-find
|
||||
(lambda (entry) (eq name (plist-get entry :name)))
|
||||
definitions)))
|
||||
(append (copy-sequence contract)
|
||||
(list :observed-business-props
|
||||
(plist-get observed :business-props)
|
||||
:observed-definition (plist-get observed :definition)
|
||||
:line (plist-get observed :line)
|
||||
:drift
|
||||
(unless (and observed
|
||||
(equal (plist-get contract :business-props)
|
||||
(plist-get observed :business-props))
|
||||
(equal (plist-get contract :definition)
|
||||
(plist-get observed :definition)))
|
||||
'contract-mismatch)))))
|
||||
etaf-ui-m0a-public-component-contracts)))
|
||||
|
||||
(defun etaf-ui-m0a--private-occurrences-in-file (file scope root call-only)
|
||||
"Return active private occurrences in FILE under SCOPE and ROOT.
|
||||
|
||||
When CALL-ONLY is non-nil, record only symbols in function-call position.
|
||||
The linear scanner excludes strings and both line and block comments."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(goto-char (point-min))
|
||||
(let ((block-depth 0)
|
||||
in-string
|
||||
escaped
|
||||
result)
|
||||
(while (< (point) (point-max))
|
||||
(cond
|
||||
((> block-depth 0)
|
||||
(cond ((looking-at "#|")
|
||||
(setq block-depth (1+ block-depth))
|
||||
(forward-char 2))
|
||||
((looking-at "|#")
|
||||
(setq block-depth (1- block-depth))
|
||||
(forward-char 2))
|
||||
(t (forward-char 1))))
|
||||
(in-string
|
||||
(let ((character (char-after)))
|
||||
(forward-char 1)
|
||||
(cond (escaped (setq escaped nil))
|
||||
((eq character ?\\) (setq escaped t))
|
||||
((eq character ?\") (setq in-string nil)))))
|
||||
((looking-at "#|")
|
||||
(setq block-depth 1)
|
||||
(forward-char 2))
|
||||
((eq (char-after) ?\;)
|
||||
(forward-line 1))
|
||||
((eq (char-after) ?\")
|
||||
(setq in-string t)
|
||||
(forward-char 1))
|
||||
((eq (char-after) ??)
|
||||
;; Skip an Emacs Lisp character literal, including ?\\X.
|
||||
(forward-char (min (if (eq (char-after (1+ (point))) ?\\) 3 2)
|
||||
(- (point-max) (point)))))
|
||||
((and call-only (eq (char-after) ?\())
|
||||
(forward-char 1)
|
||||
(skip-chars-forward " \t\r\n")
|
||||
(when (looking-at "\\(etaf--[[:alnum:]-]+\\)\\_>")
|
||||
(push (list :symbol (intern (match-string-no-properties 1))
|
||||
:scope scope
|
||||
:file (file-relative-name file root)
|
||||
:line (line-number-at-pos (point)))
|
||||
result)))
|
||||
((and (not call-only)
|
||||
(looking-at "\\_<\\(etaf--[[:alnum:]-]+\\)\\_>"))
|
||||
(push (list :symbol (intern (match-string-no-properties 1))
|
||||
:scope scope
|
||||
:file (file-relative-name file root)
|
||||
:line (line-number-at-pos (point)))
|
||||
result)
|
||||
(goto-char (match-end 1)))
|
||||
(t (forward-char 1))))
|
||||
(nreverse result))))
|
||||
|
||||
(defun etaf-ui-m0a-private-consumers (&optional root)
|
||||
"Return active core-private consumers below ROOT.
|
||||
|
||||
ROOT defaults to the etaf-ui package root."
|
||||
(let* ((root (file-name-as-directory
|
||||
(or root etaf-ui-m0a--package-root)))
|
||||
(tests-directory (expand-file-name "tests" root))
|
||||
(files (append
|
||||
(directory-files root t
|
||||
"\\`etaf-ui-.*\\.el\\'")
|
||||
(when (file-directory-p tests-directory)
|
||||
(directory-files tests-directory t "\\.el\\'"))))
|
||||
result)
|
||||
(dolist (file files)
|
||||
;; The inventory's own expectation literals are evidence vocabulary,
|
||||
;; not calls into the private API under inventory.
|
||||
(unless (string-suffix-p "etaf-ui-m0a-inventory-tests.el" file)
|
||||
(setq result
|
||||
(nconc result
|
||||
(if (string-match-p "/tests/" file)
|
||||
(etaf-ui-m0a--private-occurrences-in-file
|
||||
file 'test root nil)
|
||||
(etaf-ui-m0a--private-occurrences-in-file
|
||||
file 'production root t))))))
|
||||
result))
|
||||
|
||||
(defun etaf-ui-m0a-private-consumer-drift (&optional root)
|
||||
"Return current M0b production private-call drift below optional ROOT."
|
||||
(let ((observed
|
||||
(seq-filter
|
||||
(lambda (entry) (eq 'production (plist-get entry :scope)))
|
||||
(etaf-ui-m0a-private-consumers root))))
|
||||
(list :expected etaf-ui-m0b-private-production-callsites
|
||||
:observed observed
|
||||
:missing (seq-remove (lambda (entry) (member entry observed))
|
||||
etaf-ui-m0b-private-production-callsites)
|
||||
:unexpected
|
||||
(seq-remove (lambda (entry)
|
||||
(member entry etaf-ui-m0b-private-production-callsites))
|
||||
observed))))
|
||||
|
||||
(defun etaf-ui-m0a-inventory ()
|
||||
"Return the complete machine-readable etaf-ui M0a inventory."
|
||||
(list :schema-version 1
|
||||
:milestone 'M0b
|
||||
:evidence-mode 'migrated-public-extension-seam
|
||||
:datagrid-contract
|
||||
'(:handler-publication postcommit-promoted
|
||||
:fallback-ref instance-scoped-uninterned
|
||||
:fixed-width-row single-text-host)
|
||||
:components (etaf-ui-m0a-component-inventory)
|
||||
:m0a-private-production-baseline
|
||||
etaf-ui-m0a-private-production-callsites
|
||||
:private-consumers (etaf-ui-m0a-private-consumers)
|
||||
:private-production-drift (etaf-ui-m0a-private-consumer-drift)))
|
||||
|
||||
(defun etaf-ui-m0a-inventory-batch ()
|
||||
"Print `etaf-ui-m0a-inventory' for a batch evidence run."
|
||||
(prin1 (etaf-ui-m0a-inventory))
|
||||
(terpri))
|
||||
|
||||
(provide 'etaf-ui-m0a-inventory)
|
||||
;;; etaf-ui-m0a-inventory.el ends here
|
||||
76
tests/etaf-ui-button-commit-tests.el
Normal file
76
tests/etaf-ui-button-commit-tests.el
Normal 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
706
tests/etaf-ui-cell-tests.el
Normal 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
85
tests/etaf-ui-docs-tests.el
Normal 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
|
||||
187
tests/etaf-ui-m0a-inventory-tests.el
Normal file
187
tests/etaf-ui-m0a-inventory-tests.el
Normal file
@ -0,0 +1,187 @@
|
||||
;;; etaf-ui-m0a-inventory-tests.el --- M0a inventory tests -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
(require 'ert)
|
||||
(require 'seq)
|
||||
(require 'etaf-ui)
|
||||
(declare-function etaf-ui-m0a-component-inventory
|
||||
"../scripts/etaf-ui-m0a-inventory")
|
||||
(declare-function etaf-ui-m0a-private-consumers
|
||||
"../scripts/etaf-ui-m0a-inventory")
|
||||
(declare-function etaf-ui-m0a-private-consumer-drift
|
||||
"../scripts/etaf-ui-m0a-inventory")
|
||||
(declare-function etaf-ui-m0a-inventory
|
||||
"../scripts/etaf-ui-m0a-inventory")
|
||||
(load-file (expand-file-name "scripts/etaf-ui-m0a-inventory.el"
|
||||
default-directory))
|
||||
|
||||
(ert-deftest etaf-ui-m0a-inventory-records-eight-public-components ()
|
||||
"Record exactly the eight current public etaf-ui Components."
|
||||
(let ((components (etaf-ui-m0a-component-inventory)))
|
||||
(should (= 8 (length components)))
|
||||
(should
|
||||
(equal '(etaf-button etaf-checkbox etaf-data-grid etaf-label
|
||||
etaf-number-input etaf-pagination etaf-panel etaf-table)
|
||||
(sort (mapcar (lambda (entry) (plist-get entry :name)) components)
|
||||
(lambda (left right)
|
||||
(string< (symbol-name left) (symbol-name right))))))))
|
||||
|
||||
(ert-deftest etaf-ui-m0a-inventory-matches-current-business-props ()
|
||||
"Match each declared business prop list to its source definition."
|
||||
(dolist (component (etaf-ui-m0a-component-inventory))
|
||||
(should (equal (plist-get component :business-props)
|
||||
(plist-get component :observed-business-props)))
|
||||
(should-not (plist-get component :drift))))
|
||||
|
||||
(ert-deftest etaf-ui-m0a-inventory-separates-host-forwarding-from-props ()
|
||||
"Record Host forwarding and single-root guarantees separately from props."
|
||||
(dolist (component (etaf-ui-m0a-component-inventory))
|
||||
(should (eq 'all-valid-host-attrs
|
||||
(plist-get component :forwarded-host-attrs)))
|
||||
(should (eq 'single-host-root
|
||||
(plist-get component :root-guarantee)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0a-components-forward-host-attrs-to-one-mounted-root ()
|
||||
"Forward ref, class, and aria-label through every public Component root."
|
||||
(let* ((source (etaf-data-memory-source
|
||||
'((:id 1 :name "Ada")) :id-key :id))
|
||||
(controller (etaf-data-controller source :auto-load t))
|
||||
(buffer (generate-new-buffer-name " *etaf-ui-m0a-forwarding*"))
|
||||
(components (etaf-ui-m0a-component-inventory)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(column
|
||||
(etaf-label :text "Label" :ref 'm0a-label
|
||||
:class "m0a-forwarded" :aria-label "m0a-label")
|
||||
(etaf-button :label "Button" :ref 'm0a-button
|
||||
:class "m0a-forwarded" :aria-label "m0a-button")
|
||||
(etaf-checkbox :checked nil :label "Checkbox"
|
||||
:ref 'm0a-checkbox :class "m0a-forwarded"
|
||||
:aria-label "m0a-checkbox")
|
||||
(etaf-panel :title "Panel" :ref 'm0a-panel
|
||||
:class "m0a-forwarded" :aria-label "m0a-panel"
|
||||
(etaf-label :text "Nested"))
|
||||
(etaf-number-input :value 1 :label "Number"
|
||||
:ref 'm0a-number-input
|
||||
:class "m0a-forwarded"
|
||||
:aria-label "m0a-number-input")
|
||||
(etaf-table :columns '((:key :name :label "Name"))
|
||||
:rows '((:id 1 :name "Ada"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:ref 'm0a-table :class "m0a-forwarded"
|
||||
:aria-label "m0a-table")
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:ref 'm0a-data-grid :class "m0a-forwarded"
|
||||
:aria-label "m0a-data-grid")
|
||||
(etaf-pagination :controller controller
|
||||
:ref 'm0a-pagination
|
||||
:class "m0a-forwarded"
|
||||
:aria-label "m0a-pagination"))))
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(should (= 8 (length components)))
|
||||
(dolist (component components)
|
||||
(let* ((name (plist-get component :name))
|
||||
(suffix (string-remove-prefix "etaf-"
|
||||
(symbol-name name)))
|
||||
(ref (intern (concat "m0a-" suffix)))
|
||||
(props (etaf-runtime-host-props-for runtime ref)))
|
||||
(should props)
|
||||
(should (eq ref (plist-get props :ref)))
|
||||
(should (member "m0a-forwarded"
|
||||
(etaf--class-tokens
|
||||
(plist-get props :class))))
|
||||
(should (equal (symbol-name ref)
|
||||
(plist-get props :aria-label)))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when (get-buffer buffer) (kill-buffer buffer))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-inventory-records-private-production-closure ()
|
||||
"Record zero current production private consumers and retain M0a history."
|
||||
(let* ((entries (seq-filter
|
||||
(lambda (entry) (eq 'production (plist-get entry :scope)))
|
||||
(etaf-ui-m0a-private-consumers)))
|
||||
(symbols (delete-dups
|
||||
(mapcar (lambda (entry) (plist-get entry :symbol)) entries))))
|
||||
(should-not entries)
|
||||
(should-not symbols)
|
||||
(should (cl-every (lambda (entry)
|
||||
(and (stringp (plist-get entry :file))
|
||||
(integerp (plist-get entry :line))))
|
||||
entries))
|
||||
(let ((drift (etaf-ui-m0a-private-consumer-drift)))
|
||||
(should-not (plist-get drift :missing))
|
||||
(should-not (plist-get drift :unexpected)))
|
||||
(should (= 7 (length etaf-ui-m0a-private-production-callsites)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0a-inventory-rejects-an-undeclared-production-callsite ()
|
||||
"Report a newly added private production call even when its symbol is known."
|
||||
(let ((temporary-root (make-temp-file "etaf-ui-m0a-private-" t)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(copy-file (expand-file-name "etaf-ui-data.el" default-directory)
|
||||
(expand-file-name "etaf-ui-data.el" temporary-root))
|
||||
(with-temp-buffer
|
||||
(insert "\n(etaf--expr-create 'undeclared-callsite)\n")
|
||||
(append-to-file (point-min) (point-max)
|
||||
(expand-file-name "etaf-ui-data.el"
|
||||
temporary-root)))
|
||||
(should (plist-get
|
||||
(etaf-ui-m0a-private-consumer-drift temporary-root)
|
||||
:unexpected)))
|
||||
(delete-directory temporary-root t))))
|
||||
|
||||
(ert-deftest etaf-ui-m0a-inventory-records-current-test-consumers ()
|
||||
"Record existing private test consumers without counting inventory data."
|
||||
(let* ((entries (seq-filter
|
||||
(lambda (entry) (eq 'test (plist-get entry :scope)))
|
||||
(etaf-ui-m0a-private-consumers)))
|
||||
(symbols (delete-dups
|
||||
(mapcar (lambda (entry) (plist-get entry :symbol)) entries))))
|
||||
(should (= 10 (length entries)))
|
||||
(should (= 2 (cl-count 'etaf--class-tokens entries
|
||||
:key (lambda (entry)
|
||||
(plist-get entry :symbol)))))
|
||||
(should (= 4 (cl-count 'etaf--runtime-render-dirty-component entries
|
||||
:key (lambda (entry)
|
||||
(plist-get entry :symbol)))))
|
||||
(should (= 2 (cl-count 'etaf--ebox-box-node entries
|
||||
:key (lambda (entry)
|
||||
(plist-get entry :symbol)))))
|
||||
(should (= 2 (cl-count 'etaf--ebox-text-node entries
|
||||
:key (lambda (entry)
|
||||
(plist-get entry :symbol)))))
|
||||
(should (equal '(etaf--class-tokens etaf--ebox-box-node
|
||||
etaf--ebox-text-node
|
||||
etaf--runtime-render-dirty-component)
|
||||
(sort symbols (lambda (left right)
|
||||
(string< (symbol-name left)
|
||||
(symbol-name right))))))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-inventory-labels-public-seam-migration ()
|
||||
"Label the zero-private-consumer state as the completed M0b migration."
|
||||
(let ((inventory (etaf-ui-m0a-inventory)))
|
||||
(should (eq 'M0b (plist-get inventory :milestone)))
|
||||
(should (eq 'migrated-public-extension-seam
|
||||
(plist-get inventory :evidence-mode)))
|
||||
(should
|
||||
(equal '(:handler-publication postcommit-promoted
|
||||
:fallback-ref instance-scoped-uninterned
|
||||
:fixed-width-row single-text-host)
|
||||
(plist-get inventory :datagrid-contract)))
|
||||
(should (= 7 (length (plist-get inventory
|
||||
:m0a-private-production-baseline))))
|
||||
(should-not
|
||||
(seq-filter
|
||||
(lambda (entry) (eq 'production (plist-get entry :scope)))
|
||||
(plist-get inventory :private-consumers)))))
|
||||
|
||||
(provide 'etaf-ui-m0a-inventory-tests)
|
||||
;;; etaf-ui-m0a-inventory-tests.el ends here
|
||||
377
tests/etaf-ui-m0b-extension-tests.el
Normal file
377
tests/etaf-ui-m0b-extension-tests.el
Normal file
@ -0,0 +1,377 @@
|
||||
;;; etaf-ui-m0b-extension-tests.el --- M0b public extension seam -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-ui)
|
||||
|
||||
(defconst etaf-ui-m0b--data-source-file
|
||||
(expand-file-name "../etaf-ui-data.el"
|
||||
(file-name-directory (or load-file-name buffer-file-name)))
|
||||
"DataGrid production source inspected by the M0b seam tests.")
|
||||
|
||||
(defun etaf-ui-m0b--walk (form predicate)
|
||||
"Return non-nil when PREDICATE matches FORM or one of its children."
|
||||
(or (funcall predicate form)
|
||||
(and (consp form)
|
||||
(or (etaf-ui-m0b--walk (car form) predicate)
|
||||
(etaf-ui-m0b--walk (cdr form) predicate)))))
|
||||
|
||||
(defun etaf-ui-m0b--source-forms (file)
|
||||
"Read and return every Lisp form in FILE."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(let (forms form)
|
||||
(condition-case nil
|
||||
(while t
|
||||
(setq form (read (current-buffer)))
|
||||
(push form forms))
|
||||
(end-of-file (nreverse forms))))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-production-uses-public-extension-seam ()
|
||||
"DataGrid production code contains no ETAF private API call."
|
||||
(let ((private
|
||||
(cl-loop for form in (etaf-ui-m0b--source-forms
|
||||
etaf-ui-m0b--data-source-file)
|
||||
when (etaf-ui-m0b--walk
|
||||
form
|
||||
(lambda (node)
|
||||
(and (symbolp node)
|
||||
(string-prefix-p "etaf--" (symbol-name node)))))
|
||||
collect form)))
|
||||
(should-not private)))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-public-range-retains-handler-and-root ()
|
||||
"Insert/reorder/update retain handlers and avoid a root replacement."
|
||||
(let* ((rows (cl-loop for id from 1 to 12
|
||||
collect (list :id id :name (format "Row %d" id))))
|
||||
(source (etaf-data-memory-source rows :id-key :id))
|
||||
(controller (etaf-data-controller source :page-size 120 :auto-load t))
|
||||
(buffer-name " *etaf-ui-m0b-grid-retention*")
|
||||
(root-replacements 0)
|
||||
(materialized 0)
|
||||
update-materialized
|
||||
pressed)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID")
|
||||
(:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:row-ref (lambda (row)
|
||||
(intern (format "m0b-row-%d" (plist-get row :id))))
|
||||
:on-row-press (lambda (row) (setq pressed row)))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(handler
|
||||
(cdr (assq 'press
|
||||
(etaf-runtime-handler-for runtime 'm0b-row-6))))
|
||||
(old-root (symbol-function 'ebox-candidate-replace-root))
|
||||
(old-box (symbol-function 'etaf--ebox-box-node))
|
||||
(old-text (symbol-function 'etaf--ebox-text-node)))
|
||||
(cl-letf (((symbol-function 'ebox-candidate-replace-root)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf root-replacements)
|
||||
(apply old-root arguments)))
|
||||
((symbol-function 'etaf--ebox-box-node)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf materialized)
|
||||
(apply old-box arguments)))
|
||||
((symbol-function 'etaf--ebox-text-node)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf materialized)
|
||||
(apply old-text arguments))))
|
||||
(setf (etaf-value (etaf-data-items controller))
|
||||
(cl-loop for row in rows
|
||||
if (= 6 (plist-get row :id))
|
||||
collect '(:id 6 :name "Row six updated")
|
||||
else collect row))
|
||||
(setq update-materialized materialized)
|
||||
(etaf-data-mutate controller 'insert
|
||||
'(:id 13 :name "Row 13"))
|
||||
(etaf-data-mutate controller 'update
|
||||
'(:id 6 :name "Row six updated")))
|
||||
(should (zerop root-replacements))
|
||||
;; One local update stays well below materializing all 12 rows and
|
||||
;; their two cells (at least 60 Ebox nodes).
|
||||
(should (< update-materialized 30))
|
||||
(should (eq handler
|
||||
(cdr (assq
|
||||
'press
|
||||
(etaf-runtime-handler-for runtime 'm0b-row-6)))))
|
||||
(etaf-dispatch-event runtime 'm0b-row-6 'press)
|
||||
(should (equal "Row six updated" (plist-get pressed :name)))
|
||||
(should (string-match-p
|
||||
"Row six updated"
|
||||
(with-current-buffer buffer-name
|
||||
(substring-no-properties (buffer-string)))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-enumerates-120-items-once-per-turn ()
|
||||
"A 120-row update enumerates the public Range once and stays item-local."
|
||||
(let* ((row-key-calls 0)
|
||||
(rows (cl-loop for id from 1 to 120
|
||||
collect (list :id id :name (format "Row %d" id))))
|
||||
(source (etaf-data-memory-source rows :id-key :id))
|
||||
(controller (etaf-data-controller source :page-size 120 :auto-load t))
|
||||
(buffer-name " *etaf-ui-m0b-grid-scale*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))
|
||||
:row-key (lambda (row)
|
||||
(cl-incf row-key-calls)
|
||||
(plist-get row :id)))))
|
||||
(setq row-key-calls 0)
|
||||
(etaf-data-mutate controller 'update
|
||||
'(:id 60 :name "Changed"))
|
||||
(should (= 120 row-key-calls)))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-footer-reorder-and-key-rollback ()
|
||||
"Public slot projection and keyed rollback preserve the committed grid."
|
||||
(let* ((rows '((:id 1 :name "Ada") (:id 2 :name "Grace")))
|
||||
(source (etaf-data-memory-source rows :id-key :id))
|
||||
(controller (etaf-data-controller source :page-size 10 :auto-load t))
|
||||
(buffer-name " *etaf-ui-m0b-grid-footer*")
|
||||
pressed)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:row-ref (lambda (row)
|
||||
(intern (format "m0b-footer-row-%d"
|
||||
(plist-get row :id))))
|
||||
:on-row-press (lambda (row) (setq pressed row))
|
||||
(slot :name 'footer (etaf-label :text "Grid footer")))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(handler
|
||||
(cdr (assq 'press
|
||||
(etaf-runtime-handler-for
|
||||
runtime 'm0b-footer-row-1)))))
|
||||
(should (string-match-p
|
||||
"Grid footer"
|
||||
(with-current-buffer buffer-name
|
||||
(substring-no-properties (buffer-string)))))
|
||||
(setf (etaf-value (etaf-data-items controller))
|
||||
(reverse rows))
|
||||
(should (eq handler
|
||||
(cdr (assq
|
||||
'press
|
||||
(etaf-runtime-handler-for
|
||||
runtime 'm0b-footer-row-1)))))
|
||||
(etaf-dispatch-event runtime 'm0b-footer-row-1 'press)
|
||||
(should (= 1 (plist-get pressed :id)))
|
||||
(let ((generation (etaf-runtime-current-generation runtime))
|
||||
(text (with-current-buffer buffer-name (buffer-string))))
|
||||
(should-error
|
||||
(setf (etaf-value (etaf-data-items controller))
|
||||
'((:id 1 :name "A") (:id 1 :name "duplicate")))
|
||||
:type 'etaf-component-call-error)
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (equal-including-properties
|
||||
text (with-current-buffer buffer-name
|
||||
(buffer-string)))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-late-row-failure-keeps-committed-handler ()
|
||||
"Do not leak an early candidate row when a later row fails rendering."
|
||||
(let* ((old-rows '((:id 1 :name "Committed") (:id 2 :name "Stable")))
|
||||
(new-rows '((:id 1 :name "UNCOMMITTED")
|
||||
(:id 2 :name "Late failure")))
|
||||
(source (etaf-data-memory-source old-rows :id-key :id))
|
||||
(controller (etaf-data-controller source :page-size 10 :auto-load t))
|
||||
(buffer-name " *etaf-ui-m0b-grid-late-failure*")
|
||||
fail-late pressed)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:row-ref
|
||||
(lambda (row)
|
||||
(unless (and fail-late (= 2 (plist-get row :id)))
|
||||
(intern (format "late-row-%s" (plist-get row :id)))))
|
||||
:on-row-press (lambda (row) (setq pressed row)))))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(text (with-current-buffer buffer-name (buffer-string)))
|
||||
(handler
|
||||
(cdr (assq 'press
|
||||
(etaf-runtime-handler-for runtime 'late-row-1)))))
|
||||
(setq fail-late t)
|
||||
(should-error
|
||||
(setf (etaf-value (etaf-data-items controller)) new-rows))
|
||||
(should (eq generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(should (equal-including-properties
|
||||
text (with-current-buffer buffer-name (buffer-string))))
|
||||
(should (eq handler
|
||||
(cdr (assq
|
||||
'press
|
||||
(etaf-runtime-handler-for runtime 'late-row-1)))))
|
||||
(etaf-dispatch-event runtime 'late-row-1 'press)
|
||||
(should (equal "Committed" (plist-get pressed :name)))
|
||||
(setq fail-late nil)
|
||||
(setf (etaf-value (etaf-data-items controller)) old-rows)
|
||||
(setf (etaf-value (etaf-data-items controller)) new-rows)
|
||||
(should (eq handler
|
||||
(cdr (assq
|
||||
'press
|
||||
(etaf-runtime-handler-for runtime 'late-row-1)))))
|
||||
(etaf-dispatch-event runtime 'late-row-1 'press)
|
||||
(should (equal "UNCOMMITTED" (plist-get pressed :name)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-prunes-committed-handler-cache ()
|
||||
"Bound the stable handler cache to currently retained interactive keys."
|
||||
(let* ((rows-a '((:id 1 :name "A") (:id 2 :name "B")
|
||||
(:id 3 :name "C")))
|
||||
(rows-b '((:id 4 :name "D") (:id 5 :name "E")
|
||||
(:id 6 :name "F")))
|
||||
(source (etaf-data-memory-source rows-a :id-key :id))
|
||||
(controller (etaf-data-controller source :page-size 10 :auto-load t))
|
||||
(buffer-name " *etaf-ui-m0b-grid-handler-prune*")
|
||||
state)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(let ((promote
|
||||
(symbol-function 'etaf-ui--data-grid-promote-row-actions)))
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf-ui--data-grid-promote-row-actions)
|
||||
(lambda (candidate-state)
|
||||
(setq state candidate-state)
|
||||
(funcall promote candidate-state))))
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:row-ref (lambda (row)
|
||||
(intern (format "prune-row-%s"
|
||||
(plist-get row :id))))
|
||||
:on-row-press #'ignore)))))
|
||||
(should state)
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(cache (plist-get state :row-actions)))
|
||||
(should (= 3 (hash-table-count cache)))
|
||||
(dolist (key '(1 2 3))
|
||||
(etaf-data-mutate controller 'delete key))
|
||||
(dolist (row rows-b)
|
||||
(etaf-data-mutate controller 'insert row))
|
||||
(should (= 3 (hash-table-count cache)))
|
||||
(dolist (key '(1 2 3)) (should-not (gethash key cache)))
|
||||
(dolist (key '(4 5 6)) (should (gethash key cache)))
|
||||
(dolist (key '(4 5 6))
|
||||
(etaf-data-mutate controller 'delete key))
|
||||
(should (zerop (hash-table-count cache)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-default-refs-are-instance-scoped ()
|
||||
"Keep fallback refs distinct across grids and typed row identities."
|
||||
(let* ((rows '((:id foo :name "Symbol") (:id "foo" :name "String")))
|
||||
(source (etaf-data-memory-source rows :id-key :id))
|
||||
(controller (etaf-data-controller source :page-size 10 :auto-load t))
|
||||
(buffer-name " *etaf-ui-m0b-grid-default-ref-scope*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(column
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:on-row-press #'ignore)
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:on-row-press #'ignore))))
|
||||
(let (refs)
|
||||
(maphash
|
||||
(lambda (ref props)
|
||||
(when (member (plist-get props :key) '(foo "foo"))
|
||||
(push ref refs)))
|
||||
(etaf-runtime-host-props
|
||||
(etaf-runtime-for-buffer buffer-name)))
|
||||
(should (= 4 (length refs)))
|
||||
(should (= 4 (length (delete-dups (copy-sequence refs)))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b-data-grid-error-status-beats-retained-items ()
|
||||
"Show the error state when a failed reload retains previously loaded rows."
|
||||
(let* ((rows '((:id 1 :name "Existing")))
|
||||
(source (etaf-data-memory-source rows :id-key :id))
|
||||
(controller (etaf-data-controller source :page-size 10 :auto-load t))
|
||||
(buffer-name " *etaf-ui-m0b-grid-retained-error*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:error-label "Retained load failed"
|
||||
:empty-label "EMPTY-LABEL")))
|
||||
(setf (etaf-value (etaf-data-status controller)) 'error)
|
||||
(let ((text (with-current-buffer buffer-name
|
||||
(substring-no-properties (buffer-string)))))
|
||||
(should (string-match-p "Retained load failed" text))
|
||||
(should-not (string-match-p "EMPTY-LABEL" text))
|
||||
(should-not (string-match-p "Existing" text))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(provide 'etaf-ui-m0b-extension-tests)
|
||||
;;; etaf-ui-m0b-extension-tests.el ends here
|
||||
@ -30,6 +30,25 @@ Use Chinese punctuation when CHINESE-P is non-nil."
|
||||
(plist-get component :observed-business-props)
|
||||
(if chinese-p "、" ", "))))
|
||||
|
||||
(ert-deftest etaf-ui-package-autoloads-never-register-components ()
|
||||
"Keep package activation from executing Component registration forms."
|
||||
(dolist (file (directory-files default-directory t "\\.el\\'"))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "^;;;###autoload[[:space:]]*$" nil t)
|
||||
(forward-comment (point-max))
|
||||
(should-not
|
||||
(memq (car-safe (read (current-buffer)))
|
||||
'(etaf-define-component etaf-ui--define-component)))))))
|
||||
|
||||
(ert-deftest etaf-ui-package-reload-keeps-identical-catalog-definitions ()
|
||||
"Allow package.el to reload exact catalog files without duplicate owners."
|
||||
(let ((before (etaf-ui-m0a-component-inventory)))
|
||||
(dolist (file '("etaf-ui-basic.el" "etaf-ui-table.el" "etaf-ui-data.el"))
|
||||
(load-file (expand-file-name file default-directory)))
|
||||
(should (equal before (etaf-ui-m0a-component-inventory)))))
|
||||
|
||||
(ert-deftest etaf-ui-m0b1-readmes-match-runtime-component-manifest ()
|
||||
"Keep the README contract aligned with the runtime-derived inventory."
|
||||
(let* ((components (etaf-ui-m0a-component-inventory))
|
||||
|
||||
241
tests/etaf-ui-pagination-commit-tests.el
Normal file
241
tests/etaf-ui-pagination-commit-tests.el
Normal 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
274
tests/etaf-ui-table-adaptive-tests.el
Normal 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
|
||||
@ -1,5 +1,7 @@
|
||||
;;; etaf-ui-tests.el --- Official ETAF Component tests -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf-ui)
|
||||
|
||||
@ -29,11 +31,15 @@
|
||||
(let (found)
|
||||
(maphash
|
||||
(lambda (_ref props)
|
||||
(when (equal (plist-get props :class) class)
|
||||
(when (member class (etaf--class-tokens (plist-get props :class)))
|
||||
(setq found props)))
|
||||
(etaf-runtime-host-props (etaf-runtime-for-buffer buffer-name)))
|
||||
found))
|
||||
|
||||
(defun etaf-ui-test--has-class-p (props class)
|
||||
"Return non-nil when PROPS contain CLASS."
|
||||
(member class (etaf--class-tokens (plist-get props :class))))
|
||||
|
||||
(defun etaf-ui-test--paint-color (value property)
|
||||
"Return effective paint color from VALUE for Ebox PROPERTY."
|
||||
(if (not (tp-paint-slot-p value))
|
||||
@ -63,49 +69,50 @@
|
||||
:setup
|
||||
(progn
|
||||
(etaf-theme-provide '(:color "theme-color"
|
||||
:bgcolor "theme-bg"
|
||||
:background-color "theme-bg"
|
||||
:padding (9 9)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(row
|
||||
(button :label "Styled" :ref 'styled-button)
|
||||
(button :label "Custom" :ref 'custom-button
|
||||
nil)
|
||||
:view
|
||||
(row
|
||||
(etaf-button :label "Styled" :ref 'styled-button)
|
||||
(etaf-button :label "Custom" :ref 'custom-button
|
||||
:color "explicit-color")
|
||||
(label :text "Themed" :ref 'themed-label
|
||||
(etaf-label :text "Themed" :ref 'themed-label
|
||||
:color nil :bgcolor nil)
|
||||
(panel :title "Styled panel" :ref 'styled-panel))))))
|
||||
(text :ref 'themed-host :color nil :bgcolor nil "Theme defaults")
|
||||
(etaf-panel :title "Styled panel" :ref 'styled-panel)))
|
||||
|
||||
(etaf-define-component etaf-ui-test-token-theme-fixture ()
|
||||
"Provide explicit UI Button tokens through ETAF Theme."
|
||||
:setup
|
||||
(progn
|
||||
(etaf-theme-provide
|
||||
'(:ui-button-color "token-fg"
|
||||
:ui-button-bgcolor "token-bg"
|
||||
:ui-button-border "token-border"
|
||||
:ui-button-secondary-color "secondary-fg"
|
||||
:ui-button-secondary-bgcolor "secondary-bg"
|
||||
'(:ui-button-primary-fg "token-fg"
|
||||
:ui-button-primary-bg "token-bg"
|
||||
:ui-button-primary-border "token-border"
|
||||
:ui-button-secondary-fg "secondary-fg"
|
||||
:ui-button-secondary-bg "secondary-bg"
|
||||
:ui-button-secondary-border "secondary-border"))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(row
|
||||
(button :label "Token" :ref 'token-button)
|
||||
(button :label "Secondary" :ref 'token-secondary
|
||||
:variant 'secondary))))))
|
||||
nil)
|
||||
:view
|
||||
(row
|
||||
(etaf-button :label "Token" :ref 'token-button)
|
||||
(etaf-button :label "Secondary" :ref 'token-secondary
|
||||
:variant 'secondary)))
|
||||
|
||||
(etaf-define-component etaf-ui-test-grid-theme-fixture
|
||||
(&key controller theme)
|
||||
"Provide a reactive Theme around one DataGrid for palette tests."
|
||||
:setup
|
||||
(progn
|
||||
(etaf-theme-provide (etaf-current-prop :theme))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(data-grid
|
||||
:controller (etaf-current-prop :controller)
|
||||
:columns '((:key :id :label "ID") (:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:selected-key 1)))))
|
||||
(etaf-theme-provide theme)
|
||||
nil)
|
||||
:view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID") (:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:row-selected-p (lambda (row) (= (plist-get row :id) 1))))
|
||||
|
||||
(ert-deftest etaf-ui-button-use-behavior-dispatches-through-host ()
|
||||
"Install Button `:use' Behavior and dispatch its merged callback."
|
||||
@ -116,7 +123,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(button :label "Behavior" :ref 'behavior-button
|
||||
(etaf-button :label "Behavior" :ref 'behavior-button
|
||||
:use (list (etaf-ui-test-press-behavior)))))
|
||||
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
||||
'behavior-button 'press)
|
||||
@ -132,21 +139,26 @@
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view (ui-test-theme-fixture)))
|
||||
(etaf-view (etaf-ui-test-theme-fixture)))
|
||||
(let ((styled (etaf-ui-test--props buffer-name 'styled-button))
|
||||
(custom (etaf-ui-test--props buffer-name 'custom-button))
|
||||
(themed (etaf-ui-test--props buffer-name 'themed-label))
|
||||
(host (etaf-ui-test--props buffer-name 'themed-host))
|
||||
(panel (etaf-ui-test--props buffer-name 'styled-panel)))
|
||||
(should (equal (plist-get styled :color) "#FFFFFF"))
|
||||
(should (equal (plist-get styled :bgcolor) "#2F6B43"))
|
||||
(should (equal (plist-get styled :background-color) "#2F6B43"))
|
||||
(should (equal (plist-get styled :padding) '(0 1)))
|
||||
(should (equal (plist-get custom :color) "explicit-color"))
|
||||
(should (equal (plist-get custom :bgcolor) "#2F6B43"))
|
||||
(should (equal (plist-get themed :color) "theme-color"))
|
||||
(should (equal (plist-get themed :bgcolor) "theme-bg"))
|
||||
(should (equal (plist-get custom :background-color) "#2F6B43"))
|
||||
;; Nil fallthrough omits an override; it does not erase Label's
|
||||
;; explicit presentation. An omitted Host value uses Theme.
|
||||
(should (equal (plist-get themed :color) "#252A2E"))
|
||||
(should (equal (plist-get themed :background-color) "theme-bg"))
|
||||
(should (equal (plist-get host :color) "theme-color"))
|
||||
(should (equal (plist-get host :background-color) "theme-bg"))
|
||||
(should-not (plist-get themed :padding))
|
||||
(should (equal (plist-get panel :color) "#252A2E"))
|
||||
(should (equal (plist-get panel :bgcolor) "#FFFDF8"))
|
||||
(should (equal (plist-get panel :background-color) "#FFFDF8"))
|
||||
(should (equal (plist-get panel :padding) '(1 2)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
@ -159,14 +171,15 @@
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view (ui-test-token-theme-fixture)))
|
||||
(etaf-view (etaf-ui-test-token-theme-fixture)))
|
||||
(let ((token (etaf-ui-test--props buffer-name 'token-button))
|
||||
(secondary (etaf-ui-test--props buffer-name 'token-secondary)))
|
||||
(should (equal "token-fg" (plist-get token :color)))
|
||||
(should (equal "token-bg" (plist-get token :bgcolor)))
|
||||
(should (equal "token-bg" (plist-get token :background-color)))
|
||||
(should (equal "token-border" (plist-get token :border)))
|
||||
(should (equal "secondary-fg" (plist-get secondary :color)))
|
||||
(should (equal "secondary-bg" (plist-get secondary :bgcolor)))
|
||||
(should (equal "secondary-bg"
|
||||
(plist-get secondary :background-color)))
|
||||
(should (equal "secondary-border"
|
||||
(plist-get secondary :border)))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
@ -183,7 +196,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(number-input :label "Rows" :value value :ref 'rows
|
||||
(etaf-number-input :label "Rows" :value value :ref 'rows
|
||||
:min 1 :max 10
|
||||
:on-change (lambda (next) (setq value next)))))
|
||||
(cl-letf (((symbol-function 'read-number)
|
||||
@ -204,7 +217,7 @@
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view
|
||||
(button :label "Save" :ref 'save
|
||||
(etaf-button :label "Save" :ref 'save
|
||||
:class "primary"
|
||||
:color "#FFFFFF"
|
||||
:bgcolor "#2F6B43"
|
||||
@ -221,11 +234,11 @@
|
||||
(should (equal (plist-get props :tab-index) 3))
|
||||
(should (equal (plist-get props :aria-label) "Save changes"))
|
||||
(should (equal (plist-get props :color) "#FFFFFF"))
|
||||
(should (equal (plist-get props :bgcolor) "#2F6B43"))
|
||||
(should (equal (plist-get props :background-color) "#2F6B43"))
|
||||
(should (equal (plist-get props :border) "#2F6B43"))
|
||||
(should (equal (plist-get props :padding) '(0 2)))
|
||||
(should (equal (plist-get props :font-weight) 'bold))
|
||||
(should (string-match-p "primary" (plist-get props :class))))
|
||||
(should (etaf-ui-test--has-class-p props "primary")))
|
||||
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
||||
'save 'press)
|
||||
(should (= presses 1)))
|
||||
@ -244,22 +257,22 @@
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view
|
||||
(row
|
||||
(button :label "Save" :ref 'enabled-save
|
||||
(etaf-button :label "Save" :ref 'enabled-save
|
||||
:on-press (lambda () (cl-incf presses)))
|
||||
(button :label "Delete" :ref 'disabled-delete
|
||||
(etaf-button :label "Delete" :ref 'disabled-delete
|
||||
:disabled t
|
||||
:use (list (etaf-ui-test-press-behavior))
|
||||
:on-press (lambda () (cl-incf presses))))))
|
||||
(let ((props (etaf-ui-test--props buffer-name 'enabled-save)))
|
||||
(should (equal (plist-get props :color) "#FFFFFF"))
|
||||
(should (equal (plist-get props :bgcolor) "#2F6B43"))
|
||||
(should (equal (plist-get props :background-color) "#2F6B43"))
|
||||
(should (equal (plist-get props :padding) '(0 1)))
|
||||
(should (equal (plist-get props :font-weight) 'bold)))
|
||||
(let ((props (etaf-ui-test--props buffer-name 'disabled-delete)))
|
||||
(should (eq (plist-get props :disabled) t))
|
||||
(should-not (plist-get props :tab-index))
|
||||
(should (equal (plist-get props :bgcolor) "#E5E7EB"))
|
||||
(should (string-match-p "disabled" (plist-get props :class))))
|
||||
(should (equal (plist-get props :background-color) "#E5E7EB"))
|
||||
(should (etaf-ui-test--has-class-p props "disabled")))
|
||||
(should-error
|
||||
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
||||
'disabled-delete 'press)
|
||||
@ -283,7 +296,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(button :label "Unavailable" :ref 'themed-disabled
|
||||
(etaf-button :label "Unavailable" :ref 'themed-disabled
|
||||
:disabled t :color "#F4F7FF" :bgcolor "#202C42"
|
||||
:border "#34435A")))
|
||||
(let ((position
|
||||
@ -294,11 +307,11 @@
|
||||
(with-current-buffer buffer-name
|
||||
(let ((face (get-text-property position 'face)))
|
||||
(should (string-match-p "#202C42" (format "%S" face)))
|
||||
(should (string-match-p "#F4F7FF" (format "%S" face))))))
|
||||
(should (string-match-p "#F4F7FF" (format "%S" face)))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-button-dispatches-without-retained-press-state ()
|
||||
"Buttons dispatch through semantic Host state without local press state."
|
||||
@ -309,12 +322,12 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(button :label "Run health check" :ref 'health
|
||||
(etaf-button :label "Run health check" :ref 'health
|
||||
:variant 'secondary
|
||||
:on-press (lambda () (cl-incf presses)))))
|
||||
(let ((props (etaf-ui-test--props buffer-name 'health)))
|
||||
(should (equal (plist-get props :color) "#142235"))
|
||||
(should (equal (plist-get props :bgcolor) "#D9EEEA")))
|
||||
(should (equal (plist-get props :background-color) "#D9EEEA")))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(before (cdr (assq 'press
|
||||
(etaf-runtime-handler-for runtime 'health)))))
|
||||
@ -347,7 +360,7 @@
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view
|
||||
(checkbox :label "Done" :ref 'done
|
||||
(etaf-checkbox :label "Done" :ref 'done
|
||||
:checked (etaf-value checked)
|
||||
:on-change (lambda (value)
|
||||
(setq next value)
|
||||
@ -382,7 +395,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(checkbox :label "Live" :ref 'live-checkbox :checked checked
|
||||
(etaf-checkbox :label "Live" :ref 'live-checkbox :checked checked
|
||||
:on-change (lambda (value)
|
||||
(setf (etaf-value checked) value)))))
|
||||
(let ((render (symbol-function
|
||||
@ -410,7 +423,7 @@
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view (label :text text :ref 'live-label)))
|
||||
(etaf-view (etaf-label :text text :ref 'live-label)))
|
||||
(let ((render (symbol-function
|
||||
'etaf--runtime-render-dirty-component)))
|
||||
(cl-letf (((symbol-function 'etaf--runtime-render-dirty-component)
|
||||
@ -434,18 +447,18 @@
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view
|
||||
(row
|
||||
(checkbox :label "Open" :ref 'open-box
|
||||
(etaf-checkbox :label "Open" :ref 'open-box
|
||||
:on-change (lambda (_value)
|
||||
(cl-incf changes)))
|
||||
(checkbox :label "Closed" :ref 'closed-box
|
||||
(etaf-checkbox :label "Closed" :ref 'closed-box
|
||||
:disabled t
|
||||
:on-change (lambda (_value)
|
||||
(cl-incf changes))))))
|
||||
(let ((props (etaf-ui-test--props buffer-name 'closed-box)))
|
||||
(should (eq (plist-get props :disabled) t))
|
||||
(should-not (plist-get props :tab-index))
|
||||
(should (equal (plist-get props :bgcolor) "#EEEAE2"))
|
||||
(should (string-match-p "disabled" (plist-get props :class))))
|
||||
(should (equal (plist-get props :background-color) "#EEEAE2"))
|
||||
(should (etaf-ui-test--has-class-p props "disabled")))
|
||||
(should-error
|
||||
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
|
||||
'closed-box 'press)
|
||||
@ -468,25 +481,28 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(panel :title "Account" :ref 'account-panel
|
||||
:class "surface" :color "#252A2E" :bgcolor "#FFFDF8"
|
||||
(etaf-panel :title "Account" :ref 'account-panel
|
||||
:class "surface" :color "#252A2E"
|
||||
:background-color "#FFFDF8"
|
||||
:border "#687386" :padding '(1 2)
|
||||
(slot :name 'header
|
||||
(label :text "Settings" :ref 'settings-label
|
||||
:class "eyebrow" :color "#66706A"
|
||||
:font-weight 'bold :width 12))
|
||||
(label :text "Body"))))
|
||||
(box :width 12 :ref 'settings-cell
|
||||
(etaf-label :text "Settings" :ref 'settings-label
|
||||
:class "eyebrow" :color "#66706A"
|
||||
:font-weight 'bold)))
|
||||
(etaf-label :text "Body"))))
|
||||
(let ((panel (etaf-ui-test--props buffer-name 'account-panel))
|
||||
(label (etaf-ui-test--props buffer-name 'settings-label)))
|
||||
(should (string-match-p "surface" (plist-get panel :class)))
|
||||
(label (etaf-ui-test--props buffer-name 'settings-label))
|
||||
(cell (etaf-ui-test--props buffer-name 'settings-cell)))
|
||||
(should (etaf-ui-test--has-class-p panel "surface"))
|
||||
(should (equal (plist-get panel :color) "#252A2E"))
|
||||
(should (equal (plist-get panel :bgcolor) "#FFFDF8"))
|
||||
(should (equal (plist-get panel :background-color) "#FFFDF8"))
|
||||
(should (equal (plist-get panel :border) "#687386"))
|
||||
(should (equal (plist-get panel :padding) '(1 2)))
|
||||
(should (string-match-p "eyebrow" (plist-get label :class)))
|
||||
(should (etaf-ui-test--has-class-p label "eyebrow"))
|
||||
(should (equal (plist-get label :color) "#66706A"))
|
||||
(should (equal (plist-get label :font-weight) 'bold))
|
||||
(should (equal (plist-get label :width) 12)))
|
||||
(should (equal (plist-get cell :width) 12)))
|
||||
(dolist (label '("Account" "Settings" "Body"))
|
||||
(should (string-match-p (regexp-quote label)
|
||||
(etaf-ui-test--text buffer-name)))))
|
||||
@ -508,14 +524,14 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID")
|
||||
(:key :name :label "Name"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:row-ref (lambda (row)
|
||||
(intern (format "row-%d" (plist-get row :id))))
|
||||
:selected-key 2
|
||||
:row-selected-p (lambda (row) (= (plist-get row :id) 2))
|
||||
:on-row-press (lambda (row) (setq pressed row)))))
|
||||
(should (string-match-p "Ada" (etaf-ui-test--text buffer-name)))
|
||||
(let ((first (etaf-ui-test--props buffer-name 'row-1))
|
||||
@ -524,10 +540,8 @@
|
||||
(should (equal (plist-get first :tab-index) 0))
|
||||
(should (equal (plist-get second :role) 'button))
|
||||
(should (equal (plist-get second :tab-index) 0))
|
||||
(should (string-match-p
|
||||
"selected" (or (plist-get second :class) "")))
|
||||
(should-not (string-match-p
|
||||
"selected" (or (plist-get first :class) ""))))
|
||||
(should (etaf-ui-test--has-class-p second "selected"))
|
||||
(should-not (etaf-ui-test--has-class-p first "selected")))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(handler (cdr (assq 'press
|
||||
(etaf-runtime-handler-for runtime
|
||||
@ -557,15 +571,13 @@
|
||||
:id-key :id))
|
||||
(controller (etaf-data-controller source :auto-load t))
|
||||
(buffer-name " *etaf-ui-grid-keyed-selection-test*")
|
||||
(row-renders (make-hash-table :test #'eql))
|
||||
(body-renders 0)
|
||||
host-updates)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID")
|
||||
(:key :name :label "Name"))
|
||||
@ -581,23 +593,11 @@
|
||||
(third-handler
|
||||
(cdr (assq 'press
|
||||
(etaf-runtime-handler-for runtime 'keyed-row-3))))
|
||||
(old-grid-row (symbol-function 'etaf-ui--grid-row))
|
||||
(old-grid-rows (symbol-function 'etaf-ui--grid-rows))
|
||||
(old-host
|
||||
(symbol-function 'ebox-candidate-replace-host-ref))
|
||||
(old-paint
|
||||
(symbol-function 'ebox-candidate-patch-host-paint)))
|
||||
(cl-letf (((symbol-function 'etaf-ui--grid-row)
|
||||
(lambda (&rest args)
|
||||
(let ((key (nth 1 args)))
|
||||
(puthash key (1+ (gethash key row-renders 0))
|
||||
row-renders))
|
||||
(apply old-grid-row args)))
|
||||
((symbol-function 'etaf-ui--grid-rows)
|
||||
(lambda (&rest args)
|
||||
(cl-incf body-renders)
|
||||
(apply old-grid-rows args)))
|
||||
((symbol-function 'ebox-candidate-replace-host-ref)
|
||||
(cl-letf (((symbol-function 'ebox-candidate-replace-host-ref)
|
||||
(lambda (candidate ref node)
|
||||
(push ref host-updates)
|
||||
(funcall old-host candidate ref node)))
|
||||
@ -608,11 +608,6 @@
|
||||
;; Prove direct public selection ref writes use the same keyed
|
||||
;; invalidation path as the selection helpers.
|
||||
(setf (etaf-value (etaf-data-selection controller)) '(2)))
|
||||
(should (zerop (gethash 1 row-renders 0)))
|
||||
(should (zerop (gethash 2 row-renders 0)))
|
||||
(should (zerop (gethash 3 row-renders 0)))
|
||||
(should (zerop (hash-table-count row-renders)))
|
||||
(should (zerop body-renders))
|
||||
(should (member 'keyed-row-1 host-updates))
|
||||
(should (member 'keyed-row-2 host-updates))
|
||||
(should-not (member 'keyed-row-3 host-updates))
|
||||
@ -642,10 +637,10 @@
|
||||
|
||||
(ert-deftest etaf-ui-data-grid-follows-inherited-theme-color ()
|
||||
"Re-render DataGrid rows when only inherited Theme color changes."
|
||||
(let* ((theme (etaf-ref '(:color "light-ink"
|
||||
:ui-grid-border "light-grid-border"
|
||||
:ui-grid-selected-fg "light-selected"
|
||||
:ui-grid-selected-bg "light-selected-bg")))
|
||||
(let* ((theme (etaf-ref '(:ui-fg "light-ink"
|
||||
:ui-table-border "light-grid-border"
|
||||
:ui-table-selected-fg "light-selected"
|
||||
:ui-table-selected-bg "light-selected-bg")))
|
||||
(source (etaf-data-memory-source
|
||||
'((:id 1 :name "Ada") (:id 2 :name "Grace")) :id-key :id))
|
||||
(controller (etaf-data-controller source :auto-load t))
|
||||
@ -655,27 +650,36 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(ui-test-grid-theme-fixture :controller controller :theme theme)))
|
||||
(etaf-ui-test-grid-theme-fixture
|
||||
:controller controller :theme theme)))
|
||||
(let* ((props (etaf-ui-test--props-with-key buffer-name 1))
|
||||
(background-slot (plist-get props :bgcolor))
|
||||
(foreground-slot (plist-get props :color))
|
||||
(background-slot (plist-get props :background-color))
|
||||
(border-slot (plist-get props :border-bottom-color)))
|
||||
(should (equal "light-selected"
|
||||
(etaf-ui-test--paint-color
|
||||
foreground-slot :color)))
|
||||
(should (equal "light-selected-bg"
|
||||
(etaf-ui-test--paint-color
|
||||
background-slot :bgcolor)))
|
||||
(should (equal "light-grid-border"
|
||||
(etaf-ui-test--paint-color
|
||||
border-slot :border-bottom-color)))
|
||||
(let ((row-props
|
||||
(etaf-ui-test--props-with-key buffer-name 1)))
|
||||
(should (= (plist-get row-props :border-bottom-width) 1))
|
||||
(should (eq (plist-get row-props :border-bottom-style) 'solid)))
|
||||
(setf (etaf-value theme) '(:color "dark-ink"
|
||||
:ui-grid-border "dark-grid-border"
|
||||
:ui-grid-selected-fg "dark-selected"
|
||||
:ui-grid-selected-bg "dark-selected-bg"))
|
||||
(should (= (plist-get props :border-bottom-width) 1))
|
||||
(should (eq (plist-get props :border-bottom-style) 'solid))
|
||||
(setf (etaf-value theme) '(:ui-fg "dark-ink"
|
||||
:ui-table-border "dark-grid-border"
|
||||
:ui-table-selected-fg "dark-selected"
|
||||
:ui-table-selected-bg "dark-selected-bg"))
|
||||
(let ((next (etaf-ui-test--props-with-key buffer-name 1)))
|
||||
(should (eq background-slot (plist-get next :bgcolor)))
|
||||
(should (eq border-slot (plist-get next :border-bottom-color)))
|
||||
(should (eq background-slot
|
||||
(plist-get next :background-color)))
|
||||
(should (eq border-slot
|
||||
(plist-get next :border-bottom-color)))
|
||||
(should (eq foreground-slot (plist-get next :color)))
|
||||
(should (equal "dark-selected"
|
||||
(etaf-ui-test--paint-color
|
||||
foreground-slot :color)))
|
||||
(should (equal "dark-selected-bg"
|
||||
(etaf-ui-test--paint-color
|
||||
background-slot :bgcolor)))
|
||||
@ -689,7 +693,7 @@
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-pagination-is-readable-and-boundary-safe ()
|
||||
"Pagination renders Unicode controls, stable refs, and page boundaries."
|
||||
"Pagination renders labeled controls, stable refs, and page boundaries."
|
||||
(let* ((source (etaf-data-memory-source
|
||||
'((:id 1) (:id 2) (:id 3) (:id 4) (:id 5))
|
||||
:id-key :id))
|
||||
@ -700,12 +704,12 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(pagination :controller controller
|
||||
(etaf-pagination :controller controller
|
||||
:previous-ref 'page-previous
|
||||
:next-ref 'page-next)))
|
||||
(should (string-match-p "Page 1 / 3" (etaf-ui-test--text buffer-name)))
|
||||
(should (string-match-p "←" (etaf-ui-test--text buffer-name)))
|
||||
(should (string-match-p "→" (etaf-ui-test--text buffer-name)))
|
||||
(should (string-match-p "‹ Previous" (etaf-ui-test--text buffer-name)))
|
||||
(should (string-match-p "Next ›" (etaf-ui-test--text buffer-name)))
|
||||
;; Live Ebox windows reserve two pixels for the exclusive display
|
||||
;; boundary; the pager must stay inside the corresponding 360px row.
|
||||
(ebox-surface-update-buffer-viewport (get-buffer buffer-name) 358 20)
|
||||
@ -750,7 +754,7 @@
|
||||
(text "Left")
|
||||
(column
|
||||
:width 'stretch :padding '(0 2) :border "#CBD5E1"
|
||||
(pagination :controller controller
|
||||
(etaf-pagination :controller controller
|
||||
:previous-ref 'nested-page-previous
|
||||
:next-ref 'nested-page-next))
|
||||
(text "Right"))))
|
||||
@ -780,7 +784,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :title :label "Title" :width 22))
|
||||
:row-key (lambda (row) (plist-get row :id)))))
|
||||
@ -804,7 +808,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :progress :label "Progress" :width 8)
|
||||
(:key :kind :label "Kind" :width 7))
|
||||
@ -817,6 +821,26 @@
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-table-fixed-row-text-is-exact-and-fail-closed ()
|
||||
"Pad fixed-width rows exactly and retain the general path otherwise."
|
||||
(should
|
||||
(equal "Ada Essay "
|
||||
(etaf-ui--table-fixed-row-text
|
||||
'(:name "Ada" :kind "Essay")
|
||||
'((:key :name :width 5) (:key :kind :width 7)))))
|
||||
(should-not
|
||||
(etaf-ui--table-fixed-row-text
|
||||
'(:name "Ada" :kind "Essay")
|
||||
'((:key :name :width 5) (:key :kind))))
|
||||
(should
|
||||
(equal "Name Kind "
|
||||
(etaf-ui--table-fixed-header-text
|
||||
'((:key :name :label "Name" :width 5)
|
||||
(:key :kind :label "Kind" :width 7)))))
|
||||
(should-not
|
||||
(etaf-ui--table-fixed-header-text
|
||||
'((:key :name :width 5) (:key :kind)))))
|
||||
|
||||
(ert-deftest etaf-ui-data-grid-noninteractive-rows-have-no-focus-contract ()
|
||||
"Rows without ON-ROW-PRESS have no role, ref callback, or tab stop."
|
||||
(let* ((source (etaf-data-memory-source '((:id 1 :name "Ada"))
|
||||
@ -828,7 +852,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))
|
||||
:row-key (lambda (row) (plist-get row :id)))))
|
||||
@ -841,22 +865,34 @@
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-ui-data-grid-requires-row-ref-for-interaction ()
|
||||
"Reject an interactive DataGrid without a row-ref callback."
|
||||
(ert-deftest etaf-ui-data-grid-owns-default-interaction-ref ()
|
||||
"Dispatch an interactive DataGrid row through its internal stable ref."
|
||||
(let* ((source (etaf-data-memory-source '((:id 1 :name "Ada"))
|
||||
:id-key :id))
|
||||
(controller (etaf-data-controller source :auto-load t))
|
||||
(buffer-name " *etaf-ui-grid-row-ref-test*"))
|
||||
(buffer-name " *etaf-ui-grid-row-ref-test*")
|
||||
pressed)
|
||||
(unwind-protect
|
||||
(should-error
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:on-row-press (lambda (_row) t)))))
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
:on-row-press (lambda (row) (setq pressed row)))))
|
||||
(let (host-ref)
|
||||
(maphash
|
||||
(lambda (ref props)
|
||||
(when (equal (plist-get props :key) 1)
|
||||
(setq host-ref ref)))
|
||||
(etaf-runtime-host-props
|
||||
(etaf-runtime-for-buffer buffer-name)))
|
||||
(should host-ref)
|
||||
(etaf-dispatch-event
|
||||
(etaf-runtime-for-buffer buffer-name) host-ref 'press)
|
||||
(should (equal (plist-get pressed :id) 1))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(etaf-data-stop controller)
|
||||
@ -874,7 +910,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
@ -899,12 +935,11 @@
|
||||
(progn
|
||||
(setf (etaf-value (etaf-data-status controller))
|
||||
(car case))
|
||||
(setf (etaf-value (etaf-data-items controller))
|
||||
(when (eq (car case) 'empty) nil))
|
||||
(setf (etaf-value (etaf-data-items controller)) nil)
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))
|
||||
:row-key (lambda (row) (plist-get row :id))
|
||||
@ -934,7 +969,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))))))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
@ -955,7 +990,7 @@
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(data-grid
|
||||
(etaf-data-grid
|
||||
:controller controller
|
||||
:columns '((:key :id :label "ID"))
|
||||
:row-key (lambda (_row) nil)))))
|
||||
|
||||
Loading…
Reference in New Issue
Block a user