811d51a4f2
Rename: cl-tty avoids naming collision with Quicklisp's cl-tui (naryl/cl-tui, a cl-charms-based ncurses library). Our project is pure escape-sequence CL. v0.9.0 adds: - Dialog base class: modal overlay with backdrop, centered panel, size variants (:small/:medium/:large), stack-based management - Dialog subclasses: alert, confirm, select-dialog, prompt-dialog - Toast notifications: transient, top-right corner, auto-dismiss, colored variants (info/success/warning/error) - 78 tests total, 100% passing ASDF: read-time package references (+fiveam:+) replaced with find-symbol so .asd loads without FiveAM pre-loaded
2706 lines
105 KiB
Org Mode
2706 lines
105 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~ → byte or NIL.
|
|
Read one byte from fd 0. Blocks indefinitely when timeout=NIL.
|
|
Returns NIL on timeout. Uses ~sb-posix:read~.
|
|
|
|
~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.
|
|
Called after reading ESC (0x1b). Dispatches:
|
|
- 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, 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-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
|
|
|
|
** 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)
|
|
(alt nil :type boolean)
|
|
(shift nil :type boolean)
|
|
(code nil :type (or fixnum null))
|
|
(raw nil :type (or string null))
|
|
(text nil :type (or string null)))
|
|
#+END_SRC
|
|
|
|
** Mouse Event Struct
|
|
|
|
Separate from key-event because mouse carries coordinates and button
|
|
information that key events don't need. Parsed from SGR mouse sequences
|
|
(~ESC[<Cx;Cy;M~).
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defstruct mouse-event
|
|
(type nil :type (or keyword null))
|
|
(button nil :type (or keyword nil))
|
|
(x 0 :type fixnum)
|
|
(y 0 :type fixnum)
|
|
(raw nil :type (or string null)))
|
|
#+END_SRC
|
|
|
|
** Terminal Raw Mode
|
|
|
|
~sb-posix:tcgetattr~ reads the current terminal settings from fd 0.
|
|
~sb-posix:tcsetattr~ writes new settings. The raw mode disables:
|
|
|
|
- ~ICANON~ — line buffering (otherwise Enter is needed to deliver input)
|
|
- ~ECHO~ — don't echo typed characters back
|
|
- ~ISIG~ — don't generate signals on Ctrl+C, Ctrl+Z, etc.
|
|
- ~IEXTEN~ — don't interpret special characters like Ctrl+V
|
|
- ~OPOST~ — no output processing (no LF→CRLF translation)
|
|
- ~IXON~ — no XON/XOFF flow control
|
|
|
|
VMIN=1, VTIME=0 means ~read~ returns as soon as at least 1 byte is
|
|
available, with no timeout. This is the classic "raw terminal" setup.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun save-terminal-state ()
|
|
(sb-posix:tcgetattr 0))
|
|
|
|
(defun make-raw-termios (termios)
|
|
(flet ((clear-flag (flags mask)
|
|
(logand flags (lognot mask))))
|
|
(setf (sb-posix:termios-iflag termios)
|
|
(clear-flag (sb-posix:termios-iflag termios)
|
|
(logior sb-posix:brkint sb-posix:ignpar
|
|
sb-posix:istrip sb-posix:inlcr
|
|
sb-posix:igncr sb-posix:icrnl
|
|
sb-posix:ixon)))
|
|
(setf (sb-posix:termios-oflag termios)
|
|
(clear-flag (sb-posix:termios-oflag termios)
|
|
sb-posix:opost))
|
|
(setf (sb-posix:termios-lflag termios)
|
|
(clear-flag (sb-posix:termios-lflag termios)
|
|
(logior sb-posix:icanon sb-posix:echo
|
|
sb-posix:isig sb-posix:iexten)))
|
|
(setf (sb-posix:termios-cc termios sb-posix:vmin) 1)
|
|
(setf (sb-posix:termios-cc termios sb-posix:vtime) 0)
|
|
termios))
|
|
|
|
(defun set-raw-mode ()
|
|
(let ((raw (make-raw-termios (save-terminal-state))))
|
|
(sb-posix:tcsetattr 0 sb-posix:tcsanow raw)
|
|
raw))
|
|
|
|
(defun restore-terminal-state (termios)
|
|
(sb-posix:tcsetattr 0 sb-posix:tcsanow termios))
|
|
#+END_SRC
|
|
|
|
** with-raw-terminal macro
|
|
|
|
The macro uses ~unwind-protect~ to guarantee terminal restoration even
|
|
on non-local exits (errors, throws). The saved termios is captured in a
|
|
gensym'd variable to avoid variable capture in the body.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defmacro with-raw-terminal (&body body)
|
|
(let ((saved (gensym "SAVED")))
|
|
`(let ((,saved (save-terminal-state)))
|
|
(set-raw-mode)
|
|
(unwind-protect
|
|
(progn ,@body)
|
|
(restore-terminal-state ,saved)))))
|
|
#+END_SRC
|
|
|
|
** Byte reader
|
|
|
|
~sb-posix:read~ takes (fd, buffer, count) and returns the number of
|
|
bytes read. I initially named this ~read-byte~, but SBCL has a
|
|
~PACKAGE-LOCK-VIOLATION~ on that symbol in the ~COMMON-LISP~ package.
|
|
The fix: prefix with ~read-raw-byte~.
|
|
|
|
The timeout version uses a polling loop with ~sleep 0.01~. This is
|
|
simple but wastes CPU during waits. For production, a proper ~select~
|
|
or ~poll~ syscall would be better, but the polling approach is
|
|
functional for our use case.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun read-raw-byte (&key timeout)
|
|
(if timeout
|
|
(let ((deadline (+ (get-universal-time) timeout)))
|
|
(loop while (< (get-universal-time) deadline)
|
|
do (handler-case
|
|
(let ((buf (make-array 1 :element-type '(unsigned-byte 8))))
|
|
(let ((n (sb-posix:read 0 buf 1)))
|
|
(when (plusp n)
|
|
(return-from read-raw-byte (aref buf 0)))))
|
|
(sb-posix:syscall-error ()
|
|
(return-from read-raw-byte nil)))
|
|
(sleep 0.01))
|
|
nil)
|
|
(let ((buf (make-array 1 :element-type '(unsigned-byte 8))))
|
|
(multiple-value-bind (n err)
|
|
(ignore-errors (sb-posix:read 0 buf 1))
|
|
(if (and (integerp n) (plusp n))
|
|
(aref buf 0)
|
|
(progn
|
|
(when err (format *error-output* "read error: ~A~%" err))
|
|
nil))))))
|
|
#+END_SRC
|
|
|
|
** CSI Parameter Parser
|
|
|
|
CSI sequences have the format ~ESC[params...final-byte~ where parameters
|
|
are semicolon-separated decimal numbers, and the final byte is in the
|
|
range 0x40-0x7E. This parser reads bytes one at a time, accumulates
|
|
parameter values, and returns them with the final byte.
|
|
|
|
The ~raw~ vector captures the raw sequence bytes for debugging. I use
|
|
~vector-push-extend~ because CSI sequences vary in length (from 3 bytes
|
|
for ~ESC[A~ to 10+ for mouse sequences).
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun parse-csi-params ()
|
|
(let ((params '())
|
|
(raw (make-array 0 :element-type '(unsigned-byte 8)
|
|
:fill-pointer 0 :adjustable t))
|
|
(current 0))
|
|
(loop
|
|
(let ((b (read-raw-byte)))
|
|
(unless b (return (values nil nil nil)))
|
|
(vector-push-extend b raw)
|
|
(cond
|
|
((and (>= b #x30) (<= b #x3f))
|
|
(if (char= (code-char b) #\;)
|
|
(progn (push current params) (setf current 0))
|
|
(setf current (+ (* current 10) (- b #x30)))))
|
|
((and (>= b #x20) (<= b #x2f))
|
|
nil)
|
|
((and (>= b #x40) (<= b #x7e))
|
|
(push current params)
|
|
(return (values (nreverse params) b
|
|
(map 'string #'code-char raw))))
|
|
(t
|
|
(return (values nil nil nil))))))))
|
|
#+END_SRC
|
|
|
|
** CSI Key Translation Tables
|
|
|
|
Maps CSI final bytes and parameter values to keyword names. Two tables:
|
|
one for single-byte final keys (~A=up, ~B=down, H=home, etc.) and
|
|
one for ~ sequence codes (~1~=home, ~3~=delete, ~11~=F1, etc.).
|
|
|
|
Using quoted alists (~'((#\A . :up) ...)~) because these are compile-time
|
|
constants. The ~assoc~ lookup is fast enough for single-key dispatch.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defparameter *csi-key-table*
|
|
'((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left)
|
|
(#\F . :end) (#\H . :home)
|
|
(#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4)
|
|
(#\Z . :tab)))
|
|
|
|
(defparameter *csi-tilde-table*
|
|
'((1 . :home) (2 . :insert) (3 . :delete)
|
|
(4 . :end) (5 . :page-up) (6 . :page-down)
|
|
(7 . :home) (8 . :end)
|
|
(11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4)
|
|
(15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8)
|
|
(20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12)))
|
|
#+END_SRC
|
|
|
|
** SGR Mouse Parser
|
|
|
|
The SGR mouse format is ~ESC[<Cx;Cy;M/m~ where:
|
|
- ~<~ signals SGR mode (vs legacy X10)
|
|
- Cx, Cy are zero-indexed coordinates
|
|
- M = press/drag, m = release
|
|
- The button code encodes button (bits 0-1), modifiers (bits 2-4),
|
|
motion flag (bit 5), and wheel flag (bit 6)
|
|
|
|
I parse the raw string rather than the parameter list from ~parse-csi-params~
|
|
because the leading ~<~ is absorbed as a parameter byte by the parser
|
|
(0x3c is in the parameter range 0x30-0x3f). Re-parsing from raw is simpler
|
|
than trying to detect the ~<~ during parameter collection.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun parse-sgr-mouse (raw)
|
|
(let* ((start (position #\< raw))
|
|
(end (position #\m raw :from-end t))
|
|
(end2 (position #\M raw :from-end t))
|
|
(final (if end end end2))
|
|
(releasep (char= (char raw (1- (length raw))) #\m)))
|
|
(when (and start final (> final start))
|
|
(let* ((nums (mapcar #'parse-integer
|
|
(%split-string (subseq raw (1+ start) final) #\;)))
|
|
(code (first nums))
|
|
(x (or (second nums) 0))
|
|
(y (or (third nums) 0))
|
|
(button (logand code #x03))
|
|
(mod (logand code #x1c))
|
|
(motion (logand code #x20))
|
|
(wheel (logand code #x40)))
|
|
(declare (ignore mod))
|
|
(make-mouse-event
|
|
:type (cond (releasep :release)
|
|
(motion :drag)
|
|
(t :press))
|
|
:button (cond (wheel (if (zerop (logand code #x01))
|
|
:wheel-up :wheel-down))
|
|
((= button 0) :left)
|
|
((= button 1) :middle)
|
|
((= button 2) :right)
|
|
(t :none))
|
|
:x x :y y :raw raw)))))
|
|
#+END_SRC
|
|
|
|
** Escape Sequence Reader
|
|
|
|
After reading ESC (0x1b), we need to determine if this is a standalone
|
|
Escape or the start of a multi-byte sequence. The function dispatches
|
|
based on the next byte:
|
|
|
|
- ~O~ (0x4f) → SS3 sequence (F1-F4 in most terminals). Reads one more
|
|
byte and looks up the mapping ~(#\P=F1, #\Q=F2, #\R=F3, #\S=F4)~.
|
|
- ~[~ (0x5b) → CSI sequence. Delegates to ~parse-csi-params~, then
|
|
maps the final byte with modifier support. CSI sequences can carry
|
|
modifier information in the first parameter: 1=Shift, 2=Alt, 4=Ctrl.
|
|
- Another ESC (0x1b) → double-escape, treated as Alt+Escape.
|
|
- Any printable → Alt+key. Reads one more ASCII byte and creates a
|
|
key-event with ~:alt t~.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun %read-escape-sequence ()
|
|
(let ((b (read-raw-byte)))
|
|
(unless b
|
|
(return-from %read-escape-sequence
|
|
(make-key-event :key :escape :raw (string #\Esc))))
|
|
(case b
|
|
(#x4f
|
|
(let ((b2 (read-raw-byte)))
|
|
(if b2
|
|
(let ((key (cdr (assoc (code-char b2)
|
|
'((#\P . :f1) (#\Q . :f2)
|
|
(#\R . :f3) (#\S . :f4))))))
|
|
(make-key-event :key (or key :unknown)
|
|
:raw (format nil "~C~C~C" #\Esc #\O (code-char b2))))
|
|
(make-key-event :key :escape :raw (string #\Esc)))))
|
|
(#x5b
|
|
(multiple-value-bind (params final-byte) (parse-csi-params)
|
|
(if (null final-byte)
|
|
(make-key-event :key :escape :raw (string #\Esc))
|
|
(if (and (char= (code-char final-byte) #\M)
|
|
(>= (length params) 3))
|
|
(let* ((p0 (first params)))
|
|
(if (zerop (logand p0 #x40))
|
|
(let* ((x (second params))
|
|
(y (third params))
|
|
(button (logand p0 #x03))
|
|
(motion (logand p0 #x20))
|
|
(wheel (logand p0 #x40)))
|
|
(make-mouse-event
|
|
:type (if motion :drag :press)
|
|
:button (cond (wheel (if (zerop (logand p0 #x01))
|
|
:wheel-up :wheel-down))
|
|
((= button 0) :left)
|
|
((= button 1) :middle)
|
|
((= button 2) :right)
|
|
(t :none))
|
|
:x x :y y
|
|
:raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte))))
|
|
(let* ((tilde-p (char= (code-char final-byte) #\~))
|
|
(param (or p0 0))
|
|
(key (if tilde-p
|
|
(cdr (assoc param *csi-tilde-table*))
|
|
(cdr (assoc (code-char final-byte) *csi-key-table*))))
|
|
(modifier (when (> (length params) 1) (second params))))
|
|
(let ((ctrl nil) (alt nil) (shift nil))
|
|
(when modifier
|
|
(setf shift (logtest modifier 1)
|
|
alt (logtest modifier 2)
|
|
ctrl (logtest modifier 4)))
|
|
(make-key-event :key (or key :unknown)
|
|
:ctrl ctrl :alt alt :shift shift
|
|
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))
|
|
(let* ((tilde-p (char= (code-char final-byte) #\~))
|
|
(param (or (first params) 0))
|
|
(key (if tilde-p
|
|
(cdr (assoc param *csi-tilde-table*))
|
|
(cdr (assoc (code-char final-byte) *csi-key-table*))))
|
|
(modifier (when (> (length params) 1) (second params))))
|
|
(let ((ctrl nil) (alt nil) (shift nil))
|
|
(when modifier
|
|
(setf shift (logtest modifier 1)
|
|
alt (logtest modifier 2)
|
|
ctrl (logtest modifier 4)))
|
|
(make-key-event :key (or key :unknown)
|
|
:ctrl ctrl :alt alt :shift shift
|
|
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))))))
|
|
(#x1b
|
|
(make-key-event :key :escape :alt t :raw "\\e\\e"))
|
|
(t
|
|
(let ((ch (code-char b)))
|
|
(if (and (>= b #x20) (<= b #x7e))
|
|
(make-key-event :key (intern (string (string-upcase ch)) :keyword)
|
|
:alt t
|
|
:raw (format nil "~C~C" #\Esc ch))
|
|
(make-key-event :key :unknown
|
|
:raw (format nil "~C~C" #\Esc ch))))))))
|
|
#+END_SRC
|
|
|
|
** Top-level Event Reader
|
|
|
|
The main input dispatcher. Reads one byte and classifies it:
|
|
|
|
- Ctrl characters (0x01-0x1a) map to ~:A~ through ~:Z~ with ~:ctrl t~.
|
|
The mapping adds 0x60 to get the lowercase letter, then ~string-upcase~s
|
|
it so the keyword matches ~:ctrl+a~ (uppercase P from reader convention).
|
|
- Tab (0x09), Enter (0x0a and 0x0d — both mapped to ~:enter~).
|
|
- Backspace (0x7f DEL or 0x08 BS — mapped to ~:backspace~).
|
|
- Printable ASCII (0x20-0x7e) → keyword ~:A~ through ~:~.
|
|
- Escape (0x1b) → ~%read-escape-sequence~ for multi-byte sequences.
|
|
- Anything else → ~:unknown~.
|
|
|
|
~:key~ values are always uppercase keywords. This matters because
|
|
the reader interns keyword symbols uppercase by default — if the
|
|
parser returns lowercase keywords, key matching fails silently.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun %read-event (&key timeout)
|
|
(let ((b (read-raw-byte :timeout timeout)))
|
|
(unless b
|
|
(return-from %read-event nil))
|
|
(case b
|
|
(#x1b
|
|
(%read-escape-sequence))
|
|
(#x09
|
|
(make-key-event :key :tab :code #x09))
|
|
(#x0a
|
|
(make-key-event :key :enter :code #x0a))
|
|
(#x0d
|
|
(make-key-event :key :enter :code #x0d))
|
|
((#x7f #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)))
|
|
(#x1c (make-key-event :key :backslash :ctrl t :code b))
|
|
(#x1d (make-key-event :key :rbracket :ctrl t :code b))
|
|
(#x1e (make-key-event :key :caret :ctrl t :code 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)))
|
|
(t
|
|
(make-key-event :key :unknown :code b :raw (string (code-char b)))))))
|
|
#+END_SRC
|
|
|
|
** Backend Integration
|
|
|
|
The backend protocol declares ~read-event~ as a generic function with a
|
|
default no-op. This method overrides it for all ~backend~ instances,
|
|
providing real terminal input via our parser. The ~probe-file~ guard
|
|
handles the case where stdin is not a terminal (piped input).
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defmethod read-event ((b cl-tty.backend:backend) &key timeout)
|
|
(declare (ignore b))
|
|
(when (probe-file "/dev/stdin")
|
|
(%read-event :timeout timeout)))
|
|
#+END_SRC
|
|
|
|
* TextInput Widget
|
|
|
|
** Widget Class
|
|
|
|
~text-input~ inherits from ~dirty-mixin~ for dirty tracking. The
|
|
~on-submit~ slot stores a callback function that receives the current
|
|
value when Enter is pressed. ~layout-node~ enables integration with
|
|
the layout engine. ~focusable~ is always ~t~ for input widgets.
|
|
|
|
The ~value~ and ~cursor~ slots are directly accessible for testing
|
|
without going through the event handler.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(in-package #:cl-tty.input)
|
|
|
|
(defclass text-input (dirty-mixin)
|
|
((value :initform "" :initarg :value :accessor text-input-value :type string)
|
|
(cursor :initform 0 :initarg :cursor :accessor text-input-cursor :type fixnum)
|
|
(placeholder :initform "" :initarg :placeholder :accessor text-input-placeholder :type string)
|
|
(max-length :initform nil :initarg :max-length :accessor text-input-max-length)
|
|
(on-submit :initform nil :initarg :on-submit :accessor text-input-on-submit)
|
|
(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))
|
|
#+END_SRC
|
|
|
|
** Editing Operations: Insert
|
|
|
|
~text-input-insert~ inserts a character at the cursor position by
|
|
splitting the string at the cursor and concatenating the three parts.
|
|
I use ~concatenate 'string~ rather than a data structure because
|
|
terminal input fields are typically short (< 100 chars). The ~max-length~
|
|
check returns early if the limit is reached.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun text-input-insert (input char)
|
|
(let* ((val (text-input-value input))
|
|
(pos (text-input-cursor input))
|
|
(max (text-input-max-length input)))
|
|
(when (and max (>= (length val) max))
|
|
(return-from text-input-insert))
|
|
(setf (text-input-value input)
|
|
(concatenate 'string
|
|
(subseq val 0 pos)
|
|
(string char)
|
|
(subseq val pos)))
|
|
(incf (text-input-cursor input))
|
|
(mark-dirty input)))
|
|
#+END_SRC
|
|
|
|
** Editing Operations: Backspace and Delete
|
|
|
|
~text-input-backspace~ deletes the character before the cursor. I guard
|
|
against ~(zerop pos)~ because calling ~(subseq "abc" -1 0)~ would error.
|
|
~text-input-delete~ deletes the character AT the cursor — essentially
|
|
the same operation but at a different position.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun text-input-backspace (input)
|
|
(let* ((val (text-input-value input))
|
|
(pos (text-input-cursor input)))
|
|
(when (zerop pos) (return-from text-input-backspace))
|
|
(setf (text-input-value input)
|
|
(concatenate 'string
|
|
(subseq val 0 (1- pos))
|
|
(subseq val pos)))
|
|
(decf (text-input-cursor input))
|
|
(mark-dirty input)))
|
|
|
|
(defun text-input-delete (input)
|
|
(let* ((val (text-input-value input))
|
|
(pos (text-input-cursor input)))
|
|
(when (>= pos (length val))
|
|
(return-from text-input-delete))
|
|
(setf (text-input-value input)
|
|
(concatenate 'string
|
|
(subseq val 0 pos)
|
|
(subseq val (1+ pos))))
|
|
(mark-dirty input)))
|
|
#+END_SRC
|
|
|
|
** Cursor Movement
|
|
|
|
Four cursor movement functions: left, right, home (start), end. Each
|
|
clamps to valid bounds. ~decf~ and ~incf~ naturally saturate at the
|
|
boundaries because of the guards.
|
|
|
|
~text-input-delete-word-before~ deletes from cursor back to the previous
|
|
word boundary. This is the emacs ~Ctrl+W~ behavior — whitespace-delimited
|
|
word deletion. The logic finds the first space going backward from the
|
|
cursor, then deletes everything between that space and the cursor.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(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)
|
|
(let* ((val (text-input-value input))
|
|
(pos (text-input-cursor input)))
|
|
(when (zerop pos)
|
|
(return-from text-input-delete-word-before))
|
|
(let* ((start (or (position-if (lambda (c) (not (char= c #\Space)))
|
|
val :end pos :from-end t)
|
|
0))
|
|
(word-start (or (and (plusp start)
|
|
(position #\Space val :end start :from-end t))
|
|
0))
|
|
(delete-start (if (and (zerop word-start)
|
|
(or (char/= (char val 0) #\Space)
|
|
(zerop start)))
|
|
0
|
|
(if (zerop start)
|
|
(1+ word-start)
|
|
(1+ (or (position #\Space val :end start :from-end t)
|
|
0))))))
|
|
(setf (text-input-value input)
|
|
(concatenate 'string
|
|
(subseq val 0 delete-start)
|
|
(subseq val pos)))
|
|
(setf (text-input-cursor input) delete-start)
|
|
(mark-dirty input))))
|
|
#+END_SRC
|
|
|
|
** Key Event Handler
|
|
|
|
~handle-text-input~ is the main dispatcher for a TextInput widget.
|
|
It receives a ~key-event~ and dispatches based on ~ctrl~ flag and
|
|
~key~:
|
|
|
|
- Ctrl+key shortcuts use an inner ~case~ on ~key~ to dispatch
|
|
Ctrl+A/E/W/U/K.
|
|
- Non-ctrl keys dispatch cursor movement, editing, Enter callback,
|
|
and character insertion via the ~otherwise~ clause.
|
|
|
|
The ~otherwise~ clause (right before Render metho), uses ~code-char~
|
|
to convert the raw byte code into a character, and ~graphic-char-p~
|
|
to filter out control characters. This is the fallthrough for ANY
|
|
unrecognized key — including printable characters.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun handle-text-input (input event)
|
|
(cond
|
|
((key-event-ctrl event)
|
|
(case (key-event-key event)
|
|
(:a (text-input-move-home input))
|
|
(:e (text-input-move-end input))
|
|
(:w (text-input-delete-word-before input))
|
|
(:u (progn
|
|
(setf (text-input-value input)
|
|
(subseq (text-input-value input)
|
|
(text-input-cursor input)))
|
|
(setf (text-input-cursor input) 0)
|
|
(mark-dirty input)))
|
|
(:k (progn
|
|
(setf (text-input-value input)
|
|
(subseq (text-input-value input) 0
|
|
(text-input-cursor input)))
|
|
(mark-dirty input)))
|
|
(t nil)))
|
|
(t
|
|
(case (key-event-key event)
|
|
(:left (text-input-move-left input))
|
|
(:right (text-input-move-right input))
|
|
(:home (text-input-move-home input))
|
|
(:end (text-input-move-end input))
|
|
(:backspace (text-input-backspace input))
|
|
(:delete (text-input-delete input))
|
|
(:enter (let ((cb (text-input-on-submit input)))
|
|
(when cb (funcall cb (text-input-value input)))))
|
|
(:tab nil)
|
|
(:escape nil)
|
|
(otherwise
|
|
(let ((ch (code-char (key-event-code event))))
|
|
(when (and ch (graphic-char-p ch))
|
|
(text-input-insert input ch))))))))
|
|
#+END_SRC
|
|
|
|
** Rendering Stub
|
|
|
|
~render~ is defined as a method on the component's ~render~ generic
|
|
to satisfy the rendering pipeline protocol. The full implementation
|
|
needs ~*current-backend*~ and ~*current-theme*~ — for unit testing,
|
|
this no-op lets us test editing logic without terminal output.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defmethod render ((in text-input) (backend t))
|
|
(declare (ignore in backend))
|
|
(values))
|
|
#+END_SRC
|
|
|
|
* Textarea Widget
|
|
|
|
** Widget Class
|
|
|
|
~textarea~ is like ~text-input~ but multi-line. The cursor is a
|
|
(row, column) pair. ~undo-stack~ and ~redo-stack~ use ~make-array~
|
|
with ~:fill-pointer 0~ to create adjustable vectors — ~vector-push~
|
|
and ~vector-pop~ manage them as stacks with automatic bounds checking.
|
|
|
|
The ~selection-start~ slot supports Shift+click and Shift+arrow
|
|
selection (not yet implemented in the handler). ~on-submit~ fires
|
|
on Ctrl+Enter when set.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(in-package #:cl-tty.input)
|
|
|
|
(defclass textarea (dirty-mixin)
|
|
((value :initform "" :initarg :value :accessor textarea-value :type string)
|
|
(cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum)
|
|
(cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum)
|
|
(selection-start :initform nil :accessor textarea-selection-start)
|
|
(undo-stack :initform (make-array 100 :fill-pointer 0)
|
|
:accessor textarea-undo-stack)
|
|
(redo-stack :initform (make-array 100 :fill-pointer 0)
|
|
:accessor textarea-redo-stack)
|
|
(on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit)
|
|
(layout-node :initform (make-layout-node) :accessor textarea-layout-node)
|
|
(focusable :initform t :accessor textarea-focusable)))
|
|
|
|
(defun make-textarea (&key value on-submit)
|
|
(make-instance 'textarea
|
|
:value (or value "")
|
|
:on-submit on-submit))
|
|
#+END_SRC
|
|
|
|
** Line Helpers
|
|
|
|
~textarea-lines~ splits the value at newlines. I coerce to vector
|
|
in editing functions for ~aref~ access (O(1) indexed access vs
|
|
~nth~'s O(n) list traversal for large documents).
|
|
|
|
~textarea-ensure-cursor~ clamps the cursor to valid bounds after
|
|
operations like undo or up/down movement. The ~min~ with ~max~
|
|
pattern avoids branching.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun textarea-lines (ta)
|
|
(%split-string (textarea-value ta) #\Newline))
|
|
|
|
(defun textarea-line-count (ta)
|
|
(length (textarea-lines ta)))
|
|
|
|
(defun textarea-ensure-cursor (ta)
|
|
(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))))))
|
|
#+END_SRC
|
|
|
|
** Character Insertion
|
|
|
|
~textarea-insert-char~ inserts a character at the cursor (row, col)
|
|
position within the current line. I use a vector copy of lines for
|
|
indexed access, modify the specific line via concatenation, then
|
|
rebuild the value from the modified vector.
|
|
|
|
The ~undo~ push captures the state BEFORE the edit — this is
|
|
important for correct undo semantics (undo restores the previous
|
|
state, not the state before the undo).
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun textarea-insert-char (ta char)
|
|
(textarea-push-undo ta)
|
|
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
|
(row (textarea-cursor-row ta))
|
|
(col (textarea-cursor-col ta)))
|
|
(if (< row (length lines))
|
|
(let* ((line (aref lines row))
|
|
(new-line (concatenate 'string
|
|
(subseq line 0 col)
|
|
(string char)
|
|
(subseq line col))))
|
|
(setf (aref lines row) new-line)
|
|
(setf (textarea-value ta)
|
|
(%join-lines lines))
|
|
(incf (textarea-cursor-col ta))
|
|
(mark-dirty ta))
|
|
(progn
|
|
(setf (textarea-value ta)
|
|
(concatenate 'string (textarea-value ta) (string char)))
|
|
(incf (textarea-cursor-col ta))
|
|
(mark-dirty ta)))))
|
|
#+END_SRC
|
|
|
|
** Newline Insertion
|
|
|
|
~textarea-newline~ splits the current line at the cursor and inserts
|
|
the cursor position pushes everything after into a new line. The
|
|
~concatenate 'vector~ approach builds the new line array with the
|
|
inserted empty line.
|
|
|
|
The special case ~(< 0 (length lines))~ catches edge cases like
|
|
inserting a newline at the very end of the last line.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun textarea-newline (ta)
|
|
(textarea-push-undo ta)
|
|
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
|
(row (textarea-cursor-row ta))
|
|
(col (textarea-cursor-col ta)))
|
|
(if (< row (length lines))
|
|
(let* ((line (aref lines row))
|
|
(before (subseq line 0 col))
|
|
(after (subseq line col)))
|
|
(setf (aref lines row) before)
|
|
(let ((new-lines (concatenate 'vector
|
|
(subseq lines 0 (1+ row))
|
|
(vector after)
|
|
(subseq lines (1+ row)))))
|
|
(setf (textarea-value ta)
|
|
(%join-lines new-lines)))
|
|
(incf (textarea-cursor-row ta))
|
|
(setf (textarea-cursor-col ta) 0)
|
|
(mark-dirty ta))
|
|
(progn
|
|
(setf (textarea-value ta)
|
|
(concatenate 'string (textarea-value ta) (string #\Newline)))
|
|
(incf (textarea-cursor-row ta))
|
|
(setf (textarea-cursor-col ta) 0)
|
|
(mark-dirty ta)))))
|
|
#+END_SRC
|
|
|
|
** Backspace
|
|
|
|
~textarea-backspace~ handles two cases:
|
|
|
|
1. ~(zerop col)~ — at the start of a line. Joins the current line
|
|
with the previous one by concatenating ~prev + curr~ and removing
|
|
the current line from the vector. Cursor moves to the join point
|
|
(end of previous line).
|
|
2. ~(> col 0)~ — inside a line. Deletes the character before the
|
|
cursor within the same line using concatenation.
|
|
|
|
The ~(and (zerop row) (zerop col))~ case is a no-op (already at the
|
|
very beginning of the document).
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun textarea-backspace (ta)
|
|
(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)
|
|
((zerop col)
|
|
(let* ((prev (aref lines (1- row)))
|
|
(curr (aref lines row))
|
|
(new-pos (length prev)))
|
|
(setf (aref lines (1- row))
|
|
(concatenate 'string prev curr))
|
|
(let ((new-lines (concatenate 'vector
|
|
(subseq lines 0 row)
|
|
(subseq lines (1+ row)))))
|
|
(setf (textarea-value ta)
|
|
(%join-lines new-lines)))
|
|
(decf (textarea-cursor-row ta))
|
|
(setf (textarea-cursor-col ta) new-pos)
|
|
(mark-dirty ta)))
|
|
(t
|
|
(let* ((line (aref lines row))
|
|
(new-line (concatenate 'string
|
|
(subseq line 0 (1- col))
|
|
(subseq line col))))
|
|
(setf (aref lines row) new-line)
|
|
(setf (textarea-value ta)
|
|
(%join-lines lines))
|
|
(decf (textarea-cursor-col ta))
|
|
(mark-dirty ta))))))
|
|
#+END_SRC
|
|
|
|
** Cursor Movement: Up/Down
|
|
|
|
~textarea-move-up~ and ~textarea-move-down~ decrement/increment the
|
|
row, then call ~ensure-cursor~ to clamp the column to the new line's
|
|
length. This handles the case where the user moves from a long line
|
|
to a short one.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(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))
|
|
#+END_SRC
|
|
|
|
** Undo/Redo Stack
|
|
|
|
~textarea-push-undo~ saves the current value onto the undo stack and
|
|
clears the redo stack (any new action after an undo invalidates the
|
|
redo history). The stacks are fill-pointer arrays — ~vector-push~
|
|
adds to the end, ~vector-pop~ removes from the end (LIFO).
|
|
|
|
~textarea-undo~ pops from the undo stack, pushes the current value
|
|
onto the redo stack, and restores the old value. ~textarea-redo~ does
|
|
the reverse.
|
|
|
|
The ~(>= (length stack) (array-total-size stack))~ guard prevents the
|
|
stack from growing beyond 100 entries by resetting it.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun textarea-push-undo (ta)
|
|
(let ((stack (textarea-undo-stack ta)))
|
|
(when (>= (length stack) (array-total-size stack))
|
|
(setf (textarea-undo-stack ta)
|
|
(make-array 100 :fill-pointer 0)))
|
|
(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)))))
|
|
#+END_SRC
|
|
|
|
** Key Event Handler
|
|
|
|
~handle-textarea-input~ dispatches key events for the textarea widget.
|
|
It handles all the keys that ~handle-text-input~ does (cursor movement,
|
|
character insertion, backspace, delete) plus:
|
|
|
|
- Ctrl+Z/Y for undo/redo
|
|
- Ctrl+A/E for home/end on current line
|
|
- Up/Down for line navigation
|
|
- Enter for newline insertion
|
|
- Left/Right/Home/End for cursor movement within/between lines
|
|
|
|
Critically, this function does NOT fall through to ~handle-text-input~
|
|
— early versions tried that but failed because ~handle-text-input~
|
|
accesses ~text-input-*~ slots that ~textarea~ doesn't have. Instead,
|
|
textarea implements its own complete dispatching with line-aware
|
|
versions of each operation.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun handle-textarea-input (ta event)
|
|
(cond
|
|
((key-event-ctrl event)
|
|
(case (key-event-key event)
|
|
(:z (textarea-undo ta))
|
|
(:y (textarea-redo ta))
|
|
(: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))
|
|
(: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))))))
|
|
(: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))))
|
|
(otherwise
|
|
(let ((ch (code-char (key-event-code event))))
|
|
(when (and ch (graphic-char-p ch))
|
|
(textarea-insert-char ta ch)))))))
|
|
#+END_SRC
|
|
|
|
** %join-lines helper
|
|
|
|
This helper is needed because Common Lisp's ~format~ directive
|
|
~"~{~A~^~C~}"~ does NOT work as a newline-separated join — ~^C~
|
|
inside ~{~}~ consumes list items, not format arguments. The correct
|
|
approach is ~write-char~ between items in an explicit loop.
|
|
|
|
The function accepts both lists and vectors (the textarea code uses
|
|
vectors internally, but ~textarea-lines~ returns lists).
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun %join-lines (lines)
|
|
(with-output-to-string (s)
|
|
(loop for line across (if (listp lines) (coerce lines 'vector) lines)
|
|
for first = t then nil
|
|
do (unless first (write-char #\Newline s))
|
|
(write-string line s))))
|
|
#+END_SRC
|
|
|
|
** Rendering Stub
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defmethod render ((ta textarea) (backend t))
|
|
(declare (ignore ta backend))
|
|
(values))
|
|
#+END_SRC
|
|
|
|
* Keybinding System
|
|
|
|
The keybinding system provides layered keymaps — dispatch checks the
|
|
focused component's keymap first, then :local, then :global. This
|
|
allows modal applications (Vim-style) where the same key does
|
|
different things in different contexts.
|
|
|
|
** Keymap Struct
|
|
|
|
A keymap has a ~name~ for debugging, ~bindings~ as an alist (ordered
|
|
for priority), and an optional ~parent~ for inheritance chains.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(in-package #:cl-tty.input)
|
|
|
|
(defstruct keymap
|
|
(name nil :type (or keyword null))
|
|
(bindings nil :type list)
|
|
(parent nil :type (or keymap null)))
|
|
#+END_SRC
|
|
|
|
** Global Registry
|
|
|
|
~*keymaps*~ is a hash table mapping keyword names to keymap structs.
|
|
~equal~ test is used because keymap names are keywords (which are
|
|
~eql~-comparable, but ~equal~ is safer for edge cases).
|
|
~*chord-timeout*~ controls how long the system waits for the second
|
|
key in a two-key chord sequence.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defparameter *keymaps* (make-hash-table :test #'equal))
|
|
(defparameter *chord-timeout* 0.5)
|
|
#+END_SRC
|
|
|
|
** Key Spec Matching
|
|
|
|
~key-match-p~ determines whether a keybinding spec matches a key event.
|
|
The spec format is a keyword like ~:ctrl+p~ — the function splits the
|
|
keyword name on ~+~ to extract the modifier (~"CTRL"~, ~"ALT"~,
|
|
~"SHIFT"~) and the base key (~"P"~).
|
|
|
|
I used ~case~ with string literals in an early version:
|
|
~(~case mod-str ("CTRL" ...))~. This does NOT work because ~case~ uses
|
|
~eql~ for comparison, and ~eql~ compares strings by object identity,
|
|
not value. Two ~"CTRL"~ literals may or may not be ~eql~ depending on
|
|
whether the compiler coalesces them. The fix is ~cond~ with ~string=?.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun key-match-p (spec event)
|
|
(etypecase spec
|
|
(keyword
|
|
(let* ((name (string spec))
|
|
(plus (position #\+ name)))
|
|
(if plus
|
|
(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))))
|
|
(eql spec (key-event-key event)))))
|
|
(list
|
|
(when spec
|
|
(key-match-p (first spec) event)))))
|
|
#+END_SRC
|
|
|
|
** Dispatch
|
|
|
|
~dispatch-key-event~ routes an event through the three keymap layers:
|
|
|
|
1. Focused component's keymap (from ~component-keymap~ generic)
|
|
2. ~:local~ keymap (for the current screen/modal context)
|
|
3. ~:global~ keymap (always active — Ctrl+C, Ctrl+Q, etc.)
|
|
|
|
Each keymap is tried in order. The first match calls the handler and
|
|
returns ~t~. If no keymap matches, the event is unhandled (~nil~).
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun dispatch-key-event (event &key component)
|
|
(labels ((try-keymap (km)
|
|
(when km
|
|
(loop for (spec . handler) in (keymap-bindings km)
|
|
thereis (when (key-match-p spec event)
|
|
(funcall handler event)
|
|
t))))
|
|
(find-keymap (name)
|
|
(gethash name *keymaps*)))
|
|
(or (and component
|
|
(let ((km (component-keymap component)))
|
|
(when km (try-keymap km))))
|
|
(try-keymap (find-keymap :local))
|
|
(try-keymap (find-keymap :global)))))
|
|
#+END_SRC
|
|
|
|
** defkeymap macro
|
|
|
|
~defkeymap~ is a convenience macro for registering a keymap. It
|
|
expands to a ~setf~ on ~*keymaps*~. Each binding is a cons of a
|
|
key spec and a handler form, quoted and wrapped in a ~list~.
|
|
|
|
The ~loop~ handles both ~(spec . handler)~ and ~(spec handler)~
|
|
binding formats for flexibility.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defmacro defkeymap (name &body bindings)
|
|
`(setf (gethash ',name *keymaps*)
|
|
(make-keymap :name ',name
|
|
:bindings (list ,@(loop for b in bindings
|
|
collect (if (consp (cdr b))
|
|
`(cons ',(car b) ,(cadr b))
|
|
`(cons ',(car b) ,(cdr b))))))))
|
|
#+END_SRC
|
|
|
|
** Component Protocol Integration
|
|
|
|
~component-keymap~ is a generic function that returns ~nil~ by default.
|
|
Widgets with custom keymaps override this method to return their own
|
|
~keymap~ struct.
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defgeneric component-keymap (component)
|
|
(:method ((c t)) nil))
|
|
#+END_SRC
|
|
|
|
|
|
* Working Code (tangle targets)
|
|
|
|
The code below is the working, tested implementation. Each block tangles
|
|
to its target file. The per-function blocks above are the literate reading
|
|
experience; this section is what actually generates the compilable code.
|
|
|
|
** input.lisp
|
|
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
|
|
(in-package #:cl-tty.input)
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Utility: split-string (avoids external dependency)
|
|
;;; ---------------------------------------------------------------------------
|
|
(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 variables for rendering pipeline (set by application)
|
|
;;; ---------------------------------------------------------------------------
|
|
(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
|
|
;;; ---------------------------------------------------------------------------
|
|
(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)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Mouse event struct
|
|
;;; ---------------------------------------------------------------------------
|
|
(defstruct mouse-event
|
|
(type nil :type (or keyword null))
|
|
(button nil :type (or keyword nil))
|
|
(x 0 :type fixnum)
|
|
(y 0 :type fixnum)
|
|
(raw nil :type (or string null)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Terminal raw mode
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun save-terminal-state ()
|
|
(sb-posix:tcgetattr 0))
|
|
|
|
(defun make-raw-termios (termios)
|
|
(flet ((clear-flag (flags mask)
|
|
(logand flags (lognot mask))))
|
|
(setf (sb-posix:termios-iflag termios)
|
|
(clear-flag (sb-posix:termios-iflag termios)
|
|
(logior sb-posix:brkint sb-posix:ignpar
|
|
sb-posix:istrip sb-posix:inlcr
|
|
sb-posix:igncr sb-posix:icrnl
|
|
sb-posix:ixon)))
|
|
(setf (sb-posix:termios-oflag termios)
|
|
(clear-flag (sb-posix:termios-oflag termios)
|
|
sb-posix:opost))
|
|
(setf (sb-posix:termios-lflag termios)
|
|
(clear-flag (sb-posix:termios-lflag termios)
|
|
(logior sb-posix:icanon sb-posix:echo
|
|
sb-posix:isig sb-posix:iexten)))
|
|
(setf (sb-posix:termios-cc termios sb-posix:vmin) 1)
|
|
(setf (sb-posix:termios-cc termios sb-posix:vtime) 0)
|
|
termios))
|
|
|
|
(defun set-raw-mode ()
|
|
(let ((raw (make-raw-termios (save-terminal-state))))
|
|
(sb-posix:tcsetattr 0 sb-posix:tcsanow raw)
|
|
raw))
|
|
|
|
(defun restore-terminal-state (termios)
|
|
(sb-posix:tcsetattr 0 sb-posix:tcsanow termios))
|
|
|
|
(defmacro with-raw-terminal (&body body)
|
|
(let ((saved (gensym "SAVED")))
|
|
`(let ((,saved (save-terminal-state)))
|
|
(set-raw-mode)
|
|
(unwind-protect
|
|
(progn ,@body)
|
|
(restore-terminal-state ,saved)))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Low-level byte reading
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun read-raw-byte (&key timeout)
|
|
(if timeout
|
|
(let ((deadline (+ (get-universal-time) timeout)))
|
|
(loop while (< (get-universal-time) deadline)
|
|
do (handler-case
|
|
(let ((buf (make-array 1 :element-type '(unsigned-byte 8))))
|
|
(let ((n (sb-posix:read 0 buf 1)))
|
|
(when (plusp n)
|
|
(return-from read-raw-byte (aref buf 0)))))
|
|
(sb-posix:syscall-error ()
|
|
(return-from read-raw-byte nil)))
|
|
(sleep 0.01))
|
|
nil)
|
|
(let ((buf (make-array 1 :element-type '(unsigned-byte 8))))
|
|
(multiple-value-bind (n err)
|
|
(ignore-errors (sb-posix:read 0 buf 1))
|
|
(if (and (integerp n) (plusp n))
|
|
(aref buf 0)
|
|
(progn
|
|
(when err (format *error-output* "read error: ~A~%" err))
|
|
nil))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; CSI parameter parser
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun parse-csi-params ()
|
|
(let ((params '())
|
|
(raw (make-array 0 :element-type '(unsigned-byte 8)
|
|
:fill-pointer 0 :adjustable t))
|
|
(current 0))
|
|
(loop
|
|
(let ((b (read-raw-byte)))
|
|
(unless b (return (values nil nil nil)))
|
|
(vector-push-extend b raw)
|
|
(cond
|
|
((and (>= b #x30) (<= b #x3f))
|
|
(if (char= (code-char b) #\;)
|
|
(progn (push current params) (setf current 0))
|
|
(setf current (+ (* current 10) (- b #x30)))))
|
|
((and (>= b #x20) (<= b #x2f))
|
|
nil)
|
|
((and (>= b #x40) (<= b #x7e))
|
|
(push current params)
|
|
(return (values (nreverse params) b
|
|
(map 'string #'code-char raw))))
|
|
(t
|
|
(return (values nil nil nil))))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Key event tables
|
|
;;; ---------------------------------------------------------------------------
|
|
(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 . :tab)))
|
|
|
|
(defparameter *csi-tilde-table*
|
|
'((1 . :home) (2 . :insert) (3 . :delete)
|
|
(4 . :end) (5 . :page-up) (6 . :page-down)
|
|
(7 . :home) (8 . :end)
|
|
(11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4)
|
|
(15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8)
|
|
(20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; SGR mouse parser
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun parse-sgr-mouse (raw)
|
|
(let* ((start (position #\< raw))
|
|
(end (position #\m raw :from-end t))
|
|
(end2 (position #\M raw :from-end t))
|
|
(final (if end end end2))
|
|
(releasep (char= (char raw (1- (length raw))) #\m)))
|
|
(when (and start final (> final start))
|
|
(let* ((nums (mapcar #'parse-integer
|
|
(%split-string (subseq raw (1+ start) final) #\;)))
|
|
(code (first nums))
|
|
(x (or (second nums) 0))
|
|
(y (or (third nums) 0))
|
|
(button (logand code #x03))
|
|
(mod (logand code #x1c))
|
|
(motion (logand code #x20))
|
|
(wheel (logand code #x40)))
|
|
(declare (ignore mod))
|
|
(make-mouse-event
|
|
:type (cond (releasep :release)
|
|
(motion :drag)
|
|
(t :press))
|
|
:button (cond (wheel (if (zerop (logand code #x01))
|
|
:wheel-up :wheel-down))
|
|
((= button 0) :left)
|
|
((= button 1) :middle)
|
|
((= button 2) :right)
|
|
(t :none))
|
|
:x x :y y :raw raw)))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Escape sequence reader
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun %read-escape-sequence ()
|
|
(let ((b (read-raw-byte)))
|
|
(unless b
|
|
(return-from %read-escape-sequence
|
|
(make-key-event :key :escape :raw (string #\Esc))))
|
|
(case b
|
|
;; SS3: ESC O X
|
|
(#x4f
|
|
(let ((b2 (read-raw-byte)))
|
|
(if b2
|
|
(let ((key (cdr (assoc (code-char b2)
|
|
'((#\P . :f1) (#\Q . :f2)
|
|
(#\R . :f3) (#\S . :f4))))))
|
|
(make-key-event :key (or key :unknown)
|
|
:raw (format nil "~C~C~C" #\Esc #\O (code-char b2))))
|
|
(make-key-event :key :escape :raw (string #\Esc)))))
|
|
;; CSI: ESC [ ...
|
|
(#x5b
|
|
(multiple-value-bind (params final-byte) (parse-csi-params)
|
|
(if (null final-byte)
|
|
(make-key-event :key :escape :raw (string #\Esc))
|
|
(if (and (char= (code-char final-byte) #\M)
|
|
(>= (length params) 3))
|
|
(let* ((p0 (first params)))
|
|
(if (zerop (logand p0 #x40))
|
|
(let* ((x (second params))
|
|
(y (third params))
|
|
(button (logand p0 #x03))
|
|
(motion (logand p0 #x20))
|
|
(wheel (logand p0 #x40)))
|
|
(make-mouse-event
|
|
:type (if motion :drag :press)
|
|
:button (cond (wheel (if (zerop (logand p0 #x01))
|
|
:wheel-up :wheel-down))
|
|
((= button 0) :left)
|
|
((= button 1) :middle)
|
|
((= button 2) :right)
|
|
(t :none))
|
|
:x x :y y :raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte))))
|
|
(let* ((tilde-p (char= (code-char final-byte) #\~))
|
|
(param (or p0 0))
|
|
(key (if tilde-p
|
|
(cdr (assoc param *csi-tilde-table*))
|
|
(cdr (assoc (code-char final-byte) *csi-key-table*))))
|
|
(modifier (when (> (length params) 1) (second params))))
|
|
(let ((ctrl nil) (alt nil) (shift nil))
|
|
(when modifier
|
|
(setf shift (logtest modifier 1)
|
|
alt (logtest modifier 2)
|
|
ctrl (logtest modifier 4)))
|
|
(make-key-event :key (or key :unknown)
|
|
:ctrl ctrl :alt alt :shift shift
|
|
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))
|
|
(let* ((tilde-p (char= (code-char final-byte) #\~))
|
|
(param (or (first params) 0))
|
|
(key (if tilde-p
|
|
(cdr (assoc param *csi-tilde-table*))
|
|
(cdr (assoc (code-char final-byte) *csi-key-table*))))
|
|
(modifier (when (> (length params) 1) (second params))))
|
|
(let ((ctrl nil) (alt nil) (shift nil))
|
|
(when modifier
|
|
(setf shift (logtest modifier 1)
|
|
alt (logtest modifier 2)
|
|
ctrl (logtest modifier 4)))
|
|
(make-key-event :key (or key :unknown)
|
|
:ctrl ctrl :alt alt :shift shift
|
|
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))))))
|
|
;; ESC ESC
|
|
(#x1b
|
|
(make-key-event :key :escape :alt t :raw "\\e\\e"))
|
|
;; ESC + printable = Alt+key
|
|
(t
|
|
(let ((ch (code-char b)))
|
|
(if (and (>= b #x20) (<= b #x7e))
|
|
(make-key-event :key (intern (string (string-upcase ch)) :keyword)
|
|
:alt t
|
|
:raw (format nil "~C~C" #\Esc ch))
|
|
(make-key-event :key :unknown
|
|
:raw (format nil "~C~C" #\Esc ch))))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Top-level event reader
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun %read-event (&key timeout)
|
|
(let ((b (read-raw-byte :timeout timeout)))
|
|
(unless b
|
|
(return-from %read-event nil))
|
|
(case b
|
|
(#x1b
|
|
(%read-escape-sequence))
|
|
(#x09
|
|
(make-key-event :key :tab :code #x09))
|
|
(#x0a
|
|
(make-key-event :key :enter :code #x0a))
|
|
(#x0d
|
|
(make-key-event :key :enter :code #x0d))
|
|
((#x7f #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)))
|
|
(#x1c (make-key-event :key :backslash :ctrl t :code b))
|
|
(#x1d (make-key-event :key :rbracket :ctrl t :code b))
|
|
(#x1e (make-key-event :key :caret :ctrl t :code 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)))
|
|
(t
|
|
(make-key-event :key :unknown :code b :raw (string (code-char b)))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Backend integration
|
|
;;; ---------------------------------------------------------------------------
|
|
(defmethod read-event ((b cl-tty.backend:backend) &key timeout)
|
|
(declare (ignore b))
|
|
(when (probe-file "/dev/stdin")
|
|
(%read-event :timeout timeout)))
|
|
#+END_SRC
|
|
|
|
|
|
** text-input.lisp
|
|
#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp
|
|
(in-package #:cl-tty.input)
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; TextInput class
|
|
;;; ---------------------------------------------------------------------------
|
|
(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))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Editing operations
|
|
;;; ---------------------------------------------------------------------------
|
|
(defun text-input-insert (input char)
|
|
"Insert CHAR at the cursor position in INPUT."
|
|
(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)
|
|
"Delete character before cursor."
|
|
(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)
|
|
"Delete character at cursor."
|
|
(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)))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Cursor movement
|
|
;;; ---------------------------------------------------------------------------
|
|
(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 (stub — proper rendering uses theme + backend)
|
|
;;; ---------------------------------------------------------------------------
|
|
(defmethod render ((in text-input) (backend t))
|
|
"Render a text-input widget. Full rendering requires *current-backend*,
|
|
*current-theme*, and the rendering pipeline. This is a no-op stub for
|
|
unit testing the widget logic."
|
|
(declare (ignore in backend))
|
|
(values))
|
|
#+END_SRC
|
|
|
|
|
|
** textarea.lisp
|
|
#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp
|
|
(in-package #:cl-tty.input)
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; Utility: split string (local copy for dependency-free operation)
|
|
;;; ---------------------------------------------------------------------------
|
|
(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))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; 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))))))
|
|
|
|
;;; ---------------------------------------------------------------------------
|
|
;;; 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))
|
|
(setf (textarea-undo-stack ta)
|
|
(make-array 100 :fill-pointer 0)))
|
|
(vector-push (textarea-value ta) stack)
|
|
;; Clear redo stack on new action
|
|
(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))
|
|
(: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))))))
|
|
(: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 (stub — proper rendering uses theme + backend)
|
|
;;; ---------------------------------------------------------------------------
|
|
(defmethod render ((ta textarea) (backend t))
|
|
"Render a textarea widget. Full rendering requires *current-backend*,
|
|
*current-theme*, and the rendering pipeline. This is a no-op stub for
|
|
unit testing the widget logic."
|
|
(declare (ignore ta backend))
|
|
(values))
|
|
#+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
|
|
;;; ---------------------------------------------------------------------------
|
|
(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
|
|
;; 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-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))))
|
|
|
|
;; ── 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 ────────────────────────────────────────────
|
|
|
|
(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
|
|
|