1409 lines
56 KiB
Org Mode
1409 lines
56 KiB
Org Mode
#+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.
|
|
|
|
* 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
|
|
|
|
#+BEGIN_SRC lisp
|
|
(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)))
|
|
#+END_SRC
|
|
|
|
* 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.
|
|
|
|
#+BEGIN_SRC 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
|
|
;; 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))
|
|
#+END_SRC
|
|
|
|
** 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.
|
|
|
|
#+BEGIN_SRC 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
|
|
(defvar *current-backend* nil
|
|
"The active backend used for rendering.")
|
|
(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.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(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)))
|
|
#+END_SRC
|
|
|
|
|
|
** textarea.lisp
|
|
#+BEGIN_SRC lisp :tangle ../src/components/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))))
|
|
#+END_SRC
|
|
|
|
|
|
** keybindings.lisp
|
|
#+BEGIN_SRC lisp :tangle ../src/components/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))
|
|
#+END_SRC
|
|
|
|
|
|
** input-package.lisp
|
|
#+BEGIN_SRC lisp :tangle ../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
|
|
;; 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))
|
|
#+END_SRC
|
|
|
|
|
|
** input-tests.lisp
|
|
#+BEGIN_SRC lisp :tangle ../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) "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*)))
|
|
|
|
#+END_SRC |