v1.0.0: merge select → dialog — eliminate cl-tty.select package
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%.
This commit is contained in:
367
org/dialog.org
367
org/dialog.org
@@ -54,8 +54,9 @@ 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.select)
|
||||
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.box :cl-tty.layout)
|
||||
(:export
|
||||
;; Dialog
|
||||
#:dialog
|
||||
#:dialog-title
|
||||
#:dialog-content
|
||||
@@ -70,12 +71,24 @@ subsystems. All public symbols are exported for user convenience.
|
||||
#:confirm-dialog
|
||||
#:select-dialog
|
||||
#:prompt-dialog
|
||||
;; Toast
|
||||
#:toast
|
||||
#:toast-message
|
||||
#:toast-variant
|
||||
#:render-toast
|
||||
#:dismiss-toast
|
||||
#:*toasts*))
|
||||
#:*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))
|
||||
#+END_SRC
|
||||
|
||||
* Special variables
|
||||
@@ -258,6 +271,196 @@ dialog and calls ~on-submit~ with the entered value after dismissing.
|
||||
(when on-submit (funcall on-submit value))))))
|
||||
#+END_SRC
|
||||
|
||||
* 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
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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)))
|
||||
#+END_SRC
|
||||
|
||||
** make-select
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select
|
||||
:options (or options nil)
|
||||
:filter filter
|
||||
:on-select on-select))
|
||||
#+END_SRC
|
||||
|
||||
** component-layout-node
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(defmethod component-layout-node ((sel select))
|
||||
(select-layout-node sel))
|
||||
#+END_SRC
|
||||
|
||||
** select-filtered-options
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
** fuzzy-match-p
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
** select-clamp-index
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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)))))))
|
||||
#+END_SRC
|
||||
|
||||
** select-next / select-prev
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
** select-handle-key
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
** select-visible-options
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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)))
|
||||
#+END_SRC
|
||||
|
||||
** Render method for select
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
|
||||
(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)))
|
||||
#+END_SRC
|
||||
|
||||
* Toast system
|
||||
|
||||
Transient notifications that appear in the top-right corner. Each toast
|
||||
@@ -331,12 +534,18 @@ interaction.
|
||||
;;; dialog-tests.lisp — Tests for cl-tty.dialog
|
||||
|
||||
(defpackage :cl-tty-dialog-test
|
||||
(:use :cl :cl-tty.dialog :fiveam))
|
||||
(: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 tests for cl-tty.dialog")
|
||||
(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)))
|
||||
#+END_SRC
|
||||
|
||||
** dialog-create
|
||||
@@ -409,3 +618,153 @@ Verifies that ~dismiss-toast~ removes the toast from =*toasts*~.
|
||||
(dismiss-toast (first *toasts*))
|
||||
(is (= 0 (length *toasts*)))))
|
||||
#+END_SRC
|
||||
|
||||
** Select tests (merged from cl-tty.select)
|
||||
|
||||
*** select-creates
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** select-with-options
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** select-filtered-exact
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
*** select-filtered-all
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
*** select-navigation
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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")))
|
||||
#+END_SRC
|
||||
|
||||
*** select-navigation-skips-categories
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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")))
|
||||
#+END_SRC
|
||||
|
||||
*** select-handle-key
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** select-handle-key-ctrl
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** select-visible-count
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
*** select-fuzzy-fallback
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
@@ -50,7 +50,7 @@ package, so the symbol must be interned and accessible.
|
||||
(defpackage :cl-tty-integration-test
|
||||
(:use :cl :fiveam
|
||||
:cl-tty.backend :cl-tty.box :cl-tty.layout
|
||||
:cl-tty.input :cl-tty.select :cl-tty.container
|
||||
:cl-tty.input :cl-tty.container
|
||||
:cl-tty.rendering :cl-tty.dialog))
|
||||
|
||||
(in-package :cl-tty-integration-test)
|
||||
|
||||
599
org/select.org
599
org/select.org
@@ -1,599 +0,0 @@
|
||||
#+TITLE: cl-tty v0.7.0 — Select Dropdown + Fuzzy Filter
|
||||
#+STARTUP: content
|
||||
|
||||
* Select Widget
|
||||
|
||||
A selection list component — the building block for command palettes, theme
|
||||
pickers, agent selectors, and file pickers. Options are plists with ~:title~,
|
||||
~:value~, and optional ~:category~ fields.
|
||||
|
||||
The widget supports keyboard navigation (Up/Down, Ctrl+P/N, Enter, Esc),
|
||||
option filtering by case-insensitive substring match with trigram fuzzy
|
||||
fallback, and category grouping with dimmed headers.
|
||||
|
||||
** Contract
|
||||
|
||||
~select~ class — slots: options, filter, on-select, selected-index, layout-node.
|
||||
|
||||
~make-select &key options filter on-select~ → select instance.
|
||||
|
||||
~select-options sel~ / ~(setf select-options)~ — list of option plists.
|
||||
~select-filter sel~ / ~(setf select-filter)~ — filter string or nil.
|
||||
~select-selected-index sel~ / ~(setf select-selected-index)~ — currently highlighted index.
|
||||
~select-on-select sel~ / ~(setf select-on-select)~ — callback fn (receives option plist).
|
||||
~select-layout-node sel~ / ~(setf select-layout-node)~ — layout node.
|
||||
|
||||
~select-filtered-options sel~ → list of options matching the filter.
|
||||
Returns all options when filter is nil. Matches title (case-insensitive).
|
||||
Falls back to trigram fuzzy matching when no exact substring matches.
|
||||
|
||||
~select-next sel~ / ~select-prev sel~ — move selection forward/backward,
|
||||
skipping category headers. Wraps around at boundaries.
|
||||
|
||||
~select-visible-options sel~ → filtered options visible in viewport.
|
||||
Uses available-height from layout node. Culls like ScrollBox.
|
||||
|
||||
~select-handle-key sel event~ → T if handled.
|
||||
Down/Ctrl+N → next. Up/Ctrl+P → prev. Enter → on-select callback. Esc → nil.
|
||||
|
||||
~render ((sel select) backend)~ — renders visible options with selection highlight.
|
||||
|
||||
** Tests
|
||||
|
||||
*** Test package and suite setup
|
||||
|
||||
The test file uses FiveAM. The ~defpackage~ pulls in all the dependencies needed
|
||||
by the select widget tests — FiveAM itself, the backend/box/layout/input infrastructure,
|
||||
and the ~cl-tty.select~ package under test. ~run-tests~ is the entry point for
|
||||
CI and interactive use.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(defpackage :cl-tty-select-test
|
||||
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select)
|
||||
(:export #:run-tests))
|
||||
(in-package #:cl-tty-select-test)
|
||||
#+END_SRC
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(def-suite select-suite :description "Select widget tests")
|
||||
(in-suite select-suite)
|
||||
#+END_SRC
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(defun run-tests ()
|
||||
(let ((result (run 'select-suite)))
|
||||
(fiveam:explain! result)
|
||||
(uiop:quit 0)))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-creates
|
||||
|
||||
Verifies that a select widget can be constructed with default values. The
|
||||
~selected-index~ should start at 0, and both ~options~ and ~filter~ should
|
||||
be nil. This establishes the baseline contract for the default constructor.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-with-options
|
||||
|
||||
Ensures that passing ~:options~ to ~make-select~ stores them correctly. The
|
||||
length check is the simplest invariant — two options in, two options out.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-filtered-exact
|
||||
|
||||
Tests case-insensitive substring filtering: setting filter to ~\"bl\"~ should
|
||||
match \"Blue\" but not \"Red\" or \"Green\". The return value is an alist of
|
||||
~(display-index original-index option)~, so we dig into the third element
|
||||
to check the ~:value~.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-filtered-all
|
||||
|
||||
When the filter is nil ~select-filtered-options~ must return every option
|
||||
unchanged. This is the unfiltered/identity case and the most common state
|
||||
when the user hasn't typed anything.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-navigation
|
||||
|
||||
Exercises ~select-next~ and ~select-prev~ through a three-item list,
|
||||
confirming that forward and backward movement works and that both directions
|
||||
wrap around at list boundaries.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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")))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-navigation-skips-categories
|
||||
|
||||
Category headers (options with ~:category t~) should be invisible to
|
||||
navigation — ~select-next~ and ~select-prev~ skip over them. This test
|
||||
sets up a list with two category headers interleaved and verifies they
|
||||
are transparent to movement.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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")))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-handle-key
|
||||
|
||||
Validates that ~select-handle-key~ dispatches correctly: Down moves forward,
|
||||
Up moves backward, and Enter invokes the ~on-select~ callback with the
|
||||
currently highlighted option's plist.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-handle-key-ctrl
|
||||
|
||||
Ctrl+N and Ctrl+P are Emacs-compatible alternatives to Down/Up. They must
|
||||
produce identical navigation behavior. This test confirms the control-key
|
||||
dispatch paths.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-visible-count
|
||||
|
||||
~select-visible-options~ should never return more items than the viewport
|
||||
height. This test creates 20 options, sets the layout height to 5, and
|
||||
asserts the visible subset fits within that constraint.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
*** test select-fuzzy-fallback
|
||||
|
||||
When exact substring matching fails, the filter falls back to character-set
|
||||
Jaccard similarity. ~\"nrd\"~ should match ~\"Nord\"~ because the character
|
||||
overlap (n, o, r, d → 3 of 4) exceeds the 0.3 threshold.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/select-tests.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
* Implementation
|
||||
|
||||
** Package
|
||||
|
||||
The ~cl-tty.select~ package depends on the backend, box model, layout,
|
||||
and input subsystems. The exported symbols cover the public API: the
|
||||
~select~ class, constructor, accessors, filtering, navigation, key
|
||||
handling, rendering, and the fuzzy matching predicate (exposed for
|
||||
testing and extensibility).
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select-package.lisp
|
||||
(defpackage :cl-tty.select
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
#: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))
|
||||
#+END_SRC
|
||||
|
||||
** Select class
|
||||
|
||||
*** defclass select
|
||||
|
||||
~select~ inherits from ~dirty-mixin~ so the rendering layer knows when
|
||||
the widget state has changed (after navigation, filter updates, etc.).
|
||||
Options are stored as a list of plists. ~selected-index~ tracks the
|
||||
currently highlighted option. ~filter~ is a string (or nil for
|
||||
unfiltered). ~on-select~ is a callback receiving the selected option
|
||||
plist. ~layout-node~ positions the widget in the window.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(in-package #:cl-tty.select)
|
||||
|
||||
(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)))
|
||||
#+END_SRC
|
||||
|
||||
*** defun make-select
|
||||
|
||||
A convenience constructor that wraps ~make-instance~ with keyword
|
||||
arguments. Defaults to nil for all optional parameters, matching the
|
||||
~defclass~ initforms.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select
|
||||
:options (or options nil)
|
||||
:filter filter
|
||||
:on-select on-select))
|
||||
#+END_SRC
|
||||
|
||||
** Component protocol
|
||||
|
||||
*** defmethod component-layout-node
|
||||
|
||||
The layout engine needs a uniform way to access a component's position.
|
||||
~component-layout-node~ is part of the component protocol; this method
|
||||
for ~select~ simply delegates to the ~select-layout-node~ accessor.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(defmethod component-layout-node ((sel select))
|
||||
(select-layout-node sel))
|
||||
#+END_SRC
|
||||
|
||||
** Option filtering: substring match
|
||||
|
||||
*** defun select-filtered-options
|
||||
|
||||
~select-filtered-options~ returns options whose ~:title~ contains the
|
||||
filter string (case-insensitive). When ~filter~ is nil, returns all
|
||||
options. Category headers are NOT filtered out — they remain in the
|
||||
list so the user can see category context.
|
||||
|
||||
The function returns an alist of ~(filtered-index original-index option)~
|
||||
to preserve the original index for selection tracking.
|
||||
|
||||
Internally, the filter first checks for exact substring containment via
|
||||
~search~. If no option matches that way, it falls through to the
|
||||
character-set ~fuzzy-match-p~ predicate. Category headers short-circuit
|
||||
so they always pass through the filter.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
** Fuzzy matching: character-set Jaccard similarity
|
||||
|
||||
*** defun string-trigrams
|
||||
|
||||
Converts a string into a set of 3-character sliding window n-grams.
|
||||
Short strings (fewer than 3 characters) return the whole string as a
|
||||
single trigram. Duplicates are removed so the set can be used for
|
||||
Jaccard intersection/union calculations.
|
||||
|
||||
Note: the running tangle does not call this function directly — the
|
||||
simpler character-set ~fuzzy-match-p~ is used instead. Trigram
|
||||
matching is retained here as a documented alternative for future
|
||||
experimentation.
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(defun string-trigrams (str)
|
||||
"Return a list of 3-character trigrams from STR."
|
||||
(let ((s (string-downcase str))
|
||||
(result nil))
|
||||
(when (< (length s) 3)
|
||||
(return-from string-trigrams (list s)))
|
||||
(loop for i from 0 to (- (length s) 3)
|
||||
do (push (subseq s i (+ i 3)) result))
|
||||
(delete-duplicates result :test #'string=)))
|
||||
#+END_SRC
|
||||
|
||||
*** defun trigram-score
|
||||
|
||||
Jaccard similarity of two trigram sets: the size of the intersection
|
||||
divided by the size of the union. A score of 1.0 means identical sets;
|
||||
0.0 means no overlap. This is used by ~fuzzy-match-p~ if trigram mode
|
||||
is enabled (currently unused in the default filter path — see
|
||||
~string-trigrams~).
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(defun trigram-score (query target)
|
||||
"Jaccard similarity of trigram sets: |intersection| / |union|."
|
||||
(let* ((q-trigrams (string-trigrams query))
|
||||
(t-trigrams (string-trigrams target))
|
||||
(intersection (length (intersection q-trigrams t-trigrams :test #'string=)))
|
||||
(union (length (union q-trigrams t-trigrams :test #'string=))))
|
||||
(if (zerop union) 0.0 (/ (float intersection) union))))
|
||||
#+END_SRC
|
||||
|
||||
*** defun fuzzy-match-p
|
||||
|
||||
Returns T if the Jaccard similarity between the character sets of the
|
||||
query and target exceeds 0.3. The character-set approach is simpler
|
||||
and cheaper than trigrams while still catching common typos and
|
||||
near-misses like ~\"nrd\"~ for ~\"Nord\"~.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
** Navigation
|
||||
|
||||
*** defun select-clamp-index
|
||||
|
||||
After the filter changes (user types or clears input), the selected
|
||||
index may point beyond the filtered list. ~select-clamp-index~ ensures
|
||||
the index stays within valid bounds. If the list is empty the index
|
||||
resets to 0.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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)))))))
|
||||
#+END_SRC
|
||||
|
||||
*** defun select-next
|
||||
|
||||
Moves the selection forward to the next non-category option. Iterates
|
||||
through the filtered list starting from the current index, wrapping
|
||||
around at the end. Each candidate is checked for ~:category t~ and
|
||||
skipped. Marks the widget dirty so the render pass picks up the change.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
*** defun select-prev
|
||||
|
||||
Moves the selection backward to the previous non-category option.
|
||||
Mirrors ~select-next~ but decrements the index (with modular arithmetic
|
||||
for wrap-around). Category headers are skipped identically.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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)))))
|
||||
#+END_SRC
|
||||
|
||||
** Key event handler
|
||||
|
||||
*** defun select-handle-key
|
||||
|
||||
Dispatches keyboard events:
|
||||
- Down, Ctrl+N → ~select-next~
|
||||
- Up, Ctrl+P → ~select-prev~
|
||||
- Enter → ~on-select~ callback with the selected option
|
||||
- Esc → return NIL (caller can dismiss the widget)
|
||||
|
||||
Returns T if the key was handled (consumed), NIL otherwise so the
|
||||
caller knows not to propagate the event further.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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))))
|
||||
#+END_SRC
|
||||
|
||||
** Visible options (viewport culling)
|
||||
|
||||
*** defun select-visible-options
|
||||
|
||||
Returns only the filtered options that fit within the widget's
|
||||
available height. Each option occupies 1 row. This prevents rendering
|
||||
hundreds of items when the viewport shows only 10. The window is
|
||||
centered around the currently selected index so the user always sees
|
||||
context around their cursor.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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))
|
||||
;; Show items around the selection
|
||||
(half (floor (1- height) 2))
|
||||
(start (max 0 (- sel-idx half)))
|
||||
(end (min (length filtered) (+ start height))))
|
||||
(subseq filtered start end)))
|
||||
#+END_SRC
|
||||
|
||||
** Rendering
|
||||
|
||||
*** defmethod render
|
||||
|
||||
Draws each visible option on its own line. The selected option is
|
||||
highlighted with ~:accent~ foreground and ~:background-element~
|
||||
background. Category headers are rendered dimmed (~:text-muted~) and
|
||||
visually distinct from selectable items. Long titles are truncated with
|
||||
an ellipsis character to fit the viewport width.
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/select.lisp
|
||||
(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)))
|
||||
#+END_SRC
|
||||
Reference in New Issue
Block a user