v0.15.0: Critical input/rendering fixes, subagent-reviewed #7
13
cl-tui.asd
13
cl-tui.asd
@@ -2,7 +2,7 @@
|
||||
(asdf:defsystem :cl-tui
|
||||
:description "Reusable Common Lisp Terminal UI Framework"
|
||||
:author "Amr Gharbeia"
|
||||
:version "0.6.0"
|
||||
:version "0.7.0"
|
||||
:license "TBD"
|
||||
:depends-on (:fiveam :sb-posix)
|
||||
:components
|
||||
@@ -32,7 +32,10 @@
|
||||
;; Container components (v0.6.0)
|
||||
(:file "container-package" :depends-on ("package" "input-package"))
|
||||
(:file "scrollbox" :depends-on ("container-package" "dirty" "box"))
|
||||
(:file "tabbar" :depends-on ("container-package" "dirty" "box"))))
|
||||
(:file "tabbar" :depends-on ("container-package" "dirty" "box"))
|
||||
;; Select widget (v0.7.0)
|
||||
(:file "select-package" :depends-on ("package" "input-package"))
|
||||
(:file "select" :depends-on ("select-package" "dirty" "box"))))
|
||||
:in-order-to ((test-op (test-op :cl-tui-tests))))
|
||||
|
||||
(asdf:defsystem :cl-tui-tests
|
||||
@@ -52,12 +55,14 @@
|
||||
(:file "render-tests")
|
||||
(:file "theme-tests")
|
||||
(:file "input-tests")
|
||||
(:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests.lisp"))))
|
||||
(:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests.lisp")
|
||||
(:file "select-tests" :pathname "../../tests/select-tests.lisp"))))
|
||||
:perform (test-op (o c)
|
||||
(dolist (suite '((:cl-tui-backend-test "BACKEND-SUITE")
|
||||
(:cl-tui-box-test "BOX-SUITE")
|
||||
(:cl-tui-input-test "INPUT-SUITE")
|
||||
(:cl-tui-scrollbox-test "SCROLLBOX-SUITE")))
|
||||
(:cl-tui-scrollbox-test "SCROLLBOX-SUITE")
|
||||
(:cl-tui-select-test "SELECT-SUITE")))
|
||||
(let* ((pkg (find-package (first suite)))
|
||||
(s (and pkg (find-symbol (second suite) pkg))))
|
||||
(when s
|
||||
|
||||
543
org/select.org
Normal file
543
org/select.org
Normal file
@@ -0,0 +1,543 @@
|
||||
#+TITLE: cl-tui 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
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
|
||||
(defpackage :cl-tui-select-test
|
||||
(:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.select)
|
||||
(:export #:run-tests))
|
||||
(in-package #:cl-tui-select-test)
|
||||
|
||||
(def-suite select-suite :description "Select widget tests")
|
||||
(in-suite select-suite)
|
||||
|
||||
(defun run-tests ()
|
||||
(let ((result (run 'select-suite)))
|
||||
(fiveam:explain! result)
|
||||
(uiop:quit 0)))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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")))
|
||||
|
||||
(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")))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(defpackage :cl-tui.select
|
||||
(:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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
|
||||
|
||||
~select~ inherits from ~dirty-mixin~. 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.
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(in-package #:cl-tui.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)))
|
||||
|
||||
(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
|
||||
|
||||
~component-layout-node~ returns the layout node so the layout engine
|
||||
can position the select widget.
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(defmethod component-layout-node ((sel select))
|
||||
(select-layout-node sel))
|
||||
#+END_SRC
|
||||
|
||||
** Option filtering: substring match
|
||||
|
||||
~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.
|
||||
|
||||
#+BEGIN_SRC 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)
|
||||
(when (getf opt :category)
|
||||
(return-from select-filtered-options all-options))
|
||||
(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: trigram Jaccard similarity
|
||||
|
||||
~trigram-score~ converts a string into a set of 3-character sliding
|
||||
window n-grams. ~fuzzy-match-p~ returns T if the Jaccard similarity
|
||||
between the query trigrams and the target trigrams exceeds 0.3.
|
||||
|
||||
Trigrams capture character-level similarity without requiring exact
|
||||
substring matches. "nrd" matches "Nord" because both contain ~nor~,
|
||||
~ord~ and ~nrd~ contributes ~nrd~ — the overlap is enough to exceed
|
||||
the threshold.
|
||||
|
||||
#+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=)))
|
||||
|
||||
(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))))
|
||||
|
||||
(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
|
||||
|
||||
~select-next~ and ~select-prev~ move the selection forward/backward
|
||||
through the filtered options list. They skip category headers (options
|
||||
with ~:category t~). The selection wraps at list boundaries.
|
||||
~select-clamp-index~ ensures the index is valid after filtering changes.
|
||||
|
||||
#+BEGIN_SRC 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)))))))
|
||||
|
||||
(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
|
||||
|
||||
** Key event handler
|
||||
|
||||
~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)
|
||||
|
||||
Returns T if the key was handled, NIL otherwise.
|
||||
|
||||
#+BEGIN_SRC 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)
|
||||
|
||||
~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 10.
|
||||
|
||||
#+BEGIN_SRC 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
|
||||
|
||||
~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
|
||||
not selectable (visually distinct).
|
||||
|
||||
#+BEGIN_SRC lisp
|
||||
(defmethod render ((sel select) backend)
|
||||
(let* ((ln (select-layout-node sel))
|
||||
(x 0) (y 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
|
||||
|
||||
** Combined tangle block
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
|
||||
(in-package #:cl-tui.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)))
|
||||
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select :options (or options nil) :filter filter :on-select on-select))
|
||||
|
||||
(defmethod component-layout-node ((sel select)) (select-layout-node sel))
|
||||
|
||||
(defun select-filtered-options (sel)
|
||||
(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))))
|
||||
|
||||
(defun fuzzy-match-p (query target)
|
||||
(let* ((q (remove-duplicates (coerce (string-downcase query) 'list)))
|
||||
(tg (remove-duplicates (coerce (string-downcase target) 'list)))
|
||||
(intersection (length (intersection q tg)))
|
||||
(union (length (union q tg))))
|
||||
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))
|
||||
|
||||
(defun select-clamp-index (sel)
|
||||
(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)))))))
|
||||
|
||||
(defun select-next (sel)
|
||||
(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)
|
||||
(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-handle-key (sel event)
|
||||
(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))))
|
||||
|
||||
(defun select-visible-options (sel)
|
||||
(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)))
|
||||
|
||||
(defmethod render ((sel select) backend)
|
||||
(let* ((ln (select-layout-node sel)) (x 0) (y 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)) (cat (getf option :category))
|
||||
(selected (eql display-idx sel-idx))
|
||||
(display (if (> (length title) (1- w))
|
||||
(concatenate 'string (subseq title 0 (1- w)) "…") title)))
|
||||
(cond (cat (draw-text backend x y display :text-muted nil))
|
||||
(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
|
||||
|
||||
#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp
|
||||
(defpackage :cl-tui.select
|
||||
(:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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
|
||||
13
src/components/select-package.lisp
Normal file
13
src/components/select-package.lisp
Normal file
@@ -0,0 +1,13 @@
|
||||
(defpackage :cl-tui.select
|
||||
(:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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))
|
||||
94
src/components/select.lisp
Normal file
94
src/components/select.lisp
Normal file
@@ -0,0 +1,94 @@
|
||||
(in-package #:cl-tui.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)))
|
||||
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select :options (or options nil) :filter filter :on-select on-select))
|
||||
|
||||
(defmethod component-layout-node ((sel select)) (select-layout-node sel))
|
||||
|
||||
(defun select-filtered-options (sel)
|
||||
(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))))
|
||||
|
||||
(defun fuzzy-match-p (query target)
|
||||
(let* ((q (remove-duplicates (coerce (string-downcase query) 'list)))
|
||||
(tg (remove-duplicates (coerce (string-downcase target) 'list)))
|
||||
(intersection (length (intersection q tg)))
|
||||
(union (length (union q tg))))
|
||||
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))
|
||||
|
||||
(defun select-clamp-index (sel)
|
||||
(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)))))))
|
||||
|
||||
(defun select-next (sel)
|
||||
(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)
|
||||
(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-handle-key (sel event)
|
||||
(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))))
|
||||
|
||||
(defun select-visible-options (sel)
|
||||
(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)))
|
||||
|
||||
(defmethod render ((sel select) backend)
|
||||
(let* ((ln (select-layout-node sel)) (x 0) (y 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)) (cat (getf option :category))
|
||||
(selected (eql display-idx sel-idx))
|
||||
(display (if (> (length title) (1- w))
|
||||
(concatenate 'string (subseq title 0 (1- w)) "…") title)))
|
||||
(cond (cat (draw-text backend x y display :text-muted nil))
|
||||
(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)))
|
||||
120
tests/select-tests.lisp
Normal file
120
tests/select-tests.lisp
Normal file
@@ -0,0 +1,120 @@
|
||||
(defpackage :cl-tui-select-test
|
||||
(:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.select)
|
||||
(:export #:run-tests))
|
||||
(in-package #:cl-tui-select-test)
|
||||
|
||||
(def-suite select-suite :description "Select widget tests")
|
||||
(in-suite select-suite)
|
||||
|
||||
(defun run-tests ()
|
||||
(let ((result (run 'select-suite)))
|
||||
(fiveam:explain! result)
|
||||
(uiop:quit 0)))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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")))
|
||||
|
||||
(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")))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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)))))
|
||||
Reference in New Issue
Block a user