Compare commits
7 Commits
feature/v0
...
feature/v0
| Author | SHA1 | Date | |
|---|---|---|---|
|
3b0410b088 | ||
|
|
c55f1773fb | ||
|
|
f07cb65186 | ||
|
|
2d3227aaf1 | ||
|
|
0851311c3d | ||
|
|
6ba69f4610 | ||
|
|
b0e5c18257 |
28
cl-tui.asd
28
cl-tui.asd
@@ -2,9 +2,9 @@
|
||||
(asdf:defsystem :cl-tui
|
||||
:description "Reusable Common Lisp Terminal UI Framework"
|
||||
:author "Amr Gharbeia"
|
||||
:version "0.2.0"
|
||||
:version "0.5.0"
|
||||
:license "TBD"
|
||||
:depends-on (:fiveam)
|
||||
:depends-on (:fiveam :sb-posix)
|
||||
:components
|
||||
((:module "backend"
|
||||
:components
|
||||
@@ -20,7 +20,15 @@
|
||||
((:file "package")
|
||||
(:file "dirty")
|
||||
(:file "box" :depends-on ("package"))
|
||||
(:file "text" :depends-on ("package" "box")))))
|
||||
(:file "text" :depends-on ("package" "box"))
|
||||
(: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
|
||||
@@ -36,6 +44,16 @@
|
||||
(:module "src/components"
|
||||
:components
|
||||
((:file "box-tests")
|
||||
(:file "dirty-tests"))))
|
||||
(:file "dirty-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)))
|
||||
|
||||
28
demo.lisp
Normal file
28
demo.lisp
Normal file
@@ -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 "~%~%"))
|
||||
365
docs/plans/2026-05-11-v0.5.0-text-input.md
Normal file
365
docs/plans/2026-05-11-v0.5.0-text-input.md
Normal file
@@ -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
|
||||
2705
org/text-input.org
Normal file
2705
org/text-input.org
Normal file
File diff suppressed because it is too large
Load Diff
74
scripts/tangle.py
Normal file
74
scripts/tangle.py
Normal file
@@ -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 <path>
|
||||
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()
|
||||
@@ -1,6 +1,6 @@
|
||||
(in-package :cl-tui.box)
|
||||
|
||||
(defclass box ()
|
||||
(defclass box (dirty-mixin)
|
||||
((layout-node :initform (make-layout-node) :accessor box-layout-node
|
||||
:initarg :layout-node)
|
||||
(border-style :initform :single :initarg :border-style
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
;; Dirty tracking tests are in box-tests.lisp (same test suite)
|
||||
(in-package :cl-tui-box-test)
|
||||
(in-suite box-suite)
|
||||
|
||||
(test dirty-mixin-default-is-dirty
|
||||
"A dirty-mixin starts as dirty"
|
||||
|
||||
34
src/components/input-package.lisp
Normal file
34
src/components/input-package.lisp
Normal file
@@ -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))
|
||||
269
src/components/input-tests.lisp
Normal file
269
src/components/input-tests.lisp
Normal file
@@ -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)))
|
||||
307
src/components/input.lisp
Normal file
307
src/components/input.lisp
Normal file
@@ -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)))
|
||||
77
src/components/keybindings.lisp
Normal file
77
src/components/keybindings.lisp
Normal file
@@ -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))
|
||||
@@ -19,5 +19,13 @@
|
||||
;; Utilities (for tests)
|
||||
#:word-wrap #:split-string
|
||||
;; Dirty tracking
|
||||
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty))
|
||||
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty
|
||||
;; Rendering pipeline
|
||||
#:render #:render-screen #:render-node
|
||||
#:component-layout-node #:component-children #:component-parent
|
||||
#:available-width #:available-height
|
||||
#:propagate-dirty
|
||||
;; Theme engine
|
||||
#:theme #:make-theme #:theme-mode
|
||||
#:theme-color #:load-preset #:define-preset))
|
||||
(in-package :cl-tui.box)
|
||||
|
||||
48
src/components/render-tests.lisp
Normal file
48
src/components/render-tests.lisp
Normal file
@@ -0,0 +1,48 @@
|
||||
(in-package :cl-tui-box-test)
|
||||
(in-suite box-suite)
|
||||
|
||||
(defun make-capturing-backend ()
|
||||
(let* ((s (make-string-output-stream))
|
||||
(b (make-modern-backend :output-stream s)))
|
||||
(values b s)))
|
||||
|
||||
(test render-generic-dispatches-box
|
||||
"render dispatches to render-box for box instances"
|
||||
(multiple-value-bind (b s) (make-capturing-backend)
|
||||
(let ((bx (make-box :border-style :single :width 10 :height 5)))
|
||||
(compute-layout (box-layout-node bx) 10 5)
|
||||
(render bx b)
|
||||
(is (search "┌" (get-output-stream-string s)) "box renders border"))))
|
||||
|
||||
(test render-generic-dispatches-text
|
||||
"render dispatches to render-text for text instances"
|
||||
(multiple-value-bind (b s) (make-capturing-backend)
|
||||
(let ((tx (make-text "Hello" :width 10 :height 1)))
|
||||
(compute-layout (text-layout-node tx) 10 1)
|
||||
(render tx b)
|
||||
(is (search "Hello" (get-output-stream-string s)) "text renders content"))))
|
||||
|
||||
(test component-layout-node-works
|
||||
"component-layout-node returns the right slot for each type"
|
||||
(let ((bx (make-box)) (tx (make-text "")))
|
||||
(is (typep (component-layout-node bx) 'layout-node))
|
||||
(is (typep (component-layout-node tx) 'layout-node))))
|
||||
|
||||
(test component-children-returns-nil
|
||||
"Leaf components have no children"
|
||||
(let ((bx (make-box)) (tx (make-text "")))
|
||||
(is (null (component-children bx)))
|
||||
(is (null (component-children tx)))))
|
||||
|
||||
(test propagate-dirty-marks-component
|
||||
"propagate-dirty marks the component dirty"
|
||||
(let ((c (make-box)))
|
||||
(mark-clean c)
|
||||
(is-false (dirty-p c) "should be clean after mark-clean")
|
||||
(propagate-dirty c)
|
||||
(is-true (dirty-p c) "should be dirty after propagate-dirty")))
|
||||
|
||||
(test available-width-defaults
|
||||
"available-width returns 0 for components without explicit width"
|
||||
(let ((c (make-box)))
|
||||
(is (= (available-width c) 0))))
|
||||
66
src/components/render.lisp
Normal file
66
src/components/render.lisp
Normal file
@@ -0,0 +1,66 @@
|
||||
(in-package :cl-tui.box)
|
||||
|
||||
;; ── Component Protocol ────────────────────────────────────────
|
||||
|
||||
(defgeneric component-layout-node (component)
|
||||
(:documentation "Return the layout-node for COMPONENT.")
|
||||
(:method ((bx box)) (box-layout-node bx))
|
||||
(:method ((tx text)) (text-layout-node tx)))
|
||||
|
||||
(defgeneric component-children (component)
|
||||
(:documentation "Return the children of COMPONENT, or nil.")
|
||||
(:method ((c t)) nil))
|
||||
|
||||
(defgeneric component-parent (component)
|
||||
(:documentation "Return the parent of COMPONENT, or nil.")
|
||||
(:method ((c t)) nil))
|
||||
|
||||
;; ── Rendering Pipeline ────────────────────────────────────────
|
||||
|
||||
(defgeneric render (component backend)
|
||||
(:documentation "Render COMPONENT at its computed position using BACKEND.")
|
||||
(:method ((c t) backend)
|
||||
(declare (ignore backend))
|
||||
(values)))
|
||||
|
||||
(defmethod render ((bx box) backend)
|
||||
(render-box bx backend))
|
||||
|
||||
(defmethod render ((tx text) backend)
|
||||
(render-text tx backend))
|
||||
|
||||
(defun render-screen (root backend)
|
||||
"Render the component tree ROOT using BACKEND.
|
||||
Computes layout for dirty branches, calls render on each component,
|
||||
and wraps output in synchronized updates."
|
||||
(let ((w (available-width root))
|
||||
(h (available-height root)))
|
||||
(begin-sync backend)
|
||||
(render-node root backend w h)
|
||||
(end-sync backend)))
|
||||
|
||||
(defun render-node (node backend w h)
|
||||
"Render a component NODE and its children."
|
||||
(compute-layout (component-layout-node node) w h)
|
||||
(render node backend)
|
||||
(dolist (child (component-children node))
|
||||
(render-node child backend w h)))
|
||||
|
||||
(defun available-width (component)
|
||||
"Return the available width for COMPONENT (or 80 as default)."
|
||||
(let ((ln (component-layout-node component)))
|
||||
(if ln (layout-node-width ln) 80)))
|
||||
|
||||
(defun available-height (component)
|
||||
"Return the available height for COMPONENT (or 24 as default)."
|
||||
(let ((ln (component-layout-node component)))
|
||||
(if ln (layout-node-height ln) 24)))
|
||||
|
||||
;; ── Dirty Propagation ─────────────────────────────────────────
|
||||
|
||||
(defun propagate-dirty (component)
|
||||
"Mark COMPONENT and all ancestors dirty."
|
||||
(mark-dirty component)
|
||||
(let ((parent (component-parent component)))
|
||||
(when parent
|
||||
(propagate-dirty parent))))
|
||||
163
src/components/text-input.lisp
Normal file
163
src/components/text-input.lisp
Normal file
@@ -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))
|
||||
@@ -18,7 +18,7 @@
|
||||
:underline underline :reverse reverse :dim dim
|
||||
:fg fg :bg bg))
|
||||
|
||||
(defclass text ()
|
||||
(defclass text (dirty-mixin)
|
||||
((layout-node :initform (make-layout-node) :accessor text-layout-node
|
||||
:initarg :layout-node)
|
||||
(content :initform "" :initarg :content :accessor text-content)
|
||||
|
||||
258
src/components/textarea.lisp
Normal file
258
src/components/textarea.lisp
Normal file
@@ -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))
|
||||
61
src/components/theme-tests.lisp
Normal file
61
src/components/theme-tests.lisp
Normal file
@@ -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"))))
|
||||
87
src/components/theme.lisp
Normal file
87
src/components/theme.lisp
Normal file
@@ -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"))
|
||||
Reference in New Issue
Block a user