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

feat: close Research Shelf M0 integration

Browse Source
This commit is contained in:
Kinneyzhang 2026-08-31 16:07:25 +08:00
parent 5cbf949465
commit d124c33ba4
5 changed files with 478 additions and 280 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

545
examples/research-shelf.el
View File

@ -226,17 +226,17 @@ user's prior local additions cannot collide with the generated dataset."
:ui-disabled-border line :ui-disabled-border line
:ui-button-primary-fg paper :ui-button-primary-bg accent :ui-button-primary-fg paper :ui-button-primary-bg accent
:ui-button-primary-border accent :ui-button-primary-border accent
:ui-button-secondary-fg ink :ui-button-secondary-bg mint :ui-button-secondary-fg ink :ui-button-secondary-bg mint-bg
:ui-button-secondary-border mint :ui-button-secondary-border mint
:ui-button-ghost-fg ink :ui-button-ghost-bg panel :ui-button-ghost-fg ink :ui-button-ghost-bg panel
:ui-button-ghost-border line :ui-button-ghost-border line
:ui-checkbox-enabled-fg ink :ui-checkbox-enabled-bg mint :ui-checkbox-enabled-fg ink :ui-checkbox-enabled-bg mint-bg
:ui-checkbox-enabled-border mint :ui-checkbox-enabled-border mint
:ui-checkbox-disabled-fg muted :ui-checkbox-disabled-bg soft :ui-checkbox-disabled-fg muted :ui-checkbox-disabled-bg soft
:ui-checkbox-disabled-border line :ui-checkbox-disabled-border line
:ui-grid-border line :ui-grid-selected-fg mint :ui-table-border line :ui-table-selected-fg mint
:ui-grid-selected-bg mint-bg :ui-table-selected-bg mint-bg
:ui-grid-error-fg coral :ui-pagination-muted-fg muted :ui-data-grid-error-fg coral :ui-pagination-muted-fg muted
:ui-panel-fg ink :ui-panel-bg panel :ui-panel-border line)))) :ui-panel-fg ink :ui-panel-bg panel :ui-panel-border line))))
;;; --------------------------------------------------------------------------- ;;; ---------------------------------------------------------------------------
@ -433,264 +433,302 @@ constructed. When omitted, initialize it for direct programmatic callers."
(or (and entry (plist-get (cdr entry) :label)) fallback))))) (or (and entry (plist-get (cdr entry) :label)) fallback)))))
(etaf-define-component etaf-research-shelf-filter-button (etaf-define-component etaf-research-shelf-filter-button
(&key filter-key fallback ref) (&key filter-key fallback)
"Render one filter Button from inherited model and static filter Context." "Render one filter Button from inherited model and static filter Context."
:setup :setup
(let ((model (etaf-inject 'research-shelf-model nil t)) (list :model (etaf-inject 'research-shelf-model nil t)
(form (etaf-inject 'research-shelf-filters nil t)) :form (etaf-inject 'research-shelf-filters nil t))
(filter-key (etaf-current-prop :filter-key)) :view
(fallback (etaf-current-prop :fallback)) (etaf-button
(ref (etaf-current-prop :ref))) :label
(lambda () (let* ((model (plist-get (etaf-state) :model))
(let ((active (eq filter-key (etaf-value (plist-get model :filter))))) (form (plist-get (etaf-state) :form))
(etaf-view (label (etaf-research-shelf--filter-label
(button :label form filter-key fallback)))
(let ((label (etaf-research-shelf--filter-label (if (eq filter-key (etaf-value (plist-get model :filter)))
form filter-key fallback))) (concat "● " label)
(if active (concat "● " label) label)) label))
:ref ref :variant (if active 'secondary 'ghost) :variant
:on-press (lambda () (if (eq filter-key
(etaf-dispatch 'etaf-research-shelf-filter (etaf-value
model filter-key)))))))) (plist-get (plist-get (etaf-state) :model) :filter)))
'secondary
(defun etaf-research-shelf--filter-view (model) 'ghost)
"Return the filter rail for MODEL and inherited filter Context." :on-press
(etaf-view (let ((model (plist-get (etaf-state) :model))
(column (key filter-key))
:class "research-shelf-filter-rail" :width 'stretch :min-width 0 (lambda ()
:flex-grow 1 :flex-shrink 1 :flex-basis '(220) (etaf-dispatch 'etaf-research-shelf-filter model key)))))
:padding '(1 1)
:border (etaf-theme-token :line)
:color (etaf-theme-token :ink)
:bgcolor (etaf-theme-token :panel)
(label :text "Library" :font-weight 'bold)
(label :text "VIEWS" :color (etaf-theme-token :muted))
(etaf-research-shelf-filter-button
:filter-key 'all :fallback "All" :ref 'research-shelf-filter-all)
(etaf-research-shelf-filter-button
:filter-key 'reading :fallback "In progress"
:ref 'research-shelf-filter-reading)
(etaf-research-shelf-filter-button
:filter-key 'unread :fallback "Unread" :ref 'research-shelf-filter-unread)
(etaf-research-shelf-filter-button
:filter-key 'finished :fallback "Finished"
:ref 'research-shelf-filter-finished)
(etaf-research-shelf-filter-button
:filter-key 'starred :fallback "★ Starred"
:ref 'research-shelf-filter-starred)
(box :height 1)
(label :text "STORAGE" :color (etaf-theme-token :muted))
(label :text (file-name-nondirectory
(plist-get model :database-file)))
(button :label "↻ Reload library" :ref 'research-shelf-reload
:variant 'ghost
:on-press (lambda ()
(etaf-dispatch 'etaf-research-shelf-reload
model))))))
(defun etaf-research-shelf--reading-list-view (model form)
"Return the reading list for MODEL and static MAIN FORM."
(let ((controller (etaf-research-shelf--controller model)))
(etaf-view
(column
:class "research-shelf-list" :width 'stretch :min-width 0
:flex-grow 4 :flex-shrink 1 :flex-basis '(620)
:padding '(1 2)
:border (etaf-theme-token :line)
:bgcolor (etaf-theme-token :panel)
(flex
:width 'stretch :flex-wrap 'wrap :align-items 'center :gap '(1 (8))
(column
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
(label :text (etaf-playground-static-value
form :title "Reading queue") :font-weight 'bold)
(label :text (format "%d items · SQLite-backed"
(or (etaf-value (etaf-data-total controller)) 0))
:color (etaf-theme-token :muted)))
(number-input :label "Rows"
:value (etaf-value (etaf-data-page-size controller))
:ref 'research-shelf-page-size :min 1 :max 100
:on-change
(lambda (next)
(etaf-dispatch 'etaf-research-shelf-page-size
model next)))
(button :label "＋ Add reading" :ref 'research-shelf-add
:variant 'secondary
:on-press (lambda ()
(etaf-dispatch 'etaf-research-shelf-add model))))
(data-grid
:controller controller
:columns etaf-research-shelf--grid-columns
:row-key #'etaf-research-shelf--item-id
:row-ref (lambda (row)
(intern (format "research-shelf-row-%s"
(etaf-research-shelf--item-id row))))
:on-row-press
(lambda (row)
(etaf-data-select-one controller
(etaf-research-shelf--item-id row)))
:loading-label "◷ Loading library…"
:error-label "⚠ Could not read the shelf. Use Reload.")
(etaf-pagination :controller controller
:previous-ref 'research-shelf-page-previous
:next-ref 'research-shelf-page-next
:color (etaf-theme-token :ink))))))
(defun etaf-research-shelf--detail-view (model form)
"Return the selected record inspector for MODEL and static FORM."
(etaf-view
(column
:class "research-shelf-detail" :width 'stretch :min-width 0
:flex-grow 2 :flex-shrink 1 :flex-basis '(340)
:padding '(2 2)
:border (etaf-theme-token :line)
:bgcolor (etaf-theme-token :panel)
(label :text (etaf-playground-static-value form :title
"Selected item")
:color (etaf-theme-token :accent))
(text :font-weight 'bold
(expr :value
(if-let* ((row (etaf-research-shelf--selected model)))
(plist-get row :title)
"Choose a record")))
(text :color (etaf-theme-token :muted)
(expr :value
(if-let* ((row (etaf-research-shelf--selected model)))
(format "%s · %s" (plist-get row :author)
(plist-get row :kind))
"Select one row to inspect it.")))
(box :height 1)
(text :font-weight 'bold
(expr :value
(if-let* ((row (etaf-research-shelf--selected model)))
(etaf-research-shelf--status-label (plist-get row :status))
"○ No selection")))
(text
(expr :value
(if-let* ((row (etaf-research-shelf--selected model)))
(format "Progress %d%% · Priority %s"
(or (plist-get row :progress) 0)
(plist-get row :priority))
"Progress — · Priority —")))
(text :color (etaf-theme-token :accent)
(expr :value
(let* ((row (etaf-research-shelf--selected model))
(progress (or (and row (plist-get row :progress)) 0))
(filled (max 0 (min 10 (/ progress 10)))))
(format "%s %s" (make-string filled ?█)
(make-string (- 10 filled) ?░)))))
(box :height 1)
(text :color (etaf-theme-token :muted)
(expr :value
(if-let* ((row (etaf-research-shelf--selected model)))
(concat "“" (or (plist-get row :note) "No note yet.") "”")
"Your notes and actions will appear here.")))
(box :height 1)
(etaf-research-shelf-detail-actions))))
(etaf-define-component etaf-research-shelf-detail-actions ()
"Render selected-record actions from the inherited Research Shelf model."
:setup
(let ((model (etaf-inject 'research-shelf-model nil t)))
(lambda ()
(let* ((row (etaf-research-shelf--selected model))
(progress (or (and row (plist-get row :progress)) 0))
(finished (and row (equal (plist-get row :status) "finished")))
(archived (and row (equal (plist-get row :status) "archived"))))
(etaf-view
(flex
:width 'stretch :flex-wrap 'wrap :gap '(1 (6))
(button :label "+ 10%" :ref 'research-shelf-progress
:variant 'secondary
:disabled (or (null row) archived (>= progress 100))
:on-press (lambda ()
(etaf-dispatch 'etaf-research-shelf-progress
model)))
(button :label "✓ Finish" :ref 'research-shelf-finish
:variant 'secondary :disabled (or (null row) finished archived)
:on-press (lambda ()
(etaf-dispatch 'etaf-research-shelf-finish
model)))
(button :label "★ Star" :ref 'research-shelf-star
:variant 'ghost :disabled (null row)
:on-press (lambda ()
(etaf-dispatch 'etaf-research-shelf-star model)))
(button :label "Archive" :ref 'research-shelf-archive
:variant 'ghost :disabled (or (null row) archived)
:on-press (lambda ()
(etaf-dispatch 'etaf-research-shelf-archive
model)))))))))
(etaf-define-component etaf-research-shelf-filter-rail () (etaf-define-component etaf-research-shelf-filter-rail ()
"Render the Research Shelf filter rail from inherited Context." "Render the Research Shelf filter rail from inherited Context."
:setup :setup
(let ((model (etaf-inject 'research-shelf-model nil t))) (etaf-inject 'research-shelf-model nil t)
(lambda () (etaf-research-shelf--filter-view model)))) :view
(column :class "research-shelf-filter-rail"
:width 'stretch :min-width 0
:flex-grow 1 :flex-shrink 1 :flex-basis '(220)
:padding '(1 1)
:border (etaf-theme-token :line)
:color (etaf-theme-token :ink)
:bgcolor (etaf-theme-token :panel)
(text :font-weight 'bold "Library")
(text :color (etaf-theme-token :muted) "VIEWS")
(etaf-research-shelf-filter-button
:filter-key 'all :fallback "All" :ref 'research-shelf-filter-all)
(etaf-research-shelf-filter-button
:filter-key 'reading :fallback "In progress"
:ref 'research-shelf-filter-reading)
(etaf-research-shelf-filter-button
:filter-key 'unread :fallback "Unread"
:ref 'research-shelf-filter-unread)
(etaf-research-shelf-filter-button
:filter-key 'finished :fallback "Finished"
:ref 'research-shelf-filter-finished)
(etaf-research-shelf-filter-button
:filter-key 'starred :fallback "★ Starred"
:ref 'research-shelf-filter-starred)
(box :height 1)
(text :color (etaf-theme-token :muted) "STORAGE")
(text
(expr (file-name-nondirectory (plist-get (etaf-state) :database-file))))
(etaf-button
:label "↻ Reload library" :ref 'research-shelf-reload :variant 'ghost
:on-press
(let ((model (etaf-state)))
(lambda ()
(etaf-dispatch 'etaf-research-shelf-reload model))))))
(etaf-define-component etaf-research-shelf-reading-list () (etaf-define-component etaf-research-shelf-reading-list ()
"Render the Research Shelf reading list from inherited Context." "Render the Research Shelf reading list from inherited Context."
:setup :setup
(let ((model (etaf-inject 'research-shelf-model nil t)) (list :model (etaf-inject 'research-shelf-model nil t)
(form (etaf-inject 'research-shelf-library nil t))) :form (etaf-inject 'research-shelf-library nil t))
(lambda () (etaf-research-shelf--reading-list-view model form)))) :view
(column :class "research-shelf-list" :width 'stretch :min-width 0
:flex-grow 4 :flex-shrink 1 :flex-basis '(620)
:padding '(1 2)
:border (etaf-theme-token :line)
:bgcolor (etaf-theme-token :panel)
(flex :width 'stretch :flex-wrap 'wrap
:align-items 'center :gap '(1 (8))
(column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
(text :font-weight 'bold
(expr (etaf-playground-static-value
(plist-get (etaf-state) :form) :title "Reading queue")))
(text :color (etaf-theme-token :muted)
(expr
(format
"%d items · SQLite-backed"
(or (etaf-value
(etaf-data-total
(etaf-research-shelf--controller
(plist-get (etaf-state) :model))))
0)))))
(etaf-number-input
:label "Rows"
:value
(etaf-value
(etaf-data-page-size
(etaf-research-shelf--controller
(plist-get (etaf-state) :model))))
:ref 'research-shelf-page-size :min 1 :max 100
:on-change
(let ((model (plist-get (etaf-state) :model)))
(lambda (next)
(etaf-dispatch 'etaf-research-shelf-page-size model next))))
(etaf-button
:label "＋ Add reading" :ref 'research-shelf-add :variant 'secondary
:on-press
(let ((model (plist-get (etaf-state) :model)))
(lambda ()
(etaf-dispatch 'etaf-research-shelf-add model)))))
(etaf-data-grid
:controller
(etaf-research-shelf--controller (plist-get (etaf-state) :model))
:columns etaf-research-shelf--grid-columns
:row-key #'etaf-research-shelf--item-id
:row-ref
(lambda (row)
(intern (format "research-shelf-row-%s"
(etaf-research-shelf--item-id row))))
:on-row-press
(let ((controller
(etaf-research-shelf--controller
(plist-get (etaf-state) :model))))
(lambda (row)
(etaf-data-select-one controller
(etaf-research-shelf--item-id row))))
:loading-label "◷ Loading library…"
:error-label "⚠ Could not read the shelf. Use Reload.")
(etaf-pagination
:controller
(etaf-research-shelf--controller (plist-get (etaf-state) :model))
:previous-ref 'research-shelf-page-previous
:next-ref 'research-shelf-page-next
:color (etaf-theme-token :ink))))
(etaf-define-component etaf-research-shelf-detail-inspector () (etaf-define-component etaf-research-shelf-detail-inspector ()
"Render the Research Shelf detail inspector from inherited Context." "Render the Research Shelf detail inspector from inherited Context."
:setup :setup
(let ((model (etaf-inject 'research-shelf-model nil t)) (list :model (etaf-inject 'research-shelf-model nil t)
(form (etaf-inject 'research-shelf-detail nil t))) :form (etaf-inject 'research-shelf-detail nil t))
(lambda () (etaf-research-shelf--detail-view model form)))) :view
(column :class "research-shelf-detail" :width 'stretch :min-width 0
:flex-grow 2 :flex-shrink 1 :flex-basis '(340)
:padding '(2 2)
:border (etaf-theme-token :line)
:bgcolor (etaf-theme-token :panel)
(text :color (etaf-theme-token :accent)
(expr (etaf-playground-static-value
(plist-get (etaf-state) :form) :title "Selected item")))
(text :font-weight 'bold
(expr
(if-let* ((row
(etaf-research-shelf--selected
(plist-get (etaf-state) :model))))
(plist-get row :title)
"Choose a record")))
(text :color (etaf-theme-token :muted)
(expr
(if-let* ((row
(etaf-research-shelf--selected
(plist-get (etaf-state) :model))))
(format "%s · %s" (plist-get row :author) (plist-get row :kind))
"Select one row to inspect it.")))
(box :height 1)
(text :font-weight 'bold
(expr
(if-let* ((row
(etaf-research-shelf--selected
(plist-get (etaf-state) :model))))
(etaf-research-shelf--status-label (plist-get row :status))
"○ No selection")))
(text
(expr
(if-let* ((row
(etaf-research-shelf--selected
(plist-get (etaf-state) :model))))
(format "Progress %d%% · Priority %s"
(or (plist-get row :progress) 0)
(plist-get row :priority))
"Progress — · Priority —")))
(text :color (etaf-theme-token :accent)
(expr
(let* ((row
(etaf-research-shelf--selected
(plist-get (etaf-state) :model)))
(progress (or (and row (plist-get row :progress)) 0))
(filled (max 0 (min 10 (/ progress 10)))))
(format "%s %s" (make-string filled ?█)
(make-string (- 10 filled) ?░)))))
(box :height 1)
(text :color (etaf-theme-token :muted)
(expr
(if-let* ((row
(etaf-research-shelf--selected
(plist-get (etaf-state) :model))))
(concat "“" (or (plist-get row :note) "No note yet.") "”")
"Your notes and actions will appear here.")))
(box :height 1)
(etaf-research-shelf-detail-actions)))
(etaf-define-component etaf-research-shelf-detail-actions ()
"Render selected-record actions from the inherited Research Shelf model."
:setup
(etaf-inject 'research-shelf-model nil t)
:view
(flex :width 'stretch :flex-wrap 'wrap :gap '(1 (6))
(etaf-button
:label "+ 10%" :ref 'research-shelf-progress :variant 'secondary
:disabled
(let* ((row (etaf-research-shelf--selected (etaf-state)))
(progress (or (and row (plist-get row :progress)) 0)))
(or (null row) (equal (plist-get row :status) "archived")
(>= progress 100)))
:on-press
(let ((model (etaf-state)))
(lambda ()
(etaf-dispatch 'etaf-research-shelf-progress model))))
(etaf-button
:label "✓ Finish" :ref 'research-shelf-finish :variant 'secondary
:disabled
(let ((row (etaf-research-shelf--selected (etaf-state))))
(or (null row)
(not (null (member (plist-get row :status)
'("finished" "archived"))))))
:on-press
(let ((model (etaf-state)))
(lambda ()
(etaf-dispatch 'etaf-research-shelf-finish model))))
(etaf-button
:label "★ Star" :ref 'research-shelf-star :variant 'ghost
:disabled (null (etaf-research-shelf--selected (etaf-state)))
:on-press
(let ((model (etaf-state)))
(lambda ()
(etaf-dispatch 'etaf-research-shelf-star model))))
(etaf-button
:label "Archive" :ref 'research-shelf-archive :variant 'ghost
:disabled
(let ((row (etaf-research-shelf--selected (etaf-state))))
(or (null row) (equal (plist-get row :status) "archived")))
:on-press
(let ((model (etaf-state)))
(lambda ()
(etaf-dispatch 'etaf-research-shelf-archive model))))))
(etaf-define-component etaf-research-shelf-header () (etaf-define-component etaf-research-shelf-header ()
"Render the default `header' slot from App Context." "Render the default `header' slot from App Context."
:setup :setup
(let ((model (etaf-inject 'research-shelf-model nil t)) (list :model (etaf-inject 'research-shelf-model nil t)
(root-spec (etaf-inject 'research-shelf-root-spec nil t)) :root (etaf-inject 'research-shelf-root-spec nil t)
(header-spec (etaf-inject 'research-shelf-header-spec nil t))) :header (etaf-inject 'research-shelf-header-spec nil t))
(lambda () :view
(etaf-view (flex :class "research-shelf-header" :width 'stretch :min-width 0
(flex :flex-wrap 'wrap :align-items 'center :gap '(1 (10))
:class "research-shelf-header" :width 'stretch :min-width 0 (column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
:flex-wrap 'wrap :align-items 'center :gap '(1 (10)) (text :color (etaf-theme-token :accent)
(column (expr (etaf-playground-static-value
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0 (plist-get (etaf-state) :header) :eyebrow "Research Shelf")))
(label :text (etaf-playground-static-value (text :font-weight 'bold
header-spec :eyebrow "Research Shelf") (expr (etaf-playground-static-value
:color (etaf-theme-token :accent)) (plist-get (etaf-state) :root) :title "Research Shelf")))
(label :text (etaf-playground-static-value (text :color (etaf-theme-token :muted)
root-spec :title "Research Shelf") :font-weight 'bold) (expr (etaf-playground-static-value
(label :text (etaf-playground-static-value (plist-get (etaf-state) :root) :subtitle
root-spec :subtitle "A quiet place for unfinished ideas"))))
"A quiet place for unfinished ideas") (column :width 'max-content :min-width 0
:color (etaf-theme-token :muted))) :flex-grow 0 :flex-shrink 0
(column :width 'max-content :min-width 0 (etaf-checkbox
:flex-grow 0 :flex-shrink 0 :label "Dark" :ref 'research-shelf-theme-toggle
(checkbox :label "Dark" :ref 'research-shelf-theme-toggle :checked (plist-get (plist-get (etaf-state) :model) :dark)
:checked (plist-get model :dark) :on-change
:on-change (lambda (value) (let ((model (plist-get (etaf-state) :model)))
(setf (etaf-value (plist-get model :dark)) value) (lambda (value)
(setf (etaf-value (plist-get model :toast)) (setf (etaf-value (plist-get model :dark)) value)
(if value "Dark theme" "Light theme")))))))))) (setf (etaf-value (plist-get model :toast))
(if value "Dark theme" "Light theme"))))))))
(etaf-define-component etaf-research-shelf-footer () (etaf-define-component etaf-research-shelf-footer ()
"Render the default `footer' slot from App Context." "Render the default `footer' slot from App Context."
:setup :setup
(let ((model (etaf-inject 'research-shelf-model nil t)) (list :model (etaf-inject 'research-shelf-model nil t)
(footer-spec (etaf-inject 'research-shelf-footer-spec nil t))) :footer (etaf-inject 'research-shelf-footer-spec nil t))
(lambda () :view
(etaf-view (flex :class "research-shelf-footer" :width 'stretch
(flex :flex-wrap 'wrap :gap '(1 (8))
:class "research-shelf-footer" :width 'stretch (column :flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0
:flex-wrap 'wrap :gap '(1 (8)) (text
(column (expr
:flex-grow 1 :flex-shrink 1 :flex-basis '(0) :min-width 0 (etaf-value (plist-get (plist-get (etaf-state) :model) :toast))))
(label :text (plist-get model :toast)) (text :color (etaf-theme-token :muted)
(label :text (etaf-playground-static-value (expr (etaf-playground-static-value
footer-spec :label "SQLite · saved locally") (plist-get (etaf-state) :footer)
:color (etaf-theme-token :muted))) :label "SQLite · saved locally"))))
(label :text (file-name-nondirectory (text :color (etaf-theme-token :muted)
(plist-get model :database-file)) (expr (file-name-nondirectory
:color (etaf-theme-token :muted))))))) (plist-get (plist-get (etaf-state) :model) :database-file))))))
(etaf-define-component etaf-research-shelf-shell () (etaf-define-component etaf-research-shelf-shell ()
"Pure responsive layout shell with named content slots. "Pure responsive layout shell with named content slots.
@ -759,21 +797,16 @@ slot has a reusable built-in fallback for direct composition."
(etaf-provide 'research-shelf-footer-spec (etaf-provide 'research-shelf-footer-spec
(etaf-playground-static-child (etaf-playground-static-child
static-form 'research-shelf-footer-spec)) static-form 'research-shelf-footer-spec))
(lambda () nil)
(etaf-view :view
;; These are real ETAF named slot inputs; the `.etaf' manifest remains ;; These are real ETAF named slot inputs; the `.etaf' manifest remains inert
;; inert configuration and never pretends to be View syntax. ;; configuration and never pretends to be View syntax.
(etaf-research-shelf-shell (etaf-research-shelf-shell
(slot :name 'header (slot :name 'header (etaf-research-shelf-header))
(etaf-research-shelf-header)) (slot :name 'filters (etaf-research-shelf-filter-rail))
(slot :name 'filters (slot :name 'library (etaf-research-shelf-reading-list))
(etaf-research-shelf-filter-rail)) (slot :name 'detail (etaf-research-shelf-detail-inspector))
(slot :name 'library (slot :name 'footer (etaf-research-shelf-footer))))
(etaf-research-shelf-reading-list))
(slot :name 'detail
(etaf-research-shelf-detail-inspector))
(slot :name 'footer
(etaf-research-shelf-footer)))))))
;;; --------------------------------------------------------------------------- ;;; ---------------------------------------------------------------------------
;;; ROOT / PLAYGROUND REGISTRATION ;;; ROOT / PLAYGROUND REGISTRATION

44
scripts/benchmark-research-shelf.el
View File

@ -670,9 +670,13 @@ ETAF generation and preserve RUNTIME's mounted surface in BUFFER."
(unless (etaf-performance-evaluator--visible-match-p (unless (etaf-performance-evaluator--visible-match-p
buffer "Page 1 / 22") buffer "Page 1 / 22")
(etaf-dispatch-event runtime 'research-shelf-page-previous 'press)) (etaf-dispatch-event runtime 'research-shelf-page-previous 'press))
(let ((refs '(research-shelf-row-2 research-shelf-row-4 ;; Use one actionable reading per sample. Reusing a visible row
research-shelf-row-5 research-shelf-row-8 ;; eventually reaches 100% during the five warmups and would make a
research-shelf-row-9 research-shelf-row-10))) ;; real disabled button look like a failed mutation. Moving to the
;; target page is setup work and remains outside the timed action.
(let ((ids '(1 4 6 9 12 13 16 17 20 21 24 25 28 29 32 33
36 37 40 41 44 45 48 49 52 53 56 57 60 61 64
65 68 69 72)))
(push (push
(etaf-performance-evaluator--measure (etaf-performance-evaluator--measure
"progress-mutation" "progress-mutation"
@ -688,9 +692,39 @@ ETAF generation and preserve RUNTIME's mounted surface in BUFFER."
(etaf-performance-evaluator--surface-invariant (etaf-performance-evaluator--surface-invariant
runtime buffer "progress-mutation")) runtime buffer "progress-mutation"))
:setup (lambda (index) :setup (lambda (index)
(etaf-performance-evaluator--select-ref (let* ((id (nth
runtime (nth (% (1+ index) (length refs)) refs)))) (mod (+ index
etaf-performance-evaluator-warmup-count)
(length ids))
ids))
(target-page
(1+ (/ (1- id)
etaf-performance-evaluator-page-size)))
(current-page
(or (car
(etaf-performance-evaluator--visible-page
buffer))
1)))
(while (< current-page target-page)
(etaf-dispatch-event
runtime 'research-shelf-page-next 'press)
(setq current-page (1+ current-page)))
(while (> current-page target-page)
(etaf-dispatch-event
runtime 'research-shelf-page-previous 'press)
(setq current-page (1- current-page)))
(etaf-performance-evaluator--select-ref
runtime (intern (format "research-shelf-row-%d" id))))))
results)) results))
;; Progress setup traverses several pages to keep each action
;; enabled. Return to the first page before the shared focus and
;; add/reload scenarios, whose refs intentionally target page one.
(when-let* ((page (etaf-performance-evaluator--visible-page buffer)))
(while (> (car page) 1)
(etaf-dispatch-event
runtime 'research-shelf-page-previous 'press)
(setq page
(etaf-performance-evaluator--visible-page buffer))))
(push (push
(etaf-performance-evaluator--measure (etaf-performance-evaluator--measure

38
scripts/playground-gui-scenarios.el
View File

@ -14,6 +14,10 @@
(require 'benchmark-research-shelf) (require 'benchmark-research-shelf)
(require 'ebox-native-reflow) (require 'ebox-native-reflow)
(defvar etaf-research-shelf-database-file)
(defvar etaf-research-shelf-fixture-size)
(defvar etaf-research-shelf-page-size)
(defun etaf-playground-gui-scenarios--report (context) (defun etaf-playground-gui-scenarios--report (context)
"Return CONTEXT target's public Ebox report, or nil before mount." "Return CONTEXT target's public Ebox report, or nil before mount."
(let ((buffer (etaf-gui-verifier-context-target-buffer context))) (let ((buffer (etaf-gui-verifier-context-target-buffer context)))
@ -261,8 +265,10 @@
"scroll-reset" (= (window-start) (point-min))))))) "scroll-reset" (= (window-start) (point-min)))))))
(defun etaf-playground-gui-scenarios--research-event-action (defun etaf-playground-gui-scenarios--research-event-action
(id reference postcondition &optional screenshot) (id reference postcondition &optional screenshot assertion-name)
"Return Research action ID for REFERENCE, POSTCONDITION, and SCREENSHOT." "Return Research action ID for REFERENCE and POSTCONDITION.
When non-nil, SCREENSHOT requests visual evidence and ASSERTION-NAME names the
product-specific postcondition in the evidence stream."
(etaf-gui-verifier-action-create (etaf-gui-verifier-action-create
:id id :id id
:execute :execute
@ -304,7 +310,7 @@
"activated-host-focused" "activated-host-focused"
(equal reference (etaf-focused-host-ref runtime))) (equal reference (etaf-focused-host-ref runtime)))
(etaf-gui-verifier-assert (etaf-gui-verifier-assert
"product-postcondition" (or assertion-name "product-postcondition")
(funcall postcondition context))))) (funcall postcondition context)))))
:screenshot screenshot)) :screenshot screenshot))
@ -356,6 +362,22 @@
(string-match-p (string-match-p
"John Berger · Book" "John Berger · Book"
(etaf-playground-gui-scenarios--buffer-text context)))) (etaf-playground-gui-scenarios--buffer-text context))))
(etaf-playground-gui-scenarios--research-event-action
"data-mutation" 'research-shelf-progress
(lambda (context)
(let ((text
(etaf-playground-gui-scenarios--buffer-text context)))
(and (string-match-p "Progress saved" text)
(string-match-p "10%" text))))
t "progress-persisted")
(etaf-playground-gui-scenarios--research-event-action
"filter-reading" 'research-shelf-filter-reading
(lambda (context)
(let ((text
(etaf-playground-gui-scenarios--buffer-text context)))
(and (string-match-p "Showing Reading" text)
(string-match-p "Ways of Seeing" text))))
t "reading-filter-applied")
(etaf-playground-gui-scenarios--research-event-action (etaf-playground-gui-scenarios--research-event-action
"theme-toggle" 'research-shelf-theme-toggle "theme-toggle" 'research-shelf-theme-toggle
(lambda (context) (lambda (context)
@ -374,7 +396,7 @@
(etaf-playground-gui-scenarios--maximize-action)) (etaf-playground-gui-scenarios--maximize-action))
:completion :completion
(lambda (context) (lambda (context)
(= (etaf-gui-verifier-context-action-count context) 10)))) (= (etaf-gui-verifier-context-action-count context) 12))))
(defun etaf-playground-gui-scenarios-ebox (scenario fixture) (defun etaf-playground-gui-scenarios-ebox (scenario fixture)
"Return one Ebox SCENARIO adapter for FIXTURE." "Return one Ebox SCENARIO adapter for FIXTURE."
@ -431,6 +453,14 @@
(run-directory (or (getenv "ETAF_GUI_RUN_DIR") (run-directory (or (getenv "ETAF_GUI_RUN_DIR")
(error "ETAF_GUI_RUN_DIR is not configured"))) (error "ETAF_GUI_RUN_DIR is not configured")))
(fixture (getenv "ETAF_GUI_FIXTURE")) (fixture (getenv "ETAF_GUI_FIXTURE"))
(_research-fixture
(when (equal scenario "research-shelf")
(setq etaf-research-shelf-database-file
(expand-file-name "research-shelf.sqlite" run-directory)
etaf-research-shelf-fixture-size 256
etaf-research-shelf-page-size 12)
(when (file-exists-p etaf-research-shelf-database-file)
(delete-file etaf-research-shelf-database-file))))
(adapter (adapter
(pcase scenario (pcase scenario
("research-shelf" ("research-shelf"

39
tests/etaf-playground-tests.el
View File

@ -69,6 +69,15 @@ database and mounts a test buffer before running BODY."
(when (file-exists-p ,database) (when (file-exists-p ,database)
(delete-file ,database)))))) (delete-file ,database))))))
(defun etaf-playground-test--open (buffer)
"Mount Research Shelf in BUFFER with a deterministic headless viewport.
Text assertions should not depend on whether batch Ebox has a selected
window. GUI verification exercises responsive geometry separately on a real
frame."
(etaf-playground-mount-example
buffer "research-shelf" nil '(:viewport-width 1400 :viewport-height 80)))
(ert-deftest etaf-playground-framework-discovers-generic-file-triplets () (ert-deftest etaf-playground-framework-discovers-generic-file-triplets ()
"Discover examples from files without a business catalog in the framework." "Discover examples from files without a business catalog in the framework."
(should (member "research-shelf" etaf-playground-example-names)) (should (member "research-shelf" etaf-playground-example-names))
@ -395,11 +404,13 @@ database and mounts a test buffer before running BODY."
(replace-match ":title \"Research Shelf (edited)\"" t t) (replace-match ":title \"Research Shelf (edited)\"" t t)
(set-buffer-modified-p t)) (set-buffer-modified-p t))
(should (etaf-playground-refresh source)) (should (etaf-playground-refresh source))
(should (string-match-p "Research Shelf (edited)" (let* ((session (buffer-local-value 'etaf-playground-session source))
(etaf-playground-test--text (preview (etaf-playground-session-preview-buffer session))
(etaf-playground-session-preview-buffer (form (etaf-playground-read-static "research-shelf" session)))
(buffer-local-value 'etaf-playground-session (should (equal "Research Shelf (edited)"
source)))))))) (plist-get (cdr form) :title)))
(should (string-match-p "edited"
(etaf-playground-test--text preview)))))))
(ert-deftest etaf-playground-refresh-reloads-unsaved-el-companion () (ert-deftest etaf-playground-refresh-reloads-unsaved-el-companion ()
"Refreshing a dirty `.el' companion redefines its consumer intentionally." "Refreshing a dirty `.el' companion redefines its consumer intentionally."
@ -426,13 +437,11 @@ database and mounts a test buffer before running BODY."
(etaf-compiler-clear-cache) (etaf-compiler-clear-cache)
(let* ((before (etaf-compiler-statistics)) (let* ((before (etaf-compiler-statistics))
(instantiations (plist-get before :instantiations)) (instantiations (plist-get before :instantiations))
(fallbacks (plist-get before :fallbacks))
(cache-entries (plist-get before :static-cache-entries))) (cache-entries (plist-get before :static-cache-entries)))
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(let* ((after (etaf-compiler-statistics)) (let* ((after (etaf-compiler-statistics))
(blueprint (plist-get after :last-blueprint))) (blueprint (plist-get after :last-blueprint)))
(should (> (plist-get after :instantiations) instantiations)) (should (> (plist-get after :instantiations) instantiations))
(should (>= (plist-get after :fallbacks) fallbacks))
(should (> (plist-get after :static-cache-entries) cache-entries)) (should (> (plist-get after :static-cache-entries) cache-entries))
(should (> (plist-get blueprint :dynamic-nodes) 0)) (should (> (plist-get blueprint :dynamic-nodes) 0))
(should (> (plist-get blueprint :hole-count) 0)))))) (should (> (plist-get blueprint :hole-count) 0))))))
@ -440,7 +449,7 @@ database and mounts a test buffer before running BODY."
(ert-deftest etaf-playground-pair-mounts-sqlite-backed-surface () (ert-deftest etaf-playground-pair-mounts-sqlite-backed-surface ()
"Mounting the pair initializes SQLite and renders the real app shell." "Mounting the pair initializes SQLite and renders the real app shell."
(etaf-playground-test--with-app (buffer database) (etaf-playground-test--with-app (buffer database)
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(should (etaf-runtime-p (etaf-runtime-for-buffer buffer))) (should (etaf-runtime-p (etaf-runtime-for-buffer buffer)))
(should (file-exists-p database)) (should (file-exists-p database))
(let ((text (etaf-playground-test--text buffer)) (let ((text (etaf-playground-test--text buffer))
@ -492,7 +501,7 @@ database and mounts a test buffer before running BODY."
(ert-deftest etaf-playground-row-selection-is-repeatable () (ert-deftest etaf-playground-row-selection-is-repeatable ()
"Repeated DataGrid row presses replace one selected identity." "Repeated DataGrid row presses replace one selected identity."
(etaf-playground-test--with-app (buffer database) (etaf-playground-test--with-app (buffer database)
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(let ((runtime (etaf-runtime-for-buffer buffer))) (let ((runtime (etaf-runtime-for-buffer buffer)))
(dolist (entry '((research-shelf-row-1 research-shelf-row-2 (dolist (entry '((research-shelf-row-1 research-shelf-row-2
"The best tools make attention feel larger") "The best tools make attention feel larger")
@ -526,7 +535,7 @@ database and mounts a test buffer before running BODY."
(ert-deftest etaf-playground-row-observer-on-off-is-exact () (ert-deftest etaf-playground-row-observer-on-off-is-exact ()
"Observation preserves one real row mutation and its retained identity." "Observation preserves one real row mutation and its retained identity."
(etaf-playground-test--with-app (buffer database) (etaf-playground-test--with-app (buffer database)
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(let* ((runtime (etaf-runtime-for-buffer buffer)) (let* ((runtime (etaf-runtime-for-buffer buffer))
(surface (surface
(lambda () (lambda ()
@ -578,7 +587,7 @@ database and mounts a test buffer before running BODY."
(ert-deftest etaf-playground-filters-and-pagination-reload-data () (ert-deftest etaf-playground-filters-and-pagination-reload-data ()
"Filter and pager refs drive the SQLite-backed Data Controller." "Filter and pager refs drive the SQLite-backed Data Controller."
(etaf-playground-test--with-app (buffer database) (etaf-playground-test--with-app (buffer database)
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(let ((runtime (etaf-runtime-for-buffer buffer))) (let ((runtime (etaf-runtime-for-buffer buffer)))
;; Move the selected identity through the old page first. The following ;; Move the selected identity through the old page first. The following
;; filter reorders keyed Range items; generated cell Host addresses must ;; filter reorders keyed Range items; generated cell Host addresses must
@ -621,7 +630,7 @@ database and mounts a test buffer before running BODY."
(ert-deftest etaf-playground-workspace-reflows-at-responsive-widths () (ert-deftest etaf-playground-workspace-reflows-at-responsive-widths ()
"Workspace cards share a row when wide and wrap in document order." "Workspace cards share a row when wide and wrap in document order."
(etaf-playground-test--with-app (buffer database) (etaf-playground-test--with-app (buffer database)
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(cl-labels (cl-labels
((line-of (label) ((line-of (label)
(with-current-buffer buffer (with-current-buffer buffer
@ -652,7 +661,7 @@ database and mounts a test buffer before running BODY."
(ert-deftest etaf-playground-mutations-persist-and-refresh () (ert-deftest etaf-playground-mutations-persist-and-refresh ()
"Add and mutate actions persist through the SQLite source and refresh UI." "Add and mutate actions persist through the SQLite source and refresh UI."
(etaf-playground-test--with-app (buffer database) (etaf-playground-test--with-app (buffer database)
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(let ((runtime (etaf-runtime-for-buffer buffer))) (let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-dispatch-event runtime 'research-shelf-row-1 'press) (etaf-dispatch-event runtime 'research-shelf-row-1 'press)
(etaf-dispatch-event runtime 'research-shelf-progress 'press) (etaf-dispatch-event runtime 'research-shelf-progress 'press)
@ -675,7 +684,7 @@ database and mounts a test buffer before running BODY."
(ert-deftest etaf-playground-theme-and-lifecycle-are-repeatable () (ert-deftest etaf-playground-theme-and-lifecycle-are-repeatable ()
"Theme changes and reset/close do not leave a stale mounted runtime." "Theme changes and reset/close do not leave a stale mounted runtime."
(etaf-playground-test--with-app (buffer database) (etaf-playground-test--with-app (buffer database)
(etaf-playground-open buffer) (etaf-playground-test--open buffer)
(let ((runtime (etaf-runtime-for-buffer buffer))) (let ((runtime (etaf-runtime-for-buffer buffer)))
(etaf-dispatch-event runtime 'research-shelf-row-1 'press) (etaf-dispatch-event runtime 'research-shelf-row-1 'press)
(let (dark-output light-output) (let (dark-output light-output)

92
tests/playground-gui-scenarios-tests.el Normal file
View File

@ -0,0 +1,92 @@
;;; playground-gui-scenarios-tests.el --- GUI scenario contracts -*- lexical-binding: t; -*-
;;; Commentary:
;; These tests keep the Research Shelf GUI action matrix aligned with the M0a
;; evidence claim without running a graphical Emacs session.
;;; Code:
(require 'cl-lib)
(require 'ert)
(add-to-list 'load-path (expand-file-name "../etaf/scripts" default-directory))
(add-to-list 'load-path (expand-file-name "../ebox-playground" default-directory))
(require 'playground-gui-scenarios)
(defvar etaf-research-shelf-database-file)
(defvar etaf-research-shelf-fixture-size)
(defvar etaf-research-shelf-page-size)
(defun etaf-playground-gui-test--action (scenario id)
"Return SCENARIO action named ID."
(cl-find id (etaf-gui-verifier-scenario-actions scenario)
:key #'etaf-gui-verifier-action-id :test #'equal))
(ert-deftest etaf-playground-gui-research-covers-public-action-matrix ()
"Research Shelf covers every required public M0a interaction in order."
(let* ((scenario (etaf-playground-gui-scenarios-research))
(actions (etaf-gui-verifier-scenario-actions scenario)))
(should
(equal
(mapcar #'etaf-gui-verifier-action-id actions)
'("mount" "leave-fullscreen" "resize-narrow" "scroll-down"
"reset-scroll" "resize-wide" "row-select" "data-mutation"
"filter-reading" "theme-toggle" "pagination"
"maximize-frame")))
(should
(funcall
(etaf-gui-verifier-scenario-completion scenario)
(etaf-gui-verifier--context-create
:scenario scenario :action-count (length actions))))))
(ert-deftest etaf-playground-gui-research-names-product-assertions ()
"Public filter and mutation actions publish specific passing assertions."
(let ((database (make-temp-file "etaf-gui-research-" nil ".sqlite"))
(buffer " *etaf-gui-research-test*"))
(unwind-protect
(let* ((etaf-research-shelf-database-file database)
(etaf-research-shelf-fixture-size 32)
(etaf-research-shelf-page-size 12)
(scenario (etaf-playground-gui-scenarios-research))
context)
(ignore etaf-research-shelf-database-file
etaf-research-shelf-fixture-size
etaf-research-shelf-page-size)
(etaf-playground-mount-example
buffer "research-shelf" nil
'(:viewport-width 1400 :viewport-height 80))
(switch-to-buffer buffer)
(setq context
(etaf-gui-verifier--context-create
:scenario scenario :target-buffer (get-buffer buffer)))
(dolist (entry '(("row-select")
("data-mutation" . "progress-persisted")
("filter-reading" . "reading-filter-applied")))
(let ((id (car entry))
(assertion-name (cdr entry)))
(let ((action
(etaf-playground-gui-test--action scenario id)))
(should action)
(funcall (etaf-gui-verifier-action-execute action) context)
(should
(funcall
(etaf-gui-verifier-action-settled-p action) context))
(when assertion-name
(let* ((assertions
(funcall
(etaf-gui-verifier-action-assertions action)
context))
(assertion
(cl-find
assertion-name assertions
:key (lambda (item) (alist-get 'name item))
:test #'equal)))
(should assertion)
(should (alist-get 'passed assertion))))))))
(when (get-buffer buffer)
(etaf-playground-close buffer))
(when (file-exists-p database)
(delete-file database)))))
(provide 'playground-gui-scenarios-tests)
;;; playground-gui-scenarios-tests.el ends here