diff --git a/cl-tui.asd b/cl-tui.asd index 3ccc036..1cbacf8 100644 --- a/cl-tui.asd +++ b/cl-tui.asd @@ -2,9 +2,9 @@ (asdf:defsystem :cl-tui :description "Reusable Common Lisp Terminal UI Framework" :author "Amr Gharbeia" - :version "0.3.0" + :version "0.5.0" :license "TBD" - :depends-on (:fiveam) + :depends-on (:fiveam :sb-posix) :components ((:module "backend" :components @@ -21,7 +21,14 @@ (:file "dirty") (:file "box" :depends-on ("package")) (:file "text" :depends-on ("package" "box")) - (:file "render" :depends-on ("package" "box" "text"))))) + (:file "render" :depends-on ("package" "box" "text")) + (:file "theme" :depends-on ("package")) + ;; Input system (v0.5.0) + (:file "input-package" :depends-on ("package")) + (:file "input" :depends-on ("input-package" "dirty" "box")) + (:file "text-input" :depends-on ("input-package" "input" "box")) + (:file "textarea" :depends-on ("input-package" "input" "box")) + (:file "keybindings" :depends-on ("input-package" "input"))))) :in-order-to ((test-op (test-op :cl-tui-tests)))) (asdf:defsystem :cl-tui-tests @@ -38,6 +45,15 @@ :components ((:file "box-tests") (:file "dirty-tests") - (:file "render-tests")))) + (:file "render-tests") + (:file "theme-tests") + (:file "input-tests")))) :perform (test-op (o c) - (uiop:symbol-call :cl-tui-backend-test '#:run-tests))) + (dolist (suite '((:cl-tui-backend-test "BACKEND-SUITE") + (:cl-tui-box-test "BOX-SUITE") + (:cl-tui-input-test "INPUT-SUITE"))) + (let* ((pkg (find-package (first suite))) + (s (and pkg (find-symbol (second suite) pkg)))) + (when s + (fiveam:explain! (fiveam:run s))))) + (uiop:quit 0))) diff --git a/demo.lisp b/demo.lisp new file mode 100644 index 0000000..f373266 --- /dev/null +++ b/demo.lisp @@ -0,0 +1,28 @@ +;; demo.lisp — minimal cl-tui demo +(load "/root/quicklisp/setup.lisp") +(ql:quickload :fiveam :silent t) +(load "backend/package.lisp") +(load "backend/classes.lisp") +(load "backend/simple.lisp") +(load "backend/modern.lisp") +(load "layout/layout.lisp") +(load "src/components/package.lisp") +(load "src/components/dirty.lisp") +(load "src/components/box.lisp") +(load "src/components/text.lisp") +(load "src/components/render.lisp") +(in-package :cl-tui.box) + +;; Demo 1: Simple backend (ASCII) +(let* ((b (make-simple-backend)) + (bx (make-box :border-style :rounded :title " Hello World " :width 30 :height 5))) + (compute-layout (box-layout-node bx) 30 5) + (render bx b)) + +;; Demo 2: Box with text inside +(let* ((b (make-simple-backend)) + (tx (make-text "This is cl-tui in action!" :width 28 :height 1))) + (setf (layout-node-direction (text-layout-node tx)) :column) + (compute-layout (text-layout-node tx) 28 1) + (render tx b) + (format t "~%~%")) diff --git a/docs/plans/2026-05-11-v0.5.0-text-input.md b/docs/plans/2026-05-11-v0.5.0-text-input.md new file mode 100644 index 0000000..ae7c723 --- /dev/null +++ b/docs/plans/2026-05-11-v0.5.0-text-input.md @@ -0,0 +1,365 @@ +# v0.5.0: Text Input + Keybinding System + +**Architecture:** Three layers. First, terminal input infrastructure (raw mode, escape parsing, key events) — this is the missing piece the roadmap assumed croatoan would provide. Then TextInput and Textarea widgets. Finally, the layered keybinding system. + +**The hidden dependency:** `read-event` is currently a no-op in both backends. We need raw terminal I/O (tcsetattr, non-canonical mode, escape sequence parsing) before any input widget works. SBCL provides `sb-posix` for POSIX terminal APIs. + +**File structure:** +``` +org/input.org — literate source: terminal input + key events +org/text-input.org — literate source: TextInput widget +org/textarea.org — literate source: Textarea widget +org/keybindings.org — literate source: keybinding system + +backend/input.lisp — tangled: raw terminal, escape parser, key events +src/components/input.lisp — tangled: TextInput widget +src/components/textarea.lisp — tangled: Textarea widget +src/components/keybindings.lisp — tangled: keybinding system +``` + +--- + +### Task 1: Terminal Input Infrastructure + +**Objective:** Raw terminal mode, ANSI escape sequence parser, key event types. Implements `read-event` for both backends. + +**Files:** +- Create: `org/input.org` +- Create: `src/input.lisp` (tangled) +- Create: `tests/input-tests.lisp` +- Modify: `backend/package.lisp` — add input exports +- Modify: `backend/modern.lisp` — implement read-event +- Modify: `backend/simple.lisp` — implement read-event (stdin) +- Modify: `cl-tui.asd` — add input module to main and test systems + +**Code architecture:** + +```lisp +;; Key event type — all input gets normalized to this +(defstruct key-event + key ;; :a, :b, :space, :enter, :tab, :escape + ;; :up, :down, :left, :right + ;; :f1..:f12 + ctrl ;; boolean + alt ;; boolean + shift ;; boolean + code ;; raw character code (fixnum) + raw ;; raw escape sequence string (for debugging) + text) ;; for bracketed paste: the pasted text string + +(defstruct mouse-event + type ;; :press, :release, :drag + button ;; :left, :middle, :right, :none + x y + raw) + +;; Terminal raw mode — saves/restores termios +(defun save-terminal-state () ...) ;; tcgetattr(0) +(defun set-raw-mode () ...) ;; tcsetattr(0, TCSANOW, raw) +(defun restore-terminal-state () ...) +(defmacro with-raw-terminal (&body body) ...) + +;; Escape sequence parser +(defun read-byte-from-stdin (&optional timeout) ...) +(defun parse-escape-sequence () ...) ;; reads CSI, SS3 sequences +(defun parse-csi-sequence () ...) ;; parses CSI number;...$char +(defun parse-sgr-mouse () ...) ;; parse CSI < r;c;M/m +(defun read-event-from-stdin (&key timeout) ...) ;; full read+parse + +;; Backend integration +(defmethod read-event ((b modern-backend) &key timeout) + (let ((event (read-event-from-stdin :timeout timeout))) + (if (key-event-p event) + (values (key-event-key event) event) + (values nil event)))) + +(defmethod read-event ((b simple-backend) &key timeout) + (read-event-from-stdin :timeout timeout)) +``` + +**Key normalization table (partial):** +| Raw byte(s) | Key | Ctrl | Alt | +|---|---|---|---| +| #x1b | :escape | nil | nil | +| #x7f or #x08 | :backspace | nil | nil | +| #x0a | :enter | nil | nil | +| #x09 | :tab | nil | nil | +| #x01 | :a | t | nil | +| CSI A | :up | nil | nil | +| CSI 1~ | :home | nil | nil | +| CSI 200~ | (bracketed paste start) | — | — | + +**Tests:** +```lisp +(test read-ctrl-a + (let* ((event (make-key-event :a :ctrl t))) + (is (eql (key-event-key event) :a)) + (is-true (key-event-ctrl event)))) + +(test parse-csi-up + (let ((kb (terminal-sequence->key-event (format nil \"~C[A\" #\\Esc)))) + (is (eql (key-event-key kb) :up)))) + +(test mouse-sgr + (let ((event (parse-sgr-mouse \"<0;10;5M\"))) + (is (eql (mouse-event-type event) :press)) + (is (eql (mouse-event-button event) :left)) + (is (= (mouse-event-x event) 10)) + (is (= (mouse-event-y event) 5)))) +``` + +**Line count:** ~250 lines + +--- + +### Task 2: TextInput Widget + +**Objective:** Single-line text input widget with cursor, placeholder, insertion/deletion, clipboard, emacs keybindings. + +**Files:** +- Create: `org/text-input.org` +- Create: `src/components/input.lisp` +- Modify: `src/components/package.lisp` — add exports +- Modify: `cl-tui.asd` — add input.lisp + +**TextInput class:** +```lisp +(defclass text-input (dirty-mixin) + ((value :initform "" :initarg :value :accessor text-input-value) + (cursor :initform 0 :initarg :cursor :accessor text-input-cursor) + (placeholder :initform "" :initarg :placeholder :accessor text-input-placeholder) + (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))) +``` + +**Methods:** +- `render-text-input` — renders value at cursor position, placeholder when empty, cursor +- `handle-input text-input key-event` — dispatches key events to editing actions: + - Left/Right → cursor-char-left/right + - Home → cursor-line-start + - End → cursor-line-end + - Backspace → delete-char-before + - Delete → delete-char-after + - Printable chars → insert-char + - Enter → on-submit callback + - Ctrl+W → delete-word-before + - Ctrl+U → delete-line-before + - Ctrl+K → delete-line-after + - Ctrl+A → cursor-line-start + - Ctrl+E → cursor-line-end + +**Visual:** +``` +┌──────────────────────────────┐ +│ Hello world| │ ← cursor at position 11 +└──────────────────────────────┘ + +┌──────────────────────────────┐ +│ Type something... │ ← placeholder (dimmed) +└──────────────────────────────┘ +``` + +**Tests:** +```lisp +(test input-empty + (let ((in (make-text-input))) + (is (string= (text-input-value in) "")) + (is (= (text-input-cursor in) 0)))) + +(test input-insert-char + (let ((in (make-text-input))) + (handle-input in (make-key-event :a)) + (is (string= (text-input-value in) "a")) + (is (= (text-input-cursor in) 1)))) + +(test input-backspace + (let ((in (make-text-input :initial-value "ab"))) + (setf (text-input-cursor in) 2) + (handle-input in (make-key-event :backspace)) + (is (string= (text-input-value in) "a")) + (is (= (text-input-cursor in) 1)))) + +(test input-max-length + (let ((in (make-text-input :max-length 3))) + (handle-input in (make-key-event :a)) + (handle-input in (make-key-event :b)) + (handle-input in (make-key-event :c)) + (handle-input in (make-key-event :d)) ;; should be ignored + (is (string= (text-input-value in) "abc")))) + +(test input-cursor-movement + (let ((in (make-text-input :initial-value "hello"))) + (setf (text-input-cursor in) 5) + (handle-input in (make-key-event :left)) + (is (= (text-input-cursor in) 4)) + (handle-input in (make-key-event :right)) + (is (= (text-input-cursor in) 5)) + (handle-input in (make-key-event :home)) + (is (= (text-input-cursor in) 0)) + (handle-input in (make-key-event :end)) + (is (= (text-input-cursor in) 5)))) +``` + +**Line count:** ~150 lines + +--- + +### Task 3: Textarea Widget + +**Objective:** Multi-line text input with selection, undo/redo, word navigation. + +**Files:** +- Create: `org/textarea.org` +- Create: `src/components/textarea.lisp` +- Modify: `src/components/package.lisp` — add exports +- Modify: `cl-tui.asd` — add textarea.lisp + +**Textarea class:** +```lisp +(defclass textarea (dirty-mixin) + ((value :initform "" :initarg :value :accessor textarea-value) + (cursor-row :initform 0 :accessor textarea-cursor-row) + (cursor-col :initform 0 :accessor textarea-cursor-col) + (selection-start :initform nil :accessor textarea-selection-start) ;; (row . col) or nil + (undo-stack :initform (make-array 100 :fill-pointer 0) :accessor textarea-undo-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))) +``` + +**Methods:** +- `render-textarea` — renders visible lines with cursor, optional selection highlight +- `handle-textarea-input textarea key-event` — dispatches +- `textarea-insert-at textarea str` — insert at cursor +- `textarea-delete-before textarea` — backspace +- `textarea-delete-after textarea` — delete +- `textarea-newline textarea` — insert newline +- `textarea-cursor-up/down/left/right` — movement +- `textarea-word-forward/backward` — word skips +- `textarea-select-to textarea` — extend selection to cursor +- `textarea-copy-selection / cut-selection / paste` — clipboard +- `textarea-undo / redo` — undo/redo stack + +**Tests:** Similar pattern to TextInput but multi-line, with selection tests. +**Line count:** ~200 lines + +--- + +### Task 4: Keybinding System + +**Objective:** Layered keymaps (global → local → input), defkeymap macro, chord sequences. + +**Files:** +- Create: `org/keybindings.org` +- Create: `src/components/keybindings.lisp` +- Modify: `src/components/package.lisp` — add exports +- Modify: `cl-tui.asd` — add keybindings.lisp + +**Architecture:** +```lisp +(defstruct keymap + name ;; :global, :local, or symbol + bindings ;; alist: ((key-event-spec . handler-function) ...) + parent) ;; parent keymap for fallback + +(defmacro defkeymap (name &body bindings) + ;; (defkeymap :global + ;; (:ctrl+p . command-palette) + ;; ((:ctrl+c :ctrl+d) . quit)) + `(setf (gethash ',name *keymaps*) + (make-keymap :name ',name + :bindings ',bindings))) + +(defparameter *keymaps* (make-hash-table)) + +;; Dispatch order: focused-component-keymap → local → global +(defun dispatch-key-event (event &key component) + (let* ((local (and component (component-keymap component))) + (global (gethash :global *keymaps*))) + (or (match-and-call local event) + (match-and-call global event)))) + +(defun match-and-call (keymap event) + (loop for (spec . handler) in (keymap-bindings keymap) + thereis (when (key-match-p spec event) + (funcall handler event)))) + +;; Key spec matching +(defun key-match-p (spec event) + (etypecase spec + (keyword (eql spec (key-event-key event))) + (list (and (eql (first spec) (key-event-key event)) + (eql (getf (rest spec) :ctrl) (key-event-ctrl event)) + (eql (getf (rest spec) :alt) (key-event-alt event)))))) +``` + +**Chord support:** Two-key sequences with timeout: +```lisp +(defparameter *chord-timeout* 0.5) ;; seconds + +(defun handle-chord (first-event) + (when (chord-p first-event) ;; first key has pending status + (let ((second-event (read-event-from-stdin :timeout *chord-timeout*))) + (if (key-event-p second-event) + (dispatch-key-event (combine-chord first-event second-event)) + ;; timeout — dispatch first event as standalone + (dispatch-key-event first-event))))) +``` + +**Tests:** +```lisp +(test keymap-simple + (let ((called nil)) + (setf (gethash :test *keymaps*) + (make-keymap :name :test + :bindings `((:ctrl+p . ,(lambda (e) (setf called t)))))) + (dispatch-key-event (make-key-event :p :ctrl t)) + (is-true called))) + +(test keymap-fallback + (let ((global-called nil) (local-called nil)) + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+q . ,(lambda (e) (setf global-called t)))))) + ;; Event not in local should fall through + (dispatch-key-event (make-key-event :q :ctrl t)) + (is-true global-called))) + +(test chord-sequence + (let ((called nil)) + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `(((:ctrl+c :ctrl+d) . ,(lambda (e) (setf called t)))))) + ;; Simulate chord + (handler-chord (make-key-event :c :ctrl t) (make-key-event :d :ctrl t)) + (is-true called))) +``` + +**Line count:** ~150 lines + +--- + +### Dependency Order + +``` +Task 1 (input infra) ──→ Task 2 (TextInput) ──→ Task 3 (Textarea) + └──→ Task 4 (keybinding) ──→ uses both +``` + +Task 1 is the prerequisite for everything. Tasks 2, 3, 4 can then proceed in parallel (2 and 3 depend on 1, 4 depends on key events from 1). + +--- + +### Verification + +After each task: +1. `sbcl --eval "(asdf:test-system :cl-tui)" --quit` — all tests GREEN +2. `scripts/validate-parens.py` — all files balanced +3. Commit with RED/GREEN evidence + +Final verification: +- All 4 phases implemented and tested +- ~750 lines total across all components +- Full test suite: ~100+ assertions, 100% GREEN diff --git a/org/text-input.org b/org/text-input.org new file mode 100644 index 0000000..cf4221a --- /dev/null +++ b/org/text-input.org @@ -0,0 +1,2705 @@ +#+TITLE: cl-tui 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[= 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[ 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-tui.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-tui.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-tui.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-tui.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-tui.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-tui.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-tui.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-tui.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-tui.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-tui.input + (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.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-tui-input-test + (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) + (:export #:run-tests)) +(in-package :cl-tui-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 + diff --git a/scripts/tangle.py b/scripts/tangle.py new file mode 100644 index 0000000..da6df2f --- /dev/null +++ b/scripts/tangle.py @@ -0,0 +1,74 @@ +#!/usr/bin/env python3 +"""tangle.py — Extract code blocks from .org files into .lisp files. + +Reads all .org files in org/ directory, finds #+BEGIN_SRC lisp :tangle +blocks, and writes/concatenates them to the specified target paths. + +Blocks with the same :tangle target are concatenated in file order. + +Usage: + python3 scripts/tangle.py # tangle all org/ files + python3 scripts/tangle.py org/specific.org # tangle one file + +Target paths are relative to the project root (../target from org/ = project/target). +""" +import re +import os +import sys +from collections import OrderedDict + +PROJECT_ROOT = os.path.dirname(os.path.dirname(os.path.abspath(__file__))) +ORG_DIR = os.path.join(PROJECT_ROOT, 'org') + +def tangle_file(org_path): + """Extract tangle blocks from one .org file.""" + with open(org_path) as f: + content = f.read() + + # Find all tangle blocks with their targets + pattern = r'#\+BEGIN_SRC lisp :tangle ([^\n]+)\n(.*?)\n#\+END_SRC' + blocks = re.findall(pattern, content, re.DOTALL) + + if not blocks: + return 0 + + # Group by target path + targets = OrderedDict() + for tangle_path, code in blocks: + # Resolve tangle path: ../src/x.lisp -> src/x.lisp + resolved = tangle_path.replace('../', '') + full_path = os.path.join(PROJECT_ROOT, resolved) + if full_path not in targets: + targets[full_path] = [] + targets[full_path].append(code.strip()) + + for full_path, codes in targets.items(): + os.makedirs(os.path.dirname(full_path), exist_ok=True) + combined = '\n\n'.join(codes) + '\n' + with open(full_path, 'w') as f: + f.write(combined) + print(f" {os.path.relpath(full_path, PROJECT_ROOT)} ({len(codes)} blocks, {sum(len(c) for c in codes)} chars)") + + return len(blocks) + +def main(): + if len(sys.argv) > 1: + org_files = [f for f in sys.argv[1:] if f.endswith('.org')] + else: + org_files = [os.path.join(ORG_DIR, f) for f in os.listdir(ORG_DIR) if f.endswith('.org')] + + total_blocks = 0 + for org_file in sorted(org_files): + name = os.path.basename(org_file) + blocks = tangle_file(org_file) + if blocks: + print(f"{name}: {blocks} blocks") + total_blocks += blocks + + if total_blocks > 0: + print(f"\nTotal: {total_blocks} code blocks tangled") + else: + print("No tangle blocks found.") + +if __name__ == '__main__': + main() diff --git a/src/components/input-package.lisp b/src/components/input-package.lisp new file mode 100644 index 0000000..e9010af --- /dev/null +++ b/src/components/input-package.lisp @@ -0,0 +1,34 @@ +(defpackage :cl-tui.input + (:use :cl :cl-tui.backend :cl-tui.box :cl-tui.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)) diff --git a/src/components/input-tests.lisp b/src/components/input-tests.lisp new file mode 100644 index 0000000..1fadb5e --- /dev/null +++ b/src/components/input-tests.lisp @@ -0,0 +1,269 @@ +(defpackage :cl-tui-input-test + (:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input) + (:export #:run-tests)) +(in-package :cl-tui-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))) diff --git a/src/components/input.lisp b/src/components/input.lisp new file mode 100644 index 0000000..ffe522f --- /dev/null +++ b/src/components/input.lisp @@ -0,0 +1,307 @@ +(in-package #:cl-tui.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-tui.backend:backend) &key timeout) + (declare (ignore b)) + (when (probe-file "/dev/stdin") + (%read-event :timeout timeout))) diff --git a/src/components/keybindings.lisp b/src/components/keybindings.lisp new file mode 100644 index 0000000..f99453f --- /dev/null +++ b/src/components/keybindings.lisp @@ -0,0 +1,77 @@ +(in-package #:cl-tui.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)) diff --git a/src/components/package.lisp b/src/components/package.lisp index 34cdfd3..3722403 100644 --- a/src/components/package.lisp +++ b/src/components/package.lisp @@ -24,5 +24,8 @@ #:render #:render-screen #:render-node #:component-layout-node #:component-children #:component-parent #:available-width #:available-height - #:propagate-dirty)) + #:propagate-dirty + ;; Theme engine + #:theme #:make-theme #:theme-mode + #:theme-color #:load-preset #:define-preset)) (in-package :cl-tui.box) diff --git a/src/components/text-input.lisp b/src/components/text-input.lisp new file mode 100644 index 0000000..f43153f --- /dev/null +++ b/src/components/text-input.lisp @@ -0,0 +1,163 @@ +(in-package #:cl-tui.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)) diff --git a/src/components/textarea.lisp b/src/components/textarea.lisp new file mode 100644 index 0000000..e160de3 --- /dev/null +++ b/src/components/textarea.lisp @@ -0,0 +1,258 @@ +(in-package #:cl-tui.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)) diff --git a/src/components/theme-tests.lisp b/src/components/theme-tests.lisp new file mode 100644 index 0000000..da0f669 --- /dev/null +++ b/src/components/theme-tests.lisp @@ -0,0 +1,61 @@ +(in-package :cl-tui-box-test) +(in-suite box-suite) + +(test theme-create-default + "A theme can be created with default mode" + (let ((th (make-theme))) + (is (typep th 'theme)) + (is (eql (theme-mode th) :dark)))) + +(test theme-create-light + "A theme can be created in light mode" + (let ((th (make-theme :mode :light))) + (is (eql (theme-mode th) :light)))) + +(test theme-color-set-and-get + "theme-color setf/get works" + (let ((th (make-theme))) + (setf (theme-color th :primary) "#FFD700") + (is (string= (theme-color th :primary) "#FFD700")))) + +(test theme-color-unknown-returns-nil + "Unknown roles return nil" + (let ((th (make-theme))) + (is (null (theme-color th :nonexistent))))) + +(test load-default-dark-preset + "Loading the default dark preset populates roles" + (let ((th (make-theme :mode :dark))) + (load-preset th :default) + (is (string= (theme-color th :primary) "#FFD700")) + (is (string= (theme-color th :background) "#1A1A2E")) + (is (string= (theme-color th :error) "#FF4444")))) + +(test load-default-light-preset + "Light variant has different colors" + (let ((th (make-theme :mode :light))) + (load-preset th :default) + (is (string= (theme-color th :primary) "#B8860B")) + (is (string= (theme-color th :background) "#F8F9FA")))) + +(test load-nord-preset + "Nord preset has different colors than default" + (let ((th (make-theme :mode :dark))) + (load-preset th :nord) + (is (string= (theme-color th :primary) "#88C0D0")) + (is (string= (theme-color th :background) "#2E3440")))) + +(test load-preset-unknown-warns + "Unknown preset warns but doesn't error" + (let ((th (make-theme))) + (signals warning (load-preset th :nonexistent)) + (is (null (theme-color th :primary))))) + +(test preset-switch-mode + "Switching mode and reloading changes colors" + (let ((th (make-theme :mode :dark))) + (load-preset th :default) + (is (string= (theme-color th :background) "#1A1A2E")) + (setf (theme-mode th) :light) + (load-preset th :default) + (is (string= (theme-color th :background) "#F8F9FA")))) diff --git a/src/components/theme.lisp b/src/components/theme.lisp new file mode 100644 index 0000000..487933a --- /dev/null +++ b/src/components/theme.lisp @@ -0,0 +1,87 @@ +(in-package :cl-tui.box) + +;; ── Theme Engine ────────────────────────────────────────────── + +(defclass theme () + ((mode :initform :dark :initarg :mode :accessor theme-mode) + (roles :initform (make-hash-table) :accessor theme-roles))) + +(defun make-theme (&key (mode :dark)) + (make-instance 'theme :mode mode)) + +(defun theme-color (theme role) + "Resolve a semantic ROLE to a hex color string in THEME." + (gethash role (theme-roles theme))) + +(defun (setf theme-color) (hex theme role) + "Set the hex color for a semantic ROLE in THEME." + (setf (gethash role (theme-roles theme)) hex)) + +(defparameter *presets* (make-hash-table :test #'eq)) + +(defmacro define-preset (name &key dark light) + "Define a theme preset with DARK and LIGHT variants. +NAME should be a keyword (e.g., :default, :nord)." + (check-type name keyword) + `(setf (gethash ,name *presets*) '(:dark ,dark :light ,light))) + +(defun load-preset (theme preset-name) + "Load PRESET-NAME (a keyword) into THEME, overwriting role mappings." + (let ((preset (gethash preset-name *presets*))) + (if preset + (let* ((variant (if (eql (theme-mode theme) :dark) + (getf preset :dark) + (getf preset :light))) + (roles (theme-roles theme))) + (clrhash roles) + (loop for (role hex) on variant by #'cddr + do (setf (gethash role roles) hex))) + (warn "Unknown preset: ~S" preset-name)))) + +(define-preset :default + :dark (:primary "#FFD700" :secondary "#B8860B" :accent "#FFA500" + :error "#FF4444" :warning "#FF8800" :success "#44BB44" :info "#4488FF" + :text "#FFFFFF" :text-muted "#888888" + :background "#1A1A2E" :background-panel "#16213E" :background-element "#0F3460" + :border "#334155" :border-active "#FFD700" + :diff-added "#164B16" :diff-removed "#4B1616" :diff-context "#1A1A2E" + :markdown-heading "#FFD700" :markdown-code "#334155" + :markdown-link "#4488FF" :markdown-quote "#888888" + :syntax-keyword "#FF79C6" :syntax-function "#50FA7B" + :syntax-string "#F1FA8C" :syntax-number "#BD93F9" + :syntax-comment "#6272A4" :syntax-type "#8BE9FD") + :light (:primary "#B8860B" :secondary "#8B6914" :accent "#FF8C00" + :error "#CC0000" :warning "#CC6600" :success "#228B22" :info "#0055CC" + :text "#1A1A2E" :text-muted "#888888" + :background "#F8F9FA" :background-panel "#FFFFFF" :background-element "#E9ECEF" + :border "#DEE2E6" :border-active "#B8860B" + :diff-added "#DFD" :diff-removed "#FDD" :diff-context "#F8F9FA" + :markdown-heading "#B8860B" :markdown-code "#E9ECEF" + :markdown-link "#0055CC" :markdown-quote "#888888" + :syntax-keyword "#D63384" :syntax-function "#198754" + :syntax-string "#FFC107" :syntax-number "#6F42C1" + :syntax-comment "#6C757D" :syntax-type "#0DCAF0")) + +(define-preset :nord + :dark (:primary "#88C0D0" :secondary "#81A1C1" :accent "#5E81AC" + :error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD" + :text "#ECEFF4" :text-muted "#616E88" + :background "#2E3440" :background-panel "#3B4252" :background-element "#434C5E" + :border "#4C566A" :border-active "#88C0D0" + :diff-added "#164B16" :diff-removed "#4B1616" :diff-context "#2E3440" + :markdown-heading "#88C0D0" :markdown-code "#3B4252" + :markdown-link "#81A1C1" :markdown-quote "#616E88" + :syntax-keyword "#81A1C1" :syntax-function "#A3BE8C" + :syntax-string "#EBCB8B" :syntax-number "#B48EAD" + :syntax-comment "#616E88" :syntax-type "#88C0D0") + :light (:primary "#5E81AC" :secondary "#81A1C1" :accent "#88C0D0" + :error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD" + :text "#2E3440" :text-muted "#8F9BB3" + :background "#ECEFF4" :background-panel "#FFFFFF" :background-element "#E5E9F0" + :border "#D8DEE9" :border-active "#5E81AC" + :diff-added "#DFD" :diff-removed "#FDD" :diff-context "#ECEFF4" + :markdown-heading "#5E81AC" :markdown-code "#E5E9F0" + :markdown-link "#81A1C1" :markdown-quote "#8F9BB3" + :syntax-keyword "#81A1C1" :syntax-function "#A3BE8C" + :syntax-string "#D08770" :syntax-number "#B48EAD" + :syntax-comment "#8F9BB3" :syntax-type "#88C0D0"))