amr/cl-tty
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
94df17a7b9d1e879bc0012c2f829f2e032c1d6fe
cl-tty/org/text-input.org
Amr Gharbeia 94df17a7b9 Add render-select-minibuffer, fix CSI parser nil-code crash 
- 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)
2026-05-20 16:27:53 -04:00

2476 lines
103 KiB
Org Mode
Raw Blame History

#+TITLE: cl-tty v0.5.0 — Text Input + Keybinding System
#+STARTUP: content
* Text Input System
The input pipeline has four layers:
1. **Terminal raw mode** — put stdin into non-canonical mode so every
keystroke is delivered immediately (no line buffering, no echo).
2. **Escape sequence parser** — read bytes from stdin, classify them as
plain characters, modified keys (Ctrl/Alt), cursor keys, function keys,
mouse events, or bracketed paste.
3. **Input widget (TextInput / Textarea)** — editable text with cursor,
selection, undo/redo, and emacs-style keybindings.
4. **Keybinding system** — layered keymaps that route keystrokes through
focused-component → local → global dispatch.
SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~,
~tcsetattr~, ~read~) needed for raw mode. No external libraries required.
** Design decisions
- ~key-event~ is a struct — structs generate inline accessors, key/ctrl/alt
are fixnum/boolean slots that never need CLOS dispatch.
- Mouse events are a separate struct — they carry coordinates and button
info that key events don't need.
- Terminal state save/restore is explicit (save/set-raw/restore), not
wired into backend lifecycle. Different apps want different modes.
- The parser reads one byte at a time through a state machine, not a
buffer-at-once approach. This keeps the implementation simple and
handles arbitrary interleaving of terminal output with input.
- SBCL's ~defstruct~ generates keyword constructors by default — we use
them directly without custom ~:constructor~ overrides.
- CSI sequences are parsed via a two-pass approach: first collect params
and terminator, then look up in tables. This separates concerns — the
byte-level parsing is distinct from the semantic mapping.
- The 50ms timeout on escape sequence detection resolves the classic
ambiguity between a lone Escape key press and the start of a CSI/SS3
sequence. If a byte arrives within 50ms, it's an escape sequence; if
not, the user pressed Escape.
- UTF-8 decoding uses a direct bit-manipulation approach rather than a
table-driven decoder. For the terminal input use case (short sequences
of 2-4 bytes), the simpler code is both faster and more readable.
- ~key-event-code~ exists alongside ~key-event-key~ to carry the raw
character code. ~:key~ is a semantic keyword (:a, :enter, :up) while
~:code~ is the numeric code point or byte value. This separation is
essential for printable character insertion — ~handle-text-input~ uses
~key-event-code~ with ~code-char~, not ~key-event-key~ which is always
uppercased (and thus useless for case-sensitive insertion).
- The undo/redo system uses fill-pointer vectors as stacks, capped at 100
entries. Oldest entries are evicted when the stack fills. This avoids
consing on every keystroke while bounding memory use.
* Contract
~(key-event key ctrl alt shift code raw text)~ — struct.
~make-key-event :key :enter :ctrl nil~ creates a key-press event.
~key-event-key~ returns the keyword (~:a~, ~:enter~, ~:space~,
~:up~, ~:f1~, etc.).
~(mouse-event type button x y raw)~ — struct.
~type~ is ~:press~, ~:release~, or ~:drag~.
~button~ is ~:left~, ~:middle~, ~:right~, ~:wheel-up~, or ~:wheel-down~.
~%split-string string separator~ → list of strings.
Split a string at each occurrence of SEPARATOR character.
Used internally to split textarea lines.
~*current-backend*~, ~*current-theme*~ — special variables.
Set by the application's main loop. Used by widget render methods
to draw themselves.
~save-terminal-state~ → termios. Capture current terminal settings.
~set-raw-mode~ → termios. Disable ICANON, ECHO, ISIG, IEXTEN. VMIN=1, VTIME=0.
~restore-terminal-state termios~ — restore saved settings.
~with-raw-terminal &body body~ — macro. Save → set raw → body → restore
(via ~unwind-protect~).
~read-raw-byte &key timeout~ → (values byte-or-nil reason).
Read one byte from fd 0. Blocks indefinitely when timeout=NIL.
Returns (values byte NIL) on success, (values NIL :TIMEOUT) on timeout,
(values NIL :EOF) when stdin is closed or /dev/null.
~parse-csi-params~ → (values params final-byte raw-string).
Read bytes from stdin until a final CSI byte (0x40-0x7E).
Returns list of parameter numbers, the final byte, and the raw string.
~parse-sgr-mouse raw~ → mouse-event or NIL.
Parse "ESC[<Cx;Cy;M/m" format into a structured mouse event.
Converts button codes (0=left, 1=middle, 2=right, 32=motion)
and tracks press vs release vs drag.
~%read-escape-sequence~ → key-event or :eof.
Called after reading ESC (0x1b). Uses a 50ms timeout on the first
follow-up byte to resolve Escape ambiguity (lone Escape vs start of
CSI/SS3 sequence). Dispatches:
- timeout → :escape key event
- ESC O X → SS3 (F1-F4)
- ESC [ ... → CSI (cursors, function keys, mouse)
- ESC ESC → Alt+Escape
- ESC printable → Alt+letter
~%read-event &key timeout~ → key-event, mouse-event, :eof, or NIL.
Top-level reader. Handles:
- Printable ASCII (0x20-0x7e) → key :A, :B, ..., :~
- Ctrl letters (0x01-0x1a) → :A with ctrl=T
- Tab (0x09), Enter (0x0a, 0x0d)
- Backspace (0x7f, 0x08)
- Escape (0x1b) → delegates to ~%read-escape-sequence~
- High bytes (UTF-8, etc.) → :unknown
~:key~ is always uppercase (interred in KEYWORD package)
to match how the reader interns keyword literals.
~read-event (b backend) &key timeout~ — defmethod.
Backend protocol integration. Probes /dev/stdin and calls ~%read-event~.
~text-input~ — widget class. slots: value, cursor, placeholder,
max-length, on-submit, layout-node, focusable. Inherits ~dirty-mixin~.
~make-text-input ...~ — constructor.
~handle-text-input input event~ — process a key-event:
- Ctrl+A/E → home/end
- Ctrl+W → delete word before
- Ctrl+U → delete to line start
- Ctrl+K → delete to line end
- :enter → on-submit callback
- :left/:right/:home/:end → cursor movement
- :backspace/:delete → char deletion
- printable chars → insert at cursor
~textarea~ — widget class. slots: value, cursor-row, cursor-col,
selection-start, undo/redo stacks (fill-pointer vectors), on-submit,
layout-node, focusable. Inherits ~dirty-mixin~.
~make-textarea ...~ — constructor.
~handle-textarea-input ta event~ — process a key-event:
- All TextInput operations plus:
- Ctrl+Z → undo, Ctrl+Y → redo
- Ctrl+A/E → home/end on current line
- :up/:down → line navigation
- :enter → newline (or on-submit if set)
- :left/:right/:home/:end → cursor movement
- :delete → char at cursor
- :backspace → joins lines at start, deletes char otherwise
~%join-lines lines~ → string.
Join a sequence of strings with #\Newline separators.
Handles both lists and vectors (used throughout textarea).
~keymap~ — struct. slots: name, bindings (alist), parent.
~*keymaps*~ — hash table (test: equal), maps keyword names to keymaps.
~*chord-timeout*~ — seconds (default 0.5).
~key-match-p spec event~ → boolean.
SPEC is a keyword like ~:ctrl+p~ (modifier+key, split on +)
or a list like ~(:ctrl+p)~ for wrapped specs.
Modified keys match mod-str with ~string=? — not ~case~ (EQL trap).
~dispatch-key-event event &key component~ → boolean (handled?).
Routes through: focused-component → :local → :global keymaps.
~defkeymap name &body bindings~ — macro.
Registers a keymap. Each binding: ~(:ctrl+p . handler-fn)~.
~component-keymap component~ — generic (returns nil by default).
* Package
** input-package.lisp
The package uses ~:cl-tty.backend~ for backend protocol (draw-text, etc.),
~:cl-tty.box~ for dirty-mixin and rendering pipeline,
and ~:cl-tty.layout~ for layout-node.
I export everything users of the input system need: key events, mouse events,
terminal raw mode, TextInput, Textarea, and the keybinding system.
~save-terminal-state~, ~set-raw-mode~, ~restore-terminal-state~, and
~with-raw-terminal~ are declared in the export list for forward compatibility
— they belong in this module once implemented, and exporting them from the
start avoids package redefinition churn. The current system does not yet call
raw mode from within the input module; consumers manage raw mode themselves
via ~sb-posix~ directly.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input-package.lisp
(defpackage :cl-tty.input
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout)
(:export
;; Key events
#:key-event #:make-key-event
#:key-event-p #:key-event-key #:key-event-ctrl
#:key-event-alt #:key-event-shift #:key-event-code
#:key-event-raw #:key-event-text
;; Mouse events
#:mouse-event #:make-mouse-event
#:mouse-event-p #:mouse-event-type #:mouse-event-button
#:mouse-event-x #:mouse-event-y
;; Terminal raw mode
#:save-terminal-state #:set-raw-mode #:restore-terminal-state
#:with-raw-terminal
;; Event reading
#:read-event
#:*terminal-resized-p*
;; UTF-8 input support
#:utf8-decode
;; TextInput
#:text-input #:make-text-input
#:text-input-value #:text-input-cursor
#:text-input-placeholder #:text-input-max-length
#:text-input-on-submit #:text-input-on-cancel
#:text-input-on-tab #:text-input-on-history
#:text-input-layout-node
#:text-input-insert #:text-input-backspace #:text-input-delete
#:text-input-move-left #:text-input-move-right
#:text-input-move-home #:text-input-move-end
#:text-input-delete-word-before
#:handle-text-input #:render-text-input
;; Textarea
#:textarea #:make-textarea
#:textarea-value #:textarea-cursor-row #:textarea-cursor-col
#:textarea-lines
#:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack
#:textarea-layout-node
#:handle-textarea-input #:render-textarea
;; Keybindings
#:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent
#:*keymaps* #:*chord-timeout*
#:defkeymap #:dispatch-key-event #:key-match-p
#:component-keymap
;; Mouse (merged from cl-tty.mouse)
#:mouse-mixin
#:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll
#:handle-mouse-event
#:hit-test
#:selection #:get-selection #:copy-to-clipboard
#:make-selection #:selection-p
#:start-selection #:update-selection #:finalize-selection
#:selection-active-p
#:*selection* #:*selection-active* #:*selection-start* #:*selection-end*
#:cell-link-at #:open-link-at))
#+END_SRC
* Input Reader Core
This section contains all the terminal input reading machinery:
raw byte reads, escape sequence parsing, CSI sequence handling,
UTF-8 decoding, and the top-level event dispatch.
All blocks tangle to ~../src/components/input.lisp~. The first block
includes the ~in-package~ form; subsequent blocks contain only the
individual definition.
** Utility: %split-string
A simple loop-based split. I avoid using ~split-sequence~ from Quicklisp
to keep dependencies minimal — the framework already depends on ~fiveam~ and
~sb-posix~, and adding another dep just for one function is wasteful.
The loop collects subsequences between occurrences of SEPARATOR. The
~while pos~ guard prevents an empty trailing element. For an empty string,
this returns ~("")~ (one empty string), which is the correct behavior for
textarea line splitting — a blank document has one empty line.
This is the first block tangling to input.lisp, so it includes the
~in-package~ form that all subsequent blocks share.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(in-package #:cl-tty.input)
(defun %split-string (string separator)
"Split STRING at each occurrence of SEPARATOR. Returns list of strings."
(loop with start = 0
for pos = (position separator string :start start)
collect (subseq string start pos)
while pos
do (setf start (1+ pos))))
#+END_SRC
** Global rendering variables
~*current-backend*~ and ~*current-theme*~ are special variables set by the
application's main loop. Widget ~render~ methods use them to draw themselves.
Defining them here rather than in the rendering module keeps the dependency
clean — input widgets depend on rendering, not the other way around.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *current-backend* nil
"The active backend used for rendering.")
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *current-theme* nil
"The active theme used for semantic color resolution.")
#+END_SRC
** Key Event Struct
I chose ~defstruct~ over ~defclass~ for key events because structs give
inline accessors and value semantics. Every keystroke creates one, and
in the hot path (terminal parsing) we don't want CLOS dispatch overhead.
Key observation about SBCL's ~defstruct~: it generates a keyword constructor
by default. ~(make-key-event :key :a :ctrl t)~ is valid out of the box.
I initially wrote a custom ~(:constructor ...)~ wrapper and spent hours
debugging argument mismatches — avoid that trap.
The ~code~ slot carries the raw character code (or code point for UTF-8
sequences). The ~raw~ slot carries the raw byte(s) as a string for debugging
or passthrough. The ~text~ slot is reserved for composed text input (IME).
~key-event-key~ is always a keyword interned in the KEYWORD package,
uppercased. This means ~:a~ (not ~:A~) for the letter 'a', ~:enter~ for
Enter, ~:up~ for the up arrow. The uppercasing convention matches how the
Common Lisp reader interns keyword literals, so ~(eql (key-event-key e)
:a)~ works exactly as written.
~key-event-code~ exists alongside ~key-event-key~ because the key keyword
loses information needed for character insertion: ~:a~ could be uppercase
or lowercase, but ~code~ preserves the actual code point. The
~handle-text-input~ function uses ~code-char~ on the code slot to get the
true character for insertion.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defstruct key-event
(key nil :type (or keyword null))
(ctrl nil :type boolean)
(alt nil :type boolean)
(shift nil :type boolean)
(code nil :type (or fixnum null))
(raw nil :type (or string null))
(text nil :type (or string null)))
#+END_SRC
** Mouse Event Struct
Mouse events are a separate struct because they carry fundamentally
different data: button (left/middle/right/wheel), coordinates (x, y),
and event type (press/release/drag). Combining them with key-event
would waste slots and complicate accessor semantics.
The mouse parser (~parse-sgr-mouse~) converts from the SGR extended
mouse protocol format (~ESC[<Cx;Cy;M/m~) into this struct. The ~type~
field is :press, :release, or :drag, determined by whether the button
code includes the motion bit (bit 5). Coordinates are 1-indexed from
the terminal; no adjustment is performed here.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defstruct mouse-event
(type nil :type (or keyword null))
(button nil :type (or keyword null))
(x 0 :type fixnum)
(y 0 :type fixnum))
#+END_SRC
** CSI tilde table
The ~*csi-tilde-table*~ maps numeric parameters from ~ESC[~...~~ sequences
to semantic key names. These are the "application mode" cursor and editing
keys: Home, Insert, Delete, End, Page Up/Down, and F-keys F1-F20.
The tilde-terminated form (~ESC[1~~ = Home, ~ESC[2~~ = Insert, etc.) is
the modern xterm format, as opposed to the single-letter terminators used
by VT100-style sequences (~ESC[H~ = Home, ~ESC[F~ = End). Modern terminal
emulators emit the tilde form for most keys; we handle both.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defparameter *csi-tilde-table*
'((1 . :home) (2 . :insert) (3 . :delete) (4 . :end)
(5 . :page-up) (6 . :page-down)
(11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4)
(15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8)
(20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12)))
#+END_SRC
** CSI key table
The ~*csi-key-table*~ maps single-letter terminators from ~ESC[~...letter~
sequences to semantic key names. These are the VT100/VT220-style cursor
and editing keys: A=up, B=down, C=right, D=left, F=end, H=home, plus
F1-F4 via P/Q/R/S and back-tab via Z.
These terminators come from the original DEC VT series and are still
emitted by most terminal emulators in "normal" (non-application) cursor
key mode. The ~:back-tab~ mapping for Z handles Shift+Tab, which some
emulators report as ~ESC[Z~.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defparameter *csi-key-table*
'((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left)
(#\F . :end) (#\H . :home)
(#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4)
(#\Z . :back-tab)))
#+END_SRC
** CSI parameter parser
~parse-csi-params~ takes the numeric parameter list, the terminator
character, and the extended parameter vector, then constructs the
appropriate ~key-event~.
The function handles three cases:
1. Tilde-terminated sequences (~ESC[1~~): look up the numeric parameter
in ~*csi-tilde-table*~.
2. Key-terminated sequences (~ESC[A~, ~ESC[1;5B~): look up the terminator
character in ~*csi-key-table*~ and extract modifier information from
the second parameter.
3. Unicode/u-terminated sequences (~ESC[NNNNu~): decode a direct code
point, used by kitty's keyboard protocol for unambiguous character
reporting.
Modifier encoding follows the xterm convention: Shift=1, Alt=2, Ctrl=4.
The extended parameter vector carries the raw parameter bytes for
sequences where modifiers appear in a non-standard position.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun parse-csi-params (params terminator extended)
(let* ((terminator-char (code-char terminator))
(key (if (and terminator-char (find terminator-char '(#\~ #\u)))
(cdr (assoc (first params) *csi-tilde-table*))
(cdr (assoc terminator-char *csi-key-table*))))
(modifier (when (and (> (length params) 1) (not (find terminator '(#\~ #\u))))
(second params)))
(actual-modifier (when (> (length extended) 1) (second extended)))
(ctrl nil) (alt nil) (shift nil))
(when modifier
(setf shift (logtest modifier 1)
alt (logtest modifier 2)
ctrl (logtest modifier 4)))
(when actual-modifier
(setf shift (or shift (logtest actual-modifier 1))
alt (or alt (logtest actual-modifier 2))
ctrl (or ctrl (logtest actual-modifier 4))))
(if (eql terminator #\u)
(let ((code (first params)))
(make-key-event :key :codepoint :code code
:ctrl ctrl :alt alt :shift shift
:raw (string (code-char code))))
(make-key-event :key (or key :unknown)
:ctrl ctrl :alt alt :shift shift
:raw (format nil "~C[~{~d~};~d" #\Esc params terminator)))))
#+END_SRC
** Raw byte reader
~read-raw-byte~ is the lowest-level I/O function in the input system.
It reads exactly one byte from file descriptor 0 (stdin) using SBCL's
~sb-unix:unix-read~, bypassing the standard CL stream layer.
Why bypass ~read-char~ and ~listen~? CL streams buffer input, which
interferes with the byte-at-a-time state machine of escape sequence
parsing. Once the stream has buffered bytes, ~listen~ may return T even
though the next byte belongs to a different sequence. Direct ~unix-read~
gives us precise control over how many bytes we consume.
The ~timeout~ keyword uses ~sb-unix:unix-simple-poll~ to implement
non-blocking reads with a configurable deadline. This is critical for
the 50ms escape sequence ambiguity resolution in ~%read-escape-sequence~.
Memory management: we use ~sb-sys:with-pinned-objects~ to pin a 1-byte
~make-array~ vector in memory, obtain its SAP via ~sb-sys:vector-sap~,
and read directly into the backing storage. This avoids alien allocation
and manual ~free-alien~ while keeping the GC from moving the buffer
during the ~unix-read~ syscall.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun get-input-fd ()
"Return a file descriptor suitable for reading terminal input.
Prefers fd 0 (stdin) if it's a TTY, otherwise opens /dev/tty.
Falls back to fd 0 if /dev/tty is not available."
(or (and (sb-unix:unix-isatty 0) 0)
(handler-case
(let ((fd (sb-unix:unix-open "/dev/tty" sb-unix:o_rdonly)))
(if (and fd (>= fd 0)) fd 0))
(error () 0))))
(defun read-raw-byte (&key timeout)
(let* ((buf (make-array 1 :element-type '(unsigned-byte 8)))
(fd-stream (get-input-fd))
(timeout-ms (when timeout (max 1 (round (* timeout 1000))))))
(sb-sys:with-pinned-objects (buf)
(let ((sap (sb-sys:vector-sap buf)))
(if timeout-ms
(let ((poll-result (sb-unix:unix-simple-poll fd-stream :input timeout-ms)))
(if poll-result
(let ((n (sb-unix:unix-read fd-stream sap 1)))
(if (= n 1)
(aref buf 0)
;; EOF on fd — try opening /dev/tty
(let ((tty-fd (sb-unix:unix-open "/dev/tty" sb-unix:o_rdonly)))
(if (and tty-fd (>= tty-fd 0))
(let ((m (sb-unix:unix-read tty-fd sap 1)))
(sb-unix:unix-close tty-fd)
(if (= m 1) (aref buf 0) (values nil nil)))
(values nil nil)))))
(values nil nil)))
(let ((n (sb-unix:unix-read fd-stream sap 1)))
(if (= n 1) (aref buf 0) (values nil :eof))))))))
#+END_SRC
** Escape sequence reader
~%read-escape-sequence~ is called after the top-level reader has consumed
byte 0x1b (Escape). Its job is to resolve the classic terminal ambiguity:
is this a lone Escape key press, or the start of a multi-byte escape
sequence (CSI, SS3, etc.)?
The resolution strategy uses a 50ms timeout on the first follow-up byte:
- No byte within 50ms → the user pressed Escape. Return ~:escape~.
- Byte is 0x5b ([) → CSI sequence. Delegate to ~parse-csi-sequence~.
- Byte is 0x4f (O) → SS3 sequence. Read one more byte for F1-F4 or shifted
cursor keys.
- Byte is 0x7f (DEL) → Alt+Backspace (a common terminal convention).
- Byte is < 0x20 → Ctrl+letter with Alt modifier.
- Any other byte → Alt+letter.
Why 50ms? This value is the de facto standard across terminal emulators
and TUI frameworks. It's long enough that human key repeat rates (typ.
30-50ms between key repeat events) won't falsely trigger escape sequence
detection, but short enough that the Escape key feels responsive. The
Linux kernel's default key repeat rate uses a similar timing.
The SS3 path handles shifted cursor keys that some emulators report as
~ESC O A~ through ~ESC O D~ (shifted up/down/right/left). These use a
different byte prefix from the CSI form ~ESC [ A~ through ~ESC [ D~.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %read-escape-sequence ()
(flet ((read-next (&optional (timeout nil))
(let ((b (read-raw-byte :timeout timeout)))
(unless b (return-from %read-escape-sequence
(make-key-event :key :escape :code 27)))
b)))
(let ((b1 (read-next 0.05)))
(cond
((null b1) (make-key-event :key :escape :code 27))
((= b1 79) (let ((b2 (read-next)))
(case b2
(80 (make-key-event :key :f1))
(81 (make-key-event :key :f2))
(82 (make-key-event :key :f3))
(83 (make-key-event :key :f4))
(72 (make-key-event :key :home))
(70 (make-key-event :key :end))
(65 (make-key-event :key :up :shift t))
(66 (make-key-event :key :down :shift t))
(67 (make-key-event :key :right :shift t))
(68 (make-key-event :key :left :shift t))
(otherwise (make-key-event :key :unknown :raw (string (code-char b2)))))))
((= b1 91) (parse-csi-sequence))
((= b1 127) (make-key-event :key :alt-backspace))
((< b1 32)
(let ((c (code-char (+ b1 96))))
(make-key-event :key (intern (string-upcase (string c)) :keyword)
:alt t :code b1)))
(t (make-key-event :key (intern (string-upcase (string (code-char b1))) :keyword)
:alt t :code b1))))))
#+END_SRC
** SGR mouse parser
The SGR extended mouse protocol sends events in the format
~ESC [ < Cb ; Cx ; Cy M/m~ where:
- ~<~ is the SGR marker byte (0x3C)
- ~Cb~ is the button code (0=left, 1=middle, 2=right, 32+=motion/drag,
64=scroll-up, 65=scroll-down)
- ~Cx~, ~Cy~ are the 1-based coordinates
- ~M~ (0x4D) = press, ~m~ (0x6D) = release
The parser splits the byte stream into the three numeric parameters by
reading digits until a non-digit byte is encountered (~%read-digits~),
then converts the button code and press/release flag into a ~mouse-event~.
*** Digit reader
~%read-digits~ reads bytes from the raw terminal input until the first
non-digit byte, handling an optional list of initial bytes that were
already consumed by the caller. Returns the parsed integer and the
terminator byte.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %read-digits (&optional (initial-bytes nil))
"Read bytes until a non-digit is encountered.
Returns (values number terminator-byte)."
(let ((acc nil))
(dolist (b initial-bytes)
(when (and (>= b 48) (<= b 57))
(push (- b 48) acc)))
(loop for b = (read-raw-byte)
while (and (>= b 48) (<= b 57))
do (push (- b 48) acc)
finally (return (values (if acc
(reduce (lambda (n d) (+ (* n 10) d))
(reverse acc))
0)
b)))))
#+END_SRC
*** Mouse event parser
~%parse-sgr-mouse~ is called after ~ESC[<~ has been consumed by
~parse-csi-sequence~ (which detects the SGR marker byte). It reads the
three semicolon-separated parameters using ~%read-digits~ and constructs
a ~mouse-event~ struct with proper button and type classification.
Coordinates are converted from 1-based (terminal protocol) to 0-based
(framebuffer convention) by subtracting 1 from both x and y.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %parse-sgr-mouse ()
"Parse SGR mouse escape sequence: ESC [ < Cb ; Cx ; Cy M/m
Returns a mouse-event struct."
(let ((b (read-raw-byte)))
(multiple-value-bind (cb sep1) (%read-digits (list b))
(declare (ignore sep1))
(multiple-value-bind (cx sep2) (%read-digits)
(declare (ignore sep2))
(multiple-value-bind (cy term) (%read-digits)
(let ((button (cond
((= cb 0) :left)
((= cb 1) :middle)
((= cb 2) :right)
((= cb 64) :scroll-up)
((= cb 65) :scroll-down)
((>= cb 32) :drag)
(t :left)))
(type (cond
((= term 77) :press)
((= term 109) :release)
(t :press))))
(make-mouse-event :type type :button button
:x (- cx 1) :y (- cy 1))))))))
#+END_SRC
** CSI sequence parser
~parse-csi-sequence~ reads and parses a full Control Sequence Introducer
sequence: ~ESC [ (param) (terminator)~ or SGR mouse events: ~ESC [ < Cb ; Cx ; Cy M/m~.
The function implements a recursive descent parser for the CSI grammar:
- Read the first byte after ~ESC [~.
- If it's ~~<~~ (0x3C), the sequence is an SGR mouse event — delegate to
~%parse-sgr-mouse~ which returns a ~mouse-event~ struct.
- If it's a digit (0x30-0x39), collect all consecutive digits as the first
parameter, then the next non-digit byte is the terminator.
- If it's not a digit, it may be a modifier byte or the terminator itself.
The ~extended~ array accumulates raw parameter bytes for sequences where
the modifier appears after the primary parameter in an extended format
(e.g., ~ESC [ 1 ; 5 A~ where 5 encodes Ctrl+Shift). This array is passed
to ~parse-csi-params~ for modifier extraction.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun parse-csi-sequence ()
(flet ((read-param (next-fn) (let ((acc nil))
(loop for b = (funcall next-fn)
do (if (and (>= b 48) (<= b 57))
(push (- b 48) acc)
(return (values (reverse acc) b)))))))
(let* ((b2 (read-raw-byte)))
(if (= b2 60) ;; < — SGR mouse marker
(%parse-sgr-mouse)
(let* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0))
(parsed (if (and (>= b2 48) (<= b2 57))
;; Digit branch: read params with their digits
(let ((r (multiple-value-list (read-param (lambda () (read-raw-byte))))))
(let ((p (first r)))
(setf (fill-pointer extended) (length p))
(replace extended p))
r)
;; Non-digit branch: b2 is a direct CSI terminator
(progn (vector-push-extend b2 extended)
(list nil b2)))))
(let ((params (first parsed))
(terminator (or (second parsed) 0)))
(parse-csi-params (or params '()) terminator extended)))))))
#+END_SRC
** UTF-8 decoder
~utf8-decode~ converts a list of raw bytes (2 to 4 of them) into a Unicode
code point. It validates the byte sequence against the UTF-8 encoding rules
and returns ~nil~ for invalid sequences.
UTF-8 encoding structure:
- 2-byte: 110xxxxx 10xxxxxx (U+0080 through U+07FF)
- 3-byte: 1110xxxx 10xxxxxx 10xxxxxx (U+0800 through U+FFFF)
- 4-byte: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx (U+10000 through U+10FFFF)
Each case performs:
1. Range validation on the leading byte (ensuring it's in the correct pattern).
2. Continuation byte validation (each must be 10xxxxxx, i.e., 0x80-0xBF).
3. Bit masking and shifting to extract the code point.
This approach is intentionally simple and table-free. For terminal input,
sequences are always short (2-4 bytes), dispatched by the leading byte
category (~%read-event~ classifies them), so a compact ~case~ form is both
efficient and easy to audit for correctness.
Overlong sequences (e.g., encoding ASCII in 2+ bytes) are rejected because
the range checks on the leading byte exclude them: a 2-byte sequence with
b0=0xC0 would have ~(= #xc2 b0 #xdf)~ fail since 0xC0 < 0xC2.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun utf8-decode (bytes)
(case (length bytes)
(2 (let ((b0 (first bytes)) (b1 (second bytes)))
(when (and (<= #xc2 b0 #xdf) (<= #x80 b1 #xbf))
(+ (ash (logand b0 #x1f) 6) (logand b1 #x3f)))))
(3 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes)))
(when (and (<= #xe0 b0 #xef) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf))
(+ (ash (logand b0 #x0f) 12) (ash (logand b1 #x3f) 6) (logand b2 #x3f)))))
(4 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes)) (b3 (fourth bytes)))
(when (and (<= #xf0 b0 #xf4) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf) (<= #x80 b3 #xbf))
(+ (ash (logand b0 #x07) 18) (ash (logand b1 #x3f) 12)
(ash (logand b2 #x3f) 6) (logand b3 #x3f)))))
(t nil)))
#+END_SRC
** Top-level event reader
~%read-event~ is the main entry point for terminal input parsing. It reads
one byte, classifies it, and returns an appropriate event.
The classification hierarchy:
1. ~~x1b (Escape) → delegate to ~%read-escape-sequence~.
2. ~~x09 (Tab) → ~:tab~ with code ~~x09.
3. ~~x0a (LF) or ~~x0d (CR) → ~:enter~.
4. ~~x7f (DEL) or ~~x08 (BS) → ~:backspace~.
5. Byte range ~~x01-~~x1a → Ctrl+letter (Ctrl+A through Ctrl+Z).
The offset ~~x60 converts the control code to its corresponding
printable character: ~~x01 + ~~x60 = #\a = code 97.
6. ~~x1c-~~x1f → Ctrl+\ through Ctrl+_ with specific key names.
7. Byte range ~~x20-~~x7e → printable ASCII, interned as keyword
(uppercased).
8. Byte >= ~~xc2 → Start of UTF-8 multi-byte sequence. Read the
continuation bytes (up to 3 more) with a 500ms timeout each.
If enough valid bytes arrive, decode via ~utf8-decode~.
9. Anything else → ~:unknown~.
The Ctrl+letter mapping (~~x01-~~x1a → Ctrl+A..Ctrl+Z) follows the
standard ASCII control code layout where Ctrl+letter subtracts 0x60
from the uppercase letter's code point. For example, Ctrl+A (SOH) is
~~x01, and ~~x01 + ~~x60 = 97 = #\a, which interns as ~:a~.
Why 500ms for UTF-8 continuation byte timeout? This is intentionally
longer than the 50ms escape-sequence timeout. UTF-8 sequences are
streamed in real time from the terminal; if we're too aggressive, we
might cut off a multi-byte character during a slow paste or network
connection. The 500ms gives the terminal ample time to deliver all bytes.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %read-event (&key timeout)
(multiple-value-bind (b reason) (read-raw-byte :timeout timeout)
(unless b (return-from %read-event (if (eq reason :eof) :eof nil)))
(cond
((= b #x1b) (%read-escape-sequence))
((= b #x09) (make-key-event :key :tab :code #x09))
((= b #x0a) (make-key-event :key :enter :code #x0a))
((= b #x0d) (make-key-event :key :enter :code #x0d))
((or (= b #x7f) (= b #x08)) (make-key-event :key :backspace :code b))
((and (>= b #x01) (<= b #x1a))
(let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword)))
(make-key-event :key key :ctrl t :code b)))
((= b #x1c) (make-key-event :key :backslash :ctrl t :code b))
((= b #x1d) (make-key-event :key :rbracket :ctrl t :code b))
((= b #x1e) (make-key-event :key :caret :ctrl t :code b))
((= b #x1f) (make-key-event :key :underscore :ctrl t :code b))
((and (>= b #x20) (<= b #x7e))
(let ((ch (code-char b)))
(make-key-event :key (intern (string (string-upcase ch)) :keyword) :code b)))
((>= b #xc2)
(let* ((n (cond ((<= b #xdf) 2) ((<= b #xef) 3) (t 4)))
(bytes (list b)))
(loop for i from 1 below n
for b2 = (multiple-value-bind (byte reason) (read-raw-byte :timeout 0.5)
(declare (ignore reason)) byte)
while (and b2 (<= #x80 b2 #xbf))
do (push b2 bytes))
(setf bytes (nreverse bytes))
(if (= (length bytes) n)
(let ((cp (utf8-decode bytes)))
(if cp (make-key-event :key :codepoint :code cp :raw (map 'string #'code-char bytes))
(make-key-event :key :unknown :raw (map 'string #'code-char bytes))))
(make-key-event :key :unknown :raw (map 'string #'code-char bytes)))))
(t (make-key-event :key :unknown :code b :raw (string (code-char b)))))))
#+END_SRC
** Terminal resize detection
~*terminal-resized-p*~ is a flag set by a SIGWINCH signal handler.
When the terminal emulator window is resized, the kernel sends SIGWINCH
to the foreground process group. SBCL's signal handling facility
(~sb-sys:enable-interrupt~) lets us install a handler that sets this
flag. The ~:sb-posix~ module must be ~require~d first so that the
~sb-posix:sigwinch~ constant is available.
The main event loop should check this flag after each ~%read-event~
call and, if set, query the new terminal dimensions and redraw. The
flag is not automatically cleared — the consumer must set it to ~nil~
after handling the resize.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *terminal-resized-p* nil)
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
#+sbcl
(eval-when (:load-toplevel :execute)
(require :sb-posix)
(sb-sys:enable-interrupt sb-posix:sigwinch
(lambda (signal info context)
(declare (ignore signal info context))
(setf *terminal-resized-p* t))))
#+END_SRC
** Raw terminal mode
Most terminal applications need raw mode (no echo, character-by-character
input). SBCL's ~SB-POSIX:WITH-RAW-TERMINAL~ is not available in all builds
(e.g. Debian-packaged SBCL 2.5.x). This implementation uses ~stty~ for
portability.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %raw-mode-on ()
(uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr")
:output nil :error-output nil :ignore-error-status t))
(defun %raw-mode-off ()
(uiop:run-program '("stty" "sane")
:output nil :error-output nil :ignore-error-status t))
(defmacro with-raw-terminal (&body body)
"Execute BODY with the terminal in raw mode."
`(unwind-protect
(progn (%raw-mode-on) ,@body)
(%raw-mode-off)))
#+END_SRC
** Backend protocol integration
~read-event~ is a ~defmethod~ on the backend generic function, part of the
cl-tty backend protocol. This allows the same application code to read
input regardless of which backend is active.
The implementation probes ~/dev/stdin~ (which is a symlink to the actual
terminal device when stdin is a terminal) and, if it exists, delegates to
~%read-event~. The ~(declare (ignore b))~ means this method ignores the
backend instance — terminal input is independent of the output backend.
This method is deliberately simple: it's a thin wrapper that adapts the
~%read-event~ API to the backend protocol's ~read-event~ generic function.
All the complexity lives in ~%read-event~ and its callees.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defmethod read-event ((b cl-tty.backend:backend) &key timeout)
;; Check for pending terminal resize before reading input.
;; The SIGWINCH handler sets *terminal-resized-p* asynchronously.
(when *terminal-resized-p*
(setf *terminal-resized-p* nil)
(multiple-value-bind (w h) (backend-size b)
(return-from read-event (values :resize (cons w h)))))
(when (probe-file "/dev/stdin")
(%read-event :timeout timeout)))
#+END_SRC
* Textarea Widget
The textarea is a multi-line text editing widget with undo/redo support,
cursor movement across lines, and line-based operations (newline, join,
delete at line boundaries).
All blocks tangle to ~../src/components/textarea.lisp~.
** Textarea class definition
The textarea class inherits from ~dirty-mixin~ (from cl-tty.box) for
automatic dirty-flag tracking used by the rendering pipeline. Key slots:
- ~value~: The full text content as a single string with embedded newlines.
- ~cursor-row~ / ~cursor-col~: The cursor position in row/column coordinates.
Row 0 is the first line of ~value~; col 0 is the first character of that line.
- ~selection-start~: Cursor position when a selection began (nil when no selection).
- ~undo-stack~ / ~redo-stack~: Fill-pointer vectors (capacity 100) for
linear undo/redo. The fill-pointer acts as a stack pointer — ~vector-push~
pushes, ~vector-pop~ pops, and resetting the fill-pointer to 0 clears.
- ~on-submit~: Optional callback invoked on Enter when set. If nil, Enter
inserts a newline.
- ~layout-node~: Position/size info for the rendering system.
- ~focusable~: Whether this widget can receive keyboard focus.
Why fill-pointer vectors instead of lists for undo/redo? Vectors provide
O(1) indexed access, bounded memory (capacity 100), and ~vector-push~
avoids consing on every keystroke. The eviction strategy (oldest entries
shift out when full) keeps memory bounded.
This is the first block tangling to textarea.lisp, so it includes the
~in-package~ form.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(in-package #:cl-tty.input)
(defclass textarea (dirty-mixin)
((value :initform "" :initarg :value :accessor textarea-value :type string)
(cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum)
(cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum)
(selection-start :initform nil :accessor textarea-selection-start)
(undo-stack :initform (make-array 100 :fill-pointer 0)
:accessor textarea-undo-stack)
(redo-stack :initform (make-array 100 :fill-pointer 0)
:accessor textarea-redo-stack)
(on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit)
(layout-node :initform (make-layout-node) :accessor textarea-layout-node)
(focusable :initform t :accessor textarea-focusable)))
#+END_SRC
** Textarea constructor
~make-textarea~ is a convenience constructor that wraps ~make-instance~
with sensible defaults. It accepts ~:value~ and ~:on-submit~ keyword
arguments, defaulting ~value~ to the empty string if not provided.
The constructor is a separate function rather than a ~:constructor~
option on ~defclass~ because it needs to normalize the value argument
~(or value "")~ — a pattern that would clutter the class definition.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun make-textarea (&key value on-submit)
(make-instance 'textarea
:value (or value "")
:on-submit on-submit))
#+END_SRC
** Line helpers
The ~textarea-lines~ function splits the value into a list of lines.
It delegates to ~%split-string~ (defined in input.lisp) with #\Newline
as the separator. For an empty string, this returns ~("")~ — one empty
line, which is the correct representation of a blank document.
~textarea-line-count~ is a simple wrapper for the number of lines.
It's used by cursor movement functions to clamp the cursor row.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-lines (ta)
"Split value into lines."
(%split-string (textarea-value ta) #\Newline))
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-line-count (ta)
"Number of lines in value."
(length (textarea-lines ta)))
#+END_SRC
** Cursor clamping
~textarea-ensure-cursor~ clamps the cursor position to valid ranges
after any operation that might move it out of bounds. It:
1. Clamps ~cursor-row~ to [0, line-count-1].
2. Clamps ~cursor-col~ to [0, current-line-length].
This function is called after every cursor movement and after edits
that change line structure (newline, backspace joining lines). It
also marks the widget dirty, ensuring the renderer picks up the
cursor position change.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-ensure-cursor (ta)
"Clamp cursor to valid range."
(let ((lines (textarea-lines ta)))
(setf (textarea-cursor-row ta)
(max 0 (min (textarea-cursor-row ta) (1- (length lines)))))
(let ((line-len (length (nth (textarea-cursor-row ta) lines))))
(setf (textarea-cursor-col ta)
(max 0 (min (textarea-cursor-col ta) line-len)))))
(mark-dirty ta))
#+END_SRC
** Line joiner utility
~%join-lines~ is the inverse of ~%split-string~: it takes a sequence of
strings (list or vector) and joins them with #\Newline separators. It
uses ~with-output-to-string~ for efficient string construction.
The function handles both lists and vectors because different parts of
the textarea code work with different representations — ~textarea-lines~
returns a list, but the insertion/backspace code operates on vectors
for efficient element replacement.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun %join-lines (lines)
"Join a sequence of strings with newlines."
(with-output-to-string (s)
(loop for line across (if (listp lines) (coerce lines 'vector) lines)
for first = t then nil
do (unless first (write-char #\Newline s))
(write-string line s))))
#+END_SRC
** Character insertion
~textarea-insert-char~ inserts a single character at the cursor position
within the current line. The algorithm:
1. Push undo state (so the insertion can be undone).
2. Split the value into lines (coerced to vector for indexed access).
3. If the cursor row is within the current line count, insert the
character into that line at the cursor column by concatenating
the prefix, the character, and the suffix.
4. If the cursor row is beyond the last line (shouldn't happen with
proper cursor clamping, but handled defensively), append the
character to the end of the full value.
The function updates ~cursor-col~ by 1 after insertion and marks the
widget dirty.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-insert-char (ta char)
"Insert CHAR at the cursor position."
(textarea-push-undo ta)
(let* ((lines (coerce (textarea-lines ta) 'vector))
(row (textarea-cursor-row ta))
(col (textarea-cursor-col ta)))
(if (< row (length lines))
(let* ((line (aref lines row))
(new-line (concatenate 'string
(subseq line 0 col)
(string char)
(subseq line col))))
(setf (aref lines row) new-line)
(setf (textarea-value ta)
(%join-lines lines))
(incf (textarea-cursor-col ta))
(mark-dirty ta))
(progn
(setf (textarea-value ta)
(concatenate 'string (textarea-value ta) (string char)))
(incf (textarea-cursor-col ta))
(mark-dirty ta)))))
#+END_SRC
** Newline insertion
~textarea-newline~ splits the current line at the cursor column and
inserts a newline character between the two halves.
Algorithm:
1. Push undo state.
2. Split the value into lines (coerced to vector).
3. If the cursor row is valid, split the current line into ~before~
(characters before cursor) and ~after~ (characters after).
4. Replace the current line with ~before~ and insert ~after~ as a
new line immediately after.
5. Move cursor to the start of the new line (row+1, col=0).
6. If the cursor row is beyond the last line, simply append a newline.
7. Mark dirty.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-newline (ta)
"Insert a newline at the cursor."
(textarea-push-undo ta)
(let* ((lines (coerce (textarea-lines ta) 'vector))
(row (textarea-cursor-row ta))
(col (textarea-cursor-col ta)))
(if (< row (length lines))
(let* ((line (aref lines row))
(before (subseq line 0 col))
(after (subseq line col)))
(setf (aref lines row) before)
(let ((new-lines (concatenate 'vector
(subseq lines 0 (1+ row))
(vector after)
(subseq lines (1+ row)))))
(setf (textarea-value ta)
(%join-lines new-lines)))
(incf (textarea-cursor-row ta))
(setf (textarea-cursor-col ta) 0)
(mark-dirty ta))
(progn
(setf (textarea-value ta)
(concatenate 'string (textarea-value ta) (string #\Newline)))
(incf (textarea-cursor-row ta))
(setf (textarea-cursor-col ta) 0)
(mark-dirty ta)))))
#+END_SRC
** Backspace
~textarea-backspace~ handles both character deletion and line joining:
1. At (0,0): nothing to delete — return nil.
2. At column 0 (start of a non-first line): join the current line
with the previous line. Cursor moves to the end of the previous line.
3. At any other column: delete the character before the cursor within
the current line.
The line-joining behavior is what distinguishes multi-line backspace
from single-line backspace. When the cursor is at column 0 of a line,
backspace conceptually "pulls" that line up to the end of the previous
line, removing the newline character between them.
All paths push undo state before modifying the value.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-backspace (ta)
"Delete character before cursor."
(textarea-push-undo ta)
(let* ((lines (coerce (textarea-lines ta) 'vector))
(row (textarea-cursor-row ta))
(col (textarea-cursor-col ta)))
(cond
((and (zerop row) (zerop col))
nil) ;; nothing to delete
((zerop col)
;; Join with previous line
(let* ((prev (aref lines (1- row)))
(curr (aref lines row))
(new-pos (length prev)))
(setf (aref lines (1- row))
(concatenate 'string prev curr))
(let ((new-lines (concatenate 'vector
(subseq lines 0 row)
(subseq lines (1+ row)))))
(setf (textarea-value ta)
(%join-lines new-lines)))
(decf (textarea-cursor-row ta))
(setf (textarea-cursor-col ta) new-pos)
(mark-dirty ta)))
(t
(let* ((line (aref lines row))
(new-line (concatenate 'string
(subseq line 0 (1- col))
(subseq line col))))
(setf (aref lines row) new-line)
(setf (textarea-value ta)
(%join-lines lines))
(decf (textarea-cursor-col ta))
(mark-dirty ta))))))
#+END_SRC
** Cursor movement: up/down
~textarea-move-up~ and ~textarea-move-down~ move the cursor between lines
while preserving the column position as much as possible. The decrement
or increment on ~cursor-row~ may produce a row outside the valid range,
but ~textarea-ensure-cursor~ clamps it immediately afterward.
The column preservation is implicit: ~textarea-ensure-cursor~ clamps
the column to the new line's length, so if the user was at column 10
on a long line and moves up to a shorter 5-character line, the column
clamps to 5. This matches how most editors handle column preservation
— the column "remembers" its position but is constrained by line length.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-move-up (ta)
(decf (textarea-cursor-row ta))
(textarea-ensure-cursor ta))
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-move-down (ta)
(incf (textarea-cursor-row ta))
(textarea-ensure-cursor ta))
#+END_SRC
** Undo/redo system
The undo system uses fill-pointer vectors as bounded stacks (capacity 100).
Each edit pushes the current value onto the undo stack before modifying it.
~textarea-push-undo~: Saves the current value onto the undo stack.
If the stack is full (fill-pointer >= total-size), it shifts all entries
left by one (dropping the oldest) and decrements the fill-pointer, making
room for the new entry. It then pushes the current value and clears the
redo stack (any new edit invalidates the redo history).
~textarea-undo~: Pops the most recent value from the undo stack, pushes
the current value onto the redo stack, restores the popped value, and
clamps the cursor via ~textarea-ensure-cursor~.
~textarea-redo~: Pops the most recent value from the redo stack, pushes
the current value onto the undo stack, restores the popped value, and
clamps the cursor.
Why clear the redo stack on new edits? This is the standard "linear undo"
model — once you make a new edit after undoing, the redo history is
discarded because the edit graph has branched. Implementing a full tree
undo would be significantly more complex and is unnecessary for a TUI
textarea.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-push-undo (ta)
"Save current value on undo stack."
(let ((stack (textarea-undo-stack ta)))
(when (>= (length stack) (array-total-size stack))
(loop for i from 1 below (length stack)
do (setf (aref stack (1- i)) (aref stack i)))
(decf (fill-pointer stack)))
(vector-push (textarea-value ta) stack)
(setf (fill-pointer (textarea-redo-stack ta)) 0)))
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-undo (ta)
(let ((stack (textarea-undo-stack ta)))
(when (plusp (length stack))
(let ((prev (vector-pop stack)))
(vector-push (textarea-value ta) (textarea-redo-stack ta))
(setf (textarea-value ta) prev)
(textarea-ensure-cursor ta)
(mark-dirty ta)))))
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-redo (ta)
(let ((stack (textarea-redo-stack ta)))
(when (plusp (length stack))
(let ((next (vector-pop stack)))
(vector-push (textarea-value ta) (textarea-undo-stack ta))
(setf (textarea-value ta) next)
(textarea-ensure-cursor ta)
(mark-dirty ta)))))
#+END_SRC
** Textarea key event handler
~handle-textarea-input~ is the main event dispatcher for the textarea.
It processes ~key-event~ instances and delegates to the appropriate
textarea operation or performs inline actions.
Ctrl+key bindings:
- Ctrl+Z → undo
- Ctrl+Y → redo
- Ctrl+A → home (move cursor-col to 0 on current line)
- Ctrl+E → end (move cursor-col to end of current line)
Unmodified key bindings:
- :left/:right → column movement with cursor clamping
- :up/:down → row movement with cursor clamping
- :home/:end → column extremes
- :enter → on-submit callback if set, otherwise insert newline
- :backspace → delete before cursor / join lines
- :delete → delete at cursor (character under cursor)
- Other printable characters → insert at cursor via ~key-event-code~
The printable character insertion uses ~code-char~ on ~key-event-code~
rather than looking at ~key-event-key~. This is because ~key-event-key~
is always an uppercase keyword (~:a~ for both 'a' and 'A'), but the
code preserves the actual character.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun handle-textarea-input (ta event)
"Process a key-event on a textarea widget."
(cond
((key-event-ctrl event)
(case (key-event-key event)
(:z (textarea-undo ta))
(:y (textarea-redo ta))
;; Ctrl+A/E: home/end
(:a (setf (textarea-cursor-col ta) 0))
(:e (let ((lines (textarea-lines ta)))
(when (< (textarea-cursor-row ta) (length lines))
(setf (textarea-cursor-col ta)
(length (nth (textarea-cursor-row ta) lines))))))
(t nil)))
(t
(case (key-event-key event)
(:left (decf (textarea-cursor-col ta))
(textarea-ensure-cursor ta))
(:right (incf (textarea-cursor-col ta))
(textarea-ensure-cursor ta))
(:up (textarea-move-up ta))
(:down (textarea-move-down ta))
(:home (setf (textarea-cursor-col ta) 0)
(textarea-ensure-cursor ta))
(:end (let ((lines (textarea-lines ta)))
(when (< (textarea-cursor-row ta) (length lines))
(setf (textarea-cursor-col ta)
(length (nth (textarea-cursor-row ta) lines))))
(textarea-ensure-cursor ta)))
(:enter (let ((cb (textarea-on-submit ta)))
(if cb
(funcall cb (textarea-value ta))
(textarea-newline ta))))
(:backspace (textarea-backspace ta))
(:delete (let* ((lines (textarea-lines ta))
(row (textarea-cursor-row ta))
(col (textarea-cursor-col ta))
(line (nth row lines)))
(when (and line (< col (length line)))
(textarea-push-undo ta)
(setf (nth row lines)
(concatenate 'string
(subseq line 0 col)
(subseq line (1+ col))))
(setf (textarea-value ta)
(%join-lines lines))
(mark-dirty ta))))
;; Character insertion
(otherwise
(let ((ch (code-char (key-event-code event))))
(when (and ch (graphic-char-p ch))
(textarea-insert-char ta ch))))))))
#+END_SRC
** Textarea rendering
~render~ for textarea draws the visible portion of the text content
within the widget's layout bounds. It:
1. Retrieves the layout node for position and size.
2. Splits the value into lines.
3. Loops over the visible lines (up to the available height).
4. For each line, draws it at the correct position, truncating to the
available width.
The render method iterates ~max-lines~ (minimum of total lines and
available height) to avoid drawing outside the widget boundaries.
Each line is truncated to ~w~ characters to prevent horizontal overflow.
Cursor rendering is handled by the focus/selection rendering layer,
not by this method. This keeps the render method simple — it just
paints text.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defmethod render ((ta textarea) (backend t))
"Render textarea lines at layout position."
(let* ((ln (textarea-layout-node ta))
(x (if ln (layout-node-x ln) 0))
(y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(h (if ln (layout-node-height ln) 24))
(lines (textarea-lines ta))
(max-lines (min (length lines) h)))
(loop for i from 0 below max-lines
for line in lines
do (draw-text backend x (+ y i)
(subseq line 0 (min (length line) w))
nil nil))))
#+END_SRC
* Text Input Widget
TextInput is a single-line text editing widget with cursor movement,
character insertion/deletion, word deletion, and emacs-style keyboard
shortcuts.
All blocks tangle to ~../src/components/text-input.lisp~.
** Text input class definition
The TextInput class inherits from ~dirty-mixin~ for automatic dirty
tracking. Slots:
- ~value~: The text content (single line, no newline characters).
- ~cursor~: The cursor position as a 0-indexed integer offset from the
start of ~value~.
- ~placeholder~: Text displayed when ~value~ is empty, giving the user
a hint about what to type.
- ~max-length~: Optional maximum character count. When set, insertions
beyond this limit are silently rejected.
- ~on-submit~: Callback invoked with the current value when Enter is pressed.
- ~layout-node~: Position/size info for rendering.
- ~focusable~: Whether this widget can receive keyboard focus.
This is the first block tangling to text-input.lisp, so it includes the
~in-package~ form.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(in-package #:cl-tty.input)
(defclass text-input (dirty-mixin)
((value :initform "" :initarg :value :accessor text-input-value
:type string)
(cursor :initform 0 :initarg :cursor :accessor text-input-cursor
:type fixnum)
(placeholder :initform "" :initarg :placeholder
:accessor text-input-placeholder :type string)
(max-length :initform nil :initarg :max-length
:accessor text-input-max-length)
(on-submit :initform nil :initarg :on-submit
:accessor text-input-on-submit)
(on-cancel :initform nil :initarg :on-cancel
:accessor text-input-on-cancel)
(on-tab :initform nil :initarg :on-tab
:accessor text-input-on-tab)
(on-history :initform nil :initarg :on-history
:accessor text-input-on-history)
(layout-node :initform (make-layout-node) :accessor text-input-layout-node)
(focusable :initform t :accessor text-input-focusable)))
#+END_SRC
** Text input constructor
~make-text-input~ wraps ~make-instance~ with keyword arguments and
sensible defaults. Each optional parameter has a fallback: ~value~
defaults to "", ~cursor~ to 0, ~placeholder~ to "", and ~max-length~
and ~on-submit~ to nil (disabled).
The ~(or value "")~ pattern ensures the value is always a string,
even if the caller passes nil. This eliminates a class of nil-pointer
errors in string operations downstream.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun make-text-input (&key value cursor placeholder max-length
on-submit on-cancel on-tab on-history)
(make-instance 'text-input
:value (or value "")
:cursor (or cursor 0)
:placeholder (or placeholder "")
:max-length max-length
:on-submit on-submit
:on-cancel on-cancel
:on-tab on-tab
:on-history on-history))
#+END_SRC
** Character insertion
~text-input-insert~ inserts a character at the cursor position within
the single-line value. The algorithm:
1. Check ~max-length~: if set and the value is already at the limit,
return immediately (the character is silently dropped).
2. Construct the new value by concatenating the prefix (before cursor),
the new character, and the suffix (after cursor).
3. Increment the cursor by 1.
4. Mark the widget dirty.
This is a pure insert — it does not replace the character at the cursor;
it shifts subsequent characters right. For overwrite behavior, the caller
would need a different function.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-insert (input char)
(let* ((val (text-input-value input))
(pos (text-input-cursor input))
(max (text-input-max-length input)))
(when (and max (>= (length val) max)) (return-from text-input-insert))
(setf (text-input-value input) (concatenate 'string (subseq val 0 pos) (string char) (subseq val pos)))
(incf (text-input-cursor input))
(mark-dirty input)))
#+END_SRC
** Backspace
~text-input-backspace~ deletes the character immediately before the
cursor. If the cursor is at position 0, nothing happens.
The algorithm concatenates the prefix (up to one before cursor) with
the suffix (from cursor onward), effectively removing the character
at cursor-1. The cursor is decremented by 1.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-backspace (input)
(let* ((val (text-input-value input)) (pos (text-input-cursor input)))
(when (zerop pos) (return-from text-input-backspace))
(setf (text-input-value input) (concatenate 'string (subseq val 0 (1- pos)) (subseq val pos)))
(decf (text-input-cursor input))
(mark-dirty input)))
#+END_SRC
** Delete
~text-input-delete~ removes the character at the cursor position.
If the cursor is at or beyond the end of the value, nothing happens.
The algorithm concatenates the prefix (up to cursor) with the suffix
(from cursor+1 onward), removing the character at cursor without
moving the cursor position.
This contrasts with backspace, which removes the character before
cursor and decrements the cursor.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-delete (input)
(let* ((val (text-input-value input)) (pos (text-input-cursor input)))
(when (>= pos (length val)) (return-from text-input-delete))
(setf (text-input-value input) (concatenate 'string (subseq val 0 pos) (subseq val (1+ pos))))
(mark-dirty input)))
#+END_SRC
** Cursor movement: left/right
~text-input-move-left~ and ~text-input-move-right~ move the cursor by
one character position, clamped to [0, length]. Left movement stops at
0; right movement stops at the end of the value.
Each movement function marks the widget dirty so the renderer redraws
the cursor position.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-move-left (input)
(when (plusp (text-input-cursor input)) (decf (text-input-cursor input)))
(mark-dirty input))
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-move-right (input)
(when (< (text-input-cursor input) (length (text-input-value input))) (incf (text-input-cursor input)))
(mark-dirty input))
#+END_SRC
** Cursor movement: home/end
~text-input-move-home~ moves the cursor to position 0 (start of value).
~text-input-move-end~ moves the cursor to the end of the value.
These are the programmatic equivalents of the Home and End keys and
are also used by the Ctrl+A and Ctrl+E keybindings.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-move-home (input)
(setf (text-input-cursor input) 0)
(mark-dirty input))
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-move-end (input)
(setf (text-input-cursor input) (length (text-input-value input)))
(mark-dirty input))
#+END_SRC
** Word-delete before cursor
~text-input-delete-word-before~ implements Ctrl+W / Emacs ~backward-kill-word~.
It deletes from the cursor position backward to the previous word boundary.
The algorithm:
1. Find the last non-space character before the cursor (~start~).
If none exists, ~start~ is 0.
2. Find the last space character before ~start~. If none, ~word-start~ is 0.
3. Compute ~delete-start~: the position from which to start deleting.
- If word-start is 0 and the first character is non-space (or start is 0),
delete from 0.
- Otherwise, delete from one past the last space (i.e., the start of the
word before the cursor).
A "word" here is defined as a run of non-space characters. This matches
the shell/Emacs convention for Ctrl+W rather than an English word boundary
(which would involve punctuation handling).
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-delete-word-before (input)
(let* ((val (text-input-value input)) (pos (text-input-cursor input)))
(when (zerop pos) (return-from text-input-delete-word-before))
(let* ((start (or (position-if (lambda (c) (not (char= c #\Space))) val :end pos :from-end t) 0))
(word-start (or (and (plusp start) (position #\Space val :end start :from-end t)) 0))
(delete-start (if (and (zerop word-start) (or (char/= (char val 0) #\Space) (zerop start)))
0
(if (zerop start) (1+ word-start) (1+ (or (position #\Space val :end start :from-end t) 0))))))
(setf (text-input-value input) (concatenate 'string (subseq val 0 delete-start) (subseq val pos)))
(setf (text-input-cursor input) delete-start)
(mark-dirty input))))
#+END_SRC
** Text input key event handler
~handle-text-input~ is the main event dispatcher for TextInput.
Ctrl+key bindings (Emacs-style):
- Ctrl+A → move to home (start of line)
- Ctrl+E → move to end
- Ctrl+W → delete word before cursor
- Ctrl+U → delete from cursor to start of line
- Ctrl+K → delete from cursor to end of line
Unmodified key bindings:
- :left/:right → cursor movement
- :home/:end → extremes
- :backspace/:delete → character deletion
- :enter → invoke on-submit callback with current value
- :tab/:escape → ignored (no-op)
- Other → insert as printable character via ~key-event-code~
The printable character check uses ~graphic-char-p~ to ensure only
visible characters (letters, digits, punctuation, symbols) are
inserted. Control characters and spaces are handled by their specific
key bindings.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun handle-text-input (input event)
(cond
((key-event-ctrl event)
(case (key-event-key event)
(:a (text-input-move-home input))
(:e (text-input-move-end input))
(:w (text-input-delete-word-before input))
(:u (progn (setf (text-input-value input) (subseq (text-input-value input) (text-input-cursor input)))
(setf (text-input-cursor input) 0) (mark-dirty input)))
(:k (progn (setf (text-input-value input) (subseq (text-input-value input) 0 (text-input-cursor input)))
(mark-dirty input)))
(t nil)))
(t
(case (key-event-key event)
(:left (text-input-move-left input))
(:right (text-input-move-right input))
(:home (text-input-move-home input))
(:end (text-input-move-end input))
(:backspace (text-input-backspace input))
(:delete (text-input-delete input))
(:enter (let ((cb (text-input-on-submit input))) (when cb (funcall cb (text-input-value input)))))
(:tab (let ((cb (text-input-on-tab input)))
(when cb
(multiple-value-bind (new-text new-pos)
(funcall cb (text-input-value input) (text-input-cursor input))
(when new-text
(setf (text-input-value input) new-text
(text-input-cursor input) (or new-pos (length new-text)))
(mark-dirty input))))))
(:escape (let ((cb (text-input-on-cancel input))) (when cb (funcall cb))))
(:up (let ((cb (text-input-on-history input)))
(when cb
(multiple-value-bind (new-text new-pos)
(funcall cb :up)
(when new-text
(setf (text-input-value input) new-text
(text-input-cursor input) (or new-pos (length new-text)))
(mark-dirty input))))))
(:down (let ((cb (text-input-on-history input)))
(when cb
(multiple-value-bind (new-text new-pos)
(funcall cb :down)
(when new-text
(setf (text-input-value input) new-text
(text-input-cursor input) (or new-pos (length new-text)))
(mark-dirty input))))))
(otherwise (let ((code (key-event-code event)))
(when code
(let ((ch (code-char code)))
(when (and ch (graphic-char-p ch))
(text-input-insert input ch))))))))))
#+END_SRC
** Text input rendering
~render~ for TextInput draws the current value (or placeholder if the
value is empty) at the widget's layout position, truncated to the
available width.
Rendering steps:
1. Retrieve the layout node for position (x, y) and width (w).
2. Determine display text: if value is non-empty, use it; otherwise
use the placeholder (or empty string if placeholder is also empty).
3. Truncate the display text to the available width.
4. Draw the truncated text at (x, y) using the backend's ~draw-text~.
5. Draw the cursor as a block character ("█") at the cursor position
if the value is non-empty.
The cursor is a solid block ("█") drawn at the cursor column offset
from the text start. If the cursor is beyond the truncated display
width, it's clamped to the last visible position.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defmethod render ((in text-input) (backend t))
(let* ((ln (text-input-layout-node in))
(x (if ln (layout-node-x ln) 0)) (y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(value (text-input-value in)) (cursor (text-input-cursor in))
(display (if (plusp (length value)) value (or (text-input-placeholder in) ""))))
(when (zerop (length display)) (return-from render (values)))
(let* ((lines (cl-tty.box:word-wrap display w))
(n-lines (length lines)))
;; Draw each wrapped line
(loop for line in lines
for row from 0
do (let ((fg (if (plusp (length value)) nil :dim)))
(draw-text backend x (+ y row) line fg nil)))
;; Draw block cursor at the right position when value is non-empty
(when (plusp (length value))
(let ((cl 0) (cc 0) (accum 0))
(dotimes (i n-lines)
(let ((len (length (nth i lines))))
(when (and (>= cursor accum) (or (< cursor (+ accum len)) (= i (1- n-lines))))
(setf cl i cc (- cursor accum)))
(incf accum (1+ len))))
(let ((cx (+ x cc))
(cy (+ y cl)))
(draw-text backend cx cy "█" :bright-white nil)))))))
#+END_SRC
* Keybinding System
The keybinding system provides a flexible dispatch mechanism for
routing keystrokes to handler functions through layered keymaps.
Keymaps are named and stored in a global registry, allowing components
to install local keymaps that fall through to global keymaps.
All blocks tangle to ~../src/components/keybindings.lisp~.
** Keymap struct
The ~keymap~ struct is a simple data container with three slots:
- ~name~: A keyword identifier (e.g., ~:global~, ~:local~).
- ~bindings~: An alist of (spec . handler) pairs.
- ~parent~: An optional parent keymap for inheritance (reserved for
future use — currently the fallback chain is handled by name-based
lookup in ~dispatch-key-event~, not by the ~parent~ slot).
Like ~key-event~, this is a struct rather than a class because keymaps
are created frequently and never need CLOS dispatch on their own — all
polymorphism is handled by the dispatch function.
This is the first block tangling to keybindings.lisp, so it includes
the ~in-package~ form.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(in-package #:cl-tty.input)
(defstruct keymap
(name nil :type (or keyword null))
(bindings nil :type list)
(parent nil :type (or keymap null)))
#+END_SRC
** Global keymap registry
~*keymaps*~ is a hash table mapping keyword names (~:global~, ~:local~)
to ~keymap~ instances. The ~equal~ test allows string-keyword flexibility
(though in practice all keys are keywords).
~*chord-timeout*~ is a 0.5-second timeout reserved for future multi-key
chord support (e.g., ~(:ctrl+x :ctrl+s)~). Currently only single-key
specs work; the timeout and list-of-lists spec syntax are placeholders
for the eventual chord implementation.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defparameter *keymaps* (make-hash-table :test #'equal))
#+END_SRC
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defparameter *chord-timeout* 0.5)
#+END_SRC
** Key spec matching
~key-match-p~ compares a key specification (spec) against a ~key-event~.
The spec can be:
1. A keyword, like ~:ctrl+p~, ~:alt+f~, ~:enter~, ~:f1~.
- If the keyword contains ~+~, the part before ~+~ is the modifier
(CTRL, ALT, or SHIFT) and the part after is the key.
- Modifier names are matched case-insensitively with ~string=?~,
avoiding the ~case~ EQL trap (where ~:CTRL+p~ and ~:ctrl+p~ would
be different symbols).
- If no ~+~, the keyword is matched against ~key-event-key~ directly.
2. A list, like ~(:ctrl+p)~ or ~(:ctrl+x :ctrl+s)~.
- Currently only the first element is matched; the list form exists
for future chord support.
The modifier matching uses ~string=?~ on the modifier part because
~:CTRL+p~ and ~:Ctrl+p~ should both match Ctrl events. Using ~eql~
on the keyword would make them different specifiers, which is unexpected
for users writing ~:ctrl+p~ in their keymaps.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defun key-match-p (spec event)
"T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword)
or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords."
(etypecase spec
;; Keyword like :ctrl+p, :alt+f, :enter, :space, :f1
(keyword
(let* ((name (string spec))
(plus (position #\+ name)))
(if plus
;; Modified key: :ctrl+p -> mod-str="CTRL", key-str="P"
(let ((mod-str (subseq name 0 plus))
(key-str (subseq name (1+ plus))))
(and (eql (intern key-str :keyword)
(intern (string-upcase (symbol-name (key-event-key event))) :keyword))
(cond
((string= mod-str "CTRL") (key-event-ctrl event))
((string= mod-str "ALT") (key-event-alt event))
((string= mod-str "SHIFT") (key-event-shift event))
(t t))))
;; Plain keyword: :enter, :escape, :f1, etc.
(eql spec (key-event-key event)))))
;; List: (:ctrl+p) or (:ctrl+x :ctrl+s)
(list
(when spec
(key-match-p (first spec) event)))))
#+END_SRC
** Event dispatch
~dispatch-key-event~ is the main entry point for the keybinding system.
It implements a three-level lookup chain:
1. **Component keymap** (:keyword parameter): If the caller supplies a
~component~, the function calls ~component-keymap~ on it to get a
component-specific keymap. Matches in this keymap take highest priority.
2. **:local keymap**: Look up the ~:local~ keymap in ~*keymaps*~. This
is typically installed by the active "screen" or "mode" (e.g., a
help overlay might have its own local keymap).
3. **:global keymap**: Look up the ~:global~ keymap. This is the catch-all
for application-wide bindings.
Each level iterates the keymap's bindings alist and returns ~t~ as soon
as a matching handler is found and called. If no binding matches at any
level, returns ~nil~.
Important caveat: This function is NOT called automatically by the demo's
event loop or widget event handlers. Users who want keymap-based dispatch
MUST call ~dispatch-key-event~ explicitly in their own event loops, e.g.:
(defun handle-event (event)
(or (dispatch-key-event event)
(handle-text-input my-input event)
...))
Chords ~((:ctrl+x :ctrl+s))~ are not yet supported; only single
key specs work. The ~*chord-timeout*~ variable and list-of-lists syntax
are reserved for future implementation.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defun dispatch-key-event (event &key component)
(labels ((try-keymap (km)
(when km
(loop for (spec . handler) in (keymap-bindings km)
thereis (when (key-match-p spec event)
(funcall handler event)
t))))
(find-keymap (name)
(gethash name *keymaps*)))
(or (and component
(let ((km (component-keymap component)))
(when km (try-keymap km))))
(try-keymap (find-keymap :local))
(try-keymap (find-keymap :global)))))
#+END_SRC
** defkeymap macro
~defkeymap~ is a convenience macro that registers a keymap in the global
~*keymaps*~ hash table. Syntax:
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defmacro defkeymap (name &body bindings)
`(setf (gethash ',name *keymaps*)
(make-keymap :name ',name
:bindings (list ,@(loop for b in bindings
collect (if (consp (cdr b))
`(cons ',(car b) ,(cadr b))
`(cons ',(car b) ,(cdr b))))))))
#+END_SRC
** Component keymap protocol
~component-keymap~ is a generic function that returns a ~keymap~ instance
for a given component, or ~nil~ if the component has no keymap. The default
method on ~t~ returns ~nil~, meaning components must explicitly define a
method to participate in the keymap system.
This generic function allows the dispatch system to query any object for
its keymap, enabling per-component keybinding customization without
requiring components to inherit from a specific base class.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
;;; --- Component protocol integration ---
(defgeneric component-keymap (component)
(:method ((c t)) nil))
#+END_SRC
* Mouse support (merged from cl-tty.mouse)
Mouse event propagation through the component tree. The input system
already parses SGR mouse sequences into ~mouse-event~ structs. This
section adds:
1. A ~mouse-mixin~ class with event handler slots
2. Hit-testing: given (x,y), find the deepest component owning that cell
3. Event dispatch: route ~mouse-event~ → component handlers, bubble up
4. Text selection: drag highlight + clipboard copy
** mouse-mixin — mixin class for mouse event handler slots
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defclass mouse-mixin ()
((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down)
(on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up)
(on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move)
(on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll)))
#+END_SRC
** handle-mouse-event — dispatch mouse events to the right slot handler
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun handle-mouse-event (component event)
(let* ((type (mouse-event-type event))
(handler (case type
(:press (on-mouse-down component))
(:release (on-mouse-up component))
(:drag (on-mouse-move component))
(t nil))))
(when handler (funcall handler event))))
#+END_SRC
** hit-test — find the deepest component at a given (x, y)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun hit-test (root x y)
"Find the deepest component at (X, Y) by testing layout-node bounds."
(labels ((recurse (node)
(let ((ln (ignore-errors (component-layout-node node)))
(best nil))
(when ln
(let ((nx (layout-node-x ln))
(ny (layout-node-y ln))
(nw (layout-node-width ln))
(nh (layout-node-height ln)))
(dolist (child (ignore-errors (component-children node)))
(let ((child-hit (recurse child)))
(when child-hit (setf best child-hit))))
(or best
(when (and (>= x nx) (< x (+ nx nw))
(>= y ny) (< y (+ ny nh)))
node)))))))
(recurse root)))
#+END_SRC
** Selection state
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *selection* nil)
(defvar *selection-active* nil "T when a drag selection is in progress.")
(defvar *selection-start* nil "Cons (X . Y) of mouse-down position during drag.")
(defvar *selection-end* nil "Cons (X . Y) of current mouse position during drag.")
#+END_SRC
** selection struct
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defstruct (selection (:conc-name sel-))
(start-x 0) (start-y 0) (end-x 0) (end-y 0) (text ""))
#+END_SRC
** get-selection / copy-to-clipboard
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun get-selection ()
(when *selection* (sel-text *selection*)))
(defun copy-to-clipboard (text)
#+linux
(cond
((sb-ext:posix-getenv "WAYLAND_DISPLAY")
(sb-ext:run-program "wl-copy" nil :input text :wait nil))
(t
(sb-ext:run-program "xclip" (list "-selection" "clipboard")
:input text :wait nil)))
#+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil))
#+END_SRC
** start-selection / update-selection
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun start-selection (x y)
"Begin a drag selection at (X Y)."
(setf *selection-start* (cons x y)
*selection-end* (cons x y)
*selection-active* t))
(defun update-selection (x y)
"Update the drag selection end position to (X Y)."
(setf *selection-end* (cons x y)))
#+END_SRC
** selection-active-p
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun selection-active-p ()
"Return T if a drag selection is in progress."
*selection-active*)
#+END_SRC
** finalize-selection
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun finalize-selection (fb)
"End the drag selection and extract text from the framebuffer."
(setf *selection-active* nil)
(when (and *selection-start* *selection-end* fb)
(let* ((x1 (car *selection-start*))
(y1 (cdr *selection-start*))
(x2 (car *selection-end*))
(y2 (cdr *selection-end*))
(text (cl-tty.rendering:extract-text fb x1 y1 x2 y2)))
(setf *selection* (make-selection :start-x x1 :start-y y1
:end-x x2 :end-y y2
:text text))
(setf *selection-start* nil *selection-end* nil)
text)))
#+END_SRC
** cell-link-at / open-link-at
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun cell-link-at (fb x y)
"Return the link URL at (X Y) in framebuffer FB, or nil."
(cl-tty.rendering:fb-cell-link-url fb x y))
(defun open-link-at (fb x y)
"If there is a link URL at (X Y) in FB, open it via xdg-open."
(let ((url (cell-link-at fb x y)))
(when url
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
url))
#+END_SRC
* Tests
The test suite is tangled to ~../tests/input-tests.lisp~ and covers:
- Key event construction and accessor correctness
- Mouse event construction and accessor correctness
- UTF-8 decoding (Latin-1 supplement, Euro sign, emoji, invalid sequences)
- TextInput operations (insert, backspace, delete, cursor movement,
home/end, max-length, placeholder, on-submit, Ctrl+A/E, insertion
in middle, dirty tracking)
- Textarea operations (empty, newline, cursor up/down, bounds,
backspace line-joining, undo, redo)
- Keybinding dispatch (simple match, no match, fallthrough,
key-spec matching with all modifiers, list-form specs, return values,
empty keymap, local-over-global, multiple bindings, defkeymap macro)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/input-tests.lisp
(defpackage :cl-tty-input-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
(:export #:run-tests))
(in-package :cl-tty-input-test)
(def-suite input-suite :description "Text input and keybinding tests")
(in-suite input-suite)
(defun run-tests ()
(let ((result (run 'input-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
;; ── Key Event Tests ─────────────────────────────────────────────
(test key-event-construction
"A key-event can be created and queried."
(let ((e (make-key-event :key :a :ctrl t :alt nil)))
(is (eql (key-event-key e) :a))
(is-true (key-event-ctrl e))
(is-false (key-event-alt e))))
(test key-event-defaults
"Fields default to NIL/nil."
(let ((e (make-key-event :key :space)))
(is (eql (key-event-key e) :space))
(is-false (key-event-ctrl e))
(is-false (key-event-alt e))
(is-false (key-event-shift e))))
(test mouse-event-construction
"A mouse-event can be created and queried."
(let ((e (make-mouse-event :type :press :button :left :x 10 :y 5)))
(is (eql (mouse-event-type e) :press))
(is (eql (mouse-event-button e) :left))
(is (= (mouse-event-x e) 10))
(is (= (mouse-event-y e) 5))))
;; ── UTF-8 Decode Tests ──────────────────────────────────────────
(test utf8-decode-latin1-supplement
"0xC3 0xA9 (é) decodes to code point 233."
(is (= (cl-tty.input:utf8-decode '(#xc3 #xa9)) 233)))
(test utf8-decode-euro-sign
"0xE2 0x82 0xAC (€) decodes to code point 8364."
(is (= (cl-tty.input:utf8-decode '(#xe2 #x82 #xac)) 8364)))
(test utf8-decode-emoji
"0xF0 0x9F 0x92 0xA9 (💩) decodes to code point 128169."
(is (= (cl-tty.input:utf8-decode '(#xf0 #x9f #x92 #xa9)) 128169)))
(test utf8-decode-invalid-short
"Invalid byte 0x80 alone returns nil."
(is-false (cl-tty.input:utf8-decode '(#x80))))
(test utf8-decode-invalid-overlong
"Overlong 2-byte sequence 0xC0 0x80 returns nil."
(is-false (cl-tty.input:utf8-decode '(#xc0 #x80))))
;; ── TextInput Tests ─────────────────────────────────────────────
(test text-input-empty
"A newly created text-input has empty value and cursor at 0."
(let ((in (make-text-input)))
(is (string= (text-input-value in) ""))
(is (= (text-input-cursor in) 0))))
(test text-input-insert-char
"Inserting a character appends and moves cursor."
(let ((in (make-text-input)))
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
(is (string= (text-input-value in) "a"))
(is (= (text-input-cursor in) 1))))
(test text-input-insert-multiple
"Inserting multiple characters works left to right."
(let ((in (make-text-input)))
(handle-text-input in (make-key-event :key :h :code (char-code #\h)))
(handle-text-input in (make-key-event :key :e :code (char-code #\e)))
(handle-text-input in (make-key-event :key :l :code (char-code #\l)))
(handle-text-input in (make-key-event :key :l :code (char-code #\l)))
(handle-text-input in (make-key-event :key :o :code (char-code #\o)))
(is (string= (text-input-value in) "hello"))
(is (= (text-input-cursor in) 5))))
(test text-input-backspace
"Backspace removes the character before the cursor."
(let ((in (make-text-input :value "ab" :cursor 2)))
(handle-text-input in (make-key-event :key :backspace))
(is (string= (text-input-value in) "a"))
(is (= (text-input-cursor in) 1))))
(test text-input-backspace-at-start
"Backspace at position 0 does nothing."
(let ((in (make-text-input :value "ab" :cursor 0)))
(handle-text-input in (make-key-event :key :backspace))
(is (string= (text-input-value in) "ab"))
(is (= (text-input-cursor in) 0))))
(test text-input-delete
"Delete removes the character at the cursor."
(let ((in (make-text-input :value "abc" :cursor 1)))
(handle-text-input in (make-key-event :key :delete))
(is (string= (text-input-value in) "ac"))
(is (= (text-input-cursor in) 1))))
(test text-input-cursor-left-right
"Cursor moves left and right."
(let ((in (make-text-input :value "ab" :cursor 2)))
(handle-text-input in (make-key-event :key :left))
(is (= (text-input-cursor in) 1))
(handle-text-input in (make-key-event :key :right))
(is (= (text-input-cursor in) 2))))
(test text-input-cursor-bounds
"Cursor cannot move past start or end."
(let ((in (make-text-input :value "ab" :cursor 0)))
(handle-text-input in (make-key-event :key :left))
(is (= (text-input-cursor in) 0))
(setf (text-input-cursor in) 2)
(handle-text-input in (make-key-event :key :right))
(is (= (text-input-cursor in) 2))))
(test text-input-home-end
"Home moves to start, End moves to end."
(let ((in (make-text-input :value "hello" :cursor 3)))
(handle-text-input in (make-key-event :key :home))
(is (= (text-input-cursor in) 0))
(handle-text-input in (make-key-event :key :end))
(is (= (text-input-cursor in) 5))))
(test text-input-max-length
"Max-length prevents inserting beyond the limit."
(let ((in (make-text-input :max-length 3)))
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
(handle-text-input in (make-key-event :key :b :code (char-code #\b)))
(handle-text-input in (make-key-event :key :c :code (char-code #\c)))
(handle-text-input in (make-key-event :key :d :code (char-code #\d)))
(is (string= (text-input-value in) "abc"))))
(test text-input-placeholder
"Placeholder is stored but does not affect value."
(let ((in (make-text-input :placeholder "Type here...")))
(is (string= (text-input-placeholder in) "Type here..."))
(is (string= (text-input-value in) ""))))
(test text-input-on-submit
"On-submit callback fires on Enter."
(let ((result (list nil)))
(let ((in (make-text-input :value "hello"
:on-submit (lambda (v) (setf (car result) v)))))
(handle-text-input in (make-key-event :key :enter))
(is (string= (car result) "hello")))))
(test text-input-ctrl-a-e
"Ctrl+A moves to home, Ctrl+E moves to end."
(let ((in (make-text-input :value "abc" :cursor 2)))
(handle-text-input in (make-key-event :key :a :ctrl t))
(is (= (text-input-cursor in) 0))
(handle-text-input in (make-key-event :key :e :ctrl t))
(is (= (text-input-cursor in) 3))))
(test text-input-insert-in-middle
"Inserting in the middle of text shifts rest right."
(let ((in (make-text-input :value "ab" :cursor 1)))
(handle-text-input in (make-key-event :key :x :code (char-code #\x)))
(is (string= (text-input-value in) "axb"))
(is (= (text-input-cursor in) 2))))
(test text-input-dirty-on-insert
"Inserting marks the widget dirty."
(let ((in (make-text-input)))
(mark-clean in)
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
(is-true (dirty-p in))))
;; ── Textarea Tests ──────────────────────────────────────────────
(test textarea-empty
"New textarea has empty value and cursor at (0,0)."
(let ((a (make-textarea)))
(is (string= (textarea-value a) ""))
(is (= (textarea-cursor-row a) 0))
(is (= (textarea-cursor-col a) 0))))
(test textarea-newline
"Enter inserts a newline."
(let ((a (make-textarea)))
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
(handle-textarea-input a (make-key-event :key :enter))
(handle-textarea-input a (make-key-event :key :b :code (char-code #\b)))
(is (string= (textarea-value a) (format nil "a~Cb" #\Newline)))))
(test textarea-cursor-up-down
"Cursor moves between lines maintaining column position."
(let ((a (make-textarea :value (format nil "abc~Cde~Cfghi" #\Newline #\Newline))))
(setf (textarea-cursor-row a) 1)
(setf (textarea-cursor-col a) 1)
(handle-textarea-input a (make-key-event :key :up))
(is (= (textarea-cursor-row a) 0))
(is (= (textarea-cursor-col a) 1))
(handle-textarea-input a (make-key-event :key :down))
(is (= (textarea-cursor-row a) 1))
(is (= (textarea-cursor-col a) 1))))
(test textarea-cursor-up-down-bounds
"Cursor cannot move past first or last line."
(let ((a (make-textarea :value (format nil "a~Cb" #\Newline))))
(handle-textarea-input a (make-key-event :key :up))
(is (= (textarea-cursor-row a) 0))
(setf (textarea-cursor-row a) 1)
(handle-textarea-input a (make-key-event :key :down))
(is (= (textarea-cursor-row a) 1))))
(test textarea-backspace-joins-lines
"Backspace at start of a line joins with previous."
(let ((a (make-textarea :value (format nil "hello~Cworld" #\Newline))))
(setf (textarea-cursor-row a) 1)
(setf (textarea-cursor-col a) 0)
(handle-textarea-input a (make-key-event :key :backspace))
(is (string= (textarea-value a) "helloworld"))))
(test textarea-undo
"Ctrl+Z undoes the last edit."
(let ((a (make-textarea)))
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
(handle-textarea-input a (make-key-event :key :z :ctrl t))
(is (string= (textarea-value a) ""))))
(test textarea-undo-redo
"Ctrl+Y redoes an undone edit."
(let ((a (make-textarea)))
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
(handle-textarea-input a (make-key-event :key :z :ctrl t))
(handle-textarea-input a (make-key-event :key :y :ctrl t))
(is (string= (textarea-value a) "a"))))
;; ── Keybinding Tests ────────────────────────────────────────────
;; These tests verify the keymap dispatch system works correctly
;; when wired up. Note: dispatch-key-event is NOT called by the
;; demo's event loop — users MUST call it explicitly in their own
;; event loops if they want to use the defkeymap/dispatch-key-event
;; system. See src/components/keybindings.lisp for details.
;;
;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single
;; key specs work. The *chord-timeout* variable and list-of-lists
;; syntax are reserved for future implementation.
(test keymap-simple
"A keymap dispatches to its handler on matching event."
(let ((called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf called t))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))
(is-true called)))
(test keymap-no-match
"Non-matching event returns nil."
(let ((called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf called t))))))
(is-false (dispatch-key-event (make-key-event :key :a)))
(is-false called)))
(test keymap-fallback
"Event not in local falls through to global."
(let ((global-called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+q . ,(lambda (e)
(declare (ignore e))
(setf global-called t))))))
(dispatch-key-event (make-key-event :key :q :ctrl t))
(is-true global-called)))
(test key-spec-simple
"Keyword key-spec matches key+ctrl."
(is-true (key-match-p :ctrl+p (make-key-event :key :p :ctrl t)))
(is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t)))
(is-false (key-match-p :ctrl+p (make-key-event :key :p))))
(test key-spec-alt-modifier
"Alt modifier is matched correctly."
(is-true (key-match-p :alt+x (make-key-event :key :x :alt t)))
(is-false (key-match-p :alt+x (make-key-event :key :x)))
(is-false (key-match-p :alt+x (make-key-event :key :x :ctrl t))))
(test key-spec-shift-modifier
"Shift modifier is matched correctly."
(is-true (key-match-p :shift+tab (make-key-event :key :tab :shift t)))
(is-false (key-match-p :shift+tab (make-key-event :key :tab))))
(test key-spec-plain
"Plain key spec matches unmodified keys."
(is-true (key-match-p :enter (make-key-event :key :enter)))
(is-true (key-match-p :escape (make-key-event :key :escape)))
(is-false (key-match-p :enter (make-key-event :key :escape))))
(test key-spec-list-form
"List-form spec (:ctrl+p) matches same as keyword :ctrl+p."
(is-true (key-match-p '(:ctrl+p) (make-key-event :key :p :ctrl t)))
(is-false (key-match-p '(:ctrl+p) (make-key-event :key :a :ctrl t))))
(test dispatch-return-value-match
"dispatch-key-event returns T on matching binding."
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e)))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t))))
(test dispatch-return-value-no-match
"dispatch-key-event returns NIL when no binding matches."
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e)))))))
(is-false (dispatch-key-event (make-key-event :key :a))))
(test dispatch-empty-keymap
"dispatch-key-event returns NIL on empty keymap."
(setf (gethash :global *keymaps*) (make-keymap :name :global))
(is-false (dispatch-key-event (make-key-event :key :a))))
(test dispatch-local-overrides-global
"Local keymap takes priority over global."
(let ((local-called nil) (global-called nil))
(setf (gethash :local *keymaps*)
(make-keymap :name :local
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf local-called t))))))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf global-called t))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))
(is-true local-called)
(is-false global-called)))
(test dispatch-multiple-bindings
"dispatch-key-event finds the right binding among many."
(let ((called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+a . (lambda (e) (declare (ignore e))))
(:ctrl+b . (lambda (e) (declare (ignore e))))
(:ctrl+c . ,(lambda (e)
(declare (ignore e))
(setf called t)))
(:ctrl+d . (lambda (e) (declare (ignore e)))))))
(is-true (dispatch-key-event (make-key-event :key :c :ctrl t)))
(is-true called)))
(test defkeymap-macro
"defkeymap macro registers a keymap."
(let ((called nil))
(eval `(defkeymap :global
(:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t)))))
(dispatch-key-event (make-key-event :key :q :ctrl t))
(is-true called)))
(test defkeymap-macro-with-list-spec
"defkeymap macro works with list-form specs."
(let ((called nil))
(eval `(defkeymap :global
((:ctrl+w) ,(lambda (e) (declare (ignore e)) (setf called t)))))
(dispatch-key-event (make-key-event :key :w :ctrl t))
(is-true called)))
;; cleanup after keybinding tests
(test keybinding-cleanup-global
"Clean up global keymap after testing."
(remhash :global *keymaps*)
(remhash :local *keymaps*)
(is-false (gethash :global *keymaps*))
(is-false (gethash :local *keymaps*)))
;; cleanup after keybinding tests
(test keybinding-cleanup-global
"Clean up global keymap after testing."
(remhash :global *keymaps*)
(remhash :local *keymaps*)
(is-false (gethash :global *keymaps*))
(is-false (gethash :local *keymaps*)))
(test resize-event-check
"read-event returns :resize when *terminal-resized-p* is set"
(let ((b (make-instance 'cl-tty.backend:backend)))
(setf cl-tty.input:*terminal-resized-p* t)
(multiple-value-bind (type data) (cl-tty.input:read-event b :timeout 0)
(is (eq :resize type))
(is (consp data))
(is (integerp (car data)))
(is (integerp (cdr data))))
(is-false cl-tty.input:*terminal-resized-p*)))
(test with-terminal-macro-expands
"with-terminal macro expands and compiles"
(is (macro-function 'cl-tty.backend:with-terminal))
(let ((expanded (macroexpand-1 '(cl-tty.backend:with-terminal (be)
(print be)))))
(is (listp expanded))))
#+END_SRC
;; ─── Mouse tests (merged from cl-tty.mouse) ───────────────────
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/input-tests.lisp
(def-test mouse-mixin-create ()
(let ((m (make-instance 'mouse-mixin)))
(is-true (typep m 'mouse-mixin))))
(def-test mouse-hit-test-point ()
"hit-test returns nil when no component has position slots bound"
(let ((obj (make-instance 'mouse-mixin)))
(is-false (hit-test obj 0 0))
(is-false (hit-test obj 100 100))))
(def-test selection-set-and-get ()
(setf *selection* (make-selection :text "hello"))
(is (equal "hello" (get-selection))))
(def-test start-selection-initializes-state ()
(start-selection 5 10)
(is-true (selection-active-p))
(is (equal '(5 . 10) *selection-start*))
(is (equal '(5 . 10) *selection-end*))
(setf *selection-active* nil *selection-start* nil *selection-end* nil))
(def-test update-selection-moves-end ()
(start-selection 0 0)
(update-selection 3 7)
(is (equal '(3 . 7) *selection-end*))
(setf *selection-active* nil *selection-start* nil *selection-end* nil))
(def-test finalize-selection-extracts-text ()
(let* ((fb-be (cl-tty.rendering:make-framebuffer-backend))
(fb (cl-tty.rendering:fb-framebuffer fb-be)))
(cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil)
(cl-tty.backend:draw-text fb-be 0 1 "world" nil nil)
(start-selection 0 0)
(update-selection 4 1)
(let ((text (finalize-selection fb)))
(is (equal "hello
world" text)))))
#+END_SRC
Reference in New Issue View Git Blame Copy Permalink