Amr Gharbeia
94df17a7b9
- render-select-minibuffer: new function for bottom-anchored dialog panel (minibuffer style), accepts colors plist for theme integration - handle-text-input: guard code-char against nil key-event-code to prevent crash on CSI escape sequences (arrow keys)
28 KiB
28 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
#:render-select-minibuffer
#: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)))))render-select-minibuffer
Renders a select widget as a bottom-anchored minibuffer panel at the
given position. The panel fills a rectangular area, draws a separator
line with the title at the top, the filtered options in the middle,
and a filter input line (>= ...) at the bottom. colors is a plist
with keys :bg-panel, :separator, :accent, :text-muted,
:agent-fg, :input-fg, :bg-input, :input-prompt.
(defun render-select-minibuffer (be x y width height select title colors)
(let* ((filtered (select-filtered-options select))
(sel-idx (or (select-selected-index select) 0))
(filter (select-filter select))
(bg-p (getf colors :bg-panel))
(sep-c (getf colors :separator)))
(dotimes (r height)
(draw-rect be x (+ y r) width 1 :bg bg-p))
(draw-text be x y (make-string width :initial-element #\─) sep-c bg-p)
(draw-text be (1+ x) y title (getf colors :accent) bg-p)
(loop for item in filtered
for i from 1
for display-idx = (first item)
for option = (third item)
for opt-title = (getf option :title)
for cat = (getf option :category)
for sel-p = (eql display-idx sel-idx)
for row = (+ y i)
while (< row (+ y (min height (length filtered))))
do (cond
(sel-p
(draw-rect be (1+ x) row (1- width) 1
:bg (getf colors :input-fg))
(draw-text be (1+ x) row
(format nil " >> ~a" opt-title)
(getf colors :bg-input)
(getf colors :input-fg)))
(cat
(draw-text be (1+ x) row
(format nil " ~a" opt-title)
(getf colors :text-muted) bg-p))
(t
(draw-text be (1+ x) row
(format nil " ~a" opt-title)
(getf colors :agent-fg) bg-p))))
(let ((filter-y (+ y (- height 3))))
(draw-rect be x filter-y width 1 :bg bg-p)
(draw-text be x filter-y
(format nil "> ~a" (or filter ""))
(getf colors :input-prompt) bg-p))))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)))))