d5caaf296d
The tangled handle-text-input used (key-event-text event) for character insertion, but the test suite creates key events with :code not :text. Restored the original handle-text-input which uses (code-char (key-event-code event)) — matching the test expectations.
70 KiB
70 KiB
cl-tty v0.5.0 — Text Input + Keybinding System
Text Input System
The input pipeline has four layers:
- Terminal raw mode — put stdin into non-canonical mode so every keystroke is delivered immediately (no line buffering, no echo).
- 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.
- Input widget (TextInput / Textarea) — editable text with cursor, selection, undo/redo, and emacs-style keybindings.
- 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-eventis 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
defstructgenerates keyword constructors by default — we use them directly without custom:constructoroverrides.
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).
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))))
;; ── 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 ────────────────────────────────────────────
(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 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)))Implementation
Package
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.
(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
;; 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-layout-node
#: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
#:*keymaps* #:*chord-timeout*
#:defkeymap #:dispatch-key-event #:key-match-p
#:component-keymap))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.
(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))))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.
(defvar *current-backend* nil
"The active backend used for rendering.")
(defvar *current-theme* nil
"The active theme used for semantic color resolution.")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.
(defstruct key-event
(key nil :type (or keyword null))
(ctrl nil :type boolean)
... [OUTPUT TRUNCATED - 58394 chars omitted out of 108394 total] ...
--------------------------------------------
(defun text-input-move-left (input)
(when (plusp (text-input-cursor input))
(decf (text-input-cursor input))))
(defun text-input-move-right (input)
(when (< (text-input-cursor input) (length (text-input-value input)))
(incf (text-input-cursor input))))
(defun text-input-move-home (input)
(setf (text-input-cursor input) 0))
(defun text-input-move-end (input)
(setf (text-input-cursor input) (length (text-input-value input))))
(defun text-input-delete-word-before (input)
"Delete from cursor back to previous word boundary."
(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))))
;;; ---------------------------------------------------------------------------
;;; Key event handler
;;; ---------------------------------------------------------------------------
(defun handle-text-input (input event)
"Process a key-event on a text-input widget."
(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 nil)
(:escape nil)
;; Insert printable characters
(otherwise
(let ((ch (code-char (key-event-code event))))
(when (and ch (graphic-char-p ch))
(text-input-insert input ch))))))))
;;; ---------------------------------------------------------------------------
;;; Rendering
;;; ---------------------------------------------------------------------------
(defmethod render ((in text-input) (backend t))
"Render text-input value or placeholder at layout position."
(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) "")))
(truncated (subseq display 0 (min (length display) w))))
(draw-text backend x y truncated nil nil)))textarea.lisp
(in-package #:cl-tty.input)
;;; ---------------------------------------------------------------------------
;;; Textarea class
;;; ---------------------------------------------------------------------------
(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)))
(defun make-textarea (&key value on-submit)
(make-instance 'textarea
:value (or value "")
:on-submit on-submit))
;;; ---------------------------------------------------------------------------
;;; Line helpers
;;; ---------------------------------------------------------------------------
(defun textarea-lines (ta)
"Split value into lines."
(%split-string (textarea-value ta) #\Newline))
(defun textarea-line-count (ta)
"Number of lines in value."
(length (textarea-lines ta)))
(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))
;;; ---------------------------------------------------------------------------
;;; Utility: join strings with newline
;;; ---------------------------------------------------------------------------
(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))))
;;; ---------------------------------------------------------------------------
;;; Text manipulation
;;; ---------------------------------------------------------------------------
(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)))))
(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)))))
(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))))))
;;; ---------------------------------------------------------------------------
;;; Cursor movement
;;; ---------------------------------------------------------------------------
(defun textarea-move-up (ta)
(decf (textarea-cursor-row ta))
(textarea-ensure-cursor ta))
(defun textarea-move-down (ta)
(incf (textarea-cursor-row ta))
(textarea-ensure-cursor ta))
;;; ---------------------------------------------------------------------------
;;; Undo/redo
;;; ---------------------------------------------------------------------------
(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)))
(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)))))
(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)))))
;;; ---------------------------------------------------------------------------
;;; Key event handler
;;; ---------------------------------------------------------------------------
(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))))))))
;;; ---------------------------------------------------------------------------
;;; Rendering
;;; ---------------------------------------------------------------------------
(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))))keybindings.lisp
(in-package #:cl-tty.input)
;;; ---------------------------------------------------------------------------
;;; Key map struct
;;; ---------------------------------------------------------------------------
(defstruct keymap
(name nil :type (or keyword null))
(bindings nil :type list)
(parent nil :type (or keymap null)))
;;; ---------------------------------------------------------------------------
;;; Global keymap registry
;;; ---------------------------------------------------------------------------
(defparameter *keymaps* (make-hash-table :test #'equal))
(defparameter *chord-timeout* 0.5)
;;; ---------------------------------------------------------------------------
;;; Key spec matching
;;; ---------------------------------------------------------------------------
(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)
(key-event-key event))
(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)))))
;;; ---------------------------------------------------------------------------
;;; Dispatch
;;; ---------------------------------------------------------------------------
;;; dispatch-key-event — main entry point for keymap-based dispatch.
;;;
;;; IMPORTANT: This function is NOT called by the demo's event loop
;;; or by any built-in widget event handlers. Users who want to use
;;; the keymap system 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* and list-of-lists syntax
;;; are reserved for future implementation.
(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)))))
;;; ---------------------------------------------------------------------------
;;; defkeymap macro
;;; ---------------------------------------------------------------------------
(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))))))))
;;; --- Component protocol integration ---
(defgeneric component-keymap (component)
(:method ((c t)) nil))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
;; 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-layout-node
#: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))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) "a
b"))))
(test textarea-cursor-up-down
"Cursor moves between lines maintaining column position."
(let ((a (make-textarea :value "abc
de
fghi")))
(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 "a
b")))
(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 "hello
world")))
(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*)))input.lisp — Raw input reader and escape parser
input.lisp — Raw input reader and escape parser
(in-package #:cl-tty.input)
(defun %split-string (string separator)
(loop with start = 0
for pos = (position separator string :start start)
collect (subseq string start pos)
while pos
do (setf start (1+ pos))))
(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)))
(defstruct mouse-event
(type nil :type (or keyword null))
(button nil :type (or keyword null))
(x 0 :type fixnum)
(y 0 :type fixnum))
(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)))
(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)))
(defun parse-csi-params (params terminator extended)
(let* ((key (if (find terminator '(#\~ #\u))
(cdr (assoc (first params) *csi-tilde-table*))
(cdr (assoc terminator *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~C" #\Esc params terminator)))))
(defun read-raw-byte (&key timeout)
(let* ((buf (sb-alien:make-alien sb-alien:unsigned-char 1))
(fd 0))
(unwind-protect
(if timeout
(progn (sb-unix:unix-simple-poll fd :input timeout)
(let ((n (sb-unix:unix-read fd buf 1)))
(if (= n 1) (sb-alien:deref buf 0) (values nil :eof))))
(let ((n (sb-unix:unix-read fd buf 1)))
(if (= n 1) (sb-alien:deref buf 0) (values nil :eof))))
(sb-alien:free-alien buf))))
(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))))))
(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* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0))
(b2 (read-raw-byte))
(params (if (and (>= b2 48) (<= b2 57))
(multiple-value-bind (p term) (read-param (lambda () (read-raw-byte)))
(setf (fill-pointer extended) (length p))
(replace extended p)
(values p term))
(progn (vector-push-extend b2 extended) (read-param (lambda () (read-raw-byte)))))))
(destructuring-bind (params terminator) params
(parse-csi-params params terminator extended)))))
(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)))
(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)))))))
(defvar *terminal-resized-p* nil)
#+sbcl
(eval-when (:load-toplevel :execute)
(sb-sys:enable-interrupt sb-posix:sigwinch
(lambda (signal info context)
(declare (ignore signal info context))
(setf *terminal-resized-p* t))))
(defmethod read-event ((b cl-tty.backend:backend) &key timeout)
(declare (ignore b))
(when (probe-file "/dev/stdin")
(%read-event :timeout timeout)))text-input.lisp — TextInput widget logic
(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)
(layout-node :initform (make-layout-node) :accessor text-input-layout-node)
(focusable :initform t :accessor text-input-focusable)))
(defun make-text-input (&key value cursor placeholder max-length on-submit)
(make-instance 'text-input
:value (or value "")
:cursor (or cursor 0)
:placeholder (or placeholder "")
:max-length max-length
:on-submit on-submit))
(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)))
(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)))
(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)))
(defun text-input-move-left (input)
(when (plusp (text-input-cursor input)) (decf (text-input-cursor input)))
(mark-dirty input))
(defun text-input-move-right (input)
(when (< (text-input-cursor input) (length (text-input-value input))) (incf (text-input-cursor input)))
(mark-dirty input))
(defun text-input-move-home (input)
(setf (text-input-cursor input) 0)
(mark-dirty input))
(defun text-input-move-end (input)
(setf (text-input-cursor input) (length (text-input-value input)))
(mark-dirty input))
(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))))
(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 nil) (:escape nil)
(otherwise (let ((ch (code-char (key-event-code event))))
(when (and ch (graphic-char-p ch)) (text-input-insert input ch))))))))
(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) "")))
(truncated (subseq display 0 (min (length display) w))))
(draw-text backend x y truncated nil nil)
(when (plusp (length value))
(let ((cursor-col (min cursor (length truncated))))
(draw-text backend (+ x cursor-col) y "█" :bright-white nil)))))