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

perf: retain keyed UI component state

Browse Source
This commit is contained in:
Kinneyzhang 2026-08-25 17:16:57 +08:00
parent 7ee8d65679
commit e85a4079d7
2 changed files with 511 additions and 162 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

462
etaf-ui.el
View File

@ -24,6 +24,7 @@
(declare-function etaf-data-total "etaf-data" (controller)) (declare-function etaf-data-total "etaf-data" (controller))
(declare-function etaf-data-previous-page "etaf-data" (controller)) (declare-function etaf-data-previous-page "etaf-data" (controller))
(declare-function etaf-data-next-page "etaf-data" (controller)) (declare-function etaf-data-next-page "etaf-data" (controller))
(declare-function etaf-data-selected-ref "etaf-data" (controller identity))
(declare-function etaf-theme-defaults "etaf-context" (&optional default)) (declare-function etaf-theme-defaults "etaf-context" (&optional default))
(declare-function text "etaf-view" (&rest arguments)) (declare-function text "etaf-view" (&rest arguments))
(declare-function row "etaf-view" (&rest arguments)) (declare-function row "etaf-view" (&rest arguments))
@ -125,16 +126,37 @@ REQUESTED is nil, return the complete catalog token map."
) )
result)) result))
(defun etaf-ui-theme-tokens (&rest requested)
"Return deferred semantic Theme tokens for REQUESTED UI keys.
Catalog defaults and legacy aliases are encoded as nested token fallbacks, so
Host lowering can update paint properties without making the current
Component render depend on the Theme source."
(let ((keys (or requested
(cl-loop for (key _spec) on etaf-ui--default-theme-palette
by #'cddr collect key)))
result)
(dolist (key keys result)
(let* ((default (plist-get etaf-ui--default-theme-palette key))
(alias (cadr (assq key etaf-ui--legacy-theme-aliases)))
(fallback (if alias (etaf-theme-token alias default) default)))
(setq result
(plist-put result key (etaf-theme-token key fallback)))))))
(defun etaf-ui--theme-border (value) (defun etaf-ui--theme-border (value)
"Return Ebox border VALUE, preserving complete caller-owned specs. "Return Ebox border VALUE, preserving complete caller-owned specs.
Semantic Theme border tokens conventionally contain a color string. The Semantic Theme border tokens conventionally contain a color string. The
catalog turns a hex color into its one-cell border shape; an existing border catalog turns a hex color into its one-cell border shape; an existing border
plist or a legacy caller-owned string remains untouched for compatibility." plist or a legacy caller-owned string remains untouched for compatibility."
(if (and (stringp value) (cond
((etaf-theme-token-p value)
(etaf-theme-token (nth 1 value) (nth 2 value)
#'etaf-ui--theme-border))
((and (stringp value)
(string-match-p "\\`#[[:xdigit:]]+\\'" value)) (string-match-p "\\`#[[:xdigit:]]+\\'" value))
(list (list 1) 'solid value) (list (list 1) 'solid value))
value)) (t value)))
(defun etaf-ui--class-value (base state custom) (defun etaf-ui--class-value (base state custom)
"Return BASE and STATE classes with optional CUSTOM classes." "Return BASE and STATE classes with optional CUSTOM classes."
@ -148,6 +170,12 @@ plist or a legacy caller-owned string remains untouched for compatibility."
(append (list base state) custom)) (append (list base state) custom))
" "))) " ")))
(defun etaf-ui--reactive-value (value)
"Return VALUE, reading it when it is an ETAF reactive source."
(if (or (etaf-ref-p value) (etaf-computed-p value))
(etaf-value value)
value))
(defun etaf-ui--interactive-surface-properties (label disabled) (defun etaf-ui--interactive-surface-properties (label disabled)
"Return shared text properties for an interactive LABEL surface. "Return shared text properties for an interactive LABEL surface.
DISABLED selects a non-pointer help description instead of an activation DISABLED selects a non-pointer help description instead of an activation
@ -175,7 +203,7 @@ the optional text properties and keep the semantic role/event contract."
((eq variant 'secondary) :ui-button-secondary-border) ((eq variant 'secondary) :ui-button-secondary-border)
((eq variant 'ghost) :ui-button-ghost-border) ((eq variant 'ghost) :ui-button-ghost-border)
(t :ui-button-primary-border))) (t :ui-button-primary-border)))
(theme (etaf-ui-theme-values fg bg border))) (theme (etaf-ui-theme-tokens fg bg border)))
(list :color (plist-get theme fg) (list :color (plist-get theme fg)
:bgcolor (plist-get theme bg) :bgcolor (plist-get theme bg)
:border (etaf-ui--theme-border (plist-get theme border)) :border (etaf-ui--theme-border (plist-get theme border))
@ -291,22 +319,32 @@ too small; the original ROW remains intact for selection and callbacks."
collect (etaf-ui--grid-header-cell collect (etaf-ui--grid-header-cell
column (cdr tail))))))) column (cdr tail)))))))
(defun etaf-ui--grid-cell (row column gap-p) (defun etaf-ui--grid-cell (row column gap-p host-ref)
"Return one data cell View for ROW and COLUMN, using GAP-P for air." "Return one data cell View for ROW and COLUMN using HOST-REF and GAP-P."
(etaf-view (etaf-view
(text :width (etaf-ui--grid-track-width column gap-p) (text :ref host-ref :width (etaf-ui--grid-track-width column gap-p)
(expr :value (etaf-ui--grid-display-value row column))))) (expr :value (etaf-ui--grid-display-value row column)))))
(defun etaf-ui--grid-cells (row columns) (defun etaf-ui--grid-cells (row columns cell-refs)
"Return data cell Views for ROW and COLUMNS." "Return data cell Views for ROW and COLUMNS using stable CELL-REFS."
(cl-loop for column in columns (cl-loop for column in columns
for tail on columns for tail on columns
collect (etaf-ui--grid-cell row column (cdr tail)))) for index from 0
collect
(etaf-ui--grid-cell
row column (cdr tail)
(or (gethash index cell-refs)
(puthash index (gensym "etaf-data-grid-cell-")
cell-refs)))))
(defun etaf-ui--grid-selected-p (row key selected-key row-selected-p) (defun etaf-ui--grid-selected-p
"Return whether ROW with KEY matches SELECTED-KEY or ROW-SELECTED-P." (row key selected-key row-selected-p selected-ref)
"Return whether ROW with KEY is selected.
ROW-SELECTED-P and SELECTED-KEY preserve custom controlled selection;
SELECTED-REF supplies the controller-backed keyed default."
(or (and row-selected-p (funcall row-selected-p row)) (or (and row-selected-p (funcall row-selected-p row))
(and selected-key (equal key selected-key)))) (and selected-key (equal key selected-key))
(and selected-ref (etaf-value selected-ref))))
(defun etaf-ui--grid-row-action (cache key row callback) (defun etaf-ui--grid-row-action (cache key row callback)
"Return CACHE's stable row action for KEY, refreshing ROW and CALLBACK." "Return CACHE's stable row action for KEY, refreshing ROW and CALLBACK."
@ -324,18 +362,19 @@ too small; the original ROW remains intact for selection and callbacks."
(aref entry 2))) (aref entry 2)))
(defun etaf-ui--grid-row (defun etaf-ui--grid-row
(row columns row-key row-ref on-row-press selected-key row-selected-p (row key columns row-ref on-row-press selected-key row-selected-p
row-actions theme) selected-ref row-actions theme internal-row-ref cell-refs)
"Return a View row for ROW and COLUMNS using THEME and the DataGrid contract. "Return a View row for ROW and COLUMNS using THEME and the DataGrid contract.
ROW-KEY returns identity; ROW-REF returns the interactive reference; KEY is ROW's stable identity; ROW-REF returns the interactive reference;
ON-ROW-PRESS, SELECTED-KEY, and ROW-SELECTED-P control state. ROW-ACTIONS ON-ROW-PRESS, SELECTED-KEY, ROW-SELECTED-P, and SELECTED-REF control state.
owns stable keyed callbacks across Range reevaluation." ROW-ACTIONS owns stable keyed callbacks across body reevaluation."
(let* ((key (funcall row-key row)) (let* ((interactive-p (not (null on-row-press)))
(interactive-p (not (null on-row-press))) (selected-p
(selected-p (etaf-ui--grid-selected-p (lambda ()
row key selected-key row-selected-p)) (etaf-ui--grid-selected-p
host-ref) row key selected-key row-selected-p selected-ref)))
(host-ref internal-row-ref))
(unless key (unless key
(error "ETAF DataGrid row-key must return a non-nil stable scalar")) (error "ETAF DataGrid row-key must return a non-nil stable scalar"))
(when interactive-p (when interactive-p
@ -344,10 +383,14 @@ owns stable keyed callbacks across Range reevaluation."
(setq host-ref (funcall row-ref row)) (setq host-ref (funcall row-ref row))
(unless host-ref (unless host-ref
(error "ETAF DataGrid :row-ref must return a non-nil stable ref"))) (error "ETAF DataGrid :row-ref must return a non-nil stable ref")))
(etaf-view (etaf--view-call
(row :key key 'row
:class (concat "etaf-data-grid-row" (list :key key
(if selected-p " selected" "")) :class
(etaf--expr-create
:thunk (lambda ()
(concat "etaf-data-grid-row"
(if (funcall selected-p) " selected" ""))))
:ref host-ref :ref host-ref
:role (when interactive-p 'button) :role (when interactive-p 'button)
:tab-index (when interactive-p 0) :tab-index (when interactive-p 0)
@ -356,35 +399,106 @@ owns stable keyed callbacks across Range reevaluation."
:on-press (when interactive-p :on-press (when interactive-p
(etaf-ui--grid-row-action (etaf-ui--grid-row-action
row-actions key row on-row-press)) row-actions key row on-row-press))
:bgcolor (when selected-p :bgcolor
(plist-get theme :ui-grid-selected-bg)) (etaf--expr-create
(expr :value (etaf-ui--grid-cells row columns)))))) :thunk (lambda ()
(when (funcall selected-p)
(plist-get theme :ui-grid-selected-bg)))))
(etaf-ui--grid-cells row columns cell-refs))))
(defun etaf-ui--grid-row-state (states key)
"Return STATES' retained internal row and cell refs for KEY."
(or (gethash key states)
(let ((state (cons (gensym "etaf-data-grid-row-")
(make-hash-table :test #'eql))))
(puthash key state states)
state)))
(defun etaf-ui--grid-keyed-items
(items row-key row-actions row-states)
"Return validated `(KEY . ITEM)' entries and prune retained row caches."
(let ((seen (make-hash-table :test #'equal)) entries)
(dolist (item items)
(let ((key (funcall row-key item)))
(unless key
(error "ETAF DataGrid row-key must return a non-nil stable scalar"))
(when (gethash key seen)
(error "ETAF DataGrid row-key must be unique: %S" key))
(puthash key t seen)
(push (cons key item) entries)))
(maphash
(lambda (key _entry)
(unless (gethash key seen)
(remhash key row-actions)
(remhash key row-states)))
row-actions)
(nreverse entries)))
(defun etaf-ui--grid-rows (defun etaf-ui--grid-rows
(items columns row-key row-ref on-row-press selected-key row-selected-p (controller items columns row-key row-ref on-row-press selected-key
row-actions &optional theme) row-selected-p row-actions row-states &optional theme)
"Return keyed item Views and prune ROW-ACTIONS outside current ITEMS. "Return keyed Host rows and prune caches outside current ITEMS.
COLUMNS and ROW-KEY describe cells and identity. ROW-REF, ON-ROW-PRESS, CONTROLLER owns keyed default selection refs. COLUMNS and ROW-KEY describe
SELECTED-KEY, and ROW-SELECTED-P provide interaction state." cells and identity. ROW-REF, ON-ROW-PRESS, SELECTED-KEY, and ROW-SELECTED-P
provide interaction state. ROW-ACTIONS and ROW-STATES retain callback and
internal Host identities. THEME optionally supplies resolved colors."
(let* ((theme (or theme (let* ((theme (or theme
;; A Range owns the data rows, so read Theme once here to ;; Resolve Theme once in the retained DataGrid owner
;; keep palette changes reactive without doing it per row. ;; of doing it independently in every row Component.
(etaf-ui-theme-values :ui-grid-border (etaf-ui-theme-tokens :ui-grid-border
:ui-grid-selected-fg :ui-grid-selected-fg
:ui-grid-selected-bg))) :ui-grid-selected-bg)))
(seen (make-hash-table :test #'equal))) (entries
(prog1 (etaf-ui--grid-keyed-items
items row-key row-actions row-states)))
(mapcar (mapcar
(lambda (item) (lambda (entry)
(puthash (funcall row-key item) t seen) (let* ((key (car entry))
(item (cdr entry))
(state (etaf-ui--grid-row-state row-states key)))
(etaf-ui--grid-row (etaf-ui--grid-row
item columns row-key row-ref on-row-press selected-key item key columns row-ref on-row-press selected-key row-selected-p
row-selected-p row-actions theme)) (unless (or row-selected-p selected-key)
items) (etaf-data-selected-ref controller key))
(maphash (lambda (key _entry) row-actions theme (car state) (cdr state))))
(unless (gethash key seen) entries)))
(remhash key row-actions)))
row-actions)))) (defun etaf-ui--grid-body-items
(controller status items columns row-key row-ref on-row-press selected-key
row-selected-p row-actions row-states theme loading-label
error-label empty-label)
"Return CONTROLLER DataGrid body items for STATUS and ITEMS.
COLUMNS and ROW-KEY describe rows; ROW-REF and ON-ROW-PRESS add interaction.
SELECTED-KEY, ROW-SELECTED-P, and ROW-ACTIONS preserve controlled behavior.
THEME supplies colors, while LOADING-LABEL, ERROR-LABEL, and EMPTY-LABEL
customize state messages. The parent Component directly owns the result."
(unless (functionp row-key)
(error "ETAF DataGrid requires a function-valued :row-key"))
(when (and on-row-press (not (functionp on-row-press)))
(error "ETAF DataGrid :on-row-press must be a function"))
(when (and on-row-press (not (functionp row-ref)))
(error "ETAF DataGrid requires :row-ref for interactive rows"))
(when (and row-selected-p (not (functionp row-selected-p)))
(error "ETAF DataGrid :row-selected-p must be a function"))
(cond
((eq status 'loading)
(list (etaf--view-call 'text nil
(list (or loading-label "Loading...")))))
((eq status 'error)
(list
(etaf--view-call
'text
(list :class "etaf-data-grid-error"
:color (plist-get (etaf-ui-theme-tokens :ui-grid-error-fg)
:ui-grid-error-fg))
(list (or error-label "Unable to load data.")))))
((null items)
(list (etaf--view-call 'text nil
(list (or empty-label "No data.")))))
(t
(etaf-ui--grid-rows
controller items columns row-key row-ref on-row-press selected-key
row-selected-p row-actions row-states theme))))
(defun etaf-ui--button-setup () (defun etaf-ui--button-setup ()
"Create the retained renderer for one Button instance." "Create the retained renderer for one Button instance."
@ -495,7 +609,8 @@ ARIA-LABEL provide its semantic and presentation properties."
:color color :bgcolor bgcolor :border border :padding padding :face face :color color :bgcolor bgcolor :border border :padding padding :face face
:surface-properties (etaf-ui--interactive-surface-properties label disabled) :surface-properties (etaf-ui--interactive-surface-properties label disabled)
:on-press on-change :on-press on-change
(text :class "etaf-checkbox-mark" (expr :value (if checked "☑" "☐"))) (text :class "etaf-checkbox-mark"
(expr :value (if (etaf-ui--reactive-value checked) "☑" "☐")))
(text (expr :value (if label (concat " " label) "")))))) (text (expr :value (if label (concat " " label) ""))))))
;;;###autoload ;;;###autoload
@ -504,8 +619,9 @@ ARIA-LABEL provide its semantic and presentation properties."
face tab-index aria-label) face tab-index aria-label)
"Render a controlled checkbox with CHECKED, LABEL, and ON-CHANGE. "Render a controlled checkbox with CHECKED, LABEL, and ON-CHANGE.
ON-CHANGE receives the next boolean value. State ownership stays with the CHECKED may be a boolean or an ETAF reactive source. ON-CHANGE receives the
caller, so the Component works with local refs or Data-backed forms." next boolean value. State ownership stays with the caller, so the Component
works with local refs or Data-backed forms."
:styles :styles
(styles (styles
("&" :width max-content) ("&" :width max-content)
@ -520,9 +636,10 @@ caller, so the Component works with local refs or Data-backed forms."
(press (press
(lambda () (lambda ()
(when current-callback (when current-callback
(funcall current-callback (not current-checked)))))) (funcall current-callback
(not (etaf-ui--reactive-value current-checked)))))))
(lambda () (lambda ()
(let* ((theme (etaf-ui-theme-values :ui-fg :ui-bg (let* ((theme (etaf-ui-theme-tokens :ui-fg :ui-bg
:ui-checkbox-enabled-fg :ui-checkbox-enabled-fg
:ui-checkbox-enabled-bg :ui-checkbox-enabled-bg
:ui-checkbox-enabled-border :ui-checkbox-enabled-border
@ -554,18 +671,20 @@ caller, so the Component works with local refs or Data-backed forms."
;;;###autoload ;;;###autoload
(etaf-define-component etaf-label (etaf-define-component etaf-label
(&key text face class color bgcolor border padding ref width) (&key text face class color bgcolor border padding ref width)
"Render TEXT as a semantic label with presentation properties." "Render TEXT as a semantic label with presentation properties.
TEXT may be an ordinary value or an ETAF reactive source."
:view :view
(expr (expr
:value :value
(etaf-view (etaf-view
(text :class class :face face :color color :bgcolor bgcolor :border border (text :class class :face face :color color :bgcolor bgcolor :border border
:padding padding :ref ref :width width (expr :value text))))) :padding padding :ref ref :width width
(expr :value (etaf-ui--reactive-value text))))))
(defun etaf-ui--panel-view (title class color bgcolor border padding ref) (defun etaf-ui--panel-view (title class color bgcolor border padding ref)
"Render a themed Panel View. "Render a themed Panel View.
Arguments are TITLE, CLASS, COLOR, BGCOLOR, BORDER, PADDING, and REF." Arguments are TITLE, CLASS, COLOR, BGCOLOR, BORDER, PADDING, and REF."
(let ((theme (etaf-ui-theme-values :ui-panel-fg :ui-panel-bg (let ((theme (etaf-ui-theme-tokens :ui-panel-fg :ui-panel-bg
:ui-panel-border))) :ui-panel-border)))
(etaf-view (etaf-view
(column (column
@ -617,7 +736,53 @@ a stable Host reference."
;; this Component style scope contains geometry only. ;; this Component style scope contains geometry only.
) )
:setup :setup
(let ((row-actions (make-hash-table :test #'equal))) (let ((row-actions (make-hash-table :test #'equal))
(row-states (make-hash-table :test #'equal))
current-controller current-columns current-row-key current-row-ref
current-on-row-press current-selected-key current-row-selected-p
current-loading-label current-error-label current-empty-label
body-config body-expr body-thunk body-range-snapshot body-range-item)
(setq
body-thunk
(lambda ()
(let* ((status
(etaf-value (etaf-data-status current-controller)))
(items
(etaf-value (etaf-data-items current-controller)))
(theme
(etaf-ui-theme-tokens :ui-grid-border
:ui-grid-selected-bg)))
(etaf-ui--grid-body-items
current-controller status items current-columns current-row-key
current-row-ref current-on-row-press current-selected-key
current-row-selected-p row-actions row-states theme
current-loading-label current-error-label current-empty-label))))
(setq
body-range-snapshot
(lambda ()
(let ((status (etaf-value (etaf-data-status current-controller)))
(items (etaf-value (etaf-data-items current-controller))))
(when (and (eq status 'success) items)
(let ((theme
(etaf-ui-theme-tokens :ui-grid-border
:ui-grid-selected-bg)))
(list
:items
(etaf-ui--grid-keyed-items
items current-row-key row-actions row-states)
:context theme))))))
(setq
body-range-item
(lambda (entry theme)
(let* ((key (car entry))
(item (cdr entry))
(state (etaf-ui--grid-row-state row-states key)))
(etaf-ui--grid-row
item key current-columns current-row-ref current-on-row-press
current-selected-key current-row-selected-p
(unless (or current-row-selected-p current-selected-key)
(etaf-data-selected-ref current-controller key))
row-actions theme (car state) (cdr state)))))
(lambda () (lambda ()
(let* ((controller (etaf-current-prop :controller)) (let* ((controller (etaf-current-prop :controller))
(columns (etaf-current-prop :columns)) (columns (etaf-current-prop :columns))
@ -629,61 +794,43 @@ a stable Host reference."
(loading-label (etaf-current-prop :loading-label)) (loading-label (etaf-current-prop :loading-label))
(error-label (etaf-current-prop :error-label)) (error-label (etaf-current-prop :error-label))
(empty-label (etaf-current-prop :empty-label)) (empty-label (etaf-current-prop :empty-label))
;; Resolve the shared semantic UI Theme once at the DataGrid (config
;; boundary. Rows reuse this immutable snapshot instead of (list controller columns row-key row-ref on-row-press
;; allocating or resolving border values independently during selected-key row-selected-p loading-label error-label
;; every retained Range update. empty-label))
(raw-theme (etaf-ui-theme-values :ui-fg (theme (etaf-ui-theme-tokens :ui-fg :ui-grid-border))
:ui-grid-border
:ui-grid-selected-bg))
(theme (plist-put (copy-sequence raw-theme)
:ui-grid-border
(etaf-ui--theme-border
(plist-get raw-theme :ui-grid-border))))
(theme-color (plist-get theme :ui-fg))) (theme-color (plist-get theme :ui-fg)))
(etaf-view (unless (eq controller current-controller)
(column (clrhash row-actions)
:class "etaf-data-grid" :color theme-color (clrhash row-states))
(expr :value (etaf-ui--grid-header (setq current-controller controller
columns theme)) current-columns columns
(column current-row-key row-key
:class "etaf-data-grid-body" current-row-ref row-ref
(expr current-on-row-press on-row-press
:value current-selected-key selected-key
(progn current-row-selected-p row-selected-p
(unless (functionp row-key) current-loading-label loading-label
(error "ETAF DataGrid requires a function-valued :row-key")) current-error-label error-label
(when (and on-row-press (not (functionp on-row-press))) current-empty-label empty-label)
(error "ETAF DataGrid :on-row-press must be a function")) (unless (equal-including-properties config body-config)
(when (and on-row-press (not (functionp row-ref))) (setq body-config (copy-tree config)
(error "ETAF DataGrid requires :row-ref for interactive rows")) body-expr
(when (and row-selected-p (not (functionp row-selected-p))) (etaf--expr-create
(error "ETAF DataGrid :row-selected-p must be a function")) :token (gensym "etaf-data-grid-body-")
(let ((status (etaf-value (etaf-data-status controller))) :thunk body-thunk
(items (etaf-value (etaf-data-items controller)))) :range-snapshot body-range-snapshot
(cond :range-key #'car
((eq status 'loading) :range-item body-range-item)))
(etaf-view (etaf--view-call
(text (expr :value (or loading-label "Loading..."))))) 'column
((eq status 'error) (list :class "etaf-data-grid" :color theme-color)
(etaf-view (list
(text :class "etaf-data-grid-error" (etaf-ui--grid-header columns theme)
:color (plist-get (etaf-ui-theme-values (etaf--view-call
:ui-grid-error-fg) 'column (list :class "etaf-data-grid-body") (list body-expr))
:ui-grid-error-fg) (etaf--slot-projection-create
(expr :value :name 'footer :token 'etaf-ui-data-grid-footer :fallback nil)))))))
(or error-label "Unable to load data.")))))
((null items)
(etaf-view
(text (expr :value (or empty-label "No data.")))))
(t
;; Read Theme inside this Range's evaluator so retained row
;; Hosts follow palette changes without requiring the parent
;; DataGrid Component to be rebuilt.
(etaf-ui--grid-rows
items columns row-key row-ref on-row-press selected-key
row-selected-p row-actions))))))
(slot :name 'footer))))))))
;;;###autoload ;;;###autoload
(etaf-define-component etaf-pagination (etaf-define-component etaf-pagination
@ -702,26 +849,51 @@ readable in both GUI and text review."
(".etaf-pagination-label" :face bold)) (".etaf-pagination-label" :face bold))
:setup :setup
(let* ((current-controller nil) (let* ((current-controller nil)
(current-parent-color nil)
(current-parent-bgcolor nil)
(page-value
(lambda ()
(max 1 (or (etaf-value
(etaf-data-page current-controller))
1))))
(page-size-value
(lambda ()
(max 1 (or (etaf-value
(etaf-data-page-size current-controller))
1))))
(total-value
(lambda ()
(max 0 (or (etaf-value
(etaf-data-total current-controller))
0))))
(pages-value
(lambda ()
(max 1 (ceiling (/ (float (funcall total-value))
(funcall page-size-value))))))
(loading-p
(lambda ()
(eq (etaf-value (etaf-data-status current-controller))
'loading)))
(previous-disabled
(lambda ()
(or (funcall loading-p) (<= (funcall page-value) 1))))
(next-disabled
(lambda ()
(or (funcall loading-p)
(>= (funcall page-value) (funcall pages-value)))))
(previous (previous
(lambda () (lambda ()
(when current-controller (when (and current-controller
(not (funcall previous-disabled)))
(etaf-data-previous-page current-controller)))) (etaf-data-previous-page current-controller))))
(next (next
(lambda () (lambda ()
(when current-controller (when (and current-controller
(not (funcall next-disabled)))
(etaf-data-next-page current-controller))))) (etaf-data-next-page current-controller)))))
(lambda () (lambda ()
(let* ((controller-value (etaf-current-prop :controller)) (let* ((controller-value (etaf-current-prop :controller))
(page (max 1 (or (etaf-value (etaf-data-page controller-value)) 1))) (theme (etaf-ui-theme-tokens :ui-fg :ui-bg
(page-size (max 1 (or (etaf-value (etaf-data-page-size controller-value)) 1)))
(total (max 0 (or (etaf-value (etaf-data-total controller-value)) 0)))
(pages (max 1 (ceiling (/ (float total) page-size))))
(status (etaf-value (etaf-data-status controller-value)))
(first-item (if (zerop total) 0 (1+ (* (1- page) page-size))))
(last-item (min total (* page page-size)))
(previous-disabled (or (eq status 'loading) (<= page 1)))
(next-disabled (or (eq status 'loading) (>= page pages)))
(theme (etaf-ui-theme-values :ui-fg :ui-bg
:ui-disabled-fg :ui-disabled-fg
:ui-pagination-muted-fg)) :ui-pagination-muted-fg))
(parent-color (or (etaf-current-prop :color) (parent-color (or (etaf-current-prop :color)
@ -729,7 +901,9 @@ readable in both GUI and text review."
(parent-bgcolor (or (etaf-current-prop :bgcolor) (parent-bgcolor (or (etaf-current-prop :bgcolor)
(plist-get theme :ui-bg))) (plist-get theme :ui-bg)))
(arrow-border '((0) solid "transparent"))) (arrow-border '((0) solid "transparent")))
(setq current-controller controller-value) (setq current-controller controller-value
current-parent-color parent-color
current-parent-bgcolor parent-bgcolor)
(etaf-view (etaf-view
(flex :class (etaf-ui--class-value "etaf-pagination" nil (flex :class (etaf-ui--class-value "etaf-pagination" nil
(etaf-current-prop :class)) (etaf-current-prop :class))
@ -748,35 +922,47 @@ readable in both GUI and text review."
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto :flex-grow 0 :flex-shrink 0 :flex-basis 'auto
(button :label "←" :ref (etaf-current-prop :previous-ref) (button :label "←" :ref (etaf-current-prop :previous-ref)
:aria-label "Previous page" :aria-label "Previous page"
:disabled previous-disabled :disabled (funcall previous-disabled)
:padding '(0 0) :padding '(0 0)
:border arrow-border :border arrow-border
:color (if previous-disabled :color (if (funcall previous-disabled)
(plist-get theme :ui-disabled-fg) (plist-get theme :ui-disabled-fg)
parent-color) current-parent-color)
:bgcolor parent-bgcolor :bgcolor current-parent-bgcolor
:face 'bold :face 'bold
:on-press (unless previous-disabled previous))) :on-press previous))
(column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0 (column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
(text :class "etaf-pagination-label" :text-align 'center (text :class "etaf-pagination-label" :text-align 'center
(expr :value (format "Page %d / %d" page pages))) (expr :value
(format "Page %d / %d"
(funcall page-value)
(funcall pages-value))))
(text :class "etaf-pagination-summary" :text-align 'center (text :class "etaf-pagination-summary" :text-align 'center
:color (plist-get theme :ui-pagination-muted-fg) :color (plist-get theme :ui-pagination-muted-fg)
(expr :value (format "%d–%d of %d" (expr :value
first-item last-item total)))) (let* ((page (funcall page-value))
(page-size (funcall page-size-value))
(total (funcall total-value))
(first-item
(if (zerop total)
0
(1+ (* (1- page) page-size))))
(last-item (min total (* page page-size))))
(format "%d–%d of %d"
first-item last-item total)))))
(column :width 'max-content (column :width 'max-content
:flex-grow 0 :flex-shrink 0 :flex-basis 'auto :flex-grow 0 :flex-shrink 0 :flex-basis 'auto
(button :label "→" :ref (etaf-current-prop :next-ref) (button :label "→" :ref (etaf-current-prop :next-ref)
:aria-label "Next page" :aria-label "Next page"
:disabled next-disabled :disabled (funcall next-disabled)
:padding '(0 0) :padding '(0 0)
:border arrow-border :border arrow-border
:color (if next-disabled :color (if (funcall next-disabled)
(plist-get theme :ui-disabled-fg) (plist-get theme :ui-disabled-fg)
parent-color) current-parent-color)
:bgcolor parent-bgcolor :bgcolor current-parent-bgcolor
:face 'bold :face 'bold
:on-press (unless next-disabled next))))))))) :on-press next))))))))
(provide 'etaf-ui) (provide 'etaf-ui)

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

@ -43,6 +43,20 @@
(get-text-property position 'mouse-face) (get-text-property position 'mouse-face)
(get-text-property position 'help-echo))))) (get-text-property position 'help-echo)))))
(defun etaf-ui-test--paint-color (value property)
"Return effective paint color from VALUE for Ebox PROPERTY."
(if (not (tp-paint-slot-p value))
value
(let ((spec (tp-paint-slot-spec value)))
(pcase property
(:color (plist-get spec :foreground))
((or :bgcolor :background-color) (plist-get spec :background))
(:border-top-color (plist-get spec :overline))
(:border-bottom-color
(plist-get (plist-get spec :underline) :color))
((or :border-left-color :border-right-color)
(plist-get spec :background))))))
(defvar etaf-ui-test-use-count 0) (defvar etaf-ui-test-use-count 0)
(etaf-define-behavior etaf-ui-test-press-behavior (&rest attributes) (etaf-define-behavior etaf-ui-test-press-behavior (&rest attributes)
@ -371,6 +385,59 @@
(when-let ((buffer (get-buffer buffer-name))) (when-let ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))) (kill-buffer buffer)))))
(ert-deftest etaf-ui-checkbox-reactive-value-updates-through-inline-range ()
"Update a reactive CHECKED source without rerunning Checkbox Component."
(let ((buffer-name " *etaf-ui-reactive-checkbox-test*")
(checked (etaf-ref nil))
(component-renders 0))
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(checkbox :label "Live" :ref 'live-checkbox :checked checked
:on-change (lambda (value)
(setf (etaf-value checked) value)))))
(let ((render (symbol-function
'etaf--runtime-render-dirty-component)))
(cl-letf (((symbol-function 'etaf--runtime-render-dirty-component)
(lambda (&rest arguments)
(cl-incf component-renders)
(apply render arguments))))
(etaf-dispatch-event (etaf-runtime-for-buffer buffer-name)
'live-checkbox 'press)))
(should (etaf-value checked))
(should (string-match-p "☑ Live"
(etaf-ui-test--text buffer-name)))
(should (zerop component-renders)))
(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-ui-label-reactive-text-updates-through-inline-range ()
"Update reactive Label text without rerunning its Component."
(let ((buffer-name " *etaf-ui-reactive-label-test*")
(text (etaf-ref "One"))
(component-renders 0))
(unwind-protect
(progn
(etaf-mount buffer-name
(etaf-view (label :text text :ref 'live-label)))
(let ((render (symbol-function
'etaf--runtime-render-dirty-component)))
(cl-letf (((symbol-function 'etaf--runtime-render-dirty-component)
(lambda (&rest arguments)
(cl-incf component-renders)
(apply render arguments))))
(setf (etaf-value text) "Two")))
(should (equal "Two" (etaf-ui-test--text buffer-name)))
(should (zerop component-renders)))
(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-ui-checkbox-disabled-is-not-interactive () (ert-deftest etaf-ui-checkbox-disabled-is-not-interactive ()
"A disabled checkbox has no callback or tab stop and remains visible." "A disabled checkbox has no callback or tab stop and remains visible."
(let ((buffer-name " *etaf-ui-disabled-checkbox-test*") (let ((buffer-name " *etaf-ui-disabled-checkbox-test*")
@ -494,6 +561,98 @@
(when-let ((buffer (get-buffer buffer-name))) (when-let ((buffer (get-buffer buffer-name)))
(kill-buffer buffer))))) (kill-buffer buffer)))))
(ert-deftest etaf-ui-data-grid-default-selection-updates-only-delta-hosts ()
"Controller selection updates old/new row Hosts without rebuilding rows."
(let* ((source (etaf-data-memory-source
'((:id 1 :name "Ada")
(:id 2 :name "Grace")
(:id 3 :name "Alan"))
:id-key :id))
(controller (etaf-data-controller source :auto-load t))
(buffer-name " *etaf-ui-grid-keyed-selection-test*")
(row-renders (make-hash-table :test #'eql))
(body-renders 0)
host-updates)
(unwind-protect
(progn
(etaf-mount
buffer-name
(etaf-view
(data-grid
:controller controller
:columns '((:key :id :label "ID")
(:key :name :label "Name"))
:row-key (lambda (row) (plist-get row :id))
:row-ref (lambda (row)
(intern (format "keyed-row-%d" (plist-get row :id))))
:on-row-press
(lambda (row)
(etaf-data-select-one controller (plist-get row :id))))))
(etaf-data-select-one controller 1)
(let* ((runtime (etaf-runtime-for-buffer buffer-name))
(text-before (etaf-ui-test--text buffer-name))
(third-handler
(cdr (assq 'press
(etaf-runtime-handler-for runtime 'keyed-row-3))))
(old-grid-row (symbol-function 'etaf-ui--grid-row))
(old-grid-rows (symbol-function 'etaf-ui--grid-rows))
(old-host
(symbol-function 'ebox-candidate-replace-host-ref))
(old-paint
(symbol-function 'ebox-candidate-patch-host-paint)))
(cl-letf (((symbol-function 'etaf-ui--grid-row)
(lambda (&rest args)
(let ((key (nth 1 args)))
(puthash key (1+ (gethash key row-renders 0))
row-renders))
(apply old-grid-row args)))
((symbol-function 'etaf-ui--grid-rows)
(lambda (&rest args)
(cl-incf body-renders)
(apply old-grid-rows args)))
((symbol-function 'ebox-candidate-replace-host-ref)
(lambda (candidate ref node)
(push ref host-updates)
(funcall old-host candidate ref node)))
((symbol-function 'ebox-candidate-patch-host-paint)
(lambda (candidate ref old-node new-node)
(push ref host-updates)
(funcall old-paint candidate ref old-node new-node))))
;; Prove direct public selection ref writes use the same keyed
;; invalidation path as the selection helpers.
(setf (etaf-value (etaf-data-selection controller)) '(2)))
(should (zerop (gethash 1 row-renders 0)))
(should (zerop (gethash 2 row-renders 0)))
(should (zerop (gethash 3 row-renders 0)))
(should (zerop (hash-table-count row-renders)))
(should (zerop body-renders))
(should (member 'keyed-row-1 host-updates))
(should (member 'keyed-row-2 host-updates))
(should-not (member 'keyed-row-3 host-updates))
(should (equal text-before (etaf-ui-test--text buffer-name)))
(should-not
(string-match-p
"selected"
(or (plist-get (etaf-ui-test--props buffer-name 'keyed-row-1)
:class)
"")))
(should
(string-match-p
"selected"
(or (plist-get (etaf-ui-test--props buffer-name 'keyed-row-2)
:class)
"")))
(should (eq third-handler
(cdr (assq
'press
(etaf-runtime-handler-for runtime
'keyed-row-3)))))))
(when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime))
(etaf-data-stop controller)
(when-let ((buffer (get-buffer buffer-name)))
(kill-buffer buffer)))))
(ert-deftest etaf-ui-data-grid-follows-inherited-theme-color () (ert-deftest etaf-ui-data-grid-follows-inherited-theme-color ()
"Re-render DataGrid rows when only inherited Theme color changes." "Re-render DataGrid rows when only inherited Theme color changes."
(let* ((theme (etaf-ref '(:color "light-ink" (let* ((theme (etaf-ref '(:color "light-ink"
@ -510,26 +669,30 @@
buffer-name buffer-name
(etaf-view (etaf-view
(ui-test-grid-theme-fixture :controller controller :theme theme))) (ui-test-grid-theme-fixture :controller controller :theme theme)))
(let* ((props (etaf-ui-test--props-with-key buffer-name 1))
(background-slot (plist-get props :bgcolor))
(border-slot (plist-get props :border-bottom-color)))
(should (equal "light-selected-bg" (should (equal "light-selected-bg"
(plist-get (etaf-ui-test--props-with-key buffer-name 1) (etaf-ui-test--paint-color
:bgcolor))) background-slot :bgcolor)))
(should (equal "light-grid-border" (should (equal "light-grid-border"
(plist-get (etaf-ui-test--props-with-key (etaf-ui-test--paint-color
buffer-name 1) border-slot :border-bottom-color)))
:border-bottom-color)))
(should (plist-get (etaf-ui-test--props-with-key buffer-name 1) (should (plist-get (etaf-ui-test--props-with-key buffer-name 1)
:border-bottom-p)) :border-bottom-p))
(setf (etaf-value theme) '(:color "dark-ink" (setf (etaf-value theme) '(:color "dark-ink"
:ui-grid-border "dark-grid-border" :ui-grid-border "dark-grid-border"
:ui-grid-selected-fg "dark-selected" :ui-grid-selected-fg "dark-selected"
:ui-grid-selected-bg "dark-selected-bg")) :ui-grid-selected-bg "dark-selected-bg"))
(let ((next (etaf-ui-test--props-with-key buffer-name 1)))
(should (eq background-slot (plist-get next :bgcolor)))
(should (eq border-slot (plist-get next :border-bottom-color)))
(should (equal "dark-selected-bg" (should (equal "dark-selected-bg"
(plist-get (etaf-ui-test--props-with-key buffer-name 1) (etaf-ui-test--paint-color
:bgcolor))) background-slot :bgcolor)))
(should (equal "dark-grid-border" (should (equal "dark-grid-border"
(plist-get (etaf-ui-test--props-with-key (etaf-ui-test--paint-color
buffer-name 1) border-slot :border-bottom-color))))))
:border-bottom-color))))
(when-let ((runtime (etaf-runtime-for-buffer buffer-name))) (when-let ((runtime (etaf-runtime-for-buffer buffer-name)))
(etaf-unmount runtime)) (etaf-unmount runtime))
(etaf-data-stop controller) (etaf-data-stop controller)