perf: precompile apps and trace retained runtime updates
This commit is contained in:
Kinneyzhang
parent
a0e0145639
commit
f69f6889ff
109
AGENTS.md
Normal file
109
AGENTS.md
Normal file
@ -0,0 +1,109 @@
|
||||
# ETAF 开发约束
|
||||
|
||||
本文件适用于 ETAF 及其联调范围内的 `etaf-ui`、`ebox`、`tp`、
|
||||
`etaf-sqlite`、`etaf-playground`。实现与性能优化必须从最终产品目标倒推，
|
||||
不得用局部完成、容易通过的替代目标缩小原始范围。
|
||||
|
||||
## 最终目标驱动
|
||||
|
||||
开始工作前先明确最终可观察结果、硬性指标、不可牺牲的功能、权威验证方式
|
||||
和停止条件。架构、算法、缓存、预编译与局部优化都只是达到目标的手段，不能
|
||||
反过来成为交付物本身。
|
||||
|
||||
ETAF 当前性能工作的最终结果是：通用性能工具能解释每次操作跨包各阶段的
|
||||
耗时；固定真实场景在功能、文本属性、身份、生命周期和回滚语义不缩水的前提
|
||||
下，p95 与 max 都不超过 50ms。
|
||||
|
||||
## 架构与抽象准则
|
||||
|
||||
- 先从复杂现象中识别最小、稳定、可命名的领域模型及其不变量，再写代码；
|
||||
不把偶然的调用顺序、示例名称或当前数据形状伪装成抽象。
|
||||
- 一个模块只拥有一项完整职责，并为这项职责提供少量、精确、正交的接口。
|
||||
接口之间通过明确数据契约组合，不读取彼此的内部状态，不复制彼此的规则。
|
||||
- 区分语义身份、视觉槽位、布局坐标、绘制层和发布权限。只有模型本身允许时
|
||||
才能合并概念；不能为了减少代码把不同生命周期的身份混在一起。
|
||||
- 复杂系统通过小模块的组合与复用逐步形成。新增能力应优先扩展已有模型的
|
||||
输入域或组合方式，不平行创建第二套状态、第二条渲染链或只服务一个例子的
|
||||
特殊协议。
|
||||
- 架构必须满足性能可组合性。每层只处理变化集合，成本应为 `O(changed)` 或有
|
||||
明确上界的小常数；模块增加时，总成本应接近各层小常数之和，不能因每层都
|
||||
重新扫描 `O(all)` 而相乘。
|
||||
- 上一层输出的稳定身份、坐标、依赖、布局证书和绘制贡献就是下一层的输入。
|
||||
下游不得丢弃这些中间产物后重新推导；一次事务中的同一全量遍历最多发生
|
||||
一次，多个模块应组合在同一遍历或直接消费保留状态。
|
||||
- 数据只 materialize 一次。跨层优先传递不可变中间产物、稳定句柄或精确操作
|
||||
批次；重复建树、重复复制文本、重复合并属性和重复证明都必须有独立收益证据。
|
||||
- 每个模块都要有独立性能预算和基准。模块单独合格但组合后超标，说明接口
|
||||
泄漏了重复工作，必须修正边界，不能把额外耗时解释为“架构层数的正常代价”。
|
||||
- 每条快速路径都必须是普通正确路径的严格子集：入口条件可判定、保留状态可
|
||||
验证、失败可精确回退、提交与回滚仍由原有权限边界控制。
|
||||
- 代码量不是进度。没有清晰模型、独立测试和真实收益的辅助层、兼容分支、
|
||||
预留接口、重复证明与缓存都属于 slop，应删除而不是继续包装。
|
||||
|
||||
## 纵向最小可运行版本
|
||||
|
||||
面对架构级任务，先选择一个真实、代表性强、可以端到端运行的最小切片。这个
|
||||
切片必须同时经过“输入 → 核心机制 → 运行时消费 → 用户可见结果 → 验证”，
|
||||
不能只交付数据结构、接口空壳、设计文档或与真实应用脱节的玩具示例。
|
||||
|
||||
例如 App 预编译应先打通一个真实 View：编译阶段产生中间 blueprint，运行时
|
||||
只填动态洞，不支持的语法精确回退，真实应用实际使用该产物。只有这个闭环
|
||||
可运行、结果等价且确有性能收益，才扩展语法和覆盖面。
|
||||
|
||||
## 最小验证循环
|
||||
|
||||
每个实现假设都采用下面的短循环：
|
||||
|
||||
1. 写出本次最小假设以及它应改善的一个可测指标。
|
||||
2. 只实现证明该假设所需的最小代码，不提前铺设后续层次。
|
||||
3. 立即运行最小但有判定力的验证：可运行、结果等价、目标指标改善。
|
||||
4. 验证通过才保留并扩展；失败则先定位原因，无法证明价值的实验立即完整撤掉。
|
||||
5. 每次只扩大一个维度，例如一种语法、一个组件或一个缓存层，然后重复验证。
|
||||
|
||||
最小验证不能偷换最终目标。微基准只能证明局部机制；真实跨包场景和完整门禁
|
||||
仍是最终证据。
|
||||
|
||||
## 控制变更规模
|
||||
|
||||
- 避免一次编写大段跨层代码后才首次运行测试。
|
||||
- 优先提交或保留小而完整的纵向切片；每个切片都应可独立解释、回退和验证。
|
||||
- 新抽象必须服务于当前已验证的下一步，不为尚未证明的未来需求预建框架。
|
||||
- 不因已有方案投入较多就继续扩建；数据否定假设时及时收缩或删除。
|
||||
- 同一轮不要同时改变编译协议、Runtime 语义、Ebox 发布算法和 TP 权限边界，
|
||||
除非最小闭环确实无法拆分，并且有逐层验证点。
|
||||
|
||||
## Git 基线与完成提交
|
||||
|
||||
- 每个完整目标在新鲜验证通过后、开始下一个目标前，必须提交所有受影响仓库，
|
||||
让已证明正确的状态成为可比较、可回退的基线；工作树中“已经完成但未提交”
|
||||
不算真正收敛。
|
||||
- 提交只包含当前已经完成并验证通过的目标。下一目标的失败测试、实验代码、
|
||||
临时诊断和未验证实现必须与基线提交分离，不能为了清空工作树混进同一提交。
|
||||
- 多仓库目标按依赖顺序分别提交，每个仓库使用与其实际改动相符的 message；
|
||||
不用 `update`、`changes`、`work` 一类无法说明结果的含糊描述。
|
||||
- commit message 应以可观察结果或稳定的架构能力为中心，例如
|
||||
`perf: retain native frame updates across ETAF commits`，而不是罗列实现步骤。
|
||||
- 提交前至少运行该目标约定的定向测试、静态检查和最终门禁；验证失败时继续修复，
|
||||
不得通过提交把失败状态包装成完成。
|
||||
- 完成汇报列出各仓库 commit hash、验证证据和仍未提交的下一目标改动，确保后续
|
||||
性能对比能够明确指出基准版本。
|
||||
|
||||
## 性能优化纪律
|
||||
|
||||
- 先用通用记录面板确认真实热区，再选择架构或算法改动。
|
||||
- 一次优化只绑定一个主要瓶颈和一个预期收益，记录优化前后的相同口径数据。
|
||||
- 不用示例名称或业务概念污染通用工具、编译器和底层包协议。
|
||||
- 不以关闭校验、减少功能、弱化文本属性、破坏身份或回滚语义换取数字。
|
||||
- 缓存和预编译提示不能自行授权快速路径；运行时仍负责验证和精确回退。
|
||||
- 如果最小切片没有改善真实目标场景，不继续实现持久化、原生后端或更复杂缓存。
|
||||
|
||||
## 每轮汇报格式
|
||||
|
||||
进度更新应明确说明：最终目标、当前最小切片、已经验证的证据、未通过的指标、
|
||||
下一次只准备验证的一个假设。不得把普通字节编译、局部优化或设计计划描述成
|
||||
尚未实现的 App 预编译能力。
|
||||
|
||||
## 完成条件
|
||||
|
||||
只有当前工作树中的真实实现和新鲜验证同时证明最终要求，任务才算完成。计划、
|
||||
部分测试、单个微基准、一次偶然的低耗时或“没有发现错误”都不是完成证据。
|
||||
177
DESIGN.md
177
DESIGN.md
@ -2,9 +2,9 @@
|
||||
|
||||
## Source of truth
|
||||
- Status: Active
|
||||
- Last refreshed: 2026-08-05
|
||||
- Primary product surfaces: Executable applications under `examples/`, especially the buffers opened by the three `etaf-*-example-open` commands.
|
||||
- Evidence reviewed: ETAF public source and user guide, core/Data/Resource tests, `../etaf-playground/DESIGN.md`, the polished ETAF Showcase, and the original Ebox Flex reference.
|
||||
- Last refreshed: 2026-08-24
|
||||
- Primary product surfaces: Executable applications under `examples/` and the generic ETAF performance recorder/panel used to inspect any mounted application.
|
||||
- Evidence reviewed: ETAF public source and user guide, core/Data/Resource tests, `../etaf-playground/DESIGN.md`, the Research Shelf integration benchmark, Ebox's performance evaluator and architecture analysis, TP surface reports, and the original Ebox Flex reference.
|
||||
|
||||
## Brand
|
||||
- Personality: Precise, calm, modern, technical, and intentionally composed.
|
||||
@ -12,26 +12,176 @@
|
||||
- Avoid: Bare fixture text, low-contrast pastel text, decorative emoji, fake browser chrome, huge empty surfaces, and controls indistinguishable from copy.
|
||||
|
||||
## Product goals
|
||||
- Goals: Make core ETAF practices copyable from small executable files; prove the installed Runtime interaction path; keep examples visually consistent with the Flex reference and ETAF Showcase.
|
||||
- Non-goals: Replacing `etaf-playground`, simulating the missing `etaf-ui` catalog, introducing a second theme system, or demonstrating every public symbol in one application.
|
||||
- Success signals: Each example teaches one ownership boundary, opens without side effects at load time, reacts through public events, cleans up its resources, and remains unclipped in a compact GUI frame.
|
||||
- Goals: Make core ETAF practices copyable from small executable files; prove the installed Runtime interaction path; keep examples visually consistent with the Flex reference and ETAF Showcase; make every public operation's cross-package latency attributable to concrete nested stages.
|
||||
- Non-goals: Replacing `etaf-playground`, simulating the missing `etaf-ui` catalog, introducing a second theme system, demonstrating every public symbol in one application, or binding performance analysis to one example or application package.
|
||||
- Success signals: Each example teaches one ownership boundary, opens without side effects at load time, reacts through public events, cleans up its resources, and remains unclipped in a compact GUI frame. The performance panel can record any mounted application, preserve operation results/errors, expose inclusive and exclusive stage time, and keep a bounded history.
|
||||
|
||||
## Personas and jobs
|
||||
- Primary personas: ETAF application authors and framework maintainers.
|
||||
- User jobs: Copy a correct state/data/resource pattern, inspect a real mounted application, and verify the visible result of an event.
|
||||
- User jobs: Copy a correct state/data/resource pattern, inspect a real mounted application, verify the visible result of an event, and identify which framework/package stage owns an operation's latency.
|
||||
- Key contexts of use: Source reading, GUI Emacs exploration, automated ERT, and framework regression review.
|
||||
|
||||
## Information architecture
|
||||
- Primary navigation: No shared launcher; every file owns one explicit open and close command.
|
||||
- Core routes/screens: Retained counter, task Data Controller, and Resource health.
|
||||
- Content hierarchy: Capability eyebrow, application title and explanation, primary state surface, actions, then an ownership rule footer.
|
||||
- Core routes/screens: Retained counter, task Data Controller, Resource health, and the generic performance records buffer.
|
||||
- Content hierarchy: Examples use capability eyebrow, application title and explanation, primary state surface, actions, then an ownership rule footer. The performance panel uses operation summary first, followed by indented nested stages with package/category, inclusive time, exclusive time, status, and details.
|
||||
|
||||
## Design principles
|
||||
- Principle 1: One example teaches one lifecycle owner; avoid a mega-demo that hides where state and cleanup belong.
|
||||
- Principle 2: Writes happen at Event, Action, lifecycle, Data, or Resource boundaries; render functions remain read-only.
|
||||
- Principle 3: Use warm restrained semantic color families and one-pixel borders to make structure obvious without adding a design-system dependency.
|
||||
- Principle 4: Instrument public operation boundaries once and let package-neutral stage registration extend coverage; examples are validation fixtures, never analyzer concepts.
|
||||
- Tradeoffs: Prefer a fixed compact teaching canvas over viewport arithmetic in each standalone example; keep the responsive full-application showcase in `etaf-playground`.
|
||||
|
||||
## Performance architecture: three root principles
|
||||
|
||||
### 1. Host/Box properties are visual update units; Components are not default repaint units
|
||||
|
||||
A Component is the computation and ownership boundary for setup, state,
|
||||
Context, slots, and lifecycle. It may produce one or more Hosts/Boxes, or be
|
||||
transparent and produce only Components, Ranges, or fragments, so the
|
||||
Component record itself is not a Box. Once a change is localized to a visual
|
||||
node property, however, the Component that produced it must not run again.
|
||||
|
||||
The Runtime retains a structured property delta instead of collapsing every
|
||||
reactive dependency into “Component dirty”:
|
||||
|
||||
```text
|
||||
source-id → semantic-host-id → backend-node-id → property → old/new → impact
|
||||
```
|
||||
|
||||
The deterministic update tiers are:
|
||||
|
||||
- `paint`: update the Host/Box property contribution directly, with no
|
||||
Component execution and no layout;
|
||||
- `content` or local geometry: recompute only the Box and its exact layout
|
||||
dependency closure;
|
||||
- control flow, slot, list topology, or lifecycle: execute the Component that
|
||||
owns that structure;
|
||||
- untrusted input, external buffer mutation, or a missing index: enter an
|
||||
explicit root fallback.
|
||||
|
||||
Theme is the first vertical implementation. Theme tokens compile to property
|
||||
bindings, and palette changes schedule only Hosts bound to color, background,
|
||||
and border properties. Real content changes such as `Light theme` versus
|
||||
`Dark theme` continue to schedule their own Component or Range.
|
||||
|
||||
### 2. Authoritative dependency state replaces repeated hot-path proofs
|
||||
|
||||
Initial layout produces and retains authoritative parent edges, allocated
|
||||
slots, containment boundaries, property impacts, overflow facts,
|
||||
viewport/display revisions, and layout revisions. Later updates compute a
|
||||
dirty closure from property schemas and dependency edges; they do not rescan
|
||||
the rendered buffer to guess whether a local update is safe.
|
||||
|
||||
- paint deltas have no layout dependency and require zero proof;
|
||||
- content in a fixed slot checks an O(1) revision/token;
|
||||
- auto/intrinsic content follows retained layout dependency edges until a
|
||||
containment boundary;
|
||||
- structure and viewport changes invalidate only affected certificates and
|
||||
edges;
|
||||
- full span scans and conservative proofs remain only for untrusted
|
||||
candidates, external mutation, debug assertions, and fallback—not normal
|
||||
interaction hot paths.
|
||||
|
||||
The current retained allocation certificate is a migration device: establish
|
||||
once, then validate a revision. Once the dependency graph is complete, remove
|
||||
the superseded scan path instead of permanently layering two decision systems.
|
||||
|
||||
### 3. Paint remains ordered TP property contributions through publication
|
||||
|
||||
Theme, Component style, interaction state, explicit inline properties, and
|
||||
focus/selection are distinct paint contributions. Ebox must not flatten them
|
||||
into one final `face` per fragment before TP, and palette changes must not
|
||||
recompose the complete fragment set.
|
||||
|
||||
“Layer” here means ordered property contributions in a TP properties
|
||||
surface/ledger, not the definition-time recipes in `tp-layer.el`. Ownership
|
||||
is explicit:
|
||||
|
||||
- ETAF retains `source → Host property contribution` bindings and source
|
||||
precedence;
|
||||
- Ebox retains Box/role mappings to stable TP ranges/objects and reports only
|
||||
layout/content deltas;
|
||||
- TP merges ordered contributions inside one surface and owns baselines,
|
||||
conflict detection, atomic publication, rollback, and unmount restoration;
|
||||
- a palette switch replaces the Theme contribution while higher-priority
|
||||
Component/state/inline contributions remain intact.
|
||||
|
||||
The target Theme path is therefore:
|
||||
|
||||
```text
|
||||
Theme source changed
|
||||
→ resolve changed Theme contributions
|
||||
→ TP properties-only scoped publication
|
||||
→ redisplay
|
||||
```
|
||||
|
||||
It creates no View, executes no color-consuming Component, runs no Ebox
|
||||
layout, scans no ancestor slot, and walks no complete fragment ledger. Real
|
||||
text or structure changes use a separate content/layout transaction; the
|
||||
parent ETAF operation still correlates and atomically commits both.
|
||||
|
||||
## Precompiled Operation Programs and performance composability
|
||||
|
||||
A compiled artifact cannot retain only View syntax or final text coordinates.
|
||||
An Operation Program that the Runtime can consume directly owns five facts as
|
||||
one indivisible contract:
|
||||
|
||||
1. stable Host/Box/Range topology templates and dynamic holes;
|
||||
2. `source/effect → OperationBatch` dependency routes;
|
||||
3. layout slots, containment, overflow, and revision invalidation edges;
|
||||
4. a closed style environment covering selectors, inheritance, and Theme
|
||||
contributions;
|
||||
5. TP object/ownership ranges/paint contribution addresses plus atomic
|
||||
rollback boundaries.
|
||||
|
||||
Retaining only a subset merely moves the same work downstream. Coordinates
|
||||
without style and TP objects require reconstruction; a View blueprint still
|
||||
requires lowering, layout, and paint; flattened final faces discard TP
|
||||
layering. Such partial artifacts are not App performance compilation.
|
||||
|
||||
The Runtime submits only precise operation batches:
|
||||
|
||||
```text
|
||||
OperationBatch = RangeReplace | HostPropertySet | InlineTextSet |
|
||||
LayoutInvalidate | PaintContributionSet
|
||||
```
|
||||
|
||||
Each layer consumes only its fields and forwards the remaining retained
|
||||
addresses. Data materializes once; a transaction performs at most one full
|
||||
walk; every module costs `O(changed)` or a documented small constant. If an
|
||||
extra module materially increases total latency, its interface discarded an
|
||||
upstream intermediate—the overhead is not an inherent cost of architecture.
|
||||
|
||||
The current `etaf-view-blueprint/0` caches only static View construction and
|
||||
is a migration artifact. A later ABI becomes an Operation Program only after
|
||||
a real App Range update avoids whole-tree Ebox projection/render and passes
|
||||
the formal Pagination budget.
|
||||
|
||||
### Root implementation order and acceptance
|
||||
|
||||
1. Theme vertical slice: add a Theme source→Host/property index and TP
|
||||
contributions. Color-consuming Component render count becomes zero while
|
||||
content consumers update separately.
|
||||
2. Generic property effects: compile reactive expressions written directly in
|
||||
Host property positions into stable property bindings; structural
|
||||
expressions remain Component/Range work.
|
||||
3. Exact incremental layout: Ebox retains property-impact and containment
|
||||
dependency edges, recomputes the dirty closure directly, and removes
|
||||
span/ancestor proofs from the normal path.
|
||||
4. TP paint plane: migrate precomposed fragment faces to ordered properties
|
||||
contributions and delete full-fragment palette recomposition.
|
||||
5. Converge: remove compatibility caches and proofs that are superseded while
|
||||
retaining the conservative root path for arbitrary candidates, rollback,
|
||||
and all existing semantics.
|
||||
|
||||
Acceptance requires GUI-visible completion timing, not batch alone; no layout
|
||||
stage or full-fragment recomposition for Theme paint; no regressions in
|
||||
structure, slots, lifecycle, inheritance, precedence, conflicts, or rollback;
|
||||
and representative warmed operations passing the scenario budgets in the
|
||||
performance evaluator.
|
||||
|
||||
## Visual language
|
||||
- Color: Warm canvas `#F8F5EE`, paper `#FFFDF8`, ink `#252A2E`, muted ink `#66706A`, terracotta `#F1D4C9`, sage `#DCEBDD`, blue `#D9EAF2`, and violet `#E7E2F1`, always with explicit dark text.
|
||||
- Typography: The configured Emacs monospace face; bold only for titles, actions, statuses, and important values.
|
||||
@ -42,8 +192,8 @@
|
||||
|
||||
## Components
|
||||
- Existing components to reuse: Core Hosts, retained Components, refs, computed values, Actions, focusable Behaviors, Data Controllers, Resources, and Runtime lifecycle callbacks.
|
||||
- New/changed components: Example-specific shell, metric, action, row, status, and footer Components/Hosts.
|
||||
- Variants and states: Ready/active counter, selected/unselected task, open/done filter, idle/loading/success/error Resource.
|
||||
- New/changed components: Example-specific shell, metric, action, row, status, and footer Components/Hosts; one `tabulated-list-mode` performance panel backed by generic operation and stage records.
|
||||
- Variants and states: Ready/active counter, selected/unselected task, open/done filter, idle/loading/success/error Resource; recorder disabled/enabled, successful/failed operation, empty history, bounded history, and explicit manual refresh outside the measured hot path.
|
||||
- Token/component ownership: Each example owns its small static palette and composition; ETAF/Ebox own semantics, layout, and rendering.
|
||||
|
||||
## Accessibility
|
||||
@ -64,6 +214,9 @@
|
||||
- Error: High-contrast visible error message that persists until the next action.
|
||||
- Success: Explicit status text on a sage surface.
|
||||
- Disabled: Remove the event/tab stop instead of presenting a misleading active control.
|
||||
- Performance recorder disabled: Explain the enabling command without manufacturing sample data.
|
||||
- Empty performance history: Show a concise empty state and the public operation boundaries that can create records.
|
||||
- Failed operation trace: Retain the timing record with an error status while allowing the original condition to propagate unchanged.
|
||||
- Offline/slow network, if applicable: Not applicable to the synchronous core examples.
|
||||
|
||||
## Content voice
|
||||
@ -75,8 +228,10 @@
|
||||
- Framework/styling system: Emacs 29.1+, the public `etaf` facade, and public Ebox properties lowered through ETAF Hosts.
|
||||
- Design-token constraints: Reuse the established warm palette directly; do not add a token framework for three examples.
|
||||
- Performance constraints: Synchronous bounded data only; no timers, background work, or hidden repeated mounts.
|
||||
- Performance analysis constraints: Recording is opt-in, bounded, package-neutral, result/error preserving, and removable. Disabled operation boundaries perform one fast gate. Third-party packages register stage symbols without creating reverse dependencies. Inclusive/exclusive stage accounting must remain valid under nesting.
|
||||
- Compatibility constraints: Core examples must not require `etaf-ui`, `etaf-sqlite`, `etaf-playground`, or private `etaf--*` / `ebox--*` APIs.
|
||||
- Test/screenshot expectations: `make check` byte-compiles examples and drives their mounted public event paths; GUI verification uses one target buffer window and rejects clipping or continuation indicators.
|
||||
|
||||
## Open questions
|
||||
- [ ] Add an asynchronous Resource example only after ETAF defines a public asynchronous completion contract / maintainer / avoids teaching a speculative API.
|
||||
- [ ] GUI redisplay completion is outside batch publication timing; define a portable Emacs redisplay marker before presenting it as a synchronous framework stage / maintainer / avoids false end-to-end claims.
|
||||
|
||||
150
DESIGN.zh-CN.md
150
DESIGN.zh-CN.md
@ -2,9 +2,9 @@
|
||||
|
||||
## 事实来源
|
||||
- 状态：生效中
|
||||
- 最近更新：2026-08-05
|
||||
- 主要产品界面：`examples/` 下的可执行应用，尤其是三个 `etaf-*-example-open` 命令打开的缓冲区。
|
||||
- 已审阅证据：ETAF 公开源码与用户指南、core/Data/Resource 测试、`../etaf-playground/DESIGN.md`、精修后的 ETAF Showcase，以及原始 Ebox Flex 参考示例。
|
||||
- 最近更新：2026-08-24
|
||||
- 主要产品界面：`examples/` 下的可执行应用，以及用于检查任意已挂载应用的通用 ETAF 性能记录器/面板。
|
||||
- 已审阅证据：ETAF 公开源码与用户指南、core/Data/Resource 测试、`../etaf-playground/DESIGN.md`、Research Shelf 集成基准、Ebox 性能评估器与架构分析、TP surface report，以及原始 Ebox Flex 参考示例。
|
||||
|
||||
## 品牌
|
||||
- 气质：精确、克制、现代、技术化，并且经过明确构图。
|
||||
@ -12,26 +12,149 @@
|
||||
- 避免：裸 fixture 文本、低对比度浅色文字、装饰性 emoji、假浏览器外壳、无意义的大面积留白，以及与正文无法区分的控件。
|
||||
|
||||
## 产品目标
|
||||
- 目标：通过小型可执行文件提供可复制的 ETAF core 最佳实践；证明已安装 Runtime 的真实交互路径；让视觉质量与 Flex 参考和 ETAF Showcase 保持一致。
|
||||
- 非目标：替代 `etaf-playground`、假装缺失的 `etaf-ui` 目录已经存在、引入第二套主题系统，或在一个应用里展示全部公开符号。
|
||||
- 成功信号：每个示例只讲清一个所有权边界；加载文件时不产生应用副作用；通过公开事件响应；正确清理资源；在紧凑 GUI 窗口中不裁切。
|
||||
- 目标：通过小型可执行文件提供可复制的 ETAF core 最佳实践；证明已安装 Runtime 的真实交互路径；让视觉质量与 Flex 参考和 ETAF Showcase 保持一致；让每个公共操作的跨包延迟都可归因到具体嵌套阶段。
|
||||
- 非目标：替代 `etaf-playground`、假装缺失的 `etaf-ui` 目录已经存在、引入第二套主题系统、在一个应用里展示全部公开符号，或把性能分析绑定到某个示例/应用包。
|
||||
- 成功信号：每个示例只讲清一个所有权边界；加载文件时不产生应用副作用；通过公开事件响应；正确清理资源；在紧凑 GUI 窗口中不裁切。性能面板可记录任意挂载应用，保持操作返回值/错误，展示 inclusive 与 exclusive 阶段耗时，并保留有界历史。
|
||||
|
||||
## 用户与任务
|
||||
- 主要用户：ETAF 应用作者和框架维护者。
|
||||
- 用户任务：复制正确的状态/Data/Resource 模式、检查真实挂载应用，并验证事件产生的可见结果。
|
||||
- 用户任务：复制正确的状态/Data/Resource 模式、检查真实挂载应用、验证事件产生的可见结果，并定位哪个框架/包阶段承担了操作延迟。
|
||||
- 主要环境：源码阅读、GUI Emacs 探索、自动化 ERT 和框架回归审查。
|
||||
|
||||
## 信息架构
|
||||
- 主导航：不增加共享 launcher；每个文件拥有一个明确的 open 与 close 命令。
|
||||
- 核心界面：保留式计数器、任务 Data Controller、Resource 健康状态。
|
||||
- 内容层级：能力 eyebrow、应用标题与说明、主要状态区域、操作区、所有权规则页脚。
|
||||
- 核心界面：保留式计数器、任务 Data Controller、Resource 健康状态，以及通用性能记录缓冲区。
|
||||
- 内容层级：示例使用能力 eyebrow、应用标题与说明、主要状态区域、操作区、所有权规则页脚。性能面板先显示 operation 摘要，再显示带包/类别、inclusive、exclusive、状态和细节的嵌套阶段。
|
||||
|
||||
## 设计原则
|
||||
- 原则一：一个示例只讲一个 lifecycle owner；避免用 mega-demo 隐藏状态与清理的归属。
|
||||
- 原则二：写操作发生在 Event、Action、lifecycle、Data 或 Resource 边界；render 函数保持只读。
|
||||
- 原则三：使用暖色、克制的语义色和一像素边框呈现结构，不增加设计系统依赖。
|
||||
- 原则四：公共 operation 边界只插桩一次，并通过包无关的 stage 注册扩展覆盖面；示例只能作为验证负载，不能成为分析器概念。
|
||||
- 取舍：独立示例采用固定的紧凑教学画布；完整 viewport 响应式应用继续由 `etaf-playground` 展示。
|
||||
|
||||
## 性能架构：三个根原则
|
||||
|
||||
### 一、Host/Box 属性是视觉更新单位，Component 不是默认重绘单位
|
||||
|
||||
Component 是 setup、状态、Context、slot 和 lifecycle 的计算/所有权边界；它可能
|
||||
产生一个或多个 Host/Box，也可能透明地只产生 Component、Range 或 fragment，
|
||||
因此不能把 Component 数据结构直接等同为一个 Box。但一次已经定位到具体视觉
|
||||
节点的属性变化，不应重新执行产生它的 Component。
|
||||
|
||||
Runtime 必须保留结构化属性 delta，而不是把所有响应式依赖压缩成
|
||||
“Component dirty”：
|
||||
|
||||
```text
|
||||
source-id → semantic-host-id → backend-node-id → property → old/new → impact
|
||||
```
|
||||
|
||||
更新层级按确定性从小到大选择：
|
||||
|
||||
- `paint`：直接更新 Host/Box 的属性贡献，不执行 Component、不运行布局；
|
||||
- `content` 或局部 geometry：只重算对应 Box 及精确布局依赖闭包；
|
||||
- control flow、slot、列表拓扑或 lifecycle：执行拥有该结构的 Component；
|
||||
- 来源不可信、外部 buffer 被改写或索引缺失：显式进入 root fallback。
|
||||
|
||||
Theme 是第一条垂直实现：Theme token 编译为 property binding；palette 变化只调度
|
||||
绑定到颜色、背景和边框属性的 Host。只有 `Light theme`/`Dark theme` 等真实内容
|
||||
变化继续调度它自己的 Component/Range。
|
||||
|
||||
### 二、权威依赖状态替代热路径上的重复 proof
|
||||
|
||||
初次布局应产出并持有权威状态：父链、分配 slot、containment boundary、
|
||||
property impact、overflow、viewport/display revision 和布局 revision。之后的更新
|
||||
根据 property schema 与依赖图直接计算 dirty closure，不从渲染后的 buffer 重新
|
||||
扫描并猜测局部更新是否安全。
|
||||
|
||||
- paint delta 对布局没有依赖，必须是零 proof；
|
||||
- 固定 slot 的内容变化只比较 O(1) revision/token；
|
||||
- auto/intrinsic 内容变化沿已保存的布局依赖边更新，到 containment boundary 停止；
|
||||
- 结构或 viewport 变化只失效实际受影响的证书/依赖边；
|
||||
- 完整 span 扫描和保守 proof 只保留给不可信 candidate、外部 mutation、debug
|
||||
assertion 与 fallback，不属于正常交互热路径。
|
||||
|
||||
当前 retained allocation certificate 是迁移措施：它把重复 proof 改为一次建立、
|
||||
后续 revision 校验；最终依赖图完整后，应删除被取代的扫描路径，而不是永久叠加
|
||||
两套判断逻辑。
|
||||
|
||||
### 三、Paint 必须以 TP 有序属性贡献保留到 publication
|
||||
|
||||
Theme、Component 样式、交互状态、显式 inline 属性和 focus/selection 是不同的
|
||||
paint contribution。Ebox 不应在进入 TP 之前把它们压平成每个 fragment 的最终
|
||||
`face`，也不应在 palette 切换时重新调和所有 fragment。
|
||||
|
||||
这里的“层”指 TP properties surface/ledger 中的有序 property contribution，
|
||||
不是 `tp-layer.el` 的 definition-time recipe。职责边界是：
|
||||
|
||||
- ETAF 保留 `source → Host property contribution` 绑定和优先级来源；
|
||||
- Ebox 保留 Box/role 到稳定 TP range/object 的映射，只报告 layout/content delta；
|
||||
- TP 合并同一 surface 内的有序属性贡献，拥有 baseline、冲突检测、原子发布、
|
||||
回滚和 unmount restoration；
|
||||
- palette 切换替换 Theme contribution，较高优先级的 Component/state/inline
|
||||
contribution 保持不变。
|
||||
|
||||
因此换主题的目标路径是：
|
||||
|
||||
```text
|
||||
Theme source changed
|
||||
→ resolve changed Theme contributions
|
||||
→ TP properties-only scoped publication
|
||||
→ redisplay
|
||||
```
|
||||
|
||||
它不得创建新 View、重新执行颜色消费者 Component、运行 Ebox layout、扫描祖先
|
||||
slot，或遍历完整 fragment ledger。只有真实文本/结构变化走独立的 content/layout
|
||||
事务；二者仍由同一个上层 ETAF operation 关联并原子提交。
|
||||
|
||||
## 预编译 Operation Program 与性能可组合性
|
||||
|
||||
预编译产物不能只保存 View 语法树或最终文本坐标。一个可以在运行时直接消费的
|
||||
Operation Program 必须把下面五项作为同一个不可拆分契约：
|
||||
|
||||
1. 稳定 Host/Box/Range 拓扑模板和动态 hole；
|
||||
2. `source/effect → OperationBatch` 的依赖路由；
|
||||
3. 布局 slot、containment、overflow 与 revision 失效边；
|
||||
4. 已闭合的样式计算环境，包括 selector/继承/Theme contribution；
|
||||
5. TP object/ownership range/paint contribution 地址和原子回滚边界。
|
||||
|
||||
只保留其中一部分会把工作转移到下一层：只保留坐标仍需重新建立 style 与 TP
|
||||
object；只保留 View blueprint 仍需重新 lower、layout 和 paint；只保留最终 face
|
||||
又会丢失 TP 分层。因此这种“局部预编译”不能宣称为 App 性能预编译。
|
||||
|
||||
运行时只允许提交精确操作批次：
|
||||
|
||||
```text
|
||||
OperationBatch = RangeReplace | HostPropertySet | InlineTextSet |
|
||||
LayoutInvalidate | PaintContributionSet
|
||||
```
|
||||
|
||||
每一层只消费属于自己的字段并保留其余地址。一次数据只 materialize 一次；同一
|
||||
事务的全量遍历最多一次；各模块成本必须是 `O(changed)` 或有明确小常数上界。
|
||||
如果增加一个模块后总耗时明显增加，说明接口丢失了上层中间产物，而不是架构
|
||||
层数本身应有的代价。
|
||||
|
||||
当前 `etaf-view-blueprint/0` 只缓存静态 View 构造，是迁移产物。下一 ABI 只有在
|
||||
真实 App 的 Range 操作无需重新进行整树 Ebox projection/render，并通过正式
|
||||
Pagination 预算后，才能称为 Operation Program。
|
||||
|
||||
### 根源实现顺序与验收
|
||||
|
||||
1. Theme 垂直切片：建立 Theme source→Host/property 索引和 TP contribution；
|
||||
Theme 颜色消费者的 Component render 次数为 0，内容消费者单独更新。
|
||||
2. 通用 property effect：把直接写在 Host 属性位置的响应式表达式编译为稳定
|
||||
property binding；结构表达式继续归 Component/Range。
|
||||
3. 精确 incremental layout：Ebox 持有 property impact 与 containment 依赖图，
|
||||
直接重算 dirty closure，移除正常路径的 span/ancestor proof。
|
||||
4. TP paint plane：将预合成 fragment face 迁移为有序 properties contribution，
|
||||
删除 palette 切换时的全 fragment recomposition。
|
||||
5. 收尾：删除已被替代的兼容缓存和 proof；保守 root 路径继续保证任意 candidate、
|
||||
rollback 和现有功能语义。
|
||||
|
||||
验收必须同时满足：GUI 可见完成计时而非只看 batch；Theme paint 操作没有 layout
|
||||
阶段和全 fragment 重组；结构、slot、lifecycle、继承、优先级、冲突与 rollback
|
||||
测试不退化；代表性 warmed 操作达到性能 evaluator 的场景预算。
|
||||
|
||||
## 视觉语言
|
||||
- 颜色：暖色画布 `#F8F5EE`、纸张 `#FFFDF8`、正文 `#252A2E`、弱化正文 `#66706A`、陶土色 `#F1D4C9`、鼠尾草绿 `#DCEBDD`、蓝色 `#D9EAF2` 与紫色 `#E7E2F1`，始终搭配明确的深色文字。
|
||||
- 字体：沿用 Emacs 当前等宽字体；粗体只用于标题、操作、状态和关键数值。
|
||||
@ -42,8 +165,8 @@
|
||||
|
||||
## 组件
|
||||
- 复用能力：core Host、保留式 Component、ref、computed、Action、focusable Behavior、Data Controller、Resource 与 Runtime lifecycle callback。
|
||||
- 新增或调整：示例专用 shell、metric、action、row、status 与 footer Component/Host。
|
||||
- 状态：ready/active 计数器、selected/unselected 任务、open/done 筛选、idle/loading/success/error Resource。
|
||||
- 新增或调整：示例专用 shell、metric、action、row、status 与 footer Component/Host；一个由通用 operation/stage 记录驱动的 `tabulated-list-mode` 性能面板。
|
||||
- 状态：ready/active 计数器、selected/unselected 任务、open/done 筛选、idle/loading/success/error Resource；记录器禁用/启用、操作成功/失败、空历史、有界历史，以及在被测热路径之外显式手动刷新。
|
||||
- 所有权：每个示例拥有自己的小型静态配色和组合；ETAF/Ebox 拥有语义、布局和渲染。
|
||||
|
||||
## 可访问性
|
||||
@ -64,6 +187,9 @@
|
||||
- Error：高对比、持续可见的错误文案，直到下一次操作。
|
||||
- Success：鼠尾草绿表面和明确状态文字。
|
||||
- Disabled：移除 event/tab stop，不展示误导性的可用控件。
|
||||
- 性能记录器禁用：说明启用命令，不伪造示例数据。
|
||||
- 性能历史为空：显示简洁空状态，并说明哪些公共操作会生成记录。
|
||||
- 操作失败：保留带 error 状态的 timing 记录，同时原始 condition 不变地继续传播。
|
||||
- 离线/慢网络：同步 core 示例不适用。
|
||||
|
||||
## 内容语气
|
||||
@ -75,8 +201,10 @@
|
||||
- 技术边界：Emacs 29.1+、公开 `etaf` facade，以及通过 ETAF Host 下沉的公开 Ebox 属性。
|
||||
- Token：直接复用既有暖色配色；不为三个示例增加 token 框架。
|
||||
- 性能：只使用同步、有界数据；不使用 timer、后台工作或隐藏的重复 mount。
|
||||
- 性能分析：记录必须按需启用、有界、包无关，并保持返回值/error；关闭后可完全移除。默认阶段采用粗粒度边界，第三方包可注册临时细节探针而不产生反向依赖。嵌套 inclusive/exclusive 统计必须成立。
|
||||
- 兼容性：core 示例不得依赖 `etaf-ui`、`etaf-sqlite`、`etaf-playground`，也不得调用私有 `etaf--*` / `ebox--*` API。
|
||||
- 验证：`make check` 会编译示例并驱动已挂载的公开事件路径；GUI 验证只使用一个目标缓冲区窗口，并拒绝裁切或续行标记。
|
||||
|
||||
## 待解决问题
|
||||
- [ ] 只有 ETAF 定义公开异步完成契约后才增加异步 Resource 示例；维护者；避免教授臆造 API。
|
||||
- [ ] GUI redisplay 完成不属于 batch publication timing；在把它展示成同步框架阶段前，需要定义可移植的 Emacs redisplay marker；维护者；避免错误的端到端结论。
|
||||
|
||||
5
Makefile
5
Makefile
@ -1,8 +1,8 @@
|
||||
EMACS ?= emacs
|
||||
LOAD_PATH = -L . -L examples -L ../ebox -L ../tp -L ../ecss
|
||||
SOURCES = etaf-view.el etaf-component.el etaf-reactive.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf.el
|
||||
SOURCES = etaf-view.el etaf-compiler.el etaf-app.el etaf-component.el etaf-reactive.el etaf-context.el etaf-theme-tp.el etaf-resource.el etaf-data.el etaf-renderer.el etaf-runtime.el etaf-behavior.el etaf-actions.el etaf-events.el etaf-performance.el etaf.el
|
||||
EXAMPLES = examples/etaf-counter-example.el examples/etaf-data-example.el examples/etaf-resource-example.el
|
||||
TESTS = tests/etaf-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el
|
||||
TESTS = tests/etaf-tests.el tests/etaf-compiler-tests.el tests/etaf-app-tests.el tests/etaf-resource-tests.el tests/etaf-data-tests.el tests/etaf-theme-tp-tests.el tests/etaf-examples-tests.el tests/etaf-performance-tests.el
|
||||
|
||||
.PHONY: test compile load checkdoc docs-check check clean
|
||||
|
||||
@ -13,6 +13,7 @@ test: compile
|
||||
|
||||
compile: clean
|
||||
$(EMACS) -Q --batch $(LOAD_PATH) \
|
||||
--eval "(setq load-prefer-newer t)" \
|
||||
--eval "(load-file \"etaf.el\")" \
|
||||
--eval "(dolist (file '($(foreach file,$(SOURCES) $(EXAMPLES),\"$(file)\"))) (byte-compile-file file))"
|
||||
|
||||
|
||||
74
README.md
74
README.md
@ -40,6 +40,80 @@ Define a Component:
|
||||
|
||||
`etaf-view` is the single public View constructor. Structural forms do not use quote; quote remains ordinary Elisp data syntax, such as `'bold`. A View returned from ordinary Elisp is explicitly constructed with `(etaf-view ...)` inside `expr`.
|
||||
|
||||
## App precompilation
|
||||
|
||||
App precompilation is an ETAF core capability and does not depend on
|
||||
Playground. An App or host first registers its source manifest and artifact
|
||||
location:
|
||||
|
||||
```elisp
|
||||
(etaf-register-app
|
||||
"my-app"
|
||||
:source "/path/to/my-app.el"
|
||||
:static "/path/to/my-app.etaf"
|
||||
:style "/path/to/my-app.ecss"
|
||||
:artifact "/path/to/build/my-app.etafc")
|
||||
```
|
||||
|
||||
The user then runs `M-x etaf-compile-app` once to select a registered App and
|
||||
atomically generate its standalone `.etafc` intermediate artifact. Use
|
||||
`M-x etaf-app-compile-status` to report `current`, `missing`, `stale`, or
|
||||
`invalid`.
|
||||
|
||||
ETAF records content hashes for the companion, `.etaf`, and `.ecss` sources;
|
||||
changing any of them rejects the old artifact. An App host calls
|
||||
`etaf-app-load-artifact-or-warn` before startup. A current artifact is loaded;
|
||||
a missing or stale artifact retains the complete source fallback and emits an
|
||||
explicit reminder to run `M-x etaf-compile-app`.
|
||||
|
||||
`etaf-compiler.el` owns blueprint and `.etafc` compilation/validation.
|
||||
`etaf-app.el` independently owns App registration, interactive commands,
|
||||
status, and fallback warnings. Playground is only an optional UI consumer of
|
||||
these core APIs.
|
||||
|
||||
## Performance records
|
||||
|
||||
ETAF includes an opt-in, application-neutral timing recorder. It recognizes
|
||||
public Event, Action, mount, flush, focus, Data, Resource, and viewport
|
||||
operations, then correlates coarse ETAF, Ebox, TP, and SQLite stages when those
|
||||
packages are loaded.
|
||||
|
||||
```elisp
|
||||
(etaf-performance-mode 1)
|
||||
;; Use any mounted ETAF application normally.
|
||||
(etaf-performance-show)
|
||||
```
|
||||
|
||||
For an interactive capture, run `M-x etaf-performance-clear` first. After
|
||||
reproducing the operations, press `c` in the panel (or run
|
||||
`M-x etaf-performance-copy-report`) to copy a complete report. Press `w` (or
|
||||
run `M-x etaf-performance-export`) to save the same report as an `.eld` file.
|
||||
The portable report includes the Emacs/display environment, power source,
|
||||
low-power mode, system load, grouped p50/p95/max, individual operations, GC
|
||||
deltas, and nested stages. The panel header exposes the same environment
|
||||
context so a machine-wide slowdown is not mistaken for one package hotspot.
|
||||
|
||||
The `*ETAF Performance*` panel shows operation IDs and parent operations,
|
||||
generation changes, total latency, GC deltas, and nested stage inclusive/self
|
||||
time. Records are bounded by `etaf-performance-max-records`; disabling the
|
||||
mode removes all recorder advice. `etaf-performance-summary` computes
|
||||
operation p50/p95/max statistics on demand, while
|
||||
`etaf-performance-operation-stage-summary` ranks one operation's package
|
||||
categories by exclusive time.
|
||||
|
||||
The default registry deliberately uses coarse package boundaries to keep the
|
||||
measured application representative. A package or application can add a
|
||||
temporary detail probe without coupling itself to an example:
|
||||
|
||||
```elisp
|
||||
(etaf-performance-register-stage
|
||||
'my-package-expensive-step 'application 'expensive-step)
|
||||
```
|
||||
|
||||
Use `etaf-performance-call-operation` or
|
||||
`etaf-performance-with-operation` to trace an arbitrary operation that has no
|
||||
built-in public boundary.
|
||||
|
||||
## Executable examples
|
||||
|
||||
The [`examples/`](examples/README.md) directory contains three core-only best-practice applications: retained state and Actions, Data Controller ownership, and Resource error/cleanup lifecycle. They are byte-compiled and driven through mounted public event paths by `make check`.
|
||||
|
||||
@ -40,6 +40,80 @@ Component(props, Scope) → View → Renderer → Ebox Node → Emacs buffer
|
||||
|
||||
`etaf-view` 是唯一的公共 View 构造入口。结构 form 不使用 quote；quote 仍然是普通 Elisp 数据语法，例如 `'bold`。普通 Elisp 返回 View 时，必须在 `expr` 中显式使用 `(etaf-view ...)` 构造它。
|
||||
|
||||
## App 预编译
|
||||
|
||||
App 预编译是 ETAF core 的通用能力，不依赖 Playground。App 或宿主先注册文件
|
||||
清单和产物位置：
|
||||
|
||||
```elisp
|
||||
(etaf-register-app
|
||||
"my-app"
|
||||
:source "/path/to/my-app.el"
|
||||
:static "/path/to/my-app.etaf"
|
||||
:style "/path/to/my-app.ecss"
|
||||
:artifact "/path/to/build/my-app.etafc")
|
||||
```
|
||||
|
||||
用户手动执行一次：
|
||||
|
||||
```text
|
||||
M-x etaf-compile-app
|
||||
```
|
||||
|
||||
命令会选择已注册 App，并原子生成独立 `.etafc` 中间产物。查看状态使用：
|
||||
|
||||
```text
|
||||
M-x etaf-app-compile-status
|
||||
```
|
||||
|
||||
状态包括 `current`、`missing`、`stale` 和 `invalid`。ETAF 会记录 companion、
|
||||
`.etaf` 和 `.ecss` 的内容 hash；任一源码变化都会拒绝旧产物。宿主启动 App 时
|
||||
调用 `etaf-app-load-artifact-or-warn`：有效产物直接加载，缺失或过期则保持完整
|
||||
source fallback 功能，同时明确提醒用户运行 `M-x etaf-compile-app`。
|
||||
|
||||
`etaf-compiler.el` 只负责 blueprint 与 `.etafc` 的编译/校验；App 注册、交互
|
||||
命令、状态和回退提醒属于独立的 `etaf-app.el`。Playground 只是这个通用 API 的
|
||||
一个可选 UI consumer。
|
||||
|
||||
## 性能记录面板
|
||||
|
||||
ETAF 内置了一个按需启用、与具体应用无关的性能记录器。它自动识别公共
|
||||
Event、Action、mount、flush、focus、Data、Resource 和 viewport 操作；当
|
||||
Ebox、TP、SQLite 等包已加载时，还会把这些包的粗粒度阶段关联到同一个
|
||||
operation。
|
||||
|
||||
```elisp
|
||||
(etaf-performance-mode 1)
|
||||
;; 正常操作任意已挂载的 ETAF 应用。
|
||||
(etaf-performance-show)
|
||||
```
|
||||
|
||||
交互采集时先执行 `M-x etaf-performance-clear`，复现一组操作后，在面板按
|
||||
`c`（或执行 `M-x etaf-performance-copy-report`）即可把完整报告复制到剪贴板；
|
||||
按 `w`（或执行 `M-x etaf-performance-export`）可保存为 `.eld` 文件。报告包含
|
||||
Emacs/显示环境、电源来源、低功耗模式、系统负载、分组 p50/p95/max、每次
|
||||
operation、GC 增量和嵌套阶段；面板 header 也显示同一环境信息，避免把整机降频
|
||||
误判成某个包的热点。
|
||||
|
||||
`*ETAF Performance*` 面板会显示 operation ID 与父 operation、generation
|
||||
变化、总耗时、GC 增量，以及嵌套阶段的 inclusive/self 耗时。记录数量由
|
||||
`etaf-performance-max-records` 限制；关闭 mode 会移除全部记录 advice。
|
||||
`etaf-performance-summary` 会按需计算 operation 的 p50/p95/max，
|
||||
`etaf-performance-operation-stage-summary` 则按 exclusive 耗时排列单次
|
||||
operation 的包级阶段。
|
||||
|
||||
默认注册表刻意只记录包级粗边界，避免分析工具明显改变被测应用。任意包或
|
||||
应用可以临时增加更细的探针，不需要绑定某个示例：
|
||||
|
||||
```elisp
|
||||
(etaf-performance-register-stage
|
||||
'my-package-expensive-step 'application 'expensive-step)
|
||||
```
|
||||
|
||||
没有内置公共边界的任意操作，可以使用
|
||||
`etaf-performance-call-operation` 或 `etaf-performance-with-operation`
|
||||
包裹。
|
||||
|
||||
## 可执行示例
|
||||
|
||||
[`examples/`](examples/README.zh-CN.md) 目录包含三个只依赖 core 的最佳实践应用：保留式状态与 Action、Data Controller 所有权，以及 Resource 错误/清理 lifecycle。`make check` 会编译它们，并通过已挂载的公开事件路径驱动交互。
|
||||
|
||||
@ -48,6 +48,15 @@ Mount it into an Emacs buffer:
|
||||
(etaf-unmount (etaf-runtime-for-buffer "*etaf-hello*"))
|
||||
```
|
||||
|
||||
Headless hosts or callers that already know the final layout context can pass
|
||||
it with the optional third argument. The first Ebox publication then uses
|
||||
that viewport directly instead of immediately rerendering:
|
||||
|
||||
```elisp
|
||||
(etaf-mount buffer view
|
||||
'(:viewport-width 1200 :viewport-height 48))
|
||||
```
|
||||
|
||||
`etaf-render` is useful for pure, stateless rendering or tests:
|
||||
|
||||
```elisp
|
||||
@ -455,6 +464,14 @@ The Component emits the next value; the caller owns the ref and supplies the cur
|
||||
|
||||
The controller exposes reactive refs through `etaf-data-items`, `etaf-data-status`, `etaf-data-error`, `etaf-data-total`, `etaf-data-query`, `etaf-data-page`, `etaf-data-page-size`, and `etaf-data-selection`. Use `etaf-data-load`, `etaf-data-reload`, `etaf-data-mutate`, `etaf-data-set-query`, `etaf-data-next-page`, `etaf-data-previous-page`, `etaf-data-select` (additive multi-select), `etaf-data-select-one` (exclusive single-select), `etaf-data-selected-item`, and `etaf-data-stop` for operations. The imperative next/previous commands also reload a Controller whose `:auto-load` is nil; `:auto-load t` keeps reload ownership with the reactive effect.
|
||||
|
||||
`etaf-data-selected-ref` returns one stable boolean ref for a row identity. It
|
||||
updates only when that identity enters or leaves the main selection, including
|
||||
when application code writes `etaf-data-selection` directly. The default
|
||||
DataGrid path uses these refs with keyed retained row owners, so a single-select
|
||||
change invalidates the old and new rows rather than the complete visible page.
|
||||
Custom `:row-selected-p` and `:selected-key` contracts remain available when
|
||||
selection is owned outside the Controller.
|
||||
|
||||
`etaf-data-controller` accepts `:item-key` for stable selected-row lookup. When
|
||||
created inside a Component setup, its internal effect Scope is owned by the
|
||||
current Component Scope automatically; pass `:owner-scope` when integrating a
|
||||
@ -589,7 +606,39 @@ The independent Ebox playground demonstrates the lower-level layout contract:
|
||||
|
||||
It depends only on Ebox. Use it when inspecting Ebox boxes and Grid layout; use `etaf-playground` when inspecting Components, Runtime, Data, and the official catalog.
|
||||
|
||||
## 13. Public API map
|
||||
## 13. Performance records
|
||||
|
||||
Enable the generic recorder around any application workload, then open its
|
||||
ordinary `tabulated-list-mode` panel:
|
||||
|
||||
```elisp
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-show)
|
||||
```
|
||||
|
||||
Run `M-x etaf-performance-clear` before the measured reproduction. Afterwards,
|
||||
press `c` in the panel, or run `M-x etaf-performance-copy-report`, to copy the
|
||||
environment, summary, operation, GC, and stage data. Press `w`, or run
|
||||
`M-x etaf-performance-export`, to save the same portable report as an `.eld`
|
||||
file. The report and panel header include power source, low-power mode, and
|
||||
system load alongside the ordinary Emacs/display environment.
|
||||
|
||||
The recorder creates bounded operation records for public interaction,
|
||||
lifecycle, Data, Resource, and viewport boundaries. Loaded Ebox, TP, and
|
||||
SQLite functions contribute nested coarse stages without depending on ETAF.
|
||||
Each stage reports inclusive and exclusive milliseconds; failures and quits
|
||||
are recorded and then re-signaled unchanged.
|
||||
|
||||
`etaf-performance-summary` calculates grouped p50/p95/max statistics only when
|
||||
requested. `etaf-performance-operation-stage-summary` ranks the package
|
||||
categories of one recorded operation by exclusive time.
|
||||
|
||||
Use `etaf-performance-register-stage` for a temporary package-specific detail
|
||||
probe. Use `etaf-performance-with-operation` for application work that does
|
||||
not enter through a built-in public boundary. Disable the mode when the
|
||||
capture is complete; all installed advice is removed.
|
||||
|
||||
## 14. Public API map
|
||||
|
||||
| API family | Main entry points | Use it when |
|
||||
| --- | --- | --- |
|
||||
@ -606,10 +655,11 @@ It depends only on Ebox. Use it when inspecting Ebox boxes and Grid layout; use
|
||||
| Resource | `etaf-resource`, `etaf-resource-result`, `etaf-error-boundary-run` | Own loader state and cleanup |
|
||||
| Official UI | `require 'etaf-ui`, `etaf-button`, `etaf-checkbox`, `etaf-number-input`, `etaf-label`, `etaf-panel`, `etaf-data-grid` | Use ready-made Components |
|
||||
| Playground | `etaf-playground-open`, `etaf-playground-open-ui`, `etaf-playground-close`, `ebox-playground-open`, `ebox-playground-close` | Explore the corresponding layer interactively |
|
||||
| Performance | `etaf-performance-mode`, `etaf-performance-show`, `etaf-performance-copy-report`, `etaf-performance-export`, `etaf-performance-environment-data`, `etaf-performance-records`, `etaf-performance-summary`, `etaf-performance-operation-stage-summary`, `etaf-performance-with-operation`, `etaf-performance-register-stage` | Attribute generic operation latency across loaded packages and share reports |
|
||||
|
||||
Most applications need only `etaf-view`, `etaf-mount`, `etaf-define-component`, `etaf-ref`, and event callbacks at first. The remaining APIs are additive capabilities, not prerequisites for understanding the core grammar.
|
||||
|
||||
## 14. Common mistakes
|
||||
## 15. Common mistakes
|
||||
|
||||
- Put every property before the first child.
|
||||
- Use `:face 'bold`, not `:face :bold`; a face is an Elisp symbol value, not a property keyword.
|
||||
|
||||
@ -48,6 +48,15 @@ ETAF 依赖独立的 Ebox 包。开发时把核心检出目录放入 `load-path`
|
||||
(etaf-unmount (etaf-runtime-for-buffer "*etaf-hello*"))
|
||||
```
|
||||
|
||||
Headless host 或已经知道最终布局上下文的调用方，可以通过可选第三个参数传入
|
||||
初始 viewport。这样第一次 Ebox publication 会直接使用最终尺寸，不需要紧接着
|
||||
再 rerender：
|
||||
|
||||
```elisp
|
||||
(etaf-mount buffer view
|
||||
'(:viewport-width 1200 :viewport-height 48))
|
||||
```
|
||||
|
||||
纯渲染或测试可以使用 `etaf-render`：
|
||||
|
||||
```elisp
|
||||
@ -452,6 +461,13 @@ Component 发出 next value；ref 由调用方拥有，并在下一次 render
|
||||
|
||||
Controller 通过 `etaf-data-items`、`etaf-data-status`、`etaf-data-error`、`etaf-data-total`、`etaf-data-query`、`etaf-data-page`、`etaf-data-page-size` 和 `etaf-data-selection` 暴露响应式 ref。操作使用 `etaf-data-load`、`etaf-data-reload`、`etaf-data-mutate`、`etaf-data-set-query`、`etaf-data-next-page`、`etaf-data-previous-page`、`etaf-data-select`（追加式多选）、`etaf-data-select-one`（互斥单选）、`etaf-data-selected-item` 和 `etaf-data-stop`。当 Controller 的 `:auto-load` 为 nil 时，命令式的 next/previous 也会自动 reload；`:auto-load t` 时仍由 reactive effect 负责 reload，避免重复请求。
|
||||
|
||||
`etaf-data-selected-ref` 会为某个 row identity 返回稳定的 boolean ref；只有该
|
||||
identity 进入或离开主 selection 时它才会变化，应用直接写
|
||||
`etaf-data-selection` 时也一样。DataGrid 默认把这些 ref 与 keyed retained row
|
||||
owner 配合使用，因此单选变化只会使旧行和新行失效，而不是整个可见页。
|
||||
selection 由 Controller 外部拥有时，仍可使用自定义 `:row-selected-p` 与
|
||||
`:selected-key` 契约。
|
||||
|
||||
`etaf-data-controller` 支持用于稳定选中行查找的 `:item-key`。在 Component
|
||||
setup 中创建时，它的内部 effect Scope 会自动归当前 Component Scope 所有；如果
|
||||
需要接入其他显式 owner，可以传入 `:owner-scope`。`etaf-data-mutate` 会在 reload
|
||||
@ -584,7 +600,35 @@ Loader 错误会保存在 `etaf-resource-error`；cleanup/type 错误保持可
|
||||
|
||||
它只依赖 Ebox。检查 Ebox Box 和 Grid 布局时使用它；检查 Component、Runtime、Data 和官方目录时使用 `etaf-playground`。
|
||||
|
||||
## 13. 公共 API 速查
|
||||
## 13. 性能记录
|
||||
|
||||
对任意应用负载启用通用记录器，然后打开普通的 `tabulated-list-mode` 面板：
|
||||
|
||||
```elisp
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-show)
|
||||
```
|
||||
|
||||
正式复现前执行 `M-x etaf-performance-clear`。复现后在面板按 `c`，或者执行
|
||||
`M-x etaf-performance-copy-report`，可把环境、汇总、operation、GC 和阶段数据
|
||||
完整复制到剪贴板；按 `w` 或执行 `M-x etaf-performance-export` 可导出 `.eld`
|
||||
文件。报告和面板 header 还会显示电源来源、低功耗模式与系统负载。这两种报告
|
||||
都可以直接发送给分析者。
|
||||
|
||||
记录器会为公共交互、lifecycle、Data、Resource 和 viewport 边界创建有界的
|
||||
operation 记录。已加载的 Ebox、TP 与 SQLite 可以贡献嵌套的粗粒度阶段，
|
||||
但不需要反向依赖 ETAF。每个阶段同时报告 inclusive 与 exclusive 毫秒；
|
||||
error 和 quit 会先被记录，再保持原条件继续抛出。
|
||||
|
||||
`etaf-performance-summary` 只在请求时计算分组后的 p50/p95/max；
|
||||
`etaf-performance-operation-stage-summary` 会按 exclusive 时间排列某条记录
|
||||
中的包级阶段。
|
||||
|
||||
使用 `etaf-performance-register-stage` 临时加入包级细节探针。没有经过内置
|
||||
公共边界的应用操作可以使用 `etaf-performance-with-operation`。采集结束后
|
||||
关闭 mode，所有已安装 advice 都会被移除。
|
||||
|
||||
## 14. 公共 API 速查
|
||||
|
||||
| API 家族 | 主要入口 | 何时使用 |
|
||||
| --- | --- | --- |
|
||||
@ -601,10 +645,11 @@ Loader 错误会保存在 `etaf-resource-error`；cleanup/type 错误保持可
|
||||
| Resource | `etaf-resource`、`etaf-resource-result`、`etaf-error-boundary-run` | 管理 loader 状态和 cleanup |
|
||||
| 官方 UI | `require 'etaf-ui`、`etaf-button`、`etaf-checkbox`、`etaf-number-input`、`etaf-label`、`etaf-panel`、`etaf-data-grid` | 使用现成 Component |
|
||||
| Playground | `etaf-playground-open`、`etaf-playground-open-ui`、`etaf-playground-close`、`ebox-playground-open`、`ebox-playground-close` | 探索对应层 |
|
||||
| 性能分析 | `etaf-performance-mode`、`etaf-performance-show`、`etaf-performance-copy-report`、`etaf-performance-export`、`etaf-performance-environment-data`、`etaf-performance-records`、`etaf-performance-summary`、`etaf-performance-operation-stage-summary`、`etaf-performance-with-operation`、`etaf-performance-register-stage` | 跨已加载包定位通用 operation 的耗时并分享报告 |
|
||||
|
||||
大多数应用一开始只需要 `etaf-view`、`etaf-mount`、`etaf-define-component`、`etaf-ref` 和事件 callback。其余 API 都是可选能力，不是理解核心语法的前置条件。
|
||||
|
||||
## 14. 常见错误
|
||||
## 15. 常见错误
|
||||
|
||||
- 所有属性必须放在第一个子节点之前。
|
||||
- 使用 `:face 'bold`，不要使用 `:face :bold`；face 是 Elisp symbol 值，不是属性 keyword。
|
||||
|
||||
204
etaf-app.el
Normal file
204
etaf-app.el
Normal file
@ -0,0 +1,204 @@
|
||||
;;; etaf-app.el --- ETAF App registry and compile workflow -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This module owns the user-facing App boundary. The compiler remains a pure
|
||||
;; engine; hosts such as etaf-playground register source manifests here and use
|
||||
;; the same compile/status/fallback workflow as any other ETAF application.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-compiler)
|
||||
|
||||
(cl-defstruct (etaf-app-spec (:constructor etaf-app--spec-create))
|
||||
name source-file static-file style-file artifact-file)
|
||||
|
||||
(defvar etaf-app--registry (make-hash-table :test #'equal))
|
||||
(defvar etaf-app--warning-state (make-hash-table :test #'equal))
|
||||
(defvar etaf-app--status-cache (make-hash-table :test #'equal))
|
||||
|
||||
(declare-function ebox-native-reflow-load "ebox-native-reflow" ())
|
||||
(declare-function ebox-native-reflow-layout-ready-p "ebox-native-reflow" ())
|
||||
|
||||
(defun etaf-app--prepare-runtime-accelerator ()
|
||||
"Load the optional compiled Ebox runtime and return its status."
|
||||
(if (not (require 'ebox-native-reflow nil t))
|
||||
'unavailable
|
||||
(condition-case _error
|
||||
(progn
|
||||
(ebox-native-reflow-load)
|
||||
(if (ebox-native-reflow-layout-ready-p) 'ready 'unavailable))
|
||||
(error 'unavailable))))
|
||||
|
||||
(defcustom etaf-app-warn-on-artifact-fallback t
|
||||
"Whether running an uncompiled or stale App emits a warning."
|
||||
:type 'boolean
|
||||
:group 'etaf)
|
||||
|
||||
;;;###autoload
|
||||
(cl-defun etaf-register-app
|
||||
(name &key source static style artifact)
|
||||
"Register App NAME and its SOURCE, STATIC, STYLE, and ARTIFACT files."
|
||||
(setq name (if (symbolp name) (symbol-name name) name))
|
||||
(unless (and (stringp name) (stringp source) (stringp static)
|
||||
(stringp artifact))
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-app-manifest name source static style artifact)))
|
||||
(let ((spec (etaf-app--spec-create
|
||||
:name name
|
||||
:source-file (expand-file-name source)
|
||||
:static-file (expand-file-name static)
|
||||
:style-file (and style (expand-file-name style))
|
||||
:artifact-file (expand-file-name artifact))))
|
||||
(unless (equal spec (gethash name etaf-app--registry))
|
||||
(remhash name etaf-app--status-cache))
|
||||
(puthash name spec etaf-app--registry)
|
||||
spec))
|
||||
|
||||
(defun etaf-app-names ()
|
||||
"Return registered App names in stable order."
|
||||
(let (names)
|
||||
(maphash (lambda (name _spec) (push name names)) etaf-app--registry)
|
||||
(sort names #'string<)))
|
||||
|
||||
(defun etaf-app-spec (name)
|
||||
"Return registered App NAME or signal a user error."
|
||||
(setq name (if (symbolp name) (symbol-name name) name))
|
||||
(or (gethash name etaf-app--registry)
|
||||
(user-error "Unknown ETAF App: %s" name)))
|
||||
|
||||
(defun etaf-app--interactive-name (prompt)
|
||||
"Read a registered App name using PROMPT."
|
||||
(let ((names (etaf-app-names)))
|
||||
(unless names (user-error "No ETAF Apps are registered"))
|
||||
(completing-read prompt names nil t nil nil (car names))))
|
||||
|
||||
(defun etaf-app--file-fingerprint (file)
|
||||
"Return a cheap invalidation fingerprint for FILE."
|
||||
(when-let ((attributes (and file (file-attributes file 'string))))
|
||||
(list file
|
||||
(file-attribute-size attributes)
|
||||
(file-attribute-modification-time attributes)
|
||||
(file-attribute-inode-number attributes))))
|
||||
|
||||
(defun etaf-app--spec-fingerprint (spec)
|
||||
"Return source/artifact invalidation facts for SPEC."
|
||||
(mapcar #'etaf-app--file-fingerprint
|
||||
(list (etaf-app-spec-source-file spec)
|
||||
(etaf-app-spec-static-file spec)
|
||||
(etaf-app-spec-style-file spec)
|
||||
(etaf-app-spec-artifact-file spec))))
|
||||
|
||||
(defun etaf-app--status (name &optional use-cache)
|
||||
"Return App NAME's compilation status plist.
|
||||
USE-CACHE reuses a fully validated result while file fingerprints are stable."
|
||||
(let* ((spec (etaf-app-spec name))
|
||||
(file (etaf-app-spec-artifact-file spec))
|
||||
(fingerprint (etaf-app--spec-fingerprint spec))
|
||||
(cached (and use-cache (gethash name etaf-app--status-cache)))
|
||||
(source-directory
|
||||
(file-name-directory (etaf-app-spec-source-file spec))))
|
||||
(if (and cached (equal fingerprint (car cached)))
|
||||
(cdr cached)
|
||||
(let ((status
|
||||
(if (not (file-readable-p file))
|
||||
(list :app (etaf-app-spec-name spec)
|
||||
:status 'missing :file file)
|
||||
(condition-case err
|
||||
(let ((artifact
|
||||
(etaf-load-app-artifact file source-directory)))
|
||||
(list :app (etaf-app-spec-name spec)
|
||||
:status 'current :file file
|
||||
:blueprints
|
||||
(length (plist-get artifact :blueprints))
|
||||
:artifact artifact))
|
||||
(etaf-compiler-stale-artifact
|
||||
(list :app (etaf-app-spec-name spec) :status 'stale
|
||||
:file file :error err))
|
||||
(etaf-compiler-artifact-error
|
||||
(list :app (etaf-app-spec-name spec) :status 'invalid
|
||||
:file file :error err))
|
||||
(error
|
||||
(list :app (etaf-app-spec-name spec) :status 'invalid
|
||||
:file file :error err))))))
|
||||
(puthash name (cons fingerprint status) etaf-app--status-cache)
|
||||
(unless (eq (plist-get status :status) 'current)
|
||||
(etaf-compiler-deactivate-app-artifact name))
|
||||
status))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-app-compile-status (&optional name)
|
||||
"Show and return compilation status for App NAME."
|
||||
(interactive (list (etaf-app--interactive-name "ETAF App status: ")))
|
||||
(setq name (or name (car (etaf-app-names))))
|
||||
(let* ((status (etaf-app--status name))
|
||||
(state (plist-get status :status))
|
||||
(detail
|
||||
(pcase state
|
||||
('current (format "compiled, current, %d blueprints"
|
||||
(plist-get status :blueprints)))
|
||||
('missing "not compiled")
|
||||
('stale "compiled artifact is stale")
|
||||
(_ "compiled artifact is invalid"))))
|
||||
(when (called-interactively-p 'interactive)
|
||||
(message "ETAF App %s: %s (%s)"
|
||||
name detail (plist-get status :file)))
|
||||
status))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-compile-app (&optional name)
|
||||
"Compile registered App NAME into its standalone `.etafc' artifact."
|
||||
(interactive (list (etaf-app--interactive-name "Compile ETAF App: ")))
|
||||
(setq name (or name (car (etaf-app-names))))
|
||||
(let* ((spec (etaf-app-spec name))
|
||||
(output (etaf-app-spec-artifact-file spec)))
|
||||
(etaf-compiler-write-app-artifact
|
||||
:name (etaf-app-spec-name spec)
|
||||
:source (etaf-app-spec-source-file spec)
|
||||
:static (etaf-app-spec-static-file spec)
|
||||
:style (etaf-app-spec-style-file spec)
|
||||
:output output)
|
||||
(remhash name etaf-app--warning-state)
|
||||
(remhash name etaf-app--status-cache)
|
||||
(let ((status (etaf-app--status name)))
|
||||
(unless (eq (plist-get status :status) 'current)
|
||||
(error "ETAF App compilation produced an unusable artifact: %S"
|
||||
status))
|
||||
(when (called-interactively-p 'interactive)
|
||||
(message "Compiled ETAF App %s: %s (%d blueprints)"
|
||||
name output (plist-get status :blueprints)))
|
||||
(setq status
|
||||
(plist-put (copy-sequence status) :runtime-accelerator
|
||||
(etaf-app--prepare-runtime-accelerator)))
|
||||
status)))
|
||||
|
||||
(defun etaf-app--warn-fallback (name status)
|
||||
"Warn once that App NAME is using source fallback because of STATUS."
|
||||
(when (and etaf-app-warn-on-artifact-fallback
|
||||
(not noninteractive)
|
||||
(not (eq (gethash name etaf-app--warning-state) status)))
|
||||
(puthash name status etaf-app--warning-state)
|
||||
(display-warning
|
||||
'etaf
|
||||
(format (concat "ETAF App %s is %s; running the slower source fallback. "
|
||||
"Run M-x etaf-compile-app.")
|
||||
name status)
|
||||
:warning)))
|
||||
|
||||
(defun etaf-app-load-artifact-or-warn (name)
|
||||
"Return App NAME's current artifact, or warn and return nil."
|
||||
(let* ((status (etaf-app--status name t))
|
||||
(state (plist-get status :status)))
|
||||
(if (eq state 'current)
|
||||
(progn
|
||||
(etaf-app--prepare-runtime-accelerator)
|
||||
(plist-get status :artifact))
|
||||
(etaf-compiler-note-artifact-miss state)
|
||||
(etaf-app--warn-fallback name state)
|
||||
nil)))
|
||||
|
||||
(provide 'etaf-app)
|
||||
;;; etaf-app.el ends here
|
||||
437
etaf-compiler.el
Normal file
437
etaf-compiler.el
Normal file
@ -0,0 +1,437 @@
|
||||
;;; etaf-compiler.el --- AOT View blueprints for ETAF -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This is the first compiler slice: structured View topology and literal
|
||||
;; values are emitted into an immutable blueprint during byte compilation.
|
||||
;; Runtime instantiation constructs only nodes on paths containing dynamic
|
||||
;; property holes. Unsupported structural forms use the existing View
|
||||
;; compiler unchanged.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'etaf-view)
|
||||
|
||||
(defvar read-eval)
|
||||
|
||||
(defconst etaf-compiler-blueprint-abi "etaf-view-blueprint/1")
|
||||
(defconst etaf-compiler-app-artifact-abi "etaf-app/3")
|
||||
|
||||
(define-error 'etaf-compiler-artifact-error "Invalid ETAF App artifact")
|
||||
(define-error 'etaf-compiler-stale-artifact "Stale ETAF App artifact"
|
||||
'etaf-compiler-artifact-error)
|
||||
|
||||
(defvar etaf-compiler--static-cache (make-hash-table :test #'equal))
|
||||
(defvar etaf-compiler--artifact-blueprints (make-hash-table :test #'equal))
|
||||
(defvar etaf-compiler--artifact-blueprint-owners
|
||||
(make-hash-table :test #'equal))
|
||||
(defvar etaf-compiler--active-artifacts (make-hash-table :test #'equal))
|
||||
(defvar etaf-compiler--registry-epoch 0)
|
||||
(defvar etaf-compiler--instantiate-count 0)
|
||||
(defvar etaf-compiler--fallback-count 0)
|
||||
(defvar etaf-compiler--last-blueprint nil)
|
||||
(defvar etaf-compiler--artifact-hit-count 0)
|
||||
(defvar etaf-compiler--artifact-miss-count 0)
|
||||
(defvar etaf-compiler--last-artifact-status nil)
|
||||
|
||||
(defun etaf-compiler-deactivate-app-artifact (name)
|
||||
"Remove App NAME's active artifact and unowned blueprints."
|
||||
(when-let ((artifact (gethash name etaf-compiler--active-artifacts)))
|
||||
(dolist (entry (plist-get artifact :blueprints))
|
||||
(let* ((id (plist-get entry :id))
|
||||
(owners (delete name
|
||||
(copy-sequence
|
||||
(gethash id
|
||||
etaf-compiler--artifact-blueprint-owners)))))
|
||||
(if owners
|
||||
(puthash id owners etaf-compiler--artifact-blueprint-owners)
|
||||
(remhash id etaf-compiler--artifact-blueprint-owners)
|
||||
(remhash id etaf-compiler--artifact-blueprints))))
|
||||
(remhash name etaf-compiler--active-artifacts)))
|
||||
|
||||
(defun etaf-compiler-note-registry-change ()
|
||||
"Invalidate the static Component-call cache after a registry change."
|
||||
(cl-incf etaf-compiler--registry-epoch)
|
||||
(clrhash etaf-compiler--static-cache))
|
||||
|
||||
(defun etaf-compiler-clear-cache ()
|
||||
"Clear all process-local compiled View materializations."
|
||||
(interactive)
|
||||
(clrhash etaf-compiler--static-cache))
|
||||
|
||||
(defun etaf-compiler-note-artifact-miss (reason)
|
||||
"Record a rejected or unavailable App artifact REASON."
|
||||
(cl-incf etaf-compiler--artifact-miss-count)
|
||||
(setq etaf-compiler--last-artifact-status reason))
|
||||
|
||||
(defun etaf-compiler-statistics ()
|
||||
"Return a read-only snapshot of compiler runtime statistics."
|
||||
(list :abi etaf-compiler-blueprint-abi
|
||||
:instantiations etaf-compiler--instantiate-count
|
||||
:fallbacks etaf-compiler--fallback-count
|
||||
:artifact-hits etaf-compiler--artifact-hit-count
|
||||
:artifact-misses etaf-compiler--artifact-miss-count
|
||||
:last-artifact-status etaf-compiler--last-artifact-status
|
||||
:static-cache-entries (hash-table-count etaf-compiler--static-cache)
|
||||
:last-blueprint
|
||||
(and etaf-compiler--last-blueprint
|
||||
(list :id (plist-get etaf-compiler--last-blueprint :id)
|
||||
:static-nodes
|
||||
(plist-get etaf-compiler--last-blueprint :static-nodes)
|
||||
:dynamic-nodes
|
||||
(plist-get etaf-compiler--last-blueprint :dynamic-nodes)
|
||||
:hole-count
|
||||
(plist-get etaf-compiler--last-blueprint :hole-count)))
|
||||
:registry-epoch etaf-compiler--registry-epoch))
|
||||
|
||||
(defun etaf-compiler--read-forms (file)
|
||||
"Read every inert Lisp form from FILE."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(goto-char (point-min))
|
||||
(let ((read-eval nil) forms form done)
|
||||
(while (not done)
|
||||
(condition-case nil
|
||||
(progn (setq form (read (current-buffer))) (push form forms))
|
||||
(end-of-file (setq done t))))
|
||||
(nreverse forms))))
|
||||
|
||||
(defun etaf-compiler--read-single-form (file)
|
||||
"Read exactly one inert Lisp form from FILE."
|
||||
(let ((forms (etaf-compiler--read-forms file)))
|
||||
(unless (= (length forms) 1)
|
||||
(signal 'etaf-compiler-artifact-error
|
||||
(list :expected-one-form file (length forms))))
|
||||
(car forms)))
|
||||
|
||||
(defun etaf-compiler--collect-blueprints (form)
|
||||
"Return compiled blueprints found below source FORM."
|
||||
(let (blueprints)
|
||||
(cl-labels
|
||||
((visit (value)
|
||||
(when (consp value)
|
||||
(cond
|
||||
((memq (car value) '(quote function)) nil)
|
||||
((and (memq (car value) '(etaf-view etaf-compiled-view))
|
||||
(cadr value))
|
||||
(when-let* ((compiled (etaf-compiler--compile (cadr value)))
|
||||
(blueprint (car compiled))
|
||||
((etaf-compiler--beneficial-blueprint-p blueprint)))
|
||||
(push blueprint blueprints)))
|
||||
(t (visit (car value))
|
||||
(visit (cdr value)))))))
|
||||
(visit form))
|
||||
(nreverse blueprints)))
|
||||
|
||||
(defun etaf-compiler--source-record (file)
|
||||
"Return the content hash record for FILE."
|
||||
(list :file (file-name-nondirectory file)
|
||||
:sha256 (with-temp-buffer
|
||||
(insert-file-contents-literally file)
|
||||
(secure-hash 'sha256 (current-buffer)))))
|
||||
|
||||
(defun etaf-compiler--write-artifact (artifact output)
|
||||
"Atomically write data-only ARTIFACT to OUTPUT."
|
||||
(let* ((directory (file-name-directory (expand-file-name output)))
|
||||
(_ (make-directory directory t))
|
||||
(temporary (make-temp-file (expand-file-name ".etafc-" directory))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-temp-file temporary
|
||||
(let ((print-circle nil) (print-length nil) (print-level nil))
|
||||
(prin1 artifact (current-buffer))
|
||||
(insert "\n")))
|
||||
(rename-file temporary output t)
|
||||
(setq temporary nil)
|
||||
output)
|
||||
(when (and temporary (file-exists-p temporary))
|
||||
(delete-file temporary)))))
|
||||
|
||||
;;;###autoload
|
||||
(cl-defun etaf-compiler-write-app-artifact
|
||||
(&key name source static style output)
|
||||
"Compile one App into data-only OUTPUT.
|
||||
NAME identifies the App. SOURCE is its Elisp companion, STATIC its inert
|
||||
`.etaf' input, and STYLE its optional `.ecss' input."
|
||||
(unless (and (stringp name) (file-readable-p source)
|
||||
(file-readable-p static) (stringp output))
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-app-source name source static output)))
|
||||
(let (blueprints)
|
||||
(dolist (form (etaf-compiler--read-forms source))
|
||||
(setq blueprints
|
||||
(append blueprints
|
||||
(etaf-compiler--collect-blueprints form))))
|
||||
(setq blueprints
|
||||
(delete-dups blueprints))
|
||||
(let ((artifact
|
||||
(list :kind 'etaf/app-artifact
|
||||
:abi etaf-compiler-app-artifact-abi
|
||||
:app name
|
||||
:sources
|
||||
(delq nil
|
||||
(list (etaf-compiler--source-record source)
|
||||
(etaf-compiler--source-record static)
|
||||
(and style (etaf-compiler--source-record style))))
|
||||
:static-form (etaf-compiler--read-single-form static)
|
||||
:style-form (and style
|
||||
(etaf-compiler--read-single-form style))
|
||||
:blueprints
|
||||
(mapcar (lambda (blueprint)
|
||||
(list :id (plist-get blueprint :id)
|
||||
:blueprint blueprint))
|
||||
blueprints))))
|
||||
(etaf-compiler--write-artifact artifact output))))
|
||||
|
||||
(defun etaf-compiler--validate-source-records (artifact base-directory)
|
||||
"Signal when ARTIFACT does not match BASE-DIRECTORY."
|
||||
(dolist (record (plist-get artifact :sources))
|
||||
(let ((file (expand-file-name (plist-get record :file) base-directory)))
|
||||
(unless (and (file-readable-p file)
|
||||
(equal (with-temp-buffer
|
||||
(insert-file-contents-literally file)
|
||||
(secure-hash 'sha256 (current-buffer)))
|
||||
(plist-get record :sha256)))
|
||||
(signal 'etaf-compiler-stale-artifact
|
||||
(list :source file))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-load-app-artifact (file base-directory)
|
||||
"Load FILE after validating it against BASE-DIRECTORY."
|
||||
(let ((artifact (etaf-compiler--read-single-form file)))
|
||||
(unless (and (eq (plist-get artifact :kind) 'etaf/app-artifact)
|
||||
(equal (plist-get artifact :abi)
|
||||
etaf-compiler-app-artifact-abi)
|
||||
(stringp (plist-get artifact :app)))
|
||||
(signal 'etaf-compiler-artifact-error (list :manifest file)))
|
||||
(etaf-compiler--validate-source-records artifact base-directory)
|
||||
(etaf-compiler-deactivate-app-artifact (plist-get artifact :app))
|
||||
(dolist (entry (plist-get artifact :blueprints))
|
||||
(let ((blueprint (plist-get entry :blueprint)))
|
||||
(unless (and (equal (plist-get entry :id) (plist-get blueprint :id))
|
||||
(equal (plist-get blueprint :abi)
|
||||
etaf-compiler-blueprint-abi))
|
||||
(signal 'etaf-compiler-artifact-error
|
||||
(list :blueprint entry)))
|
||||
(puthash (plist-get entry :id) blueprint
|
||||
etaf-compiler--artifact-blueprints)
|
||||
(cl-pushnew (plist-get artifact :app)
|
||||
(gethash (plist-get entry :id)
|
||||
etaf-compiler--artifact-blueprint-owners)
|
||||
:test #'equal)))
|
||||
(puthash (plist-get artifact :app) artifact
|
||||
etaf-compiler--active-artifacts)
|
||||
(setq etaf-compiler--last-artifact-status 'loaded)
|
||||
artifact))
|
||||
|
||||
(defun etaf-compiler--literal (form)
|
||||
"Return `(t . VALUE)' when FORM is a portable literal, otherwise nil."
|
||||
(cond
|
||||
((or (null form) (eq form t) (numberp form) (stringp form)
|
||||
(characterp form) (keywordp form))
|
||||
(cons t form))
|
||||
((and (consp form) (eq (car form) 'quote) (null (cddr form)))
|
||||
(cons t (cadr form)))
|
||||
(t nil)))
|
||||
|
||||
(defun etaf-compiler--compile-property (form programs)
|
||||
"Compile property FORM, returning `(DESCRIPTOR . PROGRAMS)'."
|
||||
(if-let ((literal (etaf-compiler--literal form)))
|
||||
(cons (list :kind 'static :value (cdr literal)) programs)
|
||||
(let ((index (length programs)))
|
||||
(cons (list :kind 'hole :index index)
|
||||
(append programs (list `(lambda () ,form)))))))
|
||||
|
||||
(defun etaf-compiler--compile-block (form path programs)
|
||||
"Compile View FORM at PATH, returning `(BLOCK PROGRAMS)' or nil."
|
||||
(cond
|
||||
((or (null form) (stringp form))
|
||||
(list (list :kind 'literal :value form :path path :static-p t) programs))
|
||||
((not (and (consp form) (symbolp (car form)))) nil)
|
||||
((eq (car form) 'expr)
|
||||
(let ((index (length programs)))
|
||||
(list (list :kind 'expr :path path :hole index :static-p nil)
|
||||
(append programs
|
||||
(list `(lambda () ,(etaf--parse-expr-form (cdr form))))))))
|
||||
((memq (car form) '(slot raw-ebox)) nil)
|
||||
((etaf--ordinary-expression-head-p (car form)) nil)
|
||||
(t
|
||||
(let* ((parts (etaf--parse-attributes-and-children (cdr form)))
|
||||
(props (car parts))
|
||||
(children (cdr parts))
|
||||
(compiled-props nil)
|
||||
(compiled-children nil)
|
||||
(all-static t)
|
||||
(tail props)
|
||||
(child-index 0)
|
||||
result)
|
||||
(while tail
|
||||
(let* ((key (pop tail))
|
||||
(value (pop tail))
|
||||
(compiled (etaf-compiler--compile-property value programs))
|
||||
(descriptor (car compiled)))
|
||||
(setq programs (cdr compiled))
|
||||
(unless (eq (plist-get descriptor :kind) 'static)
|
||||
(setq all-static nil))
|
||||
(setq compiled-props
|
||||
(append compiled-props (list key descriptor)))))
|
||||
(while (and children (not (eq result 'unsupported)))
|
||||
(let ((compiled
|
||||
(etaf-compiler--compile-block
|
||||
(pop children) (append path (list child-index)) programs)))
|
||||
(if (not compiled)
|
||||
(setq result 'unsupported)
|
||||
(let ((block (car compiled)))
|
||||
(setq programs (cadr compiled)
|
||||
compiled-children (append compiled-children (list block)))
|
||||
(unless (plist-get block :static-p) (setq all-static nil)))))
|
||||
(cl-incf child-index))
|
||||
(unless (eq result 'unsupported)
|
||||
(list (list :kind 'node :name (car form) :path path
|
||||
:props compiled-props :children compiled-children
|
||||
:static-p all-static)
|
||||
programs))))))
|
||||
|
||||
(defun etaf-compiler--block-counts (block)
|
||||
"Return `(STATIC . DYNAMIC)' node counts below BLOCK."
|
||||
(if (eq (plist-get block :kind) 'literal)
|
||||
(cons 0 0)
|
||||
(let ((static (if (plist-get block :static-p) 1 0))
|
||||
(dynamic (if (plist-get block :static-p) 0 1)))
|
||||
(dolist (child (plist-get block :children))
|
||||
(pcase-let ((`(,child-static . ,child-dynamic)
|
||||
(etaf-compiler--block-counts child)))
|
||||
(cl-incf static child-static)
|
||||
(cl-incf dynamic child-dynamic)))
|
||||
(cons static dynamic))))
|
||||
|
||||
(defun etaf-compiler--beneficial-blueprint-p (blueprint)
|
||||
"Return non-nil when BLUEPRINT can reuse at least one static node."
|
||||
(> (or (plist-get blueprint :static-nodes) 0) 0))
|
||||
|
||||
(defun etaf-compiler--compile (form)
|
||||
"Compile FORM into `(BLUEPRINT PROGRAM-CODE...)', or return nil."
|
||||
(when-let ((compiled (etaf-compiler--compile-block form '(0) nil)))
|
||||
(let* ((root (car compiled))
|
||||
(programs (cadr compiled))
|
||||
(id (secure-hash 'sha256 (prin1-to-string form)))
|
||||
(counts (etaf-compiler--block-counts root)))
|
||||
(cons (list :kind 'etaf/view-blueprint
|
||||
:abi etaf-compiler-blueprint-abi
|
||||
:id id :root root
|
||||
:static-nodes (car counts)
|
||||
:dynamic-nodes (cdr counts)
|
||||
:hole-count (length programs))
|
||||
programs))))
|
||||
|
||||
(defun etaf-compiler--materialize (blueprint block programs)
|
||||
"Materialize BLOCK from BLUEPRINT using PROGRAMS."
|
||||
(let* ((static-p (plist-get block :static-p))
|
||||
(cache-key (and static-p
|
||||
(list (plist-get blueprint :id)
|
||||
(plist-get block :path)
|
||||
etaf-compiler--registry-epoch)))
|
||||
(missing (make-symbol "etaf-compiled-missing"))
|
||||
(cached (and cache-key
|
||||
(gethash cache-key etaf-compiler--static-cache missing))))
|
||||
(if (and cache-key (not (eq cached missing)))
|
||||
cached
|
||||
(let ((value
|
||||
(pcase (plist-get block :kind)
|
||||
('literal (plist-get block :value))
|
||||
('expr
|
||||
(etaf--expr-create
|
||||
:token (list 'etaf-compiled-site
|
||||
(plist-get blueprint :id)
|
||||
(plist-get block :path))
|
||||
:thunk (aref programs (plist-get block :hole))))
|
||||
('node
|
||||
(let ((props nil))
|
||||
(cl-loop for (key descriptor) on (plist-get block :props)
|
||||
by #'cddr
|
||||
do (setq props
|
||||
(append
|
||||
props
|
||||
(list
|
||||
key
|
||||
(if (eq (plist-get descriptor :kind)
|
||||
'static)
|
||||
(plist-get descriptor :value)
|
||||
(etaf--expr-create
|
||||
:thunk
|
||||
(aref programs
|
||||
(plist-get descriptor
|
||||
:index))))))))
|
||||
(etaf--view-call
|
||||
(plist-get block :name) props
|
||||
(mapcar (lambda (child)
|
||||
(etaf-compiler--materialize
|
||||
blueprint child programs))
|
||||
(plist-get block :children))
|
||||
(list 'etaf-compiled-site
|
||||
(plist-get blueprint :id)
|
||||
(plist-get block :path)))))
|
||||
(_ (error "Unknown ETAF compiled block: %S" block)))))
|
||||
(when cache-key
|
||||
(puthash cache-key value etaf-compiler--static-cache))
|
||||
value))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-compiler-instantiate (blueprint programs)
|
||||
"Instantiate compiled View BLUEPRINT with dynamic PROGRAMS."
|
||||
(unless (and (eq (plist-get blueprint :kind) 'etaf/view-blueprint)
|
||||
(equal (plist-get blueprint :abi)
|
||||
etaf-compiler-blueprint-abi)
|
||||
(stringp (plist-get blueprint :id))
|
||||
(vectorp programs)
|
||||
(= (length programs) (plist-get blueprint :hole-count)))
|
||||
(error "Invalid or incompatible ETAF View blueprint"))
|
||||
(let ((artifact-blueprint
|
||||
(gethash (plist-get blueprint :id)
|
||||
etaf-compiler--artifact-blueprints)))
|
||||
(if artifact-blueprint
|
||||
(progn
|
||||
(cl-incf etaf-compiler--artifact-hit-count)
|
||||
(setq etaf-compiler--last-artifact-status 'hit
|
||||
blueprint artifact-blueprint))
|
||||
(cl-incf etaf-compiler--artifact-miss-count)
|
||||
(setq etaf-compiler--last-artifact-status 'embedded-fallback))
|
||||
(cl-incf etaf-compiler--instantiate-count)
|
||||
(setq etaf-compiler--last-blueprint blueprint)
|
||||
(etaf-compiler--materialize
|
||||
blueprint (plist-get blueprint :root) programs)))
|
||||
|
||||
(defun etaf-compiler-expand-view
|
||||
(form &optional slot-mode artifact-required count-fallback)
|
||||
"Return compiler expansion for View FORM.
|
||||
SLOT-MODE is forwarded to the legacy compiler. ARTIFACT-REQUIRED keeps the
|
||||
legacy path unless a manually loaded artifact contains the blueprint.
|
||||
COUNT-FALLBACK records an unsupported explicit compiler request."
|
||||
(let* ((compiled (etaf-compiler--compile form))
|
||||
(blueprint (car compiled))
|
||||
(legacy (etaf--compile-view-form form (or slot-mode :projection))))
|
||||
(if (and compiled (etaf-compiler--beneficial-blueprint-p blueprint))
|
||||
(let ((instantiate
|
||||
`(etaf-compiler-instantiate
|
||||
',blueprint (vector ,@(cdr compiled)))))
|
||||
(if artifact-required
|
||||
`(if (gethash ,(plist-get blueprint :id)
|
||||
etaf-compiler--artifact-blueprints)
|
||||
,instantiate
|
||||
,legacy)
|
||||
instantiate))
|
||||
(if count-fallback
|
||||
`(progn (cl-incf etaf-compiler--fallback-count) ,legacy)
|
||||
legacy))))
|
||||
|
||||
;;;###autoload
|
||||
(defmacro etaf-compiled-view (form)
|
||||
"Compatibility spelling for explicitly compiled View FORM."
|
||||
(declare (indent 1) (debug (form)))
|
||||
(etaf-compiler-expand-view form :projection nil t))
|
||||
|
||||
(provide 'etaf-compiler)
|
||||
;;; etaf-compiler.el ends here
|
||||
@ -33,6 +33,20 @@ validated copy by Context frame avoids rebuilding the same semantic palette
|
||||
for every Host that reads one token, while weak keys let disposed Component
|
||||
Contexts disappear with their Runtime.")
|
||||
|
||||
(defvar etaf--theme-value-cache
|
||||
(make-hash-table :test #'eq :weakness 'key)
|
||||
"Theme-value identity cache of validated immutable palette snapshots.
|
||||
|
||||
Many descendant Context frames can inherit the same reactive Theme value.
|
||||
Caching the defensive copy by that shared value avoids validating and copying
|
||||
the complete palette once per consumer while keeping Context dependency reads
|
||||
unchanged.")
|
||||
|
||||
(cl-defstruct (etaf--theme-property-binding
|
||||
(:constructor etaf--theme-property-binding-create))
|
||||
"One reactive Theme token bound to a concrete Host property."
|
||||
property token source)
|
||||
|
||||
(defvar etaf--context-inject-recorder nil
|
||||
"Candidate-local function recording Context provider reads.")
|
||||
|
||||
@ -114,8 +128,9 @@ Hosts in the inherited subtree."
|
||||
(unless (keywordp key)
|
||||
(signal 'etaf-context-error
|
||||
(list (format "Theme default must use a keyword: %S" key))))
|
||||
(setq copy (append copy (list key value)))))
|
||||
copy))
|
||||
(push key copy)
|
||||
(push value copy)))
|
||||
(nreverse copy)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-theme-provide (theme)
|
||||
@ -125,10 +140,13 @@ THEME is a property plist such as `(:color \"#F4F6FB\" :bgcolor \"#202634\")'.
|
||||
Explicit Host properties and matching Component `:styles' declarations take
|
||||
precedence over these defaults. A reactive ref containing such a plist is
|
||||
also accepted and remains tracked by the current render effect."
|
||||
(etaf-provide 'theme
|
||||
(etaf-provide
|
||||
'theme
|
||||
(if (or (etaf-ref-p theme) (etaf-computed-p theme))
|
||||
theme
|
||||
(etaf--validate-theme-defaults theme))))
|
||||
(let ((validated (etaf--validate-theme-defaults theme)))
|
||||
(puthash validated validated etaf--theme-value-cache)
|
||||
validated))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-theme-defaults (&optional default)
|
||||
@ -147,7 +165,10 @@ also accepted and remains tracked by the current render effect."
|
||||
(let ((validated
|
||||
(if (and (proper-list-p value)
|
||||
(zerop (% (length value) 2)))
|
||||
(etaf--validate-theme-defaults value)
|
||||
(or (gethash value etaf--theme-value-cache)
|
||||
(let ((copy (etaf--validate-theme-defaults value)))
|
||||
(puthash value copy etaf--theme-value-cache)
|
||||
copy))
|
||||
default)))
|
||||
(puthash context
|
||||
(list :source theme :value value :default default
|
||||
@ -155,6 +176,29 @@ also accepted and remains tracked by the current render effect."
|
||||
etaf--theme-defaults-cache)
|
||||
validated))))
|
||||
|
||||
(defun etaf--theme-source (&optional default)
|
||||
"Return the inherited Theme source without reading its reactive value."
|
||||
(etaf-inject 'theme default))
|
||||
|
||||
(defun etaf--theme-source-value (source &optional default tracked-p)
|
||||
"Return SOURCE Theme value or DEFAULT.
|
||||
When TRACKED-P is nil, do not attach the read to the current render effect."
|
||||
(let ((value
|
||||
(if (or (etaf-ref-p source) (etaf-computed-p source))
|
||||
(let ((etaf--tracking-enabled-p tracked-p))
|
||||
(etaf-value source))
|
||||
source)))
|
||||
(if (and (proper-list-p value) (zerop (% (length value) 2)))
|
||||
value
|
||||
default)))
|
||||
|
||||
(defun etaf--theme-token-resolve-from-source (value source)
|
||||
"Resolve Theme token VALUE from SOURCE without render-effect tracking."
|
||||
(if (etaf-theme-token-p value)
|
||||
(let ((theme (etaf--theme-source-value source nil nil)))
|
||||
(etaf--theme-token-resolve-from-theme value theme))
|
||||
value))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-theme-value (key &optional default)
|
||||
"Return Theme property KEY from inherited defaults, or DEFAULT."
|
||||
@ -164,32 +208,56 @@ also accepted and remains tracked by the current render effect."
|
||||
default)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-theme-token (key &optional default)
|
||||
(defun etaf-theme-token (key &optional default transform)
|
||||
"Return a deferred Theme token for a static Component style.
|
||||
|
||||
KEY is resolved when ETAF lowers the Component's `:styles' declaration, so a
|
||||
static rule can use the current inherited Theme without turning every retained
|
||||
Host into an inline dynamic property. DEFAULT is used when KEY is absent.
|
||||
TRANSFORM, when non-nil, is a pure function applied after nested defaults have
|
||||
resolved; it lets a semantic color token lower to a backend value such as a
|
||||
border specification without reading Theme during Component render.
|
||||
The returned list is intentionally data, which also makes it safe to place
|
||||
directly in a quoted `(styles ...)' form."
|
||||
(unless (keywordp key)
|
||||
(signal 'etaf-context-error
|
||||
(list (format "Theme token keys must be keywords: %S" key))))
|
||||
(list 'etaf-theme-token key default))
|
||||
(when (and transform (not (functionp transform)))
|
||||
(signal 'etaf-context-error
|
||||
(list (format "Theme token transform must be callable: %S"
|
||||
transform))))
|
||||
(append (list 'etaf-theme-token key default)
|
||||
(and transform (list transform))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-theme-token-p (value)
|
||||
"Return non-nil when VALUE is a deferred ETAF Theme token."
|
||||
(and (proper-list-p value)
|
||||
(memq (length value) '(2 3))
|
||||
(memq (length value) '(2 3 4))
|
||||
(eq (car value) 'etaf-theme-token)
|
||||
(keywordp (nth 1 value))))
|
||||
(keywordp (nth 1 value))
|
||||
(or (< (length value) 4) (functionp (nth 3 value)))))
|
||||
|
||||
(defun etaf--theme-token-resolve-from-theme (value theme)
|
||||
"Resolve token VALUE from already resolved THEME data."
|
||||
(if (not (etaf-theme-token-p value))
|
||||
value
|
||||
(let* ((key (nth 1 value))
|
||||
(default (nth 2 value))
|
||||
(transform (nth 3 value))
|
||||
(resolved
|
||||
(if (plist-member theme key) (plist-get theme key) default))
|
||||
(resolved
|
||||
(if (etaf-theme-token-p resolved)
|
||||
(etaf--theme-token-resolve-from-theme resolved theme)
|
||||
resolved)))
|
||||
(if transform (funcall transform resolved) resolved))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-theme-token-resolve (value)
|
||||
"Resolve deferred Theme token VALUE, or return ordinary VALUE unchanged."
|
||||
(if (etaf-theme-token-p value)
|
||||
(etaf-theme-value (nth 1 value) (nth 2 value))
|
||||
(etaf--theme-token-resolve-from-theme value (etaf-theme-defaults))
|
||||
value))
|
||||
|
||||
;;;###autoload
|
||||
@ -243,9 +311,9 @@ palette package may adapt its own registry into this shape at the boundary."
|
||||
(signal 'etaf-context-error
|
||||
(list (format "Theme palette key must be a keyword: %S"
|
||||
key))))
|
||||
(setq result
|
||||
(append result (list key (etaf--theme-resolve-color value mode))))))
|
||||
result))
|
||||
(push key result)
|
||||
(push (etaf--theme-resolve-color value mode) result)))
|
||||
(nreverse result)))
|
||||
|
||||
(provide 'etaf-context)
|
||||
|
||||
|
||||
107
etaf-data.el
107
etaf-data.el
@ -37,7 +37,9 @@
|
||||
request-id
|
||||
stopped-p
|
||||
auto-load-p
|
||||
item-key)
|
||||
item-key
|
||||
selection-snapshot
|
||||
selected-refs)
|
||||
|
||||
(defun etaf-data-source (&rest capabilities)
|
||||
"Create a Data source from callable CAPABILITIES.
|
||||
@ -204,6 +206,17 @@ and `reset'."
|
||||
(error "ETAF Data source load result lacks :items"))
|
||||
result)
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-data-source-load-page
|
||||
(source &optional query page page-size)
|
||||
"Load and normalize one SOURCE page without creating a Controller.
|
||||
QUERY is passed through unchanged. PAGE and PAGE-SIZE default to 1 and 20.
|
||||
This public preparation boundary performs no reactive publication; callers may
|
||||
use its result as `:initial-result' for `etaf-data-controller'."
|
||||
(etaf-data--normalize-result
|
||||
(funcall (etaf-data--source-function source :load t)
|
||||
query (max 1 (or page 1)) (max 1 (or page-size 20)))))
|
||||
|
||||
(defun etaf-data--apply-load-success (controller request-id result)
|
||||
"Publish successful RESULT for CONTROLLER when REQUEST-ID is current."
|
||||
(when (= request-id (etaf-data--controller-request-id controller))
|
||||
@ -238,7 +251,7 @@ and `reset'."
|
||||
;;;###autoload
|
||||
(cl-defun etaf-data-controller
|
||||
(source &key query (page 1) (page-size 20) selection auto-load name
|
||||
item-key owner-scope)
|
||||
item-key owner-scope initial-result)
|
||||
"Create a reactive Data Controller for SOURCE.
|
||||
|
||||
QUERY, PAGE, PAGE-SIZE, result ITEMS, TOTAL, STATUS, ERROR, and SELECTION are
|
||||
@ -248,12 +261,29 @@ controller for diagnostics. ITEM-KEY is a function used by
|
||||
`etaf-data-selected-item' to match a selected identity to one loaded item.
|
||||
When OWNER-SCOPE is supplied, or when a current ETAF Scope exists, the
|
||||
controller's own child Scope is disposed with that owner; otherwise it keeps
|
||||
the detached Scope behavior."
|
||||
the detached Scope behavior. INITIAL-RESULT may be a normalized source result
|
||||
for QUERY/PAGE/PAGE-SIZE; it seeds a successful Controller without another
|
||||
load. INITIAL-RESULT and AUTO-LOAD are mutually exclusive."
|
||||
(unless (etaf-data-source-p source)
|
||||
(signal 'wrong-type-argument (list 'etaf-data-source-p source)))
|
||||
(unless (or (null item-key) (functionp item-key))
|
||||
(signal 'wrong-type-argument (list 'functionp item-key)))
|
||||
(let* ((owner-scope (or owner-scope (etaf-current-effect-scope)))
|
||||
(when (and initial-result auto-load)
|
||||
(error "ETAF Data :initial-result and :auto-load are mutually exclusive"))
|
||||
(let* ((initial-result (and initial-result
|
||||
(etaf-data--normalize-result initial-result)))
|
||||
(initial-items (and initial-result
|
||||
(plist-get initial-result :items)))
|
||||
(initial-page (if (and initial-result
|
||||
(plist-member initial-result :page))
|
||||
(plist-get initial-result :page)
|
||||
page))
|
||||
(initial-page-size
|
||||
(if (and initial-result
|
||||
(plist-member initial-result :page-size))
|
||||
(plist-get initial-result :page-size)
|
||||
page-size))
|
||||
(owner-scope (or owner-scope (etaf-current-effect-scope)))
|
||||
(scope (if owner-scope
|
||||
(etaf-scope-run
|
||||
owner-scope
|
||||
@ -265,20 +295,56 @@ the detached Scope behavior."
|
||||
:source source
|
||||
:scope scope
|
||||
:query (etaf-ref query :name 'etaf-data-query)
|
||||
:page (etaf-ref page :name 'etaf-data-page)
|
||||
:page-size (etaf-ref page-size :name 'etaf-data-page-size)
|
||||
:items (etaf-ref nil :name 'etaf-data-items)
|
||||
:total (etaf-ref 0 :name 'etaf-data-total)
|
||||
:status (etaf-ref 'idle :name 'etaf-data-status)
|
||||
:page (etaf-ref initial-page :name 'etaf-data-page)
|
||||
:page-size (etaf-ref initial-page-size :name 'etaf-data-page-size)
|
||||
:items (etaf-ref initial-items :name 'etaf-data-items)
|
||||
:total (etaf-ref (if initial-result
|
||||
(or (plist-get initial-result :total)
|
||||
(length initial-items))
|
||||
0)
|
||||
:name 'etaf-data-total)
|
||||
:status (etaf-ref (if initial-result 'success 'idle)
|
||||
:name 'etaf-data-status)
|
||||
:error (etaf-ref nil :name 'etaf-data-error)
|
||||
:selection (etaf-ref (copy-sequence selection)
|
||||
:name 'etaf-data-selection)
|
||||
:selection-snapshot (copy-sequence selection)
|
||||
:selected-refs (make-hash-table :test #'equal :weakness 'value)
|
||||
:request-id 0
|
||||
:auto-load-p auto-load
|
||||
:item-key item-key)))
|
||||
(etaf-scope-run
|
||||
scope
|
||||
(lambda ()
|
||||
(etaf-watch
|
||||
(etaf-data--controller-selection controller)
|
||||
(lambda (new-selection old-selection)
|
||||
(setf (etaf-data--controller-selection-snapshot controller)
|
||||
new-selection)
|
||||
(let ((selected-refs
|
||||
(etaf-data--controller-selected-refs controller)))
|
||||
(unless (zerop (hash-table-count selected-refs))
|
||||
(let ((old-set (make-hash-table :test #'equal))
|
||||
(new-set (make-hash-table :test #'equal)))
|
||||
(dolist (identity old-selection)
|
||||
(puthash identity t old-set))
|
||||
(dolist (identity new-selection)
|
||||
(puthash identity t new-set))
|
||||
(maphash
|
||||
(lambda (identity _present)
|
||||
(unless (gethash identity new-set)
|
||||
(when-let ((selected-ref
|
||||
(gethash identity selected-refs)))
|
||||
(setf (etaf-value selected-ref) nil))))
|
||||
old-set)
|
||||
(maphash
|
||||
(lambda (identity _present)
|
||||
(unless (gethash identity old-set)
|
||||
(when-let ((selected-ref
|
||||
(gethash identity selected-refs)))
|
||||
(setf (etaf-value selected-ref) t))))
|
||||
new-set)))))
|
||||
:name 'etaf-data-selection-index)
|
||||
(let ((effect
|
||||
(etaf-reactive-effect-create
|
||||
(lambda ()
|
||||
@ -295,6 +361,7 @@ the detached Scope behavior."
|
||||
(etaf-reactive-effect-run effect))
|
||||
(etaf-on-scope-dispose
|
||||
(lambda ()
|
||||
(clrhash (etaf-data--controller-selected-refs controller))
|
||||
(when-let ((dispose (etaf-data--source-function
|
||||
source :dispose nil)))
|
||||
(funcall dispose))))))
|
||||
@ -395,6 +462,28 @@ The status value is one of `idle', `loading', `success', or `error'."
|
||||
(etaf-data--controller-selection
|
||||
(etaf-data--require-controller controller)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-data-selected-ref (controller identity)
|
||||
"Return CONTROLLER's stable boolean selection ref for IDENTITY.
|
||||
|
||||
The returned ref changes only when IDENTITY enters or leaves the controller's
|
||||
selection. Repeated calls for the same identity return the same ref for the
|
||||
controller lifetime. Updates made through the selection APIs or by writing
|
||||
the public `etaf-data-selection' ref directly are both reflected."
|
||||
(setq controller (etaf-data--require-controller controller))
|
||||
(let* ((refs (etaf-data--controller-selected-refs controller))
|
||||
(selected-ref (gethash identity refs)))
|
||||
(or selected-ref
|
||||
(let ((created
|
||||
(etaf-ref
|
||||
(not (null
|
||||
(member identity
|
||||
(etaf-data--controller-selection-snapshot
|
||||
controller))))
|
||||
:name 'etaf-data-selected)))
|
||||
(puthash identity created refs)
|
||||
created))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-data-selected-item (controller &optional item-key)
|
||||
"Return the loaded item matching CONTROLLER's first selected identity.
|
||||
|
||||
@ -28,6 +28,8 @@
|
||||
(declare-function etaf-runtime-set-focus-ref "etaf-runtime" (runtime host-ref))
|
||||
(declare-function etaf-runtime-event-begin "etaf-runtime" (runtime))
|
||||
(declare-function etaf-runtime-event-end "etaf-runtime" (runtime))
|
||||
(declare-function ebox-call-with-render-burst
|
||||
"ebox-buffer-backend" (function &rest arguments))
|
||||
|
||||
(define-error 'etaf-event-error "Invalid ETAF Event")
|
||||
|
||||
@ -59,6 +61,8 @@
|
||||
|
||||
When PAYLOAD-P is non-nil, pass PAYLOAD as the callback's only argument;
|
||||
otherwise call the local callback with no arguments."
|
||||
(let ((dispatch
|
||||
(lambda ()
|
||||
(setq runtime (etaf-runtime-require-mounted runtime))
|
||||
(let ((callback (etaf--event-handler runtime host-ref kind)))
|
||||
(unless callback
|
||||
@ -74,7 +78,8 @@ otherwise call the local callback with no arguments."
|
||||
(if payload-p
|
||||
(funcall callback payload)
|
||||
(funcall callback))
|
||||
(etaf-runtime-event-end runtime)))))
|
||||
(etaf-runtime-event-end runtime)))))))
|
||||
(ebox-call-with-render-burst dispatch)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-host-ref-bounds (runtime host-ref)
|
||||
|
||||
902
etaf-performance.el
Normal file
902
etaf-performance.el
Normal file
@ -0,0 +1,902 @@
|
||||
;;; etaf-performance.el --- Cross-package ETAF performance records -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Commentary:
|
||||
|
||||
;; This opt-in recorder follows one user-visible ETAF operation through the
|
||||
;; reactive, data, Ebox, and TP layers. Other packages remain independent:
|
||||
;; instrumentation is attached here, after those packages are loaded.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'pp)
|
||||
(require 'ring)
|
||||
(require 'seq)
|
||||
(require 'tabulated-list)
|
||||
|
||||
(defgroup etaf-performance nil
|
||||
"Operation and stage timing for ETAF applications."
|
||||
:group 'etaf)
|
||||
|
||||
(defcustom etaf-performance-max-records 200
|
||||
"Maximum completed operations retained by the recorder."
|
||||
:type 'integer
|
||||
:group 'etaf-performance)
|
||||
|
||||
(defconst etaf-performance-report-format-version 1
|
||||
"Current portable performance report format version.")
|
||||
|
||||
(cl-defstruct (etaf-performance-stage
|
||||
(:constructor etaf-performance--stage-create))
|
||||
"One timed stage inside an ETAF operation.
|
||||
All duration fields are milliseconds."
|
||||
id category function detail depth start-time end-time inclusive exclusive
|
||||
status)
|
||||
|
||||
(cl-defstruct (etaf-performance-operation
|
||||
(:constructor etaf-performance--operation-create))
|
||||
"One bounded, user-visible ETAF operation record.
|
||||
ELAPSED is milliseconds; START-TIME and END-TIME are wall-clock seconds."
|
||||
id parent-id kind label runtime-id buffer-name generation-before generation-after
|
||||
start-time end-time elapsed status
|
||||
gc-count-before gc-count-after gc-elapsed-before gc-elapsed-after metadata
|
||||
stages)
|
||||
|
||||
(cl-defstruct (etaf-performance--stage-frame
|
||||
(:constructor etaf-performance--stage-frame-create))
|
||||
id category function detail depth start-time (child-time 0.0))
|
||||
|
||||
(defvar etaf-performance--record-ring nil)
|
||||
(defvar etaf-performance--next-operation-id 0)
|
||||
(defvar etaf-performance--next-stage-id 0)
|
||||
(defvar etaf-performance--current-operation nil)
|
||||
(defvar etaf-performance--stage-stack nil)
|
||||
(defvar etaf-performance--installed-advices nil)
|
||||
(defvar etaf-performance-mode nil)
|
||||
|
||||
(defconst etaf-performance--operation-functions
|
||||
'((etaf-dispatch-event event)
|
||||
(etaf-dispatch action)
|
||||
(etaf-runtime-mount mount)
|
||||
(etaf-runtime-flush flush)
|
||||
(etaf-runtime-unmount unmount)
|
||||
(etaf-data-load data-load)
|
||||
(etaf-data-source-load-page data-prepare)
|
||||
(etaf-data-mutate data-mutate)
|
||||
(etaf-resource-load resource-load)
|
||||
(etaf-compile-app app-compile)
|
||||
(ebox-surface-update-buffer-viewport viewport)
|
||||
(ebox-rerender-buffer-with-context rerender)
|
||||
(etaf-focus focus)
|
||||
(etaf-focus-next focus)
|
||||
(etaf-focus-previous focus)
|
||||
(etaf-activate activate)
|
||||
(etaf-activate-mouse activate))
|
||||
"Coarse functions that begin visible operation records.")
|
||||
|
||||
(defvar etaf-performance--stage-functions
|
||||
'((etaf--runtime-component-overlay runtime owner-overlay)
|
||||
(etaf--runtime-render-root-turn runtime root-turn)
|
||||
(etaf--runtime-build-generation runtime generation)
|
||||
(etaf--runtime-render-dirty-component runtime component-effect)
|
||||
(etaf--runtime-render-dirty-host-properties runtime host-property-effect)
|
||||
(etaf--runtime-render-dirty-range runtime range-effect)
|
||||
(etaf--runtime-render-dirty-inline-range runtime inline-range-effect)
|
||||
(etaf--runtime-render-dirty-slot-range runtime slot-range-effect)
|
||||
(etaf-compiler-instantiate compiler blueprint-instantiate)
|
||||
(etaf-compiler-write-app-artifact compiler app-artifact-write)
|
||||
(etaf-load-app-artifact compiler app-artifact-load)
|
||||
(etaf-sqlite--call sqlite call)
|
||||
(etaf-sqlite--transaction sqlite transaction)
|
||||
(etaf-sqlite--select-items sqlite query)
|
||||
(etaf-sqlite--mutate sqlite mutate)
|
||||
(ebox-incremental-consume-candidate ebox candidate)
|
||||
(ebox-incremental--prepare-logical-candidate ebox candidate-preparation)
|
||||
(ebox-incremental--candidate-logical-root ebox candidate-root)
|
||||
(ebox-incremental--candidate-local-index-delta ebox index-delta)
|
||||
(ebox-incremental--candidate-copy-index-table ebox index-table-copy)
|
||||
(ebox-incremental--candidate-dirty-set-from-touched ebox dirty-diff)
|
||||
(ebox-incremental--candidate-map-native-postorder ebox native-postorder)
|
||||
(ebox-incremental--candidate-range-ref-overlay ebox range-index)
|
||||
(ebox-incremental--candidate-structural-caches ebox structural-cache)
|
||||
(ebox-incremental--prepare-declarative-runtime ebox runtime-preparation)
|
||||
(ebox-incremental--candidate-layout-snapshots ebox snapshot-seed)
|
||||
(ebox-incremental--candidate-state ebox candidate-state)
|
||||
(ebox-incremental--surface-commit-input ebox owner-proof)
|
||||
(ebox-incremental--mixed-owner-proof ebox mixed-owner-proof)
|
||||
(ebox-incremental--formatting-context-reflow-proof ebox context-proof)
|
||||
(ebox-incremental--common-runtime-ancestor-id ebox common-ancestor)
|
||||
(ebox-incremental--formatting-context-reflow-fast-eligible-p
|
||||
ebox context-eligibility)
|
||||
(ebox-incremental--cached-layout-snapshot-details ebox snapshot-details)
|
||||
(ebox-incremental--layout-owner-plan ebox owner-plan)
|
||||
(ebox-incremental--span-patch-projection-proof ebox span-proof)
|
||||
(ebox-incremental--allocation-closure-proof ebox allocation-proof)
|
||||
(ebox-incremental--two-owner-allocation-proof ebox allocation-union-proof)
|
||||
(ebox-surface--cascade-local-owner-proof-p ebox cascade-proof)
|
||||
(ebox-incremental--layout-owner-report ebox owner-report)
|
||||
(ebox-incremental--surface-state-overrides ebox state-overrides)
|
||||
(ebox-surface-update-buffer-scoped ebox scoped-publication)
|
||||
(ebox-surface--project ebox projection)
|
||||
(ebox-surface--projection-start ebox projection-start)
|
||||
(ebox-surface--style-state-table ebox style-state-copy)
|
||||
(ebox-tree-subject-index ebox selector-subject-index)
|
||||
(ebox-surface--project-native-stable-node-table ebox native-object-reuse)
|
||||
(ebox-surface--mixed-owner-output ebox mixed-owner-output)
|
||||
(ebox-surface--rendered-fragments ebox fragments)
|
||||
(ebox-surface--render-candidate ebox candidate-render)
|
||||
(ebox-surface--surface-plan ebox surface-plan)
|
||||
(ebox-surface--native-patch-result ebox native-patch-result)
|
||||
(ebox-native-commit-render ebox native-commit)
|
||||
(ebox-native-commit-context-axes-stable-p ebox native-axes-proof)
|
||||
(ebox-native-commit--apply-fragment-style-delta
|
||||
ebox fragment-style-delta)
|
||||
(ebox-native-reflow--compile-layout-package compiler layout-ir)
|
||||
(ebox-native-reflow--compile-retained-layout-package
|
||||
compiler retained-layout-ir)
|
||||
(ebox-native-reflow--materialize-layout-tape ebox tape-decode)
|
||||
(ebox-surface--native-owned-ranges ebox native-ownership)
|
||||
(ebox-surface--owned-ranges ebox ownership-ranges)
|
||||
(ebox-commit ebox commit)
|
||||
(ebox-render-to-buffer ebox render-to-buffer)
|
||||
(tp-surface-update-scoped tp scoped-update)
|
||||
(tp-object-reuse-subtree tp object-subtree-reuse)
|
||||
(tp--prepare-surface tp prepare)
|
||||
(tp-commit-batch-result-create tp batch-result)
|
||||
(tp--prepare-commit-batch tp prepare-batch)
|
||||
(tp--commit-batch-retained-mount-state tp mount-proof)
|
||||
(tp--retain-candidate-mount-state tp retain-mounts)
|
||||
(tp--validate-retained-batch-precommit tp retained-precommit)
|
||||
(tp--publish-one-surface tp publication))
|
||||
"Cross-package coarse stages installed only while recording is enabled.")
|
||||
|
||||
(defun etaf-performance-records ()
|
||||
"Return a newest-first copy of completed performance records."
|
||||
(if etaf-performance--record-ring
|
||||
(ring-elements etaf-performance--record-ring)
|
||||
nil))
|
||||
|
||||
(defun etaf-performance--percentile (samples percentile)
|
||||
"Return nearest-rank PERCENTILE from numeric SAMPLES."
|
||||
(when samples
|
||||
(let* ((ordered (sort (copy-sequence samples) #'<))
|
||||
(rank (max 1 (ceiling (* percentile (length ordered))))))
|
||||
(nth (1- rank) ordered))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-operation-stage-summary (operation)
|
||||
"Return stage-category timing summaries for OPERATION.
|
||||
|
||||
Each result plist contains `:category', `:count', `:inclusive-ms', and
|
||||
`:exclusive-ms'. Results are sorted by decreasing exclusive time. Inclusive
|
||||
totals may overlap because they preserve nested span semantics; exclusive
|
||||
totals partition the recorded work."
|
||||
(unless (etaf-performance-operation-p operation)
|
||||
(signal 'wrong-type-argument
|
||||
(list 'etaf-performance-operation-p operation)))
|
||||
(let ((table (make-hash-table :test #'eq)) result)
|
||||
(dolist (stage (etaf-performance-operation-stages operation))
|
||||
(let* ((category (etaf-performance-stage-category stage))
|
||||
(value (or (gethash category table) (vector 0 0.0 0.0))))
|
||||
(aset value 0 (1+ (aref value 0)))
|
||||
(aset value 1 (+ (aref value 1)
|
||||
(etaf-performance-stage-inclusive stage)))
|
||||
(aset value 2 (+ (aref value 2)
|
||||
(etaf-performance-stage-exclusive stage)))
|
||||
(puthash category value table)))
|
||||
(maphash
|
||||
(lambda (category value)
|
||||
(push (list :category category :count (aref value 0)
|
||||
:inclusive-ms (aref value 1)
|
||||
:exclusive-ms (aref value 2))
|
||||
result))
|
||||
table)
|
||||
(sort result
|
||||
(lambda (left right)
|
||||
(> (plist-get left :exclusive-ms)
|
||||
(plist-get right :exclusive-ms))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-summary (&optional records)
|
||||
"Summarize completed RECORDS by operation kind and label.
|
||||
|
||||
RECORDS defaults to `etaf-performance-records'. Each result plist contains
|
||||
`:kind', `:label', `:count', `:min-ms', `:p50-ms', `:p95-ms', `:max-ms', and
|
||||
`:mean-ms'. Summary calculation happens on demand, never in the measured hot
|
||||
path."
|
||||
(let ((groups (make-hash-table :test #'equal)) result)
|
||||
(dolist (operation (or records (etaf-performance-records)))
|
||||
(let ((key (cons (etaf-performance-operation-kind operation)
|
||||
(etaf-performance-operation-label operation))))
|
||||
(puthash key
|
||||
(cons (etaf-performance-operation-elapsed operation)
|
||||
(gethash key groups))
|
||||
groups)))
|
||||
(maphash
|
||||
(lambda (key samples)
|
||||
(push
|
||||
(list :kind (car key) :label (cdr key) :count (length samples)
|
||||
:min-ms (apply #'min samples)
|
||||
:p50-ms (etaf-performance--percentile samples 0.50)
|
||||
:p95-ms (etaf-performance--percentile samples 0.95)
|
||||
:max-ms (apply #'max samples)
|
||||
:mean-ms (/ (apply #'+ samples) (float (length samples))))
|
||||
result))
|
||||
groups)
|
||||
(sort result
|
||||
(lambda (left right)
|
||||
(> (plist-get left :p95-ms) (plist-get right :p95-ms))))))
|
||||
|
||||
(defun etaf-performance--stage-report-data (stage)
|
||||
"Return portable report data for performance STAGE."
|
||||
(list :id (etaf-performance-stage-id stage)
|
||||
:category (etaf-performance-stage-category stage)
|
||||
:function (etaf-performance-stage-function stage)
|
||||
:detail (etaf-performance-stage-detail stage)
|
||||
:depth (etaf-performance-stage-depth stage)
|
||||
:inclusive-ms (etaf-performance-stage-inclusive stage)
|
||||
:exclusive-ms (etaf-performance-stage-exclusive stage)
|
||||
:status (etaf-performance-stage-status stage)))
|
||||
|
||||
(defun etaf-performance--operation-report-data (operation)
|
||||
"Return portable report data for performance OPERATION."
|
||||
(list
|
||||
:id (etaf-performance-operation-id operation)
|
||||
:parent-id (etaf-performance-operation-parent-id operation)
|
||||
:kind (etaf-performance-operation-kind operation)
|
||||
:label (etaf-performance-operation-label operation)
|
||||
:runtime-id (etaf-performance-operation-runtime-id operation)
|
||||
:buffer-name (etaf-performance-operation-buffer-name operation)
|
||||
:generation-before
|
||||
(etaf-performance-operation-generation-before operation)
|
||||
:generation-after
|
||||
(etaf-performance-operation-generation-after operation)
|
||||
:started-at
|
||||
(format-time-string "%Y-%m-%dT%H:%M:%S%z"
|
||||
(seconds-to-time
|
||||
(etaf-performance-operation-start-time operation)))
|
||||
:elapsed-ms (etaf-performance-operation-elapsed operation)
|
||||
:status (etaf-performance-operation-status operation)
|
||||
:gc-count-delta
|
||||
(- (etaf-performance-operation-gc-count-after operation)
|
||||
(etaf-performance-operation-gc-count-before operation))
|
||||
:gc-elapsed-ms
|
||||
(* 1000.0
|
||||
(- (etaf-performance-operation-gc-elapsed-after operation)
|
||||
(etaf-performance-operation-gc-elapsed-before operation)))
|
||||
:metadata (copy-tree (etaf-performance-operation-metadata operation))
|
||||
:stage-summary (etaf-performance-operation-stage-summary operation)
|
||||
:stages
|
||||
(mapcar #'etaf-performance--stage-report-data
|
||||
(etaf-performance-operation-stages operation))))
|
||||
|
||||
(defun etaf-performance--parse-darwin-power-state
|
||||
(battery-output custom-output)
|
||||
"Return normalized macOS power state from PMSET outputs.
|
||||
BATTERY-OUTPUT identifies the active source; CUSTOM-OUTPUT contains settings."
|
||||
(let* ((source
|
||||
(cond
|
||||
((string-match-p "Battery Power" (or battery-output "")) 'battery)
|
||||
((string-match-p "AC Power" (or battery-output "")) 'ac)
|
||||
(t 'unknown)))
|
||||
(target-heading
|
||||
(pcase source ('battery "Battery Power") ('ac "AC Power") (_ nil)))
|
||||
active low-power)
|
||||
(dolist (line (split-string (or custom-output "") "\n" t))
|
||||
(cond
|
||||
((string-match "^\\(.+ Power\\):[[:space:]]*$" line)
|
||||
(setq active (and target-heading
|
||||
(string= (match-string 1 line) target-heading))))
|
||||
((and active
|
||||
(string-match
|
||||
"^[[:space:]]*lowpowermode[[:space:]]+\\([01]\\)" line))
|
||||
(setq low-power (if (string= (match-string 1 line) "1")
|
||||
'on 'off)))))
|
||||
(list :source source :low-power-mode (or low-power 'unknown))))
|
||||
|
||||
(defun etaf-performance--command-output (program &rest arguments)
|
||||
"Return PROGRAM output for ARGUMENTS, or nil on failure."
|
||||
(when program
|
||||
(with-temp-buffer
|
||||
(let ((default-directory temporary-file-directory))
|
||||
(when (eq 0 (apply #'call-process program nil t nil arguments))
|
||||
(buffer-string))))))
|
||||
|
||||
(defun etaf-performance--power-state ()
|
||||
"Return a portable local power-state snapshot."
|
||||
(if (not (eq system-type 'darwin))
|
||||
(list :source 'unknown :low-power-mode 'unknown)
|
||||
(let ((pmset (executable-find "pmset")))
|
||||
(if (not pmset)
|
||||
(list :source 'unknown :low-power-mode 'unknown)
|
||||
(etaf-performance--parse-darwin-power-state
|
||||
(etaf-performance--command-output pmset "-g" "batt")
|
||||
(etaf-performance--command-output pmset "-g" "custom"))))))
|
||||
|
||||
(defun etaf-performance-environment-data ()
|
||||
"Return the environment snapshot used to interpret latency records."
|
||||
(list :emacs-version emacs-version
|
||||
:system-type system-type
|
||||
:window-system window-system
|
||||
:graphic-display (display-graphic-p)
|
||||
:frame-pixel-size
|
||||
(list (frame-pixel-width) (frame-pixel-height))
|
||||
:window-body-pixel-size
|
||||
(list (window-body-width nil t) (window-body-height nil t))
|
||||
:gc-cons-threshold gc-cons-threshold
|
||||
:gc-cons-percentage gc-cons-percentage
|
||||
:load-average (load-average t)
|
||||
:power-state (etaf-performance--power-state)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-report-data (&optional records)
|
||||
"Return a portable report for completed performance RECORDS.
|
||||
|
||||
RECORDS defaults to `etaf-performance-records'. Operations are returned in
|
||||
capture order, oldest first. The report contains only plain Lisp data so it
|
||||
can be copied, saved, and read in another Emacs process."
|
||||
(let ((records (or records (etaf-performance-records))))
|
||||
(list
|
||||
:format-version etaf-performance-report-format-version
|
||||
:generated-at (format-time-string "%Y-%m-%dT%H:%M:%S%z")
|
||||
:environment (etaf-performance-environment-data)
|
||||
:summary (etaf-performance-summary records)
|
||||
:operations
|
||||
(mapcar #'etaf-performance--operation-report-data
|
||||
(reverse (copy-sequence records))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-report-string (&optional records)
|
||||
"Return completed performance RECORDS as a readable report string."
|
||||
(concat ";; ETAF performance report\n"
|
||||
(pp-to-string (etaf-performance-report-data records))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-copy-report ()
|
||||
"Copy all retained performance records to the kill ring."
|
||||
(interactive)
|
||||
(let* ((record-count (length (etaf-performance-records)))
|
||||
(report (etaf-performance-report-string)))
|
||||
(kill-new report)
|
||||
(message "Copied %d ETAF performance operation%s"
|
||||
record-count (if (= 1 record-count) "" "s"))
|
||||
report))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-export (file)
|
||||
"Export all retained performance records to FILE.
|
||||
|
||||
When called interactively, suggest a timestamped `.eld' file in
|
||||
`default-directory'. Refuse to overwrite an existing file."
|
||||
(interactive
|
||||
(list
|
||||
(read-file-name
|
||||
"Export ETAF performance report: " nil
|
||||
(expand-file-name
|
||||
(format "etaf-performance-%s.eld"
|
||||
(format-time-string "%Y%m%d-%H%M%S"))
|
||||
default-directory))))
|
||||
(let* ((record-count (length (etaf-performance-records)))
|
||||
(report (etaf-performance-report-string)))
|
||||
(write-region report nil file nil 'silent nil 'excl)
|
||||
(message "Exported %d ETAF performance operations to %s"
|
||||
record-count (abbreviate-file-name file))
|
||||
file))
|
||||
|
||||
(defun etaf-performance-clear ()
|
||||
"Clear all completed performance records."
|
||||
(interactive)
|
||||
;; Keep correlation IDs monotonic even if an active operation clears history.
|
||||
(setq etaf-performance--record-ring nil)
|
||||
(when-let ((panel (get-buffer "*ETAF Performance*")))
|
||||
(with-current-buffer panel
|
||||
(when (derived-mode-p 'etaf-performance-panel-mode)
|
||||
(tabulated-list-revert))))
|
||||
nil)
|
||||
|
||||
(defun etaf-performance--now ()
|
||||
"Return a wall-clock timestamp as floating-point seconds."
|
||||
(float-time))
|
||||
|
||||
(defun etaf-performance--runtime-p (value)
|
||||
"Return non-nil when VALUE is an ETAF Runtime."
|
||||
(and (fboundp 'etaf-runtime-p) (etaf-runtime-p value)))
|
||||
|
||||
(defun etaf-performance--runtime-for-buffer (buffer)
|
||||
"Return the Runtime mounted in BUFFER, without signaling."
|
||||
(and buffer (fboundp 'etaf-runtime-for-buffer)
|
||||
(ignore-errors (etaf-runtime-for-buffer buffer))))
|
||||
|
||||
(defun etaf-performance--runtime-from-call (function arguments result after)
|
||||
"Resolve Runtime for FUNCTION call using ARGUMENTS, RESULT, and AFTER."
|
||||
(let ((first (car arguments)))
|
||||
(cond
|
||||
((eq function 'etaf-runtime-mount)
|
||||
(when after (etaf-performance--runtime-for-buffer result)))
|
||||
((etaf-performance--runtime-p first) first)
|
||||
((memq function '(etaf-runtime-flush etaf-runtime-unmount
|
||||
etaf-focus etaf-focus-next etaf-focus-previous
|
||||
etaf-activate))
|
||||
(or (and first (etaf-performance--runtime-for-buffer first))
|
||||
(and (boundp 'etaf--current-runtime) etaf--current-runtime)
|
||||
(etaf-performance--runtime-for-buffer (current-buffer))))
|
||||
((eq function 'etaf-activate-mouse)
|
||||
(and (boundp 'etaf--current-runtime) etaf--current-runtime))
|
||||
((eq function 'etaf-dispatch)
|
||||
(if (etaf-performance--runtime-p first)
|
||||
first
|
||||
(and (boundp 'etaf--current-runtime) etaf--current-runtime)))
|
||||
((eq function 'etaf-compile-app) nil)
|
||||
((memq function '(ebox-surface-update-buffer-viewport
|
||||
ebox-rerender-buffer-with-context))
|
||||
(etaf-performance--runtime-for-buffer first))
|
||||
(t
|
||||
(and (boundp 'etaf--current-runtime) etaf--current-runtime)))))
|
||||
|
||||
(defun etaf-performance--buffer (runtime function arguments result after)
|
||||
"Resolve operation buffer from RUNTIME and call metadata.
|
||||
FUNCTION received ARGUMENTS and produced RESULT when AFTER is non-nil."
|
||||
(cond
|
||||
((and runtime (fboundp 'etaf-runtime-buffer))
|
||||
(ignore-errors (etaf-runtime-buffer runtime)))
|
||||
((eq function 'etaf-runtime-mount)
|
||||
(let ((value (if after result (car arguments))))
|
||||
(cond ((bufferp value) value)
|
||||
((stringp value) (get-buffer value)))))
|
||||
((memq function '(ebox-surface-update-buffer-viewport
|
||||
ebox-rerender-buffer-with-context))
|
||||
(get-buffer (car arguments)))
|
||||
(t nil)))
|
||||
|
||||
(defun etaf-performance--generation (runtime)
|
||||
"Return RUNTIME's committed generation, or nil."
|
||||
(and runtime (fboundp 'etaf-runtime-generation)
|
||||
(ignore-errors (etaf-runtime-generation runtime))))
|
||||
|
||||
(defun etaf-performance--runtime-id (runtime)
|
||||
"Return RUNTIME's stable scalar mount identity, or nil."
|
||||
(and runtime (fboundp 'etaf-runtime-mount-epoch)
|
||||
(ignore-errors (etaf-runtime-mount-epoch runtime))))
|
||||
|
||||
(defun etaf-performance--buffer-name (buffer)
|
||||
"Return BUFFER's name snapshot, or nil."
|
||||
(cond ((bufferp buffer) (buffer-name buffer))
|
||||
((stringp buffer) buffer)
|
||||
(t nil)))
|
||||
|
||||
(defun etaf-performance--label (function arguments)
|
||||
"Return a concise label for FUNCTION called with ARGUMENTS."
|
||||
(pcase function
|
||||
('etaf-dispatch-event
|
||||
(format "%s %S" (nth 2 arguments) (nth 1 arguments)))
|
||||
('etaf-dispatch
|
||||
(format "%S" (if (etaf-performance--runtime-p (car arguments))
|
||||
(nth 1 arguments)
|
||||
(car arguments))))
|
||||
('etaf-runtime-mount (format "%s" (car arguments)))
|
||||
('etaf-runtime-flush "manual flush")
|
||||
('etaf-runtime-unmount "unmount")
|
||||
('etaf-data-load "data load")
|
||||
('etaf-data-source-load-page
|
||||
(format "data prepare page %s/%s"
|
||||
(or (nth 2 arguments) 1) (or (nth 3 arguments) 20)))
|
||||
('etaf-data-mutate (format "data %S" (nth 1 arguments)))
|
||||
('etaf-resource-load "resource load/reload")
|
||||
('etaf-compile-app (format "%s" (or (car arguments) "default App")))
|
||||
('ebox-surface-update-buffer-viewport
|
||||
(format "viewport %sx%s" (nth 1 arguments) (or (nth 2 arguments) "-")))
|
||||
('ebox-rerender-buffer-with-context
|
||||
(format "rerender %sx%s" (nth 1 arguments) (or (nth 2 arguments) "-")))
|
||||
('etaf-focus (format "focus %S" (nth 1 arguments)))
|
||||
('etaf-focus-next "next")
|
||||
('etaf-focus-previous "previous")
|
||||
('etaf-activate-mouse "mouse")
|
||||
('etaf-activate "keyboard")
|
||||
(_ (symbol-name function))))
|
||||
|
||||
(defun etaf-performance--retain (operation)
|
||||
"Retain completed OPERATION under the configured bound."
|
||||
(let ((limit (max 0 etaf-performance-max-records)))
|
||||
(if (zerop limit)
|
||||
(setq etaf-performance--record-ring nil)
|
||||
(unless (and etaf-performance--record-ring
|
||||
(= (ring-size etaf-performance--record-ring) limit))
|
||||
(let ((existing (etaf-performance-records)))
|
||||
(setq etaf-performance--record-ring (make-ring limit))
|
||||
(dolist (record (reverse (seq-take existing limit)))
|
||||
(ring-insert etaf-performance--record-ring record))))
|
||||
(ring-insert etaf-performance--record-ring operation))))
|
||||
|
||||
(defun etaf-performance--call-operation
|
||||
(original function kind arguments &optional label runtime buffer)
|
||||
"Call ORIGINAL as operation FUNCTION of KIND with ARGUMENTS.
|
||||
Optional LABEL, RUNTIME, and BUFFER override inferred metadata."
|
||||
(if (not etaf-performance-mode)
|
||||
(apply original arguments)
|
||||
(let* ((runtime-before
|
||||
(or runtime
|
||||
(etaf-performance--runtime-from-call
|
||||
function arguments nil nil)))
|
||||
(buffer-before
|
||||
(or buffer
|
||||
(etaf-performance--buffer
|
||||
runtime-before function arguments nil nil)))
|
||||
(start (etaf-performance--now))
|
||||
(gc-count-before gcs-done)
|
||||
(gc-elapsed-before gc-elapsed)
|
||||
(operation
|
||||
(etaf-performance--operation-create
|
||||
:id (cl-incf etaf-performance--next-operation-id)
|
||||
:parent-id (and etaf-performance--current-operation
|
||||
(etaf-performance-operation-id
|
||||
etaf-performance--current-operation))
|
||||
:kind kind :label (or label
|
||||
(etaf-performance--label
|
||||
function arguments))
|
||||
:runtime-id (etaf-performance--runtime-id runtime-before)
|
||||
:buffer-name (etaf-performance--buffer-name buffer-before)
|
||||
:generation-before
|
||||
(etaf-performance--generation runtime-before)
|
||||
:start-time start :gc-count-before gc-count-before
|
||||
:gc-elapsed-before gc-elapsed-before))
|
||||
(etaf-performance--current-operation operation)
|
||||
(etaf-performance--stage-stack nil)
|
||||
(completed nil)
|
||||
(quit-p nil)
|
||||
result)
|
||||
(unwind-protect
|
||||
(condition-case condition
|
||||
(prog1 (setq result (apply original arguments))
|
||||
(setq completed t))
|
||||
(quit
|
||||
(setq quit-p t)
|
||||
(signal (car condition) (cdr condition))))
|
||||
(let* ((end (etaf-performance--now))
|
||||
(runtime-after
|
||||
(or (etaf-performance--runtime-from-call
|
||||
function arguments result t)
|
||||
runtime-before))
|
||||
(buffer-after
|
||||
(or (etaf-performance--buffer
|
||||
runtime-after function arguments result t)
|
||||
buffer-before)))
|
||||
(setf (etaf-performance-operation-runtime-id operation)
|
||||
(etaf-performance--runtime-id runtime-after)
|
||||
(etaf-performance-operation-buffer-name operation)
|
||||
(etaf-performance--buffer-name buffer-after)
|
||||
(etaf-performance-operation-generation-after operation)
|
||||
(etaf-performance--generation runtime-after)
|
||||
(etaf-performance-operation-end-time operation) end
|
||||
(etaf-performance-operation-elapsed operation)
|
||||
(* 1000.0 (- end start))
|
||||
(etaf-performance-operation-status operation)
|
||||
(cond (completed 'success) (quit-p 'quit) (t 'error))
|
||||
(etaf-performance-operation-gc-count-after operation) gcs-done
|
||||
(etaf-performance-operation-gc-elapsed-after operation)
|
||||
gc-elapsed
|
||||
(etaf-performance-operation-stages operation)
|
||||
(sort (etaf-performance-operation-stages operation)
|
||||
(lambda (left right)
|
||||
(< (etaf-performance-stage-id left)
|
||||
(etaf-performance-stage-id right)))))
|
||||
(etaf-performance--retain operation)))
|
||||
result)))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-call-operation
|
||||
(kind label function &optional runtime buffer)
|
||||
"Call FUNCTION as a recorded operation and return its exact result.
|
||||
KIND and LABEL identify the operation. Optional RUNTIME and BUFFER attach
|
||||
framework metadata without constraining FUNCTION's implementation. FUNCTION
|
||||
should close over any arguments it needs. Errors and quits are re-signaled."
|
||||
(unless (functionp function)
|
||||
(signal 'wrong-type-argument (list 'functionp function)))
|
||||
(etaf-performance--call-operation
|
||||
function 'etaf-performance-call-operation kind nil label runtime buffer))
|
||||
|
||||
(cl-defmacro etaf-performance-with-operation
|
||||
((kind label &optional runtime buffer) &rest body)
|
||||
"Evaluate BODY as a recorded operation and return its exact result.
|
||||
KIND, LABEL, optional RUNTIME, and optional BUFFER are evaluated once."
|
||||
(declare (indent 1) (debug ((form form &optional form form) body)))
|
||||
`(etaf-performance-call-operation
|
||||
,kind ,label (lambda () ,@body) ,runtime ,buffer))
|
||||
|
||||
(defun etaf-performance--make-operation-advice (function kind)
|
||||
"Return an around advice closure for operation FUNCTION and KIND."
|
||||
(lambda (original &rest arguments)
|
||||
(etaf-performance--call-operation original function kind arguments)))
|
||||
|
||||
(defun etaf-performance--call-stage
|
||||
(original function category detail arguments)
|
||||
"Call ORIGINAL as stage FUNCTION in CATEGORY with DETAIL and ARGUMENTS."
|
||||
(if (not etaf-performance--current-operation)
|
||||
(apply original arguments)
|
||||
(let* ((start (etaf-performance--now))
|
||||
(frame
|
||||
(etaf-performance--stage-frame-create
|
||||
:id (cl-incf etaf-performance--next-stage-id)
|
||||
:category category :function function :detail detail
|
||||
:depth (length etaf-performance--stage-stack)
|
||||
:start-time start))
|
||||
(parent (car etaf-performance--stage-stack))
|
||||
(etaf-performance--stage-stack
|
||||
(cons frame etaf-performance--stage-stack))
|
||||
(completed nil)
|
||||
(quit-p nil)
|
||||
result)
|
||||
(unwind-protect
|
||||
(condition-case condition
|
||||
(prog1 (setq result (apply original arguments))
|
||||
(setq completed t))
|
||||
(quit
|
||||
(setq quit-p t)
|
||||
(signal (car condition) (cdr condition))))
|
||||
(let* ((end (etaf-performance--now))
|
||||
(inclusive (* 1000.0 (- end start)))
|
||||
(exclusive
|
||||
(max 0.0 (- inclusive
|
||||
(etaf-performance--stage-frame-child-time frame)))))
|
||||
(when parent
|
||||
(cl-incf (etaf-performance--stage-frame-child-time parent)
|
||||
inclusive))
|
||||
(when completed
|
||||
(etaf-performance--capture-stage-result
|
||||
etaf-performance--current-operation function result))
|
||||
(push
|
||||
(etaf-performance--stage-create
|
||||
:id (etaf-performance--stage-frame-id frame)
|
||||
:category category :function function :detail detail
|
||||
:depth (etaf-performance--stage-frame-depth frame)
|
||||
:start-time start :end-time end :inclusive inclusive
|
||||
:exclusive exclusive
|
||||
:status (cond (completed 'success) (quit-p 'quit) (t 'error)))
|
||||
(etaf-performance-operation-stages
|
||||
etaf-performance--current-operation))))
|
||||
result)))
|
||||
|
||||
(defun etaf-performance--compact-ebox-report (report)
|
||||
"Return stable scalar diagnostics from public Ebox REPORT."
|
||||
(when (listp report)
|
||||
(list :strategy (plist-get report :strategy)
|
||||
:projection-kind (plist-get report :projection-kind)
|
||||
:dirty-count (plist-get report :dirty-count)
|
||||
:owner-count (length (plist-get report :owner-ids))
|
||||
:patch-count (plist-get report :patch-count)
|
||||
:tp-scope-count (plist-get report :tp-scope-count)
|
||||
:tp-text-operations (plist-get report :tp-text-operations)
|
||||
:tp-property-operations (plist-get report :tp-property-operations)
|
||||
:tp-full-root (and (plist-get report :tp-full-root) t)
|
||||
:tp-scope-fallback (and (plist-get report :tp-scope-fallback) t)
|
||||
:native-frame-kind (plist-get report :native-frame-kind)
|
||||
:timing (copy-tree (plist-get report :timing)))))
|
||||
|
||||
(defun etaf-performance--capture-stage-result (operation function result)
|
||||
"Attach public FUNCTION RESULT diagnostics to OPERATION."
|
||||
(when (eq function 'ebox-commit)
|
||||
(setf (etaf-performance-operation-metadata operation)
|
||||
(plist-put (etaf-performance-operation-metadata operation)
|
||||
:ebox
|
||||
(etaf-performance--compact-ebox-report result)))))
|
||||
|
||||
(defun etaf-performance--make-stage-advice (function category detail)
|
||||
"Return an around advice closure for stage FUNCTION CATEGORY and DETAIL."
|
||||
(lambda (original &rest arguments)
|
||||
(etaf-performance--call-stage
|
||||
original function category detail arguments)))
|
||||
|
||||
(defun etaf-performance--install-one (function advice)
|
||||
"Install ADVICE around FUNCTION once and remember it."
|
||||
(let ((installed
|
||||
(cl-find function etaf-performance--installed-advices :key #'car)))
|
||||
(cond
|
||||
((and installed (advice-member-p (cdr installed) function)) nil)
|
||||
(installed
|
||||
;; Reloading a package replaces its advised symbol-function. Reattach
|
||||
;; the exact tracked closure so disable/unregister can still remove it.
|
||||
(advice-add function :around (cdr installed)))
|
||||
(t
|
||||
(advice-add function :around advice)
|
||||
(push (cons function advice) etaf-performance--installed-advices)))))
|
||||
|
||||
(defun etaf-performance--uninstall-function (function)
|
||||
"Remove recorder advice installed on FUNCTION."
|
||||
(when-let ((entry (assq function etaf-performance--installed-advices)))
|
||||
(advice-remove function (cdr entry))
|
||||
(setq etaf-performance--installed-advices
|
||||
(delq entry etaf-performance--installed-advices))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-register-stage (function category &optional detail)
|
||||
"Register FUNCTION as a timed stage in CATEGORY.
|
||||
DETAIL defaults to FUNCTION. Registration is safe before or after the
|
||||
package defining FUNCTION is loaded. Return FUNCTION."
|
||||
(unless (symbolp function)
|
||||
(signal 'wrong-type-argument (list 'symbolp function)))
|
||||
(unless (symbolp category)
|
||||
(signal 'wrong-type-argument (list 'symbolp category)))
|
||||
(when (assq function etaf-performance--operation-functions)
|
||||
(error "ETAF performance operation boundary cannot be a stage: %S"
|
||||
function))
|
||||
(let ((detail (or detail function)))
|
||||
(unless (symbolp detail)
|
||||
(signal 'wrong-type-argument (list 'symbolp detail)))
|
||||
(setq etaf-performance--stage-functions
|
||||
(cons (list function category detail)
|
||||
(assq-delete-all function
|
||||
etaf-performance--stage-functions)))
|
||||
(etaf-performance--uninstall-function function)
|
||||
(when (and etaf-performance-mode (fboundp function))
|
||||
(etaf-performance--install-one
|
||||
function
|
||||
(etaf-performance--make-stage-advice function category detail))))
|
||||
function)
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-unregister-stage (function)
|
||||
"Unregister timed stage FUNCTION and remove its installed advice."
|
||||
(when (assq function etaf-performance--operation-functions)
|
||||
(error "ETAF performance operation boundary is not a registered stage: %S"
|
||||
function))
|
||||
(setq etaf-performance--stage-functions
|
||||
(assq-delete-all function etaf-performance--stage-functions))
|
||||
(etaf-performance--uninstall-function function)
|
||||
function)
|
||||
|
||||
(defun etaf-performance--install-loaded-advices (&optional _file)
|
||||
"Install configured advices whose functions are currently loaded."
|
||||
(when etaf-performance-mode
|
||||
(dolist (entry etaf-performance--operation-functions)
|
||||
(when (fboundp (car entry))
|
||||
(etaf-performance--install-one
|
||||
(car entry)
|
||||
(etaf-performance--make-operation-advice
|
||||
(car entry) (nth 1 entry)))))
|
||||
(dolist (entry etaf-performance--stage-functions)
|
||||
(when (fboundp (car entry))
|
||||
(etaf-performance--install-one
|
||||
(car entry)
|
||||
(etaf-performance--make-stage-advice
|
||||
(car entry) (nth 1 entry) (nth 2 entry)))))))
|
||||
|
||||
(defun etaf-performance--uninstall-advices ()
|
||||
"Remove every operation and stage advice installed by this recorder."
|
||||
(dolist (entry etaf-performance--installed-advices)
|
||||
(advice-remove (car entry) (cdr entry)))
|
||||
(setq etaf-performance--installed-advices nil))
|
||||
|
||||
;;;###autoload
|
||||
(define-minor-mode etaf-performance-mode
|
||||
"Globally record ETAF operations and cross-package performance stages."
|
||||
:global t
|
||||
:init-value nil
|
||||
:lighter " ETAF-Perf"
|
||||
(if etaf-performance-mode
|
||||
(progn
|
||||
(add-hook 'after-load-functions
|
||||
#'etaf-performance--install-loaded-advices)
|
||||
(etaf-performance--install-loaded-advices))
|
||||
(remove-hook 'after-load-functions
|
||||
#'etaf-performance--install-loaded-advices)
|
||||
(etaf-performance--uninstall-advices)))
|
||||
|
||||
(defun etaf-performance--format-object (value)
|
||||
"Format VALUE compactly for the performance table."
|
||||
(cond ((bufferp value) (buffer-name value))
|
||||
((null value) "-")
|
||||
(t (format "%s" value))))
|
||||
|
||||
(defun etaf-performance--format-report (operation)
|
||||
"Return compact public backend metadata for OPERATION."
|
||||
(if-let ((report (plist-get (etaf-performance-operation-metadata operation)
|
||||
:ebox)))
|
||||
(format "%s/%s d:%s o:%s tp:%s/%s/%s%s"
|
||||
(or (plist-get report :strategy) "-")
|
||||
(or (plist-get report :projection-kind) "-")
|
||||
(or (plist-get report :dirty-count) 0)
|
||||
(or (plist-get report :owner-count) 0)
|
||||
(or (plist-get report :tp-scope-count) 0)
|
||||
(or (plist-get report :tp-text-operations) 0)
|
||||
(or (plist-get report :tp-property-operations) 0)
|
||||
(if (or (plist-get report :tp-full-root)
|
||||
(plist-get report :tp-scope-fallback))
|
||||
" fallback"
|
||||
""))
|
||||
"-"))
|
||||
|
||||
(defun etaf-performance--tabulated-entries ()
|
||||
"Return tabulated entries for retained operations and their stages."
|
||||
(let (entries)
|
||||
(dolist (operation (reverse (etaf-performance-records)))
|
||||
(let ((id (etaf-performance-operation-id operation)))
|
||||
(push
|
||||
(list (cons 'operation id)
|
||||
(vector
|
||||
(number-to-string id)
|
||||
(etaf-performance--format-object
|
||||
(etaf-performance-operation-parent-id operation))
|
||||
(symbol-name (etaf-performance-operation-kind operation))
|
||||
(or (etaf-performance-operation-label operation) "")
|
||||
"operation" "-" "0"
|
||||
(format "%.3f" (etaf-performance-operation-elapsed operation))
|
||||
"-" (symbol-name (etaf-performance-operation-status operation))
|
||||
(etaf-performance--format-object
|
||||
(etaf-performance-operation-buffer-name operation))
|
||||
(format "%s→%s"
|
||||
(etaf-performance--format-object
|
||||
(etaf-performance-operation-generation-before operation))
|
||||
(etaf-performance--format-object
|
||||
(etaf-performance-operation-generation-after operation)))
|
||||
(etaf-performance--format-report operation)
|
||||
(format "%d/%.3fms"
|
||||
(- (etaf-performance-operation-gc-count-after operation)
|
||||
(etaf-performance-operation-gc-count-before operation))
|
||||
(* 1000.0
|
||||
(- (etaf-performance-operation-gc-elapsed-after operation)
|
||||
(etaf-performance-operation-gc-elapsed-before operation))))))
|
||||
entries)
|
||||
(dolist (stage (etaf-performance-operation-stages operation))
|
||||
(push
|
||||
(list (cons id (etaf-performance-stage-id stage))
|
||||
(vector
|
||||
(format "%s.%s" id (etaf-performance-stage-id stage))
|
||||
(number-to-string id) "stage"
|
||||
(concat (make-string (* 2 (etaf-performance-stage-depth stage)) ?\s)
|
||||
(symbol-name (etaf-performance-stage-detail stage)))
|
||||
(symbol-name (etaf-performance-stage-category stage))
|
||||
(symbol-name (etaf-performance-stage-function stage))
|
||||
(number-to-string (etaf-performance-stage-depth stage))
|
||||
(format "%.3f" (etaf-performance-stage-inclusive stage))
|
||||
(format "%.3f" (etaf-performance-stage-exclusive stage))
|
||||
(symbol-name (etaf-performance-stage-status stage))
|
||||
"-" "-" "-" "-"))
|
||||
entries))))
|
||||
(nreverse entries)))
|
||||
|
||||
(defun etaf-performance--panel-environment-line (&optional environment)
|
||||
"Return one compact header for performance ENVIRONMENT."
|
||||
(let* ((environment (or environment
|
||||
(etaf-performance-environment-data)))
|
||||
(power (plist-get environment :power-state))
|
||||
(load (car (plist-get environment :load-average))))
|
||||
(format " ETAF Performance | Emacs %s | power %s/low:%s | load %.2f "
|
||||
(or (plist-get environment :emacs-version) "unknown")
|
||||
(or (plist-get power :source) 'unknown)
|
||||
(or (plist-get power :low-power-mode) 'unknown)
|
||||
(or load 0.0))))
|
||||
|
||||
(define-derived-mode etaf-performance-panel-mode tabulated-list-mode "ETAF-Performance"
|
||||
"Display ETAF operation and nested stage timing records.
|
||||
|
||||
Press `c' to copy a complete report or `w' to export it to a file."
|
||||
(setq tabulated-list-format
|
||||
[("ID" 9 t) ("Parent" 7 t) ("Type" 10 t) ("Label / Detail" 24 t)
|
||||
("Category" 12 t) ("Function" 34 t) ("Depth" 6 t)
|
||||
("Inclusive ms" 13 t) ("Exclusive ms" 13 t) ("Status" 8 t)
|
||||
("Buffer" 18 t) ("Generation" 12 t) ("Backend report" 40 t)
|
||||
("GC delta" 14 t)])
|
||||
(setq tabulated-list-padding 2
|
||||
tabulated-list-entries #'etaf-performance--tabulated-entries
|
||||
header-line-format (etaf-performance--panel-environment-line))
|
||||
(tabulated-list-init-header))
|
||||
|
||||
(define-key etaf-performance-panel-mode-map (kbd "c")
|
||||
#'etaf-performance-copy-report)
|
||||
(define-key etaf-performance-panel-mode-map (kbd "w")
|
||||
#'etaf-performance-export)
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-performance-show ()
|
||||
"Show retained ETAF operations and stages in a tabulated panel."
|
||||
(interactive)
|
||||
(let ((buffer (get-buffer-create "*ETAF Performance*")))
|
||||
(with-current-buffer buffer
|
||||
(etaf-performance-panel-mode)
|
||||
(tabulated-list-print t))
|
||||
(pop-to-buffer buffer)))
|
||||
|
||||
(provide 'etaf-performance)
|
||||
|
||||
;;; etaf-performance.el ends here
|
||||
@ -101,17 +101,34 @@ Runtime, watchers run synchronously.")
|
||||
|
||||
(defvar etaf--dispatch-depth 0)
|
||||
(defvar etaf--dispatch-source-queue nil)
|
||||
(defvar etaf--dispatch-source-queue-tail nil)
|
||||
(defvar etaf--dispatch-source-set (make-hash-table :test #'eq))
|
||||
(defvar etaf--dispatch-runtime-queue nil)
|
||||
(defvar etaf--dispatch-runtime-queue-tail nil)
|
||||
(defvar etaf--dispatch-runtime-set (make-hash-table :test #'eq))
|
||||
(defvar etaf--dispatch-effect-set (make-hash-table :test #'eq))
|
||||
|
||||
(defun etaf--dispatch-append-source (source)
|
||||
"Append SOURCE to the reactive FIFO in constant time."
|
||||
(let ((cell (list source)))
|
||||
(if etaf--dispatch-source-queue-tail
|
||||
(setcdr etaf--dispatch-source-queue-tail cell)
|
||||
(setq etaf--dispatch-source-queue cell))
|
||||
(setq etaf--dispatch-source-queue-tail cell)))
|
||||
|
||||
(defun etaf--dispatch-append-runtime (runtime)
|
||||
"Append RUNTIME to the reactive publication FIFO in constant time."
|
||||
(let ((cell (list runtime)))
|
||||
(if etaf--dispatch-runtime-queue-tail
|
||||
(setcdr etaf--dispatch-runtime-queue-tail cell)
|
||||
(setq etaf--dispatch-runtime-queue cell))
|
||||
(setq etaf--dispatch-runtime-queue-tail cell)))
|
||||
|
||||
(defun etaf-reactive-enqueue-runtime-flush (runtime function)
|
||||
"Queue FUNCTION once for RUNTIME after the outer reactive dispatch settles."
|
||||
(unless (gethash runtime etaf--dispatch-runtime-set)
|
||||
(puthash runtime function etaf--dispatch-runtime-set)
|
||||
(setq etaf--dispatch-runtime-queue
|
||||
(nconc etaf--dispatch-runtime-queue (list runtime)))))
|
||||
(etaf--dispatch-append-runtime runtime)))
|
||||
|
||||
(defun etaf--dispatch-source-now (source)
|
||||
"Notify SOURCE subscribers without opening another dispatch boundary."
|
||||
@ -135,12 +152,15 @@ Runtime, watchers run synchronously.")
|
||||
(while (or etaf--dispatch-source-queue etaf--dispatch-runtime-queue)
|
||||
(while etaf--dispatch-source-queue
|
||||
(let ((source (pop etaf--dispatch-source-queue)))
|
||||
(unless etaf--dispatch-source-queue
|
||||
(setq etaf--dispatch-source-queue-tail nil))
|
||||
(remhash source etaf--dispatch-source-set)
|
||||
(etaf--dispatch-source-now source)))
|
||||
;; Detach this turn. A lifecycle write may enqueue a source and the same
|
||||
;; Runtime again for the following turn without merging it into this one.
|
||||
(let ((turn etaf--dispatch-runtime-queue))
|
||||
(setq etaf--dispatch-runtime-queue nil)
|
||||
(setq etaf--dispatch-runtime-queue nil
|
||||
etaf--dispatch-runtime-queue-tail nil)
|
||||
(dolist (runtime turn)
|
||||
(let ((function (gethash runtime etaf--dispatch-runtime-set)))
|
||||
(remhash runtime etaf--dispatch-runtime-set)
|
||||
@ -257,13 +277,14 @@ of the run."
|
||||
"Notify every current subscriber of SOURCE once."
|
||||
(unless (gethash source etaf--dispatch-source-set)
|
||||
(puthash source t etaf--dispatch-source-set)
|
||||
(setq etaf--dispatch-source-queue
|
||||
(nconc etaf--dispatch-source-queue (list source))))
|
||||
(etaf--dispatch-append-source source))
|
||||
(when (zerop etaf--dispatch-depth)
|
||||
(let ((etaf--dispatch-depth 1))
|
||||
(unwind-protect (etaf--drain-dispatch)
|
||||
(setq etaf--dispatch-source-queue nil
|
||||
etaf--dispatch-runtime-queue nil)
|
||||
etaf--dispatch-source-queue-tail nil
|
||||
etaf--dispatch-runtime-queue nil
|
||||
etaf--dispatch-runtime-queue-tail nil)
|
||||
(clrhash etaf--dispatch-source-set)
|
||||
(clrhash etaf--dispatch-runtime-set)
|
||||
(clrhash etaf--dispatch-effect-set)))))
|
||||
|
||||
134
etaf-renderer.el
134
etaf-renderer.el
@ -22,9 +22,22 @@
|
||||
(defvar etaf--rendered-range-container-nodes nil
|
||||
"Candidate-local Ebox nodes whose layout directly contains a Range.")
|
||||
(declare-function etaf--runtime-render-child-range "etaf-runtime" (runtime expr path))
|
||||
(declare-function etaf--runtime-render-fragment-range
|
||||
"etaf-runtime" (runtime fragment path))
|
||||
(declare-function etaf--runtime-render-raw-range
|
||||
"etaf-runtime" (runtime raw path))
|
||||
(declare-function etaf--runtime-render-slot-range
|
||||
"etaf-runtime" (runtime projection path))
|
||||
(declare-function etaf--runtime-register-semantic-host "etaf-runtime" (runtime name props backend-props path))
|
||||
(declare-function etaf--runtime-register-semantic-host
|
||||
"etaf-runtime"
|
||||
(runtime name props backend-props path
|
||||
&optional theme-bindings theme-deps
|
||||
property-bindings property-deps
|
||||
property-context-deps base-props site-token))
|
||||
(declare-function etaf--runtime-resolve-host-properties
|
||||
"etaf-runtime" (props))
|
||||
(declare-function etaf--runtime-theme-paint-value
|
||||
"etaf-runtime" (runtime property token source resolved))
|
||||
(declare-function etaf--runtime-finish-semantic-host
|
||||
"etaf-runtime" (runtime semantic-id &optional content content-parts))
|
||||
(declare-function etaf--runtime-render-inline-content
|
||||
@ -32,7 +45,8 @@
|
||||
(declare-function etaf--runtime-call-with-component-env
|
||||
"etaf-runtime" (runtime component-id function))
|
||||
(declare-function etaf--runtime-behavior-node "etaf-runtime" (runtime node path))
|
||||
(declare-function etaf--runtime-register-host "etaf-runtime" (runtime props path))
|
||||
(declare-function etaf--runtime-register-host
|
||||
"etaf-runtime" (runtime props path &optional site-token))
|
||||
(declare-function etaf-theme-defaults "etaf-context" (&optional default))
|
||||
(declare-function etaf-theme-token-p "etaf-context" (value))
|
||||
(declare-function etaf-theme-token-resolve "etaf-context" (value))
|
||||
@ -65,10 +79,10 @@
|
||||
(and (keywordp property)
|
||||
(string-prefix-p "on-" (substring (symbol-name property) 1))))
|
||||
|
||||
(defun etaf--generated-host-ref (props path)
|
||||
"Return the explicit or generated opaque host reference for PROPS and PATH."
|
||||
(defun etaf--generated-host-ref (props path &optional site-token)
|
||||
"Return the explicit or generated opaque Host reference."
|
||||
(or (plist-get props :ref)
|
||||
(list 'etaf-host (copy-sequence path))))
|
||||
(list 'etaf-host (or site-token (copy-sequence path)))))
|
||||
|
||||
(defun etaf--merge-property (props key value)
|
||||
"Return PROPS with KEY set to VALUE, preserving the original order."
|
||||
@ -136,9 +150,6 @@ not create another visual node category."
|
||||
(setq value (if (and (consp value) (eq (car value) 'quote))
|
||||
(cadr value)
|
||||
value))
|
||||
(setq value (if (etaf-theme-token-p value)
|
||||
(etaf-theme-token-resolve value)
|
||||
value))
|
||||
(unless (plist-get props key)
|
||||
(setq props (etaf--merge-property props key value))))))))
|
||||
(etaf--view-node-create
|
||||
@ -151,7 +162,8 @@ not create another visual node category."
|
||||
"Apply known inherited Theme defaults to NODE without overriding props.
|
||||
Unknown Theme keys remain readable through `etaf-theme-value' but are design
|
||||
tokens, not Ebox Host properties, and therefore are not materialized here."
|
||||
(let ((defaults (etaf-theme-defaults)))
|
||||
(let* ((source (etaf--theme-source))
|
||||
(defaults (etaf--theme-source-value source nil nil)))
|
||||
(if (null defaults)
|
||||
node
|
||||
(let ((props (copy-sequence
|
||||
@ -162,13 +174,41 @@ tokens, not Ebox Host properties, and therefore are not materialized here."
|
||||
(value (pop defaults)))
|
||||
(when (and (etaf--theme-ebox-property-p key)
|
||||
(not (plist-get props key)))
|
||||
(setq props (etaf--merge-property props key value)))))
|
||||
(setq props
|
||||
(etaf--merge-property
|
||||
props key (etaf-theme-token key value))))))
|
||||
(etaf--view-node-create
|
||||
:name (etaf--view-node-name node)
|
||||
:token (etaf--view-node-token node)
|
||||
:props props
|
||||
:children (etaf--view-node-children node))))))
|
||||
|
||||
(defun etaf--resolve-theme-property-plist (props)
|
||||
"Return resolved PROPS, Theme bindings, and reactive dependencies."
|
||||
(let ((source (etaf--theme-source)) resolved bindings deps)
|
||||
(while props
|
||||
(let ((property (pop props))
|
||||
(value (pop props)))
|
||||
(if (etaf-theme-token-p value)
|
||||
(let ((resolved-value
|
||||
(etaf--theme-token-resolve-from-source value source)))
|
||||
(push property resolved)
|
||||
(push (if etaf--render-runtime
|
||||
(etaf--runtime-theme-paint-value
|
||||
etaf--render-runtime property value source
|
||||
resolved-value)
|
||||
resolved-value)
|
||||
resolved)
|
||||
(when (or (etaf-ref-p source) (etaf-computed-p source))
|
||||
(push (etaf--theme-property-binding-create
|
||||
:property property :token (copy-tree value)
|
||||
:source source)
|
||||
bindings)
|
||||
(cl-pushnew source deps :test #'eq)))
|
||||
(push property resolved)
|
||||
(push value resolved))))
|
||||
(list (nreverse resolved) (nreverse bindings) (nreverse deps))))
|
||||
|
||||
(defun etaf--theme-ebox-property-p (key)
|
||||
"Return non-nil when Theme KEY is a known Ebox property.
|
||||
The public `ebox-property-rules' table is the shared property vocabulary;
|
||||
@ -250,7 +290,7 @@ the ordinary layout lowering path instead."
|
||||
(cl-every #'etaf--inline-text-structural-p value))
|
||||
(t nil)))
|
||||
|
||||
(defun etaf--ebox-properties (props path)
|
||||
(defun etaf--ebox-properties (props path &optional site-token)
|
||||
"Translate ETAF PROPS at PATH into Ebox's public property list."
|
||||
(let* ((source-props (etaf--resolve-property-plist props))
|
||||
(props (copy-sequence source-props))
|
||||
@ -260,11 +300,13 @@ the ordinary layout lowering path instead."
|
||||
(value (pop props)))
|
||||
(cond
|
||||
((eq key :face)
|
||||
(setq surface-properties
|
||||
(append surface-properties (list 'face value))))
|
||||
(push 'face surface-properties)
|
||||
(push value surface-properties))
|
||||
((eq key :surface-properties)
|
||||
(setq surface-properties
|
||||
(append surface-properties value)))
|
||||
(let ((tail value))
|
||||
(while tail
|
||||
(push (pop tail) surface-properties)
|
||||
(push (pop tail) surface-properties))))
|
||||
((eq key :content)
|
||||
(signal 'etaf-renderer-error
|
||||
(list "Use View children for content, not :content")))
|
||||
@ -273,10 +315,14 @@ the ordinary layout lowering path instead."
|
||||
(eq key :styles))
|
||||
nil)
|
||||
(t
|
||||
(setq ebox-props (append ebox-props (list key value)))))))
|
||||
(push key ebox-props)
|
||||
(push value ebox-props)))))
|
||||
(setq ebox-props (nreverse ebox-props)
|
||||
surface-properties (nreverse surface-properties))
|
||||
(setq ebox-props
|
||||
(etaf--merge-property
|
||||
ebox-props :host-ref (etaf--generated-host-ref source-props path)))
|
||||
ebox-props :host-ref
|
||||
(etaf--generated-host-ref source-props path site-token)))
|
||||
(when surface-properties
|
||||
(setq ebox-props
|
||||
(append ebox-props
|
||||
@ -426,24 +472,47 @@ the ordinary layout lowering path instead."
|
||||
(etaf--runtime-behavior-node
|
||||
etaf--render-runtime node path)
|
||||
node))
|
||||
(property-result
|
||||
(if etaf--render-runtime
|
||||
(etaf--runtime-resolve-host-properties
|
||||
(etaf--view-node-props node))
|
||||
(list (etaf--resolve-property-plist
|
||||
(etaf--view-node-props node))
|
||||
nil nil nil)))
|
||||
(property-bindings (nth 1 property-result))
|
||||
(property-deps (nth 2 property-result))
|
||||
(property-context-deps (nth 3 property-result))
|
||||
(base-props (car property-result))
|
||||
(node (let ((copy (copy-sequence node)))
|
||||
(setf (etaf--view-node-props copy) base-props)
|
||||
copy))
|
||||
(node (if (fboundp 'etaf--runtime-style-node)
|
||||
(etaf--runtime-style-node node path)
|
||||
node))
|
||||
(node (etaf--apply-theme-defaults node))
|
||||
(name (etaf--view-node-name node))
|
||||
(raw-props (etaf--resolve-property-plist
|
||||
(etaf--view-node-props node)))
|
||||
(props (etaf--ebox-properties raw-props path))
|
||||
(theme-result
|
||||
(etaf--resolve-theme-property-plist
|
||||
(etaf--resolve-property-plist (etaf--view-node-props node))))
|
||||
(raw-props (nth 0 theme-result))
|
||||
(theme-bindings (nth 1 theme-result))
|
||||
(theme-deps (nth 2 theme-result))
|
||||
(props (etaf--ebox-properties
|
||||
raw-props path (etaf--view-node-token node)))
|
||||
(children (etaf--view-node-children node)))
|
||||
(when (and etaf--render-runtime
|
||||
(fboundp 'etaf--runtime-register-host))
|
||||
(etaf--runtime-register-host etaf--render-runtime raw-props path))
|
||||
(etaf--runtime-register-host
|
||||
etaf--render-runtime raw-props path (etaf--view-node-token node)))
|
||||
(pcase name
|
||||
('text
|
||||
(let* ((semantic-id
|
||||
(and etaf--render-runtime
|
||||
(etaf--runtime-register-semantic-host
|
||||
etaf--render-runtime name raw-props props path)))
|
||||
etaf--render-runtime name raw-props props path
|
||||
theme-bindings theme-deps property-bindings
|
||||
property-deps property-context-deps base-props
|
||||
(etaf--view-node-token node))))
|
||||
(child-path (append path (list :text)))
|
||||
(runtime-inline
|
||||
(and semantic-id
|
||||
@ -474,7 +543,10 @@ the ordinary layout lowering path instead."
|
||||
(list "spacer cannot have children")))
|
||||
(when etaf--render-runtime
|
||||
(let ((semantic-id (etaf--runtime-register-semantic-host
|
||||
etaf--render-runtime name raw-props props path)))
|
||||
etaf--render-runtime name raw-props props path
|
||||
theme-bindings theme-deps property-bindings
|
||||
property-deps property-context-deps base-props
|
||||
(etaf--view-node-token node))))
|
||||
(etaf--runtime-finish-semantic-host
|
||||
etaf--render-runtime semantic-id)))
|
||||
(list (apply #'ebox-spacer props)))
|
||||
@ -487,7 +559,10 @@ the ordinary layout lowering path instead."
|
||||
(semantic-id
|
||||
(and etaf--render-runtime
|
||||
(etaf--runtime-register-semantic-host
|
||||
etaf--render-runtime name raw-props props path))))
|
||||
etaf--render-runtime name raw-props props path
|
||||
theme-bindings theme-deps property-bindings
|
||||
property-deps property-context-deps base-props
|
||||
(etaf--view-node-token node)))))
|
||||
(dolist (child children)
|
||||
(setq nodes
|
||||
(nconc nodes
|
||||
@ -597,11 +672,14 @@ Runtime because their setup Scope must have a lifecycle owner."
|
||||
(t (apply #'ebox-column nodes)))))
|
||||
|
||||
;;;###autoload
|
||||
(defun etaf-mount (buffer-or-name view)
|
||||
"Mount normalized VIEW into BUFFER-OR-NAME and return its buffer."
|
||||
(defun etaf-mount (buffer-or-name view &optional options)
|
||||
"Mount normalized VIEW into BUFFER-OR-NAME and return its buffer.
|
||||
OPTIONS is forwarded to `etaf-runtime-mount' when the Runtime is loaded."
|
||||
(if (fboundp 'etaf-runtime-mount)
|
||||
(etaf-runtime-mount buffer-or-name view)
|
||||
(ebox-render-to-buffer buffer-or-name (etaf-render view))))
|
||||
(etaf-runtime-mount buffer-or-name view options)
|
||||
(let ((ebox-viewport-width (plist-get options :viewport-width))
|
||||
(ebox-viewport-height (plist-get options :viewport-height)))
|
||||
(ebox-render-to-buffer buffer-or-name (etaf-render view)))))
|
||||
|
||||
(provide 'etaf-renderer)
|
||||
|
||||
|
||||
1013
etaf-runtime.el
1013
etaf-runtime.el
File diff suppressed because it is too large
Load Diff
@ -48,12 +48,11 @@ appearance."
|
||||
(signal 'etaf-context-error
|
||||
(list (format "Invalid TP Theme binding: %S"
|
||||
(cons token binding)))))
|
||||
(setq theme
|
||||
(append theme
|
||||
(list token
|
||||
(tp-palette-color-for-mode
|
||||
(car binding) (cdr binding) mode))))))
|
||||
theme))
|
||||
(push token theme)
|
||||
(push (tp-palette-color-for-mode
|
||||
(car binding) (cdr binding) mode)
|
||||
theme)))
|
||||
(nreverse theme)))
|
||||
|
||||
(provide 'etaf-theme-tp)
|
||||
;;; etaf-theme-tp.el ends here
|
||||
|
||||
23
etaf-view.el
23
etaf-view.el
@ -31,7 +31,10 @@
|
||||
(:constructor etaf--expr-create))
|
||||
"Internal executable child expression."
|
||||
token
|
||||
thunk)
|
||||
thunk
|
||||
range-snapshot
|
||||
range-key
|
||||
range-item)
|
||||
|
||||
(cl-defstruct (etaf--component-spec
|
||||
(:constructor etaf--component-spec-create))
|
||||
@ -161,6 +164,8 @@ form, or core Host. A collision receives a semantic `-view' alias."
|
||||
(etaf--component-error
|
||||
"Component alias %S is already registered" alias)))
|
||||
(puthash alias spec etaf--view-registry))
|
||||
(when (fboundp 'etaf-compiler-note-registry-change)
|
||||
(etaf-compiler-note-registry-change))
|
||||
spec)
|
||||
|
||||
(defun etaf--register-core-hosts ()
|
||||
@ -200,8 +205,9 @@ form, or core Host. A collision receives a semantic `-view' alias."
|
||||
(when (memq key seen)
|
||||
(etaf--component-error "Duplicate View property: %S" key))
|
||||
(push key seen)
|
||||
(setq copy (append copy (list key value)))))
|
||||
copy))
|
||||
(push key copy)
|
||||
(push value copy)))
|
||||
(nreverse copy)))
|
||||
|
||||
(defun etaf--resolve-property-value (value)
|
||||
"Resolve one lazily compiled property VALUE."
|
||||
@ -214,10 +220,9 @@ form, or core Host. A collision receives a semantic `-view' alias."
|
||||
(let ((copy nil)
|
||||
(tail props))
|
||||
(while tail
|
||||
(setq copy (append copy
|
||||
(list (pop tail)
|
||||
(etaf--resolve-property-value (pop tail))))))
|
||||
copy))
|
||||
(push (pop tail) copy)
|
||||
(push (etaf--resolve-property-value (pop tail)) copy))
|
||||
(nreverse copy)))
|
||||
|
||||
(defun etaf--compile-property-value (form)
|
||||
"Compile property FORM as a constant or a render-time thunk."
|
||||
@ -436,7 +441,9 @@ Properties must come first and children must come last. Property values are
|
||||
ordinary Elisp expressions. `expr' is the only computation bridge in the
|
||||
child region and accepts only `:value'."
|
||||
(declare (indent 1) (debug (form)))
|
||||
(etaf--compile-view-form form :projection))
|
||||
(if (fboundp 'etaf-compiler-expand-view)
|
||||
(etaf-compiler-expand-view form :projection t)
|
||||
(etaf--compile-view-form form :projection)))
|
||||
|
||||
(defun etaf--component-prop-key (name)
|
||||
"Return the keyword used to pass Component prop NAME."
|
||||
|
||||
6
etaf.el
6
etaf.el
@ -28,6 +28,8 @@
|
||||
(etaf--prefer-local-files)
|
||||
|
||||
(require 'etaf-view)
|
||||
(require 'etaf-compiler)
|
||||
(require 'etaf-app)
|
||||
(require 'etaf-component)
|
||||
(require 'etaf-reactive)
|
||||
(require 'etaf-context)
|
||||
@ -39,6 +41,10 @@
|
||||
(require 'etaf-behavior)
|
||||
(require 'etaf-actions)
|
||||
(require 'etaf-events)
|
||||
(require 'etaf-performance)
|
||||
|
||||
(unless (fboundp 'ebox-call-with-render-burst)
|
||||
(error "ETAF requires an Ebox build with framework render-burst support"))
|
||||
|
||||
(provide 'etaf)
|
||||
|
||||
|
||||
91
tests/etaf-app-tests.el
Normal file
91
tests/etaf-app-tests.el
Normal file
@ -0,0 +1,91 @@
|
||||
;;; etaf-app-tests.el --- ETAF App workflow tests -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
|
||||
(defmacro etaf-app-test--with-files (bindings &rest body)
|
||||
"Create temporary App files named by BINDINGS and evaluate BODY."
|
||||
(declare (indent 1))
|
||||
`(let* ((directory (make-temp-file "etaf-app-test-" t))
|
||||
(source (expand-file-name "sample.el" directory))
|
||||
(static (expand-file-name "sample.etaf" directory))
|
||||
(style (expand-file-name "sample.ecss" directory))
|
||||
(artifact (expand-file-name "sample.etafc" directory))
|
||||
,@bindings)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(with-temp-file source
|
||||
(insert "(defun sample-view (color)\n"
|
||||
" (etaf-view\n"
|
||||
" (column :color color (text \"sample\"))))\n"))
|
||||
(with-temp-file static (insert "(sample :title \"Sample\")\n"))
|
||||
(with-temp-file style (insert "(styles (\"column\" :color red))\n"))
|
||||
,@body)
|
||||
(when (file-directory-p directory)
|
||||
(delete-directory directory t)))))
|
||||
|
||||
(ert-deftest etaf-app-interactive-workflow-produces-current-artifact ()
|
||||
"The public App command writes and loads a current standalone artifact."
|
||||
(etaf-app-test--with-files ()
|
||||
(etaf-register-app "sample" :source source :static static :style style
|
||||
:artifact artifact)
|
||||
(should (eq (plist-get (etaf-app-compile-status "sample") :status)
|
||||
'missing))
|
||||
(let ((status (etaf-compile-app "sample")))
|
||||
(should (file-readable-p artifact))
|
||||
(should (eq (plist-get status :status) 'current))
|
||||
(should (= (plist-get status :blueprints) 1)))
|
||||
(should (eq (plist-get (etaf-app-compile-status "sample") :status)
|
||||
'current))))
|
||||
|
||||
(ert-deftest etaf-app-artifact-becomes-stale-after-source-change ()
|
||||
"Changing any source hash rejects the previously compiled artifact."
|
||||
(etaf-app-test--with-files ()
|
||||
(etaf-register-app "sample-stale"
|
||||
:source source :static static :style style
|
||||
:artifact artifact)
|
||||
(etaf-compile-app "sample-stale")
|
||||
(with-temp-buffer
|
||||
(insert-file-contents source)
|
||||
(goto-char (point-max))
|
||||
(insert "\n;; changed\n")
|
||||
(write-region (point-min) (point-max) source nil 'silent))
|
||||
(should (eq (plist-get (etaf-app-compile-status "sample-stale") :status)
|
||||
'stale))))
|
||||
|
||||
(ert-deftest etaf-app-loaded-blueprint-is-consumed-at-runtime ()
|
||||
"Instantiation uses the manually compiled blueprint by artifact id."
|
||||
(etaf-app-test--with-files ()
|
||||
(etaf-register-app "sample-hit" :source source :static static :style style
|
||||
:artifact artifact)
|
||||
(let* ((status (etaf-compile-app "sample-hit"))
|
||||
(entry (car (plist-get (plist-get status :artifact) :blueprints)))
|
||||
(blueprint (plist-get entry :blueprint))
|
||||
(before (plist-get (etaf-compiler-statistics) :artifact-hits))
|
||||
(view (etaf-compiler-instantiate
|
||||
blueprint (vector (lambda () "purple")))))
|
||||
(should (etaf--view-node-p view))
|
||||
(should (> (plist-get (etaf-compiler-statistics) :artifact-hits) before)))))
|
||||
|
||||
(ert-deftest etaf-app-missing-artifact-warns-once-with-compile-command ()
|
||||
"Direct fallback tells an interactive user exactly how to compile the App."
|
||||
(etaf-app-test--with-files ()
|
||||
(etaf-register-app "sample-warning"
|
||||
:source source :static static :style style
|
||||
:artifact artifact)
|
||||
(let ((noninteractive nil)
|
||||
(etaf-app-warn-on-artifact-fallback t)
|
||||
warnings)
|
||||
(remhash "sample-warning" etaf-app--warning-state)
|
||||
(cl-letf (((symbol-function 'display-warning)
|
||||
(lambda (_type message &optional _level _buffer-name)
|
||||
(push message warnings))))
|
||||
(should-not (etaf-app-load-artifact-or-warn "sample-warning"))
|
||||
(should-not (etaf-app-load-artifact-or-warn "sample-warning")))
|
||||
(should (= (length warnings) 1))
|
||||
(should (string-match-p "M-x etaf-compile-app" (car warnings))))))
|
||||
|
||||
(provide 'etaf-app-tests)
|
||||
;;; etaf-app-tests.el ends here
|
||||
151
tests/etaf-compiler-tests.el
Normal file
151
tests/etaf-compiler-tests.el
Normal file
@ -0,0 +1,151 @@
|
||||
;;; etaf-compiler-tests.el --- ETAF compiler slice tests -*- lexical-binding: t; -*-
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
|
||||
(defmacro etaf-compiler-test--legacy-view (form)
|
||||
"Construct FORM through the pre-compiler View expansion for comparison."
|
||||
(etaf--compile-view-form form :projection))
|
||||
|
||||
(defun etaf-compiler-test--canonical (value)
|
||||
"Return VALUE as comparable View data, resolving lazy holes once."
|
||||
(cond
|
||||
((etaf--expr-p value)
|
||||
(etaf-compiler-test--canonical (funcall (etaf--expr-thunk value))))
|
||||
((etaf--view-node-p value)
|
||||
(list :host (etaf--view-node-name value)
|
||||
:props (etaf--resolve-property-plist (etaf--view-node-props value))
|
||||
:children (mapcar #'etaf-compiler-test--canonical
|
||||
(etaf--view-node-children value))))
|
||||
((etaf--slot-projection-p value)
|
||||
(list :slot (etaf--slot-projection-name value)
|
||||
:fallback (mapcar #'etaf-compiler-test--canonical
|
||||
(etaf--slot-projection-fallback value))))
|
||||
((stringp value) value)
|
||||
((null value) nil)
|
||||
(t value)))
|
||||
|
||||
(defun etaf-compiler-test--interpreted (color text)
|
||||
"Return an interpreted fixture using COLOR and TEXT."
|
||||
(etaf-compiler-test--legacy-view
|
||||
(column :color color
|
||||
(column :padding '(1 2)
|
||||
(text "static"))
|
||||
(text (expr :value text)))))
|
||||
|
||||
(defun etaf-compiler-test--compiled (color text)
|
||||
"Return a compiled fixture using COLOR and TEXT."
|
||||
(etaf-compiled-view
|
||||
(column :color color
|
||||
(column :padding '(1 2)
|
||||
(text "static"))
|
||||
(text (expr :value text)))))
|
||||
|
||||
(defun etaf-compiler-test--fallback-view ()
|
||||
"Return a View containing the not-yet-compiled slot grammar."
|
||||
(etaf-compiled-view
|
||||
(column (slot (text "fallback")))))
|
||||
|
||||
(defun etaf-compiler-test--fallback-reference ()
|
||||
"Return the interpreted reference for `etaf-compiler-test--fallback-view'."
|
||||
(etaf-compiler-test--legacy-view
|
||||
(column (slot (text "fallback")))))
|
||||
|
||||
(ert-deftest etaf-compiled-view-fallback-is-exact ()
|
||||
"An unsupported slot keeps the existing View semantics."
|
||||
(let ((before (plist-get (etaf-compiler-statistics) :fallbacks)))
|
||||
(should
|
||||
(equal (etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--fallback-view))
|
||||
(etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--fallback-reference))))
|
||||
(should (= (1+ before)
|
||||
(plist-get (etaf-compiler-statistics) :fallbacks)))))
|
||||
|
||||
(defun etaf-compiler-test--compiled-supported (color)
|
||||
"Return a supported compiled fixture using COLOR."
|
||||
(etaf-compiled-view
|
||||
(column :color color
|
||||
(column :padding '(1 2)
|
||||
(text "static-a")
|
||||
(text "static-b"))
|
||||
(text :color "blue" "tail"))))
|
||||
|
||||
(defun etaf-compiler-test--interpreted-supported (color)
|
||||
"Return the matching interpreted fixture using COLOR."
|
||||
(etaf-compiler-test--legacy-view
|
||||
(column :color color
|
||||
(column :padding '(1 2)
|
||||
(text "static-a")
|
||||
(text "static-b"))
|
||||
(text :color "blue" "tail"))))
|
||||
|
||||
(ert-deftest etaf-compiled-view-supported-output-is-exact ()
|
||||
"A supported blueprint produces the same normalized View data."
|
||||
(should
|
||||
(equal (etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--compiled-supported "green"))
|
||||
(etaf-compiler-test--canonical
|
||||
(etaf-compiler-test--interpreted-supported "green")))))
|
||||
|
||||
(ert-deftest etaf-compiled-view-reuses-static-subtrees ()
|
||||
"Repeated instantiation reuses a static child while rebuilding its root."
|
||||
(etaf-compiler-clear-cache)
|
||||
(let* ((first (etaf-compiler-test--compiled-supported "red"))
|
||||
(second (etaf-compiler-test--compiled-supported "blue"))
|
||||
(first-static (car (etaf--view-node-children first)))
|
||||
(second-static (car (etaf--view-node-children second))))
|
||||
(should-not (eq first second))
|
||||
(should (eq first-static second-static))))
|
||||
|
||||
(ert-deftest etaf-compiled-view-reduces-runtime-construction-work ()
|
||||
"A warmed blueprint constructs only its dynamic ancestor path."
|
||||
(etaf-compiler-clear-cache)
|
||||
(etaf-compiler-test--compiled-supported "warm")
|
||||
(let ((calls 0)
|
||||
(original (symbol-function 'etaf--view-call)))
|
||||
(cl-letf (((symbol-function 'etaf--view-call)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf calls)
|
||||
(apply original arguments))))
|
||||
(etaf-compiler-test--compiled-supported "next"))
|
||||
(should (= calls 1))
|
||||
(setq calls 0)
|
||||
(cl-letf (((symbol-function 'etaf--view-call)
|
||||
(lambda (&rest arguments)
|
||||
(cl-incf calls)
|
||||
(apply original arguments))))
|
||||
(etaf-compiler-test--interpreted-supported "next"))
|
||||
(should (> calls 1))))
|
||||
|
||||
(ert-deftest etaf-compiled-view-exposes-blueprint-coverage ()
|
||||
"The compiler reports static nodes, dynamic paths, and holes."
|
||||
(pcase-let* ((`(,blueprint . ,programs)
|
||||
(etaf-compiler--compile
|
||||
'(column :color color
|
||||
(column (text "static")))))
|
||||
(static (plist-get blueprint :static-nodes))
|
||||
(dynamic (plist-get blueprint :dynamic-nodes)))
|
||||
(should (equal (plist-get blueprint :abi)
|
||||
etaf-compiler-blueprint-abi))
|
||||
(should (> static 0))
|
||||
(should (= dynamic 1))
|
||||
(should (= (length programs) 1))
|
||||
(should (= (plist-get blueprint :hole-count) 1))))
|
||||
|
||||
(ert-deftest etaf-compiled-view-expr-is-a-dynamic-child-hole ()
|
||||
"Expr becomes one dynamic child program without forcing root fallback."
|
||||
(pcase-let* ((`(,blueprint . ,programs)
|
||||
(etaf-compiler--compile
|
||||
'(column (text (expr :value value)))))
|
||||
(root (plist-get blueprint :root))
|
||||
(text-block (car (plist-get root :children)))
|
||||
(expr-block (car (plist-get text-block :children))))
|
||||
(should (eq (plist-get expr-block :kind) 'expr))
|
||||
(should-not (plist-get root :static-p))
|
||||
(should (= (length programs) 1))))
|
||||
|
||||
(provide 'etaf-compiler-tests)
|
||||
;;; etaf-compiler-tests.el ends here
|
||||
@ -34,6 +34,32 @@
|
||||
(should (eq 'success (etaf-value (etaf-data-status controller)))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-controller-accepts-prepared-initial-result ()
|
||||
"Seed one data-ready Controller without a second source call."
|
||||
(let* ((calls 0)
|
||||
(source
|
||||
(etaf-data-source
|
||||
:load (lambda (_query page page-size)
|
||||
(cl-incf calls)
|
||||
(list :items '((:id 9 :name "Prepared"))
|
||||
:total 41 :page page :page-size page-size))))
|
||||
(prepared (etaf-data-source-load-page source nil 2 10))
|
||||
(controller (etaf-data-controller
|
||||
source :page 2 :page-size 10
|
||||
:initial-result prepared :item-key (lambda (row)
|
||||
(plist-get row :id)))))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(should (= 1 calls))
|
||||
(should (equal '(9) (etaf-data-test--ids controller)))
|
||||
(should (= 41 (etaf-value (etaf-data-total controller))))
|
||||
(should (= 2 (etaf-value (etaf-data-page controller))))
|
||||
(should (= 10 (etaf-value (etaf-data-page-size controller))))
|
||||
(should (eq 'success (etaf-value (etaf-data-status controller))))
|
||||
(should-error
|
||||
(etaf-data-controller source :initial-result prepared :auto-load t)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-loading-state-is-visible-to-source-boundary ()
|
||||
"Publish loading before invoking the source load capability."
|
||||
(let (controller seen)
|
||||
@ -175,6 +201,63 @@
|
||||
(should-not (etaf-value (etaf-data-selection controller))))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-selected-refs-are-stable-and-differential ()
|
||||
"Selected refs keep identity and notify only changed identities."
|
||||
(let* ((source (etaf-data-memory-source etaf-data-test-records :id-key :id))
|
||||
(controller (etaf-data-controller source :selection '(1 3)))
|
||||
(one (etaf-data-selected-ref controller 1))
|
||||
(two (etaf-data-selected-ref controller 2))
|
||||
(three (etaf-data-selected-ref controller 3))
|
||||
(one-updates 0)
|
||||
(two-updates 0)
|
||||
(three-updates 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(should (eq one (etaf-data-selected-ref controller 1)))
|
||||
(should (etaf-value one))
|
||||
(should-not (etaf-value two))
|
||||
(should (etaf-value three))
|
||||
(etaf-watch one (lambda (&rest _) (cl-incf one-updates)))
|
||||
(etaf-watch two (lambda (&rest _) (cl-incf two-updates)))
|
||||
(etaf-watch three (lambda (&rest _) (cl-incf three-updates)))
|
||||
(setf (etaf-value (etaf-data-selection controller)) '(2 3))
|
||||
(should-not (etaf-value one))
|
||||
(should (etaf-value two))
|
||||
(should (etaf-value three))
|
||||
(should (= 1 one-updates))
|
||||
(should (= 1 two-updates))
|
||||
(should (zerop three-updates)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-selected-refs-preserve-multi-select-apis ()
|
||||
"Additive selection updates the matching keyed refs independently."
|
||||
(let* ((source (etaf-data-memory-source etaf-data-test-records :id-key :id))
|
||||
(controller (etaf-data-controller source))
|
||||
(one (etaf-data-selected-ref controller 1))
|
||||
(three (etaf-data-selected-ref controller 3)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-data-select controller 1)
|
||||
(etaf-data-select controller 3)
|
||||
(should (equal '(3 1) (etaf-value (etaf-data-selection controller))))
|
||||
(should (etaf-value one))
|
||||
(should (etaf-value three))
|
||||
(etaf-data-select controller 1 nil)
|
||||
(should-not (etaf-value one))
|
||||
(should (etaf-value three))
|
||||
(etaf-data-clear-selection controller)
|
||||
(should-not (etaf-value three)))
|
||||
(etaf-data-stop controller))))
|
||||
|
||||
(ert-deftest etaf-data-stop-disposes-selection-index-watcher ()
|
||||
"Stopping a controller unsubscribes its selection-index watcher."
|
||||
(let* ((source (etaf-data-memory-source etaf-data-test-records :id-key :id))
|
||||
(controller (etaf-data-controller source))
|
||||
(selection (etaf-data-selection controller)))
|
||||
(should (= 1 (hash-table-count (etaf-ref-subscribers selection))))
|
||||
(etaf-data-stop controller)
|
||||
(should (zerop (hash-table-count (etaf-ref-subscribers selection))))))
|
||||
|
||||
(ert-deftest etaf-data-select-one-replaces-existing-selection ()
|
||||
"Single-selection consumers replace, rather than adjoin, identities."
|
||||
(let* ((source (etaf-data-memory-source
|
||||
|
||||
451
tests/etaf-performance-tests.el
Normal file
451
tests/etaf-performance-tests.el
Normal file
@ -0,0 +1,451 @@
|
||||
;;; etaf-performance-tests.el --- ETAF performance recorder tests -*- lexical-binding: t; -*-
|
||||
|
||||
;; SPDX-License-Identifier: GPL-3.0-or-later
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'ert)
|
||||
(require 'etaf)
|
||||
|
||||
(defmacro etaf-performance-test--isolated (&rest body)
|
||||
"Run BODY with isolated performance recorder state."
|
||||
(declare (indent 0) (debug t))
|
||||
`(unwind-protect
|
||||
(progn
|
||||
(etaf-performance-mode -1)
|
||||
(etaf-performance-clear)
|
||||
,@body)
|
||||
(etaf-performance-mode -1)
|
||||
(etaf-performance-clear)))
|
||||
|
||||
(ert-deftest etaf-performance-records-success-result-and-error ()
|
||||
"Recording preserves successful results and original error data."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(should (equal 42
|
||||
(etaf-performance--call-operation
|
||||
(lambda () 42) 'test-success 'test nil)))
|
||||
(let ((condition
|
||||
(condition-case error-data
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda ()
|
||||
(signal 'args-out-of-range '(source 1 2)))
|
||||
'failing-stage 'test 'failure nil))
|
||||
'test-error 'test nil)
|
||||
(args-out-of-range error-data))))
|
||||
(should (equal condition '(args-out-of-range source 1 2))))
|
||||
(let ((records (etaf-performance-records)))
|
||||
(should (= 2 (length records)))
|
||||
(should (eq 'error
|
||||
(etaf-performance-operation-status (car records))))
|
||||
(should (eq 'error
|
||||
(etaf-performance-stage-status
|
||||
(car (etaf-performance-operation-stages
|
||||
(car records))))))
|
||||
(should (eq 'success
|
||||
(etaf-performance-operation-status (cadr records)))))))
|
||||
|
||||
(ert-deftest etaf-performance-records-preserve-quit ()
|
||||
"Recording marks and re-signals a quit without changing its data."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(let ((condition
|
||||
(condition-case quit-data
|
||||
(etaf-performance--call-operation
|
||||
(lambda () (signal 'quit '(performance-test)))
|
||||
'test-quit 'test nil)
|
||||
(quit quit-data))))
|
||||
(should (equal condition '(quit performance-test)))
|
||||
(should (eq 'quit
|
||||
(etaf-performance-operation-status
|
||||
(car (etaf-performance-records))))))))
|
||||
|
||||
(ert-deftest etaf-performance-public-operation-wrapper-is-generic ()
|
||||
"The public operation API records arbitrary code and preserves its result."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(should
|
||||
(equal '(generic result)
|
||||
(etaf-performance-with-operation ('command "generic fixture")
|
||||
'(generic result))))
|
||||
(let ((operation (car (etaf-performance-records))))
|
||||
(should (eq 'command
|
||||
(etaf-performance-operation-kind operation)))
|
||||
(should (equal "generic fixture"
|
||||
(etaf-performance-operation-label operation))))))
|
||||
|
||||
(ert-deftest etaf-performance-stage-registration-is-load-order-safe ()
|
||||
"Third-party stages may register before their function is defined."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((function (make-symbol "etaf-performance-generic-stage")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-performance-register-stage function 'extension 'prepare)
|
||||
(etaf-performance-mode 1)
|
||||
(should-not (assq function etaf-performance--installed-advices))
|
||||
(fset function (lambda () 'extension-result))
|
||||
(etaf-performance--install-loaded-advices)
|
||||
(should (assq function etaf-performance--installed-advices))
|
||||
(should (eq 'extension-result
|
||||
(etaf-performance-call-operation
|
||||
'extension "registered stage"
|
||||
(lambda () (funcall function)))))
|
||||
(let ((stage
|
||||
(car (etaf-performance-operation-stages
|
||||
(car (etaf-performance-records))))))
|
||||
(should (eq function
|
||||
(etaf-performance-stage-function stage)))
|
||||
(should (eq 'extension
|
||||
(etaf-performance-stage-category stage)))))
|
||||
(etaf-performance-unregister-stage function)
|
||||
(when (fboundp function)
|
||||
(fmakunbound function))))))
|
||||
|
||||
(ert-deftest etaf-performance-default-registry-keeps-per-node-probes-opt-in ()
|
||||
"High-frequency per-node probes must not distort default operation timing."
|
||||
(dolist (function '(ebox-incremental--candidate-local-changed-keys
|
||||
ebox-tree-node-local-source-signature))
|
||||
(should-not (assq function etaf-performance--stage-functions))))
|
||||
|
||||
(ert-deftest etaf-performance-stage-advice-survives-package-reload ()
|
||||
"Reattach the tracked stage closure after its function is redefined."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((function (make-symbol "etaf-performance-reloaded-stage")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(fset function (lambda () 'first))
|
||||
(etaf-performance-register-stage function 'extension 'reload)
|
||||
(etaf-performance-mode 1)
|
||||
(let ((entry (assq function
|
||||
etaf-performance--installed-advices)))
|
||||
(should (advice-member-p (cdr entry) function))
|
||||
(fset function (lambda () 'second))
|
||||
(should-not (advice-member-p (cdr entry) function))
|
||||
(etaf-performance--install-loaded-advices)
|
||||
(should (advice-member-p (cdr entry) function)))
|
||||
(etaf-performance-clear)
|
||||
(should (eq 'second
|
||||
(etaf-performance-call-operation
|
||||
'reload "package reload"
|
||||
(lambda () (funcall function)))))
|
||||
(should (= 1
|
||||
(length
|
||||
(etaf-performance-operation-stages
|
||||
(car (etaf-performance-records)))))))
|
||||
(etaf-performance-unregister-stage function)
|
||||
(when (fboundp function) (fmakunbound function))))))
|
||||
|
||||
(ert-deftest etaf-performance-stage-registration-rejects-operation-collision ()
|
||||
"A detail stage must not replace a public operation boundary advice."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(let* ((function 'etaf-data-load)
|
||||
(entry (assq function etaf-performance--installed-advices)))
|
||||
(should entry)
|
||||
(should-error
|
||||
(etaf-performance-register-stage function 'data 'nested-load))
|
||||
(should-error (etaf-performance-unregister-stage function))
|
||||
(should (eq entry (assq function etaf-performance--installed-advices)))
|
||||
(should (advice-member-p (cdr entry) function)))))
|
||||
|
||||
(ert-deftest etaf-performance-public-data-resource-and-viewport-boundaries ()
|
||||
"Public cross-package operations are boundaries, never duplicate stages."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((functions '(etaf-data-load etaf-data-source-load-page
|
||||
etaf-data-mutate etaf-resource-load
|
||||
ebox-surface-update-buffer-viewport
|
||||
ebox-rerender-buffer-with-context)))
|
||||
(dolist (function functions)
|
||||
(should (assq function etaf-performance--operation-functions))
|
||||
(should-not (assq function etaf-performance--stage-functions)))
|
||||
(etaf-performance-mode 1)
|
||||
(dolist (function functions)
|
||||
(when (fboundp function)
|
||||
(should (assq function etaf-performance--installed-advices))))
|
||||
(let* ((source (etaf-data-memory-source
|
||||
'((:id 1 :name "one")) :id-key :id))
|
||||
(controller (etaf-data-controller source))
|
||||
(resource (etaf-resource (lambda () 'loaded) :immediate nil)))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-data-load controller)
|
||||
(etaf-data-source-load-page source nil 1 20)
|
||||
(etaf-data-mutate controller 'insert '(:id 2 :name "two"))
|
||||
(etaf-resource-load resource)
|
||||
(let ((kinds
|
||||
(mapcar #'etaf-performance-operation-kind
|
||||
(etaf-performance-records))))
|
||||
(should (memq 'data-load kinds))
|
||||
(should (memq 'data-prepare kinds))
|
||||
(should (memq 'data-mutate kinds))
|
||||
(should (memq 'resource-load kinds))))
|
||||
(etaf-data-stop controller)
|
||||
(etaf-resource-dispose resource))))))
|
||||
|
||||
(ert-deftest etaf-performance-records-nested-stage-exclusive-time ()
|
||||
"Nested stages retain depth and subtract child inclusive time."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda ()
|
||||
(sleep-for 0.002)
|
||||
(etaf-performance--call-stage
|
||||
(lambda () (sleep-for 0.002) 'inner-result)
|
||||
'inner-stage 'inner 'work nil)
|
||||
(sleep-for 0.002))
|
||||
'outer-stage 'outer 'work nil))
|
||||
'nested-operation 'test nil)
|
||||
(let* ((operation (car (etaf-performance-records)))
|
||||
(stages (etaf-performance-operation-stages operation))
|
||||
(outer (car stages))
|
||||
(inner (cadr stages)))
|
||||
(should (= 2 (length stages)))
|
||||
(should (= 0 (etaf-performance-stage-depth outer)))
|
||||
(should (= 1 (etaf-performance-stage-depth inner)))
|
||||
(should (>= (etaf-performance-stage-inclusive outer)
|
||||
(etaf-performance-stage-inclusive inner)))
|
||||
(should (< (abs (- (etaf-performance-stage-exclusive outer)
|
||||
(- (etaf-performance-stage-inclusive outer)
|
||||
(etaf-performance-stage-inclusive inner))))
|
||||
0.001)))))
|
||||
|
||||
(ert-deftest etaf-performance-records-are-bounded ()
|
||||
"Only the configured number of newest operations is retained."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((etaf-performance-max-records 2))
|
||||
(etaf-performance-mode 1)
|
||||
(dotimes (index 4)
|
||||
(etaf-performance--call-operation
|
||||
(lambda () index) 'bounded 'test nil))
|
||||
(let* ((records (etaf-performance-records))
|
||||
(ids (mapcar #'etaf-performance-operation-id records)))
|
||||
(should (= 2 (length records)))
|
||||
(should (= 1 (- (car ids) (cadr ids))))))))
|
||||
|
||||
(ert-deftest etaf-performance-clear-keeps-correlation-ids-monotonic ()
|
||||
"Clearing history inside an operation must not reuse its ID."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-call-operation
|
||||
'outer "clear inside" (lambda () (etaf-performance-clear)))
|
||||
(etaf-performance-call-operation 'next "after clear" #'ignore)
|
||||
(let ((ids (mapcar #'etaf-performance-operation-id
|
||||
(etaf-performance-records))))
|
||||
(should (= 2 (length (delete-dups (copy-sequence ids)))))
|
||||
(should (= 1 (- (car ids) (cadr ids)))))))
|
||||
|
||||
(ert-deftest etaf-performance-summaries-aggregate-off-the-hot-path ()
|
||||
"Summarize operation percentiles and non-overlapping category self time."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(dolist (delay '(0.001 0.002 0.003))
|
||||
(etaf-performance-call-operation
|
||||
'summary "generic"
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda () (sleep-for delay)) 'summary-stage 'application 'work nil))))
|
||||
(let* ((records (etaf-performance-records))
|
||||
(summary (car (etaf-performance-summary records)))
|
||||
(stage-summary
|
||||
(car (etaf-performance-operation-stage-summary (car records)))))
|
||||
(should (= 3 (plist-get summary :count)))
|
||||
(should (<= (plist-get summary :min-ms)
|
||||
(plist-get summary :p50-ms)
|
||||
(plist-get summary :p95-ms)
|
||||
(plist-get summary :max-ms)))
|
||||
(should (eq 'application (plist-get stage-summary :category)))
|
||||
(should (= 1 (plist-get stage-summary :count)))
|
||||
(should (<= (plist-get stage-summary :exclusive-ms)
|
||||
(plist-get stage-summary :inclusive-ms))))))
|
||||
|
||||
(ert-deftest etaf-performance-records-real-event-and-runtime-stages ()
|
||||
"A real mounted event creates an event operation and runtime stages."
|
||||
(etaf-performance-test--isolated
|
||||
(let ((buffer-name " *etaf-performance-event-test*")
|
||||
(calls 0)
|
||||
runtime-holder)
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(text :ref 'button
|
||||
:on-press (lambda ()
|
||||
(cl-incf calls)
|
||||
(etaf-runtime-flush runtime-holder))
|
||||
"Press")))
|
||||
(etaf-performance-clear)
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(setq runtime-holder runtime)
|
||||
(etaf-dispatch-event runtime 'button 'press)
|
||||
(should (= calls 1))
|
||||
(let ((operation
|
||||
(cl-find 'event (etaf-performance-records)
|
||||
:key #'etaf-performance-operation-kind)))
|
||||
(should (eq 'event
|
||||
(etaf-performance-operation-kind operation)))
|
||||
(should (= (etaf-runtime-mount-epoch runtime)
|
||||
(etaf-performance-operation-runtime-id operation)))
|
||||
(should (equal buffer-name
|
||||
(etaf-performance-operation-buffer-name
|
||||
operation)))
|
||||
(should (numberp
|
||||
(etaf-performance-operation-generation-before
|
||||
operation)))
|
||||
(should
|
||||
(cl-some
|
||||
(lambda (record)
|
||||
(cl-some
|
||||
(lambda (stage)
|
||||
(memq (etaf-performance-stage-category stage)
|
||||
'(runtime reactive ebox tp)))
|
||||
(etaf-performance-operation-stages record)))
|
||||
(etaf-performance-records))))))
|
||||
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer))))))
|
||||
|
||||
(ert-deftest etaf-performance-panel-has-operation-and-stage-entries ()
|
||||
"The tabulated panel expands one operation into its stage rows."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda () 'ok) 'panel-stage 'panel 'detail nil))
|
||||
'panel-operation 'test nil)
|
||||
(let ((entries (etaf-performance--tabulated-entries)))
|
||||
(should (= 2 (length entries)))
|
||||
(should (equal "operation" (aref (cadr (car entries)) 4)))
|
||||
(should (equal "stage" (aref (cadr (cadr entries)) 2))))
|
||||
(with-temp-buffer
|
||||
(etaf-performance-panel-mode)
|
||||
(tabulated-list-print t)
|
||||
(should (string-match-p "panel-operation" (buffer-string)))
|
||||
(should (string-match-p "panel-stage" (buffer-string))))))
|
||||
|
||||
(ert-deftest etaf-performance-report-is-portable-and-copyable ()
|
||||
"The shareable report contains environment, operation, and stage data."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-call-operation
|
||||
'report "copy fixture"
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda () 'ok) 'report-stage 'fixture 'work nil)))
|
||||
(let* ((data (etaf-performance-report-data))
|
||||
(operations (plist-get data :operations))
|
||||
(operation (car operations))
|
||||
(stage (car (plist-get operation :stages)))
|
||||
(kill-ring nil)
|
||||
(kill-ring-yank-pointer nil)
|
||||
(report (etaf-performance-copy-report)))
|
||||
(should (= etaf-performance-report-format-version
|
||||
(plist-get data :format-version)))
|
||||
(should (equal emacs-version
|
||||
(plist-get (plist-get data :environment)
|
||||
:emacs-version)))
|
||||
(should (equal "copy fixture" (plist-get operation :label)))
|
||||
(should (eq 'report-stage (plist-get stage :function)))
|
||||
(should (equal report (current-kill 0 t)))
|
||||
(should (string-match-p "ETAF performance report" report)))))
|
||||
|
||||
(ert-deftest etaf-performance-environment-normalizes-darwin-power-state ()
|
||||
"Reports distinguish AC, battery low-power, and unknown power states."
|
||||
(should
|
||||
(equal
|
||||
'(:source battery :low-power-mode on)
|
||||
(etaf-performance--parse-darwin-power-state
|
||||
"Now drawing from 'Battery Power'\n"
|
||||
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
|
||||
(should
|
||||
(equal
|
||||
'(:source ac :low-power-mode off)
|
||||
(etaf-performance--parse-darwin-power-state
|
||||
"Now drawing from 'AC Power'\n"
|
||||
"Battery Power:\n lowpowermode 1\nAC Power:\n lowpowermode 0\n")))
|
||||
(should
|
||||
(equal
|
||||
'(:source unknown :low-power-mode unknown)
|
||||
(etaf-performance--parse-darwin-power-state "" ""))))
|
||||
|
||||
(ert-deftest etaf-performance-panel-exposes-power-and-load-context ()
|
||||
"The visible panel explains system-wide latency shifts."
|
||||
(let ((line
|
||||
(etaf-performance--panel-environment-line
|
||||
'(:emacs-version "31.1"
|
||||
:power-state (:source battery :low-power-mode on)
|
||||
:load-average (2.5 2.0 1.5)))))
|
||||
(should (string-match-p "Emacs 31.1" line))
|
||||
(should (string-match-p "power battery/low:on" line))
|
||||
(should (string-match-p "load 2.50" line))))
|
||||
|
||||
(ert-deftest etaf-performance-export-writes-readable-report ()
|
||||
"The interactive export payload is a readable plain-data report."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance-call-operation 'export "file fixture" #'ignore)
|
||||
(let ((file (concat (make-temp-name
|
||||
(expand-file-name "etaf-performance-test-"
|
||||
temporary-file-directory))
|
||||
".eld")))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(should (equal file (etaf-performance-export file)))
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(should (string-match-p "ETAF performance report"
|
||||
(buffer-string)))
|
||||
(should (string-match-p "file fixture" (buffer-string)))))
|
||||
(when (file-exists-p file)
|
||||
(delete-file file))))))
|
||||
|
||||
(ert-deftest etaf-performance-captures-public-ebox-report-metadata ()
|
||||
"Attach compact public Ebox report facts to the active operation."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(etaf-performance--call-operation
|
||||
(lambda ()
|
||||
(etaf-performance--call-stage
|
||||
(lambda ()
|
||||
'(:strategy mixed-owner-reflow
|
||||
:projection-kind mixed-owner-reflow
|
||||
:dirty-count 8 :owner-ids (1 2 3) :patch-count 3
|
||||
:tp-scope-count 3 :tp-text-operations 12
|
||||
:tp-property-operations 111 :tp-full-root nil
|
||||
:tp-scope-fallback nil))
|
||||
'ebox-commit 'ebox 'commit nil))
|
||||
'report-operation 'test nil)
|
||||
(let* ((operation (car (etaf-performance-records)))
|
||||
(report (plist-get
|
||||
(etaf-performance-operation-metadata operation) :ebox)))
|
||||
(should (eq 'mixed-owner-reflow (plist-get report :strategy)))
|
||||
(should (= 3 (plist-get report :owner-count)))
|
||||
(should (= 111 (plist-get report :tp-property-operations)))
|
||||
(should (string-match-p "mixed-owner-reflow"
|
||||
(etaf-performance--format-report operation))))))
|
||||
|
||||
(ert-deftest etaf-performance-mode-uninstalls-all-advices ()
|
||||
"Disabling recording removes operation, stage, and after-load hooks."
|
||||
(etaf-performance-test--isolated
|
||||
(etaf-performance-mode 1)
|
||||
(let ((installed (copy-sequence etaf-performance--installed-advices)))
|
||||
(should installed)
|
||||
(dolist (entry installed)
|
||||
(should (advice-member-p (cdr entry) (car entry))))
|
||||
(etaf-performance-mode -1)
|
||||
(should-not etaf-performance--installed-advices)
|
||||
(should-not (memq #'etaf-performance--install-loaded-advices
|
||||
after-load-functions))
|
||||
(dolist (entry installed)
|
||||
(should-not (advice-member-p (cdr entry) (car entry)))))))
|
||||
|
||||
(provide 'etaf-performance-tests)
|
||||
|
||||
;;; etaf-performance-tests.el ends here
|
||||
@ -96,6 +96,9 @@
|
||||
(defvar etaf-test-slot-consumer-updated 0)
|
||||
(defvar etaf-test-slot-branch-left nil)
|
||||
(defvar etaf-test-slot-branch-right nil)
|
||||
(defvar etaf-test-detached-list-source nil)
|
||||
(defvar etaf-test-detached-theme-source nil)
|
||||
(defvar etaf-test-detached-row-renders 0)
|
||||
|
||||
(defun etaf-test--range-items ()
|
||||
"Return keyed text Views from `etaf-test-range-source'."
|
||||
@ -1043,6 +1046,122 @@
|
||||
(text (expr :value
|
||||
(format "theme=%s" (etaf-theme-value :color)))))))))
|
||||
|
||||
(defvar etaf-test-theme-property-render-count 0)
|
||||
(defvar etaf-test-theme-property-cell nil)
|
||||
|
||||
(defun etaf-test--face-value (face property)
|
||||
"Return PROPERTY from anonymous FACE contributions."
|
||||
(cond
|
||||
((symbolp face)
|
||||
(let* ((remap (assq face face-remapping-alist))
|
||||
(mapped
|
||||
(cl-some (lambda (spec)
|
||||
(and (listp spec) (keywordp (car-safe spec))
|
||||
(plist-get spec property)))
|
||||
(cdr remap)))
|
||||
(attribute
|
||||
(pcase property
|
||||
(:foreground :foreground)
|
||||
(:background :background)
|
||||
(_ property)))
|
||||
(value (face-attribute face attribute nil nil)))
|
||||
(or mapped
|
||||
(unless (memq value '(unspecified unspecified-fg unspecified-bg))
|
||||
value))))
|
||||
((and (listp face) (keywordp (car-safe face)))
|
||||
(plist-get face property))
|
||||
((listp face)
|
||||
(cl-some (lambda (entry)
|
||||
(etaf-test--face-value entry property))
|
||||
face))))
|
||||
|
||||
(etaf-define-component etaf-test-theme-property-effect ()
|
||||
"Update a Theme-bound Host property without rerunning this Component."
|
||||
:setup
|
||||
(let* ((dark (etaf-ref nil))
|
||||
(theme
|
||||
(etaf-computed
|
||||
(lambda ()
|
||||
(if (etaf-value dark)
|
||||
'(:color "#EEEEEE" :bgcolor "#111111")
|
||||
'(:color "#111111" :bgcolor "#FFFFFF"))))))
|
||||
(setq etaf-test-theme-property-cell dark)
|
||||
(etaf-theme-provide theme)
|
||||
(lambda ()
|
||||
(cl-incf etaf-test-theme-property-render-count)
|
||||
(etaf-view
|
||||
(text :ref 'theme-property-toggle
|
||||
:color (etaf-theme-token :color)
|
||||
:bgcolor (etaf-theme-token :bgcolor)
|
||||
:on-press
|
||||
(lambda ()
|
||||
(setf (etaf-value dark) (not (etaf-value dark))))
|
||||
"Theme property")))))
|
||||
|
||||
(etaf-define-component etaf-test-theme-atomic-child (&key label on-press)
|
||||
"Render Theme paint below a Component whose input also changes."
|
||||
:view
|
||||
(column :ref 'theme-atomic-panel
|
||||
:color (etaf-theme-token :color)
|
||||
:bgcolor (etaf-theme-token :bgcolor)
|
||||
(text :ref 'theme-atomic-toggle :on-press on-press
|
||||
(expr :value label))))
|
||||
|
||||
(etaf-define-component etaf-test-theme-atomic-owner ()
|
||||
"Change Component content and descendant Theme properties in one turn."
|
||||
:setup
|
||||
(let* ((dark (etaf-ref nil))
|
||||
(theme
|
||||
(etaf-computed
|
||||
(lambda ()
|
||||
(if (etaf-value dark)
|
||||
'(:color "#EEEEEE" :bgcolor "#111111")
|
||||
'(:color "#111111" :bgcolor "#FFFFFF")))))
|
||||
(toggle (lambda ()
|
||||
(setf (etaf-value dark) (not (etaf-value dark))))))
|
||||
(etaf-theme-provide theme)
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'column (list :ref 'theme-atomic-root
|
||||
:bgcolor (etaf-theme-token :bgcolor))
|
||||
(list
|
||||
(etaf--view-call
|
||||
'etaf-test-theme-atomic-child
|
||||
(list :label (if (etaf-value dark) "Dark" "Light")
|
||||
:on-press toggle)
|
||||
nil))))))
|
||||
|
||||
(etaf-define-component etaf-test-detached-theme-row (&key row-ref label)
|
||||
"Render one keyed Theme-bound row used by detached-subtree tests."
|
||||
:setup
|
||||
(lambda ()
|
||||
(cl-incf etaf-test-detached-row-renders)
|
||||
(etaf--view-call
|
||||
'row
|
||||
(list :ref (etaf-current-prop :row-ref)
|
||||
:color (etaf-theme-token :color))
|
||||
(list (etaf--view-call
|
||||
'text nil (list (etaf-current-prop :label)))))))
|
||||
|
||||
(etaf-define-component etaf-test-detached-theme-list ()
|
||||
"Render keyed Components below stable nested Host containers."
|
||||
:setup
|
||||
(progn
|
||||
(etaf-theme-provide etaf-test-detached-theme-source)
|
||||
(lambda ()
|
||||
(etaf--view-call
|
||||
'column (list :key 'shell)
|
||||
(list
|
||||
(etaf--view-call
|
||||
'column (list :key 'body)
|
||||
(mapcar
|
||||
(lambda (entry)
|
||||
(etaf--view-call
|
||||
'etaf-test-detached-theme-row
|
||||
(list :key (car entry) :row-ref (car entry) :label (cdr entry))
|
||||
nil))
|
||||
(etaf-value etaf-test-detached-list-source))))))))
|
||||
|
||||
(etaf-define-component etaf-test-event-batch-resource (&key resource fail)
|
||||
"Render synchronous Resource success and error state transitions."
|
||||
:setup
|
||||
@ -1385,6 +1504,165 @@
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-theme-token-resolves-nested-fallback-before-transform ()
|
||||
"Resolve semantic aliases once, then transform the final Theme value."
|
||||
(let ((token
|
||||
(etaf-theme-token
|
||||
:ui-border
|
||||
(etaf-theme-token :line "#AAAAAA")
|
||||
(lambda (color) (list (list 1) 'solid color)))))
|
||||
(should
|
||||
(equal '((1) solid "#202020")
|
||||
(etaf--theme-token-resolve-from-theme
|
||||
token '(:ui-border "#202020" :line "#101010"))))
|
||||
(should
|
||||
(equal '((1) solid "#101010")
|
||||
(etaf--theme-token-resolve-from-theme
|
||||
token '(:line "#101010"))))
|
||||
(should
|
||||
(equal '((1) solid "#AAAAAA")
|
||||
(etaf--theme-token-resolve-from-theme token nil)))))
|
||||
|
||||
(ert-deftest etaf-theme-token-updates-host-property-without-component-render ()
|
||||
"A reactive Theme token should publish one Host paint update directly."
|
||||
(let ((buffer-name " *etaf-theme-property-effect-test*")
|
||||
(etaf-test-theme-property-render-count 0)
|
||||
(etaf-test-theme-property-cell nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view (etaf-test-theme-property-effect)))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-generation runtime)))
|
||||
(should (= etaf-test-theme-property-render-count 1))
|
||||
(etaf-dispatch-event runtime 'theme-property-toggle 'press)
|
||||
(should (= etaf-test-theme-property-render-count 1))
|
||||
(should (= (etaf-runtime-generation runtime) (1+ generation)))
|
||||
(should (etaf-value etaf-test-theme-property-cell))
|
||||
(with-current-buffer buffer-name
|
||||
(let ((face (get-text-property (point-min) 'face)))
|
||||
(should (equal (etaf-test--face-value face :foreground)
|
||||
"#EEEEEE"))
|
||||
(should (equal (etaf-test--face-value face :background)
|
||||
"#111111"))))))
|
||||
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-theme-paint-slot-rolls-back-with-generation-failure ()
|
||||
"A failed generation promotion must restore the committed paint plane."
|
||||
(let ((buffer-name " *etaf-theme-paint-rollback-test*")
|
||||
(etaf-test-theme-property-cell nil))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view (etaf-test-theme-property-effect)))
|
||||
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
|
||||
(generation (etaf-runtime-generation runtime))
|
||||
(slot
|
||||
(plist-get
|
||||
(etaf-runtime-host-props-for
|
||||
runtime 'theme-property-toggle)
|
||||
:color)))
|
||||
(should (tp-paint-slot-p slot))
|
||||
(should (equal "#111111"
|
||||
(plist-get (tp-paint-slot-spec slot) :foreground)))
|
||||
(cl-letf (((symbol-function 'etaf--runtime-swap-generation)
|
||||
(lambda (&rest _)
|
||||
(error "injected generation promotion failure"))))
|
||||
(should-error
|
||||
(etaf-dispatch-event runtime 'theme-property-toggle 'press)))
|
||||
(should (= generation (etaf-runtime-generation runtime)))
|
||||
(should (equal "#111111"
|
||||
(plist-get (tp-paint-slot-spec slot) :foreground)))))
|
||||
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-theme-and-component-change-publish-one-final-artifact ()
|
||||
"Publish same-turn content and Theme changes from the final Generation."
|
||||
(let ((buffer-name " *etaf-theme-atomic-artifact-test*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view (etaf-test-theme-atomic-owner)))
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(cl-labels
|
||||
((ebox-host-node
|
||||
(host-ref)
|
||||
(let* ((buffer (get-buffer buffer-name))
|
||||
(state (ebox--buffer-render-state buffer))
|
||||
(node-id
|
||||
(gethash host-ref
|
||||
(plist-get state :host-ref-table))))
|
||||
(gethash node-id (plist-get state :node-table))))
|
||||
(background
|
||||
(value)
|
||||
(if (tp-paint-slot-p value)
|
||||
(plist-get (tp-paint-slot-spec value) :background)
|
||||
value)))
|
||||
(let ((slot
|
||||
(plist-get (ebox-host-node 'theme-atomic-panel)
|
||||
:bgcolor)))
|
||||
(should (equal "#FFFFFF" (background slot)))
|
||||
(etaf-dispatch-event runtime 'theme-atomic-toggle 'press)
|
||||
(let ((semantic
|
||||
(plist-get
|
||||
(etaf-runtime-host-props-for
|
||||
runtime 'theme-atomic-panel)
|
||||
:bgcolor))
|
||||
(backend
|
||||
(plist-get (ebox-host-node 'theme-atomic-panel)
|
||||
:bgcolor)))
|
||||
(should (eq slot semantic))
|
||||
(should (eq slot backend))
|
||||
(should (equal "#111111" (background slot))))
|
||||
(should (string-match-p
|
||||
"Dark" (etaf-test--buffer-text buffer-name)))))))
|
||||
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-runtime-detached-component-subtree-retires-host-effects ()
|
||||
"Retire unreachable Host contributions before a later Theme update."
|
||||
(let ((buffer-name " *etaf-detached-theme-list-test*")
|
||||
(etaf-test-detached-list-source
|
||||
(etaf-ref '((old-a . "A") (old-b . "B"))))
|
||||
(etaf-test-detached-theme-source
|
||||
(etaf-ref '(:color "#111111")))
|
||||
(etaf-test-detached-row-renders 0))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount buffer-name
|
||||
(etaf-view (etaf-test-detached-theme-list)))
|
||||
(let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(should (etaf-runtime-host-props-for runtime 'old-b))
|
||||
(setf (etaf-value etaf-test-detached-list-source)
|
||||
'((old-a . "A2") (new-c . "C")))
|
||||
(should-not (etaf-runtime-host-props-for runtime 'old-b))
|
||||
(should-not
|
||||
(gethash 'old-b
|
||||
(ebox--buffer-host-ref-table (get-buffer buffer-name))))
|
||||
(setq etaf-test-detached-row-renders 0)
|
||||
(setf (etaf-value etaf-test-detached-theme-source)
|
||||
'(:color "#222222"))
|
||||
(should (zerop etaf-test-detached-row-renders))
|
||||
(let ((color
|
||||
(plist-get
|
||||
(etaf-runtime-host-props-for runtime 'new-c)
|
||||
:color)))
|
||||
(should (tp-paint-slot-p color))
|
||||
(should
|
||||
(equal "#222222"
|
||||
(plist-get (tp-paint-slot-spec color) :foreground))))))
|
||||
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-theme-resolves-explicit-light-dark-palette ()
|
||||
"Resolve semantic palette pairs without coupling Theme to a renderer."
|
||||
(should
|
||||
@ -1494,6 +1772,24 @@
|
||||
(etaf-unmount runtime))
|
||||
(when-let ((buffer (get-buffer buffer-name))) (kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-theme-validation-snapshot-is-shared-across-contexts ()
|
||||
"Validate one immutable Theme value once for all inheriting Context frames."
|
||||
(let* ((theme (list :color "ink" :bgcolor "paper" :border "line"))
|
||||
(provider (etaf--context-create))
|
||||
(left (etaf--context-create :parent provider))
|
||||
(right (etaf--context-create :parent provider))
|
||||
(etaf--theme-value-cache
|
||||
(make-hash-table :test #'eq :weakness 'key))
|
||||
left-value right-value)
|
||||
(puthash 'theme theme (etaf-context-values provider))
|
||||
(let ((etaf--current-context left))
|
||||
(setq left-value (etaf-theme-defaults)))
|
||||
(let ((etaf--current-context right))
|
||||
(setq right-value (etaf-theme-defaults)))
|
||||
(should (eq left-value right-value))
|
||||
(should-not (eq left-value theme))
|
||||
(should (equal theme left-value))))
|
||||
|
||||
(ert-deftest etaf-context-provide-inject-follows-component-tree ()
|
||||
"Resolve the nearest Context and react to its provided ref."
|
||||
(let ((buffer-name " *etaf-context-test*"))
|
||||
@ -1741,9 +2037,9 @@ Event composition is a Runtime contract, not a UI-library helper contract."
|
||||
(with-temp-buffer
|
||||
(insert-file-contents file)
|
||||
(setq source (buffer-string)))
|
||||
;; Mounted non-root invalidations set only their effect queue. The sole
|
||||
;; setter is the Root effect route; mount construction's initial t is not
|
||||
;; a mounted invalidation.
|
||||
;; Mounted non-root invalidations set only their effect queue. Root-owned
|
||||
;; rebuilds are centralized behind one marker and are requested only by a
|
||||
;; Root effect route or by an explicit local-proof miss.
|
||||
(should (= 1 (let ((start 0) count)
|
||||
(while (string-match
|
||||
"(setf (etaf-runtime-root-dirty-p runtime) t)"
|
||||
@ -1751,6 +2047,13 @@ Event composition is a Runtime contract, not a UI-library helper contract."
|
||||
(setq count (1+ (or count 0))
|
||||
start (match-end 0)))
|
||||
count)))
|
||||
(should (= 2 (let ((start 0) count)
|
||||
(while (string-match
|
||||
"(etaf--runtime-mark-root-dirty runtime)"
|
||||
source start)
|
||||
(setq count (1+ (or count 0))
|
||||
start (match-end 0)))
|
||||
count)))
|
||||
(let* ((start (string-match
|
||||
"(defun etaf--runtime-component-overlay"
|
||||
source))
|
||||
@ -1788,6 +2091,60 @@ Event composition is a Runtime contract, not a UI-library helper contract."
|
||||
(should (etaf--runtime-record-effect-input-version
|
||||
runtime generation 3))))
|
||||
|
||||
(ert-deftest etaf-reactive-dispatch-fifos-append-in-constant-time-order ()
|
||||
"Keep source and Runtime dispatch order with explicit FIFO tails."
|
||||
(let ((etaf--dispatch-depth 1)
|
||||
(etaf--dispatch-source-queue nil)
|
||||
(etaf--dispatch-source-queue-tail nil)
|
||||
(etaf--dispatch-source-set (make-hash-table :test #'eq))
|
||||
(etaf--dispatch-runtime-queue nil)
|
||||
(etaf--dispatch-runtime-queue-tail nil)
|
||||
(etaf--dispatch-runtime-set (make-hash-table :test #'eq))
|
||||
(sources (cl-loop repeat 100 collect (etaf-ref nil))))
|
||||
(dolist (source sources)
|
||||
(etaf--dispatch-source source))
|
||||
(etaf--dispatch-source (car sources))
|
||||
(etaf-reactive-enqueue-runtime-flush 'first #'ignore)
|
||||
(etaf-reactive-enqueue-runtime-flush 'second #'ignore)
|
||||
(etaf-reactive-enqueue-runtime-flush 'first #'ignore)
|
||||
(should (equal sources etaf--dispatch-source-queue))
|
||||
(should (eq (car etaf--dispatch-source-queue-tail) (car (last sources))))
|
||||
(should (equal '(first second) etaf--dispatch-runtime-queue))
|
||||
(should (eq 'second (car etaf--dispatch-runtime-queue-tail)))))
|
||||
|
||||
(ert-deftest etaf-runtime-dirty-effect-fifo-and-priority-stay-stable ()
|
||||
"Append dirty effects in O(1) and sort each immutable effect only once."
|
||||
(let* ((runtime
|
||||
(etaf--runtime-create
|
||||
:dirty-effect-ids (make-hash-table :test #'eql)))
|
||||
(generation
|
||||
(etaf--generation-create
|
||||
:effect-map
|
||||
(etaf--pvec-put-many
|
||||
nil
|
||||
(list
|
||||
(cons 5 (etaf--generation-effect-create
|
||||
:effect-id 5 :kind 'component-render))
|
||||
(cons 2 (etaf--generation-effect-create
|
||||
:effect-id 2 :kind 'inline))
|
||||
(cons 3 (etaf--generation-effect-create
|
||||
:effect-id 3 :kind 'component-input))
|
||||
(cons 1 (etaf--generation-effect-create
|
||||
:effect-id 1 :kind 'root)))))))
|
||||
(dolist (effect-id '(5 2 3 1 2))
|
||||
(etaf--runtime-enqueue-effect runtime effect-id))
|
||||
(should (equal '(5 2 3 1)
|
||||
(etaf-runtime-dirty-effect-queue runtime)))
|
||||
(should (= 1 (car (etaf-runtime-dirty-effect-queue-tail runtime))))
|
||||
(should (equal '(1 3 2 5)
|
||||
(etaf--runtime-sort-dirty-effects
|
||||
generation (etaf-runtime-dirty-effect-queue runtime))))
|
||||
(let (popped)
|
||||
(while (etaf-runtime-dirty-effect-queue runtime)
|
||||
(push (etaf--runtime-pop-effect runtime) popped))
|
||||
(should (equal '(5 2 3 1) (nreverse popped)))
|
||||
(should-not (etaf-runtime-dirty-effect-queue-tail runtime)))))
|
||||
|
||||
(ert-deftest etaf-runtime-fixed-point-step-bound-stops-monotonic-cycle ()
|
||||
"Stop a cycle whose source version changes on every evaluation."
|
||||
(let* ((runtime (etaf--runtime-create :mount-epoch 78))
|
||||
@ -3931,7 +4288,7 @@ Event composition is a Runtime contract, not a UI-library helper contract."
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-runtime-context-provider-promotes-consumer-atomically ()
|
||||
"Promote Context provider/consumer frames only with their generation."
|
||||
"Promote provider and dependent Host property only with their generation."
|
||||
(let ((buffer-name " *etaf-generation-context-test*")
|
||||
(etaf-test-context-provider-source (etaf-ref "red")))
|
||||
(setq etaf-test-context-provider-renders 0
|
||||
@ -3946,7 +4303,7 @@ Event composition is a Runtime contract, not a UI-library helper contract."
|
||||
(old-generation (etaf-runtime-current-generation runtime)))
|
||||
(setf (etaf-value etaf-test-context-provider-source) "blue")
|
||||
(should (= 1 etaf-test-context-provider-renders))
|
||||
(should (= 1 etaf-test-context-consumer-renders))
|
||||
(should (zerop etaf-test-context-consumer-renders))
|
||||
(with-current-buffer buffer-name
|
||||
(should (equal '(:foreground "blue")
|
||||
(get-text-property 0 'face (buffer-string)))))
|
||||
@ -4047,6 +4404,65 @@ Event composition is a Runtime contract, not a UI-library helper contract."
|
||||
runtime)
|
||||
'stable))))
|
||||
|
||||
(ert-deftest etaf-contribution-index-compaction-preserves-effective-values ()
|
||||
"Flatten contribution deltas without changing values or tombstones."
|
||||
(let* ((base
|
||||
(etaf--contribution-index-create
|
||||
:handlers '((a . ((press . old))) (b . ((press . removed))))
|
||||
:host-props '((a :role button) (b :role button))
|
||||
:contexts '((10 . old-context) (20 . stable-context))
|
||||
:themes '((10 . old-theme) (20 . stable-theme))
|
||||
:behaviors '((10 . old-behavior) (20 . stable-behavior))
|
||||
:context-consumers '(((10 . theme) 1) ((20 . theme) 2))
|
||||
:lifecycle '((old . updated))))
|
||||
(delta
|
||||
(etaf--contribution-index-create
|
||||
:base base :depth 2
|
||||
:handlers '((a . ((press . new))))
|
||||
:host-props '((a :role checkbox))
|
||||
:contexts '((10 . new-context))
|
||||
:themes '((10 . new-theme))
|
||||
:behaviors '((10 . new-behavior))
|
||||
:context-consumers '(((10 . theme) 3))
|
||||
:lifecycle '((new . updated))
|
||||
:host-removals '(b)
|
||||
:semantic-removals '(30)))
|
||||
(compacted (etaf--contribution-index-compact delta)))
|
||||
(should-not (etaf--contribution-index-base compacted))
|
||||
(should (= 1 (etaf--contribution-index-depth compacted)))
|
||||
(dolist (slot '(handlers host-props contexts themes behaviors
|
||||
context-consumers lifecycle))
|
||||
(should (equal (etaf--contribution-index-entries delta slot)
|
||||
(etaf--contribution-index-entries compacted slot))))
|
||||
(let ((generation (etaf--generation-create :indexes compacted)))
|
||||
(should (equal '((press . new))
|
||||
(etaf--generation-index-lookup generation 'handlers 'a)))
|
||||
(should-not
|
||||
(etaf--generation-index-lookup generation 'handlers 'b)))))
|
||||
|
||||
(ert-deftest etaf-contribution-index-depth-stays-bounded ()
|
||||
"Periodically compact a long sequence of local contribution generations."
|
||||
(let ((etaf-generation-index-max-depth 4)
|
||||
(runtime
|
||||
(etaf--runtime-create
|
||||
:candidate-handlers (make-hash-table :test #'equal)
|
||||
:candidate-host-props (make-hash-table :test #'equal)
|
||||
:candidate-semantic-nodes (make-hash-table :test #'equal)
|
||||
:candidate-graph-nodes (make-hash-table :test #'eql)
|
||||
:candidate-behaviors (make-hash-table :test #'equal)
|
||||
:candidate-behavior-resource-keys (make-hash-table :test #'equal)))
|
||||
generation)
|
||||
(dotimes (index 20)
|
||||
(setq generation
|
||||
(etaf--generation-create
|
||||
:generation-id (1+ index)
|
||||
:indexes
|
||||
(etaf--runtime-build-contribution-indexes
|
||||
runtime generation nil)))
|
||||
(should (<= (etaf--contribution-index-depth
|
||||
(etaf-generation-indexes generation))
|
||||
etaf-generation-index-max-depth)))))
|
||||
|
||||
(ert-deftest etaf-context-edge-belongs-to-direct-range-effect ()
|
||||
"Invalidate the injecting Range effect, not its lexical Component effect."
|
||||
(let ((buffer-name " *etaf-context-range-owner-test*")
|
||||
@ -4372,4 +4788,30 @@ Event composition is a Runtime contract, not a UI-library helper contract."
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
(ert-deftest etaf-mount-accepts-final-initial-viewport ()
|
||||
"Publish the first generation at its final viewport without a rerender."
|
||||
(let ((buffer-name " *etaf-test-initial-viewport*"))
|
||||
(unwind-protect
|
||||
(progn
|
||||
(etaf-mount
|
||||
buffer-name
|
||||
(etaf-view
|
||||
(column :width '(viewport) :height '(viewport-height)
|
||||
(text "Viewport")))
|
||||
'(:viewport-width 640 :viewport-height 24))
|
||||
(let ((report
|
||||
(ebox-surface-update-buffer-viewport
|
||||
(get-buffer buffer-name) 640 24)))
|
||||
(should (eq (plist-get report :strategy) 'no-op)))
|
||||
(should-error
|
||||
(etaf-mount buffer-name (etaf-view (text "Invalid"))
|
||||
'(:unknown-option t)))
|
||||
(should-error
|
||||
(etaf-mount buffer-name (etaf-view (text "Invalid"))
|
||||
'(:viewport-width 0))))
|
||||
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
|
||||
(etaf-unmount runtime))
|
||||
(when-let ((buffer (get-buffer buffer-name)))
|
||||
(kill-buffer buffer)))))
|
||||
|
||||
;;; etaf-tests.el ends here
|
||||
|
||||
Loading…
Reference in New Issue
Block a user