Amr Gharbeia
9a4d117eee
The select widget (filtered option list) was only used by the dialog system. Merging removes an entire package boundary, simplifies the dependency chain, and reduces the library from 12 packages to 11. Changes: - absorb select class, accessors, filter, navigation, key handling, rendering, fuzzy matching, and all tests into dialog.org - update cl-tty.dialog package to use cl-tty.box (for dirty-mixin) and cl-tty.layout (for layout-node) - remove select.org, select-package.lisp, select.lisp, select-tests - update ASDF, run-all-tests.lisp, scripts to drop select references - update integration tests to use cl-tty.dialog instead of cl-tty.select All 13 test suites pass at 100%.
26 KiB
26 KiB
Dialog System + Toast (v0.9.0)
- Overview
- Package definition
- Special variables
- Dialog class
- Dialog convenience constructors
- Select widget (absorbed from cl-tty.select)
- Toast system
- Tests
Overview
Modal overlays (dialogs) and transient notifications (toasts).
Dialogs are absolute-positioned panels centered on a dimmed backdrop. They stack — a new dialog goes on top, Esc dismisses the top one.
Toasts are non-blocking notifications that auto-dismiss after a duration. They stack in the top-right corner.
Design decisions
- Stack-based dialog management: a
*dialog-stack*special variable holds the active dialogs. Render walks the stack from bottom to top, drawing each dialog's backdrop over the previous one. This means two dialogs visible at once — the top one gets full interaction. - Backdrop is a solid dim color, not semi-transparent: true transparency requires compositing pixel buffers, which is expensive in the terminal. A solid dimmed color over the full screen width communicates "modal" without the complexity.
- Dialogs are components, not separate windows: they integrate into the existing render tree. The dialog class inherits from the component base and participates in dirty tracking, z-order, etc.
- Toast is fire-and-forget:
(toast ...)creates a toast component, adds it to a toast list, and schedules auto-dismissal. No lifecycle management needed from the caller.
Contract
dialogclass — overlay component with backdrop, border, title*dialog-stack*— list of active dialogs (bound per-screen)push-dialog dialog— add dialog to stack, focus its first inputpop-dialog— dismiss top dialog, fire :on-dismiss(alert-dialog title message)— OK-button alert(confirm-dialog title message &key on-yes on-no)— Yes/No/Cancel(select-dialog title options &key on-select)— modal Select(prompt-dialog title &key on-submit)— modal TextInputtoastcomponent — transient notification with variant color(toast message &key variant duration)— fire-and-forget toast
Package definition
The cl-tty.dialog package uses the backend, input, and select
subsystems. All public symbols are exported for user convenience.
;;; dialog-package.lisp — Package definition for cl-tty.dialog
(defpackage :cl-tty.dialog
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.box :cl-tty.layout)
(:export
;; Dialog
#:dialog
#:dialog-title
#:dialog-content
#:dialog-on-dismiss
#:dialog-size
#:dialog-size-pixels
#:render-dialog
#:push-dialog
#:pop-dialog
#:*dialog-stack*
#:alert-dialog
#:confirm-dialog
#:select-dialog
#:prompt-dialog
;; Toast
#:toast
#:toast-message
#:toast-variant
#:render-toast
#:dismiss-toast
#:*toasts*
;; Select widget (merged from cl-tty.select)
#:select #:make-select
#:select-options #:select-filter
#:select-selected-index #:select-on-select
#:select-layout-node
#:select-filtered-options
#:select-next #:select-prev
#:select-visible-options
#:select-handle-key
#:render
#:fuzzy-match-p))Special variables
dialog-stack
The active dialog stack. push-dialog conses onto this list;
pop-dialog pops it and fires the :on-dismiss callback. Each screen
should bind its own instance so multiple screens can have independent
dialog states.
(in-package :cl-tty.dialog)
(defvar *dialog-stack* nil
"Stack of active dialogs. (list) of dialog instances.")toasts
List of active toast notifications. toast pushes, dismiss-toast
removes by identity. The render loop walks this list to draw toasts in
the top-right corner.
(defvar *toasts* nil
"List of active toast notifications.")Dialog class
The core dialog class stores a title, a size preset, the content
component to render inside the panel, and an optional :on-dismiss
callback invoked when the dialog is popped.
(defclass dialog ()
((title :initarg :title :accessor dialog-title)
(size :initarg :size :initform :medium :accessor dialog-size)
(content :initarg :content :initform nil :accessor dialog-content)
(on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss)))dialog-size-pixels
Converts a size keyword (:small, :medium, :large) to pixel
dimensions. Accepts optional max-w / max-h to clamp the result to
terminal bounds, preventing off-screen overflow (fixed in v1.0.0).
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
(multiple-value-bind (dw dh)
(case size
(:small (values 40 8))
(:medium (values 60 16))
(:large (values 88 24))
(t (values 60 16)))
(values (min dw max-w) (min dh max-h))))render-dialog
Renders a dialog: draws a dimmed full-screen backdrop using
draw-rect, then draws the bordered dialog panel centered on screen.
Content is rendered via draw-text inside the panel area.
(defun render-dialog (dialog screen w h)
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
(let ((x (floor (- w dw) 2))
(y (floor (- h dh) 2)))
;; Backdrop — dim the full screen
(dotimes (row h)
(draw-rect screen 0 row w 1 :bg :bright-black))
;; Dialog panel
(draw-border screen x y dw dh :style :single :title (dialog-title dialog))
(when (dialog-content dialog)
;; Content rendering delegated to component system
(draw-text screen (1+ x) (1+ y)
(format nil "~a" (dialog-content dialog))
:white :default)))))push-dialog
Pushes a dialog onto *dialog-stack*. Returns the dialog for chaining.
(defun push-dialog (dialog)
(push dialog *dialog-stack*)
dialog)pop-dialog
Pops the top dialog from the stack. If an :on-dismiss callback is
set on the dialog, it is called before returning.
(defun pop-dialog ()
(when *dialog-stack*
(let ((dialog (pop *dialog-stack*)))
(when (dialog-on-dismiss dialog)
(funcall (dialog-on-dismiss dialog)))
dialog)))Dialog convenience constructors
These factory functions create common dialog variants by composing the
dialog class with interactive components (select, text-input).
alert-dialog
Simple alert with title, message, and an OK button. The button is a
select with a single "OK" option. Dismissing fires pop-dialog on
both selection and backdrop dismiss.
(defun alert-dialog (title message)
(make-instance 'dialog
:title title
:size :small
:content (make-instance 'select
:options (list (list :title "OK" :value :ok))
:on-select (lambda (opt) (declare (ignore opt)) (pop-dialog)))
:on-dismiss (lambda () (pop-dialog))))confirm-dialog
Confirm dialog with Yes/No buttons. Returns :yes or :no via the
on-yes~/~on-no callbacks. The dialog auto-dismisses on selection.
(defun confirm-dialog (title message &key on-yes on-no)
(make-instance 'dialog
:title title
:size :small
:content (make-instance 'select
:options (list (list :title "Yes" :value :yes)
(list :title "No" :value :no))
:on-select (lambda (opt)
(pop-dialog)
(if (eql opt :yes)
(when on-yes (funcall on-yes))
(when on-no (funcall on-no)))))))select-dialog
Modal wrapper around the select component. Presents a list of options
and calls on-select with the chosen value after dismissing.
(defun select-dialog (title options &key on-select)
(make-instance 'dialog
:title title
:size :medium
:content (make-instance 'select
:options options
:on-select (lambda (opt)
(pop-dialog)
(when on-select (funcall on-select opt))))))prompt-dialog
Modal wrapper around text-input. Shows a text input field inside the
dialog and calls on-submit with the entered value after dismissing.
(defun prompt-dialog (title &key on-submit)
(make-instance 'dialog
:title title
:size :small
:content (make-instance 'text-input
:on-submit (lambda (value)
(pop-dialog)
(when on-submit (funcall on-submit value))))))Select widget (absorbed from cl-tty.select)
A selection list component — the building block for command palettes, theme
pickers, and file pickers. Options are plists with :title, :value, and
optional :category fields.
Select class
(defclass select (dirty-mixin)
((options :initform nil :initarg :options
:accessor select-options :type list)
(filter :initform nil :initarg :filter
:accessor select-filter :type (or string null))
(selected-index :initform 0 :initarg :selected-index
:accessor select-selected-index :type fixnum)
(on-select :initform nil :initarg :on-select
:accessor select-on-select)
(layout-node :initform (make-layout-node) :initarg :layout-node
:accessor select-layout-node)))make-select
(defun make-select (&key options filter on-select)
(make-instance 'select
:options (or options nil)
:filter filter
:on-select on-select))component-layout-node
(defmethod component-layout-node ((sel select))
(select-layout-node sel))select-filtered-options
(defun select-filtered-options (sel)
"Return list of options matching the current filter, in display order.
Each item: (display-index original-index option-plist)."
(let* ((filter (select-filter sel))
(all-options (select-options sel))
(filtered (if (null filter)
all-options
(let ((lower (string-downcase filter)))
(remove-if-not
(lambda (opt)
(or (getf opt :category)
(let ((title (string-downcase (getf opt :title))))
(or (search lower title)
(fuzzy-match-p lower title)))))
all-options)))))
(loop for opt in filtered
for i from 0
collect (list i (position opt all-options) opt))))fuzzy-match-p
(defun fuzzy-match-p (query target)
"T if character-set Jaccard similarity exceeds threshold (0.3)."
(let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list)))
(t-chars (remove-duplicates (coerce (string-downcase target) 'list)))
(intersection (length (intersection q-chars t-chars)))
(union (length (union q-chars t-chars))))
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))select-clamp-index
(defun select-clamp-index (sel)
"Ensure selected-index is valid. Wraps if empty."
(let* ((filtered (select-filtered-options sel))
(count (length filtered)))
(if (zerop count)
(setf (select-selected-index sel) 0)
(setf (select-selected-index sel)
(max 0 (min (select-selected-index sel) (1- count)))))))select-next / select-prev
(defun select-next (sel)
"Move selection to next non-category option. Wraps at end."
(let* ((filtered (select-filtered-options sel))
(count (length filtered))
(current (select-selected-index sel)))
(when (plusp count)
(loop for i from 1 below count
for idx = (mod (+ current i) count)
for opt = (third (nth idx filtered))
when (not (getf opt :category))
do (setf (select-selected-index sel) idx)
(mark-dirty sel)
(return)))))
(defun select-prev (sel)
"Move selection to previous non-category option. Wraps at start."
(let* ((filtered (select-filtered-options sel))
(count (length filtered))
(current (select-selected-index sel)))
(when (plusp count)
(loop for i from 1 below count
for idx = (mod (- current i) count)
for opt = (third (nth idx filtered))
when (not (getf opt :category))
do (setf (select-selected-index sel) idx)
(mark-dirty sel)
(return)))))select-handle-key
(defun select-handle-key (sel event)
"Handle a key-event. Returns T if handled."
(let ((key (key-event-key event))
(ctrl (key-event-ctrl event)))
(cond
((or (eql key :down) (and ctrl (eql key :n)))
(select-next sel) t)
((or (eql key :up) (and ctrl (eql key :p)))
(select-prev sel) t)
((eql key :enter)
(let* ((filtered (select-filtered-options sel))
(idx (select-selected-index sel))
(item (when (< idx (length filtered))
(third (nth idx filtered)))))
(when item
(let ((cb (select-on-select sel)))
(when cb (funcall cb item))))
t))
((eql key :escape) nil)
(t nil))))select-visible-options
(defun select-visible-options (sel)
"Return filtered options that fit within the viewport."
(let* ((ln (select-layout-node sel))
(height (if ln (layout-node-height ln) 80))
(filtered (select-filtered-options sel))
(sel-idx (select-selected-index sel))
(half (floor (1- height) 2))
(start (max 0 (- sel-idx half)))
(end (min (length filtered) (+ start height))))
(subseq filtered start end)))Render method for select
(defmethod render ((sel select) backend)
(let* ((ln (select-layout-node sel))
(x (if ln (layout-node-x ln) 0))
(y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(visible (select-visible-options sel))
(sel-idx (select-selected-index sel)))
(dolist (item visible)
(let* ((display-idx (first item))
(option (third item))
(title (getf option :title))
(is-category (getf option :category))
(is-selected (eql display-idx sel-idx))
(display (if (> (length title) (1- w))
(concatenate 'string (subseq title 0 (1- w)) "…")
title)))
(cond
(is-category
(draw-text backend x y display :text-muted nil))
(is-selected
(draw-rect backend x y w 1 :bg :accent)
(draw-text backend x y display :background :accent))
(t
(draw-text backend x y display nil nil)))
(incf y 1)))
(values)))Toast system
Transient notifications that appear in the top-right corner. Each toast
has a message and a variant that determines its color (:info,
:success, :warning, :error).
toast class
Lightweight class storing the message text and variant keyword.
(defclass toast ()
((message :initarg :message :accessor toast-message)
(variant :initarg :variant :initform :info :accessor toast-variant)))render-toast
Draws a toast in the top-right corner of the screen. The message is truncated to 60 columns with an ellipsis if necessary. The background color reflects the variant.
(defun render-toast (toast screen w)
(let* ((msg (toast-message toast))
(variant (toast-variant toast))
(color (case variant
(:info :blue) (:success :green)
(:warning :yellow) (:error :red)))
(max-w (min 60 (1- w)))
(x (- w max-w 1))
(text (if (> (length msg) (- max-w 2))
(concatenate 'string (subseq msg 0 (- max-w 5)) "...")
msg)))
(draw-rect screen x 0 max-w 1 :bg color)
(draw-text screen (1+ x) 0 text :white color :bold t)))toast (function)
Fire-and-forget toast notification. Creates a toast instance, pushes
it onto =*toasts*~, and optionally schedules auto-dismissal via
dismiss-toast when duration is positive.
(defun toast (message &key (variant :info) (duration 0))
(let ((toast (make-instance 'toast :message message :variant variant)))
(push toast *toasts*)
(when (plusp duration) (dismiss-toast toast))
toast))dismiss-toast
Removes a toast from =*toasts*~ by identity (remove with default
:test #'eql compares by pointer for CLOS objects).
(defun dismiss-toast (toast)
(setf *toasts* (remove toast *toasts*)))Tests
Test suite using FiveAM. Each test exercises one function or interaction.
Test package and suite
;;; dialog-tests.lisp — Tests for cl-tty.dialog
(defpackage :cl-tty-dialog-test
(:use :cl :cl-tty.dialog :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.input)
(:export #:run-tests))
(in-package :cl-tty-dialog-test)
(def-suite dialog-suite :description "Dialog + Toast + Select tests")
(in-suite dialog-suite)
(defun run-tests ()
(let ((result (run 'dialog-suite)))
(fiveam:explain! result)
(uiop:quit 0)))dialog-create
Basic dialog instantiation — verifies make-instance and accessors.
(def-test dialog-create ()
(let ((d (make-instance 'dialog :title "Test")))
(is-true (typep d 'dialog))
(is (equal "Test" (dialog-title d)))))dialog-size-small
dialog-size-pixels returns the correct dimensions for :small.
(def-test dialog-size-small ()
(multiple-value-bind (w h) (dialog-size-pixels :small)
(is (= 40 w))
(is (= 8 h))))dialog-size-medium
dialog-size-pixels returns the correct dimensions for :medium.
(def-test dialog-size-medium ()
(multiple-value-bind (w h) (dialog-size-pixels :medium)
(is (= 60 w))
(is (= 16 h))))dialog-push-pop
Verifies stack operations: push adds to =*dialog-stack*~, pop removes the top element.
(def-test dialog-push-pop ()
(let ((*dialog-stack* nil))
(push-dialog (make-instance 'dialog :title "D1"))
(is (= 1 (length *dialog-stack*)))
(push-dialog (make-instance 'dialog :title "D2"))
(is (= 2 (length *dialog-stack*)))
(pop-dialog)
(is (= 1 (length *dialog-stack*)))))toast-create
Verifies that toast pushes onto =*toasts*~.
(def-test toast-create ()
(let ((*toasts* nil))
(toast "Hello" :variant :info :duration 0)
(is (= 1 (length *toasts*)))))toast-dismiss
Verifies that dismiss-toast removes the toast from =*toasts*~.
(def-test toast-dismiss ()
(let ((*toasts* (list (make-instance 'toast :message "T" :variant :info))))
(dismiss-toast (first *toasts*))
(is (= 0 (length *toasts*)))))Select tests (merged from cl-tty.select)
select-creates
(test select-creates
"A Select can be created with defaults."
(let ((sel (make-select)))
(is (typep sel 'select))
(is-false (select-options sel))
(is-false (select-filter sel))
(is (= (select-selected-index sel) 0))))select-with-options
(test select-with-options
"A Select stores options."
(let ((sel (make-select :options '((:title "Red" :value :red)
(:title "Blue" :value :blue)))))
(is (= (length (select-options sel)) 2))))select-filtered-exact
(test select-filtered-exact
"Filter returns case-insensitive substring matches."
(let ((sel (make-select
:options '((:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Blue" :value :blue)))))
(setf (select-filter sel) "bl")
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :blue)))))select-filtered-all
(test select-filtered-all
"Nil filter returns all options."
(let ((sel (make-select
:options '((:title "Red" :value :red)
(:title "Blue" :value :blue)))))
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 2)))))select-navigation
(test select-navigation
"Select-next and select-prev navigate through options."
(let ((sel (make-select
:options '((:title "A" :value :a)
(:title "B" :value :b)
(:title "C" :value :c)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1))
(select-next sel)
(is (= (select-selected-index sel) 2))
(select-next sel)
(is (= (select-selected-index sel) 0) "wraps forward")
(select-prev sel)
(is (= (select-selected-index sel) 2) "wraps backward")))select-navigation-skips-categories
(test select-navigation-skips-categories
"Navigation skips category header options."
(let ((sel (make-select
:options '((:title "Colors" :category t)
(:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Shapes" :category t)
(:title "Circle" :value :circle)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1) "skipped category header at 0")
(select-next sel)
(is (= (select-selected-index sel) 2))
(select-next sel)
(is (= (select-selected-index sel) 4) "skipped category header at 3")))select-handle-key
(test select-handle-key
"Select handle-key dispatches navigation and selection."
(let* ((result (list nil))
(sel (make-select
:options '((:title "A" :value :a) (:title "B" :value :b))
:on-select (lambda (opt) (setf (car result) (getf opt :value))))))
(select-handle-key sel (make-key-event :key :down))
(is (= (select-selected-index sel) 1))
(select-handle-key sel (make-key-event :key :up))
(is (= (select-selected-index sel) 0))
(select-handle-key sel (make-key-event :key :enter))
(is (eql (car result) :a))))select-handle-key-ctrl
(test select-handle-key-ctrl
"Ctrl+N and Ctrl+P navigate like down/up."
(let ((sel (make-select
:options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c)))))
(select-handle-key sel (make-key-event :key :n :ctrl t))
(is (= (select-selected-index sel) 1))
(select-handle-key sel (make-key-event :key :p :ctrl t))
(is (= (select-selected-index sel) 0))))select-visible-count
(test select-visible-count
"Visible options respects viewport height."
(let* ((ln (make-layout-node))
(sel (make-select
:options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i)))))
(setf (select-layout-node sel) ln)
(setf (layout-node-height ln) 5)
(let ((visible (select-visible-options sel)))
(is (<= (length visible) 5)))))select-fuzzy-fallback
(test select-fuzzy-fallback
"Fuzzy filter catches near-misses."
(let ((sel (make-select
:options '((:title "Nord" :value :nord)
(:title "Tokyo Night" :value :tokyo)
(:title "Catppuccin" :value :cat)))))
(setf (select-filter sel) "nrd")
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :nord)))))