Compare commits
21 Commits
perf-scrol
...
main
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
1812a8282a | ||
|
|
ffafd668ab | ||
|
|
920efc36f7 | ||
|
|
2b5793acd6 | ||
|
|
9fc022c974 | ||
|
|
1112a52649 | ||
|
|
4ea698645d | ||
|
|
5fc4025bc1 | ||
|
|
0e14b339c0 | ||
|
|
9905d48a36 | ||
|
|
5cd432ea18 | ||
|
|
64ca9b5931 | ||
|
|
d237b9bc67 | ||
|
|
3ed2d39f4c | ||
|
|
d124c33ba4 | ||
|
|
5cbf949465 | ||
|
|
51a00b3ee5 | ||
|
|
bf22251d40 | ||
|
|
0479ad2bde | ||
|
|
b8579e57cc | ||
|
|
7c6eb45f4f |
92
DESIGN.md
92
DESIGN.md
@ -3,9 +3,13 @@
|
||||
## Source of truth
|
||||
|
||||
- Status: Active
|
||||
- Last refreshed: 2026-08-23
|
||||
- Last refreshed: 2026-09-08
|
||||
- Primary product surface: generic `etaf-playground.el` workspace plus the
|
||||
`examples/research-shelf.etaf` / `.el` / `.ecss` consumer triplet
|
||||
- Additional product surface: `examples/task-workbench.el`, a complete
|
||||
composable task app. Its initial layout, interactions, and visual states are
|
||||
checked in real GUI Emacs; current user direction is modern, spacious,
|
||||
consistently aligned controls and a 100-task dataset.
|
||||
- Visual reference: `design/research-shelf.html`
|
||||
- Evidence reviewed: ETAF public View/Component/Data/Resource APIs, `etaf-ui`
|
||||
Button/Checkbox/Panel/DataGrid/Pagination, and `etaf-sqlite`'s typed source
|
||||
@ -81,8 +85,8 @@
|
||||
|
||||
## Components
|
||||
|
||||
- Existing components to reuse: public `button`, `checkbox`, `label`, `panel`,
|
||||
`data-grid`, and `pagination` from `etaf-ui`.
|
||||
- Existing components to reuse: `etaf-button`, `etaf-checkbox`, `etaf-label`,
|
||||
`etaf-panel`, `etaf-data-grid`, and `etaf-pagination` from `etaf-ui`.
|
||||
- Companion composition: `research-shelf-shell`, `filter-rail`,
|
||||
`reading-list`, and `detail-inspector`; these are ordinary ETAF Components,
|
||||
not a second UI kit.
|
||||
@ -186,8 +190,12 @@ triplet.
|
||||
- Pressure fixture: `etaf-research-shelf-fixture-size` defaults to 256 and
|
||||
`etaf-research-shelf-page-size` defaults to 12; existing local rows are
|
||||
preserved and missing fixture rows are topped up with fresh IDs.
|
||||
- Performance: one Data mutation -> one Runtime generation/publication; normal
|
||||
warm actions remain under the accepted 105ms p50 target.
|
||||
- Performance: one Data mutation -> one Runtime generation/publication. The
|
||||
retained Research Shelf batch evaluator uses 5 unmeasured warmups and 30
|
||||
measured samples at fixed 1413×62 geometry, with p95 and max at most 50ms.
|
||||
Current GUI acceptance has the additional requirements below. The accepted
|
||||
105ms p50 wording is historical design context, not the current evaluator
|
||||
gate; `DOC-PERF-001` keeps its formal disposition in M0b1.
|
||||
- Compatibility: any same-basename `.etaf`/`.el` example is discoverable;
|
||||
`.ecss` is optional, and the bundled Research Shelf remains only one
|
||||
consumer.
|
||||
@ -195,7 +203,81 @@ triplet.
|
||||
refresh tests, SQLite temp-file integration tests, mount/remount tests,
|
||||
repeated selection/mutation tests, and clean GUI screenshots.
|
||||
|
||||
## Performance evidence lanes
|
||||
|
||||
The batch latency lane, trace lane, and GUI lane share one
|
||||
repository/environment/scenario/fixture/build identity but remain separate
|
||||
measurements. The retained Research Shelf 1413×62 batch evaluator owns its
|
||||
uninstrumented 5/30 p95/max 50ms regression checks. Batch verifier duration
|
||||
measures batch Lisp work, not GUI first paint.
|
||||
The trace lane owns a representative instrumented invocation with cost class,
|
||||
work counters, turns, allocation, and GC. The GUI lane owns the real Emacs
|
||||
action sequence and reviewed visual evidence. Current GUI acceptance additionally
|
||||
requires three independent foreground sample sets with each operation's p95 and
|
||||
max at most 50ms from action callback through forced redisplay. This gate remains
|
||||
outstanding. Preserve all warmups, GC observations and samples through the
|
||||
measurement entry in `../etaf/scripts/README.md`; returning from redisplay does
|
||||
not certify compositor presentation. No one lane may be used to claim another
|
||||
lane passed.
|
||||
|
||||
## Open questions
|
||||
|
||||
- [ ] User may rename the product after reviewing the first HTML/ETAF render;
|
||||
architecture and interaction contracts remain unchanged.
|
||||
|
||||
## Task Workbench visual contract
|
||||
|
||||
- Source: user review of the actual Workbench GUI on 2026-09-05, especially
|
||||
adjacent buttons, cramped rows and excessive detail-panel width. Reuse the
|
||||
existing restrained cobalt emphasis; no separate design-system layer.
|
||||
- Hierarchy: a title and quiet workspace subtitle, a grouped toolbar, then
|
||||
filter rail / primary task list / compact detail and service cards. Footer
|
||||
counts and storage scope use muted text. The task list receives extra width.
|
||||
- Color: cool gray canvas, white cards, soft slate borders, cobalt primary
|
||||
action; dark mode has a charcoal canvas and lighter slate cards. All official
|
||||
control states use the existing semantic Theme tokens, including disabled,
|
||||
selected, checkbox and pagination colors.
|
||||
- Actions: New task is primary. Search and retry are secondary; location,
|
||||
deletion and error simulation are quiet controls. The current filter is
|
||||
derived from the Data query and visibly distinct. Disabled controls retain
|
||||
their official semantics and palette.
|
||||
- Rhythm: 10px within a horizontal control group, 16px between workspace
|
||||
columns, one text line between vertical groups, and `(1 2)` card padding.
|
||||
Ebox Row `:item-gap` is pixels; Column `:item-gap` is lines. Flex uses
|
||||
`:gap '(1 (16))` for one line vertically and 16px horizontally. Keep buttons
|
||||
compact with horizontal padding, rather than making every table row tall.
|
||||
- Data: 100 deterministic tasks, mixed completion states, 10 rows per page.
|
||||
Test all pages, search, filtering, selection, CRUD, two independent Apps and
|
||||
resource recovery. Do not replace the real dataset with a smaller acceptance
|
||||
fixture. Initial seed titles remain stable for reproducible input checks.
|
||||
- Responsive: retain declarative Flex wrapping in source order. Side columns
|
||||
have stable basis sizes; the task list grows. Root padding and viewport scroll
|
||||
are legitimate composition and must work together without example workarounds.
|
||||
- Panel alignment: workspace panels align at the top and keep their own
|
||||
content-driven heights in layout lines. Toggling “显示说明” collapses the
|
||||
detail content without changing the filter, task or service line counts. Following cards
|
||||
and the footer may move naturally in document flow; do not reserve invisible
|
||||
help space or introduce viewport-specific height constants. This follows
|
||||
the user's 2026-09-08 review of disclosure-induced panel resizing.
|
||||
- Native text geometry: Emacs shares ascent and descent across each displayed
|
||||
row. Moving content may therefore change a card's pixel height while its
|
||||
layout line count stays fixed. The user explicitly accepts this behavior;
|
||||
preserve layout semantics and interaction instead of forcing uniform rows.
|
||||
- Width distribution: filter/list/inspector grow with weights `1/4/1`, keeping
|
||||
emphasis on the task list while a side column fills its line when wrapped.
|
||||
Filter buttons wrap into a horizontal group when their panel has room.
|
||||
Detail and service cards share a wrapping Flex: stacked in the desktop side
|
||||
column, side by side with independent heights on a wider wrapped row, then
|
||||
stacked again when each card's usable minimum width no longer fits.
|
||||
- Table sizing: the task title receives the remaining column width through the
|
||||
existing `(fr 1)` Grid track convention; the action column keeps its compact
|
||||
character width. Header and body consume the same tracks. Resizing changes
|
||||
geometry without replacing custom cell state or semantic identity.
|
||||
- Pagination: full previous/next buttons with readable labels and horizontal
|
||||
padding, a quiet centered page/range summary, and clear disabled states.
|
||||
Workbench uses Chinese labels; the shared component retains configurable text.
|
||||
- Acceptance: inspect light/dark, selected/disabled, wide/compact and scrolled
|
||||
GUI states after functional checks. Preserve the goal's three real GUI
|
||||
performance sample sets with per-operation p95 and max at most 50ms.
|
||||
- Assumption: no new brand was requested; the repository's existing cobalt,
|
||||
neutral surfaces and typography are the design basis.
|
||||
|
||||
@ -108,12 +108,27 @@ ETAF 私有 registry 变量;Component setup 中创建的 Controller 自动归
|
||||
- 用 inert reader、source tab/session、未保存 source refresh 和 SQLite 临时文件
|
||||
测试 mount/remount、筛选、分页、重复选行、mutation、错误状态和 cleanup;GUI
|
||||
用干净 fullscreen 截图验证真实布局。
|
||||
- 目标:一次 Data mutation 对应一次 Runtime generation/publication;warm 交互
|
||||
维持已接受的 105ms p50 预算。
|
||||
- 目标:一次 Data mutation 对应一次 Runtime generation/publication。Research Shelf
|
||||
的批处理延迟 lane 在固定 1413×62 几何下执行 5 次未计时 warmup 与 30 个计时 sample,
|
||||
每个场景的 p95 和 max 均须不超过 50ms;当前 GUI 验收还有下述独立要求。
|
||||
已接受的 105ms p50 是历史设计上下文,
|
||||
不是当前 evaluator gate;其正式处置仍由 M0b1 的 `DOC-PERF-001` 负责。
|
||||
- 压测入口:`etaf-research-shelf-fixture-size` 默认 256,
|
||||
`etaf-research-shelf-page-size` 默认 12;已有本地记录保留,不足部分使用新 ID
|
||||
补齐 fixture。
|
||||
|
||||
## 性能 evidence lanes
|
||||
|
||||
批处理延迟 lane、追踪 lane 与 GUI lane 共享同一组仓库、环境、场景、fixture 和 build identity,
|
||||
但保持为三种独立测量。批处理延迟 lane 负责 Research Shelf 1413×62 fixture 中
|
||||
无 instrumentation 的 5/30、p95/max 50ms 回归检查。Batch verifier duration
|
||||
不是 GUI first paint。追踪 lane 负责一次代表性 instrumented invocation 的 cost class、
|
||||
work counters、turns、allocation 与 GC;GUI lane 负责真实 Emacs action sequence
|
||||
与已审查的画面证据。当前 GUI 验收还要求三组独立的前台实测,每项操作从回调开始
|
||||
到强制 redisplay 返回的 p95 和 max 均不超过 50ms;该门禁尚未通过。使用
|
||||
`../etaf/scripts/README.md` 中的测量入口,保留预热、GC 记录和全部样本。
|
||||
redisplay 返回不能证明操作系统已经呈现画面。任何一条 lane 都不能替另一条 lane 宣称通过。
|
||||
|
||||
## 待 review
|
||||
|
||||
- [ ] 用户可调整产品命名或 palette;pair 边界、组合/复用原则和公开交互合同不变。
|
||||
|
||||
61
Makefile
61
Makefile
@ -1,5 +1,5 @@
|
||||
EMACS ?= emacs
|
||||
LOAD_PATH = -L . -L ../etaf -L ../etaf-ui -L ../ebox -L ../ecss -L ../tp -L ../etaf-sqlite
|
||||
LOAD_PATH = -L . -L scripts -L ../etaf -L ../etaf-ui -L ../ebox -L ../ecss -L ../tp -L ../etaf-db
|
||||
EBOX_NATIVE_RELEASE_DIR = $(shell $(EMACS) -Q --batch $(LOAD_PATH) \
|
||||
--eval '(setq load-prefer-newer t)' -l ../ebox/ebox-native-reflow.el \
|
||||
--eval '(princ (expand-file-name (format "../ebox/native/target/%s/release/" (ebox-native-reflow--rust-target))))')
|
||||
@ -8,8 +8,9 @@ EXAMPLES := $(ENTRY_EXAMPLES)
|
||||
EXAMPLE_ELC := $(EXAMPLES:.el=.elc)
|
||||
TEST_FILES := $(wildcard tests/*-tests.el)
|
||||
|
||||
.PHONY: all compile examples-read test perf perf-evaluator perf-regressions \
|
||||
perf-check check checkdoc load clean
|
||||
.PHONY: all compile examples-read test perf perf-prepare perf-evaluator perf-repeatability perf-regressions \
|
||||
perf-check gui-doctor gui-research gui-flex gui-grid gui-all \
|
||||
check checkdoc load clean
|
||||
|
||||
all: check
|
||||
|
||||
@ -22,13 +23,17 @@ compile:
|
||||
$(MAKE) -C ../ebox compile EMACS="$(EMACS)" ECSS_DIR=../ecss TP_DIR=../tp
|
||||
$(MAKE) -C ../etaf compile EMACS="$(EMACS)"
|
||||
$(MAKE) -C ../etaf-ui compile EMACS="$(EMACS)"
|
||||
$(MAKE) -C ../etaf-sqlite compile EMACS="$(EMACS)"
|
||||
rm -f *.elc tests/*.elc $(EXAMPLE_ELC)
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
|
||||
$(MAKE) -C ../etaf-db compile EMACS="$(EMACS)"
|
||||
rm -f *.elc scripts/*.elc tests/*.elc $(EXAMPLE_ELC)
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) -L ../etaf/scripts -L ../ebox-playground \
|
||||
--eval "(setq load-prefer-newer t byte-compile-error-on-warn t byte-compile-warnings '(not obsolete))" \
|
||||
--eval '(load-file "etaf-playground.el")' \
|
||||
--eval '(dolist (file (quote ($(foreach file,$(ENTRY_EXAMPLES),"$(file)")))) (load-file file))' \
|
||||
--eval '(dolist (file (quote ($(foreach file,$(EXAMPLES),"$(file)")))) (byte-compile-file file))' \
|
||||
--eval '(byte-compile-file "etaf-playground.el")' \
|
||||
--eval '(byte-compile-file "scripts/playground-gui-scenarios.el")' \
|
||||
--eval '(byte-compile-file "scripts/task-workbench-gui-scenarios.el")' \
|
||||
--eval '(byte-compile-file "scripts/research-shelf-m0a-evidence.el")' \
|
||||
--eval '(dolist (file (quote ($(foreach file,$(TEST_FILES),"$(file)")))) (byte-compile-file file))'
|
||||
|
||||
examples-read: compile
|
||||
@ -41,16 +46,31 @@ test: examples-read
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
|
||||
$(foreach test,$(TEST_FILES),-l $(test)) -f ert-run-tests-batch-and-exit
|
||||
|
||||
perf: perf-evaluator
|
||||
perf:
|
||||
$(MAKE) perf-prepare EMACS="$(EMACS)"
|
||||
$(MAKE) perf-evaluator EMACS="$(EMACS)"
|
||||
|
||||
perf-evaluator: compile
|
||||
perf-prepare: compile
|
||||
$(MAKE) -C ../ebox native-build EMACS="$(EMACS)" ECSS_DIR=../ecss TP_DIR=../tp
|
||||
|
||||
# Run only the already-built product. This separate target lets an absolute
|
||||
# max-latency sample start after compilation CPU activity has settled.
|
||||
perf-evaluator:
|
||||
scripts/with-performance-lock.sh env \
|
||||
EBOX_NATIVE_REFLOW_MODULE_PATH="$(EBOX_NATIVE_RELEASE_DIR)" \
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \
|
||||
"$(EMACS)" -Q --batch $(LOAD_PATH) \
|
||||
--eval '(setq load-prefer-newer t native-comp-jit-compilation nil)' \
|
||||
--eval '(setq ebox-native-reflow-module-path (getenv "EBOX_NATIVE_REFLOW_MODULE_PATH"))' \
|
||||
-l scripts/benchmark-research-shelf.el \
|
||||
-f etaf-performance-evaluator-batch
|
||||
|
||||
# A final hard-max claim must survive three complete independent sample sets.
|
||||
# The lock above prevents parallel reviewers from benchmarking one another.
|
||||
perf-repeatability: perf-prepare
|
||||
$(MAKE) perf-evaluator EMACS="$(EMACS)"
|
||||
$(MAKE) perf-evaluator EMACS="$(EMACS)"
|
||||
$(MAKE) perf-evaluator EMACS="$(EMACS)"
|
||||
|
||||
# Run package regressions in dependency order. Keeping them in one recipe
|
||||
# prevents parallel make from cleaning/recompiling a sibling while another
|
||||
# package is loading its compiled dependencies.
|
||||
@ -60,23 +80,38 @@ perf-regressions:
|
||||
$(MAKE) -C ../ebox test EMACS="$(EMACS)" ECSS_DIR=../ecss TP_DIR=../tp
|
||||
$(MAKE) -C ../etaf test EMACS="$(EMACS)"
|
||||
$(MAKE) -C ../etaf-ui test EMACS="$(EMACS)"
|
||||
$(MAKE) -C ../etaf-sqlite test EMACS="$(EMACS)"
|
||||
$(MAKE) -C ../etaf-db test EMACS="$(EMACS)"
|
||||
$(MAKE) test EMACS="$(EMACS)"
|
||||
|
||||
# Measure absolute latency before the CPU-heavy regression graph. Regressions
|
||||
# still gate the same target, but cannot thermally contaminate product samples.
|
||||
perf-check:
|
||||
$(MAKE) perf-evaluator EMACS="$(EMACS)"
|
||||
$(MAKE) perf-repeatability EMACS="$(EMACS)"
|
||||
$(MAKE) perf-regressions EMACS="$(EMACS)"
|
||||
|
||||
gui-doctor:
|
||||
scripts/run-gui-verification.sh doctor
|
||||
|
||||
gui-research:
|
||||
scripts/run-gui-verification.sh research-shelf
|
||||
|
||||
gui-flex:
|
||||
scripts/run-gui-verification.sh flex-reference
|
||||
|
||||
gui-grid:
|
||||
scripts/run-gui-verification.sh grid-reference
|
||||
|
||||
gui-all:
|
||||
scripts/run-gui-verification.sh all
|
||||
|
||||
load: compile
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) --eval '(require (quote etaf-playground))' \
|
||||
--eval '(princ "etaf-playground load OK\\n")'
|
||||
|
||||
checkdoc:
|
||||
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (list "etaf-playground.el" "scripts/benchmark-research-shelf.el") (directory-files-recursively "tests" "\\.el$$") (directory-files-recursively "examples" "\\.el$$"))) (checkdoc-file file)))'
|
||||
$(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (list "etaf-playground.el" "scripts/benchmark-research-shelf.el" "scripts/playground-gui-scenarios.el" "scripts/task-workbench-gui-scenarios.el" "scripts/research-shelf-m0a-evidence.el") (directory-files-recursively "tests" "\\.el$$") (directory-files-recursively "examples" "\\.el$$"))) (checkdoc-file file)))'
|
||||
|
||||
check: checkdoc test
|
||||
|
||||
clean:
|
||||
rm -f *.elc tests/*.elc $(EXAMPLE_ELC)
|
||||
rm -f *.elc scripts/*.elc tests/*.elc $(EXAMPLE_ELC)
|
||||
|
||||
117
README.md
117
README.md
@ -19,6 +19,9 @@ into the right-hand preview. Saving a source file also refreshes by default.
|
||||
`etaf-playground-register-example` is available when a companion needs a
|
||||
non-conventional root or feature name.
|
||||
|
||||
ETAF Playground 0.2.2 declares ETAF 0.2.1, ETAF UI 0.1.0, and ETAF SQLite
|
||||
0.1.0 so the bundled Research Shelf companion has a complete install closure.
|
||||
|
||||
Preview placement uses the standard Emacs `display-buffer` action stored in
|
||||
`etaf-playground-display-action`. The default is a right side window using
|
||||
half the frame:
|
||||
@ -56,12 +59,124 @@ examples/research-shelf.ecss # inert style source
|
||||
examples/research-shelf.el # DATA / THEME / STATE / VIEW / ROOT sections
|
||||
```
|
||||
|
||||
Opening an inert `.etaf` or `.ecss` source loads only its lightweight editing
|
||||
mode. The ETAF/Ebox/TP runtime is loaded when a preview is refreshed or
|
||||
mounted. Runtime use requires TP 1.0.1 or newer so `tp-transaction.el` and the
|
||||
Host final-accept contract are present.
|
||||
|
||||
The companion registers `:reload-on-refresh t`, so saving the `.el`, `.etaf`, or
|
||||
`.ecss` source and refreshing reloads the complete consumer before the next
|
||||
mount.
|
||||
|
||||
## Repeatable Emacs 31.1 GUI verification
|
||||
|
||||
Use the user's running graphical Emacs server for current GUI acceptance.
|
||||
Connect with `emacsclient`, render into an explicit buffer in the existing
|
||||
frame, then inspect a capture of that window without changing application focus.
|
||||
Preserve the user's font,
|
||||
coding settings and normal GC policy. A missing server is not a reason to
|
||||
silently start a daemon or create another frame.
|
||||
|
||||
With this checkout and its sibling dependencies already on Emacs's load path:
|
||||
|
||||
```sh
|
||||
emacsclient --eval '(progn (require (quote task-workbench)) (wb-open "*Workbench review*"))'
|
||||
```
|
||||
|
||||
The maintained example is `examples/task-workbench.el`; add that directory to
|
||||
`load-path` before requiring it. For automated interaction checks, load
|
||||
`scripts/task-workbench-gui-scenarios.el` with its `emacs-gui-verifier` engine
|
||||
and adapter dependencies available, then use the existing frame:
|
||||
|
||||
```elisp
|
||||
(task-workbench-gui-prepare)
|
||||
(run-at-time 0.05 nil #'task-workbench-gui-run "/absolute/fresh/evidence-directory")
|
||||
```
|
||||
|
||||
The caller owns window capture and evidence review. The adapter requires fresh
|
||||
dedicated acceptance buffers and preserves the current rendering backend.
|
||||
Preparation also preserves application focus; `(task-workbench-gui-prepare t)`
|
||||
explicitly requests foreground activation. Background Emacs-local actions can
|
||||
verify app behavior, but their timing does not certify foreground display latency.
|
||||
When `EBOX_NATIVE_REFLOW_MODULE_PATH` is explicitly set, it requires that exact
|
||||
compatible module. It does not start a server. Check the mounted Runtime,
|
||||
action assertions and the actual
|
||||
images. Screenshots alone do not prove a latency bound or absence of flicker.
|
||||
See `../etaf/scripts/README.md` for existing-server capture and recording details.
|
||||
|
||||
The following commands are **legacy isolated-environment tools**, retained for
|
||||
explicit requests to use a separate test Emacs. They are not the default
|
||||
existing-server workflow:
|
||||
|
||||
```sh
|
||||
make gui-doctor
|
||||
make gui-research
|
||||
make gui-flex
|
||||
make gui-grid
|
||||
# Or capture all four sequentially in isolated test instances:
|
||||
make gui-all
|
||||
```
|
||||
|
||||
The reusable engine and process runner live in `../etaf/scripts/`. They know
|
||||
only Scenario, Action, Context, checkpoint, recording, and evidence contracts.
|
||||
`scripts/playground-gui-scenarios.el` is a thin adapter layer: Research Shelf
|
||||
defines its application actions, while Flex and Grid are two inputs to the same
|
||||
Ebox reference scenario factory. Adding another application does not create a
|
||||
second daemon/recording/checkpoint implementation.
|
||||
|
||||
Each scenario creates a unique named daemon, disables native-comp JIT, loads
|
||||
the sibling repositories explicitly, creates one GUI frame, activates Emacs
|
||||
from the controlling shell, records through a PTY-backed macOS screen recorder,
|
||||
runs mount/resize/scroll/interaction checkpoints, writes screenshots and a
|
||||
manifest, then shuts down every process it created. Flex and Grid are read from
|
||||
their current `ebox-playground` working files so the gate verifies the exact
|
||||
code a user is testing. The runner never writes, stages, restores, or otherwise
|
||||
mutates either fixture.
|
||||
|
||||
A fresh capture intentionally reports `INCOMPLETE` until a human or agent has
|
||||
inspected `report.md`, `contact-sheet.png`, and its selected endpoint images.
|
||||
After that temporal review, finalize the exact run directory:
|
||||
|
||||
```sh
|
||||
scripts/run-gui-verification.sh review /private/tmp/etaf-playground-gui.XXXXXX
|
||||
```
|
||||
|
||||
For this legacy capture bundle, only `VERDICT=PASS` certifies its review.
|
||||
This verdict is not required by the separate existing-server workflow.
|
||||
Assertion failure, a black segment,
|
||||
missing recording, wrong buffer, split window, stale frame, or missing temporal
|
||||
review remains fail-closed.
|
||||
|
||||
Run `make check EMACS=/Applications/Emacs.app/Contents/MacOS/Emacs`.
|
||||
Run `make perf` for the 1413×62 warm row-selection/theme latency gate.
|
||||
Run `make perf` for the fixed 1413×62 batch latency gate. Every scenario performs
|
||||
five unmeasured warmups followed by 30 measured samples; both p95 and max must
|
||||
remain at or below 50ms, including Theme and post-resize interactions.
|
||||
For repeated absolute-latency runs, use `make perf-prepare` once after source
|
||||
changes, let compilation activity settle, then run `make perf-evaluator` without
|
||||
rebuilding the dependency graph.
|
||||
|
||||
## Performance evidence lanes
|
||||
|
||||
Performance evidence has three separate lanes correlated by one
|
||||
repository/environment/scenario/fixture/build identity:
|
||||
|
||||
- The batch latency lane runs the retained Research Shelf 1413×62 evaluator
|
||||
with 5 unmeasured warmups and 30 measured samples. Its p95/max 50ms checks
|
||||
diagnose regressions in that batch fixture. Batch verifier duration measures
|
||||
batch Lisp work, not GUI first paint.
|
||||
- The trace lane runs a separate instrumented representative invocation. Its
|
||||
cost classes, work counters, turns, allocation, and GC data are not inserted
|
||||
into the timed latency distribution.
|
||||
- The GUI lane checks the real Emacs interaction sequence and reviewed images.
|
||||
Current acceptance also requires three independent foreground GUI sample sets
|
||||
with per-operation p95 and max at or below 50ms, from action callback through
|
||||
forced redisplay. This gate remains outstanding. Use the measurement boundary
|
||||
in `../etaf/scripts/README.md`, preserving warmups, GC and all samples. Returning
|
||||
from redisplay does not certify compositor presentation.
|
||||
|
||||
Evidence from one lane supports only that lane's conclusion. A
|
||||
performance-complete or user-visible-non-regression claim requires the
|
||||
applicable gates from all three lanes.
|
||||
|
||||
The bundled Research Shelf example installs a deterministic 256-record SQLite
|
||||
fixture with 12 records per page. Bind `etaf-research-shelf-fixture-size` and
|
||||
|
||||
@ -18,6 +18,9 @@ ETAF Playground 是通用的应用构建工作区:左侧编辑同一个应用
|
||||
也会刷新。若 root 或 feature 不遵循命名约定,可在 companion 中调用
|
||||
`etaf-playground-register-example` 注册覆盖。
|
||||
|
||||
ETAF Playground 0.2.2 会声明 ETAF 0.2.1、ETAF UI 0.1.0 与 ETAF SQLite
|
||||
0.1.0,保证内置 Research Shelf companion 的安装依赖闭包完整。
|
||||
|
||||
预览位置使用标准 Emacs `display-buffer` action,由
|
||||
`etaf-playground-display-action` 配置。默认在右侧使用一半 frame:
|
||||
|
||||
@ -55,11 +58,85 @@ examples/research-shelf.ecss # inert 样式 source
|
||||
examples/research-shelf.el # DATA / THEME / STATE / VIEW / ROOT 分区
|
||||
```
|
||||
|
||||
直接打开 inert `.etaf` 或 `.ecss` source 时只加载轻量编辑 mode;刷新或 mount
|
||||
preview 时才加载 ETAF/Ebox/TP runtime。运行 preview 需要 TP 1.0.1 或更高版本,
|
||||
以保证 `tp-transaction.el` 与 Host final-accept contract 已安装。
|
||||
|
||||
该 companion 注册了 `:reload-on-refresh t`;保存 `.el`、`.etaf` 或 `.ecss` 后刷新
|
||||
source,会在下一次 mount 前重新加载完整 consumer。
|
||||
|
||||
## 可重复执行的 Emacs 31.1 GUI 实测
|
||||
|
||||
当前 GUI 验收使用用户已经运行的图形 Emacs server:通过 `emacsclient`
|
||||
在明确命名的 buffer 中渲染,保留当前应用焦点,只截取已有窗口并检查。
|
||||
保留用户字体、编码设置和正常 GC 策略;连接失败时不自动启动 daemon 或另建 frame。
|
||||
|
||||
本仓库及 sibling 依赖已在 Emacs 的 load-path 中时:
|
||||
|
||||
```sh
|
||||
emacsclient --eval '(progn (require (quote task-workbench)) (wb-open "*Workbench review*"))'
|
||||
```
|
||||
|
||||
维护中的例子位于 `examples/task-workbench.el`;require 前需将 examples
|
||||
目录加入 load-path。自动交互验证可在 `emacs-gui-verifier` 引擎及适配器
|
||||
依赖已经可用后,加载 `scripts/task-workbench-gui-scenarios.el`,在已有 frame 执行:
|
||||
|
||||
```elisp
|
||||
(task-workbench-gui-prepare)
|
||||
(run-at-time 0.05 nil #'task-workbench-gui-run "/absolute/fresh/evidence-directory")
|
||||
```
|
||||
|
||||
调用方负责窗口截图及证据检查。适配器要求新的专用验收 buffer,并保留当前
|
||||
渲染后端。准备阶段也保留应用焦点;显式调用 `(task-workbench-gui-prepare t)`
|
||||
才会切到前台。后台的 Emacs 本地动作可以验证功能,其耗时不能证明前台显示延迟。
|
||||
只有显式设置 `EBOX_NATIVE_REFLOW_MODULE_PATH` 时,才要求加载该路径下的兼容
|
||||
native 模块。适配器不启动 server。需检查 mounted Runtime、动作断言和实际截图;
|
||||
截图本身不能证明延迟上界或无闪烁。现有 server 的截图与录屏细节见
|
||||
`../etaf/scripts/README.md`。
|
||||
|
||||
以下命令是保留的 **legacy 隔离环境工具**,只用于明确选择独立测试 Emacs 的
|
||||
场景,不是当前默认的 existing-server 流程:
|
||||
|
||||
```sh
|
||||
make gui-doctor
|
||||
make gui-research
|
||||
make gui-flex
|
||||
make gui-grid
|
||||
# 或在独立测试实例中按顺序采集四个场景:
|
||||
make gui-all
|
||||
```
|
||||
|
||||
可复用的执行引擎与进程 runner 位于 `../etaf/scripts/`,只理解 Scenario、Action、
|
||||
Context、checkpoint、录屏和 evidence 合同。`scripts/playground-gui-scenarios.el` 只是
|
||||
薄适配层:Research Shelf 提供应用动作,Flex 与 Grid 只是同一个 Ebox reference
|
||||
scenario factory 的两个输入。增加新应用时不会复制第二套 daemon/录屏/checkpoint
|
||||
实现。
|
||||
|
||||
每个场景都会创建唯一命名 daemon,关闭 native-comp JIT,显式加载 sibling 仓库,
|
||||
创建单一 GUI frame,由外层 shell 激活 Emacs,通过保留 PTY 的 macOS recorder 录屏,
|
||||
依次执行 mount/resize/scroll/interaction checkpoint,生成 screenshot 与 manifest,最后
|
||||
清理自己创建的全部进程。Flex 与 Grid 直接读取 `ebox-playground` 当前工作文件,确保
|
||||
门禁验证的就是用户正在测试的代码;runner 绝不写入、暂存、恢复或以其他方式修改
|
||||
这两个 fixture。
|
||||
|
||||
新采集有意保持 `INCOMPLETE`,直到人或 agent 检查 `report.md`、
|
||||
`contact-sheet.png` 和报告选出的首尾图。完成时序审查后,对同一个 run directory
|
||||
执行:
|
||||
|
||||
```sh
|
||||
scripts/run-gui-verification.sh review /private/tmp/etaf-playground-gui.XXXXXX
|
||||
```
|
||||
|
||||
对于这套 legacy 录屏包,只有 `VERDICT=PASS` 才证明其审查完成;这个 verdict
|
||||
不是另一条 existing-server 流程的必要条件。assertion 失败、黑帧、录屏缺失、错误 buffer、
|
||||
split window、陈旧 frame 或没有完成时序审查都会保持 fail-closed。
|
||||
|
||||
验证命令:`make check EMACS=/Applications/Emacs.app/Contents/MacOS/Emacs`。
|
||||
性能门禁:`make perf`(1413×62 viewport 的 warm 选行/主题延迟)。
|
||||
批处理回归:`make perf`(Research Shelf 的 1413×62 viewport,选行/主题延迟)。
|
||||
当前 GUI 验收还要求三组独立的前台实测,每项操作从回调开始到强制 redisplay
|
||||
返回的 p95 和 max 均不超过 50ms;该门禁尚未通过。使用
|
||||
`../etaf/scripts/README.md` 中的测量入口,保留预热、GC 记录和全部样本。
|
||||
redisplay 返回不能证明操作系统已经呈现画面,批处理结果也不能替代 GUI 门禁。
|
||||
|
||||
仓库中的 Research Shelf 只是上述通用工作区的一个 consumer。它默认安装确定性的
|
||||
256 条 SQLite fixture,每页显示 12 条;测试或压测时可以绑定
|
||||
|
||||
@ -3,8 +3,8 @@
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;; Author: ETAF contributors
|
||||
;; Version: 0.2.0
|
||||
;; Package-Requires: ((emacs "29.1") (etaf "0.1.0"))
|
||||
;; Version: 0.2.2
|
||||
;; Package-Requires: ((emacs "29.1") (etaf "0.2.1") (etaf-sqlite "0.1.0") (etaf-ui "0.1.0"))
|
||||
;; Keywords: tools, convenience, ui
|
||||
|
||||
;;; Commentary:
|
||||
@ -32,7 +32,21 @@
|
||||
(require 'cl-lib)
|
||||
(require 'subr-x)
|
||||
(require 'button)
|
||||
(require 'etaf)
|
||||
|
||||
(define-error 'etaf-playground-dependency-error
|
||||
"ETAF Playground requires TP 2.0.0 or newer with tp-transaction")
|
||||
|
||||
(defun etaf-playground--ensure-runtime ()
|
||||
"Load ETAF runtime dependencies or report an actionable TP mismatch."
|
||||
(condition-case condition
|
||||
(require 'etaf)
|
||||
(file-missing
|
||||
(if (member "tp-transaction" condition)
|
||||
(signal 'etaf-playground-dependency-error
|
||||
(list :required-package '(tp "2.0.0")
|
||||
:missing-feature 'tp-transaction
|
||||
:original-condition condition))
|
||||
(signal (car condition) (cdr condition))))))
|
||||
|
||||
(defgroup etaf-playground nil
|
||||
"Authoring workspaces for ETAF applications."
|
||||
@ -86,6 +100,11 @@ frame."
|
||||
|
||||
(declare-function ebox-call-with-render-burst
|
||||
"ebox-buffer-backend" (function &rest arguments))
|
||||
(declare-function etaf-action-redefine-run "etaf-actions" (function))
|
||||
(declare-function etaf-component-redefine-run "etaf-component" (function))
|
||||
(declare-function etaf-mount "etaf-runtime" (buffer view &optional options))
|
||||
(declare-function etaf-runtime-for-buffer "etaf-runtime" (buffer))
|
||||
(declare-function etaf-unmount "etaf-runtime" (runtime))
|
||||
|
||||
(cl-defstruct (etaf-playground-session
|
||||
(:constructor etaf-playground--session-create))
|
||||
@ -418,7 +437,9 @@ disk."
|
||||
(save-restriction
|
||||
(widen)
|
||||
(etaf-component-redefine-run
|
||||
(lambda () (eval-buffer nil))))
|
||||
(lambda ()
|
||||
(etaf-action-redefine-run
|
||||
(lambda () (eval-buffer nil))))))
|
||||
(setf (etaf-playground-session-companion-dirty-p session) nil)
|
||||
(setq-local etaf-playground-companion-dirty-p nil))
|
||||
(unless loaded-p
|
||||
@ -463,6 +484,23 @@ only file evaluated by the framework."
|
||||
(etaf-playground--root-factory spec)
|
||||
name static-form ecss-form)))
|
||||
|
||||
(defun etaf-playground--apply-preview-display-settings ()
|
||||
"Suppress text-editor redisplay artifacts in the current preview buffer.
|
||||
|
||||
An ETAF preview owns its viewport and line layout. Editor continuation and
|
||||
truncation indicators otherwise leak into narrow generated canvases as dark
|
||||
blocks at the right edge."
|
||||
(setq-local truncate-lines t
|
||||
auto-hscroll-mode t
|
||||
fringe-indicator-alist
|
||||
(cl-remove-if
|
||||
(lambda (entry)
|
||||
(memq (car-safe entry) '(truncation continuation)))
|
||||
(copy-tree fringe-indicator-alist))
|
||||
bidi-display-reordering nil
|
||||
bidi-paragraph-direction 'left-to-right
|
||||
bidi-inhibit-bpa t))
|
||||
|
||||
(defun etaf-playground--preview-mode-setup (buffer session)
|
||||
"Prepare generated preview BUFFER for SESSION."
|
||||
(with-current-buffer buffer
|
||||
@ -476,7 +514,7 @@ only file evaluated by the framework."
|
||||
(format " ETAF Preview %s | g refresh q close"
|
||||
(etaf-playground-session-name session)))
|
||||
(buffer-disable-undo)
|
||||
(setq-local truncate-lines nil))
|
||||
(etaf-playground--apply-preview-display-settings))
|
||||
buffer)
|
||||
|
||||
(defun etaf-playground--mount-example-now
|
||||
@ -496,7 +534,10 @@ SESSION supplies authoritative source buffers. MOUNT-OPTIONS is forwarded to
|
||||
(etaf-mount buffer (etaf-playground-read-pair name session)
|
||||
mount-options))
|
||||
(with-current-buffer buffer
|
||||
(setq-local etaf-playground-current-example name))
|
||||
(setq-local etaf-playground-current-example name)
|
||||
;; Publication may restore renderer-owned buffer settings. The generated
|
||||
;; preview display contract is final and must win after the mount.
|
||||
(etaf-playground--apply-preview-display-settings))
|
||||
buffer))
|
||||
|
||||
(defun etaf-playground-mount-example
|
||||
@ -508,6 +549,7 @@ source editors and side-by-side workspace around it. MOUNT-OPTIONS is
|
||||
forwarded to `etaf-mount', including an optional initial viewport. Source
|
||||
loading, root construction, ETAF publication, and Ebox rendering share one
|
||||
public framework render burst so GC cannot split an interactive mount."
|
||||
(etaf-playground--ensure-runtime)
|
||||
(ebox-call-with-render-burst
|
||||
#'etaf-playground--mount-example-now
|
||||
buffer-name name session mount-options))
|
||||
@ -523,6 +565,7 @@ public framework render burst so GC cannot split an interactive mount."
|
||||
(etaf-playground-session-name session)
|
||||
(error-message-string error-data))))
|
||||
(setq-local buffer-read-only t)
|
||||
(etaf-playground--apply-preview-display-settings)
|
||||
(setq-local header-line-format
|
||||
(format " ETAF Preview %s | ERROR | g retry q close"
|
||||
(etaf-playground-session-name session)))))))
|
||||
@ -532,6 +575,7 @@ public framework render burst so GC cannot split an interactive mount."
|
||||
(let ((preview (etaf-playground-session-preview-buffer session)))
|
||||
(condition-case err
|
||||
(progn
|
||||
(etaf-playground--ensure-runtime)
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer preview)))
|
||||
(with-current-buffer preview
|
||||
(etaf-unmount runtime)))
|
||||
@ -618,21 +662,25 @@ the preview instead of destroying the source workspace."
|
||||
(remove-hook 'after-change-functions
|
||||
#'etaf-playground--after-source-change t)))
|
||||
|
||||
;;;###autoload
|
||||
(define-derived-mode etaf-playground-etaf-mode emacs-lisp-mode "ETAF"
|
||||
"Major mode for inert ETAF structural source files."
|
||||
(etaf-playground-source-mode 1))
|
||||
|
||||
;;;###autoload
|
||||
(define-derived-mode etaf-playground-ecss-mode emacs-lisp-mode "ECSS"
|
||||
"Major mode for inert ETAF ECSS style source files."
|
||||
(etaf-playground-source-mode 1))
|
||||
|
||||
(define-derived-mode etaf-playground-preview-mode special-mode "ETAF-Preview"
|
||||
"Read-only major mode for a mounted ETAF Playground preview."
|
||||
(setq-local truncate-lines nil)
|
||||
(etaf-playground--apply-preview-display-settings)
|
||||
(setq-local buffer-read-only nil)
|
||||
(setq-local mode-line-process nil))
|
||||
|
||||
;;;###autoload
|
||||
(add-to-list 'auto-mode-alist '("\\.etaf\\'" . etaf-playground-etaf-mode))
|
||||
;;;###autoload
|
||||
(add-to-list 'auto-mode-alist '("\\.ecss\\'" . etaf-playground-ecss-mode))
|
||||
|
||||
(defun etaf-playground--source-header ()
|
||||
@ -982,8 +1030,10 @@ default example there."
|
||||
(window-frame preview-window)))
|
||||
(configuration
|
||||
(etaf-playground-session-previous-window-configuration session)))
|
||||
(when-let* ((runtime (and (buffer-live-p preview)
|
||||
(etaf-runtime-for-buffer preview))))
|
||||
(when-let* ((runtime
|
||||
(and (fboundp 'etaf-runtime-for-buffer)
|
||||
(buffer-live-p preview)
|
||||
(etaf-runtime-for-buffer preview))))
|
||||
(with-current-buffer preview
|
||||
(etaf-unmount runtime)))
|
||||
(remhash (etaf-playground-session-name session)
|
||||
@ -1011,7 +1061,8 @@ default example there."
|
||||
((and (stringp target) (get-buffer target))
|
||||
(get-buffer target))
|
||||
((null target) (current-buffer))))
|
||||
(runtime (and (buffer-live-p buffer)
|
||||
(runtime (and (fboundp 'etaf-runtime-for-buffer)
|
||||
(buffer-live-p buffer)
|
||||
(etaf-runtime-for-buffer buffer))))
|
||||
(when runtime
|
||||
(with-current-buffer buffer
|
||||
|
||||
@ -226,17 +226,17 @@ user's prior local additions cannot collide with the generated dataset."
|
||||
:ui-disabled-border line
|
||||
:ui-button-primary-fg paper :ui-button-primary-bg accent
|
||||
:ui-button-primary-border accent
|
||||
:ui-button-secondary-fg ink :ui-button-secondary-bg mint
|
||||
:ui-button-secondary-fg ink :ui-button-secondary-bg mint-bg
|
||||
:ui-button-secondary-border mint
|
||||
:ui-button-ghost-fg ink :ui-button-ghost-bg panel
|
||||
:ui-button-ghost-border line
|
||||
:ui-checkbox-enabled-fg ink :ui-checkbox-enabled-bg mint
|
||||
:ui-checkbox-enabled-fg ink :ui-checkbox-enabled-bg mint-bg
|
||||
:ui-checkbox-enabled-border mint
|
||||
:ui-checkbox-disabled-fg muted :ui-checkbox-disabled-bg soft
|
||||
:ui-checkbox-disabled-border line
|
||||
:ui-grid-border line :ui-grid-selected-fg mint
|
||||
:ui-grid-selected-bg mint-bg
|
||||
:ui-grid-error-fg coral :ui-pagination-muted-fg muted
|
||||
:ui-table-border line :ui-table-selected-fg mint
|
||||
:ui-table-selected-bg mint-bg
|
||||
:ui-data-grid-error-fg coral :ui-pagination-muted-fg muted
|
||||
:ui-panel-fg ink :ui-panel-bg panel :ui-panel-border line))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
@ -336,13 +336,24 @@ constructed. When omitted, initialize it for direct programmatic callers."
|
||||
(append (list :id (plist-get row :id)) fields)
|
||||
message)))
|
||||
|
||||
;; Named Actions keep product mutations out of View callbacks. The View layer
|
||||
;; only dispatches these stable application commands with the current model.
|
||||
(etaf-action-define etaf-research-shelf-filter (runtime model filter)
|
||||
"Apply FILTER to MODEL."
|
||||
(ignore runtime)
|
||||
(etaf-research-shelf--set-filter model filter))
|
||||
(defun etaf-research-shelf--advance-item (model item)
|
||||
"Advance ITEM in MODEL by ten percent without changing selection."
|
||||
(let ((next (min 100 (+ 10 (or (plist-get item :progress) 0)))))
|
||||
(etaf-research-shelf--mutate
|
||||
model 'update
|
||||
(list :id (plist-get item :id) :progress next
|
||||
:status (if (= next 100) "finished" "reading") :updated "Just now")
|
||||
"✓ Progress saved")))
|
||||
|
||||
(defun etaf-research-shelf--star-item (model item starred)
|
||||
"Set ITEM's STARRED value in MODEL without changing selection."
|
||||
(etaf-research-shelf--mutate
|
||||
model 'update
|
||||
(list :id (plist-get item :id) :starred (if starred 1 0) :updated "Just now")
|
||||
(if starred "★ Starred locally" "Removed star")))
|
||||
|
||||
;; Named Actions expose reusable application commands. Simple local controls
|
||||
;; can call ordinary business functions directly, as the filter button does.
|
||||
(etaf-action-define etaf-research-shelf-reload (runtime model)
|
||||
"Reload MODEL's data source."
|
||||
(ignore runtime)
|
||||
@ -367,13 +378,8 @@ constructed. When omitted, initialize it for direct programmatic callers."
|
||||
(etaf-action-define etaf-research-shelf-progress (runtime model)
|
||||
"Advance the selected reading by ten percent."
|
||||
(ignore runtime)
|
||||
(when-let* ((current (etaf-research-shelf--selected model))
|
||||
(value (or (plist-get current :progress) 0)))
|
||||
(etaf-research-shelf--update-selected
|
||||
model (list :progress (min 100 (+ value 10))
|
||||
:status (if (>= (+ value 10) 100) "finished" "reading")
|
||||
:updated "Just now")
|
||||
"✓ Progress saved")))
|
||||
(when-let* ((current (etaf-research-shelf--selected model)))
|
||||
(etaf-research-shelf--advance-item model current)))
|
||||
|
||||
(etaf-action-define etaf-research-shelf-finish (runtime model)
|
||||
"Mark the selected reading finished."
|
||||
@ -386,10 +392,8 @@ constructed. When omitted, initialize it for direct programmatic callers."
|
||||
"Toggle the selected reading's star."
|
||||
(ignore runtime)
|
||||
(when-let* ((current (etaf-research-shelf--selected model)))
|
||||
(let ((starred (= 1 (or (plist-get current :starred) 0))))
|
||||
(etaf-research-shelf--update-selected
|
||||
model (list :starred (if starred 0 1) :updated "Just now")
|
||||
(if starred "Removed star" "★ Starred locally")))))
|
||||
(etaf-research-shelf--star-item
|
||||
model current (not (= 1 (or (plist-get current :starred) 0))))))
|
||||
|
||||
(etaf-action-define etaf-research-shelf-archive (runtime model)
|
||||
"Archive the selected reading."
|
||||
@ -401,12 +405,55 @@ constructed. When omitted, initialize it for direct programmatic callers."
|
||||
;;; VIEW / COMPONENTS / COMPOSITION
|
||||
;;; ---------------------------------------------------------------------------
|
||||
|
||||
(etaf-define-component etaf-research-shelf-item-star (&key item)
|
||||
"Star ITEM through the consuming App's model."
|
||||
:setup
|
||||
(etaf-inject 'research-shelf-model nil t)
|
||||
:render
|
||||
(let ((model (etaf-state))
|
||||
(record item))
|
||||
(etaf-view
|
||||
(etaf-checkbox
|
||||
:label "★" :aria-label "Star reading"
|
||||
:checked (= 1 (or (plist-get record :starred) 0))
|
||||
:on-change
|
||||
(lambda (next)
|
||||
(etaf-research-shelf--star-item model record next))))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-item-advance (&key item)
|
||||
"Advance ITEM through the consuming App's model."
|
||||
:setup
|
||||
(etaf-inject 'research-shelf-model nil t)
|
||||
:render
|
||||
(let ((model (etaf-state))
|
||||
(record item))
|
||||
(etaf-view
|
||||
(etaf-button
|
||||
:label "+10%" :aria-label "Advance reading" :variant 'ghost
|
||||
:disabled
|
||||
(or (not (null (member (plist-get record :status) '("finished" "archived"))))
|
||||
(>= (or (plist-get record :progress) 0) 100))
|
||||
:on-press
|
||||
(lambda () (etaf-research-shelf--advance-item model record))))))
|
||||
|
||||
(defun etaf-research-shelf-star-cell (row)
|
||||
"Return ROW's star control at the consuming list's Context."
|
||||
(etaf-view (etaf-research-shelf-item-star :item row)))
|
||||
|
||||
(defun etaf-research-shelf-advance-cell (row)
|
||||
"Return ROW's progress control at the consuming list's Context."
|
||||
(etaf-view (etaf-research-shelf-item-advance :item row)))
|
||||
|
||||
(defconst etaf-research-shelf--grid-columns
|
||||
'((:key :title :label "Title" :width 21)
|
||||
(:key :author :label "Author" :width 12)
|
||||
(:key :status :label "Status" :width 10)
|
||||
(:key :progress :label "Progress" :width 8)
|
||||
(:key :kind :label "Kind" :width 7))
|
||||
(:key :kind :label "Kind" :width 7)
|
||||
(:key :starred :label "Star" :width 6
|
||||
:cell etaf-research-shelf-star-cell)
|
||||
(:key :advance :label "Advance" :width 8
|
||||
:cell etaf-research-shelf-advance-cell))
|
||||
"Compact DataGrid columns for the Research Shelf list.")
|
||||
|
||||
(defun etaf-research-shelf--status-label (status)
|
||||
@ -433,264 +480,295 @@ constructed. When omitted, initialize it for direct programmatic callers."
|
||||
(or (and entry (plist-get (cdr entry) :label)) fallback)))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-filter-button
|
||||
(&key filter-key fallback ref)
|
||||
(&key filter-key fallback)
|
||||
"Render one filter Button from inherited model and static filter Context."
|
||||
:setup
|
||||
(let ((model (etaf-inject 'research-shelf-model nil t))
|
||||
(form (etaf-inject 'research-shelf-filters nil t))
|
||||
(filter-key (etaf-current-prop :filter-key))
|
||||
(fallback (etaf-current-prop :fallback))
|
||||
(ref (etaf-current-prop :ref)))
|
||||
(lambda ()
|
||||
(let ((active (eq filter-key (etaf-value (plist-get model :filter)))))
|
||||
(etaf-view
|
||||
(button :label
|
||||
(let ((label (etaf-research-shelf--filter-label
|
||||
form filter-key fallback)))
|
||||
(if active (concat "● " label) label))
|
||||
:ref ref :variant (if active 'secondary 'ghost)
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-filter
|
||||
model filter-key))))))))
|
||||
|
||||
(defun etaf-research-shelf--filter-view (model)
|
||||
"Return the filter rail for MODEL and inherited filter Context."
|
||||
(etaf-view
|
||||
(column
|
||||
:class "research-shelf-filter-rail" :width 'stretch :min-width 0
|
||||
:flex-grow 1 :flex-shrink 1 :flex-basis '(220)
|
||||
:padding '(1 1)
|
||||
:border (etaf-theme-token :line)
|
||||
:color (etaf-theme-token :ink)
|
||||
:bgcolor (etaf-theme-token :panel)
|
||||
(label :text "Library" :font-weight 'bold)
|
||||
(label :text "VIEWS" :color (etaf-theme-token :muted))
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'all :fallback "All" :ref 'research-shelf-filter-all)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'reading :fallback "In progress"
|
||||
:ref 'research-shelf-filter-reading)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'unread :fallback "Unread" :ref 'research-shelf-filter-unread)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'finished :fallback "Finished"
|
||||
:ref 'research-shelf-filter-finished)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'starred :fallback "★ Starred"
|
||||
:ref 'research-shelf-filter-starred)
|
||||
(box :height 1)
|
||||
(label :text "STORAGE" :color (etaf-theme-token :muted))
|
||||
(label :text (file-name-nondirectory
|
||||
(plist-get model :database-file)))
|
||||
(button :label "↻ Reload library" :ref 'research-shelf-reload
|
||||
:variant 'ghost
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-reload
|
||||
model))))))
|
||||
|
||||
(defun etaf-research-shelf--reading-list-view (model form)
|
||||
"Return the reading list for MODEL and static MAIN FORM."
|
||||
(let ((controller (etaf-research-shelf--controller model)))
|
||||
(list :model (etaf-inject 'research-shelf-model nil t)
|
||||
:form (etaf-inject 'research-shelf-filters nil t))
|
||||
:render
|
||||
(let* ((state (etaf-state))
|
||||
(model (plist-get state :model))
|
||||
(form (plist-get state :form))
|
||||
(key filter-key)
|
||||
(label (etaf-research-shelf--filter-label form key fallback)))
|
||||
(etaf-view
|
||||
(column
|
||||
:class "research-shelf-list" :width 'stretch :min-width 0
|
||||
:flex-grow 4 :flex-shrink 1 :flex-basis '(620)
|
||||
:padding '(1 2)
|
||||
:border (etaf-theme-token :line)
|
||||
:bgcolor (etaf-theme-token :panel)
|
||||
(flex
|
||||
:width 'stretch :flex-wrap 'wrap :align-items 'center :gap '(1 (8))
|
||||
(column
|
||||
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
|
||||
(label :text (etaf-playground-static-value
|
||||
form :title "Reading queue") :font-weight 'bold)
|
||||
(label :text (format "%d items · SQLite-backed"
|
||||
(or (etaf-value (etaf-data-total controller)) 0))
|
||||
:color (etaf-theme-token :muted)))
|
||||
(number-input :label "Rows"
|
||||
:value (etaf-value (etaf-data-page-size controller))
|
||||
:ref 'research-shelf-page-size :min 1 :max 100
|
||||
:on-change
|
||||
(lambda (next)
|
||||
(etaf-dispatch 'etaf-research-shelf-page-size
|
||||
model next)))
|
||||
(button :label "+ Add reading" :ref 'research-shelf-add
|
||||
:variant 'secondary
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-add model))))
|
||||
(data-grid
|
||||
:controller controller
|
||||
:columns etaf-research-shelf--grid-columns
|
||||
:row-key #'etaf-research-shelf--item-id
|
||||
:row-ref (lambda (row)
|
||||
(intern (format "research-shelf-row-%s"
|
||||
(etaf-research-shelf--item-id row))))
|
||||
:on-row-press
|
||||
(lambda (row)
|
||||
(etaf-data-select-one controller
|
||||
(etaf-research-shelf--item-id row)))
|
||||
:loading-label "◷ Loading library…"
|
||||
:error-label "⚠ Could not read the shelf. Use Reload.")
|
||||
(etaf-pagination :controller controller
|
||||
:previous-ref 'research-shelf-page-previous
|
||||
:next-ref 'research-shelf-page-next
|
||||
:color (etaf-theme-token :ink))))))
|
||||
|
||||
(defun etaf-research-shelf--detail-view (model form)
|
||||
"Return the selected record inspector for MODEL and static FORM."
|
||||
(etaf-view
|
||||
(column
|
||||
:class "research-shelf-detail" :width 'stretch :min-width 0
|
||||
:flex-grow 2 :flex-shrink 1 :flex-basis '(340)
|
||||
:padding '(2 2)
|
||||
:border (etaf-theme-token :line)
|
||||
:bgcolor (etaf-theme-token :panel)
|
||||
(label :text (etaf-playground-static-value form :title
|
||||
"Selected item")
|
||||
:color (etaf-theme-token :accent))
|
||||
(text :font-weight 'bold
|
||||
(expr :value
|
||||
(if-let* ((row (etaf-research-shelf--selected model)))
|
||||
(plist-get row :title)
|
||||
"Choose a record")))
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr :value
|
||||
(if-let* ((row (etaf-research-shelf--selected model)))
|
||||
(format "%s · %s" (plist-get row :author)
|
||||
(plist-get row :kind))
|
||||
"Select one row to inspect it.")))
|
||||
(box :height 1)
|
||||
(text :font-weight 'bold
|
||||
(expr :value
|
||||
(if-let* ((row (etaf-research-shelf--selected model)))
|
||||
(etaf-research-shelf--status-label (plist-get row :status))
|
||||
"○ No selection")))
|
||||
(text
|
||||
(expr :value
|
||||
(if-let* ((row (etaf-research-shelf--selected model)))
|
||||
(format "Progress %d%% · Priority %s"
|
||||
(or (plist-get row :progress) 0)
|
||||
(plist-get row :priority))
|
||||
"Progress — · Priority —")))
|
||||
(text :color (etaf-theme-token :accent)
|
||||
(expr :value
|
||||
(let* ((row (etaf-research-shelf--selected model))
|
||||
(progress (or (and row (plist-get row :progress)) 0))
|
||||
(filled (max 0 (min 10 (/ progress 10)))))
|
||||
(format "%s %s" (make-string filled ?█)
|
||||
(make-string (- 10 filled) ?░)))))
|
||||
(box :height 1)
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr :value
|
||||
(if-let* ((row (etaf-research-shelf--selected model)))
|
||||
(concat "“" (or (plist-get row :note) "No note yet.") "”")
|
||||
"Your notes and actions will appear here.")))
|
||||
(box :height 1)
|
||||
(etaf-research-shelf-detail-actions))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-detail-actions ()
|
||||
"Render selected-record actions from the inherited Research Shelf model."
|
||||
:setup
|
||||
(let ((model (etaf-inject 'research-shelf-model nil t)))
|
||||
(lambda ()
|
||||
(let* ((row (etaf-research-shelf--selected model))
|
||||
(progress (or (and row (plist-get row :progress)) 0))
|
||||
(finished (and row (equal (plist-get row :status) "finished")))
|
||||
(archived (and row (equal (plist-get row :status) "archived"))))
|
||||
(etaf-view
|
||||
(flex
|
||||
:width 'stretch :flex-wrap 'wrap :gap '(1 (6))
|
||||
(button :label "+ 10%" :ref 'research-shelf-progress
|
||||
:variant 'secondary
|
||||
:disabled (or (null row) archived (>= progress 100))
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-progress
|
||||
model)))
|
||||
(button :label "✓ Finish" :ref 'research-shelf-finish
|
||||
:variant 'secondary :disabled (or (null row) finished archived)
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-finish
|
||||
model)))
|
||||
(button :label "★ Star" :ref 'research-shelf-star
|
||||
:variant 'ghost :disabled (null row)
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-star model)))
|
||||
(button :label "Archive" :ref 'research-shelf-archive
|
||||
:variant 'ghost :disabled (or (null row) archived)
|
||||
:on-press (lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-archive
|
||||
model)))))))))
|
||||
(etaf-button
|
||||
:label (if (eq key (etaf-value (plist-get model :filter)))
|
||||
(concat "● " label)
|
||||
label)
|
||||
:variant (if (eq key (etaf-value (plist-get model :filter)))
|
||||
'secondary 'ghost)
|
||||
:on-press (lambda () (etaf-research-shelf--set-filter model key))))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-filter-rail ()
|
||||
"Render the Research Shelf filter rail from inherited Context."
|
||||
:setup
|
||||
(let ((model (etaf-inject 'research-shelf-model nil t)))
|
||||
(lambda () (etaf-research-shelf--filter-view model))))
|
||||
(etaf-inject 'research-shelf-model nil t)
|
||||
:view
|
||||
(column :class "research-shelf-filter-rail"
|
||||
:width 'stretch :min-width 0
|
||||
:flex-grow 1 :flex-shrink 1 :flex-basis '(220)
|
||||
:padding '(1 1)
|
||||
:border (etaf-theme-token :line)
|
||||
:color (etaf-theme-token :ink)
|
||||
:bgcolor (etaf-theme-token :panel)
|
||||
(text :font-weight 'bold "Library")
|
||||
(text :color (etaf-theme-token :muted) "VIEWS")
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'all :fallback "All" :ref 'research-shelf-filter-all)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'reading :fallback "In progress"
|
||||
:ref 'research-shelf-filter-reading)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'unread :fallback "Unread"
|
||||
:ref 'research-shelf-filter-unread)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'finished :fallback "Finished"
|
||||
:ref 'research-shelf-filter-finished)
|
||||
(etaf-research-shelf-filter-button
|
||||
:filter-key 'starred :fallback "★ Starred"
|
||||
:ref 'research-shelf-filter-starred)
|
||||
(box :height 1)
|
||||
(text :color (etaf-theme-token :muted) "STORAGE")
|
||||
(text
|
||||
(expr (file-name-nondirectory (plist-get (etaf-state) :database-file))))
|
||||
(etaf-button
|
||||
:label "↻ Reload library" :ref 'research-shelf-reload :variant 'ghost
|
||||
:on-press
|
||||
(let ((model (etaf-state)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-reload model))))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-reading-list ()
|
||||
"Render the Research Shelf reading list from inherited Context."
|
||||
:setup
|
||||
(let ((model (etaf-inject 'research-shelf-model nil t))
|
||||
(form (etaf-inject 'research-shelf-library nil t)))
|
||||
(lambda () (etaf-research-shelf--reading-list-view model form))))
|
||||
(list :model (etaf-inject 'research-shelf-model nil t)
|
||||
:form (etaf-inject 'research-shelf-library nil t))
|
||||
:view
|
||||
(column :class "research-shelf-list" :width 'stretch :min-width 0
|
||||
:flex-grow 4 :flex-shrink 1 :flex-basis '(620)
|
||||
:padding '(1 2)
|
||||
:border (etaf-theme-token :line)
|
||||
:bgcolor (etaf-theme-token :panel)
|
||||
(flex :width 'stretch :flex-wrap 'wrap
|
||||
:align-items 'center :gap '(1 (8))
|
||||
(column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
|
||||
(text :font-weight 'bold
|
||||
(expr (etaf-playground-static-value
|
||||
(plist-get (etaf-state) :form) :title "Reading queue")))
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr
|
||||
(format
|
||||
"%d items · SQLite-backed"
|
||||
(or (etaf-value
|
||||
(etaf-data-total
|
||||
(etaf-research-shelf--controller
|
||||
(plist-get (etaf-state) :model))))
|
||||
0)))))
|
||||
(etaf-number-input
|
||||
:label "Rows"
|
||||
:value
|
||||
(etaf-value
|
||||
(etaf-data-page-size
|
||||
(etaf-research-shelf--controller
|
||||
(plist-get (etaf-state) :model))))
|
||||
:ref 'research-shelf-page-size :min 1 :max 100
|
||||
:on-change
|
||||
(let ((model (plist-get (etaf-state) :model)))
|
||||
(lambda (next)
|
||||
(etaf-dispatch 'etaf-research-shelf-page-size model next))))
|
||||
(etaf-button
|
||||
:label "+ Add reading" :ref 'research-shelf-add :variant 'secondary
|
||||
:on-press
|
||||
(let ((model (plist-get (etaf-state) :model)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-add model)))))
|
||||
(etaf-data-grid
|
||||
:controller
|
||||
(etaf-research-shelf--controller (plist-get (etaf-state) :model))
|
||||
:columns etaf-research-shelf--grid-columns
|
||||
:row-key #'etaf-research-shelf--item-id
|
||||
:row-ref
|
||||
(lambda (row)
|
||||
(intern (format "research-shelf-row-%s"
|
||||
(etaf-research-shelf--item-id row))))
|
||||
:on-row-press
|
||||
(let ((controller
|
||||
(etaf-research-shelf--controller
|
||||
(plist-get (etaf-state) :model))))
|
||||
(lambda (row)
|
||||
(etaf-data-select-one controller
|
||||
(etaf-research-shelf--item-id row))))
|
||||
:loading-label "◷ Loading library…"
|
||||
:error-label "⚠ Could not read the shelf. Use Reload.")
|
||||
(etaf-pagination
|
||||
:controller
|
||||
(etaf-research-shelf--controller (plist-get (etaf-state) :model))
|
||||
:previous-ref 'research-shelf-page-previous
|
||||
:next-ref 'research-shelf-page-next
|
||||
:color (etaf-theme-token :ink))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-detail-inspector ()
|
||||
"Render the Research Shelf detail inspector from inherited Context."
|
||||
:setup
|
||||
(let ((model (etaf-inject 'research-shelf-model nil t))
|
||||
(form (etaf-inject 'research-shelf-detail nil t)))
|
||||
(lambda () (etaf-research-shelf--detail-view model form))))
|
||||
(list :model (etaf-inject 'research-shelf-model nil t)
|
||||
:form (etaf-inject 'research-shelf-detail nil t))
|
||||
:view
|
||||
(column :class "research-shelf-detail" :width 'stretch :min-width 0
|
||||
:flex-grow 2 :flex-shrink 1 :flex-basis '(340)
|
||||
:padding '(2 2)
|
||||
:border (etaf-theme-token :line)
|
||||
:bgcolor (etaf-theme-token :panel)
|
||||
(text :color (etaf-theme-token :accent)
|
||||
(expr (etaf-playground-static-value
|
||||
(plist-get (etaf-state) :form) :title "Selected item")))
|
||||
(text :font-weight 'bold
|
||||
(expr
|
||||
(if-let* ((row
|
||||
(etaf-research-shelf--selected
|
||||
(plist-get (etaf-state) :model))))
|
||||
(plist-get row :title)
|
||||
"Choose a record")))
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr
|
||||
(if-let* ((row
|
||||
(etaf-research-shelf--selected
|
||||
(plist-get (etaf-state) :model))))
|
||||
(format "%s · %s" (plist-get row :author) (plist-get row :kind))
|
||||
"Select one row to inspect it.")))
|
||||
(box :height 1)
|
||||
(text :font-weight 'bold
|
||||
(expr
|
||||
(if-let* ((row
|
||||
(etaf-research-shelf--selected
|
||||
(plist-get (etaf-state) :model))))
|
||||
(etaf-research-shelf--status-label (plist-get row :status))
|
||||
"○ No selection")))
|
||||
(text
|
||||
(expr
|
||||
(if-let* ((row
|
||||
(etaf-research-shelf--selected
|
||||
(plist-get (etaf-state) :model))))
|
||||
(format "Progress %d%% · Priority %s"
|
||||
(or (plist-get row :progress) 0)
|
||||
(plist-get row :priority))
|
||||
"Progress — · Priority —")))
|
||||
(text :color (etaf-theme-token :accent)
|
||||
(expr
|
||||
(let* ((row
|
||||
(etaf-research-shelf--selected
|
||||
(plist-get (etaf-state) :model)))
|
||||
(progress (or (and row (plist-get row :progress)) 0))
|
||||
(filled (max 0 (min 10 (/ progress 10)))))
|
||||
(format "%s %s" (make-string filled ?█)
|
||||
(make-string (- 10 filled) ?░)))))
|
||||
(box :height 1)
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr
|
||||
(if-let* ((row
|
||||
(etaf-research-shelf--selected
|
||||
(plist-get (etaf-state) :model))))
|
||||
(concat "“" (or (plist-get row :note) "No note yet.") "”")
|
||||
"Your notes and actions will appear here.")))
|
||||
(box :height 1)
|
||||
(etaf-research-shelf-detail-actions)))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-detail-actions ()
|
||||
"Render selected-record actions from the inherited Research Shelf model."
|
||||
:setup
|
||||
(etaf-inject 'research-shelf-model nil t)
|
||||
:view
|
||||
(flex :width 'stretch :flex-wrap 'wrap :gap '(1 (6))
|
||||
(etaf-button
|
||||
:label "+ 10%" :ref 'research-shelf-progress :variant 'secondary
|
||||
:disabled
|
||||
(let* ((row (etaf-research-shelf--selected (etaf-state)))
|
||||
(progress (or (and row (plist-get row :progress)) 0)))
|
||||
(or (null row) (equal (plist-get row :status) "archived")
|
||||
(>= progress 100)))
|
||||
:on-press
|
||||
(let ((model (etaf-state)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-progress model))))
|
||||
(etaf-button
|
||||
:label "✓ Finish" :ref 'research-shelf-finish :variant 'secondary
|
||||
:disabled
|
||||
(let ((row (etaf-research-shelf--selected (etaf-state))))
|
||||
(or (null row)
|
||||
(not (null (member (plist-get row :status)
|
||||
'("finished" "archived"))))))
|
||||
:on-press
|
||||
(let ((model (etaf-state)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-finish model))))
|
||||
(etaf-button
|
||||
:label "★ Star" :ref 'research-shelf-star :variant 'ghost
|
||||
:disabled (null (etaf-research-shelf--selected (etaf-state)))
|
||||
:on-press
|
||||
(let ((model (etaf-state)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-star model))))
|
||||
(etaf-button
|
||||
:label "Archive" :ref 'research-shelf-archive :variant 'ghost
|
||||
:disabled
|
||||
(let ((row (etaf-research-shelf--selected (etaf-state))))
|
||||
(or (null row) (equal (plist-get row :status) "archived")))
|
||||
:on-press
|
||||
(let ((model (etaf-state)))
|
||||
(lambda ()
|
||||
(etaf-dispatch 'etaf-research-shelf-archive model))))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-header ()
|
||||
"Render the default `header' slot from App Context."
|
||||
:setup
|
||||
(let ((model (etaf-inject 'research-shelf-model nil t))
|
||||
(root-spec (etaf-inject 'research-shelf-root-spec nil t))
|
||||
(header-spec (etaf-inject 'research-shelf-header-spec nil t)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(flex
|
||||
:class "research-shelf-header" :width 'stretch :min-width 0
|
||||
:flex-wrap 'wrap :align-items 'center :gap '(1 (10))
|
||||
(column
|
||||
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
|
||||
(label :text (etaf-playground-static-value
|
||||
header-spec :eyebrow "Research Shelf")
|
||||
:color (etaf-theme-token :accent))
|
||||
(label :text (etaf-playground-static-value
|
||||
root-spec :title "Research Shelf") :font-weight 'bold)
|
||||
(label :text (etaf-playground-static-value
|
||||
root-spec :subtitle
|
||||
"A quiet place for unfinished ideas")
|
||||
:color (etaf-theme-token :muted)))
|
||||
(column :width 'max-content :min-width 0
|
||||
:flex-grow 0 :flex-shrink 0
|
||||
(checkbox :label "Dark" :ref 'research-shelf-theme-toggle
|
||||
:checked (plist-get model :dark)
|
||||
:on-change (lambda (value)
|
||||
(setf (etaf-value (plist-get model :dark)) value)
|
||||
(setf (etaf-value (plist-get model :toast))
|
||||
(if value "Dark theme" "Light theme"))))))))))
|
||||
(list :model (etaf-inject 'research-shelf-model nil t)
|
||||
:root (etaf-inject 'research-shelf-root-spec nil t)
|
||||
:header (etaf-inject 'research-shelf-header-spec nil t))
|
||||
:view
|
||||
(flex :class "research-shelf-header" :width 'stretch :min-width 0
|
||||
:flex-wrap 'wrap :align-items 'center :gap '(1 (10))
|
||||
(column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
|
||||
(text :color (etaf-theme-token :accent)
|
||||
(expr (etaf-playground-static-value
|
||||
(plist-get (etaf-state) :header) :eyebrow "Research Shelf")))
|
||||
(text :font-weight 'bold
|
||||
(expr (etaf-playground-static-value
|
||||
(plist-get (etaf-state) :root) :title "Research Shelf")))
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr (etaf-playground-static-value
|
||||
(plist-get (etaf-state) :root) :subtitle
|
||||
"A quiet place for unfinished ideas"))))
|
||||
(column :width 'max-content :min-width 0
|
||||
:flex-grow 0 :flex-shrink 0
|
||||
(etaf-checkbox
|
||||
:label "Dark" :ref 'research-shelf-theme-toggle
|
||||
:checked (plist-get (plist-get (etaf-state) :model) :dark)
|
||||
:on-change
|
||||
(let ((model (plist-get (etaf-state) :model)))
|
||||
(lambda (value)
|
||||
(setf (etaf-value (plist-get model :dark)) value)
|
||||
(setf (etaf-value (plist-get model :toast))
|
||||
(if value "Dark theme" "Light theme"))))))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-footer ()
|
||||
"Render the default `footer' slot from App Context."
|
||||
:setup
|
||||
(let ((model (etaf-inject 'research-shelf-model nil t))
|
||||
(footer-spec (etaf-inject 'research-shelf-footer-spec nil t)))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
(flex
|
||||
:class "research-shelf-footer" :width 'stretch
|
||||
:flex-wrap 'wrap :gap '(1 (8))
|
||||
(column
|
||||
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
|
||||
(label :text (plist-get model :toast))
|
||||
(label :text (etaf-playground-static-value
|
||||
footer-spec :label "SQLite · saved locally")
|
||||
:color (etaf-theme-token :muted)))
|
||||
(label :text (file-name-nondirectory
|
||||
(plist-get model :database-file))
|
||||
:color (etaf-theme-token :muted)))))))
|
||||
(list :model (etaf-inject 'research-shelf-model nil t)
|
||||
:footer (etaf-inject 'research-shelf-footer-spec nil t))
|
||||
:view
|
||||
(flex :class "research-shelf-footer" :width 'stretch
|
||||
:flex-wrap 'wrap :gap '(1 (8))
|
||||
(column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
|
||||
(text
|
||||
(expr
|
||||
(etaf-value (plist-get (plist-get (etaf-state) :model) :toast))))
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr (etaf-playground-static-value
|
||||
(plist-get (etaf-state) :footer)
|
||||
:label "SQLite · saved locally"))))
|
||||
(text :color (etaf-theme-token :muted)
|
||||
(expr (file-name-nondirectory
|
||||
(plist-get (plist-get (etaf-state) :model) :database-file))))))
|
||||
|
||||
(etaf-define-component etaf-research-shelf-shell ()
|
||||
"Pure responsive layout shell with named content slots.
|
||||
@ -699,7 +777,7 @@ slot has a reusable built-in fallback for direct composition."
|
||||
:view
|
||||
(column
|
||||
:class "research-shelf-shell" :width '(viewport)
|
||||
:height 'auto :min-height '(viewport-height)
|
||||
:height '(viewport-height)
|
||||
:color (etaf-theme-token :ink)
|
||||
:bgcolor (etaf-theme-token :paper)
|
||||
(slot :name 'header
|
||||
@ -759,21 +837,16 @@ slot has a reusable built-in fallback for direct composition."
|
||||
(etaf-provide 'research-shelf-footer-spec
|
||||
(etaf-playground-static-child
|
||||
static-form 'research-shelf-footer-spec))
|
||||
(lambda ()
|
||||
(etaf-view
|
||||
;; These are real ETAF named slot inputs; the `.etaf' manifest remains
|
||||
;; inert configuration and never pretends to be View syntax.
|
||||
(etaf-research-shelf-shell
|
||||
(slot :name 'header
|
||||
(etaf-research-shelf-header))
|
||||
(slot :name 'filters
|
||||
(etaf-research-shelf-filter-rail))
|
||||
(slot :name 'library
|
||||
(etaf-research-shelf-reading-list))
|
||||
(slot :name 'detail
|
||||
(etaf-research-shelf-detail-inspector))
|
||||
(slot :name 'footer
|
||||
(etaf-research-shelf-footer)))))))
|
||||
nil)
|
||||
:view
|
||||
;; These are real ETAF named slot inputs; the `.etaf' manifest remains inert
|
||||
;; configuration and never pretends to be View syntax.
|
||||
(etaf-research-shelf-shell
|
||||
(slot :name 'header (etaf-research-shelf-header))
|
||||
(slot :name 'filters (etaf-research-shelf-filter-rail))
|
||||
(slot :name 'library (etaf-research-shelf-reading-list))
|
||||
(slot :name 'detail (etaf-research-shelf-detail-inspector))
|
||||
(slot :name 'footer (etaf-research-shelf-footer))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; ROOT / PLAYGROUND REGISTRATION
|
||||
|
||||
374
examples/task-workbench.el
Normal file
374
examples/task-workbench.el
Normal file
@ -0,0 +1,374 @@
|
||||
;;; task-workbench.el --- Composable task workbench -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; A complete public API example: reusable components and cells, controlled
|
||||
;; inputs, slots, Context, Theme, resources, lifecycle, and independent Apps.
|
||||
;; Load this module and run `wb-open'. Use `wb-close' to dispose the App.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'subr-x)
|
||||
(require 'etaf-ui)
|
||||
|
||||
;;; Data and ordinary functions
|
||||
|
||||
(defconst wb-tasks
|
||||
(append
|
||||
'((:id 1 :title "设计组件接口" :done nil)
|
||||
(:id 2 :title "编写使用示例" :done nil)
|
||||
(:id 3 :title "检查状态隔离" :done t)
|
||||
(:id 4 :title "验证键盘操作" :done nil)
|
||||
(:id 5 :title "补充文档" :done t))
|
||||
(cl-loop for id from 6 to 100
|
||||
for title = (nth (mod id 10)
|
||||
'("整理项目资料" "检查发布清单" "优化任务流程"
|
||||
"更新使用指南" "确认界面文案" "梳理组件边界"
|
||||
"复核交互细节" "清理过期任务" "完善测试记录"
|
||||
"准备版本说明"))
|
||||
collect (list :id id :title (format "%s %03d" title id)
|
||||
:done (zerop (mod id 4)))))
|
||||
"Initial rows copied independently into each workbench.")
|
||||
|
||||
(defun wb-task-id (task)
|
||||
"Return TASK's stable identity."
|
||||
(plist-get task :id))
|
||||
|
||||
(defun wb-query (data query)
|
||||
"Apply QUERY to DATA and load its first page."
|
||||
(etaf-data-set-query data query)
|
||||
(etaf-data-set-page data 1)
|
||||
(etaf-data-load data))
|
||||
|
||||
(defun wb-theme (dark)
|
||||
"Return the workbench palette for DARK or light mode."
|
||||
(if dark
|
||||
'(:ui-fg "#E5EAF3" :ui-bg "#111827" :ui-border "#38465B"
|
||||
:ui-muted-fg "#A1AEC1" :ui-success-fg "#70D6B4"
|
||||
:ui-panel-fg "#E5EAF3" :ui-panel-bg "#1B2535"
|
||||
:ui-panel-border "#38465B"
|
||||
:ui-button-primary-fg "#FFFFFF" :ui-button-primary-bg "#4869D8"
|
||||
:ui-button-primary-border "#4869D8"
|
||||
:ui-button-secondary-fg "#DCE5FF" :ui-button-secondary-bg "#2C3C60"
|
||||
:ui-button-secondary-border "#2C3C60"
|
||||
:ui-button-ghost-fg "#B8C5DA" :ui-button-ghost-bg "#1B2535"
|
||||
:ui-button-ghost-border "#38465B"
|
||||
:ui-checkbox-enabled-fg "#D6E0F1" :ui-checkbox-enabled-bg "#263449"
|
||||
:ui-checkbox-enabled-border "#465872"
|
||||
:ui-disabled-fg "#8390A5" :ui-disabled-bg "#253044"
|
||||
:ui-disabled-border "#334157"
|
||||
:ui-table-border "#38465B" :ui-table-selected-fg "#E4ECFF"
|
||||
:ui-table-selected-bg "#2C3C60" :ui-pagination-muted-fg "#A1AEC1")
|
||||
'(:ui-fg "#172033" :ui-bg "#F3F5F8" :ui-border "#D8DFE8"
|
||||
:ui-muted-fg "#647084" :ui-success-fg "#24745C"
|
||||
:ui-panel-fg "#172033" :ui-panel-bg "#FFFFFF"
|
||||
:ui-panel-border "#D8DFE8"
|
||||
:ui-button-primary-fg "#FFFFFF" :ui-button-primary-bg "#3657D6"
|
||||
:ui-button-primary-border "#3657D6"
|
||||
:ui-button-secondary-fg "#263C78" :ui-button-secondary-bg "#E8EDF8"
|
||||
:ui-button-secondary-border "#E8EDF8"
|
||||
:ui-button-ghost-fg "#526174" :ui-button-ghost-bg "#FFFFFF"
|
||||
:ui-button-ghost-border "#D8DFE8"
|
||||
:ui-checkbox-enabled-fg "#33425C" :ui-checkbox-enabled-bg "#F0F3F9"
|
||||
:ui-checkbox-enabled-border "#CDD6E4"
|
||||
:ui-disabled-fg "#8290A3" :ui-disabled-bg "#F0F2F6"
|
||||
:ui-disabled-border "#E0E5ED"
|
||||
:ui-table-border "#E2E7EF" :ui-table-selected-fg "#263C78"
|
||||
:ui-table-selected-bg "#E8EDF8" :ui-pagination-muted-fg "#647084")))
|
||||
|
||||
;;; Action: one named business operation reused by add/update/delete
|
||||
|
||||
(etaf-action-define wb-mutate (runtime data operation payload)
|
||||
(ignore runtime)
|
||||
(etaf-data-set-page data 1)
|
||||
(etaf-data-mutate data operation payload))
|
||||
|
||||
(etaf-action-define wb-focus (runtime target)
|
||||
(etaf-focus runtime target))
|
||||
|
||||
;;; Behavior: stable callbacks, additive to the Button's business action
|
||||
|
||||
(defun wb-trace-press ()
|
||||
"Report a completed control action."
|
||||
(message "动作已执行"))
|
||||
(defun wb-trace-cleanup ()
|
||||
"Report disposal of a control's reusable behavior."
|
||||
(message "按钮行为已释放"))
|
||||
(defun wb-trace-install ()
|
||||
"Return the cleanup callback for a control's reusable behavior."
|
||||
#'wb-trace-cleanup)
|
||||
|
||||
(etaf-define-behavior wb-trace ()
|
||||
(etaf-behavior-create 'wb-trace
|
||||
:on-press #'wb-trace-press
|
||||
:install #'wb-trace-install))
|
||||
|
||||
(etaf-define-component wb-button (&key label on-press disabled variant)
|
||||
:view
|
||||
(etaf-button :label label :on-press on-press :disabled disabled
|
||||
:variant variant :padding '(0 2)
|
||||
:use (list (wb-trace))))
|
||||
|
||||
;;; Stateless layout: props, default slot, named slots, scoped styles
|
||||
|
||||
(etaf-define-component wb-shell (&key title)
|
||||
:view
|
||||
(column :width '(viewport) :height '(viewport-height) :overflow 'scroll
|
||||
:item-gap 1
|
||||
:color (etaf-theme-token :ui-fg)
|
||||
:bgcolor (etaf-theme-token :ui-bg)
|
||||
(flex :width 'stretch :flex-wrap 'wrap :gap '(1 (16))
|
||||
:align-items 'center :justify-content 'space-between
|
||||
(column :flex-grow 1 :min-width 0
|
||||
(text :class "title" (expr title))
|
||||
(etaf-label :variant 'muted :text "个人任务 · 本地工作空间"))
|
||||
(flex :width 'max-content :flex-wrap 'wrap :gap '(1 (10))
|
||||
:align-items 'center
|
||||
(slot :name 'toolbar)))
|
||||
(flex :width 'stretch :flex-wrap 'wrap :gap '(1 (16))
|
||||
:align-items 'flex-start
|
||||
(slot))
|
||||
(slot :name 'footer (text "准备就绪")))
|
||||
:styles
|
||||
(styles
|
||||
("&" :padding (1 3))
|
||||
(".title" :font-weight bold)
|
||||
(".etaf-table-body" :item-gap 1)
|
||||
(".etaf-table-header" :padding (0 1))))
|
||||
|
||||
;;; Reusable cell: Context dependency + controlled Checkbox + disabled Button
|
||||
|
||||
(etaf-define-component wb-task-controls (&key task)
|
||||
:setup
|
||||
(etaf-inject 'wb-data nil t)
|
||||
:render
|
||||
(let ((data (etaf-state))
|
||||
(item task)) ; Capture this render's ordinary prop.
|
||||
(etaf-view
|
||||
(row :item-gap 10
|
||||
(etaf-checkbox
|
||||
:label "完成" :checked (plist-get item :done)
|
||||
:on-press #'wb-trace-press ; Additive; does not replace on-change.
|
||||
:on-change
|
||||
(lambda (next)
|
||||
(etaf-dispatch 'wb-mutate data 'update
|
||||
(plist-put (copy-sequence item) :done next))))
|
||||
(wb-button
|
||||
:label "删除" :variant 'ghost :disabled (not (plist-get item :done))
|
||||
:on-press
|
||||
(lambda ()
|
||||
(etaf-dispatch 'wb-mutate data 'delete (wb-task-id item))))))))
|
||||
|
||||
(defun wb-controls-cell (row)
|
||||
"Return reusable task controls for ROW at the consuming cell."
|
||||
(etaf-view (wb-task-controls :task row)))
|
||||
|
||||
(defconst wb-columns
|
||||
'((:key :title :label "任务" :width (fr 1))
|
||||
(:key :actions :label "操作" :width 22 :cell wb-controls-cell))
|
||||
"Task columns with stable identities and an ordinary View factory.")
|
||||
|
||||
;;; Dynamic composition: expr returns an ordinary Component
|
||||
|
||||
(etaf-define-component wb-task-info (&key task)
|
||||
:view
|
||||
(column
|
||||
(text :font-weight 'bold (expr (plist-get task :title)))
|
||||
(text (expr (if (plist-get task :done) "已完成" "进行中")))))
|
||||
|
||||
(etaf-define-component wb-detail ()
|
||||
:setup
|
||||
(list :data (etaf-inject 'wb-data nil t) :expanded (etaf-ref t))
|
||||
:render
|
||||
(let* ((state (etaf-state))
|
||||
(data (plist-get state :data))
|
||||
(expanded (plist-get state :expanded)))
|
||||
(etaf-view
|
||||
(etaf-panel :title "详情" :item-gap 1
|
||||
(expr
|
||||
(if-let* ((task (etaf-data-selected-item data)))
|
||||
(etaf-view (wb-task-info :task task))
|
||||
(etaf-view (text "点击任务行查看详情"))))
|
||||
(etaf-checkbox
|
||||
:label "显示说明" :checked (etaf-value expanded)
|
||||
:on-change (lambda (next) (setf (etaf-value expanded) next)))
|
||||
(box :if (etaf-value expanded) :height 3 :overflow 'scroll
|
||||
(column
|
||||
(text :for (tip '("点击行:选择任务"
|
||||
"勾选:修改完成状态"
|
||||
"完成后可以删除"
|
||||
"TAB:移动焦点"
|
||||
"RET:激活控件"))
|
||||
:key tip
|
||||
(expr tip))))))))
|
||||
|
||||
;;; Resource: explicit status/error/retry, scoped result cleanup
|
||||
;;; This is a synchronous demo loader, not a simulated asynchronous API.
|
||||
|
||||
(defun wb-service-cleanup ()
|
||||
"Report disposal of a previously loaded service result."
|
||||
(message "旧服务结果已释放"))
|
||||
|
||||
(etaf-define-component wb-service ()
|
||||
:setup
|
||||
(let* ((fail-next (etaf-ref nil))
|
||||
(resource
|
||||
(etaf-resource
|
||||
(lambda ()
|
||||
(when (etaf-value fail-next)
|
||||
(setf (etaf-value fail-next) nil)
|
||||
(error "模拟加载失败"))
|
||||
(etaf-resource-result "服务正常"
|
||||
:cleanup #'wb-service-cleanup))
|
||||
:immediate nil)))
|
||||
(etaf-on-mounted (lambda () (etaf-resource-load resource)))
|
||||
(list :resource resource :fail-next fail-next))
|
||||
:render
|
||||
(let* ((state (etaf-state))
|
||||
(resource (plist-get state :resource))
|
||||
(fail-next (plist-get state :fail-next)))
|
||||
(etaf-view
|
||||
(etaf-panel :title "服务状态" :item-gap 1
|
||||
(text
|
||||
(expr
|
||||
(pcase (etaf-resource-status resource)
|
||||
('success (etaf-resource-value resource))
|
||||
('error (error-message-string (etaf-resource-error resource)))
|
||||
(_ "加载中…"))))
|
||||
(row :item-gap 10
|
||||
(wb-button :label "刷新 / 重试" :variant 'secondary
|
||||
:on-press (lambda () (etaf-resource-load resource)))
|
||||
(wb-button :label "模拟失败" :variant 'ghost
|
||||
:on-press
|
||||
(lambda ()
|
||||
(setf (etaf-value fail-next) t)
|
||||
(etaf-resource-load resource))))))))
|
||||
|
||||
;;; App owner: Data, refs, computed, watch, Context, Theme, lifecycle
|
||||
|
||||
(etaf-define-component wb-app ()
|
||||
:setup
|
||||
(let* ((data (etaf-data-controller
|
||||
(etaf-data-memory-source (copy-tree wb-tasks) :id-key :id)
|
||||
:page-size 10 :auto-load nil))
|
||||
(dark (etaf-ref nil))
|
||||
(next-id (etaf-ref (1+ (apply #'max (mapcar #'wb-task-id wb-tasks)))))
|
||||
(summary
|
||||
(etaf-computed
|
||||
(lambda ()
|
||||
(format "共 %d 条 · 当前页 %d 条"
|
||||
(etaf-value (etaf-data-total data))
|
||||
(length (etaf-value (etaf-data-items data))))))))
|
||||
(etaf-provide 'wb-data data)
|
||||
(etaf-theme-provide
|
||||
(etaf-computed (lambda () (wb-theme (etaf-value dark)))))
|
||||
(etaf-watch dark
|
||||
(lambda (new _old)
|
||||
(message "切换到%s主题" (if new "深色" "浅色"))))
|
||||
(etaf-on-mounted (lambda () (etaf-data-load data)))
|
||||
(etaf-on-updated (lambda () (message "工作台已更新")))
|
||||
(etaf-on-unmounted (lambda () (message "工作台已卸载")))
|
||||
;; Data, computed, watch and nested Resource scopes dispose automatically.
|
||||
(list :data data :dark dark :next-id next-id :summary summary
|
||||
:add-ref (make-symbol "wb-add")))
|
||||
:render
|
||||
(let* ((state (etaf-state))
|
||||
(data (plist-get state :data))
|
||||
(dark (plist-get state :dark))
|
||||
(next-id (plist-get state :next-id))
|
||||
(summary (plist-get state :summary))
|
||||
(add-ref (plist-get state :add-ref)))
|
||||
(etaf-view
|
||||
(wb-shell :title "任务工作台"
|
||||
(slot :name 'toolbar
|
||||
(wb-button
|
||||
:ref add-ref :label "新增任务"
|
||||
:on-press
|
||||
(lambda ()
|
||||
(let ((title (string-trim (read-string "任务名称:"))))
|
||||
(unless (string-empty-p title)
|
||||
(let ((id (etaf-value next-id)))
|
||||
(cl-incf (etaf-value next-id))
|
||||
(etaf-dispatch 'wb-mutate data 'insert
|
||||
(list :id id :title title :done nil)))))))
|
||||
(etaf-checkbox :label "深色" :checked (etaf-value dark)
|
||||
:on-change (lambda (next) (setf (etaf-value dark) next)))
|
||||
(wb-button :label "定位新增按钮" :variant 'ghost
|
||||
:on-press (lambda () (etaf-dispatch 'wb-focus add-ref))))
|
||||
|
||||
;; Parent owns each panel's participation in this Flex layout.
|
||||
(etaf-panel :title "筛选" :flex-basis 18 :flex-grow 1 :flex-shrink 0 :item-gap 1
|
||||
(flex :flex-wrap 'wrap :gap '(1 (10)) :align-items 'stretch
|
||||
(wb-button :label "全部" :width 'stretch :flex-basis 16 :flex-grow 1
|
||||
:variant (if (null (etaf-value (etaf-data-query data)))
|
||||
'secondary 'ghost)
|
||||
:on-press (lambda () (wb-query data nil)))
|
||||
(wb-button :label "未完成" :width 'stretch :flex-basis 16 :flex-grow 1
|
||||
:variant (if (equal (etaf-value (etaf-data-query data)) '(:done nil))
|
||||
'secondary 'ghost)
|
||||
:on-press (lambda () (wb-query data '(:done nil))))
|
||||
(wb-button :label "已完成" :width 'stretch :flex-basis 16 :flex-grow 1
|
||||
:variant (if (equal (etaf-value (etaf-data-query data)) '(:done t))
|
||||
'secondary 'ghost)
|
||||
:on-press (lambda () (wb-query data '(:done t))))
|
||||
(wb-button :label "搜索" :variant 'secondary :width 'stretch
|
||||
:flex-basis 16 :flex-grow 1
|
||||
:on-press (lambda () (wb-query data (read-string "搜索:"))))))
|
||||
|
||||
(etaf-panel :title "任务" :flex-grow 4 :flex-basis 64 :min-width 0
|
||||
:item-gap 1
|
||||
(etaf-data-grid
|
||||
:controller data :columns wb-columns :row-key #'wb-task-id
|
||||
:on-row-press (lambda (row) (etaf-data-select-one data (wb-task-id row)))
|
||||
:loading-label "读取任务…" :error-label "读取失败,请重新筛选"
|
||||
:empty-label "没有匹配的任务"
|
||||
(slot :name 'footer
|
||||
(etaf-pagination :controller data
|
||||
:previous-label "‹ 上一页" :next-label "下一页 ›")))
|
||||
(etaf-number-input
|
||||
:label "每页条数" :value (etaf-value (etaf-data-page-size data))
|
||||
:min 1 :max 20
|
||||
:on-change
|
||||
(lambda (next)
|
||||
(etaf-data-set-page-size data next)
|
||||
(etaf-data-set-page data 1)
|
||||
(etaf-data-load data))))
|
||||
|
||||
(flex :flex-wrap 'wrap :flex-basis 36 :flex-grow 1 :min-width 0
|
||||
:align-content 'space-between :align-items 'flex-start :gap '(1 (16))
|
||||
(wb-detail :flex-basis 28 :flex-grow 1)
|
||||
(wb-service :flex-basis 28 :flex-grow 1))
|
||||
|
||||
(slot :name 'footer
|
||||
(grid :width 'stretch :grid-template-columns '((fr 1) (fr 1)) :gap 1
|
||||
(etaf-label :variant 'muted :text (etaf-value summary))
|
||||
(etaf-label :variant 'muted
|
||||
:text "数据仅保存在当前工作台内存中")))))))
|
||||
|
||||
;;; Open / close. Each buffer gets independent App state and local refs.
|
||||
|
||||
(defun wb-open (&optional buffer-name)
|
||||
"Open an independent workbench in BUFFER-NAME or the default buffer."
|
||||
(interactive)
|
||||
(switch-to-buffer
|
||||
(etaf-mount (or buffer-name "*任务工作台*") (etaf-view (wb-app)))))
|
||||
|
||||
(defun wb-close (&optional buffer-name)
|
||||
"Dispose the workbench in BUFFER-NAME and close its buffer."
|
||||
(interactive)
|
||||
(let ((name (or buffer-name "*任务工作台*")))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer name)))
|
||||
(kill-buffer buffer))))
|
||||
|
||||
;; Usage:
|
||||
;; (wb-open)
|
||||
;; (wb-open "*另一个独立工作台*")
|
||||
;; (wb-close)
|
||||
|
||||
(provide 'task-workbench)
|
||||
;;; task-workbench.el ends here
|
||||
@ -8,7 +8,9 @@
|
||||
|
||||
;;; Code:
|
||||
(require 'cl-lib)
|
||||
(require 'json)
|
||||
(require 'seq)
|
||||
(require 'etaf)
|
||||
(require 'etaf-playground)
|
||||
(require 'etaf-performance)
|
||||
(require 'ebox-native-reflow)
|
||||
@ -19,18 +21,27 @@
|
||||
(declare-function etaf-research-shelf--ensure-database
|
||||
"../examples/research-shelf")
|
||||
|
||||
(defconst etaf-performance-evaluator-sample-count 20)
|
||||
(defconst etaf-performance-evaluator-warmup-count 5)
|
||||
(defconst etaf-performance-evaluator-sample-count 30)
|
||||
(defconst etaf-performance-evaluator-latency-budget-ms 50.0)
|
||||
(defconst etaf-performance-evaluator-scenario-budgets-ms
|
||||
'(("theme-toggle" :p95 90.0 :max 110.0)
|
||||
("post-resize-theme-toggle" :p95 90.0 :max 110.0))
|
||||
"User-approved scenario budgets overriding the default latency budget.")
|
||||
(defconst etaf-performance-evaluator-overhead-budget-ms 2.0)
|
||||
(defconst etaf-performance-evaluator-fixture-size 256)
|
||||
(defconst etaf-performance-evaluator-page-size 12)
|
||||
(defconst etaf-performance-evaluator-viewport-width 1413)
|
||||
(defconst etaf-performance-evaluator-viewport-height 62)
|
||||
|
||||
(defconst etaf-performance-evaluator--manifest-scenario-labels
|
||||
'("prepared-database-mount" "row-selection" "theme-toggle"
|
||||
"filter-query" "pagination" "progress-mutation" "focus-navigation"
|
||||
"add-reading" "reload" "viewport-resize" "post-resize-row-selection"
|
||||
"post-resize-theme-toggle" "post-resize-filter-query"
|
||||
"post-resize-pagination" "post-resize-add-reading"
|
||||
"post-resize-reload"))
|
||||
|
||||
(defvar etaf-performance-evaluator--manifest-output nil)
|
||||
(defvar etaf-performance-evaluator--manifest-scenarios nil)
|
||||
(defvar etaf-performance-evaluator--manifest-run-id nil)
|
||||
|
||||
(defun etaf-performance-evaluator--percentile (samples percentile)
|
||||
"Return nearest-rank PERCENTILE from non-empty numeric SAMPLES."
|
||||
(unless samples (error "Cannot summarize an empty performance sample"))
|
||||
@ -53,6 +64,70 @@
|
||||
(plist-get statistics :min) (plist-get statistics :p50)
|
||||
(plist-get statistics :p95) (plist-get statistics :max))))
|
||||
|
||||
(defun etaf-performance-evaluator--record-manifest-sample (label elapsed)
|
||||
"Record real ELAPSED milliseconds for manifest scenario LABEL.
|
||||
Recording occurs after the timed action returns and only when the batch
|
||||
manifest environment enabled evidence capture."
|
||||
(when (and etaf-performance-evaluator--manifest-scenarios
|
||||
(member label etaf-performance-evaluator--manifest-scenario-labels))
|
||||
(puthash label
|
||||
(cons elapsed
|
||||
(gethash label etaf-performance-evaluator--manifest-scenarios))
|
||||
etaf-performance-evaluator--manifest-scenarios)))
|
||||
|
||||
(defun etaf-performance-evaluator--manifest-data ()
|
||||
"Return the current raw latency evidence as a JSON-ready object."
|
||||
(let ((scenarios (make-hash-table :test #'equal)))
|
||||
(when etaf-performance-evaluator--manifest-scenarios
|
||||
(maphash
|
||||
(lambda (label reverse-samples)
|
||||
(let* ((samples (nreverse (copy-sequence reverse-samples)))
|
||||
(statistics (etaf-performance-evaluator--statistics samples))
|
||||
(record (make-hash-table :test #'equal)))
|
||||
(puthash "samples_ms" (vconcat samples) record)
|
||||
(puthash "p95_ms" (plist-get statistics :p95) record)
|
||||
(puthash "max_ms" (plist-get statistics :max) record)
|
||||
(puthash label record scenarios)))
|
||||
etaf-performance-evaluator--manifest-scenarios))
|
||||
(let ((manifest (make-hash-table :test #'equal)))
|
||||
(puthash "schema_version" 1 manifest)
|
||||
(puthash "kind" "latency-set" manifest)
|
||||
(puthash "set_index"
|
||||
(string-to-number (or (getenv "INCREMENTAL_SET_INDEX") ""))
|
||||
manifest)
|
||||
(puthash "independent" t manifest)
|
||||
(puthash "run_id" etaf-performance-evaluator--manifest-run-id manifest)
|
||||
(puthash "process_id" (emacs-pid) manifest)
|
||||
(puthash "machine_id" (system-name) manifest)
|
||||
(puthash "warmups" etaf-performance-evaluator-warmup-count manifest)
|
||||
(puthash "source_identity" (getenv "INCREMENTAL_SOURCE_IDENTITY") manifest)
|
||||
(puthash "evaluator_identity" (getenv "INCREMENTAL_EVALUATOR_IDENTITY") manifest)
|
||||
(puthash "scenarios" scenarios manifest)
|
||||
manifest)))
|
||||
|
||||
(defun etaf-performance-evaluator--write-manifest ()
|
||||
"Atomically write captured raw samples when manifest output is enabled."
|
||||
(when etaf-performance-evaluator--manifest-output
|
||||
(let* ((target (expand-file-name
|
||||
etaf-performance-evaluator--manifest-output))
|
||||
(directory (file-name-directory target))
|
||||
temporary)
|
||||
(make-directory directory t)
|
||||
(setq temporary (make-temp-file
|
||||
(expand-file-name ".incremental-perf-" directory)
|
||||
nil ".json"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-temp-file temporary
|
||||
(insert (json-serialize
|
||||
(etaf-performance-evaluator--manifest-data)
|
||||
:null-object nil :false-object :json-false))
|
||||
(insert "\n"))
|
||||
(rename-file temporary target t)
|
||||
(setq temporary nil))
|
||||
(when (and temporary (file-exists-p temporary))
|
||||
(delete-file temporary))))))
|
||||
|
||||
(defun etaf-performance-evaluator--timed-call (function)
|
||||
"Call FUNCTION and return `(ELAPSED-MS . RESULT)'."
|
||||
(let ((started (float-time)) result)
|
||||
@ -61,18 +136,22 @@
|
||||
|
||||
(cl-defun etaf-performance-evaluator--measure
|
||||
(label action verify &key setup cleanup
|
||||
(warmups etaf-performance-evaluator-warmup-count)
|
||||
(samples etaf-performance-evaluator-sample-count))
|
||||
"Warm, then measure ACTION under LABEL and verify every result.
|
||||
ACTION, VERIFY, SETUP, and CLEANUP receive an index. Warmup uses -1 and is
|
||||
never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
ACTION, VERIFY, SETUP, and CLEANUP receive an index. WARMUPS use negative
|
||||
indices and are never included in SAMPLES. ACTION's result is passed to
|
||||
VERIFY and CLEANUP."
|
||||
(let (durations)
|
||||
(when setup (funcall setup -1))
|
||||
;; Batch Emacs does not run the interactive 0.2s deferred-GC timer between
|
||||
;; synthetic inputs. Settle that idle work before, never inside, samples.
|
||||
(garbage-collect)
|
||||
(let ((result (funcall action -1)))
|
||||
(funcall verify result -1)
|
||||
(when cleanup (funcall cleanup result -1)))
|
||||
(dotimes (offset warmups)
|
||||
(let ((index (- offset warmups)))
|
||||
(when setup (funcall setup index))
|
||||
(let ((result (funcall action index)))
|
||||
(funcall verify result index)
|
||||
(when cleanup (funcall cleanup result index)))))
|
||||
(dotimes (index samples)
|
||||
(when setup (funcall setup index))
|
||||
(garbage-collect)
|
||||
@ -88,6 +167,7 @@ never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
(etaf-performance-evaluator--timed-call
|
||||
(lambda () (funcall action index)))))
|
||||
(pcase-let ((`(,elapsed . ,result) timed))
|
||||
(etaf-performance-evaluator--record-manifest-sample label elapsed)
|
||||
(funcall verify result index)
|
||||
(when cleanup (funcall cleanup result index))
|
||||
(push elapsed durations))))
|
||||
@ -153,13 +233,18 @@ never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
(let* ((power (plist-get environment :power-state))
|
||||
(source (or (plist-get power :source) 'unknown))
|
||||
(low-power (or (plist-get power :low-power-mode) 'unknown))
|
||||
(native-jit (plist-get environment :native-comp-jit-compilation))
|
||||
(load (plist-get environment :load-average)))
|
||||
(princ (format "perf-environment power-source=%s low-power-mode=%s load=%S\n"
|
||||
source low-power load))
|
||||
(princ
|
||||
(format
|
||||
"perf-environment power-source=%s low-power-mode=%s native-jit=%S load=%S\n"
|
||||
source low-power native-jit load))
|
||||
(when (eq low-power 'on)
|
||||
(error (concat "Performance evaluator requires low-power mode off; "
|
||||
"current source=%s")
|
||||
source)))
|
||||
source))
|
||||
(when native-jit
|
||||
(error "Performance evaluator requires native-comp JIT disabled")))
|
||||
environment)
|
||||
|
||||
(defun etaf-performance-evaluator--mount (buffer)
|
||||
@ -199,7 +284,7 @@ never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
(unless (eq (etaf-performance-stage-status stage) 'success)
|
||||
(error "Trace stage %s/%s finished with status %s"
|
||||
(etaf-performance-stage-category stage)
|
||||
(etaf-performance-stage-function stage)
|
||||
(etaf-performance-stage-name stage)
|
||||
(etaf-performance-stage-status stage)))))
|
||||
(let ((categories (etaf-performance-evaluator--trace-categories records)))
|
||||
(dolist (required '(runtime ebox tp sqlite))
|
||||
@ -238,53 +323,65 @@ never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
(lambda (left right)
|
||||
(> (etaf-performance-operation-elapsed left)
|
||||
(etaf-performance-operation-elapsed right)))))
|
||||
(let* ((gc-count
|
||||
(- (etaf-performance-operation-gc-count-after operation)
|
||||
(etaf-performance-operation-gc-count-before operation)))
|
||||
(gc-ms
|
||||
(* 1000.0
|
||||
(- (etaf-performance-operation-gc-elapsed-after operation)
|
||||
(etaf-performance-operation-gc-elapsed-before operation))))
|
||||
(let* ((gc-count (etaf-performance-operation-gc-count operation))
|
||||
(gc-ms (etaf-performance-operation-gc-elapsed operation))
|
||||
(stages
|
||||
(mapcar
|
||||
(lambda (entry)
|
||||
(cons (plist-get entry :category)
|
||||
(plist-get entry :exclusive-ms)))
|
||||
(etaf-performance-operation-stage-summary operation)))
|
||||
(ebox
|
||||
(plist-get (etaf-performance-operation-metadata operation) :ebox)))
|
||||
(plist-get entry :duration-ms)))
|
||||
(etaf-performance-operation-stage-summary operation))))
|
||||
(princ
|
||||
(format (concat "perf-slowest id=%d kind=%s label=%S elapsed=%.3fms "
|
||||
"gc=%d/%.3fms stages=%S ebox=%S\n")
|
||||
"gc=%d/%.3fms stages=%S\n")
|
||||
(etaf-performance-operation-id operation)
|
||||
(etaf-performance-operation-kind operation)
|
||||
(etaf-performance-operation-label operation)
|
||||
(etaf-performance-operation-elapsed operation)
|
||||
gc-count gc-ms stages ebox))))))
|
||||
gc-count gc-ms stages))
|
||||
(dolist (stage (etaf-performance-operation-stages operation))
|
||||
(princ
|
||||
(format
|
||||
"perf-stage id=%d provider=%s name=%s duration=%.3fms metadata=%S\n"
|
||||
(etaf-performance-operation-id operation)
|
||||
(etaf-performance-stage-provider stage)
|
||||
(etaf-performance-stage-name stage)
|
||||
(etaf-performance-stage-duration stage)
|
||||
(etaf-performance-stage-metadata stage))))))))
|
||||
|
||||
(defun etaf-performance-evaluator--select-ref (runtime ref)
|
||||
"Select workload row REF through RUNTIME's public event path."
|
||||
(etaf-dispatch-event runtime ref 'press)
|
||||
ref)
|
||||
|
||||
(defun etaf-performance-evaluator--measure-overhead (runtime buffer)
|
||||
"Measure trace overhead for RUNTIME with visible state in BUFFER."
|
||||
(let (signed-deltas absolute-deltas traced-samples plain-samples)
|
||||
(defun etaf-performance-evaluator--measure-overhead
|
||||
(runtime buffer &optional reset-ref)
|
||||
"Measure trace overhead for RUNTIME with visible state in BUFFER.
|
||||
RESET-REF defaults to the first Research Shelf row."
|
||||
(let ((reset-ref (or reset-ref 'research-shelf-row-1))
|
||||
signed-deltas absolute-deltas traced-samples plain-samples)
|
||||
(dotimes (index etaf-performance-evaluator-sample-count)
|
||||
(let ((order (if (zerop (% index 2)) '(nil t) '(t nil))) plain traced)
|
||||
(dolist (trace-p order)
|
||||
(etaf-performance-mode (if trace-p 1 -1))
|
||||
(if trace-p
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-performance-stop runtime))
|
||||
;; Restore equivalent state outside the timed region; AB/BA order
|
||||
;; cancels drift without retries or skipped real work.
|
||||
(garbage-collect)
|
||||
(etaf-focus runtime 'research-shelf-row-1)
|
||||
(etaf-focus runtime reset-ref)
|
||||
(when trace-p (etaf-performance-clear))
|
||||
(let ((before (etaf-focused-host-ref runtime))
|
||||
(elapsed
|
||||
(let ((gc-cons-threshold most-positive-fixnum)
|
||||
(gc-cons-percentage 1.0))
|
||||
(car (etaf-performance-evaluator--timed-call
|
||||
(lambda () (etaf-focus-next runtime)))))))
|
||||
(if trace-p
|
||||
(lambda ()
|
||||
(etaf-performance-call-operation
|
||||
runtime 'overhead "focus navigation"
|
||||
(lambda () (etaf-focus-next runtime))))
|
||||
(lambda () (etaf-focus-next runtime))))))))
|
||||
(unless (and (buffer-live-p (get-buffer buffer))
|
||||
(not (equal before
|
||||
(etaf-focused-host-ref runtime))))
|
||||
@ -298,7 +395,7 @@ never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
(push traced traced-samples)
|
||||
(push (- traced plain) signed-deltas)
|
||||
(push (abs (- traced plain)) absolute-deltas)))
|
||||
(etaf-performance-mode -1)
|
||||
(etaf-performance-stop runtime)
|
||||
(let ((signed
|
||||
(etaf-performance-evaluator--statistics (nreverse signed-deltas)))
|
||||
(jitter
|
||||
@ -319,30 +416,66 @@ never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
(defun etaf-performance-evaluator--latency-failures (results)
|
||||
"Return hard latency budget failures from scenario RESULTS."
|
||||
(cl-loop for (label . statistics) in results append
|
||||
(let* ((scenario
|
||||
(cdr (assoc label
|
||||
etaf-performance-evaluator-scenario-budgets-ms)))
|
||||
(p95-budget
|
||||
(or (plist-get scenario :p95)
|
||||
etaf-performance-evaluator-latency-budget-ms))
|
||||
(max-budget
|
||||
(or (plist-get scenario :max)
|
||||
etaf-performance-evaluator-latency-budget-ms))
|
||||
failures)
|
||||
(let (failures)
|
||||
(when (> (plist-get statistics :p95)
|
||||
p95-budget)
|
||||
etaf-performance-evaluator-latency-budget-ms)
|
||||
(push (format "%s p95 %.3fms > %.3fms" label
|
||||
(plist-get statistics :p95)
|
||||
p95-budget)
|
||||
etaf-performance-evaluator-latency-budget-ms)
|
||||
failures))
|
||||
(when (> (plist-get statistics :max)
|
||||
max-budget)
|
||||
etaf-performance-evaluator-latency-budget-ms)
|
||||
(push (format "%s max %.3fms > %.3fms" label
|
||||
(plist-get statistics :max)
|
||||
max-budget)
|
||||
etaf-performance-evaluator-latency-budget-ms)
|
||||
failures))
|
||||
(nreverse failures))))
|
||||
|
||||
(defun etaf-performance-evaluator--trace-overhead-failures (overhead)
|
||||
"Return hard trace budget failures from OVERHEAD statistics."
|
||||
(let* ((signed (plist-get overhead :signed))
|
||||
(p50 (plist-get signed :p50))
|
||||
(p95 (plist-get signed :p95))
|
||||
failures)
|
||||
(when (> (abs p50) etaf-performance-evaluator-overhead-budget-ms)
|
||||
(push (format "trace signed |p50| %.3fms > %.3fms"
|
||||
(abs p50)
|
||||
etaf-performance-evaluator-overhead-budget-ms)
|
||||
failures))
|
||||
(when (> p95 etaf-performance-evaluator-overhead-budget-ms)
|
||||
(push (format "trace signed p95 %.3fms > %.3fms"
|
||||
p95 etaf-performance-evaluator-overhead-budget-ms)
|
||||
failures))
|
||||
(nreverse failures)))
|
||||
|
||||
(defun etaf-performance-evaluator--trace-scenario
|
||||
(runtime label function &optional verify)
|
||||
"Run FUNCTION and return the one new operation for LABEL.
|
||||
RUNTIME owns the observation boundary. When VERIFY is non-nil, call it with
|
||||
FUNCTION's exact result."
|
||||
(let* ((before (etaf-performance-records))
|
||||
(before-count (length before))
|
||||
(before-id (and before
|
||||
(etaf-performance-operation-id (car before))))
|
||||
(result
|
||||
(etaf-performance-call-operation
|
||||
runtime 'trace label function))
|
||||
(after (etaf-performance-records))
|
||||
(operation (car after)))
|
||||
(unless (and operation
|
||||
(= (length after) (1+ before-count))
|
||||
(not (equal before-id
|
||||
(etaf-performance-operation-id operation)))
|
||||
(eq 'trace (etaf-performance-operation-kind operation))
|
||||
(equal label
|
||||
(etaf-performance-operation-label operation))
|
||||
(eq (etaf-performance-operation-status operation) 'success))
|
||||
(error "Trace scenario %s did not produce one successful operation"
|
||||
label))
|
||||
(when verify
|
||||
(funcall verify result))
|
||||
(list label operation result)))
|
||||
|
||||
(defun etaf-performance-evaluator--visible-item-count (buffer)
|
||||
"Return the item count rendered in BUFFER, or nil."
|
||||
(let ((text (etaf-performance-evaluator--text buffer)))
|
||||
@ -360,7 +493,7 @@ never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP."
|
||||
(label runtime buffer action verify &key setup)
|
||||
"Measure one public event ACTION under LABEL and run VERIFY.
|
||||
ACTION and VERIFY receive the sample index. Every sample must advance the
|
||||
ETAF generation and preserve the mounted surface invariant."
|
||||
ETAF generation and preserve RUNTIME's mounted surface in BUFFER."
|
||||
(etaf-performance-evaluator--measure
|
||||
label
|
||||
(lambda (index)
|
||||
@ -379,7 +512,7 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
|
||||
(defun etaf-performance-evaluator--measure-add
|
||||
(label runtime buffer)
|
||||
"Measure the public Add action under LABEL."
|
||||
"Measure RUNTIME's public Add action under LABEL in BUFFER."
|
||||
(let (before-count)
|
||||
(etaf-performance-evaluator--measure-event
|
||||
label runtime buffer
|
||||
@ -397,7 +530,7 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
|
||||
(defun etaf-performance-evaluator--measure-reload
|
||||
(label runtime buffer)
|
||||
"Measure the public Reload action under LABEL."
|
||||
"Measure RUNTIME's public Reload action under LABEL in BUFFER."
|
||||
(etaf-performance-evaluator--measure-event
|
||||
label runtime buffer
|
||||
(lambda (_index)
|
||||
@ -409,7 +542,7 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
|
||||
(defun etaf-performance-evaluator--measure-viewport-resize
|
||||
(runtime buffer)
|
||||
"Measure alternating wide/compact viewport publications for BUFFER."
|
||||
"Measure RUNTIME's alternating viewport publications for BUFFER."
|
||||
(let ((target-buffer (get-buffer buffer)))
|
||||
(unless (buffer-live-p target-buffer)
|
||||
(error "Viewport-resize: target buffer is not live"))
|
||||
@ -434,7 +567,7 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
|
||||
(defun etaf-performance-evaluator--measure-post-resize-events
|
||||
(runtime buffer)
|
||||
"Return post-resize row/theme/filter/page/Add/Reload measurements."
|
||||
"Return RUNTIME's post-resize interaction measurements for BUFFER."
|
||||
(let (results)
|
||||
(push
|
||||
(etaf-performance-evaluator--measure-event
|
||||
@ -524,14 +657,13 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
etaf-performance-evaluator-fixture-size)
|
||||
(etaf-research-shelf-page-size etaf-performance-evaluator-page-size)
|
||||
(etaf-performance-max-records 10000)
|
||||
results runtime trace-records overhead failures)
|
||||
results runtime trace-records trace-scenarios overhead failures)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-performance-evaluator--prepare-database database)
|
||||
(etaf-performance-evaluator--verify-runtime-accelerator)
|
||||
;; Latency samples measure the product path without observer work.
|
||||
;; Trace behavior and overhead have separate, explicit gates below.
|
||||
(etaf-performance-mode -1)
|
||||
(etaf-performance-clear)
|
||||
(push
|
||||
(etaf-performance-evaluator--measure
|
||||
@ -634,9 +766,13 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
(unless (etaf-performance-evaluator--visible-match-p
|
||||
buffer "Page 1 / 22")
|
||||
(etaf-dispatch-event runtime 'research-shelf-page-previous 'press))
|
||||
(let ((refs '(research-shelf-row-2 research-shelf-row-4
|
||||
research-shelf-row-5 research-shelf-row-8
|
||||
research-shelf-row-9 research-shelf-row-10)))
|
||||
;; Use one actionable reading per sample. Reusing a visible row
|
||||
;; eventually reaches 100% during the five warmups and would make a
|
||||
;; real disabled button look like a failed mutation. Moving to the
|
||||
;; target page is setup work and remains outside the timed action.
|
||||
(let ((ids '(1 4 6 9 12 13 16 17 20 21 24 25 28 29 32 33
|
||||
36 37 40 41 44 45 48 49 52 53 56 57 60 61 64
|
||||
65 68 69 72)))
|
||||
(push
|
||||
(etaf-performance-evaluator--measure
|
||||
"progress-mutation"
|
||||
@ -652,9 +788,39 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
(etaf-performance-evaluator--surface-invariant
|
||||
runtime buffer "progress-mutation"))
|
||||
:setup (lambda (index)
|
||||
(etaf-performance-evaluator--select-ref
|
||||
runtime (nth (% (1+ index) (length refs)) refs))))
|
||||
(let* ((id (nth
|
||||
(mod (+ index
|
||||
etaf-performance-evaluator-warmup-count)
|
||||
(length ids))
|
||||
ids))
|
||||
(target-page
|
||||
(1+ (/ (1- id)
|
||||
etaf-performance-evaluator-page-size)))
|
||||
(current-page
|
||||
(or (car
|
||||
(etaf-performance-evaluator--visible-page
|
||||
buffer))
|
||||
1)))
|
||||
(while (< current-page target-page)
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-page-next 'press)
|
||||
(setq current-page (1+ current-page)))
|
||||
(while (> current-page target-page)
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-page-previous 'press)
|
||||
(setq current-page (1- current-page)))
|
||||
(etaf-performance-evaluator--select-ref
|
||||
runtime (intern (format "research-shelf-row-%d" id))))))
|
||||
results))
|
||||
;; Progress setup traverses several pages to keep each action
|
||||
;; enabled. Return to the first page before the shared focus and
|
||||
;; add/reload scenarios, whose refs intentionally target page one.
|
||||
(when-let* ((page (etaf-performance-evaluator--visible-page buffer)))
|
||||
(while (> (car page) 1)
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-page-previous 'press)
|
||||
(setq page
|
||||
(etaf-performance-evaluator--visible-page buffer))))
|
||||
|
||||
(push
|
||||
(etaf-performance-evaluator--measure
|
||||
@ -691,38 +857,148 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
;; Capture one representative cross-package trace after the latency
|
||||
;; samples. This validates coverage without folding observer work
|
||||
;; into the product latency distribution.
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-evaluator--select-ref
|
||||
runtime 'research-shelf-row-1)
|
||||
(etaf-performance-evaluator--select-ref
|
||||
runtime 'research-shelf-row-2)
|
||||
(etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-filter-reading 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-filter-all 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-page-next 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-page-previous 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-add 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-reload 'press)
|
||||
(etaf-performance-evaluator--select-ref
|
||||
runtime 'research-shelf-row-2)
|
||||
(etaf-dispatch-event runtime 'research-shelf-progress 'press)
|
||||
(etaf-focus-next runtime)
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "row-selection"
|
||||
(lambda ()
|
||||
(etaf-performance-evaluator--select-ref
|
||||
runtime 'research-shelf-row-2))
|
||||
(lambda (ref)
|
||||
(unless (string-match-p
|
||||
"selected"
|
||||
(or (plist-get
|
||||
(etaf-runtime-host-props-for runtime ref) :class)
|
||||
""))
|
||||
(error "Trace row-selection product invariant failed"))))
|
||||
trace-scenarios)
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "theme-toggle"
|
||||
(lambda ()
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-theme-toggle 'press))
|
||||
(lambda (_result)
|
||||
(unless (etaf-performance-evaluator--visible-match-p
|
||||
buffer "\\(Dark theme\\|Light theme\\)")
|
||||
(error "Trace theme-toggle product invariant failed"))))
|
||||
trace-scenarios)
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "reload"
|
||||
(lambda ()
|
||||
(etaf-dispatch-event runtime 'research-shelf-reload 'press))
|
||||
(lambda (_result)
|
||||
(unless (etaf-performance-evaluator--visible-match-p
|
||||
buffer "Library reloaded")
|
||||
(error "Trace reload product invariant failed"))))
|
||||
trace-scenarios)
|
||||
(let* ((previous (ebox-buffer-update-report (get-buffer buffer)))
|
||||
(target
|
||||
(if (= (or (plist-get previous :target-viewport-width) 720)
|
||||
720)
|
||||
1413
|
||||
720)))
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "viewport-resize"
|
||||
(lambda ()
|
||||
(list target
|
||||
(ebox-rerender-buffer-with-context
|
||||
(get-buffer buffer) target 62)))
|
||||
(lambda (result)
|
||||
(let ((report (cadr result)))
|
||||
(unless (and (= (plist-get report :target-viewport-width)
|
||||
(car result))
|
||||
(plist-get report :runtime-published))
|
||||
(error
|
||||
"Trace viewport-resize product invariant failed")))))
|
||||
trace-scenarios))
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "post-resize-row-selection"
|
||||
(lambda ()
|
||||
(etaf-performance-evaluator--select-ref
|
||||
runtime 'research-shelf-row-1))
|
||||
(lambda (ref)
|
||||
(unless (string-match-p
|
||||
"selected"
|
||||
(or (plist-get
|
||||
(etaf-runtime-host-props-for runtime ref) :class)
|
||||
""))
|
||||
(error "Trace post-resize action invariant failed"))))
|
||||
trace-scenarios)
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "progress-mutation"
|
||||
(lambda ()
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-progress 'press))
|
||||
(lambda (_result)
|
||||
(unless (etaf-performance-evaluator--visible-match-p
|
||||
buffer "Progress saved")
|
||||
(error "Trace progress mutation invariant failed"))))
|
||||
trace-scenarios)
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "filter-query"
|
||||
(lambda ()
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-filter-reading 'press))
|
||||
(lambda (_result)
|
||||
(unless (etaf-performance-evaluator--visible-match-p
|
||||
buffer "Showing Reading")
|
||||
(error "Trace filter query invariant failed"))))
|
||||
trace-scenarios)
|
||||
(push
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "pagination"
|
||||
(lambda ()
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-page-next 'press))
|
||||
(lambda (_result)
|
||||
(unless (equal (car (etaf-performance-evaluator--visible-page
|
||||
buffer))
|
||||
2)
|
||||
(error "Trace pagination invariant failed"))))
|
||||
trace-scenarios)
|
||||
(dolist (scenario trace-scenarios)
|
||||
(unless (etaf-performance-operation-p (cadr scenario))
|
||||
(error "Trace scenario %s lacks a retained operation"
|
||||
(car scenario))))
|
||||
(let* ((row-operation
|
||||
(cadr (assoc "row-selection" trace-scenarios)))
|
||||
(reload-operation
|
||||
(cadr (assoc "reload" trace-scenarios)))
|
||||
(row-providers
|
||||
(mapcar #'etaf-performance-stage-provider
|
||||
(etaf-performance-operation-stages row-operation)))
|
||||
(reload-providers
|
||||
(mapcar #'etaf-performance-stage-provider
|
||||
(etaf-performance-operation-stages reload-operation))))
|
||||
(unless (equal row-providers '(tp ebox etaf))
|
||||
(error "Trace row-selection providers are %S" row-providers))
|
||||
(unless (memq 'sqlite reload-providers)
|
||||
(error "Trace reload lacks SQLite attribution")))
|
||||
(setq results (nreverse results)
|
||||
trace-records (etaf-performance-records))
|
||||
(etaf-performance-evaluator--verify-trace-records trace-records)
|
||||
(etaf-performance-evaluator--print-slowest-records trace-records)
|
||||
(etaf-performance-mode -1)
|
||||
(etaf-performance-stop runtime)
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-filter-all 'press)
|
||||
(when-let* ((page (etaf-performance-evaluator--visible-page buffer)))
|
||||
(unless (= (car page) 1)
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-page-previous 'press)))
|
||||
(setq overhead
|
||||
(etaf-performance-evaluator--measure-overhead runtime buffer)
|
||||
failures (etaf-performance-evaluator--latency-failures results))
|
||||
(when (> (abs (plist-get (plist-get overhead :signed) :p50))
|
||||
etaf-performance-evaluator-overhead-budget-ms)
|
||||
(push (format "trace signed |p50| %.3fms > %.3fms"
|
||||
(abs (plist-get (plist-get overhead :signed) :p50))
|
||||
etaf-performance-evaluator-overhead-budget-ms)
|
||||
failures))
|
||||
(setq failures
|
||||
(nconc failures
|
||||
(etaf-performance-evaluator--trace-overhead-failures
|
||||
overhead)))
|
||||
(if failures
|
||||
(let ((failure-count (length failures)))
|
||||
(princ "etaf-cross-package-perf FAIL\n")
|
||||
@ -731,19 +1007,38 @@ ETAF generation and preserve the mounted surface invariant."
|
||||
(error "Cross-package performance gate failed (%d conditions)"
|
||||
failure-count))
|
||||
(princ "etaf-cross-package-perf PASS\n") t))
|
||||
(etaf-performance-mode -1)
|
||||
(when runtime
|
||||
(etaf-performance-stop runtime))
|
||||
(etaf-performance-evaluator--close-buffer mount-buffer)
|
||||
(etaf-performance-evaluator--close-buffer buffer)
|
||||
(when (file-exists-p database) (delete-file database)))))
|
||||
|
||||
(defun etaf-performance-evaluator-batch ()
|
||||
"Batch entry point for the cross-package performance evaluator."
|
||||
(condition-case condition
|
||||
(progn (etaf-performance-evaluator-run) (kill-emacs 0))
|
||||
(error
|
||||
(princ (format "PERF-EVALUATOR-ERROR: %s\n"
|
||||
(error-message-string condition)))
|
||||
(kill-emacs 1))))
|
||||
(let* ((etaf-performance-evaluator--manifest-output
|
||||
(getenv "INCREMENTAL_PERF_MANIFEST"))
|
||||
(etaf-performance-evaluator--manifest-scenarios
|
||||
(and etaf-performance-evaluator--manifest-output
|
||||
(make-hash-table :test #'equal)))
|
||||
(etaf-performance-evaluator--manifest-run-id
|
||||
(and etaf-performance-evaluator--manifest-output
|
||||
(format "%s-%d-%06x" (format-time-string "%Y%m%dT%H%M%S%N%z")
|
||||
(emacs-pid) (random #x1000000))))
|
||||
(status
|
||||
(condition-case condition
|
||||
(progn (etaf-performance-evaluator-run) 0)
|
||||
(error
|
||||
(princ (format "PERF-EVALUATOR-ERROR: %s\n"
|
||||
(error-message-string condition)))
|
||||
1))))
|
||||
(when etaf-performance-evaluator--manifest-output
|
||||
(condition-case condition
|
||||
(etaf-performance-evaluator--write-manifest)
|
||||
(error
|
||||
(setq status 1)
|
||||
(princ (format "PERF-MANIFEST-ERROR: %s\n"
|
||||
(error-message-string condition))))))
|
||||
(kill-emacs status)))
|
||||
|
||||
(provide 'benchmark-research-shelf)
|
||||
;;; benchmark-research-shelf.el ends here
|
||||
|
||||
543
scripts/playground-gui-scenarios.el
Normal file
543
scripts/playground-gui-scenarios.el
Normal file
@ -0,0 +1,543 @@
|
||||
;;; playground-gui-scenarios.el --- Playground GUI verifier adapters -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Concrete Research Shelf and Ebox reference adapters for the generic
|
||||
;; `emacs-gui-verifier' engine. Process, recording, checkpoint ordering, and
|
||||
;; evidence lifecycle remain outside this file.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'emacs-gui-verifier)
|
||||
(require 'ebox-playground)
|
||||
(require 'etaf-playground)
|
||||
(require 'benchmark-research-shelf)
|
||||
(require 'ebox-native-reflow)
|
||||
|
||||
(defvar etaf-research-shelf-database-file)
|
||||
(defvar etaf-research-shelf-fixture-size)
|
||||
(defvar etaf-research-shelf-page-size)
|
||||
|
||||
(defun etaf-playground-gui-scenarios--report (context)
|
||||
"Return CONTEXT target's public Ebox report, or nil before mount."
|
||||
(let ((buffer (etaf-gui-verifier-context-target-buffer context)))
|
||||
(when (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer))
|
||||
(ebox-buffer-update-report buffer))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--visible-window-content-p (context)
|
||||
"Return non-nil when CONTEXT's selected window shows nonblank text."
|
||||
(let* ((buffer (etaf-gui-verifier-context-target-buffer context))
|
||||
(window (selected-window)))
|
||||
(and (buffer-live-p buffer)
|
||||
(window-live-p window)
|
||||
(eq (window-buffer window) buffer)
|
||||
(let ((start (window-start window))
|
||||
(end (window-end window t)))
|
||||
(and (integer-or-marker-p start)
|
||||
(integer-or-marker-p end)
|
||||
(< start end)
|
||||
(with-current-buffer buffer
|
||||
(string-match-p
|
||||
"[^[:space:]]"
|
||||
(buffer-substring-no-properties start end))))))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--buffer-text (context)
|
||||
"Return CONTEXT target's complete plain buffer text."
|
||||
(let ((buffer (etaf-gui-verifier-context-target-buffer context)))
|
||||
(and (buffer-live-p buffer)
|
||||
(with-current-buffer buffer
|
||||
(buffer-substring-no-properties (point-min) (point-max))))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--mounted-settled-p (context)
|
||||
"Return non-nil when CONTEXT has a mounted, visibly rendered surface."
|
||||
(let ((buffer (etaf-gui-verifier-context-target-buffer context)))
|
||||
(and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer)
|
||||
(eq (frame-parameter nil 'fullscreen)
|
||||
(etaf-gui-verifier-context-get context 'target-fullscreen))
|
||||
(etaf-playground-gui-scenarios--visible-window-content-p context))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--begin-viewport-change
|
||||
(context fullscreen &optional width height)
|
||||
"Record CONTEXT state before targeting FULLSCREEN, WIDTH, and HEIGHT."
|
||||
(when (tp-transaction-active-p)
|
||||
(error "Cannot observe committed viewport geometry inside a TP transaction"))
|
||||
(let* ((buffer (etaf-gui-verifier-context-target-buffer context))
|
||||
(revision (ebox-surface-buffer-revision buffer))
|
||||
(unchanged (and (eq (frame-parameter nil 'fullscreen) fullscreen)
|
||||
(or (not (numberp width)) (= (frame-text-width) width))
|
||||
(or (not (numberp height)) (= (frame-text-height) height)))))
|
||||
(etaf-gui-verifier-context-put
|
||||
context 'viewport-revision-before
|
||||
;; A frame already at the requested geometry has no resize to publish.
|
||||
;; Real geometry changes still require a new committed revision.
|
||||
(unless unchanged revision))
|
||||
(etaf-gui-verifier-context-put
|
||||
context 'viewport-noop-before
|
||||
(when unchanged
|
||||
(list :window (selected-window)
|
||||
:width (ebox-viewport-window-width (selected-window))
|
||||
:height (window-body-height (selected-window))
|
||||
:frame-width (frame-text-width) :frame-height (frame-text-height)
|
||||
:revision revision)))
|
||||
(etaf-gui-verifier-context-put context 'target-fullscreen fullscreen)
|
||||
(etaf-gui-verifier-context-put context 'target-frame-width width)
|
||||
(etaf-gui-verifier-context-put context 'target-frame-height height)))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--frame-target-settled-p (context)
|
||||
"Return non-nil when the selected frame reached CONTEXT's target geometry."
|
||||
(let ((fullscreen
|
||||
(etaf-gui-verifier-context-get context 'target-fullscreen))
|
||||
(width (etaf-gui-verifier-context-get context 'target-frame-width))
|
||||
(height (etaf-gui-verifier-context-get context 'target-frame-height)))
|
||||
(and (eq (frame-parameter nil 'fullscreen) fullscreen)
|
||||
(or (not (numberp width)) (= (frame-text-width) width))
|
||||
(or (not (numberp height)) (= (frame-text-height) height)))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--viewport-unchanged-p (context before)
|
||||
"Prove CONTEXT's window geometry and committed revision match BEFORE.
|
||||
This proves an unchanged action, not a new viewport publication."
|
||||
(let ((buffer (etaf-gui-verifier-context-target-buffer context)))
|
||||
(and (not (tp-transaction-active-p))
|
||||
(buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer)
|
||||
(eq (selected-window) (plist-get before :window))
|
||||
(numberp (plist-get before :width))
|
||||
(equal (ebox-viewport-window-width (selected-window))
|
||||
(plist-get before :width))
|
||||
(equal (window-body-height (selected-window)) (plist-get before :height))
|
||||
(equal (frame-text-width) (plist-get before :frame-width))
|
||||
(equal (frame-text-height) (plist-get before :frame-height))
|
||||
(numberp (plist-get before :revision))
|
||||
(> (plist-get before :revision) 0)
|
||||
(= (ebox-surface-buffer-revision buffer) (plist-get before :revision)))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--viewport-settled-p (context)
|
||||
"Return non-nil when CONTEXT's resize published or its no-op stayed unchanged."
|
||||
(let* ((before (etaf-gui-verifier-context-get context 'viewport-noop-before))
|
||||
(report (unless before (etaf-playground-gui-scenarios--report context)))
|
||||
(buffer (etaf-gui-verifier-context-target-buffer context))
|
||||
(actual (ebox-viewport-window-width (selected-window)))
|
||||
(published (or (plist-get report :target-viewport-width)
|
||||
(plist-get report :viewport-width)))
|
||||
(published-height (plist-get report :target-viewport-height))
|
||||
;; The public buffer revision is TP's committed surface revision.
|
||||
;; Ebox's runtime revision is a different, possibly lagging counter.
|
||||
(revision (plist-get report :surface-revision))
|
||||
(previous
|
||||
(etaf-gui-verifier-context-get
|
||||
context 'viewport-revision-before)))
|
||||
(and (if before
|
||||
(etaf-playground-gui-scenarios--viewport-unchanged-p context before)
|
||||
(and (not (tp-transaction-active-p))
|
||||
(buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer)
|
||||
(numberp actual)
|
||||
(numberp published)
|
||||
(= actual published)
|
||||
(numberp published-height)
|
||||
(= (window-body-height (selected-window)) published-height)
|
||||
(integerp revision)
|
||||
(integerp previous)
|
||||
(> revision previous)
|
||||
(= revision (ebox-surface-buffer-revision buffer))
|
||||
(plist-get report :runtime-published)
|
||||
(not (plist-get report :tp-scope-fallback))))
|
||||
(etaf-playground-gui-scenarios--frame-target-settled-p context)
|
||||
(etaf-playground-gui-scenarios--visible-window-content-p context))))
|
||||
|
||||
(cl-defun etaf-playground-gui-scenarios--invariants
|
||||
(context &optional (preview-p t))
|
||||
"Return shared Ebox/ETAF publication invariants for CONTEXT.
|
||||
PREVIEW-P additionally requires the display settings owned by Playground."
|
||||
(let* ((buffer (etaf-gui-verifier-context-target-buffer context))
|
||||
(mounted (and (buffer-live-p buffer)
|
||||
(ebox-surface-buffer-mounted-p buffer)))
|
||||
(canvas-settings
|
||||
(and mounted preview-p
|
||||
(with-current-buffer buffer
|
||||
(list truncate-lines fringe-indicator-alist))))
|
||||
(text (and mounted
|
||||
(with-current-buffer buffer
|
||||
(buffer-substring-no-properties
|
||||
(point-min) (point-max))))))
|
||||
(when (etaf-gui-verifier-context-get context 'expects-mounted)
|
||||
(append
|
||||
(list
|
||||
(etaf-gui-verifier-assert "surface-mounted" mounted)
|
||||
(etaf-gui-verifier-assert
|
||||
"rendered-output-nonempty" (and text (> (length text) 0)))
|
||||
(etaf-gui-verifier-assert
|
||||
"visible-output-nonempty"
|
||||
(etaf-playground-gui-scenarios--visible-window-content-p context))
|
||||
(etaf-gui-verifier-assert
|
||||
"no-render-error"
|
||||
(and text
|
||||
(not (string-match-p
|
||||
"could not render\\|runtime error\\|Wrong type argument"
|
||||
text)))))
|
||||
;; Preview chrome is owned by Playground's preview mode. A standalone
|
||||
;; App mounted with `etaf-mount' has no preview-mode contract.
|
||||
(when preview-p
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"generated-canvas-truncates-editor-lines" (car canvas-settings))
|
||||
(etaf-gui-verifier-assert
|
||||
"generated-canvas-hides-editor-edge-indicators"
|
||||
(and (not (assq 'truncation (cadr canvas-settings)))
|
||||
(not (assq 'continuation (cadr canvas-settings)))))))))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--adapter (context)
|
||||
"Return Playground-specific JSON data for CONTEXT."
|
||||
(let* ((report (etaf-playground-gui-scenarios--report context))
|
||||
(buffer (etaf-gui-verifier-context-target-buffer context))
|
||||
(runtime (and (buffer-live-p buffer)
|
||||
(etaf-runtime-for-buffer buffer)))
|
||||
(stage (plist-get report :stage)))
|
||||
(list
|
||||
(cons 'generation (if runtime (etaf-runtime-generation runtime) 0))
|
||||
(cons 'viewport_width
|
||||
(or (plist-get report :target-viewport-width)
|
||||
(plist-get report :viewport-width)
|
||||
0))
|
||||
(cons 'frame_text_width (frame-text-width))
|
||||
(cons 'frame_text_height (frame-text-height))
|
||||
(cons 'fullscreen
|
||||
(format "%s" (frame-parameter nil 'fullscreen)))
|
||||
(cons 'target_frame_width
|
||||
(or (etaf-gui-verifier-context-get
|
||||
context 'target-frame-width)
|
||||
0))
|
||||
(cons 'target_frame_height
|
||||
(or (etaf-gui-verifier-context-get
|
||||
context 'target-frame-height)
|
||||
0))
|
||||
(cons 'stage (if stage (symbol-name stage) "none")))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--resize (context width height)
|
||||
"Resize CONTEXT's selected frame to pixel WIDTH and HEIGHT."
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change
|
||||
context nil width height)
|
||||
(let ((frame-resize-pixelwise t))
|
||||
(set-frame-size nil width height t)))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--windowed-action ()
|
||||
"Return an action that leaves fullscreen and publishes its viewport."
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "leave-fullscreen"
|
||||
:execute
|
||||
(lambda (context)
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context nil)
|
||||
(set-frame-parameter nil 'fullscreen nil))
|
||||
:settled-p #'etaf-playground-gui-scenarios--viewport-settled-p
|
||||
:assertions #'etaf-playground-gui-scenarios--resize-assertions))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--resize-assertions (context)
|
||||
"Return exact viewport publication or unchanged-action assertions for CONTEXT."
|
||||
(if (etaf-gui-verifier-context-get context 'viewport-noop-before)
|
||||
(list (etaf-gui-verifier-assert
|
||||
"viewport-unchanged"
|
||||
(etaf-playground-gui-scenarios--viewport-settled-p context)))
|
||||
(let ((report (etaf-playground-gui-scenarios--report context)))
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"viewport-published"
|
||||
(etaf-playground-gui-scenarios--viewport-settled-p context))
|
||||
(etaf-gui-verifier-assert
|
||||
"resize-not-scope-fallback"
|
||||
(not (plist-get report :tp-scope-fallback)))))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--resize-action (id width height)
|
||||
"Return resize action ID for pixel WIDTH and HEIGHT."
|
||||
(etaf-gui-verifier-action-create
|
||||
:id id
|
||||
:execute (lambda (context)
|
||||
(etaf-playground-gui-scenarios--resize
|
||||
context width height))
|
||||
:settled-p #'etaf-playground-gui-scenarios--viewport-settled-p
|
||||
:assertions #'etaf-playground-gui-scenarios--resize-assertions
|
||||
:screenshot t))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--maximize-action ()
|
||||
"Return a stable full-workarea viewport publication action."
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "maximize-frame"
|
||||
:execute
|
||||
(lambda (context)
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change
|
||||
context 'maximized)
|
||||
(set-frame-parameter nil 'fullscreen 'maximized))
|
||||
:settled-p #'etaf-playground-gui-scenarios--viewport-settled-p
|
||||
:assertions #'etaf-playground-gui-scenarios--resize-assertions
|
||||
:screenshot t))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--scroll-progressed-p (context)
|
||||
"Return non-nil when CONTEXT's pending scroll changed visible state."
|
||||
(or
|
||||
(/= (etaf-gui-verifier-context-get
|
||||
context 'scroll-window-start (window-start))
|
||||
(window-start))
|
||||
(not
|
||||
(equal
|
||||
(etaf-gui-verifier-context-get context 'scroll-report)
|
||||
(etaf-playground-gui-scenarios--report context)))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--scroll-settled-p (context)
|
||||
"Return non-nil when CONTEXT's scroll progressed to visible content."
|
||||
(and (etaf-playground-gui-scenarios--scroll-progressed-p context)
|
||||
(etaf-playground-gui-scenarios--visible-window-content-p context)))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--scroll-action (id command)
|
||||
"Return Ebox page-scroll action ID using public COMMAND."
|
||||
(etaf-gui-verifier-action-create
|
||||
:id id
|
||||
:execute
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-put context 'scroll-window-start
|
||||
(window-start))
|
||||
(etaf-gui-verifier-context-put
|
||||
context 'scroll-report
|
||||
(etaf-playground-gui-scenarios--report context))
|
||||
(with-current-buffer (etaf-gui-verifier-context-target-buffer context)
|
||||
(goto-char (window-start)))
|
||||
(funcall command))
|
||||
:settled-p #'etaf-playground-gui-scenarios--scroll-settled-p
|
||||
:assertions
|
||||
(lambda (context)
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"scroll-progressed"
|
||||
(etaf-playground-gui-scenarios--scroll-progressed-p context))))
|
||||
:screenshot t))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--reset-scroll-action ()
|
||||
"Return an action that restores the outer Emacs window to its top."
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "reset-scroll"
|
||||
:execute
|
||||
(lambda (_context)
|
||||
(set-window-start (selected-window) (point-min))
|
||||
(goto-char (point-min)))
|
||||
:settled-p
|
||||
(lambda (context)
|
||||
(and (= (window-start) (point-min))
|
||||
(etaf-playground-gui-scenarios--visible-window-content-p context)))
|
||||
:assertions
|
||||
(lambda (_context)
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"scroll-reset" (= (window-start) (point-min)))))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios--research-event-action
|
||||
(id reference postcondition &optional screenshot assertion-name)
|
||||
"Return Research action ID for REFERENCE and POSTCONDITION.
|
||||
When non-nil, SCREENSHOT requests visual evidence and ASSERTION-NAME names the
|
||||
product-specific postcondition in the evidence stream."
|
||||
(etaf-gui-verifier-action-create
|
||||
:id id
|
||||
:execute
|
||||
(lambda (context)
|
||||
(let ((runtime
|
||||
(etaf-runtime-for-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context))))
|
||||
(etaf-gui-verifier-context-put
|
||||
context (intern (concat id "-generation"))
|
||||
(etaf-runtime-generation runtime))
|
||||
(with-current-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context)
|
||||
(etaf-focus runtime reference)
|
||||
(execute-kbd-macro (kbd "RET")))))
|
||||
:settled-p
|
||||
(lambda (context)
|
||||
(let ((runtime
|
||||
(etaf-runtime-for-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context))))
|
||||
(and runtime
|
||||
(> (etaf-runtime-generation runtime)
|
||||
(etaf-gui-verifier-context-get
|
||||
context (intern (concat id "-generation")) -1))
|
||||
(funcall postcondition context)
|
||||
(etaf-playground-gui-scenarios--visible-window-content-p
|
||||
context))))
|
||||
:assertions
|
||||
(lambda (context)
|
||||
(let ((runtime
|
||||
(etaf-runtime-for-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context))))
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"generation-advanced"
|
||||
(> (etaf-runtime-generation runtime)
|
||||
(etaf-gui-verifier-context-get
|
||||
context (intern (concat id "-generation")) -1)))
|
||||
(etaf-gui-verifier-assert
|
||||
"activated-host-focused"
|
||||
(equal reference (etaf-focused-host-ref runtime)))
|
||||
(etaf-gui-verifier-assert
|
||||
(or assertion-name "product-postcondition")
|
||||
(funcall postcondition context)))))
|
||||
:screenshot screenshot))
|
||||
|
||||
(defun etaf-playground-gui-scenarios-research ()
|
||||
"Return the Research Shelf GUI scenario adapter."
|
||||
(etaf-gui-verifier-scenario-create
|
||||
:name "research-shelf"
|
||||
:claim "Research Shelf mounts, resizes, scrolls, and handles interactions"
|
||||
:initialize
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-select-buffer
|
||||
context (get-buffer-create "*ETAF GUI Research Shelf*")))
|
||||
:invariants #'etaf-playground-gui-scenarios--invariants
|
||||
:adapter #'etaf-playground-gui-scenarios--adapter
|
||||
:actions
|
||||
(list
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "mount"
|
||||
:execute
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-put context 'target-fullscreen 'maximized)
|
||||
(set-frame-parameter nil 'fullscreen 'maximized)
|
||||
(etaf-playground-refresh-examples)
|
||||
(etaf-gui-verifier-context-select-buffer
|
||||
context
|
||||
(etaf-playground-open-example
|
||||
"research-shelf" "*ETAF GUI Research Shelf*"))
|
||||
(etaf-gui-verifier-context-put context 'expects-mounted t))
|
||||
:settled-p #'etaf-playground-gui-scenarios--mounted-settled-p
|
||||
:assertions
|
||||
(lambda (context)
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"runtime-mounted"
|
||||
(etaf-runtime-for-buffer
|
||||
(etaf-gui-verifier-context-target-buffer context)))))
|
||||
:screenshot t)
|
||||
(etaf-playground-gui-scenarios--windowed-action)
|
||||
(etaf-playground-gui-scenarios--resize-action
|
||||
"resize-narrow" 900 500)
|
||||
(etaf-playground-gui-scenarios--resize-action
|
||||
"resize-compact" 700 500)
|
||||
(etaf-playground-gui-scenarios--scroll-action
|
||||
"scroll-down" #'ebox-scroll-page-down)
|
||||
(etaf-playground-gui-scenarios--reset-scroll-action)
|
||||
(etaf-playground-gui-scenarios--resize-action
|
||||
"resize-wide" 1300 750)
|
||||
(etaf-playground-gui-scenarios--research-event-action
|
||||
"row-select" 'research-shelf-row-2
|
||||
(lambda (context)
|
||||
(string-match-p
|
||||
"John Berger · Book"
|
||||
(etaf-playground-gui-scenarios--buffer-text context))))
|
||||
(etaf-playground-gui-scenarios--research-event-action
|
||||
"data-mutation" 'research-shelf-progress
|
||||
(lambda (context)
|
||||
(let ((text
|
||||
(etaf-playground-gui-scenarios--buffer-text context)))
|
||||
(and (string-match-p "Progress saved" text)
|
||||
(string-match-p "10%" text))))
|
||||
t "progress-persisted")
|
||||
(etaf-playground-gui-scenarios--research-event-action
|
||||
"filter-reading" 'research-shelf-filter-reading
|
||||
(lambda (context)
|
||||
(let ((text
|
||||
(etaf-playground-gui-scenarios--buffer-text context)))
|
||||
(and (string-match-p "Showing Reading" text)
|
||||
(string-match-p "Ways of Seeing" text))))
|
||||
t "reading-filter-applied")
|
||||
(etaf-playground-gui-scenarios--research-event-action
|
||||
"theme-toggle" 'research-shelf-theme-toggle
|
||||
(lambda (context)
|
||||
(string-match-p
|
||||
"Dark theme"
|
||||
(etaf-playground-gui-scenarios--buffer-text context)))
|
||||
t)
|
||||
(etaf-playground-gui-scenarios--research-event-action
|
||||
"pagination" 'research-shelf-page-next
|
||||
(lambda (context)
|
||||
(let ((text
|
||||
(etaf-playground-gui-scenarios--buffer-text context)))
|
||||
(and (string-match-p "Page 2 /" text)
|
||||
(string-match-p "13–24 of" text))))
|
||||
t)
|
||||
(etaf-playground-gui-scenarios--maximize-action))
|
||||
:completion
|
||||
(lambda (context)
|
||||
(= (etaf-gui-verifier-context-action-count context) 13))))
|
||||
|
||||
(defun etaf-playground-gui-scenarios-ebox (scenario fixture)
|
||||
"Return one Ebox SCENARIO adapter for FIXTURE."
|
||||
(etaf-gui-verifier-scenario-create
|
||||
:name scenario
|
||||
:claim "Ebox reference mounts, follows frame resize, and scrolls"
|
||||
:initialize
|
||||
(lambda (context)
|
||||
(let ((source (find-file fixture)))
|
||||
(ebox-dsl-mode)
|
||||
(etaf-gui-verifier-context-select-buffer context source)))
|
||||
:invariants #'etaf-playground-gui-scenarios--invariants
|
||||
:adapter #'etaf-playground-gui-scenarios--adapter
|
||||
:actions
|
||||
(list
|
||||
(etaf-gui-verifier-action-create
|
||||
:id "mount"
|
||||
:execute
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-put context 'target-fullscreen 'maximized)
|
||||
(set-frame-parameter nil 'fullscreen 'maximized)
|
||||
(etaf-gui-verifier-context-select-buffer context (ebox-dsl-render))
|
||||
(etaf-gui-verifier-context-put context 'expects-mounted t))
|
||||
:settled-p #'etaf-playground-gui-scenarios--mounted-settled-p
|
||||
:assertions
|
||||
(lambda (context)
|
||||
(let ((preview (etaf-gui-verifier-context-target-buffer context)))
|
||||
(list
|
||||
(etaf-gui-verifier-assert
|
||||
"preview-mounted"
|
||||
(and (buffer-live-p preview)
|
||||
(ebox-surface-buffer-mounted-p preview))))))
|
||||
:screenshot t)
|
||||
(etaf-playground-gui-scenarios--windowed-action)
|
||||
(etaf-playground-gui-scenarios--resize-action
|
||||
"resize-narrow" 900 500)
|
||||
(etaf-playground-gui-scenarios--scroll-action
|
||||
"scroll-down" #'ebox-scroll-page-down)
|
||||
(etaf-playground-gui-scenarios--reset-scroll-action)
|
||||
(etaf-playground-gui-scenarios--resize-action
|
||||
"resize-wide" 1300 750)
|
||||
(etaf-playground-gui-scenarios--maximize-action))
|
||||
:completion
|
||||
(lambda (context)
|
||||
(= (etaf-gui-verifier-context-action-count context) 7))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-playground-gui-scenarios-run-from-environment ()
|
||||
"Build one concrete adapter from environment and run the generic engine."
|
||||
(unless (plist-get (ebox-native-reflow-runtime-report) :layout-ready-p)
|
||||
(error "Prepared Ebox native module is unavailable"))
|
||||
(let* ((scenario (or (getenv "ETAF_GUI_SCENARIO")
|
||||
(error "ETAF_GUI_SCENARIO is not configured")))
|
||||
(run-directory (or (getenv "ETAF_GUI_RUN_DIR")
|
||||
(error "ETAF_GUI_RUN_DIR is not configured")))
|
||||
(fixture (getenv "ETAF_GUI_FIXTURE"))
|
||||
(_research-fixture
|
||||
(when (equal scenario "research-shelf")
|
||||
(setq etaf-research-shelf-database-file
|
||||
(expand-file-name "research-shelf.sqlite" run-directory)
|
||||
etaf-research-shelf-fixture-size 256
|
||||
etaf-research-shelf-page-size 12)
|
||||
(when (file-exists-p etaf-research-shelf-database-file)
|
||||
(delete-file etaf-research-shelf-database-file))))
|
||||
(adapter
|
||||
(pcase scenario
|
||||
("research-shelf"
|
||||
(etaf-playground-gui-scenarios-research))
|
||||
((or "flex-reference" "grid-reference")
|
||||
(unless (and fixture (file-readable-p fixture))
|
||||
(error "ETAF_GUI_FIXTURE is not readable"))
|
||||
(etaf-playground-gui-scenarios-ebox scenario fixture))
|
||||
(_ (error "Unknown Playground GUI scenario: %s" scenario)))))
|
||||
(etaf-gui-verifier-run adapter run-directory)))
|
||||
|
||||
(provide 'playground-gui-scenarios)
|
||||
;;; playground-gui-scenarios.el ends here
|
||||
870
scripts/research-shelf-m0a-evidence.el
Normal file
870
scripts/research-shelf-m0a-evidence.el
Normal file
@ -0,0 +1,870 @@
|
||||
;;; research-shelf-m0a-evidence.el --- Research Shelf M0a evidence -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
;; Reproducible current-behavior evidence for Research Shelf. Missing target
|
||||
;; observability is represented as `observed-gap'; no target counter is
|
||||
;; synthesized from elapsed time or inferred from unrelated provider fields.
|
||||
|
||||
;;; Code:
|
||||
(require 'cl-lib)
|
||||
(require 'seq)
|
||||
(require 'subr-x)
|
||||
(require 'etaf-playground)
|
||||
(require 'etaf-performance)
|
||||
|
||||
(defvar etaf-research-shelf-database-file)
|
||||
(defvar etaf-research-shelf-fixture-size)
|
||||
(defvar etaf-research-shelf-page-size)
|
||||
(declare-function etaf-research-shelf--database "../examples/research-shelf")
|
||||
(declare-function etaf-sqlite-source "etaf-sqlite")
|
||||
|
||||
(etaf-define-component etaf-playground-m0a-dependency-fixture (&key source)
|
||||
"Observe SOURCE while retaining equal semantic output."
|
||||
:view (text (expr (progn (etaf-value source) "same"))))
|
||||
|
||||
(defvar etaf-playground-m0a--database-label nil
|
||||
"Dynamic database basename redacted from reproducible evidence.")
|
||||
|
||||
(defvar etaf-playground-m0a--property-identities nil
|
||||
"Dynamic map used to canonicalize publication-local property identities.")
|
||||
|
||||
(defvar etaf-playground-m0a--next-property-identity 0
|
||||
"Next canonical property identity in the current evidence capture.")
|
||||
|
||||
(defconst etaf-playground-m0a--package-root
|
||||
(file-name-directory
|
||||
(directory-file-name
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"Absolute etaf-playground package root used by M0a evidence.")
|
||||
|
||||
(defconst etaf-playground-m0a-evidence-schema
|
||||
'(:schema-version 1
|
||||
:evidence-mode observed-baseline
|
||||
:semantic
|
||||
(generation root-semantic-id identity-count handler-refs host-refs)
|
||||
:text-properties
|
||||
(text-sha256 property-runs-sha256 property-run-count property-names)
|
||||
:identity (range-identity-count handler-refs host-refs)
|
||||
:lifecycle (mounted unmounted buffer-killed)
|
||||
:sqlite (provider total item-ids result-sha256)
|
||||
:performance
|
||||
(operation-id operation-kind elapsed-ms generation-before generation-after
|
||||
provider-stages gc-count gc-duration-ms tp-text-operations
|
||||
tp-property-operations tp-reconciled-objects
|
||||
tp-created-objects tp-removed-objects tp-moved-objects
|
||||
tp-full-root tp-scope-count tp-scope-fallback dirty-count
|
||||
patch-count cost-class changed-sources queued-effects
|
||||
evaluated-effects turn-count turn-index turn-epoch
|
||||
semantic-nodes-visited semantic-nodes-changed
|
||||
semantic-nodes-reused
|
||||
semantic-nodes-created semantic-nodes-removed
|
||||
ebox-nodes-materialized full-path-reason
|
||||
candidate-index-node-visits candidate-index-node-copies
|
||||
candidate-effect-index-visits candidate-source-index-visits
|
||||
committed-generation-delta allocation)
|
||||
:gui-first-paint
|
||||
(:status observed-gap
|
||||
:reason no-action-start-to-forced-redisplay-complete-marker
|
||||
:activation before-performance-complete))
|
||||
"Versioned package-local M0a semantic and trace evidence schema.")
|
||||
|
||||
(defun etaf-playground-m0a--sha256 (value)
|
||||
"Return a stable SHA-256 digest for printed VALUE."
|
||||
(secure-hash 'sha256 (encode-coding-string (prin1-to-string value) 'utf-8)))
|
||||
|
||||
(defun etaf-playground-m0a--canonical-property-identity (value)
|
||||
"Return a stable encounter-order identity for publication-local VALUE."
|
||||
(or (gethash value etaf-playground-m0a--property-identities)
|
||||
(puthash value
|
||||
(prog1 etaf-playground-m0a--next-property-identity
|
||||
(setq etaf-playground-m0a--next-property-identity
|
||||
(1+ etaf-playground-m0a--next-property-identity)))
|
||||
etaf-playground-m0a--property-identities)))
|
||||
|
||||
(defun etaf-playground-m0a--canonical-paint-value (value)
|
||||
"Canonicalize publication-local TP paint slot symbols in VALUE."
|
||||
(cond
|
||||
((and (symbolp value)
|
||||
(string-match-p "\\`tp-paint-slot-[0-9]+\\'" (symbol-name value)))
|
||||
(list 'tp-paint-slot
|
||||
(etaf-playground-m0a--canonical-property-identity value)))
|
||||
((consp value)
|
||||
(cons (etaf-playground-m0a--canonical-paint-value (car value))
|
||||
(etaf-playground-m0a--canonical-paint-value (cdr value))))
|
||||
(t value)))
|
||||
|
||||
(defun etaf-playground-m0a--stable-property-value (value &optional property)
|
||||
"Return reproducible evidence for text property VALUE under PROPERTY."
|
||||
(cond
|
||||
((memq property '(ebox-content ebox-content-owner ebox-content-owners
|
||||
ebox-bb ebox-bl ebox-br ebox-bt
|
||||
ebox-pb ebox-pl ebox-pr ebox-pt
|
||||
ebox-region-id ebox-scroll-region-id))
|
||||
(if (consp value)
|
||||
(mapcar #'etaf-playground-m0a--canonical-property-identity value)
|
||||
(etaf-playground-m0a--canonical-property-identity value)))
|
||||
((eq property 'face)
|
||||
(etaf-playground-m0a--canonical-paint-value value))
|
||||
((and (symbolp value)
|
||||
(string-match-p "\\`tp-paint-slot-[0-9]+\\'" (symbol-name value)))
|
||||
(list 'tp-paint-slot
|
||||
(etaf-playground-m0a--canonical-property-identity value)))
|
||||
((stringp value)
|
||||
(if etaf-playground-m0a--database-label
|
||||
(replace-regexp-in-string
|
||||
(regexp-quote etaf-playground-m0a--database-label)
|
||||
"<database>" value t t)
|
||||
value))
|
||||
((or (null value) (numberp value) (symbolp value)) value)
|
||||
((and (consp value)
|
||||
(not (seq-some (lambda (item)
|
||||
(or (functionp item) (markerp item)
|
||||
(recordp item) (hash-table-p item)))
|
||||
(flatten-tree value))))
|
||||
value)
|
||||
((functionp value) '<function>)
|
||||
((markerp value) '<marker>)
|
||||
((hash-table-p value) '<hash-table>)
|
||||
((recordp value) (list '<record> (type-of value)))
|
||||
(t (list '<opaque> (type-of value)))))
|
||||
|
||||
(defun etaf-playground-m0a--property-runs (buffer)
|
||||
"Return normalized text-property runs from BUFFER."
|
||||
(with-current-buffer buffer
|
||||
(let ((position (point-min))
|
||||
(etaf-playground-m0a--property-identities
|
||||
(make-hash-table :test #'equal))
|
||||
(etaf-playground-m0a--next-property-identity 0)
|
||||
runs)
|
||||
(while (< position (point-max))
|
||||
(let* ((next (or (next-property-change position nil (point-max))
|
||||
(point-max)))
|
||||
(properties (text-properties-at position))
|
||||
normalized)
|
||||
(while properties
|
||||
(let ((property (pop properties))
|
||||
(value (pop properties)))
|
||||
(push (cons property
|
||||
(etaf-playground-m0a--stable-property-value
|
||||
value property))
|
||||
normalized)))
|
||||
(push (list :start (1- position) :end (1- next)
|
||||
:properties
|
||||
(sort normalized
|
||||
(lambda (left right)
|
||||
(string< (symbol-name (car left))
|
||||
(symbol-name (car right))))))
|
||||
runs)
|
||||
(setq position next)))
|
||||
(nreverse runs))))
|
||||
|
||||
(defun etaf-playground-m0a--stable-refs (entries)
|
||||
"Return stable symbol/string/number keys from public ENTRIES."
|
||||
(sort
|
||||
(delq nil
|
||||
(mapcar (lambda (entry)
|
||||
(let ((key (car entry)))
|
||||
(and (or (symbolp key) (stringp key) (numberp key)) key)))
|
||||
entries))
|
||||
(lambda (left right) (string< (format "%S" left) (format "%S" right)))))
|
||||
|
||||
(defun etaf-playground-m0a--semantic-evidence (runtime)
|
||||
"Return stable public semantic/identity evidence for RUNTIME."
|
||||
(let* ((generation (etaf-runtime-current-generation runtime))
|
||||
(identity-index (etaf-generation-identity-index generation))
|
||||
(range-count 0))
|
||||
(maphash (lambda (identity _semantic-id)
|
||||
(when (eq (car-safe identity) 'range)
|
||||
(setq range-count (1+ range-count))))
|
||||
identity-index)
|
||||
(list :generation (etaf-runtime-generation runtime)
|
||||
:root-semantic-id (etaf-generation-root-semantic-id generation)
|
||||
:identity-count (hash-table-count identity-index)
|
||||
:range-identity-count range-count
|
||||
:handler-refs
|
||||
(etaf-playground-m0a--stable-refs
|
||||
(etaf-runtime-handler-entries runtime))
|
||||
:host-refs
|
||||
(etaf-playground-m0a--stable-refs
|
||||
(etaf-runtime-host-props-entries runtime)))))
|
||||
|
||||
(defun etaf-playground-m0a--text-evidence (buffer)
|
||||
"Return stable text and text-property evidence from BUFFER."
|
||||
(with-current-buffer buffer
|
||||
(let* ((text (substring-no-properties (buffer-string)))
|
||||
(text (if etaf-playground-m0a--database-label
|
||||
(replace-regexp-in-string
|
||||
(regexp-quote etaf-playground-m0a--database-label)
|
||||
"<database>" text t t)
|
||||
text))
|
||||
(runs (etaf-playground-m0a--property-runs buffer))
|
||||
names)
|
||||
(dolist (run runs)
|
||||
(dolist (entry (plist-get run :properties))
|
||||
(cl-pushnew (car entry) names)))
|
||||
(list :text-sha256 (etaf-playground-m0a--sha256 text)
|
||||
:text-length (length text)
|
||||
:property-runs-sha256 (etaf-playground-m0a--sha256 runs)
|
||||
:property-run-count (length runs)
|
||||
:property-names
|
||||
(sort names (lambda (left right)
|
||||
(string< (symbol-name left) (symbol-name right))))))))
|
||||
|
||||
(defun etaf-playground-m0a--sqlite-evidence ()
|
||||
"Return stable Research Shelf SQLite result evidence."
|
||||
(let* ((source (etaf-sqlite-source (etaf-research-shelf--database)))
|
||||
(result (etaf-data-source-load-page source nil 1 8))
|
||||
(items (plist-get result :items))
|
||||
(canonical
|
||||
(mapcar
|
||||
(lambda (item)
|
||||
(mapcar (lambda (key) (cons key (plist-get item key)))
|
||||
'(:id :title :author :kind :status :progress :priority
|
||||
:starred :note :updated)))
|
||||
items)))
|
||||
(list :provider (plist-get source :provider)
|
||||
:total (plist-get result :total)
|
||||
:item-ids (mapcar (lambda (item) (plist-get item :id)) items)
|
||||
:result-sha256 (etaf-playground-m0a--sha256 canonical))))
|
||||
|
||||
(defun etaf-playground-m0a--metadata-field (operation keys)
|
||||
"Return `(FOUND . VALUE)' for the first of KEYS in OPERATION stages."
|
||||
(catch 'found
|
||||
(dolist (stage (etaf-performance-operation-stages operation))
|
||||
(let ((metadata (etaf-performance-stage-metadata stage)))
|
||||
(dolist (key keys)
|
||||
(when (plist-member metadata key)
|
||||
(throw 'found (cons t (plist-get metadata key)))))))
|
||||
(cons nil nil)))
|
||||
|
||||
(defun etaf-playground-m0a--observed (value)
|
||||
"Return an observed evidence cell for VALUE."
|
||||
(list :status 'observed :value value))
|
||||
|
||||
(defun etaf-playground-m0a--gap (reason)
|
||||
"Return an observed-gap evidence cell with REASON."
|
||||
(list :status 'observed-gap :reason reason))
|
||||
|
||||
(defun etaf-playground-m0a--metadata-evidence (operation name keys)
|
||||
"Return NAME evidence read from OPERATION metadata using KEYS."
|
||||
(let ((found (etaf-playground-m0a--metadata-field operation keys)))
|
||||
(cons name
|
||||
(if (car found)
|
||||
(etaf-playground-m0a--observed (cdr found))
|
||||
(etaf-playground-m0a--gap 'not-in-public-report)))))
|
||||
|
||||
(defun etaf-playground-m0a--metadata-present-p (operation keys)
|
||||
"Return non-nil when OPERATION reports a non-nil value under KEYS."
|
||||
(let ((found (etaf-playground-m0a--metadata-field operation keys)))
|
||||
(and (car found) (cdr found))))
|
||||
|
||||
(defun etaf-playground-m0a--zeroable-metadata-evidence
|
||||
(operation name keys provider)
|
||||
"Return numeric NAME from OPERATION KEYS, observing zero without PROVIDER.
|
||||
|
||||
The zero is not a synthesized span: the ordered public provider-stage list is
|
||||
the observation that PROVIDER did not participate in the operation."
|
||||
(let ((found (etaf-playground-m0a--metadata-field operation keys)))
|
||||
(cons name
|
||||
(cond
|
||||
((car found) (etaf-playground-m0a--observed (cdr found)))
|
||||
((not (seq-some
|
||||
(lambda (stage)
|
||||
(eq provider (etaf-performance-stage-provider stage)))
|
||||
(etaf-performance-operation-stages operation)))
|
||||
(append (etaf-playground-m0a--observed 0)
|
||||
(list :basis 'provider-stage-absent)))
|
||||
(t (etaf-playground-m0a--gap 'provider-stage-omits-counter))))))
|
||||
|
||||
(defun etaf-playground-m0a-performance-evidence (operation &optional allocation)
|
||||
"Return current public report fields and explicit gaps for OPERATION.
|
||||
ALLOCATION is the harness-owned before/after allocation observation."
|
||||
(append
|
||||
(list
|
||||
(cons 'operation-id
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-id operation)))
|
||||
(cons 'operation-kind
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-kind operation)))
|
||||
(cons 'elapsed-ms
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-elapsed operation)))
|
||||
(cons 'generation-before
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-generation-before operation)))
|
||||
(cons 'generation-after
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-generation-after operation)))
|
||||
(cons 'provider-stages
|
||||
(etaf-playground-m0a--observed
|
||||
(mapcar (lambda (stage)
|
||||
(cons (etaf-performance-stage-category stage)
|
||||
(etaf-performance-stage-name stage)))
|
||||
(etaf-performance-operation-stages operation))))
|
||||
(cons 'gc-count
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-gc-count operation)))
|
||||
(cons 'gc-duration-ms
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf-performance-operation-gc-elapsed operation))))
|
||||
(mapcar
|
||||
(lambda (spec)
|
||||
(etaf-playground-m0a--zeroable-metadata-evidence
|
||||
operation (car spec) (cdr spec) 'tp))
|
||||
'((tp-text-operations :tp-text-operations :text-operations)
|
||||
(tp-property-operations :tp-property-operations :property-operations)
|
||||
(tp-reconciled-objects :reconciled-objects)
|
||||
(tp-created-objects :created-objects)
|
||||
(tp-removed-objects :removed-objects)
|
||||
(tp-moved-objects :moved-objects)))
|
||||
(mapcar
|
||||
(lambda (spec)
|
||||
(etaf-playground-m0a--metadata-evidence operation (car spec) (cdr spec)))
|
||||
'((tp-full-root :tp-full-root :full-root)
|
||||
(tp-scope-count :tp-scope-count :scope-count)
|
||||
(tp-scope-fallback :tp-scope-fallback :scope-fallback)
|
||||
(dirty-count :dirty-count)
|
||||
(patch-count :patch-count)))
|
||||
(list
|
||||
(cons 'allocation
|
||||
(if allocation
|
||||
(etaf-playground-m0a--observed allocation)
|
||||
(etaf-playground-m0a--gap 'not-measured-by-caller))))))
|
||||
|
||||
(defun etaf-playground-m0a--work-probe-create ()
|
||||
"Return empty operation-local current-work instrumentation."
|
||||
(list :changed-sources (make-hash-table :test #'eql)
|
||||
:queued-effects (make-hash-table :test #'eql)
|
||||
:evaluated-effects nil :turns nil
|
||||
:semantic-nodes-visited 0 :semantic-nodes-changed 0
|
||||
:semantic-nodes-reused 0 :semantic-nodes-created 0
|
||||
:semantic-nodes-removed 0 :ebox-nodes-materialized 0
|
||||
:full-generation-p nil))
|
||||
|
||||
(defun etaf-playground-m0a--probe-increment (probe key &optional amount)
|
||||
"Increment PROBE numeric KEY by AMOUNT, defaulting to one."
|
||||
(plist-put probe key (+ (or (plist-get probe key) 0) (or amount 1))))
|
||||
|
||||
(defun etaf-playground-m0a--probe-semantic-generation
|
||||
(probe runtime base generation)
|
||||
"Record exact candidate classifications for RUNTIME into PROBE.
|
||||
BASE and GENERATION are the committed generations bracketing the candidate."
|
||||
(let ((candidate (etaf-runtime-candidate-graph-nodes runtime))
|
||||
(removed (etaf-runtime-candidate-removed-semantic-ids runtime)))
|
||||
(when (hash-table-p candidate)
|
||||
(maphash
|
||||
(lambda (semantic-id semantic)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-visited)
|
||||
(let ((old (and base
|
||||
(etaf--pvec-get
|
||||
(etaf-generation-semantic-nodes base) semantic-id))))
|
||||
(cond
|
||||
((null old)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-created))
|
||||
((equal-including-properties old semantic)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-reused))
|
||||
(t
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-changed)))))
|
||||
candidate))
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :semantic-nodes-removed (length removed))
|
||||
(when (etaf-runtime-candidate-full-rebuild-p runtime)
|
||||
(plist-put probe :full-generation-p t))
|
||||
generation))
|
||||
|
||||
(defun etaf-playground-m0a--call-with-work-probe (runtime function)
|
||||
"Call FUNCTION with operation-local current-work counters for RUNTIME.
|
||||
Return `(RESULT . PROBE)'. Counters observe existing internal boundaries;
|
||||
they neither alter scheduling nor add a product reporting contract."
|
||||
(let* ((probe (etaf-playground-m0a--work-probe-create))
|
||||
(route-scheduler (symbol-function 'etaf--runtime-route-scheduler))
|
||||
(enqueue-effect (symbol-function 'etaf--runtime-enqueue-effect))
|
||||
(record-effect (symbol-function
|
||||
'etaf--runtime-record-effect-input-version))
|
||||
(component-turn (symbol-function 'etaf--runtime-component-overlay))
|
||||
(root-turn (symbol-function 'etaf--runtime-render-root-turn))
|
||||
(build-generation (symbol-function 'etaf--runtime-build-generation))
|
||||
(text-node (symbol-function 'etaf--ebox-text-node))
|
||||
(box-node (symbol-function 'etaf--ebox-box-node))
|
||||
result)
|
||||
(cl-letf
|
||||
(((symbol-function 'etaf--runtime-route-scheduler)
|
||||
(lambda (route source)
|
||||
(when (= (etaf-runtime-route-mount-epoch route)
|
||||
(etaf-runtime-mount-epoch runtime))
|
||||
(puthash (etaf-reactive-source-id source) t
|
||||
(plist-get probe :changed-sources)))
|
||||
(funcall route-scheduler route source)))
|
||||
((symbol-function 'etaf--runtime-enqueue-effect)
|
||||
(lambda (owner effect-id)
|
||||
(let ((new-p (and (eq owner runtime)
|
||||
(not (gethash
|
||||
effect-id
|
||||
(etaf-runtime-dirty-effect-ids owner))))))
|
||||
(prog1 (funcall enqueue-effect owner effect-id)
|
||||
(when new-p
|
||||
(puthash effect-id t (plist-get probe :queued-effects)))))))
|
||||
((symbol-function 'etaf--runtime-record-effect-input-version)
|
||||
(lambda (owner generation effect-id)
|
||||
(when (eq owner runtime)
|
||||
(push effect-id (plist-get probe :evaluated-effects)))
|
||||
(funcall record-effect owner generation effect-id)))
|
||||
((symbol-function 'etaf--runtime-component-overlay)
|
||||
(lambda (owner)
|
||||
(when (eq owner runtime)
|
||||
(push (list :kind 'component-overlay
|
||||
:epoch (etaf-runtime-generation owner))
|
||||
(plist-get probe :turns)))
|
||||
(funcall component-turn owner)))
|
||||
((symbol-function 'etaf--runtime-render-root-turn)
|
||||
(lambda (owner &optional force-components-p)
|
||||
(when (eq owner runtime)
|
||||
(push (list :kind 'root
|
||||
:epoch (etaf-runtime-generation owner))
|
||||
(plist-get probe :turns)))
|
||||
(funcall root-turn owner force-components-p)))
|
||||
((symbol-function 'etaf--runtime-build-generation)
|
||||
(lambda (owner &optional base)
|
||||
(let ((generation (funcall build-generation owner base)))
|
||||
(when (eq owner runtime)
|
||||
(etaf-playground-m0a--probe-semantic-generation
|
||||
probe owner base generation))
|
||||
generation)))
|
||||
((symbol-function 'etaf--ebox-text-node)
|
||||
(lambda (&rest args)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :ebox-nodes-materialized)
|
||||
(apply text-node args)))
|
||||
((symbol-function 'etaf--ebox-box-node)
|
||||
(lambda (&rest args)
|
||||
(etaf-playground-m0a--probe-increment
|
||||
probe :ebox-nodes-materialized)
|
||||
(apply box-node args))))
|
||||
(setq result (funcall function)))
|
||||
(cons result probe)))
|
||||
|
||||
(defun etaf-playground-m0a--probe-set-value (table)
|
||||
"Return sorted numeric keys observed in hash TABLE."
|
||||
(let (values)
|
||||
(maphash (lambda (key _value) (push key values)) table)
|
||||
(sort values #'<)))
|
||||
|
||||
(defun etaf-playground-m0a--work-evidence
|
||||
(operation category probe)
|
||||
"Return M0a current-work evidence for OPERATION, CATEGORY, and PROBE."
|
||||
(let* ((turns (nreverse (plist-get probe :turns)))
|
||||
(changed
|
||||
(etaf-playground-m0a--probe-set-value
|
||||
(plist-get probe :changed-sources)))
|
||||
(queued
|
||||
(etaf-playground-m0a--probe-set-value
|
||||
(plist-get probe :queued-effects)))
|
||||
(evaluated (nreverse (plist-get probe :evaluated-effects)))
|
||||
(public-full-p
|
||||
(etaf-playground-m0a--metadata-present-p
|
||||
operation '(:tp-full-root :full-root :full-rerender)))
|
||||
(full-p (or (plist-get probe :full-generation-p) public-full-p))
|
||||
(cost-class
|
||||
(cond
|
||||
(full-p 'full)
|
||||
((eq category 'data-mutation) "scope(collection)")
|
||||
((memq category '(semantic-style viewport-scroll scroll))
|
||||
"scope(subtree/owners)")
|
||||
((or changed
|
||||
(> (etaf-performance-operation-generation-after operation)
|
||||
(etaf-performance-operation-generation-before operation)))
|
||||
'delta)
|
||||
(t 'no-op)))
|
||||
(full-reason
|
||||
(if full-p
|
||||
(or (cdr (etaf-playground-m0a--metadata-field
|
||||
operation '(:native-fallback-reason
|
||||
:full-path-reason :fallback-reason)))
|
||||
(and (plist-get probe :full-generation-p)
|
||||
'runtime-candidate-full-rebuild)
|
||||
(and public-full-p 'public-full-root-publication))
|
||||
'not-full-path)))
|
||||
(list
|
||||
(cons 'cost-class (etaf-playground-m0a--observed cost-class))
|
||||
(cons 'changed-sources
|
||||
(etaf-playground-m0a--observed
|
||||
(list :count (length changed) :ids changed)))
|
||||
(cons 'queued-effects
|
||||
(etaf-playground-m0a--observed
|
||||
(list :count (length queued) :ids queued)))
|
||||
(cons 'evaluated-effects
|
||||
(etaf-playground-m0a--observed
|
||||
(list :count (length evaluated) :ids evaluated)))
|
||||
(cons 'turn-count
|
||||
(etaf-playground-m0a--observed (length turns)))
|
||||
(cons 'turn-index
|
||||
(etaf-playground-m0a--observed
|
||||
(number-sequence 1 (length turns))))
|
||||
(cons 'turn-epoch
|
||||
(etaf-playground-m0a--observed
|
||||
(mapcar (lambda (turn) (plist-get turn :epoch)) turns)))
|
||||
(cons 'semantic-nodes-visited
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-visited)))
|
||||
(cons 'semantic-nodes-changed
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-changed)))
|
||||
(cons 'semantic-nodes-reused
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-reused)))
|
||||
(cons 'semantic-nodes-created
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-created)))
|
||||
(cons 'semantic-nodes-removed
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :semantic-nodes-removed)))
|
||||
(cons 'ebox-nodes-materialized
|
||||
(etaf-playground-m0a--observed
|
||||
(plist-get probe :ebox-nodes-materialized)))
|
||||
(cons 'full-path-reason
|
||||
(etaf-playground-m0a--observed full-reason)))))
|
||||
|
||||
(defun etaf-playground-m0a--allocation-observation (before after)
|
||||
"Return raw BEFORE/AFTER `memory-use-counts' plus numeric deltas."
|
||||
(list :api 'memory-use-counts
|
||||
:before before :after after
|
||||
:delta
|
||||
(cl-mapcar (lambda (left right)
|
||||
(and (numberp left) (numberp right) (- right left)))
|
||||
before after)))
|
||||
|
||||
(defun etaf-playground-m0a--candidate-metric-evidence
|
||||
(runtime generation-before generation-after)
|
||||
"Return candidate metrics for RUNTIME from GENERATION-BEFORE to GENERATION-AFTER."
|
||||
(let ((names '(candidate-index-node-visits candidate-index-node-copies
|
||||
candidate-effect-index-visits
|
||||
candidate-source-index-visits)))
|
||||
(if (<= generation-after generation-before)
|
||||
(mapcar (lambda (name)
|
||||
(cons name
|
||||
(etaf-playground-m0a--gap
|
||||
'no-candidate-generation-in-operation)))
|
||||
names)
|
||||
(let ((metrics (etaf-runtime-candidate-generation-metrics runtime)))
|
||||
(if (null metrics)
|
||||
(mapcar (lambda (name)
|
||||
(cons name
|
||||
(etaf-playground-m0a--gap
|
||||
'candidate-metrics-unavailable)))
|
||||
names)
|
||||
(list
|
||||
(cons 'candidate-index-node-visits
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-node-visits metrics)))
|
||||
(cons 'candidate-index-node-copies
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-node-copies metrics)))
|
||||
(cons 'candidate-effect-index-visits
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-effect-visits metrics)))
|
||||
(cons 'candidate-source-index-visits
|
||||
(etaf-playground-m0a--observed
|
||||
(etaf--generation-metrics-source-visits metrics)))))))))
|
||||
|
||||
(defun etaf-playground-m0a--trace-operation
|
||||
(runtime scenario category function)
|
||||
"Run FUNCTION as SCENARIO on RUNTIME and return CATEGORY evidence."
|
||||
(let* ((before (car (etaf-performance-records)))
|
||||
(before-id (and before (etaf-performance-operation-id before)))
|
||||
(allocation-before (memory-use-counts))
|
||||
(observed
|
||||
(etaf-playground-m0a--call-with-work-probe
|
||||
runtime
|
||||
(lambda ()
|
||||
(etaf-performance-call-operation
|
||||
runtime 'm0a-trace scenario function))))
|
||||
(result (car observed))
|
||||
(probe (cdr observed))
|
||||
(allocation-after (memory-use-counts)))
|
||||
(let ((operation (car (etaf-performance-records))))
|
||||
(unless (and operation
|
||||
(not (equal before-id
|
||||
(etaf-performance-operation-id operation)))
|
||||
(equal scenario
|
||||
(etaf-performance-operation-label operation)))
|
||||
(error "M0a scenario %s did not emit one public operation" scenario))
|
||||
(let* ((generation-before
|
||||
(etaf-performance-operation-generation-before operation))
|
||||
(generation-after
|
||||
(etaf-performance-operation-generation-after operation))
|
||||
(fields
|
||||
(append
|
||||
(etaf-playground-m0a-performance-evidence
|
||||
operation
|
||||
(etaf-playground-m0a--allocation-observation
|
||||
allocation-before allocation-after))
|
||||
(etaf-playground-m0a--work-evidence
|
||||
operation category probe)
|
||||
(etaf-playground-m0a--candidate-metric-evidence
|
||||
runtime generation-before generation-after)
|
||||
(list
|
||||
(cons 'committed-generation-delta
|
||||
(etaf-playground-m0a--observed
|
||||
(- generation-after generation-before)))))))
|
||||
(list :scenario-id (intern scenario)
|
||||
:category category
|
||||
:operation-label (etaf-performance-operation-label operation)
|
||||
:operation-kind (etaf-performance-operation-kind operation)
|
||||
:result result
|
||||
:public-report-fields fields
|
||||
:gui-first-paint
|
||||
(plist-get etaf-playground-m0a-evidence-schema
|
||||
:gui-first-paint))))))
|
||||
|
||||
(defun etaf-playground-m0a--dependency-only-scenario ()
|
||||
"Capture one equal-output dependency-only scenario."
|
||||
(let ((buffer (generate-new-buffer-name " *etaf-m0a-dependency*"))
|
||||
(source (etaf-ref 0)) runtime evidence)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(etaf-playground-m0a-dependency-fixture :source source)))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer))
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-start runtime)
|
||||
(setq evidence
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "dependency-only" 'dependency-only
|
||||
(lambda () (setf (etaf-value source) 1))))
|
||||
(etaf-performance-stop runtime))
|
||||
(when (and runtime (etaf-runtime-mounted-p runtime))
|
||||
(ignore-errors (etaf-performance-stop runtime))
|
||||
(etaf-unmount runtime))
|
||||
(when (get-buffer buffer) (kill-buffer buffer)))
|
||||
evidence))
|
||||
|
||||
(defun etaf-playground-m0a--scroll-property-position (buffer)
|
||||
"Return a BUFFER position carrying an Ebox scroll-window identity."
|
||||
(with-current-buffer buffer
|
||||
(let ((position (point-min)) found)
|
||||
(while (and (< position (point-max)) (not found))
|
||||
(when (get-text-property position 'ebox-scroll-window)
|
||||
(setq found position))
|
||||
(setq position
|
||||
(or (next-single-property-change
|
||||
position 'ebox-scroll-window nil (point-max))
|
||||
(point-max))))
|
||||
found)))
|
||||
|
||||
(defun etaf-playground-m0a--scroll-scenario ()
|
||||
"Capture one real public scroll operation."
|
||||
(let ((buffer (generate-new-buffer-name " *etaf-m0a-scroll*"))
|
||||
runtime evidence)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-view
|
||||
(column :height 3 :overflow 'scroll
|
||||
(box "line-1") (box "line-2") (box "line-3")
|
||||
(box "line-4") (box "line-5") (box "line-6"))))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer))
|
||||
(let* ((position (etaf-playground-m0a--scroll-property-position
|
||||
buffer))
|
||||
(region-id
|
||||
(and position
|
||||
(with-current-buffer buffer
|
||||
(get-text-property position 'ebox-scroll-window))))
|
||||
(before (and region-id
|
||||
(plist-get (ebox-scroll-state region-id)
|
||||
:scroll-offset))))
|
||||
(unless (and position region-id (numberp before))
|
||||
(error "M0a scroll fixture did not publish a scroll owner"))
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-start runtime)
|
||||
(setq evidence
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "public-scroll" 'scroll
|
||||
(lambda ()
|
||||
(with-current-buffer buffer
|
||||
(goto-char position)
|
||||
(ebox-scroll-down 1)))))
|
||||
(let ((after (plist-get (ebox-scroll-state region-id)
|
||||
:scroll-offset)))
|
||||
(unless (> after before)
|
||||
(error "M0a public scroll did not advance its owner"))
|
||||
(setq evidence
|
||||
(plist-put evidence :current-facts
|
||||
(list :region-id-present t
|
||||
:offset-before before
|
||||
:offset-after after))))
|
||||
(etaf-performance-stop runtime)))
|
||||
(when (and runtime (etaf-runtime-mounted-p runtime))
|
||||
(ignore-errors (etaf-performance-stop runtime))
|
||||
(etaf-unmount runtime))
|
||||
(when (get-buffer buffer) (kill-buffer buffer)))
|
||||
evidence))
|
||||
|
||||
(defun etaf-playground-m0a--load-app ()
|
||||
"Load the Research Shelf companion from the package root."
|
||||
(unless (featurep 'etaf-research-shelf)
|
||||
(load-file (expand-file-name "examples/research-shelf.el"
|
||||
etaf-playground-m0a--package-root))))
|
||||
|
||||
(defun etaf-playground-m0a-capture-baseline (database buffer)
|
||||
"Capture one complete deterministic baseline using DATABASE and BUFFER."
|
||||
(etaf-playground-m0a--load-app)
|
||||
(let ((default-directory etaf-playground-m0a--package-root)
|
||||
(etaf-research-shelf-database-file database)
|
||||
(etaf-research-shelf-fixture-size 256)
|
||||
(etaf-research-shelf-page-size 12)
|
||||
(etaf-playground-m0a--database-label
|
||||
(file-name-nondirectory database))
|
||||
runtime semantic text sqlite lifecycle result matrix)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-playground-mount-example
|
||||
buffer "research-shelf" nil
|
||||
'(:viewport-width 1400 :viewport-height 80))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer)
|
||||
lifecycle (list (list :event 'mounted
|
||||
:runtime-mounted t :buffer-live t)))
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "data-mutation" 'data-mutation
|
||||
(lambda ()
|
||||
(etaf-dispatch-event runtime 'research-shelf-progress 'press)))
|
||||
matrix)
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "semantic-style-theme" 'semantic-style
|
||||
(lambda ()
|
||||
(etaf-dispatch-event
|
||||
runtime 'research-shelf-theme-toggle 'press)))
|
||||
matrix)
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "viewport-resize" 'viewport-scroll
|
||||
(lambda ()
|
||||
(ebox-rerender-buffer-with-context (get-buffer buffer) 720 80)))
|
||||
matrix)
|
||||
(setq semantic (etaf-playground-m0a--semantic-evidence runtime)
|
||||
text (etaf-playground-m0a--text-evidence buffer)
|
||||
sqlite (etaf-playground-m0a--sqlite-evidence))
|
||||
(delete-file database)
|
||||
(let ((controller
|
||||
(etaf-data-controller
|
||||
(etaf-sqlite-source (etaf-research-shelf--database))
|
||||
:auto-load nil :name 'm0a-load-error)))
|
||||
(unwind-protect
|
||||
(push
|
||||
(etaf-playground-m0a--trace-operation
|
||||
runtime "data-load-error" 'data-load-error
|
||||
(lambda ()
|
||||
(condition-case condition
|
||||
(etaf-data-load controller)
|
||||
(error (list :condition (car condition))))))
|
||||
matrix)
|
||||
(etaf-data-stop controller)))
|
||||
(etaf-performance-stop runtime)
|
||||
(etaf-playground-close buffer)
|
||||
(setq lifecycle
|
||||
(append lifecycle
|
||||
(list (list :event 'unmounted :runtime-mounted nil)
|
||||
(list :event 'buffer-killed :buffer-live nil))))
|
||||
(setq result
|
||||
(list :schema-version 1
|
||||
:semantic semantic :text-properties text
|
||||
:identity
|
||||
(list :range-identity-count
|
||||
(plist-get semantic :range-identity-count)
|
||||
:handler-refs (plist-get semantic :handler-refs)
|
||||
:host-refs (plist-get semantic :host-refs))
|
||||
:lifecycle lifecycle :sqlite sqlite
|
||||
:performance
|
||||
(list
|
||||
:scenario-matrix
|
||||
(append
|
||||
(nreverse matrix)
|
||||
(list
|
||||
(etaf-playground-m0a--dependency-only-scenario)
|
||||
(etaf-playground-m0a--scroll-scenario))))
|
||||
:gui-first-paint
|
||||
(plist-get etaf-playground-m0a-evidence-schema
|
||||
:gui-first-paint))))
|
||||
(when (and runtime (etaf-runtime-mounted-p runtime))
|
||||
(ignore-errors (etaf-performance-stop runtime))
|
||||
(ignore-errors (etaf-unmount runtime)))
|
||||
(when (get-buffer buffer)
|
||||
(kill-buffer buffer)))
|
||||
result))
|
||||
|
||||
(defconst etaf-playground-m0a--required-work-fields
|
||||
'(cost-class changed-sources queued-effects evaluated-effects turn-count
|
||||
turn-index turn-epoch semantic-nodes-visited
|
||||
semantic-nodes-changed semantic-nodes-reused
|
||||
semantic-nodes-created semantic-nodes-removed
|
||||
ebox-nodes-materialized full-path-reason
|
||||
tp-text-operations tp-property-operations
|
||||
tp-reconciled-objects tp-created-objects
|
||||
tp-removed-objects tp-moved-objects allocation)
|
||||
"Fields that every representative M0a operation must actually observe.")
|
||||
|
||||
(defun etaf-playground-m0a--required-work-observed-p (baseline)
|
||||
"Return non-nil when every representative operation in BASELINE is observed."
|
||||
(cl-every
|
||||
(lambda (scenario)
|
||||
(let ((fields (plist-get scenario :public-report-fields)))
|
||||
(cl-every
|
||||
(lambda (name)
|
||||
(eq 'observed (plist-get (cdr (assq name fields)) :status)))
|
||||
etaf-playground-m0a--required-work-fields)))
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix)))
|
||||
|
||||
(defun etaf-playground-m0a-capture-baseline-batch ()
|
||||
"Write a fresh semantic/trace baseline and JSON metadata from environment.
|
||||
`ETAF_M0A_SEMANTIC_OUTPUT' names the raw printed Lisp artifact and
|
||||
`ETAF_M0A_SEMANTIC_METADATA' names its machine-readable summary."
|
||||
(let ((output (or (getenv "ETAF_M0A_SEMANTIC_OUTPUT")
|
||||
(error "ETAF_M0A_SEMANTIC_OUTPUT is not configured")))
|
||||
(metadata (or (getenv "ETAF_M0A_SEMANTIC_METADATA")
|
||||
(error "ETAF_M0A_SEMANTIC_METADATA is not configured")))
|
||||
(database (make-temp-file "research-shelf-m0a-batch-" nil ".sqlite"))
|
||||
(buffer (generate-new-buffer-name " *research-shelf-m0a-batch*")))
|
||||
(unwind-protect
|
||||
(let* ((baseline
|
||||
(etaf-playground-m0a-capture-baseline database buffer))
|
||||
(matrix
|
||||
(plist-get (plist-get baseline :performance)
|
||||
:scenario-matrix))
|
||||
(observed-p
|
||||
(etaf-playground-m0a--required-work-observed-p baseline)))
|
||||
(unless observed-p
|
||||
(error "M0a semantic evidence has unobserved required work"))
|
||||
(make-directory (file-name-directory output) t)
|
||||
(make-directory (file-name-directory metadata) t)
|
||||
(with-temp-file output
|
||||
(let ((print-circle t) (print-length nil) (print-level nil))
|
||||
(prin1 baseline (current-buffer))
|
||||
(insert "\n")))
|
||||
(with-temp-file metadata
|
||||
(insert
|
||||
(json-serialize
|
||||
`((schema_version . 1)
|
||||
(scenario_count . ,(length matrix))
|
||||
(required_work_fields_observed . t)
|
||||
(semantic_artifact . ,(file-name-nondirectory output)))))
|
||||
(insert "\n"))
|
||||
(princ (format "semantic-evidence-scenarios=%d required-work=observed\n"
|
||||
(length matrix)))
|
||||
t)
|
||||
(when (get-buffer buffer) (kill-buffer buffer))
|
||||
(when (file-exists-p database) (delete-file database)))))
|
||||
|
||||
(provide 'research-shelf-m0a-evidence)
|
||||
;;; research-shelf-m0a-evidence.el ends here
|
||||
127
scripts/run-gui-verification.sh
Executable file
127
scripts/run-gui-verification.sh
Executable file
@ -0,0 +1,127 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -eu
|
||||
|
||||
PLAYGROUND_SCRIPT_DIR=$(CDPATH= cd "$(dirname "$0")" && pwd)
|
||||
PLAYGROUND_DIR=$(dirname "$PLAYGROUND_SCRIPT_DIR")
|
||||
REPOS_DIR=$(dirname "$PLAYGROUND_DIR")
|
||||
GENERIC_RUNNER="$REPOS_DIR/etaf/scripts/run-emacs-gui-verification.sh"
|
||||
SCENARIO_ADAPTER="$PLAYGROUND_SCRIPT_DIR/playground-gui-scenarios.el"
|
||||
SCENARIO_ENTRY=etaf-playground-gui-scenarios-run-from-environment
|
||||
SCENARIO_INITIALIZER=""
|
||||
|
||||
usage() {
|
||||
echo "Legacy isolated GUI runner: creates a separate daemon/frame." >&2
|
||||
echo "For the existing Emacs server, see README.md GUI verification." >&2
|
||||
echo "usage:" >&2
|
||||
echo " $0 doctor" >&2
|
||||
echo " $0 review RUN_DIR" >&2
|
||||
echo " $0 all [--run-dir DIRECTORY]" >&2
|
||||
echo " $0 task-workbench|research-shelf|flex-reference|grid-reference [--run-dir DIRECTORY]" >&2
|
||||
exit 2
|
||||
}
|
||||
|
||||
doctor() {
|
||||
[ -x "$GENERIC_RUNNER" ] || {
|
||||
echo "generic GUI runner is unavailable: $GENERIC_RUNNER" >&2
|
||||
exit 1
|
||||
}
|
||||
[ -f "$SCENARIO_ADAPTER" ] || {
|
||||
echo "Playground scenario adapter is unavailable: $SCENARIO_ADAPTER" >&2
|
||||
exit 1
|
||||
}
|
||||
"$GENERIC_RUNNER" doctor
|
||||
echo "PLAYGROUND-GUI-ADAPTER DOCTOR PASS"
|
||||
}
|
||||
|
||||
parse_run_dir() {
|
||||
SCENARIO_RUN_DIR=""
|
||||
while [ "$#" -gt 0 ]; do
|
||||
case $1 in
|
||||
--run-dir)
|
||||
[ "$#" -ge 2 ] || usage
|
||||
SCENARIO_RUN_DIR=$2
|
||||
shift 2
|
||||
;;
|
||||
*) usage ;;
|
||||
esac
|
||||
done
|
||||
if [ -z "$SCENARIO_RUN_DIR" ]; then
|
||||
SCENARIO_RUN_DIR=$(mktemp -d /private/tmp/etaf-playground-gui.XXXXXX)
|
||||
else
|
||||
mkdir -p "$SCENARIO_RUN_DIR"
|
||||
fi
|
||||
}
|
||||
|
||||
prepare_fixture() {
|
||||
case $SCENARIO_NAME in
|
||||
task-workbench)
|
||||
SCENARIO_FIXTURE=""
|
||||
SCENARIO_ADAPTER="$PLAYGROUND_SCRIPT_DIR/task-workbench-gui-scenarios.el"
|
||||
SCENARIO_ENTRY=task-workbench-gui-run-from-environment
|
||||
SCENARIO_INITIALIZER=task-workbench-gui-prepare
|
||||
;;
|
||||
research-shelf)
|
||||
SCENARIO_FIXTURE=""
|
||||
;;
|
||||
flex-reference|grid-reference)
|
||||
SCENARIO_FIXTURE="$REPOS_DIR/ebox-playground/examples/$SCENARIO_NAME.ebox"
|
||||
;;
|
||||
*) usage ;;
|
||||
esac
|
||||
}
|
||||
|
||||
run_scenario() {
|
||||
echo "Legacy isolated GUI run: a separate test Emacs will be created (see README.md)." >&2
|
||||
prepare_fixture
|
||||
doctor >/dev/null
|
||||
export ETAF_GUI_SCENARIO="$SCENARIO_NAME"
|
||||
export ETAF_GUI_FIXTURE="$SCENARIO_FIXTURE"
|
||||
set --
|
||||
if [ -n "$SCENARIO_INITIALIZER" ]; then
|
||||
set -- --initialize-function "$SCENARIO_INITIALIZER"
|
||||
fi
|
||||
"$GENERIC_RUNNER" run "$SCENARIO_ADAPTER" "$SCENARIO_ENTRY" \
|
||||
"$@" \
|
||||
--run-dir "$SCENARIO_RUN_DIR" \
|
||||
--load-path "$REPOS_DIR/tp" \
|
||||
--load-path "$REPOS_DIR/ecss" \
|
||||
--load-path "$REPOS_DIR/ebox" \
|
||||
--load-path "$REPOS_DIR/etaf" \
|
||||
--load-path "$REPOS_DIR/etaf-ui" \
|
||||
--load-path "$REPOS_DIR/etaf-db" \
|
||||
--load-path "$REPOS_DIR/ebox-playground" \
|
||||
--load-path "$REPOS_DIR/ebox-playground/scripts" \
|
||||
--load-path "$PLAYGROUND_DIR" \
|
||||
--load-path "$PLAYGROUND_SCRIPT_DIR" \
|
||||
--load-path "$PLAYGROUND_DIR/examples"
|
||||
}
|
||||
|
||||
[ "$#" -ge 1 ] || usage
|
||||
COMMAND=$1
|
||||
shift
|
||||
|
||||
case $COMMAND in
|
||||
doctor)
|
||||
[ "$#" -eq 0 ] || usage
|
||||
doctor
|
||||
;;
|
||||
review)
|
||||
[ "$#" -eq 1 ] || usage
|
||||
"$GENERIC_RUNNER" review "$1"
|
||||
;;
|
||||
all)
|
||||
parse_run_dir "$@"
|
||||
ALL_RUN_ROOT=$SCENARIO_RUN_DIR
|
||||
for SCENARIO_ITEM in task-workbench research-shelf flex-reference grid-reference; do
|
||||
"$0" "$SCENARIO_ITEM" --run-dir "$ALL_RUN_ROOT/$SCENARIO_ITEM"
|
||||
done
|
||||
echo "PLAYGROUND-GUI ALL CAPTURED root=$ALL_RUN_ROOT"
|
||||
;;
|
||||
task-workbench|research-shelf|flex-reference|grid-reference)
|
||||
SCENARIO_NAME=$COMMAND
|
||||
parse_run_dir "$@"
|
||||
run_scenario
|
||||
;;
|
||||
*) usage ;;
|
||||
esac
|
||||
630
scripts/task-workbench-gui-scenarios.el
Normal file
630
scripts/task-workbench-gui-scenarios.el
Normal file
@ -0,0 +1,630 @@
|
||||
;;; task-workbench-gui-scenarios.el --- Workbench GUI acceptance -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; A concrete adapter for the existing temporal GUI verifier. Keyboard
|
||||
;; actions traverse TAB and RET bindings; mouse actions use actual displayed
|
||||
;; positions; text entry goes through the real minibuffer. The caller connects
|
||||
;; to the existing GUI server and owns recording, screenshots, and visual review.
|
||||
;; This adapter records observations; it does not certify visual quality or
|
||||
;; turn action timings (which include user input) into performance benchmarks.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'playground-gui-scenarios)
|
||||
(require 'task-workbench
|
||||
(expand-file-name "../examples/task-workbench.el"
|
||||
(file-name-directory
|
||||
(or load-file-name
|
||||
(bound-and-true-p byte-compile-current-file)
|
||||
buffer-file-name))))
|
||||
|
||||
(defconst wb-gui--primary-name "*ETAF GUI Task Workbench*"
|
||||
"Dedicated primary buffer used throughout one Workbench verification run.")
|
||||
(defconst wb-gui--secondary-name "*ETAF GUI Independent Workbench*"
|
||||
"Dedicated buffer used to verify independent App state.")
|
||||
(defvar wb-gui--prepared-buffer nil
|
||||
"Fresh unmounted target prepared before the screen recorder starts.")
|
||||
|
||||
(defun wb-gui--configure-native ()
|
||||
"Preserve the current backend, or verify an explicitly requested module."
|
||||
(let* ((configured (getenv "EBOX_NATIVE_REFLOW_MODULE_PATH"))
|
||||
(path
|
||||
(when configured
|
||||
(when (string-empty-p configured)
|
||||
(error "EBOX_NATIVE_REFLOW_MODULE_PATH must not be empty"))
|
||||
(expand-file-name configured))))
|
||||
(when (and path (not (file-readable-p path)))
|
||||
(error "Prepared Ebox native module path is unreadable: %s" path))
|
||||
(when path
|
||||
(setq ebox-native-reflow-module-path path))
|
||||
(let* ((report (ebox-native-reflow-runtime-report))
|
||||
(loaded (plist-get report :loaded-module-path)))
|
||||
(when (and path (not (plist-get report :layout-ready-p)))
|
||||
(error "Ebox native module is unavailable at %s: %S"
|
||||
path (plist-get report :load-error)))
|
||||
(when (and path
|
||||
(not (and loaded
|
||||
(file-equal-p
|
||||
(if (file-directory-p path)
|
||||
(file-name-directory loaded) loaded)
|
||||
path))))
|
||||
(error "Loaded Ebox module differs from configured path: %s / %s"
|
||||
loaded path))
|
||||
(when loaded
|
||||
(message "Workbench GUI native module: %s (SHA256 %s)"
|
||||
loaded (plist-get report :loaded-module-hash)))
|
||||
report)))
|
||||
|
||||
(defun wb-gui--redisplay-for-geometry ()
|
||||
"Clear this adapter's native diagnostic and paint before measuring geometry."
|
||||
(when-let* ((diagnostic (current-message))
|
||||
((string-prefix-p "Workbench GUI native module: " diagnostic)))
|
||||
(message nil))
|
||||
(redisplay t))
|
||||
|
||||
;;;###autoload
|
||||
(defun task-workbench-gui-prepare (&optional foreground)
|
||||
"Prepare a fresh target in the existing frame before recording starts.
|
||||
Preserve application focus unless FOREGROUND is explicitly non-nil."
|
||||
(unless (display-graphic-p) (error "Workbench acceptance needs GUI Emacs"))
|
||||
(when (or (get-buffer wb-gui--primary-name)
|
||||
(get-buffer wb-gui--secondary-name))
|
||||
(error "Workbench verification requires fresh dedicated buffers"))
|
||||
(wb-gui--configure-native)
|
||||
(setq wb-gui--prepared-buffer (get-buffer-create wb-gui--primary-name))
|
||||
(with-current-buffer wb-gui--prepared-buffer
|
||||
(insert "任务工作台\n")
|
||||
(goto-char (point-min)))
|
||||
(switch-to-buffer wb-gui--prepared-buffer)
|
||||
(delete-other-windows)
|
||||
(when foreground (select-frame-set-input-focus (selected-frame)))
|
||||
(wb-gui--redisplay-for-geometry)
|
||||
wb-gui--prepared-buffer)
|
||||
|
||||
(defun wb-gui--runtime (context)
|
||||
"Return the Runtime mounted in CONTEXT's target buffer."
|
||||
(etaf-runtime-for-buffer (etaf-gui-verifier-context-target-buffer context)))
|
||||
|
||||
(defun wb-gui--data (context)
|
||||
"Inspect CONTEXT's app-owned Data controller for result assertions."
|
||||
(let ((instance
|
||||
(cl-find-if
|
||||
(lambda (instance)
|
||||
(eq 'wb-app (etaf--component-spec-name
|
||||
(etaf--component-instance-spec instance))))
|
||||
(hash-table-values (etaf-runtime-instances (wb-gui--runtime context))))))
|
||||
(plist-get (etaf--component-instance-state instance) :data)))
|
||||
|
||||
(defun wb-gui--ids (context)
|
||||
"Return the currently loaded task identities in CONTEXT."
|
||||
(mapcar #'wb-task-id (etaf-value (etaf-data-items (wb-gui--data context)))))
|
||||
|
||||
(defun wb-gui--selected-id (context)
|
||||
"Return CONTEXT's selected task identity, or nil."
|
||||
(when-let* ((item (etaf-data-selected-item (wb-gui--data context))))
|
||||
(wb-task-id item)))
|
||||
|
||||
(defun wb-gui--text-p (context text)
|
||||
"Return non-nil when CONTEXT's rendered output contains TEXT."
|
||||
(string-match-p (regexp-quote text)
|
||||
(etaf-playground-gui-scenarios--buffer-text context)))
|
||||
|
||||
(defun wb-gui--control (context label &optional row-id)
|
||||
"Find CONTEXT control by aria LABEL, optionally within ROW-ID."
|
||||
(let* ((runtime (wb-gui--runtime context))
|
||||
(entries (etaf-runtime-host-props-entries runtime))
|
||||
(row (and row-id
|
||||
(cl-find-if
|
||||
(lambda (entry)
|
||||
(and (equal (plist-get (cdr entry) :key) row-id)
|
||||
(member "etaf-table-row"
|
||||
(split-string
|
||||
(or (plist-get (cdr entry) :class) "")))))
|
||||
entries)))
|
||||
(matches (cl-remove-if-not
|
||||
(lambda (entry)
|
||||
(equal label (plist-get (cdr entry) :aria-label))) entries)))
|
||||
(when row-id
|
||||
(unless row (error "No task row %S" row-id))
|
||||
(let* ((ancestries (etaf-runtime-host-ancestries
|
||||
runtime (cons (car row) (mapcar #'car matches))))
|
||||
(parent (car (gethash (car row) ancestries))))
|
||||
(setq matches
|
||||
(cl-remove-if-not
|
||||
(lambda (entry) (memq parent (gethash (car entry) ancestries)))
|
||||
matches))))
|
||||
(unless (= (length matches) 1)
|
||||
(error "Expected one control %S in row %S, got %d"
|
||||
label row-id (length matches)))
|
||||
(caar matches)))
|
||||
|
||||
(defun wb-gui--layout-snapshot (context)
|
||||
"Observe painted control pixels and semantic row bounds in CONTEXT.
|
||||
The viewport and font are part of the comparison; character offsets alone
|
||||
cannot establish that Emacs painted a control on the same visual line."
|
||||
(let* ((runtime (wb-gui--runtime context))
|
||||
(window (selected-window))
|
||||
(frame (window-frame window))
|
||||
(entries (etaf-runtime-host-props-entries runtime))
|
||||
(targets
|
||||
(append
|
||||
(list (cons "title" (wb-gui--find-text "任务工作台")))
|
||||
(mapcar
|
||||
(lambda (target)
|
||||
(cons (format "%s%s" (car target) (or (cadr target) ""))
|
||||
(etaf-host-ref-position
|
||||
runtime (wb-gui--control context (car target) (cadr target)))))
|
||||
(append
|
||||
(mapcar #'list '("新增任务" "深色" "定位新增按钮" "全部" "未完成"
|
||||
"已完成" "搜索" "每页条数 10 ✎" "显示说明"
|
||||
"刷新 / 重试" "模拟失败"))
|
||||
(mapcar (lambda (id) (list "完成" id)) (number-sequence 1 10)))))))
|
||||
(unless (and (display-graphic-p frame)
|
||||
(eq (window-buffer window) (etaf-runtime-buffer runtime)))
|
||||
(error "Pixel geometry requires the displayed Workbench GUI target"))
|
||||
(list
|
||||
:viewport (list (window-inside-pixel-edges window)
|
||||
(window-start window) (window-hscroll window))
|
||||
:font (list (format "%s" (frame-parameter frame 'font))
|
||||
(frame-char-width frame) (frame-char-height frame))
|
||||
:controls
|
||||
(mapcar
|
||||
(lambda (target)
|
||||
(let* ((position (cdr target))
|
||||
(displayed (and position (pos-visible-in-window-p position window)))
|
||||
(posn (and displayed (posn-at-point position window)))
|
||||
(xy (and posn (posn-x-y posn))))
|
||||
(unless (and (numberp (car xy)) (numberp (cdr xy)))
|
||||
(error "Theme geometry target is not visibly painted: %s" (car target)))
|
||||
(list (car target) (car xy) (cdr xy))))
|
||||
targets)
|
||||
:rows
|
||||
(mapcar
|
||||
(lambda (identity)
|
||||
(let* ((entry
|
||||
(cl-find-if
|
||||
(lambda (entry)
|
||||
(and (equal identity (plist-get (cdr entry) :key))
|
||||
(member "etaf-table-row"
|
||||
(split-string (or (plist-get (cdr entry) :class) "")))))
|
||||
entries))
|
||||
(bounds (and entry (etaf-host-ref-bounds runtime (car entry)))))
|
||||
(unless bounds (error "Theme geometry row has no live bounds: %s" identity))
|
||||
(list identity (car bounds) (cdr bounds))))
|
||||
(number-sequence 1 10)))))
|
||||
|
||||
(defun wb-gui--panel-heights (context)
|
||||
"Observe CONTEXT's four card identities and layout lines in source order."
|
||||
(let ((runtime (wb-gui--runtime context))
|
||||
panels)
|
||||
(with-current-buffer (etaf-gui-verifier-context-target-buffer context)
|
||||
(dolist (entry (etaf-runtime-host-props-entries runtime))
|
||||
(let ((class (plist-get (cdr entry) :class)))
|
||||
(when (member "etaf-panel" (if (stringp class) (split-string class) class))
|
||||
(let* ((bounds (etaf-host-ref-bounds runtime (car entry)))
|
||||
(start (car bounds))
|
||||
(end (and bounds (1- (cdr bounds)))))
|
||||
(unless (and start end)
|
||||
(error "Workbench panel has no live bounds"))
|
||||
(push (list :ref (car entry) :start start
|
||||
:lines (1+ (- (line-number-at-pos end)
|
||||
(line-number-at-pos start))))
|
||||
panels))))))
|
||||
(unless (= (length panels) 4)
|
||||
(error "Expected four Workbench panels, got %d" (length panels)))
|
||||
(sort panels (lambda (left right)
|
||||
(< (plist-get left :start) (plist-get right :start))))))
|
||||
|
||||
(defun wb-gui--help-layout-preserved-p (context expanded-p)
|
||||
"Check CONTEXT's disclosure state and unaffected card heights in layout lines.
|
||||
EXPANDED-P also requires the detail card to recover its original height.
|
||||
Native Emacs glyph rows may have different pixel heights as content moves."
|
||||
(let* ((before (etaf-gui-verifier-context-get context 'help-panels-before))
|
||||
(after (wb-gui--panel-heights context))
|
||||
(height (lambda (panels index)
|
||||
(plist-get (nth index panels) :lines))))
|
||||
(etaf-gui-verifier-context-put context 'help-panels-current after)
|
||||
(and before
|
||||
(eq expanded-p (and (wb-gui--text-p context "点击行:选择任务") t))
|
||||
(equal (mapcar (lambda (panel) (plist-get panel :ref)) before)
|
||||
(mapcar (lambda (panel) (plist-get panel :ref)) after))
|
||||
(cl-every (lambda (index)
|
||||
(= (funcall height before index)
|
||||
(funcall height after index)))
|
||||
'(0 1 3))
|
||||
(if expanded-p
|
||||
(= (funcall height before 2) (funcall height after 2))
|
||||
(< (funcall height after 2) (funcall height before 2))))))
|
||||
|
||||
(defun wb-gui--capture-theme-baseline (context)
|
||||
"Capture CONTEXT's initial geometry once it survives another paint turn."
|
||||
(when (etaf-gui-verifier-context-get context 'light-layout)
|
||||
(error "Initial theme geometry must only be captured once"))
|
||||
(wb-gui--redisplay-for-geometry)
|
||||
(let ((previous (wb-gui--layout-snapshot context))
|
||||
(deadline (+ (float-time) 5.0))
|
||||
stable)
|
||||
(while (not stable)
|
||||
(when (>= (float-time) deadline)
|
||||
(error "Initial Workbench geometry did not settle before theme input"))
|
||||
(sit-for 0.05)
|
||||
(redisplay t)
|
||||
(let ((current (wb-gui--layout-snapshot context)))
|
||||
(setq stable (equal previous current)
|
||||
previous current)))
|
||||
(etaf-gui-verifier-context-put context 'light-layout previous)))
|
||||
|
||||
(defun wb-gui--theme-layout-preserved-p (context)
|
||||
"Compare CONTEXT's current painted geometry with its settled light theme."
|
||||
(let ((current (wb-gui--layout-snapshot context)))
|
||||
(etaf-gui-verifier-context-put context 'theme-layout-current current)
|
||||
(equal (etaf-gui-verifier-context-get context 'light-layout) current)))
|
||||
|
||||
(defun wb-gui--root-background-p (context color)
|
||||
"Check that CONTEXT's painted root uses COLOR in its buffer face remap."
|
||||
(with-current-buffer (etaf-gui-verifier-context-target-buffer context)
|
||||
(let* ((face (get-text-property (point-min) 'face))
|
||||
(mapping (and (symbolp face) (assq face face-remapping-alist))))
|
||||
(and mapping
|
||||
(cl-some (lambda (attrs)
|
||||
(and (listp attrs)
|
||||
(equal color (plist-get attrs :background))))
|
||||
(cdr mapping))))))
|
||||
|
||||
(defun wb-gui--tab-to (context ref)
|
||||
"Reach REF in CONTEXT by executing actual TAB key bindings."
|
||||
(let* ((runtime (wb-gui--runtime context))
|
||||
(limit (1+ (length (etaf-runtime-host-props-entries runtime))))
|
||||
(at-target
|
||||
(lambda ()
|
||||
(and (equal ref (etaf-focused-host-ref runtime))
|
||||
(equal (point) (etaf-host-ref-position runtime ref))))))
|
||||
(unless (eq (current-buffer) (etaf-runtime-buffer runtime))
|
||||
(error "Keyboard input target drifted from the Workbench buffer"))
|
||||
(while (and (> limit 0) (not (funcall at-target)))
|
||||
(execute-kbd-macro (kbd "TAB"))
|
||||
(cl-decf limit))
|
||||
(unless (funcall at-target)
|
||||
(error "TAB cannot reach the expected control"))))
|
||||
|
||||
(defun wb-gui--press (context label &optional row-id)
|
||||
"Use TAB and RET to activate LABEL within CONTEXT's optional ROW-ID."
|
||||
(wb-gui--tab-to context (wb-gui--control context label row-id))
|
||||
(execute-kbd-macro (kbd "RET")))
|
||||
|
||||
(defun wb-gui--visit-next-page (context)
|
||||
"Advance CONTEXT one page and retain the complete visited task sequence."
|
||||
(let ((visited (etaf-gui-verifier-context-get
|
||||
context 'visited-task-ids (wb-gui--ids context))))
|
||||
(wb-gui--press context "Next page")
|
||||
(setq visited (append visited (wb-gui--ids context)))
|
||||
(etaf-gui-verifier-context-put context 'visited-task-ids visited)
|
||||
(etaf-gui-verifier-context-put context 'visited-tasks (length visited))))
|
||||
|
||||
(defun wb-gui--enter (context label text)
|
||||
"Activate LABEL and type TEXT through the actual minibuffer in CONTEXT."
|
||||
(let (received)
|
||||
(let ((minibuffer-exit-hook
|
||||
(cons (lambda ()
|
||||
(setq received (minibuffer-contents-no-properties)))
|
||||
minibuffer-exit-hook)))
|
||||
(minibuffer-with-setup-hook
|
||||
(lambda ()
|
||||
;; The recursive input loop starts after setup hooks return.
|
||||
;; Queue real input events; RET during setup has no exit target.
|
||||
(setq unread-command-events
|
||||
(append (listify-key-sequence (vconcat text (kbd "RET")))
|
||||
unread-command-events)))
|
||||
(wb-gui--press context label)))
|
||||
(unless (equal received text)
|
||||
(error "Minibuffer did not receive the expected keyboard input"))))
|
||||
|
||||
(defun wb-gui--mouse-at (position)
|
||||
"Click the actual visible buffer POSITION using its displayed event data."
|
||||
(redisplay t)
|
||||
(let ((position-data (posn-at-point position (selected-window))))
|
||||
(unless (and position-data (pos-visible-in-window-p position))
|
||||
(error "Mouse target is not currently displayed: %S" position))
|
||||
(execute-kbd-macro (vector (list 'mouse-1 position-data)))))
|
||||
|
||||
(defun wb-gui--click (context label &optional row-id)
|
||||
"Click LABEL at its rendered position within CONTEXT's optional ROW-ID."
|
||||
(let* ((runtime (wb-gui--runtime context))
|
||||
(ref (wb-gui--control context label row-id))
|
||||
(position (etaf-host-ref-position runtime ref)))
|
||||
(unless position (error "Control %S has no live bounds" label))
|
||||
(wb-gui--mouse-at position)))
|
||||
|
||||
(defun wb-gui--find-text (text)
|
||||
"Return a buffer position inside visible TEXT or signal a missing target."
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(unless (search-forward text nil t)
|
||||
(error "Rendered text target is absent: %S" text))
|
||||
(- (point) (length text))))
|
||||
|
||||
(defun wb-gui--action (id execute predicate)
|
||||
"Create action ID with EXECUTE and a persistent product PREDICATE."
|
||||
(etaf-gui-verifier-action-create
|
||||
:id id :execute execute :screenshot t
|
||||
:settled-p
|
||||
(lambda (context)
|
||||
(and (etaf-playground-gui-scenarios--mounted-settled-p context)
|
||||
(funcall predicate context)))
|
||||
:assertions
|
||||
(lambda (context)
|
||||
(list (etaf-gui-verifier-assert id (funcall predicate context))))))
|
||||
|
||||
(defun wb-gui--adapter (context)
|
||||
"Return primitive evidence for CONTEXT without copying private task text."
|
||||
(append
|
||||
(etaf-playground-gui-scenarios--adapter context)
|
||||
(let ((native (ebox-native-reflow-runtime-report)))
|
||||
(list (cons 'native_layout_ready (and (plist-get native :layout-ready-p) t))
|
||||
(cons 'native_module_path (or (plist-get native :loaded-module-path) ""))
|
||||
(cons 'native_module_hash (or (plist-get native :loaded-module-hash) ""))))
|
||||
(mapcar
|
||||
(lambda (entry)
|
||||
(cons (car entry)
|
||||
(vconcat
|
||||
(mapcar #'vconcat
|
||||
(plist-get (etaf-gui-verifier-context-get context (cdr entry))
|
||||
:controls)))))
|
||||
'((theme_pixels_before . light-layout)
|
||||
(theme_pixels_after . theme-layout-current)))
|
||||
(when (wb-gui--runtime context)
|
||||
(let ((data (wb-gui--data context)))
|
||||
(list (cons 'total (etaf-value (etaf-data-total data)))
|
||||
(cons 'page (etaf-value (etaf-data-page data)))
|
||||
(cons 'page_size (etaf-value (etaf-data-page-size data)))
|
||||
(cons 'visited_tasks
|
||||
(etaf-gui-verifier-context-get context 'visited-tasks 0))
|
||||
(cons 'visible_rows (length (wb-gui--ids context)))
|
||||
(cons 'selected_task (or (wb-gui--selected-id context) 0)))))))
|
||||
|
||||
(defun wb-gui--nested-scroll (context)
|
||||
"Scroll CONTEXT's help box and retain both inner and outer observations."
|
||||
(goto-char (wb-gui--find-text "点击行:选择任务"))
|
||||
(let* ((regions (cl-remove-if-not #'ebox-scroll-state
|
||||
(ebox--scroll-region-ids-at-point)))
|
||||
(inner (car regions)))
|
||||
(unless inner (error "Help text has no active scroll container"))
|
||||
(etaf-gui-verifier-context-put context 'inner-region inner)
|
||||
(etaf-gui-verifier-context-put
|
||||
context 'inner-offset (plist-get (ebox-scroll-state inner) :scroll-offset))
|
||||
(etaf-gui-verifier-context-put
|
||||
context 'outer-offsets
|
||||
(mapcar (lambda (id) (cons id (plist-get (ebox-scroll-state id) :scroll-offset)))
|
||||
(cdr regions)))
|
||||
(etaf-gui-verifier-context-put context 'outer-window-start (window-start))
|
||||
(ebox-scroll-down 1)))
|
||||
|
||||
(defun wb-gui--nested-scrolled-p (context)
|
||||
"Return non-nil when CONTEXT's inner help scrolled without its parent."
|
||||
(let ((inner (ebox-scroll-state
|
||||
(etaf-gui-verifier-context-get context 'inner-region))))
|
||||
(and (> (plist-get inner :scroll-offset)
|
||||
(etaf-gui-verifier-context-get context 'inner-offset))
|
||||
(= (window-start)
|
||||
(etaf-gui-verifier-context-get context 'outer-window-start))
|
||||
(cl-every
|
||||
(lambda (entry)
|
||||
(equal (cdr entry) (plist-get (ebox-scroll-state (car entry))
|
||||
:scroll-offset)))
|
||||
(etaf-gui-verifier-context-get context 'outer-offsets)))))
|
||||
|
||||
(defun wb-gui--reset-outer-scroll (_context)
|
||||
"Reset the outer Ebox viewport and its containing Emacs window."
|
||||
(goto-char (point-min))
|
||||
(condition-case nil (ebox-scroll-up 10000) (beginning-of-buffer nil))
|
||||
(goto-char (point-min))
|
||||
(set-window-start (selected-window) (point-min)))
|
||||
|
||||
(defun wb-gui--outer-reset-p (_context)
|
||||
"Return non-nil when both the outer Ebox viewport and window are at top."
|
||||
(and (= (window-start) (point-min))
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(cl-every
|
||||
(lambda (id)
|
||||
(zerop (or (plist-get (ebox-scroll-state id) :scroll-offset) 0)))
|
||||
(ebox--scroll-region-ids-at-point)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun task-workbench-gui-scenario ()
|
||||
"Return the complete Workbench temporal GUI acceptance scenario."
|
||||
(let ((primary wb-gui--primary-name)
|
||||
(secondary wb-gui--secondary-name))
|
||||
(etaf-gui-verifier-scenario-create
|
||||
:name "task-workbench"
|
||||
:claim "Workbench layout and public input, CRUD, resources, and isolated lifecycle"
|
||||
:initialize
|
||||
(lambda (context)
|
||||
(unless (display-graphic-p) (error "Workbench acceptance needs GUI Emacs"))
|
||||
(let ((buffer (get-buffer primary)))
|
||||
(unless (and (buffer-live-p buffer)
|
||||
(eq buffer wb-gui--prepared-buffer)
|
||||
(not (etaf-runtime-for-buffer buffer))
|
||||
(not (get-buffer secondary)))
|
||||
(error "Workbench target is not the fresh prepared unmounted buffer"))
|
||||
(etaf-gui-verifier-context-select-buffer context buffer)
|
||||
(setq wb-gui--prepared-buffer nil)))
|
||||
:invariants
|
||||
(lambda (context)
|
||||
(etaf-playground-gui-scenarios--invariants context nil))
|
||||
:adapter #'wb-gui--adapter
|
||||
:actions
|
||||
(append
|
||||
(list
|
||||
(wb-gui--action
|
||||
"mount"
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-put
|
||||
context 'target-fullscreen (frame-parameter nil 'fullscreen))
|
||||
(wb-open primary)
|
||||
(etaf-gui-verifier-context-select-buffer context (get-buffer primary))
|
||||
(etaf-gui-verifier-context-put context 'expects-mounted t))
|
||||
(lambda (context)
|
||||
(and (equal (wb-gui--ids context) (number-sequence 1 10))
|
||||
(wb-gui--text-p context "共 100 条 · 当前页 10 条")
|
||||
(wb-gui--text-p context "服务正常"))))
|
||||
(wb-gui--action
|
||||
"keyboard-theme"
|
||||
(lambda (context)
|
||||
(wb-gui--capture-theme-baseline context)
|
||||
(wb-gui--press context "深色"))
|
||||
(lambda (context)
|
||||
(and (wb-gui--theme-layout-preserved-p context)
|
||||
(wb-gui--root-background-p context "#111827"))))
|
||||
(wb-gui--action
|
||||
"keyboard-focus-add"
|
||||
(lambda (context) (wb-gui--press context "定位新增按钮"))
|
||||
(lambda (context)
|
||||
(equal (etaf-focused-host-ref (wb-gui--runtime context))
|
||||
(wb-gui--control context "新增任务"))))
|
||||
(wb-gui--action
|
||||
"minibuffer-add"
|
||||
(lambda (context) (wb-gui--enter context "新增任务" "GUI 验收任务"))
|
||||
(lambda (context)
|
||||
(= (etaf-value (etaf-data-total (wb-gui--data context))) 101))))
|
||||
(cl-loop for page from 2 to 11
|
||||
collect
|
||||
(let ((target page))
|
||||
(wb-gui--action
|
||||
(format "page-next-%d" target) #'wb-gui--visit-next-page
|
||||
(lambda (c)
|
||||
(and (equal (wb-gui--ids c)
|
||||
(number-sequence (1+ (* 10 (1- target)))
|
||||
(min 101 (* 10 target))))
|
||||
(equal (etaf-gui-verifier-context-get c 'visited-task-ids)
|
||||
(number-sequence 1 (min 101 (* 10 target))))
|
||||
(or (< target 11)
|
||||
(and (wb-gui--text-p c "GUI 验收任务")
|
||||
(plist-get
|
||||
(etaf-runtime-host-props-for
|
||||
(wb-gui--runtime c) (wb-gui--control c "Next page"))
|
||||
:disabled))))))))
|
||||
(cl-loop for page from 10 downto 1
|
||||
collect
|
||||
(let ((target page))
|
||||
(wb-gui--action
|
||||
(format "page-previous-%d" target)
|
||||
(lambda (c) (wb-gui--press c "Previous page"))
|
||||
(lambda (c)
|
||||
(equal (wb-gui--ids c)
|
||||
(number-sequence (1+ (* 10 (1- target))) (* 10 target)))))))
|
||||
(list
|
||||
(wb-gui--action "disabled-cell-mouse" (lambda (c) (wb-gui--click c "删除" 1))
|
||||
(lambda (c) (and (not (wb-gui--selected-id c))
|
||||
(equal (wb-gui--ids c) (number-sequence 1 10)))))
|
||||
(wb-gui--action
|
||||
"row-mouse-select"
|
||||
(lambda (_context) (wb-gui--mouse-at (wb-gui--find-text "设计组件接口")))
|
||||
(lambda (c) (and (equal (wb-gui--selected-id c) 1)
|
||||
(wb-gui--text-p c "进行中"))))
|
||||
(wb-gui--action
|
||||
"cell-mouse-toggle" (lambda (c) (wb-gui--click c "完成" 1))
|
||||
(lambda (c) (and (plist-get (etaf-data-selected-item (wb-gui--data c)) :done)
|
||||
(equal (wb-gui--selected-id c) 1))))
|
||||
(wb-gui--action "cell-mouse-delete" (lambda (c) (wb-gui--click c "删除" 1))
|
||||
(lambda (c) (and (equal (wb-gui--ids c) (number-sequence 2 11))
|
||||
(= (etaf-value (etaf-data-total
|
||||
(wb-gui--data c))) 100)
|
||||
(not (wb-gui--selected-id c)))))
|
||||
(wb-gui--action "filter-open" (lambda (c) (wb-gui--press c "未完成"))
|
||||
(lambda (c)
|
||||
(and (equal (wb-gui--ids c) '(2 4 6 7 9 10 11 13 14 15))
|
||||
(= (etaf-value (etaf-data-total (wb-gui--data c))) 74))))
|
||||
(wb-gui--action "filter-done" (lambda (c) (wb-gui--press c "已完成"))
|
||||
(lambda (c)
|
||||
(and (equal (wb-gui--ids c) '(3 5 8 12 16 20 24 28 32 36))
|
||||
(= (etaf-value (etaf-data-total (wb-gui--data c))) 26))))
|
||||
(wb-gui--action "minibuffer-search"
|
||||
(lambda (c) (wb-gui--enter c "搜索" "键盘"))
|
||||
(lambda (c) (equal (wb-gui--ids c) '(4))))
|
||||
(wb-gui--action "filter-all" (lambda (c) (wb-gui--press c "全部"))
|
||||
(lambda (c) (equal (wb-gui--ids c) (number-sequence 2 11))))
|
||||
(wb-gui--action "minibuffer-page-size"
|
||||
(lambda (c) (wb-gui--enter c "每页条数 10 ✎" "2"))
|
||||
(lambda (c) (and (equal (wb-gui--ids c) '(2 3))
|
||||
(wb-gui--text-p c "Page 1 / 50"))))
|
||||
(wb-gui--action
|
||||
"hide-help"
|
||||
(lambda (c)
|
||||
(etaf-gui-verifier-context-put
|
||||
c 'help-panels-before (wb-gui--panel-heights c))
|
||||
(wb-gui--press c "显示说明"))
|
||||
(lambda (c) (wb-gui--help-layout-preserved-p c nil)))
|
||||
(wb-gui--action "show-help" (lambda (c) (wb-gui--press c "显示说明"))
|
||||
(lambda (c) (wb-gui--help-layout-preserved-p c t)))
|
||||
(wb-gui--action "resource-failure" (lambda (c) (wb-gui--press c "模拟失败"))
|
||||
(lambda (c) (wb-gui--text-p c "模拟加载失败")))
|
||||
(wb-gui--action "resource-retry" (lambda (c) (wb-gui--press c "刷新 / 重试"))
|
||||
(lambda (c) (and (wb-gui--text-p c "服务正常")
|
||||
(not (wb-gui--text-p c "模拟加载失败")))))
|
||||
(wb-gui--action "nested-scroll" #'wb-gui--nested-scroll
|
||||
#'wb-gui--nested-scrolled-p)
|
||||
(etaf-playground-gui-scenarios--windowed-action)
|
||||
(etaf-playground-gui-scenarios--resize-action "resize-compact" 700 500)
|
||||
(etaf-playground-gui-scenarios--scroll-action "outer-scroll" #'ebox-scroll-page-down)
|
||||
(wb-gui--action "reset-scroll" #'wb-gui--reset-outer-scroll
|
||||
#'wb-gui--outer-reset-p)
|
||||
(etaf-playground-gui-scenarios--resize-action "resize-wide" 1300 750)
|
||||
(wb-gui--action
|
||||
"second-independent-app"
|
||||
(lambda (context)
|
||||
(etaf-gui-verifier-context-put context 'primary-data (wb-gui--data context))
|
||||
(wb-open secondary)
|
||||
(etaf-gui-verifier-context-select-buffer context (get-buffer secondary)))
|
||||
(lambda (c)
|
||||
(and (equal (wb-gui--ids c) (number-sequence 1 10))
|
||||
(= (etaf-value (etaf-data-total (wb-gui--data c))) 100)
|
||||
(not (eq (wb-gui--data c)
|
||||
(etaf-gui-verifier-context-get c 'primary-data))))))
|
||||
(wb-gui--action
|
||||
"close-second-app"
|
||||
(lambda (context)
|
||||
(wb-close secondary)
|
||||
(etaf-gui-verifier-context-select-buffer context (get-buffer primary)))
|
||||
(lambda (c) (and (not (get-buffer secondary))
|
||||
(equal (wb-gui--ids c) '(2 3)))))
|
||||
(wb-gui--action
|
||||
"unmount-remount"
|
||||
(lambda (context)
|
||||
(let ((old (wb-gui--runtime context)))
|
||||
(etaf-gui-verifier-context-put context 'retired-runtime old)
|
||||
(etaf-unmount old)
|
||||
(wb-open primary)
|
||||
(etaf-gui-verifier-context-select-buffer context (get-buffer primary))))
|
||||
(lambda (c)
|
||||
(and (not (etaf-runtime-mounted-p
|
||||
(etaf-gui-verifier-context-get c 'retired-runtime)))
|
||||
(equal (wb-gui--ids c) (number-sequence 1 10))
|
||||
(= (etaf-value (etaf-data-total (wb-gui--data c))) 100))))))
|
||||
:completion
|
||||
(lambda (context)
|
||||
(and (= (etaf-gui-verifier-context-action-count context)
|
||||
(length (etaf-gui-verifier-scenario-actions
|
||||
(etaf-gui-verifier-context-scenario context))))
|
||||
(not (get-buffer secondary))
|
||||
(= (etaf-gui-verifier-context-get context 'visited-tasks 0) 101)
|
||||
(equal (wb-gui--ids context) (number-sequence 1 10)))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun task-workbench-gui-run (run-directory)
|
||||
"Run Workbench GUI acceptance into prepared RUN-DIRECTORY."
|
||||
(unless (buffer-live-p wb-gui--prepared-buffer)
|
||||
(task-workbench-gui-prepare))
|
||||
(etaf-gui-verifier-run (task-workbench-gui-scenario) run-directory))
|
||||
|
||||
;;;###autoload
|
||||
(defun task-workbench-gui-run-from-environment ()
|
||||
"Run Workbench acceptance in the generic runner's evidence directory."
|
||||
(task-workbench-gui-run
|
||||
(or (getenv "ETAF_GUI_RUN_DIR")
|
||||
(error "ETAF_GUI_RUN_DIR is not configured"))))
|
||||
|
||||
(provide 'task-workbench-gui-scenarios)
|
||||
;;; task-workbench-gui-scenarios.el ends here
|
||||
63
scripts/with-performance-lock.sh
Executable file
63
scripts/with-performance-lock.sh
Executable file
@ -0,0 +1,63 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -eu
|
||||
|
||||
if [ "$#" -eq 0 ]; then
|
||||
echo "usage: $0 COMMAND [ARG ...]" >&2
|
||||
exit 2
|
||||
fi
|
||||
|
||||
PERF_LOCK_DIR=${ETAF_PERF_LOCK_DIR:-${TMPDIR:-/tmp}/etaf-performance-evaluator.lock}
|
||||
PERF_LOCK_WAIT_SECONDS=${ETAF_PERF_LOCK_WAIT_SECONDS:-180}
|
||||
|
||||
case $PERF_LOCK_WAIT_SECONDS in
|
||||
''|*[!0-9]*)
|
||||
echo "ETAF_PERF_LOCK_WAIT_SECONDS must be a non-negative integer" >&2
|
||||
exit 2
|
||||
;;
|
||||
esac
|
||||
|
||||
PERF_LOCK_ACQUIRED=false
|
||||
PERF_LOCK_WAITED=0
|
||||
|
||||
release_lock() {
|
||||
if [ "$PERF_LOCK_ACQUIRED" = true ]; then
|
||||
rm -f "$PERF_LOCK_DIR/pid"
|
||||
rmdir "$PERF_LOCK_DIR" 2>/dev/null || true
|
||||
fi
|
||||
}
|
||||
|
||||
trap release_lock EXIT HUP INT TERM
|
||||
|
||||
while ! mkdir "$PERF_LOCK_DIR" 2>/dev/null; do
|
||||
PERF_LOCK_OWNER=
|
||||
if [ -r "$PERF_LOCK_DIR/pid" ]; then
|
||||
IFS= read -r PERF_LOCK_OWNER < "$PERF_LOCK_DIR/pid" || PERF_LOCK_OWNER=
|
||||
fi
|
||||
case $PERF_LOCK_OWNER in
|
||||
''|*[!0-9]*) PERF_LOCK_OWNER= ;;
|
||||
esac
|
||||
|
||||
if [ -n "$PERF_LOCK_OWNER" ] &&
|
||||
! kill -0 "$PERF_LOCK_OWNER" 2>/dev/null; then
|
||||
rm -f "$PERF_LOCK_DIR/pid"
|
||||
rmdir "$PERF_LOCK_DIR" 2>/dev/null || true
|
||||
continue
|
||||
fi
|
||||
|
||||
if [ "$PERF_LOCK_WAITED" -ge "$PERF_LOCK_WAIT_SECONDS" ]; then
|
||||
echo "performance evaluator lock timed out: $PERF_LOCK_DIR" >&2
|
||||
exit 1
|
||||
fi
|
||||
if [ "$PERF_LOCK_WAITED" -eq 0 ]; then
|
||||
echo "performance evaluator waiting for exclusive host slot" >&2
|
||||
fi
|
||||
sleep 1
|
||||
PERF_LOCK_WAITED=$((PERF_LOCK_WAITED + 1))
|
||||
done
|
||||
|
||||
PERF_LOCK_ACQUIRED=true
|
||||
printf '%s\n' "$$" > "$PERF_LOCK_DIR/pid"
|
||||
echo "performance evaluator acquired exclusive host slot"
|
||||
|
||||
"$@"
|
||||
@ -2,6 +2,7 @@
|
||||
|
||||
;;; Code:
|
||||
(require 'ert)
|
||||
(require 'etaf-performance)
|
||||
(load-file (expand-file-name "scripts/benchmark-research-shelf.el"
|
||||
default-directory))
|
||||
|
||||
@ -11,10 +12,29 @@
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--latency-failures
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--trace-overhead-failures
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--verify-runtime-accelerator
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--verify-environment
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--trace-scenario
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--measure-overhead
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--manifest-data
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--write-manifest
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator--record-manifest-sample
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(declare-function etaf-performance-evaluator-batch
|
||||
"../scripts/benchmark-research-shelf")
|
||||
(defvar etaf-performance-evaluator-warmup-count)
|
||||
(defvar etaf-performance-evaluator-sample-count)
|
||||
(defvar etaf-performance-evaluator--manifest-output)
|
||||
(defvar etaf-performance-evaluator--manifest-scenarios)
|
||||
(defvar etaf-performance-evaluator--manifest-run-id)
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-uses-nearest-rank-percentiles ()
|
||||
"Return nearest-rank values for evaluator percentiles."
|
||||
@ -23,7 +43,7 @@
|
||||
(should (= 19 (etaf-performance-evaluator--percentile samples 0.95)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-warms-before-exact-sample-count ()
|
||||
"Execute one unmeasured warmup before the requested measured samples."
|
||||
"Execute five unmeasured warmups before the measured samples."
|
||||
(let (actions verifications)
|
||||
(let ((result
|
||||
(etaf-performance-evaluator--measure
|
||||
@ -33,10 +53,16 @@
|
||||
(should (= value index))
|
||||
(push index verifications))
|
||||
:samples 3)))
|
||||
(should (equal '(-1 0 1 2) (nreverse actions)))
|
||||
(should (equal '(-1 0 1 2) (nreverse verifications)))
|
||||
(should (equal '(-5 -4 -3 -2 -1 0 1 2) (nreverse actions)))
|
||||
(should (equal '(-5 -4 -3 -2 -1 0 1 2)
|
||||
(nreverse verifications)))
|
||||
(should (= 3 (plist-get (cdr result) :count))))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-defaults-to-stable-sample-volume ()
|
||||
"Use at least five warmups and thirty samples for every fixed scenario."
|
||||
(should (>= etaf-performance-evaluator-warmup-count 5))
|
||||
(should (>= etaf-performance-evaluator-sample-count 30)))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-models-visible-gc-boundary ()
|
||||
"Measured actions defer GC like an interactive Ebox render burst."
|
||||
(let ((gc-cons-threshold 1000)
|
||||
@ -49,12 +75,115 @@
|
||||
t)
|
||||
(lambda (result _index) (should result))
|
||||
:samples 1)
|
||||
;; Warmup is intentionally outside the timed visible transaction; the
|
||||
;; Warmups are intentionally outside the timed visible transaction; the
|
||||
;; measured sample owns the raised threshold and caller settings restore.
|
||||
(should (equal (car observed) (list most-positive-fixnum 1.0)))
|
||||
(should (= gc-cons-threshold 1000))
|
||||
(should (= gc-cons-percentage 0.1))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-manifest-preserves-raw-samples ()
|
||||
"Write exact post-timing samples and statistics to the optional manifest."
|
||||
(let* ((output (make-temp-file "etaf-perf-manifest-" nil ".json"))
|
||||
(etaf-performance-evaluator--manifest-output output)
|
||||
(etaf-performance-evaluator--manifest-scenarios
|
||||
(make-hash-table :test #'equal))
|
||||
(etaf-performance-evaluator--manifest-run-id "unit-run")
|
||||
(process-environment
|
||||
(append '("INCREMENTAL_SET_INDEX=2"
|
||||
"INCREMENTAL_SOURCE_IDENTITY=source-id"
|
||||
"INCREMENTAL_EVALUATOR_IDENTITY=evaluator-id")
|
||||
process-environment))
|
||||
(durations '(1.25 2.5 3.75)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(cl-letf (((symbol-function 'etaf-performance-evaluator--timed-call)
|
||||
(lambda (function)
|
||||
(cons (pop durations) (funcall function))))
|
||||
((symbol-function 'princ) #'ignore))
|
||||
(etaf-performance-evaluator--measure
|
||||
"row-selection" (lambda (_index) 'ok)
|
||||
(lambda (result _index) (should (eq result 'ok)))
|
||||
:warmups 0 :samples 3))
|
||||
(etaf-performance-evaluator--write-manifest)
|
||||
(let* ((json-object-type 'hash-table)
|
||||
(json-array-type 'list)
|
||||
(manifest (json-read-file output))
|
||||
(scenario (gethash "row-selection"
|
||||
(gethash "scenarios" manifest))))
|
||||
(should (equal '(1.25 2.5 3.75)
|
||||
(gethash "samples_ms" scenario)))
|
||||
(should (= 3.75 (gethash "p95_ms" scenario)))
|
||||
(should (= 3.75 (gethash "max_ms" scenario)))
|
||||
(should (= 2 (gethash "set_index" manifest)))
|
||||
(should (equal "source-id" (gethash "source_identity" manifest)))
|
||||
(should (equal "evaluator-id"
|
||||
(gethash "evaluator_identity" manifest)))))
|
||||
(when (file-exists-p output) (delete-file output)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-manifest-retains-failed-prefix ()
|
||||
"Keep only real samples captured before a scenario verification failure."
|
||||
(let ((etaf-performance-evaluator--manifest-scenarios
|
||||
(make-hash-table :test #'equal))
|
||||
(durations '(4.0 5.0 6.0)))
|
||||
(cl-letf (((symbol-function 'etaf-performance-evaluator--timed-call)
|
||||
(lambda (function)
|
||||
(cons (pop durations) (funcall function))))
|
||||
((symbol-function 'princ) #'ignore))
|
||||
(should-error
|
||||
(etaf-performance-evaluator--measure
|
||||
"pagination" (lambda (_index) 'ok)
|
||||
(lambda (_result index)
|
||||
(when (= index 1) (error "Fixture failure")))
|
||||
:warmups 0 :samples 3)))
|
||||
(should (equal '(5.0 4.0)
|
||||
(gethash "pagination"
|
||||
etaf-performance-evaluator--manifest-scenarios)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-batch-writes-manifest-on-failure ()
|
||||
"Write the actually captured prefix before returning a failing batch status."
|
||||
(let* ((output (make-temp-file "etaf-failed-perf-manifest-" nil ".json"))
|
||||
(process-environment
|
||||
(append (list (concat "INCREMENTAL_PERF_MANIFEST=" output)
|
||||
"INCREMENTAL_SET_INDEX=1"
|
||||
"INCREMENTAL_SOURCE_IDENTITY=source-id"
|
||||
"INCREMENTAL_EVALUATOR_IDENTITY=evaluator-id")
|
||||
process-environment))
|
||||
exit-status)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(cl-letf (((symbol-function 'etaf-performance-evaluator-run)
|
||||
(lambda ()
|
||||
(etaf-performance-evaluator--record-manifest-sample
|
||||
"filter-query" 8.5)
|
||||
(error "Fixture failure")))
|
||||
((symbol-function 'kill-emacs)
|
||||
(lambda (status) (setq exit-status status)))
|
||||
((symbol-function 'princ) #'ignore))
|
||||
(etaf-performance-evaluator-batch))
|
||||
(let* ((json-object-type 'hash-table)
|
||||
(json-array-type 'list)
|
||||
(manifest (json-read-file output))
|
||||
(scenario (gethash "filter-query"
|
||||
(gethash "scenarios" manifest))))
|
||||
(should (= 1 exit-status))
|
||||
(should (equal '(8.5) (gethash "samples_ms" scenario)))
|
||||
(should (= 8.5 (gethash "p95_ms" scenario)))
|
||||
(should (= 8.5 (gethash "max_ms" scenario)))))
|
||||
(when (file-exists-p output) (delete-file output)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-no-manifest-env-keeps-normal-path ()
|
||||
"Do not create evidence or change measurement results without the env opt-in."
|
||||
(let ((etaf-performance-evaluator--manifest-output nil)
|
||||
(etaf-performance-evaluator--manifest-scenarios nil))
|
||||
(cl-letf (((symbol-function 'princ) #'ignore))
|
||||
(let ((result
|
||||
(etaf-performance-evaluator--measure
|
||||
"row-selection" (lambda (_index) 'ok)
|
||||
(lambda (value _index) (should (eq value 'ok)))
|
||||
:warmups 0 :samples 1)))
|
||||
(should (= 1 (plist-get (cdr result) :count)))))
|
||||
(should-not (etaf-performance-evaluator--write-manifest))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-reports-both-hard-budget-failures ()
|
||||
"Report p95 and max independently when both exceed the hard budget."
|
||||
(let ((failures
|
||||
@ -64,19 +193,85 @@
|
||||
(should (string-match-p "slow p95" (car failures)))
|
||||
(should (string-match-p "slow max" (cadr failures)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-uses-approved-theme-budget ()
|
||||
"Accept the approved 90ms Theme budget without relaxing other scenarios."
|
||||
(ert-deftest etaf-performance-evaluator-applies-one-budget-to-theme ()
|
||||
"Theme and post-resize Theme obey the same 50ms p95/max gate."
|
||||
(let ((failures
|
||||
(etaf-performance-evaluator--latency-failures
|
||||
'(("theme-toggle" :count 30 :min 40.0 :p50 45.0
|
||||
:p95 51.0 :max 52.0)
|
||||
("post-resize-theme-toggle" :count 30 :min 40.0 :p50 45.0
|
||||
:p95 49.0 :max 51.0)))))
|
||||
(should (= 3 (length failures)))
|
||||
(dolist (failure failures)
|
||||
(should (string-match-p "> 50.000ms" failure)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-gates-trace-overhead-p95 ()
|
||||
"Apply the 2ms trace budget to signed p95 as well as median bias."
|
||||
(let ((failures
|
||||
(etaf-performance-evaluator--trace-overhead-failures
|
||||
'(:signed (:p50 0.4 :p95 2.5)))))
|
||||
(should (= 1 (length failures)))
|
||||
(should (string-match-p "p95 2.500ms > 2.000ms" (car failures))))
|
||||
(let ((failures
|
||||
(etaf-performance-evaluator--trace-overhead-failures
|
||||
'(:signed (:p50 -2.5 :p95 1.9)))))
|
||||
(should (= 1 (length failures)))
|
||||
(should (string-match-p "|p50| 2.500ms > 2.000ms" (car failures))))
|
||||
(should-not
|
||||
(etaf-performance-evaluator--latency-failures
|
||||
'(("theme-toggle" :count 20 :min 80.0 :p50 84.0
|
||||
:p95 86.0 :max 99.0)
|
||||
("post-resize-theme-toggle" :count 20 :min 80.0 :p50 84.0
|
||||
:p95 86.0 :max 99.0))))
|
||||
(should (= 2
|
||||
(length
|
||||
(etaf-performance-evaluator--latency-failures
|
||||
'(("theme-toggle" :count 20 :min 80.0 :p50 84.0
|
||||
:p95 91.0 :max 111.0)))))))
|
||||
(etaf-performance-evaluator--trace-overhead-failures
|
||||
'(:signed (:p50 0.4 :p95 1.9)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-trace-scenario-retains-one-operation ()
|
||||
"The trace driver uses the public Runtime recorder and preserves results."
|
||||
(let ((buffer-name (generate-new-buffer-name " *etaf-driver-trace-test*"))
|
||||
runtime verified)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name (etaf-view (box "Trace")))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(etaf-performance-start runtime)
|
||||
(etaf-performance-clear)
|
||||
(let ((scenario
|
||||
(etaf-performance-evaluator--trace-scenario
|
||||
runtime "fixture"
|
||||
(lambda () 'exact-result)
|
||||
(lambda (result) (setq verified result)))))
|
||||
(should (equal '("fixture") (list (car scenario))))
|
||||
(should (etaf-performance-operation-p (cadr scenario)))
|
||||
(should (eq 'exact-result (caddr scenario)))
|
||||
(should (eq 'exact-result verified))
|
||||
(should (= 1 (length (etaf-performance-records))))))
|
||||
(when runtime
|
||||
(etaf-performance-stop runtime)
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-overhead-uses-explicit-operation ()
|
||||
"Trace-on focus work enters the public Runtime operation boundary."
|
||||
(let ((buffer-name (generate-new-buffer-name " *etaf-driver-overhead-test*"))
|
||||
(etaf-performance-evaluator-sample-count 2)
|
||||
runtime)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(column
|
||||
(box :ref 'first :tab-index 0 "First")
|
||||
(box :ref 'second :tab-index 1 "Second"))))
|
||||
(setq runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(cl-letf (((symbol-function 'princ) #'ignore))
|
||||
(let ((result
|
||||
(etaf-performance-evaluator--measure-overhead
|
||||
runtime buffer-name 'first)))
|
||||
(should (numberp (plist-get (plist-get result :signed) :p50)))
|
||||
(should (= 1 (length (etaf-performance-records)))))))
|
||||
(when runtime
|
||||
(etaf-performance-stop runtime)
|
||||
(etaf-unmount runtime))
|
||||
(when-let* ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-requires-native-runtime ()
|
||||
"Never report fallback-renderer latency as the optimized product gate."
|
||||
@ -106,7 +301,38 @@
|
||||
(should-error
|
||||
(etaf-performance-evaluator--verify-environment
|
||||
'(:power-state (:source battery :low-power-mode on)
|
||||
:load-average (1.0))))
|
||||
(should-error
|
||||
(etaf-performance-evaluator--verify-environment
|
||||
'(:power-state (:source ac :low-power-mode off)
|
||||
:native-comp-jit-compilation t
|
||||
:load-average (1.0))))))
|
||||
|
||||
(ert-deftest etaf-performance-evaluator-uses-only-recorder-v2-public-api ()
|
||||
"The driver contains no v1 recorder fields or implicit global tracing."
|
||||
(let ((source
|
||||
(with-temp-buffer
|
||||
(insert-file-contents "scripts/benchmark-research-shelf.el")
|
||||
(buffer-string))))
|
||||
(dolist (obsolete
|
||||
'("etaf-performance-mode"
|
||||
"etaf-performance-stage-function"
|
||||
"etaf-performance-stage-exclusive"
|
||||
"etaf-performance-operation-gc-count-before"
|
||||
"etaf-performance-operation-gc-count-after"
|
||||
"etaf-performance-operation-gc-elapsed-before"
|
||||
"etaf-performance-operation-gc-elapsed-after"
|
||||
"etaf-performance-register-stage"
|
||||
"etaf-performance--installed-advices"
|
||||
"etaf-runtime-mount-epoch"
|
||||
"etaf-runtime-mounted-p"))
|
||||
(should-not (string-match-p (regexp-quote obsolete) source)))
|
||||
(dolist (required '("etaf-performance-start"
|
||||
"etaf-performance-stop"
|
||||
"etaf-performance-stage-name"
|
||||
"etaf-performance-operation-gc-count"
|
||||
"etaf-performance-operation-gc-elapsed"))
|
||||
(should (string-match-p (regexp-quote required) source)))))
|
||||
|
||||
(provide 'benchmark-research-shelf-tests)
|
||||
;;; benchmark-research-shelf-tests.el ends here
|
||||
|
||||
50
tests/etaf-playground-docs-tests.el
Normal file
50
tests/etaf-playground-docs-tests.el
Normal file
@ -0,0 +1,50 @@
|
||||
;;; etaf-playground-docs-tests.el --- Documentation contracts -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
|
||||
(defconst etaf-playground-docs-tests--root
|
||||
(file-name-directory
|
||||
(directory-file-name
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"Absolute etaf-playground repository root.")
|
||||
|
||||
(defun etaf-playground-docs-tests--contents (name)
|
||||
"Return the literal contents of repository file NAME."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents
|
||||
(expand-file-name name etaf-playground-docs-tests--root))
|
||||
(buffer-string)))
|
||||
|
||||
(defun etaf-playground-docs-tests--normalized-contents (name)
|
||||
"Return NAME with runs of whitespace collapsed for prose assertions."
|
||||
(replace-regexp-in-string
|
||||
"[[:space:]]+" " " (etaf-playground-docs-tests--contents name)))
|
||||
|
||||
(ert-deftest etaf-performance-docs-distinguish-evidence-lanes ()
|
||||
"Latency, trace, and GUI evidence remain explicitly separate lanes."
|
||||
(dolist (file '("README.md" "DESIGN.md" "DESIGN.zh-CN.md"))
|
||||
(let ((text (etaf-playground-docs-tests--normalized-contents file)))
|
||||
(should (string-match-p "latency lane\\|延迟 lane" text))
|
||||
(should (string-match-p "trace lane\\|追踪 lane" text))
|
||||
(should (string-match-p "GUI lane" text))
|
||||
(should (string-match-p
|
||||
"repository/environment/scenario/fixture/build identity\\|仓库、环境、场景、fixture 和 build identity"
|
||||
text))
|
||||
(should (string-match-p
|
||||
"not GUI first paint\\|不是 GUI first paint"
|
||||
text)))))
|
||||
|
||||
(ert-deftest etaf-performance-docs-separate-current-gate-from-historical-budget ()
|
||||
"The active 50ms gate must not be confused with the historical 105ms text."
|
||||
(dolist (file '("DESIGN.md" "DESIGN.zh-CN.md"))
|
||||
(let ((text (etaf-playground-docs-tests--normalized-contents file)))
|
||||
(should (string-match-p "5.*warmup.*30.*sample\\|5.*warmup.*30.*sample" text))
|
||||
(should (string-match-p "p95.*max.*50ms\\|p95.*max.*50ms" text))
|
||||
(should (string-match-p "105ms p50" text))
|
||||
(should (string-match-p "historical\\|历史" text))
|
||||
(should (string-match-p "M0b1" text)))))
|
||||
|
||||
(provide 'etaf-playground-docs-tests)
|
||||
;;; etaf-playground-docs-tests.el ends here
|
||||
@ -8,7 +8,21 @@
|
||||
;;; Code:
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'package)
|
||||
(require 'etaf-playground)
|
||||
(require 'etaf-performance)
|
||||
|
||||
(defconst etaf-playground-test--root
|
||||
(file-name-directory
|
||||
(directory-file-name
|
||||
(file-name-directory (or load-file-name buffer-file-name))))
|
||||
"Absolute ETAF Playground repository path used by subprocess gates.")
|
||||
|
||||
(defun etaf-playground-test--package-description (file)
|
||||
"Return the package description parsed from FILE."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(package-buffer-info)))
|
||||
|
||||
(defun etaf-playground-test--ensure-app-loaded ()
|
||||
"Load the same-basename Research Shelf companion for test setup."
|
||||
@ -16,6 +30,142 @@
|
||||
(load-file (expand-file-name "examples/research-shelf.el"
|
||||
default-directory))))
|
||||
|
||||
(ert-deftest etaf-playground-etaf-source-mode-clean-loads-without-runtime ()
|
||||
"Opening research-shelf.etaf must not eagerly load ETAF or TP."
|
||||
(let ((output (generate-new-buffer " *etaf-source-mode-clean-load*"))
|
||||
(program (expand-file-name invocation-name invocation-directory))
|
||||
(package-file
|
||||
(expand-file-name "etaf-playground.el" etaf-playground-test--root))
|
||||
(source-file
|
||||
(expand-file-name "examples/research-shelf.etaf"
|
||||
etaf-playground-test--root)))
|
||||
(unwind-protect
|
||||
(let ((status
|
||||
(call-process
|
||||
program nil output nil "-Q" "--batch"
|
||||
"-L" etaf-playground-test--root
|
||||
"-l" package-file
|
||||
"--eval"
|
||||
(format
|
||||
"(progn (find-file %S) (unless (eq major-mode 'etaf-playground-etaf-mode) (kill-emacs 11)) (when (featurep 'etaf) (kill-emacs 12)) (when (featurep 'tp) (kill-emacs 13)) (when (featurep 'tp-transaction) (kill-emacs 14)) (princ \"ETAF source mode clean-load OK\\n\"))"
|
||||
source-file))))
|
||||
(unless (zerop status)
|
||||
(ert-fail
|
||||
(with-current-buffer output (buffer-string))))
|
||||
(with-current-buffer output
|
||||
(should (string-match-p "ETAF source mode clean-load OK"
|
||||
(buffer-string)))))
|
||||
(when (buffer-live-p output) (kill-buffer output)))))
|
||||
|
||||
(ert-deftest etaf-playground-package-closure-requires-transaction-tp ()
|
||||
"Package metadata must reject TP snapshots without tp-transaction.el."
|
||||
(let* ((workspace (file-name-directory
|
||||
(directory-file-name etaf-playground-test--root)))
|
||||
(tp (etaf-playground-test--package-description
|
||||
(expand-file-name "tp/tp.el" workspace)))
|
||||
(ebox (etaf-playground-test--package-description
|
||||
(expand-file-name "ebox/ebox.el" workspace)))
|
||||
(etaf (etaf-playground-test--package-description
|
||||
(expand-file-name "etaf/etaf.el" workspace)))
|
||||
(playground (etaf-playground-test--package-description
|
||||
(expand-file-name
|
||||
"etaf-playground/etaf-playground.el" workspace))))
|
||||
(should (equal (package-desc-version tp) '(2 0 0)))
|
||||
(should (equal (package-desc-version ebox) '(3 0 0)))
|
||||
(should (member '(tp (1 0 1)) (package-desc-reqs ebox)))
|
||||
(should (equal (package-desc-version etaf) '(0 2 1)))
|
||||
(should (member '(ebox (3 0 0)) (package-desc-reqs etaf)))
|
||||
(should (member '(tp (2 0 0)) (package-desc-reqs etaf)))
|
||||
(should (equal (package-desc-version playground) '(0 2 2)))
|
||||
(should (member '(etaf (0 2 1)) (package-desc-reqs playground)))
|
||||
(should (member '(etaf-ui (0 1 0))
|
||||
(package-desc-reqs playground)))
|
||||
(should (member '(etaf-sqlite (0 1 0))
|
||||
(package-desc-reqs playground)))))
|
||||
|
||||
(ert-deftest etaf-playground-stale-tp-error-is-actionable ()
|
||||
"A stale TP install reports its required package instead of file-missing."
|
||||
(let ((original-require (symbol-function 'require)))
|
||||
(cl-letf (((symbol-function 'require)
|
||||
(lambda (feature &optional filename noerror)
|
||||
(if (eq feature 'etaf)
|
||||
(signal 'file-missing
|
||||
'("Cannot open load file"
|
||||
"No such file or directory"
|
||||
"tp-transaction"))
|
||||
(funcall original-require feature filename noerror)))))
|
||||
(let ((condition
|
||||
(should-error (etaf-playground--ensure-runtime)
|
||||
:type 'etaf-playground-dependency-error)))
|
||||
(should (equal (plist-get (cdr condition) :required-package)
|
||||
'(tp "2.0.0")))
|
||||
(should (eq (plist-get (cdr condition) :missing-feature)
|
||||
'tp-transaction))))))
|
||||
|
||||
(ert-deftest etaf-playground-unrelated-file-missing-is-preserved ()
|
||||
"Runtime loading must not relabel an unrelated missing dependency as TP."
|
||||
(let ((original-require (symbol-function 'require))
|
||||
(injected
|
||||
'(file-missing "Cannot open load file"
|
||||
"No such file or directory"
|
||||
"unrelated-feature")))
|
||||
(cl-letf (((symbol-function 'require)
|
||||
(lambda (feature &optional filename noerror)
|
||||
(if (eq feature 'etaf)
|
||||
(signal (car injected) (cdr injected))
|
||||
(funcall original-require feature filename noerror)))))
|
||||
(should (equal (should-error (etaf-playground--ensure-runtime)
|
||||
:type 'file-missing)
|
||||
injected)))))
|
||||
|
||||
(ert-deftest etaf-playground-preview-suppresses-editor-redisplay-artifacts ()
|
||||
"Generated previews hide wrapping indicators that appear as edge blocks."
|
||||
(let ((buffer (generate-new-buffer " *etaf-preview-display-settings*"))
|
||||
(session (etaf-playground--session-create :name "display-settings")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-current-buffer buffer
|
||||
(etaf-playground-preview-mode)
|
||||
;; Reused preview buffers may have settings changed by a caller;
|
||||
;; session setup must restore the generated-canvas contract.
|
||||
(setq-local truncate-lines nil
|
||||
auto-hscroll-mode nil
|
||||
fringe-indicator-alist
|
||||
'((truncation left-arrow right-arrow)
|
||||
(continuation left-curly-arrow right-curly-arrow))
|
||||
bidi-display-reordering t
|
||||
bidi-paragraph-direction nil
|
||||
bidi-inhibit-bpa nil))
|
||||
(etaf-playground--preview-mode-setup buffer session)
|
||||
(cl-letf (((symbol-function 'etaf-runtime-for-buffer)
|
||||
(lambda (_buffer) nil))
|
||||
((symbol-function 'etaf-playground-read-pair)
|
||||
(lambda (&rest _arguments) 'preview-view))
|
||||
((symbol-function 'etaf-mount)
|
||||
(lambda (&rest _arguments)
|
||||
;; Model renderer publication restoring ordinary editor
|
||||
;; defaults after the preview mode was initialized.
|
||||
(setq-local truncate-lines nil
|
||||
auto-hscroll-mode nil
|
||||
fringe-indicator-alist
|
||||
'((truncation left-arrow right-arrow)
|
||||
(continuation
|
||||
left-curly-arrow right-curly-arrow))
|
||||
bidi-display-reordering t
|
||||
bidi-paragraph-direction nil
|
||||
bidi-inhibit-bpa nil))))
|
||||
(etaf-playground--mount-example-now
|
||||
buffer "display-settings" session nil))
|
||||
(with-current-buffer buffer
|
||||
(should truncate-lines)
|
||||
(should auto-hscroll-mode)
|
||||
(should-not (assq 'truncation fringe-indicator-alist))
|
||||
(should-not (assq 'continuation fringe-indicator-alist))
|
||||
(should-not bidi-display-reordering)
|
||||
(should (eq bidi-paragraph-direction 'left-to-right))
|
||||
(should bidi-inhibit-bpa)))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer)))))
|
||||
|
||||
(defun etaf-playground-test--text (buffer)
|
||||
"Return BUFFER's plain rendered text."
|
||||
(with-current-buffer buffer
|
||||
@ -68,6 +218,15 @@ database and mounts a test buffer before running BODY."
|
||||
(when (file-exists-p ,database)
|
||||
(delete-file ,database))))))
|
||||
|
||||
(defun etaf-playground-test--open (buffer)
|
||||
"Mount Research Shelf in BUFFER with a deterministic headless viewport.
|
||||
|
||||
Text assertions should not depend on whether batch Ebox has a selected
|
||||
window. GUI verification exercises responsive geometry separately on a real
|
||||
frame."
|
||||
(etaf-playground-mount-example
|
||||
buffer "research-shelf" nil '(:viewport-width 1400 :viewport-height 80)))
|
||||
|
||||
(ert-deftest etaf-playground-framework-discovers-generic-file-triplets ()
|
||||
"Discover examples from files without a business catalog in the framework."
|
||||
(should (member "research-shelf" etaf-playground-example-names))
|
||||
@ -157,23 +316,49 @@ database and mounts a test buffer before running BODY."
|
||||
"$(MAKE) -C ../ebox compile"
|
||||
"$(MAKE) -C ../etaf compile"
|
||||
"$(MAKE) -C ../etaf-ui compile"
|
||||
"$(MAKE) -C ../etaf-sqlite compile"))
|
||||
"$(MAKE) -C ../etaf-db compile"))
|
||||
(should (string-match-p (regexp-quote dependency) makefile)))))
|
||||
|
||||
(ert-deftest etaf-playground-performance-gate-runs-before-regressions ()
|
||||
"CPU-heavy regressions must not contaminate absolute latency samples."
|
||||
"Repeatable exclusive latency gates run before CPU-heavy regressions."
|
||||
(let* ((makefile (with-temp-buffer
|
||||
(insert-file-contents "Makefile")
|
||||
(buffer-string)))
|
||||
(target (string-match "^perf-check:" makefile))
|
||||
(evaluator (and target
|
||||
(string-match "perf-evaluator" makefile target)))
|
||||
(repeatability
|
||||
(and target
|
||||
(string-match "$(MAKE) perf-repeatability " makefile target)))
|
||||
(regressions (and target
|
||||
(string-match "perf-regressions" makefile target))))
|
||||
(should target)
|
||||
(should evaluator)
|
||||
(should repeatability)
|
||||
(should regressions)
|
||||
(should (< evaluator regressions))))
|
||||
(should (< repeatability regressions))
|
||||
(should (string-match-p "^perf-prepare: compile" makefile))
|
||||
(should (string-match-p "^perf-evaluator:" makefile))
|
||||
(should (string-match-p "^perf-repeatability: perf-prepare" makefile))
|
||||
(should (string-match-p "scripts/with-performance-lock.sh" makefile))
|
||||
(let* ((start (string-match "^perf-repeatability:" makefile))
|
||||
(end (string-match "^# Run package regressions" makefile start))
|
||||
(body (substring makefile start end))
|
||||
(offset 0)
|
||||
(count 0))
|
||||
(while (string-match "$(MAKE) perf-evaluator" body offset)
|
||||
(setq count (1+ count)
|
||||
offset (match-end 0)))
|
||||
(should (= count 3)))))
|
||||
|
||||
(ert-deftest etaf-playground-performance-lock-is-exclusive-and-stale-safe ()
|
||||
"The evaluator wrapper serializes runs and clears stale owner locks."
|
||||
(let ((script (with-temp-buffer
|
||||
(insert-file-contents "scripts/with-performance-lock.sh")
|
||||
(buffer-string))))
|
||||
(dolist (contract '("mkdir \"$PERF_LOCK_DIR\""
|
||||
"kill -0 \"$PERF_LOCK_OWNER\""
|
||||
"rmdir \"$PERF_LOCK_DIR\""
|
||||
"performance evaluator waiting for exclusive host slot"))
|
||||
(should (string-match-p (regexp-quote contract) script)))
|
||||
(should-not (string-match-p "rm -rf" script))))
|
||||
|
||||
(ert-deftest etaf-playground-static-reader-is-inert-and-strict ()
|
||||
"Read pair structure as inert data and reject executable AST nodes."
|
||||
@ -392,11 +577,13 @@ database and mounts a test buffer before running BODY."
|
||||
(replace-match ":title \"Research Shelf (edited)\"" t t)
|
||||
(set-buffer-modified-p t))
|
||||
(should (etaf-playground-refresh source))
|
||||
(should (string-match-p "Research Shelf (edited)"
|
||||
(etaf-playground-test--text
|
||||
(etaf-playground-session-preview-buffer
|
||||
(buffer-local-value 'etaf-playground-session
|
||||
source))))))))
|
||||
(let* ((session (buffer-local-value 'etaf-playground-session source))
|
||||
(preview (etaf-playground-session-preview-buffer session))
|
||||
(form (etaf-playground-read-static "research-shelf" session)))
|
||||
(should (equal "Research Shelf (edited)"
|
||||
(plist-get (cdr form) :title)))
|
||||
(should (string-match-p "edited"
|
||||
(etaf-playground-test--text preview)))))))
|
||||
|
||||
(ert-deftest etaf-playground-refresh-reloads-unsaved-el-companion ()
|
||||
"Refreshing a dirty `.el' companion redefines its consumer intentionally."
|
||||
@ -423,13 +610,11 @@ database and mounts a test buffer before running BODY."
|
||||
(etaf-compiler-clear-cache)
|
||||
(let* ((before (etaf-compiler-statistics))
|
||||
(instantiations (plist-get before :instantiations))
|
||||
(fallbacks (plist-get before :fallbacks))
|
||||
(cache-entries (plist-get before :static-cache-entries)))
|
||||
(etaf-playground-open buffer)
|
||||
(etaf-playground-test--open buffer)
|
||||
(let* ((after (etaf-compiler-statistics))
|
||||
(blueprint (plist-get after :last-blueprint)))
|
||||
(should (> (plist-get after :instantiations) instantiations))
|
||||
(should (>= (plist-get after :fallbacks) fallbacks))
|
||||
(should (> (plist-get after :static-cache-entries) cache-entries))
|
||||
(should (> (plist-get blueprint :dynamic-nodes) 0))
|
||||
(should (> (plist-get blueprint :hole-count) 0))))))
|
||||
@ -437,7 +622,7 @@ database and mounts a test buffer before running BODY."
|
||||
(ert-deftest etaf-playground-pair-mounts-sqlite-backed-surface ()
|
||||
"Mounting the pair initializes SQLite and renders the real app shell."
|
||||
(etaf-playground-test--with-app (buffer database)
|
||||
(etaf-playground-open buffer)
|
||||
(etaf-playground-test--open buffer)
|
||||
(should (etaf-runtime-p (etaf-runtime-for-buffer buffer)))
|
||||
(should (file-exists-p database))
|
||||
(let ((text (etaf-playground-test--text buffer))
|
||||
@ -461,8 +646,8 @@ database and mounts a test buffer before running BODY."
|
||||
'(:viewport-width 900 :viewport-height 40))
|
||||
(let* ((state (ebox--buffer-render-state (get-buffer buffer)))
|
||||
(root (plist-get state :root-node)))
|
||||
(should (eq (plist-get root :height) 'auto))
|
||||
(should (equal (plist-get root :min-height) '(viewport-height)))
|
||||
(should (equal (plist-get root :height) '(viewport-height)))
|
||||
(should (= (plist-get root :min-height) 0))
|
||||
(should-not (plist-get state :scroll-region-ids)))))
|
||||
|
||||
(ert-deftest etaf-playground-fixture-supports-realistic-page-counts ()
|
||||
@ -489,7 +674,7 @@ database and mounts a test buffer before running BODY."
|
||||
(ert-deftest etaf-playground-row-selection-is-repeatable ()
|
||||
"Repeated DataGrid row presses replace one selected identity."
|
||||
(etaf-playground-test--with-app (buffer database)
|
||||
(etaf-playground-open buffer)
|
||||
(etaf-playground-test--open buffer)
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(dolist (entry '((research-shelf-row-1 research-shelf-row-2
|
||||
"The best tools make attention feel larger")
|
||||
@ -520,10 +705,62 @@ database and mounts a test buffer before running BODY."
|
||||
:class)
|
||||
""))))))))
|
||||
|
||||
(ert-deftest etaf-playground-row-observer-on-off-is-exact ()
|
||||
"Observation preserves one real row mutation and its retained identity."
|
||||
(etaf-playground-test--with-app (buffer database)
|
||||
(etaf-playground-test--open buffer)
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer))
|
||||
(surface
|
||||
(lambda ()
|
||||
(with-current-buffer buffer
|
||||
(buffer-substring (point-min) (point-max))))))
|
||||
;; Materialize the same lazy TP paint contribution before either side of
|
||||
;; the equivalence comparison. The observer remains detached here.
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-2 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(let* ((generation-before (etaf-runtime-generation runtime))
|
||||
(result-off
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-2 'press))
|
||||
(generation-off (etaf-runtime-generation runtime))
|
||||
(output-off (funcall surface)))
|
||||
(should (= 1 (- generation-off generation-before)))
|
||||
(should (string-match-p
|
||||
"selected"
|
||||
(or (plist-get
|
||||
(etaf-runtime-host-props-for
|
||||
runtime 'research-shelf-row-2)
|
||||
:class)
|
||||
"")))
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(etaf-performance-clear)
|
||||
(etaf-performance-start runtime)
|
||||
(let* ((generation-before-on (etaf-runtime-generation runtime))
|
||||
(result-on
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-2 'press))
|
||||
(generation-on (etaf-runtime-generation runtime))
|
||||
(output-on (funcall surface))
|
||||
(operation (car (etaf-performance-records)))
|
||||
(providers
|
||||
(mapcar #'etaf-performance-stage-provider
|
||||
(etaf-performance-operation-stages operation))))
|
||||
(should (equal result-off result-on))
|
||||
(should (= (- generation-off generation-before)
|
||||
(- generation-on generation-before-on)))
|
||||
(should (equal-including-properties output-off output-on))
|
||||
(should (equal providers '(tp ebox etaf)))
|
||||
(should (string-match-p
|
||||
"selected"
|
||||
(or (plist-get
|
||||
(etaf-runtime-host-props-for
|
||||
runtime 'research-shelf-row-2)
|
||||
:class)
|
||||
""))))
|
||||
(etaf-performance-stop runtime)))))
|
||||
|
||||
(ert-deftest etaf-playground-filters-and-pagination-reload-data ()
|
||||
"Filter and pager refs drive the SQLite-backed Data Controller."
|
||||
(etaf-playground-test--with-app (buffer database)
|
||||
(etaf-playground-open buffer)
|
||||
(etaf-playground-test--open buffer)
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
;; Move the selected identity through the old page first. The following
|
||||
;; filter reorders keyed Range items; generated cell Host addresses must
|
||||
@ -566,7 +803,7 @@ database and mounts a test buffer before running BODY."
|
||||
(ert-deftest etaf-playground-workspace-reflows-at-responsive-widths ()
|
||||
"Workspace cards share a row when wide and wrap in document order."
|
||||
(etaf-playground-test--with-app (buffer database)
|
||||
(etaf-playground-open buffer)
|
||||
(etaf-playground-test--open buffer)
|
||||
(cl-labels
|
||||
((line-of (label)
|
||||
(with-current-buffer buffer
|
||||
@ -597,7 +834,7 @@ database and mounts a test buffer before running BODY."
|
||||
(ert-deftest etaf-playground-mutations-persist-and-refresh ()
|
||||
"Add and mutate actions persist through the SQLite source and refresh UI."
|
||||
(etaf-playground-test--with-app (buffer database)
|
||||
(etaf-playground-open buffer)
|
||||
(etaf-playground-test--open buffer)
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-progress 'press)
|
||||
@ -620,7 +857,7 @@ database and mounts a test buffer before running BODY."
|
||||
(ert-deftest etaf-playground-theme-and-lifecycle-are-repeatable ()
|
||||
"Theme changes and reset/close do not leave a stale mounted runtime."
|
||||
(etaf-playground-test--with-app (buffer database)
|
||||
(etaf-playground-open buffer)
|
||||
(etaf-playground-test--open buffer)
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(let (dark-output light-output)
|
||||
|
||||
248
tests/playground-gui-scenarios-tests.el
Normal file
248
tests/playground-gui-scenarios-tests.el
Normal file
@ -0,0 +1,248 @@
|
||||
;;; playground-gui-scenarios-tests.el --- GUI scenario contracts -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; These tests keep the Research Shelf GUI action matrix aligned with the M0a
|
||||
;; evidence claim without running a graphical Emacs session.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(add-to-list 'load-path (expand-file-name "../etaf/scripts" default-directory))
|
||||
(add-to-list 'load-path (expand-file-name "../ebox-playground" default-directory))
|
||||
(require 'playground-gui-scenarios)
|
||||
|
||||
(defvar etaf-research-shelf-database-file)
|
||||
(defvar etaf-research-shelf-fixture-size)
|
||||
(defvar etaf-research-shelf-page-size)
|
||||
|
||||
(defun etaf-playground-gui-test--action (scenario id)
|
||||
"Return SCENARIO action named ID."
|
||||
(cl-find id (etaf-gui-verifier-scenario-actions scenario)
|
||||
:key #'etaf-gui-verifier-action-id :test #'equal))
|
||||
|
||||
(ert-deftest etaf-playground-gui-research-covers-public-action-matrix ()
|
||||
"Research Shelf covers every required public M0a interaction in order."
|
||||
(let* ((scenario (etaf-playground-gui-scenarios-research))
|
||||
(actions (etaf-gui-verifier-scenario-actions scenario)))
|
||||
(should
|
||||
(equal
|
||||
(mapcar #'etaf-gui-verifier-action-id actions)
|
||||
'("mount" "leave-fullscreen" "resize-narrow" "resize-compact"
|
||||
"scroll-down" "reset-scroll" "resize-wide" "row-select"
|
||||
"data-mutation" "filter-reading" "theme-toggle" "pagination"
|
||||
"maximize-frame")))
|
||||
(should
|
||||
(funcall
|
||||
(etaf-gui-verifier-scenario-completion scenario)
|
||||
(etaf-gui-verifier--context-create
|
||||
:scenario scenario :action-count (length actions))))))
|
||||
|
||||
(ert-deftest etaf-playground-gui-research-names-product-assertions ()
|
||||
"Public filter and mutation actions publish specific passing assertions."
|
||||
(let ((database (make-temp-file "etaf-gui-research-" nil ".sqlite"))
|
||||
(buffer " *etaf-gui-research-test*"))
|
||||
(unwind-protect
|
||||
(let* ((etaf-research-shelf-database-file database)
|
||||
(etaf-research-shelf-fixture-size 32)
|
||||
(etaf-research-shelf-page-size 12)
|
||||
(scenario (etaf-playground-gui-scenarios-research))
|
||||
context)
|
||||
(ignore etaf-research-shelf-database-file
|
||||
etaf-research-shelf-fixture-size
|
||||
etaf-research-shelf-page-size)
|
||||
(etaf-playground-mount-example
|
||||
buffer "research-shelf" nil
|
||||
'(:viewport-width 1400 :viewport-height 80))
|
||||
(switch-to-buffer buffer)
|
||||
(setq context
|
||||
(etaf-gui-verifier--context-create
|
||||
:scenario scenario :target-buffer (get-buffer buffer)))
|
||||
(dolist (entry '(("row-select")
|
||||
("data-mutation" . "progress-persisted")
|
||||
("filter-reading" . "reading-filter-applied")))
|
||||
(let ((id (car entry))
|
||||
(assertion-name (cdr entry)))
|
||||
(let ((action
|
||||
(etaf-playground-gui-test--action scenario id)))
|
||||
(should action)
|
||||
(funcall (etaf-gui-verifier-action-execute action) context)
|
||||
(should
|
||||
(funcall
|
||||
(etaf-gui-verifier-action-settled-p action) context))
|
||||
(when assertion-name
|
||||
(let* ((assertions
|
||||
(funcall
|
||||
(etaf-gui-verifier-action-assertions action)
|
||||
context))
|
||||
(assertion
|
||||
(cl-find
|
||||
assertion-name assertions
|
||||
:key (lambda (item) (alist-get 'name item))
|
||||
:test #'equal)))
|
||||
(should assertion)
|
||||
(should (alist-get 'passed assertion))))))))
|
||||
(when (get-buffer buffer)
|
||||
(etaf-playground-close buffer))
|
||||
(when (file-exists-p database)
|
||||
(delete-file database)))))
|
||||
|
||||
(ert-deftest etaf-playground-gui-viewport-noop-keeps-revision-contract ()
|
||||
"Unchanged geometry needs no new revision; an actual resize still does."
|
||||
(let ((context (etaf-gui-verifier--context-create)))
|
||||
(cl-letf (((symbol-function 'etaf-playground-gui-scenarios--report)
|
||||
(lambda (_context) '(:runtime-revision 7)))
|
||||
((symbol-function 'ebox-surface-buffer-revision) (lambda (_) 7))
|
||||
((symbol-function 'frame-parameter) (lambda (&rest _) nil))
|
||||
((symbol-function 'frame-text-width) (lambda (&rest _) 1000))
|
||||
((symbol-function 'frame-text-height) (lambda (&rest _) 700)))
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context nil)
|
||||
(should-not (etaf-gui-verifier-context-get context 'viewport-revision-before))
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context nil 1000 700)
|
||||
(should-not (etaf-gui-verifier-context-get context 'viewport-revision-before))
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context nil 700 500)
|
||||
(should (= (etaf-gui-verifier-context-get context 'viewport-revision-before) 7))
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context 'fullboth)
|
||||
(should (= (etaf-gui-verifier-context-get context 'viewport-revision-before) 7)))))
|
||||
|
||||
(ert-deftest etaf-playground-gui-viewport-noop-settles-after-scroll-report ()
|
||||
"A no-op proves unchanged geometry and revision without a viewport report."
|
||||
(with-temp-buffer
|
||||
(let ((context (etaf-gui-verifier--context-create
|
||||
:target-buffer (current-buffer)))
|
||||
(window (selected-window)) (revision 7)
|
||||
(width 1000) (height 40) (frame-width 1000) (frame-height 700))
|
||||
(cl-letf (((symbol-function 'etaf-playground-gui-scenarios--report)
|
||||
(lambda (_) '(:constraint-source scroll :runtime-revision 6)))
|
||||
((symbol-function 'ebox-surface-buffer-mounted-p) (lambda (_) t))
|
||||
((symbol-function 'ebox-surface-buffer-revision) (lambda (_) revision))
|
||||
((symbol-function 'selected-window) (lambda () window))
|
||||
((symbol-function 'ebox-viewport-window-width) (lambda (_) width))
|
||||
((symbol-function 'window-body-height) (lambda (&rest _) height))
|
||||
((symbol-function 'frame-parameter) (lambda (&rest _) nil))
|
||||
((symbol-function 'frame-text-width) (lambda (&rest _) frame-width))
|
||||
((symbol-function 'frame-text-height) (lambda (&rest _) frame-height))
|
||||
((symbol-function 'etaf-playground-gui-scenarios--visible-window-content-p)
|
||||
(lambda (_) t)))
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context nil)
|
||||
(should (etaf-playground-gui-scenarios--viewport-settled-p context))
|
||||
(let ((assertions (etaf-playground-gui-scenarios--resize-assertions context)))
|
||||
(should (equal "viewport-unchanged" (alist-get 'name (car assertions))))
|
||||
(should (cl-every (lambda (entry) (alist-get 'passed entry)) assertions)))
|
||||
(dolist (change (list (lambda () (setq window 'different-window))
|
||||
(lambda () (cl-incf width))
|
||||
(lambda () (cl-incf height))
|
||||
(lambda () (cl-incf frame-width))
|
||||
(lambda () (cl-incf frame-height))
|
||||
(lambda () (cl-incf revision))))
|
||||
(let ((original-window window))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(funcall change)
|
||||
(should-not (etaf-playground-gui-scenarios--viewport-settled-p context)))
|
||||
(setq window original-window width 1000 height 40
|
||||
frame-width 1000 frame-height 700 revision 7)))
|
||||
(should (etaf-playground-gui-scenarios--viewport-settled-p context)))))))
|
||||
|
||||
(ert-deftest etaf-playground-gui-real-resize-requires-matching-publication ()
|
||||
"An actual resize cannot reuse a stale, absent, or mismatched report."
|
||||
(with-temp-buffer
|
||||
(let ((context (etaf-gui-verifier--context-create
|
||||
:target-buffer (current-buffer)))
|
||||
(frame-width 1000)
|
||||
(revision 37)
|
||||
(report '(:runtime-revision 36 :surface-revision 37)))
|
||||
(cl-letf (((symbol-function 'etaf-playground-gui-scenarios--report)
|
||||
(lambda (_) report))
|
||||
((symbol-function 'ebox-surface-buffer-mounted-p) (lambda (_) t))
|
||||
((symbol-function 'ebox-surface-buffer-revision) (lambda (_) revision))
|
||||
((symbol-function 'frame-parameter) (lambda (&rest _) nil))
|
||||
((symbol-function 'frame-text-width) (lambda (&rest _) frame-width))
|
||||
((symbol-function 'frame-text-height) (lambda (&rest _) 700))
|
||||
((symbol-function 'ebox-viewport-window-width) (lambda (_) 700))
|
||||
((symbol-function 'window-body-height) (lambda (&rest _) 40))
|
||||
((symbol-function 'etaf-playground-gui-scenarios--visible-window-content-p)
|
||||
(lambda (_) t)))
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context nil 700 700)
|
||||
(setq frame-width 700 revision 38)
|
||||
(dolist (invalid '((:runtime-revision 37 :surface-revision 38 :runtime-published t)
|
||||
(:runtime-revision 37 :surface-revision 38
|
||||
:runtime-published t :viewport-width 800)
|
||||
(:runtime-revision 37 :surface-revision 38 :viewport-width 700)
|
||||
(:runtime-revision 37 :surface-revision 38 :runtime-published t
|
||||
:viewport-width 700 :tp-scope-fallback t)
|
||||
;; Neither a stale nor a future report belongs to
|
||||
;; the currently committed surface, regardless of
|
||||
;; its unrelated runtime revision or matching width.
|
||||
(:runtime-revision 99 :surface-revision 37
|
||||
:runtime-published t :viewport-width 700)
|
||||
(:runtime-revision 99 :surface-revision 39
|
||||
:runtime-published t :viewport-width 700)
|
||||
(:runtime-revision 99 :runtime-published t :viewport-width 700)))
|
||||
(setq report (append invalid '(:target-viewport-height 40)))
|
||||
(should-not (etaf-playground-gui-scenarios--viewport-settled-p context)))
|
||||
(setq report '(:runtime-revision 37 :surface-revision 38
|
||||
:runtime-published t :target-viewport-width 700
|
||||
:target-viewport-height 40))
|
||||
(should (etaf-playground-gui-scenarios--viewport-settled-p context))
|
||||
(setq revision 39)
|
||||
(should-not (etaf-playground-gui-scenarios--viewport-settled-p context))
|
||||
(should-not
|
||||
(alist-get 'passed
|
||||
(car (etaf-playground-gui-scenarios--resize-assertions context))))))))
|
||||
|
||||
(ert-deftest etaf-playground-gui-resize-compares-surface-revisions-only ()
|
||||
"GUI runtime37/surface38 succeeds against public before37/after38."
|
||||
(with-temp-buffer
|
||||
(let ((context (etaf-gui-verifier--context-create
|
||||
:target-buffer (current-buffer))))
|
||||
(etaf-gui-verifier-context-put context 'viewport-revision-before 37)
|
||||
(cl-letf (((symbol-function 'etaf-playground-gui-scenarios--report)
|
||||
(lambda (_) '(:runtime-revision 37 :surface-revision 38
|
||||
:runtime-published t :target-viewport-width 686
|
||||
:target-viewport-height 40)))
|
||||
((symbol-function 'ebox-surface-buffer-mounted-p) (lambda (_) t))
|
||||
((symbol-function 'ebox-surface-buffer-revision) (lambda (_) 38))
|
||||
((symbol-function 'ebox-viewport-window-width) (lambda (_) 686))
|
||||
((symbol-function 'window-body-height) (lambda (&rest _) 40))
|
||||
((symbol-function 'etaf-playground-gui-scenarios--frame-target-settled-p)
|
||||
(lambda (_) t))
|
||||
((symbol-function 'etaf-playground-gui-scenarios--visible-window-content-p)
|
||||
(lambda (_) t)))
|
||||
(should (etaf-playground-gui-scenarios--viewport-settled-p context))))))
|
||||
|
||||
(ert-deftest etaf-playground-gui-height-only-resize-requires-current-height ()
|
||||
"A 40-to-25-row resize rejects stale, missing, and nonnumeric target heights."
|
||||
(with-temp-buffer
|
||||
(let ((context (etaf-gui-verifier--context-create
|
||||
:target-buffer (current-buffer)))
|
||||
(height 40) (frame-height 700) (revision 37) report)
|
||||
(cl-letf (((symbol-function 'etaf-playground-gui-scenarios--report)
|
||||
(lambda (_) report))
|
||||
((symbol-function 'ebox-surface-buffer-mounted-p) (lambda (_) t))
|
||||
((symbol-function 'ebox-surface-buffer-revision) (lambda (_) revision))
|
||||
((symbol-function 'frame-parameter) (lambda (&rest _) nil))
|
||||
((symbol-function 'frame-text-width) (lambda (&rest _) 1000))
|
||||
((symbol-function 'frame-text-height) (lambda (&rest _) frame-height))
|
||||
((symbol-function 'ebox-viewport-window-width) (lambda (_) 1000))
|
||||
((symbol-function 'window-body-height) (lambda (&rest _) height))
|
||||
((symbol-function 'etaf-playground-gui-scenarios--visible-window-content-p)
|
||||
(lambda (_) t)))
|
||||
(etaf-playground-gui-scenarios--begin-viewport-change context nil 1000 500)
|
||||
(should (= 37 (etaf-gui-verifier-context-get context 'viewport-revision-before)))
|
||||
(should-not (etaf-gui-verifier-context-get context 'viewport-noop-before))
|
||||
(setq height 25 frame-height 500 revision 38
|
||||
report '(:runtime-published t :surface-revision 38
|
||||
:target-viewport-width 1000 :target-viewport-height 25))
|
||||
(should (etaf-playground-gui-scenarios--viewport-settled-p context))
|
||||
(dolist (height-report '((:target-viewport-height 40)
|
||||
nil (:target-viewport-height "25")
|
||||
(:viewport-height 25)))
|
||||
(setq report (append '(:runtime-published t :surface-revision 38
|
||||
:target-viewport-width 1000)
|
||||
height-report))
|
||||
(should-not (etaf-playground-gui-scenarios--viewport-settled-p context)))))))
|
||||
|
||||
(provide 'playground-gui-scenarios-tests)
|
||||
;;; playground-gui-scenarios-tests.el ends here
|
||||
278
tests/research-shelf-cell-tests.el
Normal file
278
tests/research-shelf-cell-tests.el
Normal file
@ -0,0 +1,278 @@
|
||||
;;; research-shelf-cell-tests.el --- SQLite editing cell acceptance -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Mount the real 256-record application through its public root. UI events
|
||||
;; drive edits; independent SQLite reads prove persistence. Runtime internals
|
||||
;; are inspected only to obtain the example-owned model for invariant checks.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'etaf-research-shelf
|
||||
(expand-file-name "../examples/research-shelf.el"
|
||||
(file-name-directory
|
||||
(or load-file-name
|
||||
(bound-and-true-p byte-compile-current-file)
|
||||
buffer-file-name))))
|
||||
|
||||
(defun research-cell-test--mount (buffer database-file)
|
||||
"Mount a fresh Research App in BUFFER backed by DATABASE-FILE."
|
||||
(let ((etaf-research-shelf-database-file database-file)
|
||||
(etaf-research-shelf-fixture-size 256)
|
||||
(etaf-research-shelf-page-size 12))
|
||||
(etaf-mount
|
||||
buffer
|
||||
(etaf-research-shelf-root
|
||||
(etaf-playground-read-static "research-shelf")
|
||||
(etaf-playground-read-ecss "research-shelf"))
|
||||
'(:viewport-width 1400 :viewport-height 80))
|
||||
(etaf-runtime-for-buffer buffer)))
|
||||
|
||||
(defun research-cell-test--model (runtime)
|
||||
"Return the sole reading list's application model in RUNTIME."
|
||||
(let ((instances
|
||||
(cl-remove-if-not
|
||||
(lambda (instance)
|
||||
(eq 'etaf-research-shelf-reading-list
|
||||
(etaf--component-spec-name
|
||||
(etaf--component-instance-spec instance))))
|
||||
(hash-table-values (etaf-runtime-instances runtime)))))
|
||||
(should (= (length instances) 1))
|
||||
(plist-get (etaf--component-instance-state (car instances)) :model)))
|
||||
|
||||
(defun research-cell-test--control (runtime identity label)
|
||||
"Find the control with LABEL in RUNTIME's row with IDENTITY."
|
||||
(let* ((row (intern (format "research-shelf-row-%d" identity)))
|
||||
(row-id (car (gethash row (etaf-runtime-host-ancestries
|
||||
runtime (list row)))))
|
||||
(entries
|
||||
(cl-remove-if-not
|
||||
(lambda (entry) (equal label (plist-get (cdr entry) :aria-label)))
|
||||
(etaf-runtime-host-props-entries runtime)))
|
||||
(ancestries (etaf-runtime-host-ancestries runtime (mapcar #'car entries))))
|
||||
(should row-id)
|
||||
(setq entries
|
||||
(cl-remove-if-not
|
||||
(lambda (entry) (memq row-id (gethash (car entry) ancestries)))
|
||||
entries))
|
||||
(should (= (length entries) 1))
|
||||
(caar entries)))
|
||||
|
||||
(defun research-cell-test--press (runtime identity label)
|
||||
"Press the control with LABEL in RUNTIME's row with IDENTITY."
|
||||
(etaf-dispatch-event
|
||||
runtime (research-cell-test--control runtime identity label) 'press))
|
||||
|
||||
(defun research-cell-test--row (database-file identity)
|
||||
"Read IDENTITY from DATABASE-FILE through an independent SQLite source."
|
||||
(let* ((etaf-research-shelf-database-file database-file)
|
||||
(source (etaf-sqlite-source (etaf-research-shelf--database))))
|
||||
(car (plist-get (etaf-data-source-load-page source (list :id identity) 1 1)
|
||||
:items))))
|
||||
|
||||
(defun research-cell-test--text (runtime &optional ref)
|
||||
"Return RUNTIME's displayed text, restricted to REF when supplied."
|
||||
(with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(let ((bounds (and ref (etaf-host-ref-bounds runtime ref))))
|
||||
(when ref (should bounds))
|
||||
(buffer-substring-no-properties
|
||||
(if bounds (car bounds) (point-min))
|
||||
(if bounds (cdr bounds) (point-max))))))
|
||||
|
||||
(cl-defmacro research-cell-test--with-app ((runtime database-file) &rest body)
|
||||
"Mount RUNTIME using a temporary DATABASE-FILE, then run BODY and clean up."
|
||||
(declare (indent 1))
|
||||
`(let ((,database-file (make-temp-file "research-cell-" nil ".sqlite")))
|
||||
(unwind-protect
|
||||
(with-temp-buffer
|
||||
(let ((,runtime (research-cell-test--mount (current-buffer)
|
||||
,database-file)))
|
||||
(unwind-protect (progn ,@body)
|
||||
(etaf-unmount ,runtime))))
|
||||
(delete-file ,database-file))))
|
||||
|
||||
(ert-deftest research-shelf-cell-edits-persist-without-selecting-the-row ()
|
||||
"Controlled cells share SQLite updates with detail actions, not selection."
|
||||
(research-cell-test--with-app (runtime database-file)
|
||||
(let* ((model (research-cell-test--model runtime))
|
||||
(data (etaf-research-shelf--controller model)))
|
||||
(should (= (etaf-value (etaf-data-total data)) 256))
|
||||
(should (= (etaf-value (etaf-data-page-size data)) 12))
|
||||
(should (= (length (etaf-value (etaf-data-items data))) 12))
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(let ((star (research-cell-test--control runtime 2 "Star reading")))
|
||||
(should (string-match-p "☐" (research-cell-test--text runtime star)))
|
||||
(research-cell-test--press runtime 2 "Star reading")
|
||||
(should (= (plist-get (research-cell-test--row database-file 2) :starred) 1))
|
||||
(should (equal star (research-cell-test--control runtime 2 "Star reading")))
|
||||
(should (string-match-p "☑" (research-cell-test--text runtime star)))
|
||||
(research-cell-test--press runtime 2 "Star reading")
|
||||
(should (= (plist-get (research-cell-test--row database-file 2) :starred) 0)))
|
||||
(research-cell-test--press runtime 2 "Advance reading")
|
||||
(should (= (plist-get (research-cell-test--row database-file 2) :progress) 10))
|
||||
(should (equal (plist-get (research-cell-test--row database-file 2) :status)
|
||||
"reading"))
|
||||
(should (equal (etaf-value (etaf-data-selection data)) '(1)))
|
||||
(should (equal (plist-get (etaf-data-selected-item data) :title)
|
||||
"The Shape of Tools"))
|
||||
;; A detail edit must refresh the same controlled cell's current props.
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-2 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-star 'press)
|
||||
(should (string-match-p
|
||||
"☑" (research-cell-test--text
|
||||
runtime (research-cell-test--control runtime 2 "Star reading"))))
|
||||
(etaf-dispatch-event runtime 'research-shelf-finish 'press)
|
||||
(let ((advance (research-cell-test--control runtime 2 "Advance reading")))
|
||||
(should (plist-get (etaf-runtime-host-props-for runtime advance) :disabled))
|
||||
(should-error (etaf-dispatch-event runtime advance 'press)
|
||||
:type 'etaf-event-error)
|
||||
(should (= (plist-get (research-cell-test--row database-file 2) :progress) 100)))
|
||||
(etaf-dispatch-event runtime 'research-shelf-row-1 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-archive 'press)
|
||||
(should (plist-get
|
||||
(etaf-runtime-host-props-for
|
||||
runtime (research-cell-test--control runtime 1 "Advance reading"))
|
||||
:disabled)))))
|
||||
|
||||
(ert-deftest research-shelf-edit-controls-have-distinct-column-owners ()
|
||||
"Star and advance controls belong to separate stable Table columns."
|
||||
(research-cell-test--with-app (runtime database-file)
|
||||
(ignore database-file)
|
||||
(let* ((entries (etaf-runtime-host-props-entries runtime))
|
||||
(ancestries
|
||||
(etaf-runtime-host-ancestries runtime (mapcar #'car entries))))
|
||||
(dolist (expected '(("Star reading" . :starred)
|
||||
("Advance reading" . :advance)))
|
||||
(let* ((control (research-cell-test--control runtime 2 (car expected)))
|
||||
(chain (gethash control ancestries))
|
||||
(cell
|
||||
(cl-find-if
|
||||
(lambda (entry)
|
||||
(and (member "etaf-table-cell"
|
||||
(split-string (or (plist-get (cdr entry) :class) "")))
|
||||
(memq (car (gethash (car entry) ancestries)) chain)))
|
||||
entries)))
|
||||
(should cell)
|
||||
(should (eq (cdr expected) (plist-get (cdr cell) :key))))))))
|
||||
|
||||
(ert-deftest research-shelf-cells-follow-filter-page-and-theme ()
|
||||
"Filtered removal and paging recreate cells with current SQLite values."
|
||||
(research-cell-test--with-app (runtime database-file)
|
||||
(let* ((data (etaf-research-shelf--controller
|
||||
(research-cell-test--model runtime))))
|
||||
(etaf-dispatch-event runtime 'research-shelf-filter-starred 'press)
|
||||
(should (= (etaf-value (etaf-data-total data)) 54))
|
||||
(let ((old-star (research-cell-test--control runtime 1 "Star reading")))
|
||||
(research-cell-test--press runtime 1 "Star reading")
|
||||
(should (= (etaf-value (etaf-data-total data)) 53))
|
||||
(should-not (etaf-runtime-host-props-for runtime 'research-shelf-row-1))
|
||||
(should-not (etaf-runtime-host-props-for runtime old-star)))
|
||||
(etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press)
|
||||
(dolist (item (etaf-value (etaf-data-items data)))
|
||||
(should (string-match-p
|
||||
"☑" (research-cell-test--text
|
||||
runtime (research-cell-test--control
|
||||
runtime (plist-get item :id) "Star reading")))))
|
||||
(etaf-dispatch-event runtime 'research-shelf-filter-all 'press)
|
||||
(should (= (etaf-value (etaf-data-total data)) 256))
|
||||
(should (string-match-p
|
||||
"☐" (research-cell-test--text
|
||||
runtime (research-cell-test--control runtime 1 "Star reading"))))
|
||||
(etaf-dispatch-event runtime 'research-shelf-page-next 'press)
|
||||
(should (equal (mapcar #'etaf-research-shelf--item-id
|
||||
(etaf-value (etaf-data-items data)))
|
||||
(number-sequence 13 24)))
|
||||
(research-cell-test--press runtime 13 "Star reading")
|
||||
(research-cell-test--press runtime 13 "Advance reading")
|
||||
(should (= (plist-get (research-cell-test--row database-file 13) :progress) 52))
|
||||
(etaf-dispatch-event runtime 'research-shelf-page-previous 'press)
|
||||
(should (string-match-p
|
||||
"☐" (research-cell-test--text
|
||||
runtime (research-cell-test--control runtime 1 "Star reading"))))
|
||||
(etaf-dispatch-event runtime 'research-shelf-page-next 'press)
|
||||
(etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press)
|
||||
(should (string-match-p
|
||||
"☑" (research-cell-test--text
|
||||
runtime (research-cell-test--control runtime 13 "Star reading"))))
|
||||
(research-cell-test--press runtime 13 "Advance reading")
|
||||
(should (= (plist-get (research-cell-test--row database-file 13) :progress) 62)))))
|
||||
|
||||
(ert-deftest research-shelf-cell-sqlite-abort-reloads-the-controlled-value ()
|
||||
"A real SQLite abort preserves the record; Reload restores editable cells."
|
||||
(research-cell-test--with-app (runtime database-file)
|
||||
(let ((before (research-cell-test--row database-file 2))
|
||||
(connection (sqlite-open database-file)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(sqlite-execute
|
||||
connection
|
||||
"CREATE TRIGGER reject_cell_edit BEFORE UPDATE ON reading_items
|
||||
WHEN NEW.id = 2 BEGIN SELECT RAISE(ABORT, 'cell write rejected'); END")
|
||||
(research-cell-test--press runtime 2 "Star reading")
|
||||
(should (equal before (research-cell-test--row database-file 2)))
|
||||
(should (string-match-p "Could not save" (research-cell-test--text runtime)))
|
||||
(should (string-match-p "Use Reload" (research-cell-test--text runtime)))
|
||||
(etaf-dispatch-event runtime 'research-shelf-reload 'press)
|
||||
(should (string-match-p
|
||||
"☐" (research-cell-test--text
|
||||
runtime (research-cell-test--control runtime 2 "Star reading"))))
|
||||
(research-cell-test--press runtime 2 "Advance reading")
|
||||
(should (equal before (research-cell-test--row database-file 2)))
|
||||
(should (string-match-p "Could not save" (research-cell-test--text runtime)))
|
||||
(sqlite-execute connection "DROP TRIGGER reject_cell_edit")
|
||||
(etaf-dispatch-event runtime 'research-shelf-reload 'press)
|
||||
(research-cell-test--press runtime 2 "Star reading")
|
||||
(research-cell-test--press runtime 2 "Advance reading")
|
||||
(should (= (plist-get (research-cell-test--row database-file 2) :starred) 1))
|
||||
(should (= (plist-get (research-cell-test--row database-file 2) :progress) 10))
|
||||
(should (string-match-p
|
||||
"☑" (research-cell-test--text
|
||||
runtime (research-cell-test--control runtime 2 "Star reading")))))
|
||||
(sqlite-close connection)))))
|
||||
|
||||
(ert-deftest research-shelf-cell-component-reuses-across-independent-apps ()
|
||||
"One cell definition resolves each App's own Context, including remounts."
|
||||
(research-cell-test--with-app (left left-file)
|
||||
(research-cell-test--with-app (right right-file)
|
||||
(let ((right-text (research-cell-test--text right))
|
||||
(left-data (etaf-research-shelf--controller
|
||||
(research-cell-test--model left)))
|
||||
(right-data (etaf-research-shelf--controller
|
||||
(research-cell-test--model right))))
|
||||
(should-not (eq left-data right-data))
|
||||
(dolist (data (list left-data right-data))
|
||||
(should (= (etaf-value (etaf-data-total data)) 256))
|
||||
(should (= (length (etaf-value (etaf-data-items data))) 12)))
|
||||
(etaf-dispatch-event left 'research-shelf-row-1 'press)
|
||||
(research-cell-test--press left 2 "Star reading")
|
||||
(research-cell-test--press left 2 "Advance reading")
|
||||
(should (equal right-text (research-cell-test--text right)))
|
||||
(should (= (plist-get (research-cell-test--row right-file 2) :starred) 0))
|
||||
(should (= (plist-get (research-cell-test--row right-file 2) :progress) 0))
|
||||
(should (equal (etaf-value (etaf-data-selection left-data)) '(1)))
|
||||
(should-not (etaf-value (etaf-data-selection right-data)))
|
||||
(etaf-dispatch-event right 'research-shelf-theme-toggle 'press)
|
||||
(research-cell-test--press right 1 "Star reading")
|
||||
(should (= (plist-get (research-cell-test--row left-file 1) :starred) 1))
|
||||
(should (= (plist-get (research-cell-test--row right-file 1) :starred) 0))
|
||||
(let ((old-left left)
|
||||
(buffer (etaf-runtime-buffer left)))
|
||||
(etaf-unmount left)
|
||||
(should-not (etaf-runtime-mounted-p old-left))
|
||||
(should-not (etaf-runtime-for-buffer buffer))
|
||||
(research-cell-test--press right 2 "Advance reading")
|
||||
(should (= (plist-get (research-cell-test--row right-file 2) :progress) 10))
|
||||
(setq left (research-cell-test--mount buffer left-file))
|
||||
(should-not (eq left old-left))
|
||||
(should (= (plist-get (research-cell-test--row left-file 2) :progress) 10))
|
||||
(should (string-match-p
|
||||
"☑" (research-cell-test--text
|
||||
left (research-cell-test--control left 2 "Star reading"))))
|
||||
(research-cell-test--press left 2 "Advance reading")
|
||||
(should (= (plist-get (research-cell-test--row left-file 2) :progress) 20))
|
||||
(should (= (plist-get (research-cell-test--row right-file 2) :progress) 10)))))))
|
||||
|
||||
(provide 'research-shelf-cell-tests)
|
||||
;;; research-shelf-cell-tests.el ends here
|
||||
240
tests/research-shelf-m0a-evidence-tests.el
Normal file
240
tests/research-shelf-m0a-evidence-tests.el
Normal file
@ -0,0 +1,240 @@
|
||||
;;; research-shelf-m0a-evidence-tests.el --- Research Shelf M0a tests -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
(require 'ert)
|
||||
(defvar etaf-playground-m0a-evidence-schema)
|
||||
(declare-function etaf-playground-m0a-capture-baseline
|
||||
"../scripts/research-shelf-m0a-evidence")
|
||||
(declare-function etaf-playground-m0a-capture-baseline-batch
|
||||
"../scripts/research-shelf-m0a-evidence")
|
||||
(load-file (expand-file-name "scripts/research-shelf-m0a-evidence.el"
|
||||
default-directory))
|
||||
|
||||
(defmacro etaf-playground-m0a-test--with-baseline (variable &rest body)
|
||||
"Bind VARIABLE to a fresh Research Shelf baseline while running BODY."
|
||||
(declare (indent 1))
|
||||
`(let ((database (make-temp-file "research-shelf-m0a-" nil ".sqlite"))
|
||||
(buffer (generate-new-buffer-name " *research-shelf-m0a*")))
|
||||
(unwind-protect
|
||||
(let ((,variable
|
||||
(etaf-playground-m0a-capture-baseline database buffer)))
|
||||
,@body)
|
||||
(when (get-buffer buffer) (kill-buffer buffer))
|
||||
(when (file-exists-p database) (delete-file database)))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-schema-separates-evidence-lanes ()
|
||||
"Define package-local semantic/trace evidence without conflating GUI timing."
|
||||
(dolist (key '(:semantic :text-properties :identity :lifecycle :sqlite
|
||||
:performance :gui-first-paint))
|
||||
(should (plist-member etaf-playground-m0a-evidence-schema key)))
|
||||
(should
|
||||
(eq 'observed-gap
|
||||
(plist-get
|
||||
(plist-get etaf-playground-m0a-evidence-schema :gui-first-paint)
|
||||
:status))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-baseline-captures-five-current-contracts ()
|
||||
"Capture semantic, text/property, identity, lifecycle, and SQLite evidence."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(should (= 64 (length (plist-get (plist-get baseline :text-properties)
|
||||
:text-sha256))))
|
||||
(should (> (plist-get (plist-get baseline :text-properties)
|
||||
:property-run-count)
|
||||
0))
|
||||
(should (> (plist-get (plist-get baseline :semantic) :identity-count) 0))
|
||||
(should (memq 'research-shelf-row-2
|
||||
(plist-get (plist-get baseline :identity) :handler-refs)))
|
||||
(should (equal '(mounted unmounted buffer-killed)
|
||||
(mapcar (lambda (entry) (plist-get entry :event))
|
||||
(plist-get baseline :lifecycle))))
|
||||
(should (equal 'sqlite
|
||||
(plist-get (plist-get baseline :sqlite) :provider)))
|
||||
(should (= 256 (plist-get (plist-get baseline :sqlite) :total)))
|
||||
(should (equal '(1 2 3 4 5 6 7 8)
|
||||
(plist-get (plist-get baseline :sqlite) :item-ids)))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-records-observed-public-fields ()
|
||||
"Record fields actually obtainable for every current scenario report."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let ((performance (plist-get scenario :public-report-fields)))
|
||||
(dolist (field '(operation-id operation-kind elapsed-ms
|
||||
generation-before generation-after
|
||||
provider-stages gc-count gc-duration-ms))
|
||||
(should (eq 'observed (plist-get (cdr (assq field performance))
|
||||
:status))))
|
||||
(dolist (field '(tp-text-operations tp-property-operations
|
||||
tp-reconciled-objects
|
||||
tp-created-objects
|
||||
tp-removed-objects tp-moved-objects
|
||||
tp-full-root tp-scope-count
|
||||
tp-scope-fallback dirty-count
|
||||
patch-count))
|
||||
(should (memq (plist-get (cdr (assq field performance)) :status)
|
||||
'(observed observed-gap))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-observes-required-work-fields ()
|
||||
"Observe current cost, reactive turn, and semantic work for every scenario."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let ((performance (plist-get scenario :public-report-fields)))
|
||||
(dolist (field '(cost-class changed-sources queued-effects
|
||||
evaluated-effects turn-count turn-index
|
||||
turn-epoch semantic-nodes-visited
|
||||
semantic-nodes-changed
|
||||
semantic-nodes-reused semantic-nodes-created
|
||||
semantic-nodes-removed
|
||||
ebox-nodes-materialized full-path-reason))
|
||||
(should (eq 'observed
|
||||
(plist-get (cdr (assq field performance)) :status))))
|
||||
(dolist (field '(turn-count semantic-nodes-visited
|
||||
semantic-nodes-changed
|
||||
semantic-nodes-reused semantic-nodes-created
|
||||
semantic-nodes-removed
|
||||
ebox-nodes-materialized))
|
||||
(should (natnump
|
||||
(plist-get (cdr (assq field performance)) :value))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-observes-tp-zero-work ()
|
||||
"Distinguish a non-participating TP stage from missing observation."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let ((performance (plist-get scenario :public-report-fields)))
|
||||
(dolist (field '(tp-text-operations tp-property-operations
|
||||
tp-reconciled-objects
|
||||
tp-created-objects
|
||||
tp-removed-objects tp-moved-objects))
|
||||
(should (eq 'observed
|
||||
(plist-get (cdr (assq field performance)) :status)))
|
||||
(should (natnump
|
||||
(plist-get (cdr (assq field performance)) :value))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-work-counters-are-self-consistent ()
|
||||
"Lock the harness counter identities without imposing future budgets."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(dolist (scenario
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(let* ((fields (plist-get scenario :public-report-fields))
|
||||
(value (lambda (field)
|
||||
(plist-get (cdr (assq field fields)) :value)))
|
||||
(changed (funcall value 'changed-sources))
|
||||
(queued (funcall value 'queued-effects))
|
||||
(evaluated (funcall value 'evaluated-effects))
|
||||
(visited (funcall value 'semantic-nodes-visited)))
|
||||
(should (= (plist-get changed :count)
|
||||
(length (plist-get changed :ids))))
|
||||
(should (= (plist-get queued :count)
|
||||
(length (plist-get queued :ids))))
|
||||
(should (= (plist-get evaluated :count)
|
||||
(length (plist-get evaluated :ids))))
|
||||
(should (= (funcall value 'turn-count)
|
||||
(length (funcall value 'turn-index))))
|
||||
(should (= (funcall value 'turn-count)
|
||||
(length (funcall value 'turn-epoch))))
|
||||
(should (= visited
|
||||
(+ (funcall value 'semantic-nodes-changed)
|
||||
(funcall value 'semantic-nodes-reused)
|
||||
(funcall value 'semantic-nodes-created))))
|
||||
(should (or (eq 'not-full-path
|
||||
(funcall value 'full-path-reason))
|
||||
(eq 'full (funcall value 'cost-class))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-covers-required-scenario-matrix ()
|
||||
"Cover Data, style, viewport, and dependency-only current paths."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(let ((matrix
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix)))
|
||||
(should
|
||||
(equal '(data-mutation semantic-style viewport-scroll data-load-error
|
||||
dependency-only scroll)
|
||||
(mapcar (lambda (scenario) (plist-get scenario :category))
|
||||
matrix)))
|
||||
(dolist (scenario matrix)
|
||||
(should (eq 'm0a-trace (plist-get scenario :operation-kind)))
|
||||
(should (stringp (plist-get scenario :operation-label)))
|
||||
(should (eq 'observed-gap
|
||||
(plist-get (plist-get scenario :gui-first-paint)
|
||||
:status)))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-performance-observes-allocation-and-metrics ()
|
||||
"Observe harness allocation and honest candidate-index metrics."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(let ((matrix
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix)))
|
||||
(dolist (scenario matrix)
|
||||
(let* ((fields (plist-get scenario :public-report-fields))
|
||||
(allocation (cdr (assq 'allocation fields))))
|
||||
(should (eq 'observed (plist-get allocation :status)))
|
||||
(should (eq 'memory-use-counts
|
||||
(plist-get (plist-get allocation :value) :api)))
|
||||
(should (listp (plist-get (plist-get allocation :value) :delta)))))
|
||||
(let* ((mutation (car matrix))
|
||||
(fields (plist-get mutation :public-report-fields)))
|
||||
(dolist (field '(candidate-index-node-visits
|
||||
candidate-index-node-copies
|
||||
candidate-effect-index-visits
|
||||
candidate-source-index-visits
|
||||
committed-generation-delta))
|
||||
(should (eq 'observed
|
||||
(plist-get (cdr (assq field fields)) :status))))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-load-error-and-scroll-lock-current-facts ()
|
||||
"Lock isolated load-error facts and a real advancing public scroll owner."
|
||||
(etaf-playground-m0a-test--with-baseline baseline
|
||||
(let* ((matrix
|
||||
(plist-get (plist-get baseline :performance) :scenario-matrix))
|
||||
(load-error
|
||||
(seq-find (lambda (scenario)
|
||||
(eq 'data-load-error
|
||||
(plist-get scenario :category)))
|
||||
matrix))
|
||||
(scroll
|
||||
(seq-find (lambda (scenario)
|
||||
(eq 'scroll (plist-get scenario :category)))
|
||||
matrix))
|
||||
(load-fields (plist-get load-error :public-report-fields)))
|
||||
(should (symbolp (plist-get (plist-get load-error :result) :condition)))
|
||||
(should
|
||||
(= (plist-get (cdr (assq 'generation-before load-fields)) :value)
|
||||
(plist-get (cdr (assq 'generation-after load-fields)) :value)))
|
||||
(should (plist-get (plist-get scroll :current-facts)
|
||||
:region-id-present))
|
||||
(should (> (plist-get (plist-get scroll :current-facts) :offset-after)
|
||||
(plist-get (plist-get scroll :current-facts)
|
||||
:offset-before))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-baseline-stable-projections-are-reproducible ()
|
||||
"Reproduce stable semantic/text/identity/SQLite projections twice."
|
||||
(etaf-playground-m0a-test--with-baseline first
|
||||
(etaf-playground-m0a-test--with-baseline second
|
||||
(dolist (key '(:semantic :text-properties :identity :lifecycle :sqlite))
|
||||
(should (equal (plist-get first key) (plist-get second key)))))))
|
||||
|
||||
(ert-deftest etaf-playground-m0a-batch-writes-semantic-evidence-summary ()
|
||||
"Persist raw package-local evidence plus a machine-readable summary."
|
||||
(let* ((directory (make-temp-file "m0a-semantic-output-" t))
|
||||
(output (expand-file-name "semantic.eld" directory))
|
||||
(metadata (expand-file-name "semantic.json" directory))
|
||||
(process-environment (copy-sequence process-environment)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(setenv "ETAF_M0A_SEMANTIC_OUTPUT" output)
|
||||
(setenv "ETAF_M0A_SEMANTIC_METADATA" metadata)
|
||||
(should (etaf-playground-m0a-capture-baseline-batch))
|
||||
(should (> (file-attribute-size (file-attributes output)) 0))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents metadata)
|
||||
(let ((record
|
||||
(json-parse-buffer :object-type 'plist
|
||||
:array-type 'list)))
|
||||
(should (= 6 (plist-get record :scenario_count)))
|
||||
(should (= 1 (plist-get record :schema_version)))
|
||||
(should (eq t (plist-get record
|
||||
:required_work_fields_observed))))))
|
||||
(delete-directory directory t))))
|
||||
|
||||
(provide 'research-shelf-m0a-evidence-tests)
|
||||
;;; research-shelf-m0a-evidence-tests.el ends here
|
||||
113
tests/task-workbench-gui-scenarios-tests.el
Normal file
113
tests/task-workbench-gui-scenarios-tests.el
Normal file
@ -0,0 +1,113 @@
|
||||
;;; task-workbench-gui-scenarios-tests.el --- Workbench measurement order -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Batch tests prove the adapter's message/paint/measurement ordering. Actual
|
||||
;; echo-area resizing and compositor geometry require the existing GUI run.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(add-to-list 'load-path (expand-file-name "../etaf/scripts" default-directory))
|
||||
(add-to-list 'load-path (expand-file-name "../ebox-playground" default-directory))
|
||||
(require 'task-workbench-gui-scenarios)
|
||||
|
||||
(ert-deftest wb-gui-preparation-preserves-focus-unless-requested ()
|
||||
"Preparation selects the target inside Emacs without activating the app."
|
||||
(let ((wb-gui--primary-name " *wb-gui-focus-fixture*")
|
||||
(wb-gui--secondary-name " *wb-gui-focus-secondary*")
|
||||
(wb-gui--prepared-buffer nil)
|
||||
(activations 0))
|
||||
(save-window-excursion
|
||||
(unwind-protect
|
||||
(cl-letf (((symbol-function 'display-graphic-p) (lambda (&rest _) t))
|
||||
((symbol-function 'wb-gui--configure-native) #'ignore)
|
||||
((symbol-function 'wb-gui--redisplay-for-geometry) #'ignore)
|
||||
((symbol-function 'select-frame-set-input-focus)
|
||||
(lambda (&rest _) (cl-incf activations))))
|
||||
(dolist (foreground '(nil t))
|
||||
(let ((buffer (task-workbench-gui-prepare foreground)))
|
||||
(should (eq buffer (window-buffer (selected-window))))
|
||||
(should (= activations (if foreground 1 0)))
|
||||
(kill-buffer buffer))))
|
||||
(when (buffer-live-p wb-gui--prepared-buffer)
|
||||
(kill-buffer wb-gui--prepared-buffer))))))
|
||||
|
||||
(ert-deftest wb-gui-default-keeps-current-backend ()
|
||||
"An existing GUI without a native module remains a valid acceptance target."
|
||||
(let ((process-environment (copy-sequence process-environment))
|
||||
(ebox-native-reflow-module-path "/existing/module/location"))
|
||||
(setenv "EBOX_NATIVE_REFLOW_MODULE_PATH" nil)
|
||||
(cl-letf (((symbol-function 'ebox-native-reflow-runtime-report)
|
||||
(lambda () '(:layout-ready-p nil :load-error module-not-found))))
|
||||
(should (equal (wb-gui--configure-native)
|
||||
'(:layout-ready-p nil :load-error module-not-found)))
|
||||
(should (equal ebox-native-reflow-module-path "/existing/module/location")))))
|
||||
|
||||
(ert-deftest wb-gui-explicit-native-request-remains-required ()
|
||||
"An explicit native request must not silently fall back or change modules."
|
||||
(let ((process-environment (copy-sequence process-environment))
|
||||
(ebox-native-reflow-module-path nil)
|
||||
(report '(:layout-ready-p nil :load-error module-not-found)))
|
||||
(setenv "EBOX_NATIVE_REFLOW_MODULE_PATH" "/requested/module")
|
||||
(cl-letf (((symbol-function 'file-readable-p) (lambda (_) t))
|
||||
((symbol-function 'file-directory-p) (lambda (_) nil))
|
||||
((symbol-function 'file-equal-p) #'equal)
|
||||
((symbol-function 'ebox-native-reflow-runtime-report)
|
||||
(lambda () report)))
|
||||
(should-error (wb-gui--configure-native))
|
||||
(setq report '(:layout-ready-p t :loaded-module-path "/different/module"))
|
||||
(should-error (wb-gui--configure-native))
|
||||
(setq report '(:layout-ready-p t :loaded-module-path "/requested/module"))
|
||||
(should (equal report (wb-gui--configure-native))))))
|
||||
|
||||
(ert-deftest wb-gui-empty-native-request-is-invalid ()
|
||||
"An empty configured path is an error, rather than the default backend."
|
||||
(let ((process-environment (copy-sequence process-environment)))
|
||||
(setenv "EBOX_NATIVE_REFLOW_MODULE_PATH" "")
|
||||
(should-error (wb-gui--configure-native))))
|
||||
|
||||
(ert-deftest wb-gui-theme-baseline-clears-owned-message-before-paint ()
|
||||
"The first baseline measurement follows clearing and painting our diagnostic."
|
||||
(let ((context (etaf-gui-verifier--context-create))
|
||||
(echo-message (concat "Workbench GUI native module: " (make-string 300 ?x)))
|
||||
(bottom 797)
|
||||
trace)
|
||||
(cl-letf (((symbol-function 'current-message) (lambda () echo-message))
|
||||
((symbol-function 'message)
|
||||
(lambda (format &rest _)
|
||||
(should-not format)
|
||||
(setq echo-message nil)
|
||||
(push 'clear trace)))
|
||||
((symbol-function 'redisplay)
|
||||
(lambda (&rest _)
|
||||
(setq bottom (if echo-message 797 813))
|
||||
(push 'paint trace)))
|
||||
((symbol-function 'sit-for) (lambda (&rest _) (push 'wait trace)))
|
||||
((symbol-function 'wb-gui--layout-snapshot)
|
||||
(lambda (_)
|
||||
(push 'measure trace)
|
||||
(list :viewport (list 0 0 991 bottom) :controls '((title 0 0))))))
|
||||
(wb-gui--capture-theme-baseline context)
|
||||
(should (equal '(clear paint measure wait paint measure) (nreverse trace)))
|
||||
(should (equal '(0 0 991 813)
|
||||
(plist-get (etaf-gui-verifier-context-get context 'light-layout)
|
||||
:viewport)))
|
||||
(should (wb-gui--theme-layout-preserved-p context))
|
||||
;; Later viewport differences remain a failure, even with identical controls.
|
||||
(setq bottom 797)
|
||||
(should-not (wb-gui--theme-layout-preserved-p context)))))
|
||||
|
||||
(ert-deftest wb-gui-geometry-paint-preserves-unowned-messages ()
|
||||
"Geometry preparation clears only this adapter's own diagnostic."
|
||||
(let ((paints 0))
|
||||
(cl-letf (((symbol-function 'current-message) (lambda () "A user message"))
|
||||
((symbol-function 'message)
|
||||
(lambda (&rest _) (ert-fail "Cleared an unrelated message")))
|
||||
((symbol-function 'redisplay) (lambda (&rest _) (cl-incf paints))))
|
||||
(wb-gui--redisplay-for-geometry)
|
||||
(should (= paints 1)))))
|
||||
|
||||
(provide 'task-workbench-gui-scenarios-tests)
|
||||
;;; task-workbench-gui-scenarios-tests.el ends here
|
||||
528
tests/task-workbench-tests.el
Normal file
528
tests/task-workbench-tests.el
Normal file
@ -0,0 +1,528 @@
|
||||
;;; task-workbench-tests.el --- Workbench acceptance preflight -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; Exercise the complete example through mounted public event entry points.
|
||||
;; Minibuffer readers are stubbed only in this batch preflight. Real input,
|
||||
;; redisplay, layout, and screenshots belong to task-workbench-gui-scenarios.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'ert)
|
||||
(require 'task-workbench
|
||||
(expand-file-name "../examples/task-workbench.el"
|
||||
(file-name-directory
|
||||
(or load-file-name
|
||||
(bound-and-true-p byte-compile-current-file)
|
||||
buffer-file-name))))
|
||||
|
||||
(defun wb-test--instance (runtime name)
|
||||
"Return RUNTIME's sole component instance named NAME."
|
||||
(let ((instances
|
||||
(cl-remove-if-not
|
||||
(lambda (instance)
|
||||
(eq name (etaf--component-spec-name
|
||||
(etaf--component-instance-spec instance))))
|
||||
(hash-table-values (etaf-runtime-instances runtime)))))
|
||||
(should (= (length instances) 1))
|
||||
(car instances)))
|
||||
|
||||
(defun wb-test--data (runtime)
|
||||
"Read RUNTIME's example-owned controller for result assertions."
|
||||
(plist-get (etaf--component-instance-state
|
||||
(wb-test--instance runtime 'wb-app)) :data))
|
||||
|
||||
(defun wb-test--text (runtime)
|
||||
"Return RUNTIME's rendered plain text."
|
||||
(with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(buffer-substring-no-properties (point-min) (point-max))))
|
||||
|
||||
(defun wb-test--row (runtime identity)
|
||||
"Return the semantic row reference for IDENTITY in RUNTIME."
|
||||
(let ((entry
|
||||
(cl-find-if
|
||||
(lambda (entry)
|
||||
(and (equal (plist-get (cdr entry) :key) identity)
|
||||
(member "etaf-table-row"
|
||||
(split-string (or (plist-get (cdr entry) :class) "")))))
|
||||
(etaf-runtime-host-props-entries runtime))))
|
||||
(should entry)
|
||||
(car entry)))
|
||||
|
||||
(defun wb-test--control (runtime label &optional parent)
|
||||
"Return RUNTIME control with aria LABEL, optionally inside PARENT."
|
||||
(let* ((entries
|
||||
(cl-remove-if-not
|
||||
(lambda (entry) (equal (plist-get (cdr entry) :aria-label) label))
|
||||
(etaf-runtime-host-props-entries runtime)))
|
||||
(ancestries (and parent
|
||||
(etaf-runtime-host-ancestries runtime
|
||||
(mapcar #'car entries))))
|
||||
(parent-id (and parent
|
||||
(car (gethash parent
|
||||
(etaf-runtime-host-ancestries
|
||||
runtime (list parent)))))))
|
||||
(when parent
|
||||
(setq entries
|
||||
(cl-remove-if-not
|
||||
(lambda (entry) (memq parent-id (gethash (car entry) ancestries)))
|
||||
entries)))
|
||||
(should (= (length entries) 1))
|
||||
(caar entries)))
|
||||
|
||||
(defun wb-test--press (runtime label &optional parent)
|
||||
"Press RUNTIME control with LABEL, optionally inside PARENT."
|
||||
(etaf-dispatch-event runtime (wb-test--control runtime label parent) 'press))
|
||||
|
||||
(defun wb-test--ids (data)
|
||||
"Return the currently loaded identities from DATA."
|
||||
(mapcar #'wb-task-id (etaf-value (etaf-data-items data))))
|
||||
|
||||
(defun wb-test--layout-bounds (runtime)
|
||||
"Snapshot public bounds across RUNTIME's toolbar, panels, and ten rows."
|
||||
(mapcar
|
||||
(lambda (entry)
|
||||
(let ((bounds (etaf-host-ref-bounds runtime (cdr entry))))
|
||||
(should bounds)
|
||||
(cons (car entry) (copy-tree bounds))))
|
||||
(append
|
||||
(mapcar (lambda (label) (cons label (wb-test--control runtime label)))
|
||||
'("新增任务" "深色" "定位新增按钮" "全部" "未完成" "已完成"
|
||||
"搜索" "每页条数 10 ✎" "显示说明" "刷新 / 重试" "模拟失败"))
|
||||
(mapcar (lambda (identity) (cons identity (wb-test--row runtime identity)))
|
||||
(number-sequence 1 10)))))
|
||||
|
||||
(defun wb-test--line-widths (runtime)
|
||||
"Return measured widths of RUNTIME's rendered lines, including display props."
|
||||
(with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(mapcar #'ebox-string-pixel-width (split-string (buffer-string) "\n" nil))))
|
||||
|
||||
(defun wb-test--desktop-header-inline-p (runtime)
|
||||
"Return non-nil when RUNTIME's desktop title and toolbar share a line."
|
||||
(with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(save-excursion
|
||||
(goto-char (point-min))
|
||||
(unless (search-forward "任务工作台" nil t) (error "Workbench title is absent"))
|
||||
(= (line-number-at-pos)
|
||||
(line-number-at-pos
|
||||
(etaf-host-ref-position runtime (wb-test--control runtime "新增任务")))))))
|
||||
|
||||
(defun wb-test--card-layout (runtime control-label)
|
||||
"Return public bounds and line geometry for CONTROL-LABEL's card in RUNTIME."
|
||||
(let* ((control (wb-test--control runtime control-label))
|
||||
(panels
|
||||
(cl-remove-if-not
|
||||
(lambda (entry)
|
||||
(let ((classes (plist-get (cdr entry) :class)))
|
||||
(member "etaf-panel"
|
||||
(if (stringp classes) (split-string classes) classes))))
|
||||
(etaf-runtime-host-props-entries runtime)))
|
||||
(ancestries (etaf-runtime-host-ancestries
|
||||
runtime (cons control (mapcar #'car panels))))
|
||||
(matches
|
||||
(cl-remove-if-not
|
||||
(lambda (entry)
|
||||
(memq (car (gethash (car entry) ancestries))
|
||||
(gethash control ancestries)))
|
||||
panels)))
|
||||
(should (= (length matches) 1))
|
||||
(let* ((host (caar matches))
|
||||
(bounds (etaf-host-ref-bounds runtime host)))
|
||||
(should bounds)
|
||||
(should (< (car bounds) (cdr bounds)))
|
||||
(with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(let ((top (line-number-at-pos (car bounds)))
|
||||
(bottom (line-number-at-pos (1- (cdr bounds)))))
|
||||
(list :host host :bounds (copy-tree bounds)
|
||||
:top top :bottom bottom :height (1+ (- bottom top))
|
||||
:left
|
||||
(save-excursion
|
||||
(goto-char (car bounds))
|
||||
(ebox-string-pixel-width
|
||||
(buffer-substring (line-beginning-position) (point))))))))))
|
||||
|
||||
(cl-defmacro wb-test--with-app ((runtime data &optional viewport-width) &rest body)
|
||||
"Mount RUNTIME and DATA at optional VIEWPORT-WIDTH, then execute BODY."
|
||||
(declare (indent 1))
|
||||
`(with-temp-buffer
|
||||
(let (,runtime ,data)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount (current-buffer) (etaf-view (wb-app))
|
||||
(list :viewport-width (or ,viewport-width 1600)
|
||||
:viewport-height 80))
|
||||
(setq ,runtime (etaf-runtime-for-buffer (current-buffer))
|
||||
,data (wb-test--data ,runtime))
|
||||
,@body)
|
||||
(when-let* ((mounted (etaf-runtime-for-buffer (current-buffer))))
|
||||
(etaf-unmount mounted))))))
|
||||
|
||||
(ert-deftest wb-workbench-mounts-composed-app ()
|
||||
"Slots, custom cells, resource, and summary all survive a full mount."
|
||||
(wb-test--with-app (runtime data)
|
||||
(should (etaf-runtime-mounted-p runtime))
|
||||
(should (equal (wb-test--ids data) (number-sequence 1 10)))
|
||||
(should (= (etaf-value (etaf-data-total data)) 100))
|
||||
(should (= (etaf-value (etaf-data-page-size data)) 10))
|
||||
(dolist (label '("任务工作台" "筛选" "设计组件接口" "检查状态隔离"
|
||||
"点击任务行查看详情" "服务正常" "共 100 条 · 当前页 10 条"))
|
||||
(should (string-match-p (regexp-quote label) (wb-test--text runtime))))
|
||||
(dolist (identity (number-sequence 1 10))
|
||||
(let ((row (wb-test--row runtime identity)))
|
||||
(should (wb-test--control runtime "完成" row))
|
||||
(should (wb-test--control runtime "删除" row))))
|
||||
(should (plist-get (etaf-runtime-host-props-for
|
||||
runtime (wb-test--control runtime "Previous page"))
|
||||
:disabled))))
|
||||
|
||||
(ert-deftest wb-workbench-filter-search-and-pagination ()
|
||||
"Filter and search reset paging; both pager directions update rows."
|
||||
(wb-test--with-app (runtime data)
|
||||
(wb-test--press runtime "Next page")
|
||||
(should (= (etaf-value (etaf-data-page data)) 2))
|
||||
(should (equal (wb-test--ids data) (number-sequence 11 20)))
|
||||
(wb-test--press runtime "Previous page")
|
||||
(should (equal (wb-test--ids data) (number-sequence 1 10)))
|
||||
(wb-test--press runtime "未完成")
|
||||
(should (equal (wb-test--ids data) '(1 2 4 6 7 9 10 11 13 14)))
|
||||
(should (= (etaf-value (etaf-data-total data)) 74))
|
||||
(wb-test--press runtime "已完成")
|
||||
(should (equal (wb-test--ids data) '(3 5 8 12 16 20 24 28 32 36)))
|
||||
(should (= (etaf-value (etaf-data-total data)) 26))
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "键盘")))
|
||||
(wb-test--press runtime "搜索"))
|
||||
(should (equal (wb-test--ids data) '(4)))
|
||||
(should (= (etaf-value (etaf-data-page data)) 1))
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "不存在的任务")))
|
||||
(wb-test--press runtime "搜索"))
|
||||
(should-not (wb-test--ids data))
|
||||
(should (string-match-p "没有匹配的任务" (wb-test--text runtime)))
|
||||
(wb-test--press runtime "全部")
|
||||
(should (equal (wb-test--ids data) (number-sequence 1 10)))
|
||||
(should (= (etaf-value (etaf-data-total data)) 100))))
|
||||
|
||||
(ert-deftest wb-workbench-page-size-validates-and-reloads ()
|
||||
"The NumberInput's public press callback applies valid input only."
|
||||
(wb-test--with-app (runtime data)
|
||||
(wb-test--press runtime "Next page")
|
||||
(cl-letf (((symbol-function 'read-number) (lambda (&rest _) 2)))
|
||||
(wb-test--press runtime "每页条数 10 ✎"))
|
||||
(should (= (etaf-value (etaf-data-page-size data)) 2))
|
||||
(should (= (etaf-value (etaf-data-page data)) 1))
|
||||
(should (equal (wb-test--ids data) '(1 2)))
|
||||
(should (string-match-p "Page 1 / 50" (wb-test--text runtime)))
|
||||
(cl-letf (((symbol-function 'read-number) (lambda (&rest _) 0)))
|
||||
(should-error (wb-test--press runtime "每页条数 2 ✎") :type 'user-error))
|
||||
(should (= (etaf-value (etaf-data-page-size data)) 2))
|
||||
(should (equal (wb-test--ids data) '(1 2)))))
|
||||
|
||||
(ert-deftest wb-workbench-cell-toggle-delete-and-detail ()
|
||||
"Cell actions retain the row and dynamic detail, and respect disabled."
|
||||
(let ((observed 0))
|
||||
(cl-letf (((symbol-function 'wb-trace-press) (lambda () (cl-incf observed))))
|
||||
(wb-test--with-app (runtime data)
|
||||
(let* ((row (wb-test--row runtime 1))
|
||||
(remove-ref (wb-test--control runtime "删除" row)))
|
||||
(should-error (etaf-dispatch-event runtime remove-ref 'press)
|
||||
:type 'etaf-event-error)
|
||||
(should-error (etaf-focus runtime remove-ref) :type 'etaf-event-error)
|
||||
(should-not (etaf-data-selected-item data))
|
||||
(etaf-dispatch-event runtime row 'press)
|
||||
(should (= (wb-task-id (etaf-data-selected-item data)) 1))
|
||||
(should (string-match-p "进行中" (wb-test--text runtime)))
|
||||
(let ((detail (wb-test--instance runtime 'wb-task-info)))
|
||||
(wb-test--press runtime "完成" row)
|
||||
(should (= observed 1))
|
||||
(should (plist-get (car (etaf-value (etaf-data-items data))) :done))
|
||||
(should (equal (plist-get (car (etaf-value (etaf-data-items data))) :title)
|
||||
"设计组件接口"))
|
||||
(should (eq detail (wb-test--instance runtime 'wb-task-info)))
|
||||
(should (equal row (wb-test--row runtime 1)))
|
||||
(should (equal remove-ref (wb-test--control runtime "删除" row)))
|
||||
(should-not (plist-get (etaf-runtime-host-props-for runtime remove-ref)
|
||||
:disabled))
|
||||
(etaf-dispatch-event runtime remove-ref 'press)
|
||||
(should (= observed 2))
|
||||
(should (= (etaf-value (etaf-data-total data)) 99))
|
||||
(should (equal (wb-test--ids data) (number-sequence 2 11)))
|
||||
(should-not (etaf-data-selected-item data))
|
||||
(should-not (etaf-effect-scope-active-p
|
||||
(etaf--component-instance-scope detail)))
|
||||
(should (string-match-p "点击任务行查看详情" (wb-test--text runtime)))))))))
|
||||
|
||||
(ert-deftest wb-workbench-add-trims-and-ignores-empty-input ()
|
||||
"Add creates a complete row once and leaves whitespace-only input alone."
|
||||
(wb-test--with-app (runtime data)
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) " 新增验收任务 ")))
|
||||
(wb-test--press runtime "新增任务"))
|
||||
(should (= (etaf-value (etaf-data-total data)) 101))
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) " ")))
|
||||
(wb-test--press runtime "新增任务"))
|
||||
(should (= (etaf-value (etaf-data-total data)) 101))
|
||||
(dotimes (_ 10) (wb-test--press runtime "Next page"))
|
||||
(should (= (etaf-value (etaf-data-page data)) 11))
|
||||
(should (equal (wb-test--ids data) '(101)))
|
||||
(should (equal (car (last (etaf-value (etaf-data-items data))))
|
||||
'(:id 101 :title "新增验收任务" :done nil)))
|
||||
(should (plist-get (etaf-runtime-host-props-for
|
||||
runtime (wb-test--control runtime "Next page")) :disabled))))
|
||||
|
||||
(ert-deftest wb-workbench-last-page-and-high-id-deletion ()
|
||||
"Task 100 is selectable and deletable, with a correct shorter last page."
|
||||
(wb-test--with-app (runtime data)
|
||||
(dotimes (_ 9) (wb-test--press runtime "Next page"))
|
||||
(should (= (etaf-value (etaf-data-page data)) 10))
|
||||
(should (equal (wb-test--ids data) (number-sequence 91 100)))
|
||||
(should (plist-get (etaf-runtime-host-props-for
|
||||
runtime (wb-test--control runtime "Next page")) :disabled))
|
||||
(let ((row (wb-test--row runtime 100)))
|
||||
(etaf-dispatch-event runtime row 'press)
|
||||
(should (= (wb-task-id (etaf-data-selected-item data)) 100))
|
||||
(should (plist-get (etaf-data-selected-item data) :done))
|
||||
(wb-test--press runtime "删除" row)
|
||||
(should (= (etaf-value (etaf-data-total data)) 99))
|
||||
(should (= (etaf-value (etaf-data-page data)) 1))
|
||||
(should (equal (wb-test--ids data) (number-sequence 1 10)))
|
||||
(should-not (etaf-data-selected-item data))
|
||||
(should-error (etaf-dispatch-event runtime row 'press) :type 'etaf-event-error))
|
||||
(dotimes (_ 9) (wb-test--press runtime "Next page"))
|
||||
(should (equal (wb-test--ids data) (number-sequence 91 99)))
|
||||
(should (string-match-p "91–99 of 99" (wb-test--text runtime)))))
|
||||
|
||||
(ert-deftest wb-workbench-theme-focus-and-conditional-slot-content ()
|
||||
"Theme changes paint without moving layout; local focus and details work."
|
||||
(wb-test--with-app (runtime data)
|
||||
(ignore data)
|
||||
(let ((before (with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(buffer-string)))
|
||||
(layout (wb-test--layout-bounds runtime))
|
||||
(widths (wb-test--line-widths runtime))
|
||||
(add (wb-test--control runtime "新增任务")))
|
||||
(should (wb-test--desktop-header-inline-p runtime))
|
||||
(wb-test--press runtime "深色")
|
||||
(should (etaf-value (plist-get (etaf--component-instance-state
|
||||
(wb-test--instance runtime 'wb-app)) :dark)))
|
||||
(should-not (equal-including-properties
|
||||
before (with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(buffer-string))))
|
||||
(should (equal layout (wb-test--layout-bounds runtime)))
|
||||
(should (equal widths (wb-test--line-widths runtime)))
|
||||
(should (wb-test--desktop-header-inline-p runtime))
|
||||
(should (equal add (wb-test--control runtime "新增任务")))
|
||||
(wb-test--press runtime "定位新增按钮")
|
||||
(should (eq add (etaf-focused-host-ref runtime)))
|
||||
(wb-test--press runtime "显示说明")
|
||||
(should-not (string-match-p "点击行:选择任务" (wb-test--text runtime)))
|
||||
(wb-test--press runtime "显示说明")
|
||||
(should (string-match-p "点击行:选择任务" (wb-test--text runtime)))
|
||||
(wb-test--press runtime "深色")
|
||||
(should-not (etaf-value (plist-get (etaf--component-instance-state
|
||||
(wb-test--instance runtime 'wb-app)) :dark)))
|
||||
(should (equal layout (wb-test--layout-bounds runtime)))
|
||||
(should (equal widths (wb-test--line-widths runtime)))
|
||||
(should (wb-test--desktop-header-inline-p runtime)))))
|
||||
|
||||
(ert-deftest wb-workbench-explanation-toggle-isolates-card-heights ()
|
||||
"Explanation changes only detail height across three rendered layouts."
|
||||
(dolist (viewport '((250 . stacked-sidebar) (500 . side-by-side-sidebar)
|
||||
(70 . single-column)))
|
||||
(ert-info ((format "Workbench explanation layout: %S" viewport))
|
||||
(wb-test--with-app (runtime data (car viewport))
|
||||
(etaf-dispatch-event runtime (wb-test--row runtime 1) 'press)
|
||||
(cl-labels
|
||||
((cards ()
|
||||
(mapcar (lambda (entry)
|
||||
(cons (car entry) (wb-test--card-layout runtime (cdr entry))))
|
||||
'((filter . "全部") (tasks . "每页条数 10 ✎")
|
||||
(detail . "显示说明") (service . "刷新 / 重试")))))
|
||||
(let* ((before (cards))
|
||||
(text (wb-test--text runtime))
|
||||
(items (etaf-value (etaf-data-items data)))
|
||||
(selected (etaf-data-selected-item data))
|
||||
(detail (wb-test--instance runtime 'wb-detail))
|
||||
(service (wb-test--instance runtime 'wb-service))
|
||||
(expanded (plist-get (etaf--component-instance-state detail) :expanded))
|
||||
(resource (plist-get (etaf--component-instance-state service) :resource))
|
||||
(rows (mapcar (lambda (id) (wb-test--row runtime id))
|
||||
(number-sequence 1 10)))
|
||||
(control (wb-test--control runtime "显示说明"))
|
||||
(filter (alist-get 'filter before))
|
||||
(tasks (alist-get 'tasks before))
|
||||
(detail-layout (alist-get 'detail before))
|
||||
(service-layout (alist-get 'service before)))
|
||||
;; Prove the viewport actually exercises the intended wrapping
|
||||
;; shape from published host bounds, rather than style declarations.
|
||||
(pcase (cdr viewport)
|
||||
('stacked-sidebar
|
||||
(should (= (plist-get filter :top) (plist-get tasks :top)
|
||||
(plist-get detail-layout :top)))
|
||||
(should (< (plist-get tasks :left) (plist-get detail-layout :left)))
|
||||
(should (< (plist-get detail-layout :bottom)
|
||||
(plist-get service-layout :top))))
|
||||
('side-by-side-sidebar
|
||||
(should (= (plist-get filter :top) (plist-get tasks :top)
|
||||
(plist-get detail-layout :top) (plist-get service-layout :top)))
|
||||
(should (< (plist-get detail-layout :left)
|
||||
(plist-get service-layout :left))))
|
||||
('single-column
|
||||
(should (< (plist-get filter :bottom) (plist-get tasks :top)))
|
||||
(should (< (plist-get tasks :bottom) (plist-get detail-layout :top)))
|
||||
(should (< (plist-get detail-layout :bottom)
|
||||
(plist-get service-layout :top)))))
|
||||
(should (etaf-value expanded))
|
||||
(should (= (wb-task-id selected) 1))
|
||||
(should (string-match-p "点击行:选择任务" text))
|
||||
(dolist (visible '(nil t))
|
||||
(wb-test--press runtime "显示说明")
|
||||
(let ((current (cards)))
|
||||
(message "Workbench explanation width=%d visible=%S heights=%S -> %S"
|
||||
(car viewport) visible
|
||||
(mapcar (lambda (entry) (plist-get (cdr entry) :height)) before)
|
||||
(mapcar (lambda (entry) (plist-get (cdr entry) :height)) current))
|
||||
(dolist (card '(filter tasks service))
|
||||
(should (= (plist-get (alist-get card before) :height)
|
||||
(plist-get (alist-get card current) :height))))
|
||||
(should (funcall (if visible #'= #'<)
|
||||
(plist-get (alist-get 'detail current) :height)
|
||||
(plist-get detail-layout :height)))
|
||||
(dolist (card '(filter tasks detail service))
|
||||
(should (equal (plist-get (alist-get card before) :host)
|
||||
(plist-get (alist-get card current) :host))))
|
||||
(should (eq visible (etaf-value expanded)))
|
||||
(should (eq detail (wb-test--instance runtime 'wb-detail)))
|
||||
(should (eq service (wb-test--instance runtime 'wb-service)))
|
||||
(should (eq items (etaf-value (etaf-data-items data))))
|
||||
(should (eq selected (etaf-data-selected-item data)))
|
||||
(should (= (etaf-value (etaf-data-total data)) 100))
|
||||
(should (= (etaf-value (etaf-data-page data)) 1))
|
||||
(should (= (etaf-value (etaf-data-page-size data)) 10))
|
||||
(should (eq (etaf-resource-status resource) 'success))
|
||||
(should (equal rows (mapcar (lambda (id) (wb-test--row runtime id))
|
||||
(number-sequence 1 10))))
|
||||
(should (equal control (wb-test--control runtime "显示说明")))
|
||||
(should (string-match-p "设计组件接口" (wb-test--text runtime)))
|
||||
(should (string-match-p "服务正常" (wb-test--text runtime)))
|
||||
(should (eq visible
|
||||
(not (null (string-match-p "点击行:选择任务"
|
||||
(wb-test--text runtime))))))))
|
||||
(should (equal before (cards)))
|
||||
(should (equal text (wb-test--text runtime)))))))))
|
||||
|
||||
(ert-deftest wb-workbench-theme-render-failure-retains-published-handlers ()
|
||||
"A failed theme render keeps the published UI and usable old callbacks."
|
||||
(wb-test--with-app (runtime data)
|
||||
(let* ((theme (symbol-function 'wb-theme))
|
||||
(dark (plist-get (etaf--component-instance-state
|
||||
(wb-test--instance runtime 'wb-app)) :dark))
|
||||
(generation (etaf-runtime-current-generation runtime))
|
||||
(before (with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(buffer-string))))
|
||||
(cl-letf (((symbol-function 'wb-theme)
|
||||
(lambda (value)
|
||||
(if value (error "Rejected theme candidate")
|
||||
(funcall theme value)))))
|
||||
(should-error (wb-test--press runtime "深色")))
|
||||
(should (eq generation (etaf-runtime-current-generation runtime)))
|
||||
(should (equal-including-properties
|
||||
before (with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(buffer-string))))
|
||||
;; The App passes a checked value, so the published Checkbox keeps that
|
||||
;; snapshot. Its next press still requests true; UI rollback does not
|
||||
;; restore the separately owned business ref.
|
||||
(should (etaf-value dark))
|
||||
(wb-test--press runtime "深色")
|
||||
(should (etaf-value dark))
|
||||
(should (eq generation (etaf-runtime-current-generation runtime)))
|
||||
;; Restore the business value explicitly, then retry through the same
|
||||
;; public control after removing the injected render failure.
|
||||
(setf (etaf-value dark) nil)
|
||||
(should (equal (wb-test--ids data) (number-sequence 1 10)))
|
||||
(let ((retry-generation (etaf-runtime-current-generation runtime)))
|
||||
(wb-test--press runtime "深色")
|
||||
(should (etaf-value dark))
|
||||
(should-not (eq retry-generation
|
||||
(etaf-runtime-current-generation runtime)))
|
||||
(let ((bounds (etaf-host-ref-bounds
|
||||
runtime (wb-test--control runtime "深色"))))
|
||||
(should bounds)
|
||||
(should (string-match-p
|
||||
"☑" (with-current-buffer (etaf-runtime-buffer runtime)
|
||||
(buffer-substring-no-properties
|
||||
(car bounds) (cdr bounds))))))))))
|
||||
|
||||
(ert-deftest wb-workbench-resource-failure-retry-and-cleanup ()
|
||||
"The resource reports failure, retries, and disposes its last value once."
|
||||
(let ((cleanups 0))
|
||||
(cl-letf (((symbol-function 'wb-service-cleanup) (lambda () (cl-incf cleanups))))
|
||||
(wb-test--with-app (runtime data)
|
||||
(ignore data)
|
||||
(let* ((instance (wb-test--instance runtime 'wb-service))
|
||||
(resource (plist-get (etaf--component-instance-state instance)
|
||||
:resource)))
|
||||
(should (eq (etaf-resource-status resource) 'success))
|
||||
(wb-test--press runtime "模拟失败")
|
||||
(should (eq (etaf-resource-status resource) 'error))
|
||||
(should (string-match-p "模拟加载失败" (wb-test--text runtime)))
|
||||
(wb-test--press runtime "刷新 / 重试")
|
||||
(should (eq (etaf-resource-status resource) 'success))
|
||||
(should (string-match-p "服务正常" (wb-test--text runtime)))
|
||||
(should-not (string-match-p "模拟加载失败" (wb-test--text runtime)))
|
||||
(should (= cleanups 1))
|
||||
(wb-test--press runtime "刷新 / 重试")
|
||||
(should (= cleanups 2))
|
||||
(etaf-unmount runtime)
|
||||
(should (= cleanups 3))
|
||||
(should-not (etaf-resource-active-p resource))
|
||||
(should-not (etaf-effect-scope-active-p
|
||||
(etaf--component-instance-scope instance))))))))
|
||||
|
||||
(ert-deftest wb-workbench-apps-isolate-state-and-remount-cleans-scopes ()
|
||||
"Two mounts isolate state; teardown releases all component-owned resources."
|
||||
(let ((installed 0) (cleaned 0)
|
||||
(one (generate-new-buffer " *wb-one*"))
|
||||
(two (generate-new-buffer " *wb-two*")))
|
||||
(cl-letf (((symbol-function 'wb-trace-install)
|
||||
(lambda () (cl-incf installed) (lambda () (cl-incf cleaned)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(dolist (buffer (list one two))
|
||||
(etaf-mount buffer (etaf-view (wb-app))
|
||||
'(:viewport-width 1600 :viewport-height 80)))
|
||||
(let* ((r1 (etaf-runtime-for-buffer one))
|
||||
(r2 (etaf-runtime-for-buffer two))
|
||||
(d1 (wb-test--data r1))
|
||||
(d2 (wb-test--data r2))
|
||||
(scopes (mapcar #'etaf--component-instance-scope
|
||||
(hash-table-values (etaf-runtime-instances r1)))))
|
||||
(should-not (eq d1 d2))
|
||||
(should-not (eq (wb-test--control r1 "新增任务")
|
||||
(wb-test--control r2 "新增任务")))
|
||||
(wb-test--press r1 "完成" (wb-test--row r1 1))
|
||||
(should (plist-get (car (etaf-value (etaf-data-items d1))) :done))
|
||||
(should-not (plist-get (car (etaf-value (etaf-data-items d2))) :done))
|
||||
(wb-test--press r1 "深色")
|
||||
(should-not (etaf-value (plist-get (etaf--component-instance-state
|
||||
(wb-test--instance r2 'wb-app))
|
||||
:dark)))
|
||||
(etaf-unmount r1)
|
||||
(should-not (etaf-runtime-for-buffer one))
|
||||
(should (cl-every (lambda (scope)
|
||||
(not (etaf-effect-scope-active-p scope))) scopes))
|
||||
(should (etaf-runtime-mounted-p r2))
|
||||
(etaf-mount one (etaf-view (wb-app))
|
||||
'(:viewport-width 1600 :viewport-height 80))
|
||||
(let ((fresh (wb-test--data (etaf-runtime-for-buffer one))))
|
||||
(should-not (eq d1 fresh))
|
||||
(should (equal (wb-test--ids fresh) (number-sequence 1 10)))
|
||||
(should (= (etaf-value (etaf-data-total fresh)) 100))
|
||||
(should-not (plist-get (car (etaf-value (etaf-data-items fresh))) :done)))))
|
||||
(dolist (buffer (list one two))
|
||||
(when-let* ((runtime (etaf-runtime-for-buffer buffer)))
|
||||
(etaf-unmount runtime))
|
||||
(when (buffer-live-p buffer) (kill-buffer buffer))))
|
||||
(should (> installed 0))
|
||||
(should (= installed cleaned)))))
|
||||
|
||||
(provide 'task-workbench-tests)
|
||||
;;; task-workbench-tests.el ends here
|
||||
Loading…
Reference in New Issue
Block a user