diff --git a/.gitignore b/.gitignore index 3daa17c..33948d1 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ *.elc tests/*.elc +.etaf-build/ diff --git a/Makefile b/Makefile index 779f989..d430222 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,15 @@ EMACS ?= emacs LOAD_PATH = -L . -L ../etaf -L ../etaf-ui -L ../ebox -L ../ecss -L ../tp -L ../etaf-sqlite +EBOX_NATIVE_RELEASE_DIR = $(shell $(EMACS) -Q --batch $(LOAD_PATH) \ + --eval '(setq load-prefer-newer t)' -l ../ebox/ebox-native-reflow.el \ + --eval '(princ (expand-file-name (format "../ebox/native/target/%s/release/" (ebox-native-reflow--rust-target))))') ENTRY_EXAMPLES := $(wildcard examples/*.el) EXAMPLES := $(ENTRY_EXAMPLES) EXAMPLE_ELC := $(EXAMPLES:.el=.elc) +TEST_FILES := $(wildcard tests/*-tests.el) -.PHONY: all compile examples-read test perf check checkdoc load clean +.PHONY: all compile examples-read test perf perf-evaluator perf-regressions \ + perf-check check checkdoc load clean all: check @@ -24,7 +29,7 @@ compile: --eval '(dolist (file (quote ($(foreach file,$(ENTRY_EXAMPLES),"$(file)")))) (load-file file))' \ --eval '(dolist (file (quote ($(foreach file,$(EXAMPLES),"$(file)")))) (byte-compile-file file))' \ --eval '(byte-compile-file "etaf-playground.el")' \ - --eval '(byte-compile-file "tests/etaf-playground-tests.el")' + --eval '(dolist (file (quote ($(foreach file,$(TEST_FILES),"$(file)")))) (byte-compile-file file))' examples-read: compile $(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \ @@ -34,18 +39,40 @@ examples-read: compile test: examples-read $(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \ - -l tests/etaf-playground-tests.el -f ert-run-tests-batch-and-exit + $(foreach test,$(TEST_FILES),-l $(test)) -f ert-run-tests-batch-and-exit -perf: compile +perf: perf-evaluator + +perf-evaluator: compile + $(MAKE) -C ../ebox native-build EMACS="$(EMACS)" ECSS_DIR=../ecss TP_DIR=../tp + EBOX_NATIVE_REFLOW_MODULE_PATH="$(EBOX_NATIVE_RELEASE_DIR)" \ $(EMACS) -Q --batch $(LOAD_PATH) --eval '(setq load-prefer-newer t)' \ - -l scripts/benchmark-research-shelf.el + --eval '(setq ebox-native-reflow-module-path (getenv "EBOX_NATIVE_REFLOW_MODULE_PATH"))' \ + -l scripts/benchmark-research-shelf.el \ + -f etaf-performance-evaluator-batch + +# Run package regressions in dependency order. Keeping them in one recipe +# prevents parallel make from cleaning/recompiling a sibling while another +# package is loading its artifacts. +perf-regressions: + $(MAKE) -C ../ecss test EMACS="$(EMACS)" + $(MAKE) -C ../tp test EMACS="$(EMACS)" + $(MAKE) -C ../ebox test EMACS="$(EMACS)" ECSS_DIR=../ecss TP_DIR=../tp + $(MAKE) -C ../etaf test EMACS="$(EMACS)" + $(MAKE) -C ../etaf-ui test EMACS="$(EMACS)" + $(MAKE) -C ../etaf-sqlite test EMACS="$(EMACS)" + $(MAKE) test EMACS="$(EMACS)" + +perf-check: + $(MAKE) perf-regressions EMACS="$(EMACS)" + $(MAKE) perf-evaluator EMACS="$(EMACS)" load: compile $(EMACS) -Q --batch $(LOAD_PATH) --eval '(require (quote etaf-playground))' \ --eval '(princ "etaf-playground load OK\\n")' checkdoc: - $(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (list "etaf-playground.el" "tests/etaf-playground-tests.el") (directory-files-recursively "examples" "\\.el$$"))) (checkdoc-file file)))' + $(EMACS) -Q --batch --eval '(progn (require (quote checkdoc)) (dolist (file (append (list "etaf-playground.el" "scripts/benchmark-research-shelf.el") (directory-files-recursively "tests" "\\.el$$") (directory-files-recursively "examples" "\\.el$$"))) (checkdoc-file file)))' check: checkdoc test diff --git a/README.md b/README.md index 06795d4..2afe168 100644 --- a/README.md +++ b/README.md @@ -19,6 +19,13 @@ into the right-hand preview. Saving a source file also refreshes by default. `etaf-playground-register-example` is available when a companion needs a non-conventional root or feature name. +ETAF core provides the generic `M-x etaf-compile-app` and +`M-x etaf-app-compile-status` commands; see the [ETAF +documentation](../etaf/README.md) for the full contract. Playground does not +implement compilation. It registers discovered examples as ETAF Apps and adds +a `Compile App` shortcut plus status to the header line. Its default artifact +directory is `.etaf-build/`. + The low-level `etaf-playground-mount-example` API remains available for batch tests and consumers that only need a preview buffer. Business Components, database schemas, palettes, refs, and handlers stay in the example companion. diff --git a/README.zh-CN.md b/README.zh-CN.md index 47954e2..aa4b482 100644 --- a/README.zh-CN.md +++ b/README.zh-CN.md @@ -18,6 +18,11 @@ ETAF Playground 是通用的应用构建工作区:左侧编辑同一个应用 也会刷新。若 root 或 feature 不遵循命名约定,可在 companion 中调用 `etaf-playground-register-example` 注册覆盖。 +ETAF core 提供通用 App 预编译命令 `M-x etaf-compile-app` 和状态命令 +`M-x etaf-app-compile-status`;完整合同见 [ETAF 文档](../etaf/README.zh-CN.md)。 +Playground 不实现编译,只把发现的 example 注册成 ETAF App,并在 header line +显示 `Compile App` 快捷按钮和当前状态。默认产物目录是 `.etaf-build/`。 + `etaf-playground-mount-example` 仍作为低层 batch/consumer API 保留。业务 Component、数据库 schema、palette、refs 和 handlers 都应该留在 example companion 中;Playground 只提供 source/preview 会话、读文件、窗口切换与生命周期。 diff --git a/etaf-playground.el b/etaf-playground.el index 1c9479d..2c9475a 100644 --- a/etaf-playground.el +++ b/etaf-playground.el @@ -50,6 +50,13 @@ :type 'directory :group 'etaf-playground) +(defcustom etaf-playground-artifact-directory + (expand-file-name ".etaf-build" + (file-name-directory (or load-file-name buffer-file-name))) + "Directory containing manually compiled `.etafc' App artifacts." + :type 'directory + :group 'etaf-playground) + (defcustom etaf-playground-source-extensions '(".etaf" ".el" ".ecss") "Source extensions shown in a Playground workspace, in tab order." @@ -201,6 +208,15 @@ the root factory." (specs (mapcar (lambda (name) (etaf-playground--example-spec name directory)) (sort (delete-dups names) #'string<)))) + (dolist (spec specs) + (etaf-register-app + (plist-get spec :pair) + :source (plist-get spec :el-file) + :static (plist-get spec :etaf-file) + :style (plist-get spec :ecss-file) + :artifact + (expand-file-name (concat (plist-get spec :pair) ".etafc") + etaf-playground-artifact-directory))) (setq etaf-playground-scenario-manifest specs etaf-playground-example-names (mapcar (lambda (spec) (plist-get spec :pair)) @@ -436,6 +452,11 @@ One-argument roots remain supported for small existing examples." (wrong-number-of-arguments (funcall root static-form))))) +(defun etaf-playground--compiled-artifact (spec session) + "Return SPEC's validated compiled artifact, unless SESSION owns sources." + (unless session + (etaf-app-load-artifact-or-warn (plist-get spec :pair)))) + (defun etaf-playground-read-pair (name &optional session) "Load NAME's companion and return its root View value. @@ -443,8 +464,13 @@ When SESSION is supplied, its current source buffers are authoritative. The `.etaf' and `.ecss' files are read as inert data. The `.el' companion is the only file evaluated by the framework." (let* ((spec (etaf-playground-scenario name)) - (static-form (etaf-playground-read-static name session)) - (ecss-form (etaf-playground-read-ecss name session))) + (artifact (etaf-playground--compiled-artifact spec session)) + (static-form (if artifact + (plist-get artifact :static-form) + (etaf-playground-read-static name session))) + (ecss-form (if artifact + (or (plist-get artifact :style-form) '(styles)) + (etaf-playground-read-ecss name session)))) (etaf-playground--load-companion spec session) (etaf-playground--call-root (etaf-playground--root-factory spec) @@ -466,11 +492,13 @@ only file evaluated by the framework." (setq-local truncate-lines nil)) buffer) -(defun etaf-playground-mount-example (buffer-name name &optional session) +(defun etaf-playground-mount-example + (buffer-name name &optional session mount-options) "Mount example NAME into BUFFER-NAME and return its buffer. This is the low-level consumer API. `etaf-playground-open-example' adds the -source editors and side-by-side workspace around it." +source editors and side-by-side workspace around it. MOUNT-OPTIONS is +forwarded to `etaf-mount', including an optional initial viewport." (let ((buffer (get-buffer-create buffer-name))) (when-let ((runtime (etaf-runtime-for-buffer buffer))) (with-current-buffer buffer @@ -480,7 +508,8 @@ source editors and side-by-side workspace around it." ;; buffer-local display API cannot accidentally style the source editor ;; which invoked `etaf-playground-refresh'. (with-current-buffer buffer - (etaf-mount buffer (etaf-playground-read-pair name session))) + (etaf-mount buffer (etaf-playground-read-pair name session) + mount-options)) (with-current-buffer buffer (setq-local etaf-playground-current-example name)) buffer)) @@ -630,8 +659,71 @@ the preview instead of destroying the source workspace." 'help-echo (format "Switch to %s" extension))))) etaf-playground-source-extensions " | ") + " " + (let* ((name (etaf-playground-session-name session)) + (dirty + (cl-some (lambda (entry) + (and (buffer-live-p (cdr entry)) + (buffer-modified-p (cdr entry)))) + (etaf-playground-session-source-buffers session))) + (status (unless dirty (etaf-app-compile-status name))) + (state (if dirty 'dirty (plist-get status :status)))) + (concat + (make-text-button + " Compile App " nil + 'action #'etaf-playground-compile-current-app + 'follow-link t + 'button-data name + 'help-echo "Save sources and compile this App with ETAF") + " | " + (make-text-button + (format " %s " state) nil + 'action #'etaf-playground-show-current-app-compile-status + 'follow-link t + 'button-data name + 'help-echo "Show the generic ETAF App compilation status"))) " C-c C-c refresh")))) +(defun etaf-playground--button-app-name (button) + "Return App name carried by header BUTTON." + (or (and (stringp button) + (get-text-property 0 'button-data button)) + (and (fboundp 'button-get) + (ignore-errors (button-get button 'button-data))) + etaf-playground-current-example + (and (etaf-playground-session-p etaf-playground-session) + (etaf-playground-session-name etaf-playground-session)))) + +;;;###autoload +(defun etaf-playground-compile-current-app (&optional button) + "Compile BUTTON's App, or the current App, through generic ETAF APIs." + (interactive) + (let* ((name (etaf-playground--button-app-name button)) + (session (and name (gethash name etaf-playground--sessions)))) + (unless name (user-error "No ETAF App is associated with this buffer")) + (when (and session + (cl-some (lambda (entry) + (and (buffer-live-p (cdr entry)) + (buffer-modified-p (cdr entry)))) + (etaf-playground-session-source-buffers session))) + (user-error "Save %s source buffers before compiling the App" name)) + (let ((status (etaf-compile-app name))) + (when session (etaf-playground--refresh-source-headers session)) + (message "Compiled ETAF App %s: %s" + name (plist-get status :file)) + status))) + +;;;###autoload +(defun etaf-playground-show-current-app-compile-status (&optional button) + "Show generic compile status for BUTTON's App or the current App." + (interactive) + (let* ((name (etaf-playground--button-app-name button)) + (status (and name (etaf-app-compile-status name)))) + (unless status (user-error "No ETAF App is associated with this buffer")) + (message "ETAF App %s: %s (%s)" name + (plist-get status :status) (plist-get status :file)) + status)) + (defun etaf-playground--activate-source-tab (button) "Activate source tab BUTTON from a header-line text button." (let ((extension @@ -893,7 +985,8 @@ batch tests and callers which do not need editor windows." nil t))) (if buffer-name (etaf-playground--mount-for-display buffer-name name) - (let ((session (etaf-playground--make-session name))) + (let ((_artifact-status (etaf-app-load-artifact-or-warn name)) + (session (etaf-playground--make-session name))) (etaf-playground--show-session session) (etaf-playground-refresh session) (etaf-playground--refresh-source-headers session) diff --git a/examples/research-shelf.el b/examples/research-shelf.el index 484e3b2..2794824 100644 --- a/examples/research-shelf.el +++ b/examples/research-shelf.el @@ -247,18 +247,22 @@ user's prior local additions cannot collide with the generated dataset." "Return stable identity for a reading ROW." (plist-get row :id)) -(defun etaf-research-shelf--create-model () - "Create the Research Shelf model inside the owning Component Scope." +(defun etaf-research-shelf--create-model (&optional initial-result) + "Create the Research Shelf model, optionally from INITIAL-RESULT." (let* ((database (etaf-research-shelf--ensure-database)) (controller (etaf-data-controller (etaf-sqlite-source database) :page-size etaf-research-shelf-page-size + :initial-result initial-result :auto-load nil :item-key #'etaf-research-shelf--item-id :name 'etaf-research-shelf)) (filter (etaf-ref 'all :name 'research-shelf-filter)) (dark (etaf-ref nil :name 'research-shelf-dark-theme)) - (toast (etaf-ref "Ready to read." :name 'research-shelf-toast))) + (toast (etaf-ref (if initial-result + "✓ SQLite shelf ready" + "Ready to read.") + :name 'research-shelf-toast))) (list :database database :database-file etaf-research-shelf-database-file :controller controller :filter filter :dark dark :toast toast))) @@ -407,10 +411,6 @@ user's prior local additions cannot collide with the generated dataset." (:key :kind :label "Kind" :width 7)) "Compact DataGrid columns for the Research Shelf list.") -(defun etaf-research-shelf--theme-value (key &optional default) - "Return inherited Research Shelf Theme token KEY or DEFAULT." - (etaf-theme-value key default)) - (defun etaf-research-shelf--static-child (form tag) "Return the first TAG child from inert FORM." (etaf-playground-static-child form tag)) @@ -462,16 +462,15 @@ user's prior local additions cannot collide with the generated dataset." (defun etaf-research-shelf--filter-view (model) "Return the filter rail for MODEL and inherited filter Context." - (let ((theme (etaf-theme-defaults))) - (etaf-view - (column :class "research-shelf-filter-rail" :width 'stretch :min-width 0 - :flex-grow 1 :flex-shrink 1 :flex-basis '(220) - :padding '(1 1) - :border (plist-get theme :line) - :color (plist-get theme :ink) - :bgcolor (plist-get theme :panel) + (etaf-view + (column :class "research-shelf-filter-rail" :width 'stretch :min-width 0 + :flex-grow 1 :flex-shrink 1 :flex-basis '(220) + :padding '(1 1) + :border (etaf-theme-token :line) + :color (etaf-theme-token :ink) + :bgcolor (etaf-theme-token :panel) (label :text "Library" :face 'bold) - (label :text "VIEWS" :color (plist-get theme :muted)) + (label :text "VIEWS" :color (etaf-theme-token :muted)) (etaf-research-shelf-filter-button :filter-key 'all :fallback "All" :ref 'research-shelf-filter-all) (etaf-research-shelf-filter-button @@ -486,32 +485,31 @@ user's prior local additions cannot collide with the generated dataset." :filter-key 'starred :fallback "★ Starred" :ref 'research-shelf-filter-starred) (spacer :height 1) - (label :text "STORAGE" :color (plist-get theme :muted)) + (label :text "STORAGE" :color (etaf-theme-token :muted)) (label :text (file-name-nondirectory (plist-get model :database-file))) (button :label "↻ Reload library" :ref 'research-shelf-reload :variant 'ghost :on-press (lambda () (etaf-dispatch 'etaf-research-shelf-reload - model))))))) + model)))))) (defun etaf-research-shelf--reading-list-view (model form) "Return the reading list for MODEL and static MAIN FORM." - (let ((controller (etaf-research-shelf--controller model)) - (theme (etaf-theme-defaults))) + (let ((controller (etaf-research-shelf--controller model))) (etaf-view (column :class "research-shelf-list" :width 'stretch :min-width 0 :flex-grow 4 :flex-shrink 1 :flex-basis '(620) :padding '(1 2) - :border (plist-get theme :line) - :bgcolor (plist-get theme :panel) + :border (etaf-theme-token :line) + :bgcolor (etaf-theme-token :panel) (flex :width 'stretch :flex-wrap 'wrap :align-items 'center :gap '(1 (8)) (column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0 (label :text (etaf-research-shelf--static-value form :title "Reading queue") :face 'bold) (label :text (format "%d items · SQLite-backed" (or (etaf-value (etaf-data-total controller)) 0)) - :color (plist-get theme :muted))) + :color (etaf-theme-token :muted))) (number-input :label "Rows" :value (etaf-value (etaf-data-page-size controller)) :ref 'research-shelf-page-size :min 1 :max 100 @@ -530,10 +528,6 @@ user's prior local additions cannot collide with the generated dataset." :row-ref (lambda (row) (intern (format "research-shelf-row-%s" (etaf-research-shelf--item-id row)))) - :row-selected-p - (lambda (row) - (etaf-data-selected-p controller - (etaf-research-shelf--item-id row))) :on-row-press (lambda (row) (etaf-data-select-one controller @@ -543,26 +537,25 @@ user's prior local additions cannot collide with the generated dataset." (etaf-pagination :controller controller :previous-ref 'research-shelf-page-previous :next-ref 'research-shelf-page-next - :color (plist-get theme :ink)))))) + :color (etaf-theme-token :ink)))))) (defun etaf-research-shelf--detail-view (model form) "Return the selected record inspector for MODEL and static FORM." - (let ((theme (etaf-theme-defaults))) - (etaf-view + (etaf-view (column :class "research-shelf-detail" :width 'stretch :min-width 0 :flex-grow 2 :flex-shrink 1 :flex-basis '(340) :padding '(2 2) - :border (plist-get theme :line) - :bgcolor (plist-get theme :panel) + :border (etaf-theme-token :line) + :bgcolor (etaf-theme-token :panel) (label :text (etaf-research-shelf--static-value form :title "Selected item") - :color (plist-get theme :accent)) + :color (etaf-theme-token :accent)) (text :face 'bold (expr :value (if-let ((row (etaf-research-shelf--selected model))) (plist-get row :title) "Choose a record"))) - (text :color (plist-get theme :muted) + (text :color (etaf-theme-token :muted) (expr :value (if-let ((row (etaf-research-shelf--selected model))) (format "%s · %s" (plist-get row :author) @@ -581,7 +574,7 @@ user's prior local additions cannot collide with the generated dataset." (or (plist-get row :progress) 0) (plist-get row :priority)) "Progress — · Priority —"))) - (text :color (plist-get theme :accent) + (text :color (etaf-theme-token :accent) (expr :value (let* ((row (etaf-research-shelf--selected model)) (progress (or (and row (plist-get row :progress)) 0)) @@ -589,13 +582,13 @@ user's prior local additions cannot collide with the generated dataset." (format "%s %s" (make-string filled ?█) (make-string (- 10 filled) ?░))))) (spacer :height 1) - (text :color (plist-get theme :muted) + (text :color (etaf-theme-token :muted) (expr :value (if-let ((row (etaf-research-shelf--selected model))) (concat "“" (or (plist-get row :note) "No note yet.") "”") "Your notes and actions will appear here."))) (spacer :height 1) - (etaf-research-shelf-detail-actions))))) + (etaf-research-shelf-detail-actions)))) (etaf-define-component etaf-research-shelf-detail-actions () "Render selected-record actions from the inherited Research Shelf model." @@ -649,11 +642,13 @@ user's prior local additions cannot collide with the generated dataset." (form (etaf-inject 'research-shelf-detail nil t))) (lambda () (etaf-research-shelf--detail-view model form)))) -(etaf-define-component etaf-research-shelf-shell (&key static-form) +(etaf-define-component etaf-research-shelf-shell + (&key static-form initial-result) "Compose the Research Shelf app and provide its model/theme Context." :setup (let* ((static-form (etaf-current-prop :static-form)) - (model (etaf-research-shelf--create-model)) + (initial-result (etaf-current-prop :initial-result)) + (model (etaf-research-shelf--create-model initial-result)) (theme (etaf-computed (lambda () (etaf-research-shelf--theme-defaults model)) @@ -663,41 +658,43 @@ user's prior local additions cannot collide with the generated dataset." (main (etaf-research-shelf--static-child static-form 'main)) (library (etaf-research-shelf--static-child main 'library)) (detail (etaf-research-shelf--static-child main 'detail))) - (etaf-on-mounted - (lambda () - (etaf-research-shelf--load model "✓ SQLite shelf ready"))) + (unless initial-result + (etaf-on-mounted + (lambda () + (etaf-research-shelf--load model "✓ SQLite shelf ready")))) (etaf-theme-provide theme) (etaf-provide 'research-shelf-model model) (etaf-provide 'research-shelf-filters filters) (etaf-provide 'research-shelf-library library) (etaf-provide 'research-shelf-detail detail) (lambda () - (let ((dark (etaf-value (plist-get model :dark)))) - (etaf-view - (column :class "research-shelf-shell" :width '(viewport) - :height '(viewport-height) - :color (etaf-research-shelf--theme-value :ink) - :bgcolor (etaf-research-shelf--theme-value :paper) + (etaf-view + (column :class "research-shelf-shell" :width '(viewport) + :height '(viewport-height) + :color (etaf-theme-token :ink) + :bgcolor (etaf-theme-token :paper) (flex :class "research-shelf-header" :width 'stretch :min-width 0 :flex-wrap 'wrap :align-items 'center :gap '(1 (10)) (column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0 (label :text (etaf-research-shelf--static-value header :eyebrow "Research Shelf") - :color (etaf-research-shelf--theme-value :accent)) + :color (etaf-theme-token :accent)) (label :text (etaf-research-shelf--static-value static-form :title "Research Shelf") :face 'bold) (label :text (etaf-research-shelf--static-value static-form :subtitle "A quiet place for unfinished ideas") - :color (etaf-research-shelf--theme-value :muted))) + :color (etaf-theme-token :muted))) (column :width 'max-content :min-width 0 :flex-grow 0 :flex-shrink 0 (checkbox :label "Dark" :ref 'research-shelf-theme-toggle - :checked dark + :checked (plist-get model :dark) :on-change (lambda (value) (setf (etaf-value (plist-get model :dark)) value) (setf (etaf-value (plist-get model :toast)) - (if value "Dark theme" "Light theme")))))) + (if value + "Dark theme" + "Light theme")))))) (flex :class "research-shelf-workspace" :width 'stretch :flex-wrap 'wrap :align-items 'stretch :align-content 'start :gap '(1 (6)) @@ -707,10 +704,10 @@ user's prior local additions cannot collide with the generated dataset." (flex :class "research-shelf-footer" :width 'stretch :flex-wrap 'wrap :gap '(1 (8)) (column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0 - (label :text (or (etaf-value (plist-get model :toast)) "Ready"))) + (label :text (plist-get model :toast))) (label :text (file-name-nondirectory (plist-get model :database-file)) - :color (etaf-research-shelf--theme-value :muted))))))))) + :color (etaf-theme-token :muted)))))))) ;;; --------------------------------------------------------------------------- ;;; ROOT / PLAYGROUND REGISTRATION @@ -721,9 +718,17 @@ user's prior local additions cannot collide with the generated dataset." (unless (eq (car static-form) 'research-shelf-shell) (error "Unsupported Research Shelf static root: %S" static-form)) (etaf-component-set-styles 'etaf-research-shelf-shell ecss-form) - (lambda () - (etaf-view - (research-shelf-shell :static-form static-form)))) + (let* ((database (etaf-research-shelf--ensure-database)) + (initial-result + (condition-case nil + (etaf-data-source-load-page + (etaf-sqlite-source database) + nil 1 etaf-research-shelf-page-size) + (error nil)))) + (lambda () + (etaf-view + (research-shelf-shell + :static-form static-form :initial-result initial-result))))) (etaf-playground-register-example "research-shelf" diff --git a/scripts/benchmark-research-shelf.el b/scripts/benchmark-research-shelf.el index 4615111..cc7688f 100644 --- a/scripts/benchmark-research-shelf.el +++ b/scripts/benchmark-research-shelf.el @@ -1,93 +1,557 @@ -;;; benchmark-research-shelf.el --- Research Shelf latency gate -*- lexical-binding: t; -*- +;;; benchmark-research-shelf.el --- Cross-package ETAF latency gate -*- lexical-binding: t; -*- ;;; Commentary: -;; Reproducible fullscreen-equivalent warm interaction benchmark. The process -;; exits nonzero when the declared p50/max budgets are exceeded. +;; Generic evaluator primitives exercised with Research Shelf as one fixed, +;; deterministic, real cross-package workload. Trace assertions consume only +;; public `etaf-performance' records; application concepts stay out of the +;; recorder itself. ;;; Code: (require 'cl-lib) +(require 'seq) (require 'etaf-playground) +(require 'etaf-performance) -(defconst etaf-research-shelf-benchmark-row-p50-budget-ms 100.0) -(defconst etaf-research-shelf-benchmark-row-max-budget-ms 250.0) -(defconst etaf-research-shelf-benchmark-theme-p50-budget-ms 250.0) -(defconst etaf-research-shelf-benchmark-theme-max-budget-ms 500.0) +(defvar etaf-research-shelf-database-file) +(defvar etaf-research-shelf-fixture-size) +(defvar etaf-research-shelf-page-size) +(declare-function etaf-research-shelf--ensure-database + "../examples/research-shelf") -(defun etaf-research-shelf-benchmark--percentile (samples percentile) - "Return PERCENTILE from numeric SAMPLES using nearest rank." +(defconst etaf-performance-evaluator-sample-count 20) +(defconst etaf-performance-evaluator-latency-budget-ms 50.0) +(defconst etaf-performance-evaluator-scenario-budgets-ms + '(("theme-toggle" :p95 90.0 :max 110.0)) + "User-approved scenario budgets overriding the default latency budget.") +(defconst etaf-performance-evaluator-overhead-budget-ms 2.0) +(defconst etaf-performance-evaluator-fixture-size 256) +(defconst etaf-performance-evaluator-page-size 12) +(defconst etaf-performance-evaluator-viewport-width 1413) +(defconst etaf-performance-evaluator-viewport-height 62) + +(defun etaf-performance-evaluator--percentile (samples percentile) + "Return nearest-rank PERCENTILE from non-empty numeric SAMPLES." + (unless samples (error "Cannot summarize an empty performance sample")) (let* ((ordered (sort (copy-sequence samples) #'<)) - (index (min (1- (length ordered)) - (floor (* percentile (length ordered)))))) - (nth index ordered))) + (rank (max 1 (ceiling (* percentile (length ordered)))))) + (nth (1- rank) ordered))) -(defun etaf-research-shelf-benchmark--measure (runtime refs runs) - "Measure warm press events through RUNTIME while cycling REFS. -The number of measured events is `RUNS'." - (cl-loop for index below runs - for ref = (nth (% index (length refs)) refs) - collect - (let ((started (float-time))) - (etaf-dispatch-event runtime ref 'press) - (* 1000.0 (- (float-time) started))))) +(defun etaf-performance-evaluator--statistics (samples) + "Return min, p50, p95, and max statistics for SAMPLES." + (list :count (length samples) :min (apply #'min samples) + :p50 (etaf-performance-evaluator--percentile samples 0.50) + :p95 (etaf-performance-evaluator--percentile samples 0.95) + :max (apply #'max samples))) -(defun etaf-research-shelf-benchmark--summary (label samples) - "Print and return LABEL summary for SAMPLES." - (let ((p50 (etaf-research-shelf-benchmark--percentile samples 0.5)) - (maximum (apply #'max samples))) - (princ (format "%s p50=%.3fms max=%.3fms samples=%S\n" - label p50 maximum samples)) - (list :p50 p50 :max maximum))) +(defun etaf-performance-evaluator--print-statistics (label statistics) + "Print LABEL and STATISTICS in stable machine-readable form." + (princ (format (concat "perf-scenario=%s samples=%d min=%.3fms " + "p50=%.3fms p95=%.3fms max=%.3fms\n") + label (plist-get statistics :count) + (plist-get statistics :min) (plist-get statistics :p50) + (plist-get statistics :p95) (plist-get statistics :max)))) -(defun etaf-research-shelf-benchmark-run () - "Run the Research Shelf evaluator and return non-nil on success." +(defun etaf-performance-evaluator--timed-call (function) + "Call FUNCTION and return `(ELAPSED-MS . RESULT)'." + (let ((started (float-time)) result) + (setq result (funcall function)) + (cons (* 1000.0 (- (float-time) started)) result))) + +(cl-defun etaf-performance-evaluator--measure + (label action verify &key setup cleanup + (samples etaf-performance-evaluator-sample-count)) + "Warm, then measure ACTION under LABEL and verify every result. +ACTION, VERIFY, SETUP, and CLEANUP receive an index. Warmup uses -1 and is +never included in SAMPLES. ACTION's result is passed to VERIFY and CLEANUP." + (let (durations) + (when setup (funcall setup -1)) + ;; Batch Emacs does not run the interactive 0.2s deferred-GC timer between + ;; synthetic inputs. Settle that idle work before, never inside, samples. + (garbage-collect) + (let ((result (funcall action -1))) + (funcall verify result -1) + (when cleanup (funcall cleanup result -1))) + (dotimes (index samples) + (when setup (funcall setup index)) + (garbage-collect) + (pcase-let* ((`(,elapsed . ,result) + (etaf-performance-evaluator--timed-call + (lambda () (funcall action index))))) + (funcall verify result index) + (when cleanup (funcall cleanup result index)) + (push elapsed durations))) + (let ((statistics + (etaf-performance-evaluator--statistics (nreverse durations)))) + (etaf-performance-evaluator--print-statistics label statistics) + (cons label statistics)))) + +(defun etaf-performance-evaluator--text (buffer) + "Return BUFFER's rendered text without properties." + (with-current-buffer buffer + (substring-no-properties (buffer-string)))) + +(defun etaf-performance-evaluator--surface-invariant (runtime buffer label) + "Assert committed RUNTIME/publication invariants in BUFFER for LABEL." + (unless (and (buffer-live-p (get-buffer buffer)) + (eq runtime (etaf-runtime-for-buffer buffer))) + (error "%s: mounted Runtime/buffer invariant failed" label)) + (let ((generation (etaf-runtime-current-generation runtime))) + (unless (and (etaf-generation-p generation) + (integerp (etaf-runtime-generation runtime)) + (> (etaf-runtime-generation runtime) 0) + (integerp (etaf-generation-root-semantic-id generation)) + (etaf-runtime-handler-entries runtime) + (etaf-runtime-host-props-entries runtime)) + (error "%s: committed generation/publication structure is incomplete" + label))) + (unless (> (buffer-size (get-buffer buffer)) 0) + (error "%s: publication produced an empty visible buffer" label)) + t) + +(defun etaf-performance-evaluator--load-workload () + "Load the deterministic integration workload companion." (let* ((source (expand-file-name "examples/research-shelf.el" - default-directory)) - (compiled (concat (file-name-sans-extension source) ".elc")) - (file (if (and (file-readable-p compiled) - (not (file-newer-than-file-p source compiled))) - compiled - source))) - (load file nil nil t)) - (let ((database (make-temp-file "etaf-research-shelf-perf-" nil ".sqlite")) - (buffer " *etaf-research-shelf-perf*")) + default-directory)) + (compiled (concat (file-name-sans-extension source) ".elc"))) + (load (if (and (file-readable-p compiled) + (not (file-newer-than-file-p source compiled))) + compiled source) + nil nil t))) + +(defun etaf-performance-evaluator--prepare-database (database) + "Prepare DATABASE outside the measured mount operation." + (let ((etaf-research-shelf-database-file database) + (etaf-research-shelf-fixture-size + etaf-performance-evaluator-fixture-size) + (etaf-research-shelf-page-size etaf-performance-evaluator-page-size)) + (etaf-research-shelf--ensure-database)) + (unless (and (file-exists-p database) + (> (file-attribute-size (file-attributes database)) 0)) + (error "Prepared SQLite fixture was not created: %s" database))) + +(defun etaf-performance-evaluator--verify-compiled-runtime (status) + "Require compiled App STATUS to include its native runtime accelerator." + (unless (and (eq (plist-get status :status) 'current) + (eq (plist-get status :runtime-accelerator) 'ready)) + (error "Performance evaluator requires the compiled native runtime: %S" + status)) + (princ "perf-runtime-accelerator=ready\n") + status) + +(defun etaf-performance-evaluator--verify-environment (environment) + "Require ENVIRONMENT to be suitable for an absolute latency gate." + (let* ((power (plist-get environment :power-state)) + (source (or (plist-get power :source) 'unknown)) + (low-power (or (plist-get power :low-power-mode) 'unknown)) + (load (plist-get environment :load-average))) + (princ (format "perf-environment power-source=%s low-power-mode=%s load=%S\n" + source low-power load)) + (when (eq low-power 'on) + (error (concat "Performance evaluator requires low-power mode off; " + "current source=%s") + source))) + environment) + +(defun etaf-performance-evaluator--mount (buffer) + "Mount the fixed workload in BUFFER at the fixed viewport." + (etaf-playground-mount-example + buffer "research-shelf" nil + (list :viewport-width etaf-performance-evaluator-viewport-width + :viewport-height etaf-performance-evaluator-viewport-height)) + (etaf-runtime-for-buffer buffer)) + +(defun etaf-performance-evaluator--close-buffer (buffer) + "Unmount and close BUFFER when it is live." + (when (get-buffer buffer) (etaf-playground-close buffer))) + +(defun etaf-performance-evaluator--visible-match-p (buffer regexp) + "Return non-nil when BUFFER's visible text matches REGEXP." + (string-match-p regexp (etaf-performance-evaluator--text buffer))) + +(defun etaf-performance-evaluator--trace-categories (records) + "Return unique stage categories present in performance RECORDS." + (let (categories) + (dolist (operation records) + (dolist (stage (etaf-performance-operation-stages operation)) + (cl-pushnew (etaf-performance-stage-category stage) categories))) + categories)) + +(defun etaf-performance-evaluator--verify-trace-records (records) + "Verify generic cross-package RECORDS are successful and complete." + (unless records (error "Trace-on run produced no etaf-performance records")) + (dolist (operation records) + (unless (eq (etaf-performance-operation-status operation) 'success) + (error "Trace operation %s (%s) finished with status %s" + (etaf-performance-operation-id operation) + (etaf-performance-operation-label operation) + (etaf-performance-operation-status operation))) + (dolist (stage (etaf-performance-operation-stages operation)) + (unless (eq (etaf-performance-stage-status stage) 'success) + (error "Trace stage %s/%s finished with status %s" + (etaf-performance-stage-category stage) + (etaf-performance-stage-function stage) + (etaf-performance-stage-status stage))))) + (let ((categories (etaf-performance-evaluator--trace-categories records))) + (dolist (required '(runtime ebox tp sqlite)) + (unless (memq required categories) + (error "Trace records lack required %s stage; present=%S" + required categories))) + (setq categories + (sort categories (lambda (left right) + (string< (symbol-name left) + (symbol-name right))))) + (princ (format "perf-trace records=%d categories=%S status=success\n" + (length records) categories)))) + +(defun etaf-performance-evaluator--print-slowest-records (records) + "Print the two slowest generic operation RECORDS per kind/label." + (let ((groups (make-hash-table :test #'equal)) selected) + (dolist (operation records) + (let ((key (cons (etaf-performance-operation-kind operation) + (etaf-performance-operation-label operation)))) + (puthash key (cons operation (gethash key groups)) groups))) + (maphash + (lambda (_key operations) + (setq selected + (append + (seq-take + (sort operations + (lambda (left right) + (> (etaf-performance-operation-elapsed left) + (etaf-performance-operation-elapsed right)))) + 2) + selected))) + groups) + (dolist + (operation + (sort selected + (lambda (left right) + (> (etaf-performance-operation-elapsed left) + (etaf-performance-operation-elapsed right))))) + (let* ((gc-count + (- (etaf-performance-operation-gc-count-after operation) + (etaf-performance-operation-gc-count-before operation))) + (gc-ms + (* 1000.0 + (- (etaf-performance-operation-gc-elapsed-after operation) + (etaf-performance-operation-gc-elapsed-before operation)))) + (stages + (mapcar + (lambda (entry) + (cons (plist-get entry :category) + (plist-get entry :exclusive-ms))) + (etaf-performance-operation-stage-summary operation))) + (ebox + (plist-get (etaf-performance-operation-metadata operation) :ebox))) + (princ + (format (concat "perf-slowest id=%d kind=%s label=%S elapsed=%.3fms " + "gc=%d/%.3fms stages=%S ebox=%S\n") + (etaf-performance-operation-id operation) + (etaf-performance-operation-kind operation) + (etaf-performance-operation-label operation) + (etaf-performance-operation-elapsed operation) + gc-count gc-ms stages ebox)))))) + +(defun etaf-performance-evaluator--select-ref (runtime ref) + "Select workload row REF through RUNTIME's public event path." + (etaf-dispatch-event runtime ref 'press) + ref) + +(defun etaf-performance-evaluator--measure-overhead (runtime buffer) + "Measure trace overhead for RUNTIME with visible state in BUFFER." + (let (signed-deltas absolute-deltas traced-samples plain-samples) + (dotimes (index etaf-performance-evaluator-sample-count) + (let ((order (if (zerop (% index 2)) '(nil t) '(t nil))) plain traced) + (dolist (trace-p order) + (etaf-performance-mode (if trace-p 1 -1)) + ;; Restore equivalent state outside the timed region; AB/BA order + ;; cancels drift without retries or skipped real work. + (garbage-collect) + (etaf-focus runtime 'research-shelf-row-1) + (when trace-p (etaf-performance-clear)) + (let ((before (etaf-focused-host-ref runtime)) + (elapsed + (let ((gc-cons-threshold most-positive-fixnum) + (gc-cons-percentage 1.0)) + (car (etaf-performance-evaluator--timed-call + (lambda () (etaf-focus-next runtime))))))) + (unless (and (buffer-live-p (get-buffer buffer)) + (not (equal before + (etaf-focused-host-ref runtime)))) + (error "Trace-overhead: equivalent focus-navigation work failed")) + (if trace-p + (progn (setq traced elapsed) + (unless (etaf-performance-records) + (error "Trace-overhead: trace-on sample recorded nothing"))) + (setq plain elapsed)))) + (push plain plain-samples) + (push traced traced-samples) + (push (- traced plain) signed-deltas) + (push (abs (- traced plain)) absolute-deltas))) + (etaf-performance-mode -1) + (let ((signed + (etaf-performance-evaluator--statistics (nreverse signed-deltas))) + (jitter + (etaf-performance-evaluator--statistics + (nreverse absolute-deltas)))) + (princ (format (concat "perf-trace-overhead pairs=%d off-p50=%.3fms " + "on-p50=%.3fms signed-p50=%.3fms " + "signed-p95=%.3fms jitter-p50=%.3fms " + "budget=%.3fms\n") + etaf-performance-evaluator-sample-count + (etaf-performance-evaluator--percentile plain-samples .5) + (etaf-performance-evaluator--percentile traced-samples .5) + (plist-get signed :p50) (plist-get signed :p95) + (plist-get jitter :p50) + etaf-performance-evaluator-overhead-budget-ms)) + (list :signed signed :jitter jitter)))) + +(defun etaf-performance-evaluator--latency-failures (results) + "Return hard latency budget failures from scenario RESULTS." + (cl-loop for (label . statistics) in results append + (let* ((scenario + (cdr (assoc label + etaf-performance-evaluator-scenario-budgets-ms))) + (p95-budget + (or (plist-get scenario :p95) + etaf-performance-evaluator-latency-budget-ms)) + (max-budget + (or (plist-get scenario :max) + etaf-performance-evaluator-latency-budget-ms)) + failures) + (when (> (plist-get statistics :p95) + p95-budget) + (push (format "%s p95 %.3fms > %.3fms" label + (plist-get statistics :p95) + p95-budget) + failures)) + (when (> (plist-get statistics :max) + max-budget) + (push (format "%s max %.3fms > %.3fms" label + (plist-get statistics :max) + max-budget) + failures)) + (nreverse failures)))) + +(defun etaf-performance-evaluator-run () + "Run the fixed cross-package evaluator and return non-nil on success." + (etaf-performance-evaluator--load-workload) + (etaf-performance-evaluator--verify-environment + (etaf-performance-environment-data)) + (let* ((database (make-temp-file "etaf-perf-fixture-" nil ".sqlite")) + (buffer " *etaf-cross-package-perf*") + (mount-buffer " *etaf-cross-package-mount-perf*") + (etaf-research-shelf-database-file database) + (etaf-research-shelf-fixture-size + etaf-performance-evaluator-fixture-size) + (etaf-research-shelf-page-size etaf-performance-evaluator-page-size) + (etaf-performance-max-records 10000) + results runtime trace-records overhead failures) (unwind-protect - (let ((etaf-research-shelf-database-file database)) - (ignore etaf-research-shelf-database-file) - (etaf-playground-open buffer) - (ebox-surface-update-buffer-viewport (get-buffer buffer) 1413 62) - (let ((runtime (etaf-runtime-for-buffer buffer))) - ;; Prewarm both structural states before collecting evidence. - (etaf-dispatch-event runtime 'research-shelf-row-1 'press) - (etaf-dispatch-event runtime 'research-shelf-row-2 'press) - (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press) - (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press) - (let* ((row (etaf-research-shelf-benchmark--summary - "row-selection" - (etaf-research-shelf-benchmark--measure - runtime '(research-shelf-row-1 research-shelf-row-2) 8))) - (theme (etaf-research-shelf-benchmark--summary - "theme-toggle" - (etaf-research-shelf-benchmark--measure - runtime '(research-shelf-theme-toggle) 8))) - (pass - (and (<= (plist-get row :p50) - etaf-research-shelf-benchmark-row-p50-budget-ms) - (<= (plist-get row :max) - etaf-research-shelf-benchmark-row-max-budget-ms) - (<= (plist-get theme :p50) - etaf-research-shelf-benchmark-theme-p50-budget-ms) - (<= (plist-get theme :max) - etaf-research-shelf-benchmark-theme-max-budget-ms)))) - (princ (format "research-shelf-perf %s\n" - (if pass "PASS" "FAIL"))) - (unless pass - (error "Research Shelf interaction latency budget exceeded")) - t))) - (when (get-buffer buffer) - (etaf-playground-close buffer)) - (when (file-exists-p database) - (delete-file database))))) + (progn + (etaf-performance-evaluator--prepare-database database) + ;; The maintained product path is a manually compiled App. Compile + ;; and activate its optional native runtime before latency samples; + ;; compiler command latency remains visible through the generic + ;; compiler operation when users profile that command itself. + (etaf-performance-evaluator--verify-compiled-runtime + (etaf-compile-app "research-shelf")) + ;; Latency samples measure the product path without observer work. + ;; Trace behavior and overhead have separate, explicit gates below. + (etaf-performance-mode -1) + (etaf-performance-clear) + (push + (etaf-performance-evaluator--measure + "prepared-database-mount" + (lambda (_index) + (etaf-performance-evaluator--mount mount-buffer)) + (lambda (mounted _index) + (etaf-performance-evaluator--surface-invariant + mounted mount-buffer "prepared-database-mount") + (let ((text (etaf-performance-evaluator--text mount-buffer))) + (unless (and (string-match-p "256 items · SQLite-backed" text) + (string-match-p "Page 1 / 22" text)) + (error "Prepared-database-mount: fixture/page invariant failed")))) + :cleanup (lambda (_result _index) + (etaf-performance-evaluator--close-buffer mount-buffer))) + results) + (setq runtime (etaf-performance-evaluator--mount buffer)) + (etaf-performance-evaluator--surface-invariant runtime buffer "setup") -(etaf-research-shelf-benchmark-run) + (push + (etaf-performance-evaluator--measure + "row-selection" + (lambda (index) + (let* ((ref (if (zerop (% (1+ index) 2)) + 'research-shelf-row-1 'research-shelf-row-2)) + (before (etaf-runtime-generation runtime))) + (etaf-performance-evaluator--select-ref runtime ref) + (list ref before (etaf-runtime-generation runtime)))) + (lambda (result _index) + (pcase-let ((`(,ref ,before ,after) result)) + (unless (and (>= after before) + (string-match-p + "selected" + (or (plist-get + (etaf-runtime-host-props-for runtime ref) + :class) ""))) + (error "Row-selection: selection/generation invariant failed"))) + (etaf-performance-evaluator--surface-invariant + runtime buffer "row-selection"))) + results) + (push + (etaf-performance-evaluator--measure + "theme-toggle" + (lambda (_index) + (let ((before (etaf-runtime-generation runtime))) + (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press) + (list before (etaf-runtime-generation runtime)))) + (lambda (result _index) + (unless (and (> (cadr result) (car result)) + (etaf-performance-evaluator--visible-match-p + buffer "\\(Dark theme\\|Light theme\\)")) + (error "Theme-toggle: theme/generation invariant failed")) + (etaf-performance-evaluator--surface-invariant + runtime buffer "theme-toggle"))) + results) + + (push + (etaf-performance-evaluator--measure + "filter-query" + (lambda (index) + (let* ((reading-p (zerop (% (1+ index) 2))) + (ref (if reading-p 'research-shelf-filter-reading + 'research-shelf-filter-all)) + (before (etaf-runtime-generation runtime))) + (etaf-dispatch-event runtime ref 'press) + (list reading-p before (etaf-runtime-generation runtime)))) + (lambda (result _index) + (unless (and (> (nth 2 result) (nth 1 result)) + (etaf-performance-evaluator--visible-match-p + buffer (if (car result) "Showing Reading" + "Showing All"))) + (error "Filter-query: query/generation invariant failed")) + (etaf-performance-evaluator--surface-invariant + runtime buffer "filter-query"))) + results) + + (etaf-dispatch-event runtime 'research-shelf-filter-all 'press) + (push + (etaf-performance-evaluator--measure + "pagination" + (lambda (_index) + (let* ((on-first (etaf-performance-evaluator--visible-match-p + buffer "Page 1 / 22")) + (ref (if on-first 'research-shelf-page-next + 'research-shelf-page-previous)) + (before (etaf-runtime-generation runtime))) + (etaf-dispatch-event runtime ref 'press) + (list (if on-first 2 1) before + (etaf-runtime-generation runtime)))) + (lambda (result _index) + (unless (and (> (nth 2 result) (nth 1 result)) + (etaf-performance-evaluator--visible-match-p + buffer (format "Page %d / 22" (car result)))) + (error "Pagination: page/generation invariant failed")) + (etaf-performance-evaluator--surface-invariant + runtime buffer "pagination"))) + results) + + (unless (etaf-performance-evaluator--visible-match-p + buffer "Page 1 / 22") + (etaf-dispatch-event runtime 'research-shelf-page-previous 'press)) + (let ((refs '(research-shelf-row-2 research-shelf-row-4 + research-shelf-row-5 research-shelf-row-8 + research-shelf-row-9 research-shelf-row-10))) + (push + (etaf-performance-evaluator--measure + "progress-mutation" + (lambda (_index) + (let ((before (etaf-runtime-generation runtime))) + (etaf-dispatch-event runtime 'research-shelf-progress 'press) + (list before (etaf-runtime-generation runtime)))) + (lambda (result _index) + (unless (and (> (cadr result) (car result)) + (etaf-performance-evaluator--visible-match-p + buffer "Progress saved")) + (error "Progress-mutation: persistence invariant failed")) + (etaf-performance-evaluator--surface-invariant + runtime buffer "progress-mutation")) + :setup (lambda (index) + (etaf-performance-evaluator--select-ref + runtime (nth (% (1+ index) (length refs)) refs)))) + results)) + + (push + (etaf-performance-evaluator--measure + "focus-navigation" + (lambda (_index) + (let ((before (etaf-focused-host-ref runtime))) + (etaf-focus-next runtime) + (list before (etaf-focused-host-ref runtime)))) + (lambda (result _index) + (unless (and (cadr result) + (not (equal (car result) (cadr result)))) + (error "Focus-navigation: focus did not advance")) + (etaf-performance-evaluator--surface-invariant + runtime buffer "focus-navigation"))) + results) + + ;; Capture one representative cross-package trace after the latency + ;; samples. This validates coverage without folding observer work + ;; into the product latency distribution. + (etaf-performance-mode 1) + (etaf-performance-clear) + (etaf-performance-evaluator--select-ref + runtime 'research-shelf-row-1) + (etaf-performance-evaluator--select-ref + runtime 'research-shelf-row-2) + (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press) + (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press) + (etaf-dispatch-event runtime 'research-shelf-filter-reading 'press) + (etaf-dispatch-event runtime 'research-shelf-filter-all 'press) + (etaf-dispatch-event runtime 'research-shelf-page-next 'press) + (etaf-dispatch-event runtime 'research-shelf-page-previous 'press) + (etaf-performance-evaluator--select-ref + runtime 'research-shelf-row-2) + (etaf-dispatch-event runtime 'research-shelf-progress 'press) + (etaf-focus-next runtime) + (setq results (nreverse results) + trace-records (etaf-performance-records)) + (etaf-performance-evaluator--verify-trace-records trace-records) + (etaf-performance-evaluator--print-slowest-records trace-records) + (etaf-performance-mode -1) + (setq overhead + (etaf-performance-evaluator--measure-overhead runtime buffer) + failures (etaf-performance-evaluator--latency-failures results)) + (when (> (abs (plist-get (plist-get overhead :signed) :p50)) + etaf-performance-evaluator-overhead-budget-ms) + (push (format "trace signed |p50| %.3fms > %.3fms" + (abs (plist-get (plist-get overhead :signed) :p50)) + etaf-performance-evaluator-overhead-budget-ms) + failures)) + (if failures + (let ((failure-count (length failures))) + (princ "etaf-cross-package-perf FAIL\n") + (dolist (failure (reverse failures)) + (princ (format "PERF-GATE-FAIL: %s\n" failure))) + (error "Cross-package performance gate failed (%d conditions)" + failure-count)) + (princ "etaf-cross-package-perf PASS\n") t)) + (etaf-performance-mode -1) + (etaf-performance-evaluator--close-buffer mount-buffer) + (etaf-performance-evaluator--close-buffer buffer) + (when (file-exists-p database) (delete-file database))))) + +(defun etaf-performance-evaluator-batch () + "Batch entry point for the cross-package performance evaluator." + (condition-case condition + (progn (etaf-performance-evaluator-run) (kill-emacs 0)) + (error + (princ (format "PERF-EVALUATOR-ERROR: %s\n" + (error-message-string condition))) + (kill-emacs 1)))) + +(provide 'benchmark-research-shelf) ;;; benchmark-research-shelf.el ends here diff --git a/tests/benchmark-research-shelf-tests.el b/tests/benchmark-research-shelf-tests.el new file mode 100644 index 0000000..4c342cf --- /dev/null +++ b/tests/benchmark-research-shelf-tests.el @@ -0,0 +1,93 @@ +;;; benchmark-research-shelf-tests.el --- Performance evaluator tests -*- lexical-binding: t; -*- + +;;; Code: +(require 'ert) +(load-file (expand-file-name "scripts/benchmark-research-shelf.el" + default-directory)) + +(declare-function etaf-performance-evaluator--percentile + "../scripts/benchmark-research-shelf") +(declare-function etaf-performance-evaluator--measure + "../scripts/benchmark-research-shelf") +(declare-function etaf-performance-evaluator--latency-failures + "../scripts/benchmark-research-shelf") +(declare-function etaf-performance-evaluator--verify-compiled-runtime + "../scripts/benchmark-research-shelf") +(declare-function etaf-performance-evaluator--verify-environment + "../scripts/benchmark-research-shelf") + +(ert-deftest etaf-performance-evaluator-uses-nearest-rank-percentiles () + "Return nearest-rank values for evaluator percentiles." + (let ((samples (number-sequence 1 20))) + (should (= 10 (etaf-performance-evaluator--percentile samples 0.50))) + (should (= 19 (etaf-performance-evaluator--percentile samples 0.95))))) + +(ert-deftest etaf-performance-evaluator-warms-before-exact-sample-count () + "Execute one unmeasured warmup before the requested measured samples." + (let (actions verifications) + (let ((result + (etaf-performance-evaluator--measure + "unit-workload" + (lambda (index) (push index actions) index) + (lambda (value index) + (should (= value index)) + (push index verifications)) + :samples 3))) + (should (equal '(-1 0 1 2) (nreverse actions))) + (should (equal '(-1 0 1 2) (nreverse verifications))) + (should (= 3 (plist-get (cdr result) :count)))))) + +(ert-deftest etaf-performance-evaluator-reports-both-hard-budget-failures () + "Report p95 and max independently when both exceed the hard budget." + (let ((failures + (etaf-performance-evaluator--latency-failures + '((slow :count 20 :min 1.0 :p50 2.0 :p95 51.0 :max 60.0))))) + (should (= 2 (length failures))) + (should (string-match-p "slow p95" (car failures))) + (should (string-match-p "slow max" (cadr failures))))) + +(ert-deftest etaf-performance-evaluator-uses-approved-theme-budget () + "Accept the approved 90ms Theme budget without relaxing other scenarios." + (should-not + (etaf-performance-evaluator--latency-failures + '(("theme-toggle" :count 20 :min 80.0 :p50 84.0 + :p95 86.0 :max 99.0)))) + (should (= 2 + (length + (etaf-performance-evaluator--latency-failures + '(("theme-toggle" :count 20 :min 80.0 :p50 84.0 + :p95 91.0 :max 111.0))))))) + +(ert-deftest etaf-performance-evaluator-requires-native-compiled-runtime () + "Never report fallback-renderer latency as the optimized product gate." + (cl-letf (((symbol-function 'princ) #'ignore)) + (should + (equal + (etaf-performance-evaluator--verify-compiled-runtime + '(:status current :runtime-accelerator ready)) + '(:status current :runtime-accelerator ready)))) + (should-error + (etaf-performance-evaluator--verify-compiled-runtime + '(:status current :runtime-accelerator unavailable))) + (let ((makefile (with-temp-buffer + (insert-file-contents "Makefile") + (buffer-string)))) + (should (string-match-p "native-build" makefile)) + (should (string-match-p "EBOX_NATIVE_REFLOW_MODULE_PATH" makefile)))) + +(ert-deftest etaf-performance-evaluator-rejects-low-power-baselines () + "Absolute latency gates fail closed when macOS throttles the CPU." + (cl-letf (((symbol-function 'princ) #'ignore)) + (should + (equal + '(:power-state (:source ac :low-power-mode off) :load-average (1.0)) + (etaf-performance-evaluator--verify-environment + '(:power-state (:source ac :low-power-mode off) + :load-average (1.0))))) + (should-error + (etaf-performance-evaluator--verify-environment + '(:power-state (:source battery :low-power-mode on) + :load-average (1.0)))))) + +(provide 'benchmark-research-shelf-tests) +;;; benchmark-research-shelf-tests.el ends here diff --git a/tests/etaf-playground-tests.el b/tests/etaf-playground-tests.el index a0f0c68..fa88599 100644 --- a/tests/etaf-playground-tests.el +++ b/tests/etaf-playground-tests.el @@ -113,6 +113,23 @@ database and mounts a test buffer before running BODY." "$(MAKE) -C ../etaf-sqlite compile")) (should (string-match-p (regexp-quote dependency) makefile))))) +(ert-deftest etaf-playground-registers-app-for-interactive-compilation () + "Discovered examples use the generic ETAF App compile/status commands." + (let ((directory (make-temp-file "etaf-playground-artifacts-" t))) + (unwind-protect + (let ((etaf-playground-artifact-directory directory)) + (etaf-playground-refresh-examples) + (should (eq (plist-get (etaf-app-compile-status "research-shelf") + :status) + 'missing)) + (let ((compiled (etaf-compile-app "research-shelf"))) + (should (eq (plist-get compiled :status) 'current)) + (should (> (plist-get compiled :blueprints) 0)) + (should (file-readable-p (plist-get compiled :file))))) + (etaf-playground-refresh-examples) + (when (file-directory-p directory) + (delete-directory directory t))))) + (ert-deftest etaf-playground-static-reader-is-inert-and-strict () "Read pair structure as inert data and reject executable AST nodes." (let* ((form (etaf-playground-read-static "research-shelf")) @@ -195,7 +212,8 @@ database and mounts a test buffer before running BODY." (etaf-playground-session-preview-buffer etaf-playground-session)))) (let* ((header (etaf-playground--source-header)) - (position (string-match " EL" header))) + (position (string-match " EL" header)) + (compile-position (string-match "Compile App" header))) (should position) (should (get-text-property position 'button header)) (should (equal ".el" @@ -204,7 +222,12 @@ database and mounts a test buffer before running BODY." (propertize " EL " 'etaf-playground-extension ".el")) (should (equal ".el" (etaf-playground-session-active-extension - etaf-playground-session)))))))) + etaf-playground-session))) + (should compile-position) + (should (get-text-property compile-position 'button header)) + (should (equal "research-shelf" + (get-text-property compile-position + 'button-data header)))))))) (ert-deftest etaf-playground-direct-etaf-c-c-c-opens-workspace () "The source render command opens a workspace for a directly opened `.etaf'." @@ -278,6 +301,23 @@ database and mounts a test buffer before running BODY." (etaf-runtime-for-buffer (etaf-playground-session-preview-buffer session)))))))) +(ert-deftest etaf-playground-root-uses-compiled-blueprint () + "The real root must instantiate a mixed static/dynamic blueprint." + (etaf-playground-test--with-app (buffer database) + (etaf-compiler-clear-cache) + (let* ((before (etaf-compiler-statistics)) + (instantiations (plist-get before :instantiations)) + (fallbacks (plist-get before :fallbacks)) + (cache-entries (plist-get before :static-cache-entries))) + (etaf-playground-open buffer) + (let* ((after (etaf-compiler-statistics)) + (blueprint (plist-get after :last-blueprint))) + (should (> (plist-get after :instantiations) instantiations)) + (should (= (plist-get after :fallbacks) fallbacks)) + (should (> (plist-get after :static-cache-entries) cache-entries)) + (should (> (plist-get blueprint :dynamic-nodes) 0)) + (should (> (plist-get blueprint :hole-count) 0)))))) + (ert-deftest etaf-playground-pair-mounts-sqlite-backed-surface () "Mounting the pair initializes SQLite and renders the real app shell." (etaf-playground-test--with-app (buffer database) @@ -448,14 +488,32 @@ database and mounts a test buffer before running BODY." (etaf-playground-open buffer) (let ((runtime (etaf-runtime-for-buffer buffer))) (etaf-dispatch-event runtime 'research-shelf-row-1 'press) - (dotimes (_ 4) - (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press)) + (let (dark-output light-output) + (dotimes (cycle 2) + (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press) + (with-current-buffer buffer + (let ((output (buffer-substring (point-min) (point-max)))) + (if (zerop cycle) + (setq dark-output output) + (should (equal-including-properties output dark-output))))) + (etaf-dispatch-event runtime 'research-shelf-theme-toggle 'press) + (with-current-buffer buffer + (let ((output (buffer-substring (point-min) (point-max)))) + (if (zerop cycle) + (setq light-output output) + (should (equal-including-properties output light-output))))))) (should (string-match-p "The Shape of Tools" (etaf-playground-test--text buffer))) (should (or (string-match-p "☑ Dark" (etaf-playground-test--text buffer)) (string-match-p "☐ Dark" - (etaf-playground-test--text buffer))))) + (etaf-playground-test--text buffer)))) + ;; Theme-only Host reconstruction must preserve nested Component + ;; backend anchors for the next unrelated interaction. + (let ((generation (etaf-runtime-generation runtime))) + (etaf-dispatch-event runtime 'research-shelf-filter-reading 'press) + (should (= (etaf-runtime-generation runtime) (1+ generation))) + (should (eq runtime (etaf-runtime-for-buffer buffer))))) (etaf-playground-reset buffer) (should (etaf-runtime-p (etaf-runtime-for-buffer buffer)))) (should-not (get-buffer " *etaf-research-shelf-test*")))