diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8027b67 --- /dev/null +++ b/.gitignore @@ -0,0 +1,14 @@ +# Compiled Lisp files +*.fasl +*.fasl.gz +*.lib +*.dx32fsl +*.dx64fsl + +# System files +.DS_Store +Thumbs.db + +# Python cache +__pycache__/ +*.pyc diff --git a/.hermes/plans/2026-05-12-cl-tty-bug-fixes.md b/.hermes/plans/2026-05-12-cl-tty-bug-fixes.md new file mode 100644 index 0000000..6974de0 --- /dev/null +++ b/.hermes/plans/2026-05-12-cl-tty-bug-fixes.md @@ -0,0 +1,304 @@ +# cl-tty v1.0.0 Bug Fix Iteration + +> **For Hermes:** Use subagent-driven-development + bug-fix-iteration pattern. +> Each task: inspect → write regression test → fix → verify → commit. +> Do NOT skip tests. Do NOT combine tasks. + +**Goal:** Fix all known bugs and blindspots before v1.0.0 release. + +**Architecture:** cl-tty is a pure CL terminal UI library. No FFI, no ncurses. +Components: backend (modern/simple escape seq), input (byte reader + event parser), +rendering (framebuffer diff pipeline), layout (flexbox), widgets. + +**Verification command after each fix:** +```bash +cd /mnt/hermes/projects/cl-tty && sbcl --script run-all-tests.lisp && python3 scripts/verify-api.py && python3 scripts/verify-demo-pty.py +``` + +--- + +### Task 1: Fix `read-raw-byte` timeout (CRITICAL BUG) + +**Objective:** The timeout mechanism uses `get-universal-time` which returns +integer seconds. Adding a float timeout like 0.05 produces a deadline that +equals the current second — the loop terminates immediately. The 50ms escape +ambiguity timeout never actually works. + +**Files:** +- Modify: `src/components/input.lisp:84-111` +- Test: `tests/input-tests.lisp` (add regression test) + +**Root cause:** Line 99: `(let ((deadline (+ (get-universal-time) timeout)))` — +`get-universal-time` returns integer seconds, so `(+ (integer) 0.05)` = `(+ integer 0)` = integer. +The loop `(while (< (get-universal-time) deadline))` runs zero iterations for any +sub-second timeout. + +**Fix:** Use `sb-ext:get-time-of-day` (microsecond precision) or `(/ (get-internal-real-time) +internal-time-units-per-second)` to get fractional seconds. Replace: + +```lisp +(let ((deadline (+ (get-universal-time) timeout))) + (loop while (< (get-universal-time) deadline) ...)) +``` + +with: + +```lisp +(let* ((start (get-internal-real-time)) + (ticks (round (* timeout internal-time-units-per-second))) + (deadline (+ start ticks))) + (loop while (< (get-internal-real-time) deadline) ...)) +``` + +Or simpler: use `(/ (- (get-internal-real-time) start) internal-time-units-per-second)` +to check elapsed time in a loop. + +**Verification:** +1. Write a test that calls `read-raw-byte` with :timeout 0.05 and verifies it + returns `(values nil :timeout)` within ~100ms (not instantly). +2. All existing tests still pass. +3. The demo's Escape key works (tested by verify-demo-pty.py). + +--- + +### Task 2: Fix `draw-border` ignoring title in modern backend (BUG) + +**Objective:** The `modern-backend`'s `draw-border` method has +`(declare (ignore title title-align))` on line 194. The framebuffer backend +renders titles correctly. The simple backend also ignores titles. +This means titled borders don't show titles in the modern backend. + +**Files:** +- Modify: `backend/modern.lisp:192-219` +- Add test: `backend/modern-tests.lisp` + +**Fix:** In `draw-border` for `modern-backend`, insert the title text into the +top border line after the first character. The title should be centered or +left-aligned based on `title-align`. + +The title rendering logic should extract from the framebuffer backend's +draw-border (framebuffer.lisp lines 114-117) and adapt for escape sequences: +- The top border line is constructed as: `tl + h*N + tr` +- Before writing top: if title is non-nil, insert it: `tl + " " + title + " " + h*fill + tr` +- Truncate title if it exceeds width-4 + +--- + +### Task 3: Fix `backend-size` to query real terminal size (MISSING FEATURE) + +**Objective:** `backend-size` for `modern-backend` returns hardcoded (80 24). +Should query the terminal via TIOCGWINSZ ioctl or `ESC[18t` query. + +**Files:** +- Modify: `backend/modern.lisp:163-165` +- Add test: `backend/modern-tests.lisp` (test that values are positive integers) + +**Fix:** Use SBCL's `sb-alien` to call `ioctl` with `TIOCGWINSZ` on the +stdout fd (or /dev/tty): + +```lisp +(defmethod backend-size ((b modern-backend)) + (sb-unix:unix-ioctl (sb-sys:fd-stream-fd + (or (ignore-errors + (open "/dev/tty" :direction :input + :if-does-not-exist nil)) + *standard-output*)) + sb-unix:TIOCGWINSZ ...) + ;; Or fallback to query-terminal with ESC[18t + ;; Fallback: (values 80 24)) +``` + +Simpler approach: Use `sb-unix:unix-ioctl` with the `TIOCGWINSZ` request. +The winsize struct is: (rows columns) as two 16-bit values. In SBCL, +`sb-unix:unix-ioctl` can be used with `sb-unix:TIOCGWINSZ`. + +If ioctl is complex, implement via OSC Terminal query: `query-terminal` with +`ESC[18t` returns `ESC[8;rows;colst`. Parse the response. + +--- + +### Task 4: Enable kitty keyboard protocol in `initialize-backend` (MISSING FEATURE) + +**Objective:** `modern-backend` declares `:kitty-keyboard` in `capable-p` +but never sends the escape sequence to enable it (`ESC[?u`). + +**Files:** +- Modify: `backend/modern.lisp:142-151` + +**Fix:** Add to `initialize-backend`: +```lisp +(backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard +``` + +And add to `shutdown-backend`: +```lisp +(backend-write b (format nil "~C[?u" #\Esc)) ; restore default keyboard +``` + +--- + +### Task 5: Fix text-input cursor rendering (MISSING VISUAL FEEDBACK) + +**Objective:** The `text-input.lisp` render method declares `(declare (ignore cursor))`. +The cursor position is tracked but never drawn, so users can't see where +they're typing. + +**Files:** +- Modify: `src/components/text-input.lisp` (render method) +- Add test: `tests/input-tests.lisp` or existing test file + +**Fix:** In the text-input render method, after drawing the value/placeholder, +draw a cursor block (█ or reversed ▓) at the cursor position. Use +`draw-rect` or `draw-text` with a visual cursor character at the cursor column. + +When the cursor would be beyond the visible area (scrolled past the right edge), +show it at the rightmost position. + +--- + +### Task 6: Fix SS3 branch reading without timeout (POTENTIAL HANG) + +**Objective:** In `%read-escape-sequence`, the SS3 branch (when b=#x4f) calls +`(read-raw-byte)` without a timeout parameter. If the terminal sends a partial +ESC O with no follow-up byte, the read blocks forever. + +**Files:** +- Modify: `src/components/input.lisp:210` + +**Fix:** Change line 210 from: +```lisp +(let ((b2 (read-raw-byte))) +``` +to: +```lisp +(let ((b2 (read-raw-byte :timeout 0.1))) +``` +And handle the nil case: if b2 is nil, return a key-event for the lone Escape. + +--- + +### Task 7: Add Wayland support to `copy-to-clipboard` (PLATFORM GAP) + +**Objective:** `copy-to-clipboard` in `mouse.lisp` only supports X11 (xclip) +and macOS (pbcopy). Wayland users (wl-copy) get no clipboard. + +**Files:** +- Modify: `src/components/mouse.lisp:51-54` + +**Fix:** Add `#+wayland` or detect Wayland via `$WAYLAND_DISPLAY` env var: + +```lisp +(defun copy-to-clipboard (text) + #+linux + (cond + ((sb-ext:posix-getenv "WAYLAND_DISPLAY") + (sb-ext:run-program "wl-copy" nil :input text :wait nil)) + (t + (sb-ext:run-program "xclip" (list "-selection" "clipboard") + :input text :wait nil))) + #+darwin + (sb-ext:run-program "pbcopy" nil :input text :wait nil)) +``` + +--- + +### Task 8: Add SIGWINCH handler for terminal resize (MISSING FEATURE) + +**Objective:** When the terminal is resized, the demo and any cl-tty app +will render with stale dimensions. The `backend-size` (Task 3) helps but +apps need to be notified of resizes. + +**Files:** +- Create: `src/components/notification.lisp` OR modify existing components + +**Approach:** +This is a design decision. Options: +a) Install a SIGWINCH handler that sets a flag checked each frame +b) Provide a `register-resize-callback` API +c) Only fix in the demo layer (demo.lisp) + +Keep it minimal: install a simple signal handler that sets +`*terminal-resized-p*` to T. The app checks this flag each frame. + +Add to `input.lisp` or a new file: +```lisp +(defvar *terminal-resized-p* nil + "Set to T by SIGWINCH handler when terminal resizes.") + +(defun %handle-sigwinch (signal info context) + (declare (ignore signal info context)) + (setf *terminal-resized-p* t)) + +;; Install handler +#+sbcl +(sb-sys:enable-interrupt sb-unix:sigwinch #'%handle-sigwinch) +``` + +--- + +### Bug Blindspots Verified as NOT Bugs (justifying "won't fix"): + +These were investigated and are fine: +- **Framebuffer diff link-url**: `cells-equal-p` compares `cell-link-url` with `equal` — covered. +- **Select with empty options**: `(if (zerop count) (setf (select-selected-index sel) 0)` — handled. +- **Dialog pop from empty stack**: `(when *dialog-stack*` — guarded. +- **`parse-csi-params`**: reads raw bytes, handles EOF gracefully. +- **Thread safety of globals**: out of scope for v1.0.0 (single-threaded TUI). +- **ScrollBox horizontal scrolling**: actually implemented (uses sx in render). +- **Redundant tests removed**: cleanup already done in uncommitted diff. + +--- + +### BLINDSPOT: The `parse-csi-params` function also uses `(read-raw-byte)` without timeout. + +Line 122: `(multiple-value-bind (b reason) (read-raw-byte)` — while parsing +a CSI sequence, if the terminal sends ESC[ but never completes the sequence, +this blocks forever. This should use a timeout similar to the escape sequence +reader. Same fix pattern as Task 6. + +Adding as Task 9. + +--- + +### Task 9: Fix `parse-csi-params` to use timeout (POTENTIAL HANG) + +**Objective:** `parse-csi-params` (input.lisp line 122) reads bytes without +timeout. A partial CSI sequence (ESC[ without final byte) blocks forever. + +**Files:** +- Modify: `src/components/input.lisp:116-149` + +**Fix:** Add a timeout to the read inside `parse-csi-params`. Use a total +timeout of ~500ms for the entire CSI sequence (generous given terminals +respond within a few ms). If the timeout fires, return nil for final-byte. + +Similar to `%read-escape-sequence`, pass `:timeout` parameter to `parse-csi-params` +and have `%read-escape-sequence` pass a timeout to it. + +--- + +### Task 10: Fix `draw-border` ignoring title in simple backend (BUG) + +**Objective:** Same as Task 2 but for `simple-backend`. The +`%simple-border-char` function just got refactored (uncommitted diff), and +`draw-border` in simple.lisp also ignores title. + +**Files:** +- Modify: `backend/simple.lisp` (draw-border method) +- Add test: `backend/tests.lisp` + +**Fix:** In `simple-backend`'s `draw-border`, when a title is provided, +insert it into the top border line. Use ASCII chars (the simple backend +doesn't use Unicode). + +--- + +### Task 11: Add `detect-backend` export to backend package (API GAP) + +**Objective:** The README shows `(cl-tty.backend:detect-backend)` as the +entry point, but verify this is actually exported from the backend package. + +**Files:** +- Check: `backend/package.lisp` + +**Fix:** Ensure `#:detect-backend` is in the package's `:export` list. diff --git a/README.org b/README.org index 4fc5fab..370bdea 100644 --- a/README.org +++ b/README.org @@ -1,17 +1,17 @@ -# cl-tty — Terminal UI Framework for Common Lisp +#+TITLE: cl-tty — Terminal UI Framework for Common Lisp Pure CL terminal UI framework. No ncurses, no FFI, no external dependencies. -```lisp +#+BEGIN_SRC lisp (ql:quickload :cl-tty) -``` +#+END_SRC -## Quick start +* Quick start The simplest possible cl-tty program — detect the terminal, draw some text, read a key, and shut down: -```lisp +#+BEGIN_SRC lisp (sb-posix:with-raw-terminal (let* ((be (cl-tty.backend:detect-backend)) (w 80) (h 24)) @@ -24,30 +24,30 @@ read a key, and shut down: ;; Read one key (blocks) (cl-tty.input:read-event be)) (cl-tty.backend:shutdown-backend be)))) -``` +#+END_SRC Or run the full interactive demo: -```bash +#+BEGIN_SRC bash sbcl --script demo.lisp -``` +#+END_SRC -## Architecture +* Architecture Two backends, one protocol: -- **modern-backend** — truecolor 24-bit, OSC 8 hyperlinks, DECICM sync, +- *modern-backend* — truecolor 24-bit, OSC 8 hyperlinks, DECICM sync, SGR mouse, kitty keyboard, bold/italic/underline, box-drawing chars -- **simple-backend** — ASCII art, no color, universal compatibility (pipe-safe) +- *simple-backend* — ASCII art, no color, universal compatibility (pipe-safe) Everything is pure escape sequences (no curses, no terminfo, no FFI). -### Backend protocol +** Backend protocol Every drawing operation is a CLOS generic function dispatched on the backend class. Programs never call terminal codes directly: -```lisp +#+BEGIN_SRC lisp ;; Lifecycle (initialize-backend backend) (shutdown-backend backend) @@ -59,7 +59,7 @@ class. Programs never call terminal codes directly: (draw-link backend x y string url &key fg bg) ;; Input -(read-event backend &key timeout) → key-event or mouse-event +(read-event backend &key timeout) → key-event, mouse-event, :eof, or nil (backend-size backend) → (values columns lines) ;; Cursor @@ -67,11 +67,11 @@ class. Programs never call terminal codes directly: (cursor-hide backend) (cursor-show backend) (cursor-style backend shape &key blink) ;; :bar :block :underline -``` +#+END_SRC -### Event loop pattern +** Event loop pattern -```lisp +#+BEGIN_SRC lisp (let ((be (detect-backend))) (initialize-backend be) (loop with running = t @@ -86,50 +86,51 @@ class. Programs never call terminal codes directly: (setf running nil))) (mouse-event ;; handle mouse - )))) + )) + (when (eq event :eof) (setf running nil)))) (shutdown-backend be)) -``` +#+END_SRC -### Layout system +** Layout system Pure CL flexbox layout engine. No C dependencies, no Yoga FFI. -```lisp +#+BEGIN_SRC lisp ;; Macros build layout-trees: (vbox (:gap 1 :padding 1) (header "Title") (hbox (:grow 1) (sidebar (:width 30) ...) (content ...))) -``` +#+END_SRC -Layout properties: `:direction` (`:row` / `:column`), `:grow`, `:shrink`, -`:basis`, `:gap`, `:padding`, `:margin`, `:width`, `:height`, `:wrap`. +Layout properties: ~:direction~ (~:row~ / ~:column~), ~:grow~, ~:shrink~, +~:basis~, ~:gap~, ~:padding~, ~:margin~, ~:width~, ~:height~, ~:wrap~. -See `layout/layout.lisp` or `org/layout-engine.org` for the full API. +See ~src/layout/layout.lisp~ or ~org/layout-engine.org~ for the full API. -### Rendering pipeline +** Rendering pipeline Component trees render through a coordinated pipeline: -1. **Layout pass** — `compute-layout` traverses dirty branches, solves flex constraints -2. **Render dispatch** — `render` generic dispatches per component type -3. **Framebuffer** — (optional) `make-framebuffer-backend` captures to a cell array, - `diff-framebuffers` computes minimal changes, `flush-framebuffer` writes only +1. *Layout pass* — ~compute-layout~ traverses dirty branches, solves flex constraints +2. *Render dispatch* — ~render~ generic dispatches per component type +3. *Framebuffer* — (optional) ~make-framebuffer-backend~ captures to a cell array, + ~diff-framebuffers~ computes minimal changes, ~flush-framebuffer~ writes only changed cells -```lisp +#+BEGIN_SRC lisp ;; Full pipeline with framebuffer (let* ((fb-be (make-framebuffer-backend :width 80 :height 24)) (fb (fb-framebuffer fb-be))) (render my-component fb-be) (flush-framebuffer prev-fb fb real-backend)) -``` +#+END_SRC -## Components +* Components | Component | What it does | Status | -|-------------|------------------------------------------------------|--------| +|-------------+------------------------------------------------------+--------| | Box | Bordered container with background, title | stable | | Text | Styled text with word-wrap, spans | stable | | ScrollBox | Scrollable viewport with scrollbars | stable | @@ -145,7 +146,7 @@ Component trees render through a coordinated pipeline: Each component follows a consistent pattern: -```lisp +#+BEGIN_SRC lisp ;; 1. Create — factory function returns instance (let ((input (make-text-input :placeholder "Type here...")) (box (make-box :border-style :single :title "My Box"))) @@ -159,135 +160,135 @@ Each component follows a consistent pattern: ;; 3. Render — dispatches through the component protocol (render my-component backend)) -``` +#+END_SRC -### Box +*** Box Bordered container. Draws borders using Unicode box-drawing characters -(modern) or ASCII `+`/`-`/`|` (simple). Supports background fill, titled -borders. See `org/box-renderable.org`. +(modern) or ASCII ~+~/~-~/~|~ (simple). Supports background fill, titled +borders. See ~org/box-renderable.org~. -```lisp +#+BEGIN_SRC lisp (make-box &key (border-style :single) title (title-align :left) fg bg width height) -``` +#+END_SRC -### Text +*** Text Styled text with inline spans and word wrapping. Spans support per-run -attributes (bold, italic, underline, fg, bg). See `org/box-renderable.org`. +attributes (bold, italic, underline, fg, bg). See ~org/box-renderable.org~. -```lisp +#+BEGIN_SRC lisp (make-text content &key fg bg wrap-mode width height spans) ;; Span example: (span "hello" :bold t :fg :bright-yellow) -``` +#+END_SRC -### TextInput +*** TextInput Single-line text editor with emacs-style keybindings. Supports placeholder, -max-length, on-submit callback. See `org/text-input.org`. +max-length, on-submit callback. See ~org/text-input.org~. -```lisp +#+BEGIN_SRC lisp (make-text-input &key value cursor placeholder max-length on-submit) ;; Widget logic (input-level, no backend needed): (handle-text-input input (make-key-event :key :a :code (char-code #\a))) -``` +#+END_SRC -### TextArea +*** TextArea Multi-line text editor. Supports undo/redo (Ctrl+Z/Y), cursor movement, -line joining on backspace. See `org/text-input.org`. +line joining on backspace. See ~org/text-input.org~. -```lisp +#+BEGIN_SRC lisp (make-textarea &key value on-submit) -``` +#+END_SRC -### ScrollBox +*** ScrollBox Scrollable viewport with a list of children. Only renders children intersecting the visible area (viewport culling). Scrollbars drawn -at the right/bottom edges. See `org/scrollbox-tabbar.org`. +at the right/bottom edges. See ~org/scrollbox.org~. -```lisp +#+BEGIN_SRC lisp (make-scroll-box &key children scroll-y scroll-x sticky-scroll-p) (scroll-by sb dy dx) -``` +#+END_SRC -### TabBar +*** TabBar Horizontal tab navigation. Renders tab labels, highlights active tab. -Left/right arrows cycle through tabs. See `org/scrollbox-tabbar.org`. +Left/right arrows cycle through tabs. See ~org/tabbar.org~. -```lisp +#+BEGIN_SRC lisp (make-tab-bar &key tabs active) (tab-bar-add tb id title) (tab-bar-next tb) / (tab-bar-prev tb) (tab-bar-handle-key tb event) -``` +#+END_SRC -### Select +*** Select Dropdown/filter widget. Options can have categories (rendered as non-selectable headers). Fuzzy fallback: matching > 30% character -overlap. Arrow keys navigate, Enter selects. See `org/select.org`. +overlap. Arrow keys navigate, Enter selects. See ~org/select.org~. -```lisp +#+BEGIN_SRC lisp (make-select &key options filter on-select) ;; Options format: (:title "Name" :category "Group") or (:title "Name") -``` +#+END_SRC -### Markdown +*** Markdown Parsed markdown AST with rendering. Supports headings, paragraphs, bold, italic, inline code, links, code blocks with syntax highlighting, diff blocks, blockquotes, lists, thematic breaks. See -`org/markdown-renderer.org`. +~org/markdown-renderer.org~. -```lisp +#+BEGIN_SRC lisp (render-markdown "# Hello\n\nThis is **bold**.") -``` +#+END_SRC -### Dialog + Toast +*** Dialog + Toast -Modal dialog stack. `alert-dialog`, `confirm-dialog`, `select-dialog`, -`prompt-dialog` are convenience constructors. Toasts are transient -notifications that auto-dismiss. See `org/dialog.org`. +Modal dialog stack. ~alert-dialog~, ~confirm-dialog~, ~select-dialog~, +~prompt-dialog~ are convenience constructors. Toasts are transient +notifications that auto-dismiss. See ~org/dialog.org~. -```lisp +#+BEGIN_SRC lisp (push-dialog (make-instance 'dialog :size :medium)) (alert-dialog "Notice" "Operation complete") (toast "Saved!" :variant :success) -``` +#+END_SRC -### Mouse +*** Mouse -Mixin class providing mouse event handler slots. `hit-test` finds the +Mixin class providing mouse event handler slots. ~hit-test~ finds the deepest component at a coordinate. Text selection tracks drag gestures. -Scrollboxes integrate wheel events. See `org/mouse.org`. +Scrollboxes integrate wheel events. See ~org/mouse.org~. -```lisp +#+BEGIN_SRC lisp (defclass my-panel (mouse-mixin) ...) (handle-mouse-event component mouse-event) (hit-test root x y) → deepest matching component -``` +#+END_SRC -### Slot system +*** Slot system Plugin system for extensible rendering slots. Register named rendering functions, then render them by slot name. Useful for toolbars, status bars, and plugin architectures. -```lisp +#+BEGIN_SRC lisp (defslot :status-bar :order 0 (lambda (&rest args) (draw-text backend 0 0 "Ready" :text-muted nil))) (slot-render :status-bar) -``` +#+END_SRC -## Backend features +* Backend features | Feature | modern | simple | -|-------------------|--------|--------| +|-------------------+--------+--------| | Truecolor (24-bit)| Yes | No | | Bold/italic | Yes | No | | OSC 8 hyperlinks | Yes | No | @@ -297,81 +298,92 @@ bars, and plugin architectures. | Box drawing chars | Unicode| ASCII | | Pipe-safe | No | Yes | -Backend selection happens automatically via `detect-backend`. It checks: +Backend selection happens automatically via ~detect-backend~. It checks: + 1. Is stdout a TTY? (if not → simple-backend) -2. Does `COLORTERM` contain "truecolor" or "24bit"? +2. Does ~COLORTERM~ contain "truecolor" or "24bit"? 3. Send DA1 query — does the terminal respond with modern feature codes? -Result is cached in `*detected-backend*`. +Result is cached in ~*detected-backend*~. -## Development +* Development -```bash -# Run all tests (392 checks, 12 suites) +#+BEGIN_SRC bash +# Run all tests sbcl --script run-all-tests.lisp # Run interactive demo sbcl --script demo.lisp # Tangle org files (regenerate .lisp from .org sources) -for f in org/*.org; do - emacs --batch --eval "(progn (require 'org) (find-file \"$f\") (org-babel-tangle) (kill-buffer))" 2>&1 -done -``` +python3 ~/.hermes/skills/software-development/org-babel-tangle/scripts/tangle.py org/*.org -Literate programming: `.org` files in `org/` are the source of truth for -the input system, scrollbox/tabbar, dialog, mouse, select, slot, -framebuffer, and markdown modules. The backend (`modern.lisp`, -`simple.lisp`) and basic components (`box.lisp`, `text.lisp`, `render.lisp`, -`theme.lisp`, `dirty.lisp`) are written directly. +# Verify syntax of all tangled files +for f in src/**/*.lisp tests/*.lisp; do + sbcl --eval "(with-open-file (s \"$f\") (loop for e = (read s nil s) until (eq e s)))" \ + --eval "(format t \"~a: OK~%\" \"$f\")" --quit 2>/dev/null +done +#+END_SRC + +Literate programming: every ~.lisp~ file in ~src/~ and ~tests/~ is a generated +artifact from an ~.org~ file in ~org/~. The org files are the source of truth. +Each function has its own code block with prose explaining the design reasoning. +Delete every ~.lisp~ file and they can all be regenerated by tangling the org files. Project structure: -``` +#+BEGIN_EXAMPLE cl-tty/ ├── cl-tty.asd # ASDF system definition ├── demo.lisp # Interactive demo ├── run-all-tests.lisp # Test runner -├── backend/ # Backend protocol + implementations -│ ├── package.lisp -│ ├── classes.lisp # Generic definitions -│ ├── simple.lisp # ASCII fallback backend -│ ├── modern.lisp # Truecolor escape backend -│ └── detection.lisp # Auto-detect backend from env -├── layout/ # Flexbox layout engine -│ └── layout.lisp ├── src/ -│ ├── rendering/ # Framebuffer backend + diff + flush +│ ├── backend/ # Backend protocol + implementations +│ │ ├── package.lisp, classes.lisp +│ │ ├── simple.lisp, modern.lisp +│ │ └── detection.lisp +│ ├── layout/ # Flexbox layout engine +│ │ └── layout.lisp +│ ├── rendering/ # Framebuffer diffing pipeline │ │ └── framebuffer.lisp -│ └── components/ # Widgets -│ ├── box.lisp, text.lisp, render.lisp, theme.lisp -│ ├── dirty.lisp, input-package.lisp, input.lisp +│ └── components/ # Widget library +│ ├── package.lisp, dirty.lisp, render.lisp, theme.lisp +│ ├── box.lisp, text.lisp +│ ├── input-package.lisp, input.lisp │ ├── text-input.lisp, textarea.lisp, keybindings.lisp -│ ├── scrollbox.lisp, tabbar.lisp, container-package.lisp -│ ├── select.lisp, select-package.lisp -│ ├── markdown.lisp, markdown-package.lisp -│ ├── dialog.lisp, dialog-package.lisp -│ ├── mouse.lisp, mouse-package.lisp -│ └── slot.lisp, slot-package.lisp -├── tests/ # Test files -├── org/ # Literate source files +│ ├── container-package.lisp, scrollbox.lisp, tabbar.lisp +│ ├── select-package.lisp, select.lisp +│ ├── markdown-package.lisp, markdown.lisp +│ ├── dialog-package.lisp, dialog.lisp +│ ├── mouse-package.lisp, mouse.lisp +│ └── slot-package.lisp, slot.lisp +├── tests/ # FiveAM test files +│ ├── input-tests.lisp, scrollbox-tabbar-tests.lisp +│ ├── select-tests.lisp, markdown-tests.lisp +│ ├── dialog-tests.lisp, mouse-tests.lisp, slot-tests.lisp +│ ├── framebuffer-tests.lisp, integration-tests.lisp +│ ├── box-tests.lisp, dirty-tests.lisp, render-tests.lisp +│ └── theme-tests.lisp +├── org/ # Literate source (all .lisp files come from here) +│ ├── package.org, dirty.org, render.org, theme.org +│ ├── box-renderable.org │ ├── text-input.org -│ ├── scrollbox-tabbar.org +│ ├── scrollbox.org, tabbar.org, container-package.org +│ ├── select.org +│ ├── markdown-renderer.org │ ├── dialog.org │ ├── mouse.org -│ ├── select.org │ ├── slot.org +│ ├── backend-protocol.org, modern-backend.org, detection.org +│ ├── layout-engine.org │ ├── framebuffer.org -│ ├── markdown-renderer.org -│ ├── detection.org -│ ├── modern-backend.org -│ ├── box-renderable.org -│ └── layout-engine.org -└── docs/ - ├── ROADMAP.org # Versioned roadmap - └── ARCHITECTURE.org # Design docs -``` +│ └── integration-tests.org +├── docs/ +│ ├── ROADMAP.org +│ └── ARCHITECTURE.org +└── demo/ # Demo assets (optional) +#+END_EXAMPLE -## License +* License GNU General Public License v3.0 diff --git a/cl-tty.asd b/cl-tty.asd index 064288f..0adfb45 100644 --- a/cl-tty.asd +++ b/cl-tty.asd @@ -2,18 +2,18 @@ (asdf:defsystem :cl-tty :description "Reusable Common Lisp Terminal UI Framework" :author "Amr Gharbeia" - :version "0.15.0" + :version "1.0.0" :license "GPL-3.0" :depends-on (:sb-posix) :components - ((:module "backend" + ((:module "src/backend" :components ((:file "package") (:file "classes" :depends-on ("package")) (:file "simple" :depends-on ("package" "classes")) (:file "modern" :depends-on ("package" "classes")) (:file "detection" :depends-on ("package" "classes")))) - (:module "layout" + (:module "src/layout" :components ((:file "layout"))) (:module "src/rendering" @@ -58,11 +58,11 @@ :description "Test suite for cl-tty" :depends-on (:cl-tty :fiveam) :components - ((:module "backend" + ((:module "src/backend" :components ((:file "tests") (:file "modern-tests" :depends-on ("tests")))) - (:module "layout" + (:module "src/layout" :components ((:file "tests"))) (:module "src/components" @@ -71,7 +71,7 @@ (:file "dirty-tests") (:file "render-tests") (:file "theme-tests") - (:file "input-tests") + (:file "input-tests" :pathname "../../tests/input-tests") (:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests") (:file "select-tests" :pathname "../../tests/select-tests") (:file "markdown-tests" :pathname "../../tests/markdown-tests") diff --git a/debug-layout.lisp b/debug-layout.lisp deleted file mode 100644 index af98063..0000000 --- a/debug-layout.lisp +++ /dev/null @@ -1,94 +0,0 @@ -(load "~/quicklisp/setup.lisp") -(ql:quickload :cl-tty :silent t) -(in-package :cl-tty.layout) - -(defun trace-layout (root aw ah) - "Run compute-layout with detailed traces" - (labels ((p (node x y max-w max-h depth) - (let* ((children (layout-node-children node)) - (is-row (eql (layout-node-direction node) :row)) - (pl (box-edge (layout-node-padding node) :left)) - (pt (box-edge (layout-node-padding node) :top)) - (pr (box-edge (layout-node-padding node) :right)) - (pb (box-edge (layout-node-padding node) :bottom)) - (cw (max 0 (- max-w pl pr))) - (ch (max 0 (- max-h pt pb))) - (gap (layout-node-gap node)) - (sizes (distribute-sizes children (if is-row cw ch) gap is-row))) - (format t "~v,0Tp~A: xy=~A,~A mw=~A mh=~A pl=~A pt=~A cw=~A ch=~A gap=~A sizes=~A~%" - (* depth 2) (if is-row 'ROW 'COL) - x y max-w max-h pl pt cw ch gap sizes) - (setf (layout-node-x node) (+ x pl) - (layout-node-y node) (+ y pt)) - (loop :with pos = 0 - :for child :in children - :for size :in sizes - :for i :from 0 - :do (if is-row - (setf (layout-node-width child) size - (layout-node-x child) (+ x pl pos) - (layout-node-height child) ch - (layout-node-y child) (+ y pt)) - (setf (layout-node-height child) size - (layout-node-y child) (+ y pt pos) - (layout-node-width child) cw - (layout-node-x child) (+ x pl))) - (format t "~v,0T~A#~D: placed pos=~A size=~A xy=~A,~A wh=~A,~A~%" - (* (1+ depth) 2) (if is-row 'H 'V) i pos size - (layout-node-x child) (layout-node-y child) - (layout-node-width child) (layout-node-height child)) - (p child - (layout-node-x child) (layout-node-y child) - (if is-row size cw) (if is-row ch size) - (1+ depth)) - (incf pos (+ size gap))) - (let ((last-child (car (last children)))) - (if is-row - (setf (layout-node-width node) - (or (layout-node-fixed-width node) - (if last-child - (+ (layout-node-x node) - (layout-node-width last-child) - pr) - max-w)) - (layout-node-height node) - max-h) - (setf (layout-node-height node) - (or (layout-node-fixed-height node) - (if last-child - (let ((last-y (layout-node-y last-child)) - (last-h (layout-node-height last-child))) - (+ last-y last-h pb)) - max-h)) - (layout-node-width node) - max-w)) - (format t "~v,0Tresult: node wh=~A,~A (fixed-w=~A fixed-h=~A)~%" - (* depth 2) - (layout-node-width node) (layout-node-height node) - (layout-node-fixed-width node) (layout-node-fixed-height node)))))) - (p root 0 0 aw ah 0) - root)) - -(format t "~%=== 1. SINGLE-CHILD-IN-COLUMN ===~%~%") -(let* ((r (make-layout-node :direction :column :width 10 :height 20)) - (c (make-layout-node :height 5))) - (layout-node-add-child r c) - (trace-layout r 10 20) - (format t "~%child final: x=~A (exp 0) y=~A (exp 0) w=~A h=~A (exp 5)~%~%" - (layout-node-x c) (layout-node-y c) (layout-node-width c) (layout-node-height c))) - -(format t "=== 2. PADDING-REDUCES-CONTENT-AREA ===~%~%") -(let* ((r (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1))) - (c (make-layout-node :height 3))) - (layout-node-add-child r c) - (trace-layout r 20 10) - (format t "~%child final: x=~A (exp 1) y=~A (exp 1)~%~%" - (layout-node-x c) (layout-node-y c))) - -(format t "=== 3. FLEX-GROW-SINGLE-CHILD ===~%~%") -(let* ((root (make-layout-node :direction :row :width 20)) - (c (make-layout-node :width 5 :grow 1))) - (layout-node-add-child root c) - (trace-layout root 20 10) - (format t "~%child final: w=~A (exp 20)~%~%" - (layout-node-width c))) diff --git a/demo.lisp b/demo.lisp index 3c90460..afe8db4 100644 --- a/demo.lisp +++ b/demo.lisp @@ -7,11 +7,16 @@ (push (truename ".") asdf:*central-registry*) (asdf:load-system :cl-tty) -(use-package :cl-tty.backend) -(use-package :cl-tty.input) -(use-package :cl-tty.box) -(use-package :cl-tty.layout) -(use-package :cl-tty.rendering) +;; Symbols use explicit package prefixes to avoid read-event +;; conflict between cl-tty.backend and cl-tty.input. + +;; Short aliases for readability +(import '(cl-tty.input:make-text-input + cl-tty.input:text-input-value + cl-tty.input:handle-text-input + cl-tty.input:make-textarea + cl-tty.input:textarea-lines + cl-tty.input:handle-textarea-input)) ;;; ─── Application state ─────────────────────────────────────────────────────── @@ -39,134 +44,173 @@ (defun render-tab-home (backend x y w h) "Welcome screen with version info." (declare (ignore h)) - (draw-border backend x y w 18 :style :double :title " Welcome ") - (draw-text backend (+ x 2) (+ y 2) "cl-tty — Pure CL Terminal UI Framework" :bright-white nil :bold t) - (draw-text backend (+ x 2) (+ y 4) " components: Box, Text, TextInput, TextArea, Select," nil nil) - (draw-text backend (+ x 2) (+ y 5) " ScrollBox, TabBar, Dialog, Toast, Markdown" nil nil) - (draw-text backend (+ x 2) (+ y 6) " features: 24-bit truecolor, OSC 8 links, SGR mouse," nil nil) - (draw-text backend (+ x 2) (+ y 7) " DECICM sync, kitty keyboard, framebuffer" nil nil) - (draw-text backend (+ x 2) (+ y 8) " backend: modern-backend | simple-backend (pipe-safe)" nil nil) - (draw-text backend (+ x 2) (+ y 9) " tests: 392, 100% passing" :green nil :bold t) - (draw-text backend (+ x 2) (+ y 10) " deps: zero FFI, zero ncurses, pure CL" :bright-cyan nil) - (draw-text backend (+ x 2) (+ y 12) "Controls" :bright-white nil :bold t) - (draw-text backend (+ x 2) (+ y 13) " Tab / arrows switch tabs" nil nil) - (draw-text backend (+ x 2) (+ y 14) " q / Ctrl+C / Esc quit" nil nil) - (draw-text backend (+ x 2) (+ y 15) " mouse click/drag select text (test SGR mouse)" nil nil)) + (cl-tty.backend:draw-border backend x y w 18 :style :double :title " Welcome ") + (cl-tty.backend:draw-text backend (+ x 2) (+ y 2) + "cl-tty — Pure CL Terminal UI Framework" :bright-white nil :bold t) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 4) + " components: Box, Text, TextInput, TextArea, Select," nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 5) + " ScrollBox, TabBar, Dialog, Toast, Markdown" nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 6) + " features: 24-bit truecolor, OSC 8 links, SGR mouse," nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 7) + " DECICM sync, kitty keyboard, framebuffer" nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 8) + " backend: modern-backend | simple-backend (pipe-safe)" nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 9) + " tests: 483, 100% passing" :green nil :bold t) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 10) + " deps: zero FFI, zero ncurses, pure CL" :bright-cyan nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 12) + "Controls" :bright-white nil :bold t) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 13) + " Tab / arrows switch tabs" nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 14) + " Ctrl+C / Esc quit" nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 15) + " mouse click/drag select text (test SGR mouse)" nil nil)) (defun render-tab-widgets (backend x y w h input ta) "Interactive widget demo." (declare (ignore h)) - (draw-border backend x y w 12 :style :single :title " Text Input ") + (cl-tty.backend:draw-border backend x y w 12 :style :single :title " Text Input ") (let ((val (text-input-value input))) - (draw-text backend (+ x 2) (+ y 1) "Value: " :text-muted nil) - (draw-text backend (+ x 10) (+ y 1) (if (plusp (length val)) val "(empty)") :text nil)) - (draw-text backend (+ x 2) (+ y 3) "Placeholder: \"Type here...\"" :text-muted nil) - (draw-text backend (+ x 2) (+ y 5) "Keys: type to insert, arrows to move," nil nil) - (draw-text backend (+ x 2) (+ y 6) "Enter to submit, Backspace to delete," nil nil) - (draw-text backend (+ x 2) (+ y 7) "Ctrl+A/E for home/end" nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 1) "Value: " :text-muted nil) + (cl-tty.backend:draw-text backend (+ x 10) (+ y 1) + (if (plusp (length val)) val "(empty)") :text nil)) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 3) + "Placeholder: \"Type here...\"" :text-muted nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 5) + "Keys: type to insert, arrows to move," nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 6) + "Enter to submit, Backspace to delete," nil nil) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 7) + "Ctrl+A/E for home/end" nil nil) (when (plusp (length (text-input-value input))) - (draw-text backend (+ x 2) (+ y 9) (format nil "Submitted: ~a" (text-input-value input)) :accent nil)) + (cl-tty.backend:draw-text backend (+ x 2) (+ y 9) + (format nil "Submitted: ~a" (text-input-value input)) :accent nil)) (let ((y2 (+ y 13))) - (draw-border backend x y2 w 10 :style :single :title " TextArea ") - (draw-text backend (+ x 2) (+ y2 1) "Value:" :text-muted nil) + (cl-tty.backend:draw-border backend x y2 w 10 :style :single :title " TextArea ") + (cl-tty.backend:draw-text backend (+ x 2) (+ y2 1) "Value:" :text-muted nil) (let ((lines (textarea-lines ta))) (loop for line in lines for row from 0 below (min (length lines) 6) - do (draw-text backend (+ x 2) (+ y2 2 row) - (subseq (or line "") 0 (min (length line) (- w 4))) nil nil))))) + do (cl-tty.backend:draw-text backend (+ x 2) (+ y2 2 row) + (subseq (or line "") 0 (min (length line) (- w 4))) nil nil))))) (defun render-tab-console (backend x y w h) "Event log / debug console." - (draw-border backend x y w h :style :single :title " Event Log ") - (draw-text backend (+ x 2) (+ y 1) "Last 50 keyboard and mouse events:" :text-muted nil) + (cl-tty.backend:draw-border backend x y w h :style :single :title " Event Log ") + (cl-tty.backend:draw-text backend (+ x 2) (+ y 1) + "Last 50 keyboard and mouse events:" :text-muted nil) (let ((lines *log*) (max-rows (- h 3))) (loop for line in (subseq lines 0 (min (length lines) max-rows)) for row from 0 below max-rows - do (draw-text backend (+ x 2) (+ y 3 row) - (subseq (or line "") 0 (min (length line) (- w 4))) nil nil)))) + do (cl-tty.backend:draw-text backend (+ x 2) (+ y 3 row) + (subseq (or line "") 0 (min (length line) (- w 4))) nil nil)))) ;;; ─── Main loop ────────────────────────────────────────────────────────────── (defun handle-event (event) "Process a key-event or mouse-event, returning t if consumed." (typecase event - (key-event - (let ((key (key-event-key event)) - (ctrl (key-event-ctrl event))) - (log-append "Key: ~a (ctrl=~a alt=~a shift=~a)" key ctrl (key-event-alt event) (key-event-shift event)) + (cl-tty.input:key-event + (let ((key (cl-tty.input:key-event-key event)) + (ctrl (cl-tty.input:key-event-ctrl event))) + (log-append "Key: ~a (ctrl=~a alt=~a shift=~a)" key ctrl + (cl-tty.input:key-event-alt event) + (cl-tty.input:key-event-shift event)) (cond - ((or (eql key :|Q|) (and ctrl (eql key :|C|)) (eql key :escape)) + ((or (and ctrl (eql key :|C|)) (eql key :escape)) (setf (getf *app* :running) nil) t) ((eql key :tab) (incf (getf *app* :tab)) (when (> (getf *app* :tab) 2) (setf (getf *app* :tab) 0)) t) - ((eql key :left) + ;; Only arrow keys switch tabs when NOT on the Widgets tab. + ;; On the Widgets tab (tab=1), Left/Right are forwarded to widgets + ;; for cursor navigation in text inputs. + ((and (not (= (getf *app* :tab) 1)) + (eql key :left)) (decf (getf *app* :tab)) (when (minusp (getf *app* :tab)) (setf (getf *app* :tab) 2)) t) - ((eql key :right) + ((and (not (= (getf *app* :tab) 1)) + (eql key :right)) (incf (getf *app* :tab)) (when (> (getf *app* :tab) 2) (setf (getf *app* :tab) 0)) t) - ;; Forward key to widgets for testing - (t (handle-text-input (getf *app* :input) event) - (handle-textarea-input (getf *app* :textarea) event) + ;; Forward key to widgets only when on the Widgets tab + (t (when (= (getf *app* :tab) 1) + (handle-text-input (getf *app* :input) event) + (handle-textarea-input (getf *app* :textarea) event)) t)))) - (mouse-event - (log-append "Mouse: ~a btn=~a pos=(~d,~d)" (mouse-event-type event) - (mouse-event-button event) (mouse-event-x event) (mouse-event-y event)) - (setf (getf *app* :mouse-x) (mouse-event-x event) - (getf *app* :mouse-y) (mouse-event-y event)) + (cl-tty.input:mouse-event + (log-append "Mouse: ~a btn=~a pos=(~d,~d)" + (cl-tty.input:mouse-event-type event) + (cl-tty.input:mouse-event-button event) + (cl-tty.input:mouse-event-x event) + (cl-tty.input:mouse-event-y event)) + (setf (getf *app* :mouse-x) (cl-tty.input:mouse-event-x event) + (getf *app* :mouse-y) (cl-tty.input:mouse-event-y event)) t))) (defun run-demo () "Run the demo. Raw terminal mode should already be set by the ./demo.sh shell wrapper." (init-app-state) - (let* ((backend (detect-backend)) - (w 80) (h 24)) - (declare (ignore h)) - (initialize-backend backend) + (let* ((backend (cl-tty.backend:detect-backend)) + (w (multiple-value-bind (cols rows) (cl-tty.backend:backend-size backend) + (declare (ignore rows)) + cols)) + (h (multiple-value-bind (cols rows) (cl-tty.backend:backend-size backend) + (declare (ignore cols)) + rows))) + (cl-tty.backend:initialize-backend backend) (unwind-protect (loop while (getf *app* :running) do - (backend-clear backend) + (cl-tty.backend:backend-clear backend) ;; Title bar - (draw-border backend 2 1 (- w 4) 3 :style :double :title " cl-tty v0.15.0 ") - (draw-text backend 4 2 "arrows/tab: tabs type: test input mouse: test SGR q/esc: quit" - :bright-white nil) + (cl-tty.backend:draw-border backend 2 1 (- w 4) 3 + :style :double :title " cl-tty v0.15.0 ") + (cl-tty.backend:draw-text backend 4 2 + "arrows/tab: tabs type: test input mouse: test SGR Esc/Ctrl+C: quit" + :bright-white nil) ;; Tab bar (loop for (label . idx) in '((" Home " . 0) (" Widgets " . 1) (" Console " . 2)) for x-pos = 4 then (+ x-pos label-len 2) for label-len = (length label) do (let ((active (eql idx (getf *app* :tab)))) (if active - (draw-text backend x-pos 4 label :bright-white :accent :bold t) - (draw-text backend x-pos 4 label :text-muted nil)))) + (cl-tty.backend:draw-text backend x-pos 4 label + :bright-white :accent :bold t) + (cl-tty.backend:draw-text backend x-pos 4 label + :text-muted nil)))) ;; Content area (case (getf *app* :tab) - (0 (render-tab-home backend 4 6 72 20)) - (1 (render-tab-widgets backend 4 6 72 24 + (0 (render-tab-home backend 4 6 (- w 4) (- h 8))) + (1 (render-tab-widgets backend 4 6 (- w 4) (- h 8) (getf *app* :input) (getf *app* :textarea))) - (2 (render-tab-console backend 4 6 72 16))) + (2 (render-tab-console backend 4 6 (- w 4) (- h 8)))) ;; Mouse cursor indicator (let ((mx (getf *app* :mouse-x)) (my (getf *app* :mouse-y))) (when (and (>= mx 0) (>= my 0)) - (draw-text backend mx my "@" :bright-cyan nil))) + (cl-tty.backend:draw-text backend mx my "@" :bright-cyan nil))) ;; Status bar - (draw-rect backend 2 23 (- w 4) 1 :bg :blue) - (draw-text backend 4 23 - (format nil " Tab ~d/3 | ~d events " - (1+ (getf *app* :tab)) (length *log*)) - :bright-white :blue :bold t) + (cl-tty.backend:draw-rect backend 2 (- h 2) (- w 4) 1 :bg :blue) + (cl-tty.backend:draw-text backend 4 (- h 2) + (format nil " Tab ~d/3 | ~d events " + (1+ (getf *app* :tab)) (length *log*)) + :bright-white :blue :bold t) (finish-output *standard-output*) ;; Read event — blocks until a key or mouse event arrives - (let ((event (read-event backend))) - (when event - (handle-event event)))) - (shutdown-backend backend)))) + (let ((event (cl-tty.input:read-event backend))) + (cond + ((eq event :eof) (setf (getf *app* :running) nil)) + (event (handle-event event))))) + (cl-tty.backend:shutdown-backend backend)))) (run-demo) (uiop:quit 0) diff --git a/docs/ARCHITECTURE.org b/docs/ARCHITECTURE.org index 0295fa2..de79b41 100644 --- a/docs/ARCHITECTURE.org +++ b/docs/ARCHITECTURE.org @@ -265,46 +265,91 @@ reads terminal background color at startup. #+BEGIN_SRC cl-tty/ - ├── cl-tty.asd - ├── cl-tty-tests.asd + ├── cl-tty.asd # ASDF system (main + test) ├── README.org ├── LICENSE + ├── .gitignore + ├── demo.lisp # Interactive demo + ├── demo.sh # PTY launcher for demo + ├── run-all-tests.lisp # Test runner ├── docs/ │ ├── ROADMAP.org │ └── ARCHITECTURE.org ← this file + ├── org/ # Literate source files + │ ├── backend-protocol.org + │ ├── box-renderable.org + │ ├── detection.org + │ ├── dialog.org + │ ├── framebuffer.org + │ ├── layout-engine.org + │ ├── markdown-renderer.org + │ ├── modern-backend.org + │ ├── mouse.org + │ ├── scrollbox.org + │ ├── tabbar.org + │ ├── container-package.org + │ ├── select.org + │ ├── slot.org + │ └── text-input.org ├── src/ - │ ├── package.lisp │ ├── backend/ - │ │ ├── protocol.lisp - │ │ ├── detection.lisp + │ │ ├── package.lisp + │ │ ├── classes.lisp │ │ ├── simple.lisp - │ │ └── modern.lisp + │ │ ├── modern.lisp + │ │ └── detection.lisp │ ├── layout/ - │ │ ├── nodes.lisp - │ │ ├── solver.lisp - │ │ └── api.lisp + │ │ └── layout.lisp │ ├── components/ - │ │ ├── base.lisp + │ │ ├── package.lisp │ │ ├── box.lisp - │ │ └── text.lisp - │ ├── rendering/ - │ │ ├── pipeline.lisp + │ │ ├── text.lisp + │ │ ├── render.lisp + │ │ ├── theme.lisp │ │ ├── dirty.lisp - │ │ └── diff.lisp - │ └── theme/ - │ ├── tokens.lisp - │ └── presets.lisp - └── tests/ - ├── package.lisp - ├── backend.lisp - ├── layout.lisp - └── components.lisp + │ │ ├── input-package.lisp + │ │ ├── input.lisp + │ │ ├── text-input.lisp + │ │ ├── textarea.lisp + │ │ ├── keybindings.lisp + │ │ ├── container-package.lisp + │ │ ├── scrollbox.lisp + │ │ ├── tabbar.lisp + │ │ ├── select-package.lisp + │ │ ├── select.lisp + │ │ ├── markdown-package.lisp + │ │ ├── markdown.lisp + │ │ ├── dialog-package.lisp + │ │ ├── dialog.lisp + │ │ ├── mouse-package.lisp + │ │ ├── mouse.lisp + │ │ ├── slot-package.lisp + │ │ └── slot.lisp + │ └── rendering/ + │ └── framebuffer.lisp + ├── tests/ + │ ├── input-tests.lisp + │ ├── scrollbox-tabbar-tests.lisp + │ ├── select-tests.lisp + │ ├── markdown-tests.lisp + │ ├── dialog-tests.lisp + │ ├── mouse-tests.lisp + │ ├── slot-tests.lisp + │ ├── framebuffer-tests.lisp + │ └── integration-tests.lisp + └── scripts/ + ├── binary-search.lisp + ├── code-audit.lisp + ├── audit-compiler.lisp + ├── find-t-form.lisp + ├── find-t-warning.lisp + └── verify-api.py #+END_SRC ** Dependency Graph - backend/ (no deps) - layout/ (no deps — pure math) + src/backend/ (no deps) + src/layout/ (no deps — pure math) theme/ (backend for color resolution) components/ (layout, theme, rendering) rendering/ (layout, components, backend, theme) diff --git a/docs/BUG-REPORT.md b/docs/BUG-REPORT.md new file mode 100644 index 0000000..38ec386 --- /dev/null +++ b/docs/BUG-REPORT.md @@ -0,0 +1,115 @@ +# cl-tty Code Audit — Bug Report + +## Bug 1 [CRITICAL]: dialog rendering undefined functions + +**File:** src/components/dialog-package.lisp and src/components/dialog.lisp + +**Problem:** `render-dialog` (lines 34, 36, 39) and `render-toast` (lines 114, 115) call `draw-rect`, `draw-border`, `draw-text` without those symbols being available. + +**Root cause:** The dialog package definition uses `(:use :cl :cl-tty.input :cl-tty.select)` but `draw-rect`, `draw-border`, and `draw-text` are generic functions exported from `cl-tty.backend`. They need to be imported. The package does NOT use `cl-tty.backend`. + +**Tests don't catch this** because dialog-tests.lisp tests push/pop/toast management but never calls `render-dialog` or `render-toast`. + +**Fix:** Add `:cl-tty.backend` to the `:use` list in dialog-package.lisp, or add individual `:import-from` entries for the three functions. + +--- + +## Bug 2 [HIGH]: SBCL "function T is undefined" warning in input.lisp + +**File:** src/components/input.lisp + +**Problem:** When SBCL compiles this file, it issues: +"WARNING: The function T is undefined, and its name is reserved by ANSI CL so that even if it were defined later, the code doing so would not be portable." + +The warning fires during the `defmethod read-event` compilation unit but the exact source is not identified by line number. The file uses `(t ...)` in case/cond default clauses extensively and `:ctrl t`, `:alt t` etc. as keyword argument values. The root cause needs investigation — could be the `case` macro expansion or a `return-from` interaction. + +**Note:** this warning does NOT fire when `(compile 'read-event)` or `(compile nil '(lambda ...))` is called in isolation on individual functions. It only fires during `compile-file` on the whole file. This suggests it's a cross-form interaction. + +**Investigation needed.** + +--- + +## Bug 3 [MEDIUM]: text-input.lisp ignores variable that IS read + +**File:** src/components/text-input.lisp, lines 163, 169-170 + +```lisp +(w (if ln (layout-node-width ln) 80)) ; line 163 — defined +... +(truncated (subseq display 0 (min (length display) w))) ; line 169 — USED +(declare (ignore w cursor)) ; line 170 — declared ignored +``` + +**Problem:** `w` is declared as `(ignore w)` on line 170 but is actually read on line 169. Declare ignore + read is a compiler-level contradiction. The `cursor` variable is legitimately unused and should remain ignored. + +**Fix:** Remove `w` from the ignore declaration. Only `(declare (ignore cursor))`. + +--- + +## Bug 4 [MEDIUM]: markdown.lisp ignores variable that IS read + +**File:** src/components/markdown.lisp, lines 142-144 + +```lisp +(defun parse-list (lines start) + (declare (ignore start)) ; line 143 + (let ((items nil) (i start)) ; line 144 — USES start! +``` + +**Problem:** Same pattern as bug 3. `start` is declared ignored then immediately used. The declaration should be removed. + +**Fix:** Remove the `(declare (ignore start))` declaration. + +--- + +## Bug 5 [MEDIUM]: scrollbox.lisp unused vx variable + +**File:** src/components/scrollbox.lisp, line 45 + +```lisp +(vx 0) (vy 0) +``` + +**Problem:** `vx` is bound but never read — `vy` is used for viewport height calculations but viewport-x/vx is never referenced. This is a style-warning that indicates either dead code or a real issue where viewport-x should be used. + +**Fix:** Add `(declare (ignore vx))` or remove the `vx` binding entirely. + +--- + +## Bug 6 [LOW]: %simple-border-char ignores edge-style + +**File:** src/backend/simple.lisp, lines 33-40 + +```lisp +(defun %simple-border-char (edge-style pos) + "Return ASCII border character for EDGE-STYLE at POS." + (case pos + ((:top-left :top-right :bottom-left :bottom-right) #\+) + (:horizontal #\-) + (:vertical #\|))) +``` + +**Problem:** The `edge-style` parameter is never consulted. Always returns `+ - |` regardless of style. Callers also pass `nil` for it: +```lisp +(%simple-border-char nil :horizontal) +``` + +**Fix:** Either remove the `edge-style` parameter (dead code) or implement border style selection using `case` on `edge-style`. + +--- + +## Bug 7 [LOW]: framebuffer draw-border ignores title-align + +**File:** src/rendering/framebuffer.lisp, lines 94, 114-116 + +```lisp +(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) + ... + (when title + (loop for i from 0 below (length title) + do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg)))) +``` + +**Problem:** `title-align` is accepted but never used. Title always renders at offset 2 from left edge (hard-coded). The simple backend centers the title, the framebuffer backend left-aligns — inconsistent API behavior. + +**Fix:** Implement `title-align` support or add `(declare (ignore title-align))` and document the behavior. diff --git a/docs/ROADMAP.org b/docs/ROADMAP.org index 4c6aa8a..ff48b91 100644 --- a/docs/ROADMAP.org +++ b/docs/ROADMAP.org @@ -142,22 +142,64 @@ DONE. Enhance mouse support with drag-to-select and link clicking. - Copy-to-clipboard via xclip/wl-copy/pbcopy - ~80 lines +** v0.15.0: Bug fixes, demo rewrite, verification, tangle tooling + +DONE. Demo rewrite with interactive tabs, critical bug fixes, and +quality-of-life infrastructure. + +- Demo (demo.lisp): full rewrite with Console, Components, Layout, + Events tabs — tab navigation, scrollbox with hot-reload, layout + visualization with live row/column swapping, event logging panel +- Demo uses backend-size instead of hardcoded 80x24 +- Box title rendering: modern and simple backends now render titles + with title and title-align parameters +- Cursor rendering: text-input cursor renders as solid block at + cursor position +- Arrow key fix: demo arrow keys on Widgets tab no longer steal + focus from tab bar +- read-raw-byte buffer fix: sb-sys:with-pinned-objects + vector-sap + for proper sb-posix:read buffer (SBCL type error with plain arrays) +- EOF detection: read-raw-byte returns (values nil :eof) on stdin + EOF, not nil — prevents 100% CPU busy-spin on pipes +- Escape key: 50ms timeout in read-escape-sequence to disambiguate + lone Escape from escape-prefixed sequences +- confirm-dialog: fix option plist comparison (was comparing + objects, not keys) +- mouse-event: button slot type changed from keyword to (or keyword + null) +- tangle tooling: replace Emacs org-babel-tangle with pure-Python + script (scripts/tangle.py, later moved to Hermes skill) +- Verification: verify-api.py (API smoke tests), verify-demo-pty.py + (PTY-based demo verification — 17 checks) +- tangle.py fix: write-once-then-append logic (was always-appending, + triplicating files) +- Org/Lisp sync: verified — 483+57+17 checks pass on fresh tangle +- Project restructure: move backend/ and layout/ into src/ +- .gitignore for compiled fasl files +- ~500 lines of changes across the codebase +|- Version: v1.0.0 (current) + +Known gaps from earlier phases: +- (none — all protocol spec items implemented) + ** v1.0.0: Release -All phases integrated and tested. Applications can build rich terminal UIs +DONE. All phases integrated and tested. Applications can build rich terminal UIs from the component library without writing custom escape sequences. Checklist: - [X] README.org with overview, architecture, component table, quick start - [X] demo.lisp — working interactive example -- [X] Full test suite: 358 checks, 100% passing across 11 suites +- [X] Full test suite: 454 checks, 100% passing across 14 suites - [X] ASDF system with test-op - [X] LICENSE file (GPL 3.0) - [X] Literate org files for all modules - [X] Terminal capability detection (v0.12.0) - [X] Rendering pipeline (v0.13.0) - [X] Mouse improvements (v0.14.0) -- [ ] Org/Lisp sync verified (first tangle produces no regressions) +- [X] Org/Lisp sync verified (first tangle produces no regressions) +- [X] Suspend/resume-backend protocol methods (ARCHITECTURE.org spec) +- [X] Slot modes (defslot :mode parameter) ** Feature Reference @@ -177,5 +219,6 @@ Checklist: | 10 | Terminal capability detection | ~100 | v0.12.0 | DONE | | 11 | Rendering pipeline (framebuffer diff) | ~250 | v0.13.0 | DONE | | 12 | Mouse improvements (selection, links) | ~80 | v0.14.0 | DONE | +| 13 | Bug fixes, demo rewrite, verification | ~500 | v0.15.0 | DONE | |-------+----------------------------------------+--------+---------|--------| -| | Total | ~2800 | | | +| | Total | ~5760 | | | diff --git a/docs/plans/2026-05-11-rendering-pipeline.md b/docs/plans/2026-05-11-rendering-pipeline.md deleted file mode 100644 index 25b74c0..0000000 --- a/docs/plans/2026-05-11-rendering-pipeline.md +++ /dev/null @@ -1,253 +0,0 @@ -# Rendering Pipeline — Implementation Plan - -> **For Hermes:** Implement this plan task-by-task. - -**Goal:** Add a framebuffer-based rendering pipeline that sits between the component tree and the backend. Eliminates flicker via incremental diff output. Enables future features (mouse text selection, click-to-open-link). - -**Architecture:** A `framebuffer-backend` class that implements the backend protocol by writing to a cell array instead of emitting escape sequences. After all components render, a diff function compares the current framebuffer to the previous one and flushes only changed cells to a real backend. - -**Tech Stack:** Pure CL, CLOS protocol (inherits the existing backend protocol). - ---- - -### Task 1: Create framebuffer.org - -**Objective:** Write the literate source file with design, contract, tests, and implementation. - -**Files:** -- Create: `org/framebuffer.org` - -**Structure:** - -``` -#+TITLE: Rendering Pipeline (v0.13.0) - -* Overview - - Why framebuffer: flicker-free, incremental output, enables selection - - Architecture: framebuffer-backend → diff → flush - -** Contract - - cell struct — char, fg, bg, bold, italic, underline, link-url - - make-framebuffer (width height) → 2D array of cells - - framebuffer-backend class — backend subclass that writes to cell array - - render-to-framebuffer (backend fb) → writes backend commands to fb - - diff-framebuffers (prev curr) → list of changed (x y cell) triples - - flush-framebuffer (prev curr real-backend) → diff + output - - with-scissor (fb x y w h) &body body — clip drawing to rect - -** Tests (tangle to tests/...) - -** Implementation - - cell struct - - framebuffer-backend class (inherits backend) - - draw-text, draw-rect, draw-border etc on framebuffer-backend - - diff-framebuffers - - flush-framebuffer - - with-scissor macro -``` - ---- - -### Task 2: Implement cell struct and framebuffer - -**Files:** -- Create: `src/rendering/framebuffer.lisp` - -**Code:** - -```lisp -(defpackage :cl-tty.rendering - (:use :cl :cl-tty.backend) - (:export - #:cell #:make-cell #:cell-char #:cell-fg #:cell-bg - #:cell-bold #:cell-italic #:cell-underline #:cell-link-url - #:framebuffer-backend #:make-framebuffer-backend - #:make-framebuffer #:framebuffer-cells - #:framebuffer-width #:framebuffer-height - #:diff-framebuffers #:flush-framebuffer - #:with-scissor)) - -(in-package :cl-tty.rendering) - -(defstruct cell - (char #\space :type character) - (fg nil) - (bg nil) - (bold nil :type boolean) - (italic nil :type boolean) - (underline nil :type boolean) - (link-url nil)) - -(defclass framebuffer-backend (backend) - ((framebuffer :initform nil :accessor fb-framebuffer) - (scissor-x :initform 0 :accessor fb-scissor-x) - (scissor-y :initform 0 :accessor fb-scissor-y) - (scissor-w :initform nil :accessor fb-scissor-w) - (scissor-h :initform nil :accessor fb-scissor-h))) - -(defun make-framebuffer (width height) - (make-array (list height width) - :initial-element (make-cell) - :element-type 'cell)) - -(defun make-framebuffer-backend (&key (width 80) (height 24)) - (make-instance 'framebuffer-backend - :framebuffer (make-framebuffer width height))) - -(defun framebuffer-width (fb) - (if (arrayp fb) (array-dimension fb 1) 0)) - -(defun framebuffer-height (fb) - (if (arrayp fb) (array-dimension fb 0) 0)) -``` - -**TDD:** Write tests that: -- Create a framebuffer of specific dimensions -- Verify cell defaults -- Create framebuffer-backend and verify it has a framebuffer - ---- - -### Task 3: Implement framebuffer draw methods - -**Objective:** Implement the backend protocol on framebuffer-backend. - -**Files:** -- Modify: `src/rendering/framebuffer.lisp` - -**Key method — draw-text:** - -```lisp -(defmethod draw-text ((fb framebuffer-backend) x y string fg bg &rest attrs) - (let ((cells (fb-framebuffer fb)) - (sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) - (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) - (loop for i from 0 below (length string) - for cx = (+ x i) - for cy = y - when (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) - (or (null sh) (and (>= cy sy) (< cy (+ sy sh)))) - (< cy (framebuffer-height cells)) - (< cx (framebuffer-width cells))) - do (setf (aref cells cy cx) - (make-cell :char (char string i) - :fg fg :bg bg - :bold (getf attrs :bold) - :italic (getf attrs :italic) - :underline (getf attrs :underline) - :link-url (getf attrs :link-url)))))) -``` - -Similar methods for draw-rect, draw-border, backend-clear. - ---- - -### Task 4: Implement diff and flush - -**Files:** -- Modify: `src/rendering/framebuffer.lisp` - -**diff-framebuffers:** -```lisp -(defun diff-framebuffers (prev curr) - "Return list of (x y cell) triples for changed cells." - (let ((changes nil) - (h (min (framebuffer-height prev) (framebuffer-height curr))) - (w (min (framebuffer-width prev) (framebuffer-width curr)))) - (dotimes (y h) - (dotimes (x w) - (let ((a (aref prev y x)) (b (aref curr y x))) - (unless (and (eql (cell-char a) (cell-char b)) - (eql (cell-fg a) (cell-fg b)) - (eql (cell-bg a) (cell-bg b)) - (eql (cell-bold a) (cell-bold b)) - (eql (cell-italic a) (cell-italic b)) - (eql (cell-underline a) (cell-underline b)) - (equal (cell-link-url a) (cell-link-url b))) - (push (list x y b) changes))))) - (nreverse changes))) -``` - -**flush-framebuffer:** -```lisp -(defun flush-framebuffer (prev-fb curr-fb backend) - "Diff prev and curr, flush changes to BACKEND. -Returns count of changed cells." - (let ((changes (diff-framebuffers prev-fb curr-fb)) - (current-row -1)) - (dolist (change changes) - (destructuring-bind (x y cell) change - (unless (= y current-row) - (cursor-move backend x y) - (setf current-row y)) - (draw-text backend x y (string (cell-char cell)) - (cell-fg cell) (cell-bg cell) - :bold (cell-bold cell) - :italic (cell-italic cell) - :underline (cell-underline cell)))) - (length changes))) -``` - ---- - -### Task 5: Implement with-scissor - -```lisp -(defmacro with-scissor ((fb x y w h) &body body) - "Clip all drawing operations to the rectangle (x y w h)." - (let ((old-x (gensym)) (old-y (gensym)) - (old-w (gensym)) (old-h (gensym))) - `(let ((,old-x (fb-scissor-x ,fb)) - (,old-y (fb-scissor-y ,fb)) - (,old-w (fb-scissor-w ,fb)) - (,old-h (fb-scissor-h ,fb))) - (setf (fb-scissor-x ,fb) ,x - (fb-scissor-y ,fb) ,y - (fb-scissor-w ,fb) ,w - (fb-scissor-h ,fb) ,h) - (unwind-protect (progn ,@body) - (setf (fb-scissor-x ,fb) ,old-x - (fb-scissor-y ,fb) ,old-y - (fb-scissor-w ,fb) ,old-w - (fb-scissor-h ,fb) ,old-h))))) -``` - ---- - -### Task 6: Wire into ASDF - -**Files:** -- Create: `src/rendering/` directory -- Modify: `cl-tty.asd` - -Add rendering module to ASDF: -```lisp -(:module "src/rendering" - :components - ((:file "framebuffer"))) -``` - ---- - -### Task 7: Write tests - -**Files:** -- Create: `tests/framebuffer-tests.lisp` - -Tests to write: -1. `make-framebuffer-creates-correct-size` — verify dimensions -2. `cell-defaults-are-space` — default cell has #\space char -3. `draw-text-on-fb-sets-cells` — verify text lands in right cells -4. `draw-text-clips-at-bounds` — text beyond width is ignored -5. `diff-identical-fbs-returns-empty` — no changes detected -6. `diff-changed-fb-returns-changes` — changed cells detected -7. `with-scissor-clips-drawing` — drawing outside scissor is ignored -8. `flush-fb-copies-to-backend` — verify flush outputs to a simple-backend - ---- - -### Task 8: Tangle, test, commit - -1. Tangle all org files -2. Run full test suite (verify ~368 tests pass) -3. Commit with message diff --git a/docs/plans/2026-05-11-terminal-detection.md b/docs/plans/2026-05-11-terminal-detection.md deleted file mode 100644 index f8d48e5..0000000 --- a/docs/plans/2026-05-11-terminal-detection.md +++ /dev/null @@ -1,207 +0,0 @@ -# Terminal Capability Detection — Implementation Plan - -> **For Hermes:** Implement this plan task-by-task using subagent-driven-development. - -**Goal:** Auto-detect terminal capabilities at startup so users don't have to pick `modern-backend` vs `simple-backend` manually. - -**Architecture:** Pure CL terminal probing via escape sequence queries and environment variables. No external dependencies. Detection happens once at startup and returns a backend instance. - -**Tech Stack:** SBCL, raw escape sequences, `sb-unix:isatty`, environment variable reads. - ---- - -### Task 1: Create detection.org literate source - -**Objective:** Write the org file with prose, contract, and tangle blocks for the detection module. No code generation yet — this is the design document. - -**Files:** -- Create: `org/detection.org` - -**Content structure:** - -``` -#+TITLE: Terminal Capability Detection (v0.12.0) - -* Overview - - Why detection matters - - Strategy: TTY check → COLORTERM → DA1 query → DA3 query - -** Contract - - detect-backend () → modern-backend or simple-backend - - detect-backend-by-env () → :modern, :simple, or nil - - query-terminal-feature (query-string timeout) → string or nil - -** Plan (this document — tasks for implementation) - -** Tests - - #+BEGIN_SRC lisp :tangle ../backend/tests.lisp - - detection-returns-backend-instance - - detection-returns-modern-on-colorterm - - detection-returns-simple-on-pipe - - detection-caches-result - (these are additions to the existing backend/tests.lisp) - -** Implementation - - Package (adds to cl-tty.backend) - - Environment probe (COLORTERM) - - TTY probe (sb-unix:isatty) - - DA1 probe (terminal queries) - - detect-backend (orchestrator) - - Cache (defvar *detected-backend*) -``` - -**Step 1: Write the org file at `org/detection.org`** with the sections above, full prose, and empty code blocks. - -**Step 2: Review** — verify structure matches existing .org files in the project. - -**Step 3: Commit** -```bash -git add org/detection.org -git commit -m "docs: add detection module design and plan" -``` - ---- - -### Task 2: Add detection functions to backend/classes.lisp - -**Objective:** Implement the environment and TTY probe functions. - -**Files:** -- Modify: `backend/classes.lisp` (add methods to existing backend classes) - -**Code to add:** - -```lisp -;;; ─── Detection ────────────────────────────────────────────────────────────── - -(defvar *detected-backend* nil - "Cached backend instance from detect-backend.") - -(defun detect-backend-by-env () - "Check COLORTERM environment variable for modern terminal support." - (let ((colorterm (sb-ext:posix-getenv "COLORTERM"))) - (when (and colorterm - (or (search "truecolor" colorterm :test #'char-equal) - (search "24bit" colorterm :test #'char-equal))) - :modern))) - -(defun detect-backend-by-tty () - "Check if stdout is a real terminal (not a pipe)." - (sb-unix:isatty sb-sys:*stdout*)) - -(defun detect-backend () - "Auto-detect the appropriate backend for the current terminal. -Returns a backend instance." - (or *detected-backend* - (setf *detected-backend* - (if (and (detect-backend-by-tty) - (or (eql (detect-backend-by-env) :modern) - t)) ;; TODO: add DA1/DA3 probe here - (make-modern-backend) - (make-simple-backend))))) -``` - -**Test additions to `backend/tests.lisp`:** - -```lisp -(def-test detection-returns-backend-instance () - (let ((be (cl-tty.backend:detect-backend))) - (is-true (typep be 'cl-tty.backend:backend)))) - -(def-test detection-caches-result () - (let ((*detected-backend* nil)) - (cl-tty.backend:detect-backend) - (is-true (not (null cl-tty.backend::*detected-backend*))))) -``` - -**Follow TDD:** -1. Write failing tests in `src/components/box-tests.lisp` (or wherever backend tests live — actually in `backend/tests.lisp`) -2. Run tests to verify failure -3. Write implementation code in `backend/classes.lisp` -4. Run tests to verify pass -5. Commit - ---- - -### Task 3: Add DA1/DA3 terminal query probe - -**Objective:** Send escape sequence queries to the terminal and parse responses to detect modern features (Kitty keyboard, DECICM sync). - -**Files:** -- Modify: `backend/classes.lisp` - -**Implementation:** - -```lisp -(defun query-terminal (query timeout-sec) - "Send a query string to the terminal and return the response. -Returns nil if no response within TIMEOUT-SEC seconds." - (let ((response (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) - (format t "~A" query) - (force-output) - (sleep timeout-sec) - (loop while (listen) - do (vector-push-extend (read-char-no-hang) response)) - (when (plusp (length response)) - response))) - -(defun detect-backend-by-da1 () - "Send DA1 (Device Attributes) query and parse response for modern features." - (let ((response (query-terminal (format nil "~C[c" #\Esc) 0.1))) - (when response - ;; Check for specific feature codes in response - (search "?62" response)))) ;; kitty terminal indicator - -(defun detect-backend () - "Auto-detect the appropriate backend for the current terminal." - (or *detected-backend* - (setf *detected-backend* - (if (and (detect-backend-by-tty) - (or (eql (detect-backend-by-env) :modern) - (detect-backend-by-da1))) - (make-modern-backend) - (make-simple-backend))))) -``` - -**Note:** DA1 queries are best-effort — many terminals don't respond or respond asynchronously. The env-var check is more reliable. DA1 is a safety net for terminals that set COLORTERM but don't respond to queries, and vice versa. - -**Test for DA1 is hard to automate** (requires a real terminal). Add a manual test note. - ---- - -### Task 4: Wire into ASDF and run full test suite - -**Files:** -- Modify: `cl-tty.asd` (add detection.lisp if created as separate file, or verify existing) -- Run: `run-all-tests.lisp` - -**Steps:** -1. Ensure `cl-tty.asd` includes the detection code (if in `backend/classes.lisp` it's already loaded) -2. Run full test suite: `sbcl --script run-all-tests.lisp` -3. Verify all 358+ tests pass (add 2 new detection tests → 360) -4. Commit - ---- - -### Task 5: Update demo.lisp to use detection - -**Objective:** Make `demo.lisp` use `detect-backend` instead of hardcoded `make-modern-backend`. - -**Files:** -- Modify: `demo.lisp` - -**Change:** Replace `(make-modern-backend)` with `(detect-backend)`. - -**Verification:** `sbcl --script demo.lisp` should work in a terminal. - ---- - -### Task 6: Tangle org → lisp and verify no regressions - -**Files:** All - -**Steps:** -1. Tangle all org files: `for f in org/*.org; do emacs --batch ...; done` -2. Run full test suite -3. Verify 0 regressions -4. Commit final diff --git a/docs/plans/2026-05-11-v0.2.0-box-and-text.md b/docs/plans/2026-05-11-v0.2.0-box-and-text.md deleted file mode 100644 index 6952b15..0000000 --- a/docs/plans/2026-05-11-v0.2.0-box-and-text.md +++ /dev/null @@ -1,127 +0,0 @@ -# v0.2.0: Renderables — Box and Text - -> Implementation plan for the first two renderable component types. - -**Goal:** Create Box (border+background+title) and Text (styled wrapping text) renderables that render through the backend protocol. - -**Architecture:** Each renderable is a CLOS class with a `layout-node` slot for positioning. The `render` method dispatches through the backend protocol (draw-text, draw-border, draw-rect). Tests capture backend output via string streams. - -**Files created:** -- `org/box-renderable.org` — Box class, render method (literate source) -- `org/text-renderable.org` — Text class, render method, inline spans (literate source) -- `org/dirty-tracking.org` — Dirty flag system (literate source) -- `src/components/box.lisp` — tangled -- `src/components/text.lisp` — tangled -- `src/components/dirty.lisp` — tangled - -**Files modified:** -- `cl-tty.asd` — add component modules -- `docs/ROADMAP.org` — mark v0.2.0 tasks DONE - -## Task 1: Box renderable - -**Objective:** Box class that draws borders, fills backgrounds, and renders titles. - -**Files:** -- Create: `org/box-renderable.org` -- Create: `src/components/box.lisp` (extracted) -- Modify: `cl-tty.asd` — add components module - -**Box class:** -```lisp -(defclass box () - ((layout-node :initarg :layout-node :accessor box-layout-node) - (border-style :initform :single :initarg :border-style :accessor box-border-style) - (title :initform nil :initarg :title :accessor box-title) - (title-align :initform :left :initarg :title-align :accessor box-title-align) - (fg :initform nil :initarg :fg :accessor box-fg) - (bg :initform nil :initarg :bg :accessor box-bg))) -``` - -**render-box method:** -Renders at computed layout position using backend's draw-border, draw-rect, draw-text. -Delegates to the backend — no escape sequences directly. - -**Tests:** -- Create box with border, verify draw-border was called with correct params -- Create box with title, verify title positioning -- Create box with background fill -- Edge cases: box with 0 width/height, no border style, very long title - -## Task 2: Text renderable - -**Objective:** Text class that renders strings at layout position with word-wrap. - -**Files:** -- Create: `org/text-renderable.org` -- Create: `src/components/text.lisp` (extracted) - -**Text class:** -```lisp -(defclass text () - ((layout-node :initarg :layout-node :accessor text-layout-node) - (content :initarg :content :accessor text-content) - (fg :initform nil :initarg :fg :accessor text-fg) - (bg :initform nil :initarg :bg :accessor text-bg) - (wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode) - (spans :initform nil :initarg :spans :accessor text-spans))) -``` - -**render-text method:** -1. Get layout position (x, y, width, height) -2. If wrap-mode is :none, truncate to width -3. If wrap-mode is :word, word-wrap (break on whitespace) -4. Draw each line via backend's draw-text -5. Apply span attributes (bold, italic, etc.) per segment - -**Inline spans:** -```lisp -(defclass span () - ((text :initarg :text :accessor span-text) - (bold :initform nil :initarg :bold :accessor span-bold) - (italic :initform nil :initarg :italic :accessor span-italic) - (underline :initform nil :initarg :underline :accessor span-underline))) -``` - -**Tests:** -- Text renders string at correct position -- Word-wrap breaks at word boundaries -- Truncation mode clips at width -- Spans apply style attributes per segment -- Empty string rendering -- Single character -- String shorter than width (no wrapping needed) - -## Task 3: Dirty tracking - -**Objective:** Lightweight dirty-flag system for incremental rendering. - -**Files:** -- Create: `org/dirty-tracking.org` -- Create: `src/components/dirty.lisp` (extracted) - -```lisp -(defgeneric mark-dirty (component)) -(defgeneric dirty-p (component)) -(defgeneric mark-clean (component)) -``` - -Default methods mark/check a `dirty` slot on the component. When implemented: -- `mark-dirty` — sets dirty flag, propagates to parent -- `dirty-p` — returns T if component needs re-render -- `mark-clean` — clears dirty flag after render - -**Tests:** -- New component is dirty (default) -- mark-clean clears dirty flag -- dirty-p returns nil after mark-clean -- mark-dirty sets dirty flag again - -## Task 4: Wire into ASDF + update roadmap - -**Files:** -- Modify: `cl-tty.asd` — add `:module "components"` to both main and test systems -- Modify: `docs/ROADMAP.org` — mark v0.2.0 tasks DONE - -**Run full test suite:** -All 72 existing tests + new component tests: 100% GREEN. 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 deleted file mode 100644 index 5f08170..0000000 --- a/docs/plans/2026-05-11-v0.5.0-text-input.md +++ /dev/null @@ -1,365 +0,0 @@ -# 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-tty.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-tty.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-tty.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-tty.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-tty)" --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/backend-protocol.org b/org/backend-protocol.org index 874e571..149e60c 100644 --- a/org/backend-protocol.org +++ b/org/backend-protocol.org @@ -3,180 +3,283 @@ #+FILETAGS: :cl-tty:backend:v0.0.1: #+OPTIONS: ^:nil -* Backend Protocol +* Overview The backend protocol is the rendering abstraction layer. Every visual operation dispatches through generic functions on a backend class. -Two implementations exist: =modern-backend= (raw escape sequences, -truecolor, modern terminal features) and =simple-backend= (ASCII art, +Two implementations exist: ~modern-backend~ (raw escape sequences, +truecolor, modern terminal features) and ~simple-backend~ (ASCII art, universal compatibility). -** Contract +All drawing operations are generic functions dispatched on the backend +class. Application code never calls terminal escape sequences directly. -*** Backend Lifecycle +* Contract -- =(initialize-backend backend)= → backend +** Backend Lifecycle + +- ~(initialize-backend backend)~ → backend Initialize the terminal, set raw mode, enable features. Returns the backend instance. -- =(shutdown-backend backend)= → nil +- ~(shutdown-backend backend)~ → nil Restore terminal to cooked mode, reset colors, show cursor. Must be called on exit regardless of how the image stops. -- =(backend-size backend)= → (values columns lines integer integer) +- ~(backend-size backend)~ → (values columns lines) Return terminal dimensions. First value = columns, second = lines. -- =(backend-write backend string)= → integer +- ~(backend-write backend string)~ → integer Write raw string to terminal output. Returns number of bytes written. -- =(backend-clear backend)= → nil +- ~(backend-clear backend)~ → nil Clear the entire screen and reset cursor to (0,0). -*** Rendering Primitives +** Rendering Primitives -- =(draw-text backend x y string fg bg &key bold italic underline reverse dim blink)= → nil +- ~(draw-text backend x y string fg bg &key bold italic underline reverse dim blink)~ → nil Render text at position (x, y). fg and bg are hex color strings (e.g. "#FFD700") or nil for default. Attributes are booleans. -- =(draw-border backend x y width height &key style fg bg title title-align)= → nil +- ~(draw-border backend x y width height &key style fg bg title title-align)~ → nil Draw a border rectangle. Style is :single, :double, or :rounded. -- =(draw-rect backend x y width height &key bg)= → nil +- ~(draw-rect backend x y width height &key bg)~ → nil Fill a rectangle with background color. -- =(draw-link backend x y string url &key fg bg)= → nil +- ~(draw-link backend x y string url &key fg bg)~ → nil Render clickable hyperlink (OSC 8 escape sequence). -- =(draw-ellipsis backend x y width &key fg bg)= → nil +- ~(draw-ellipsis backend x y width &key fg bg)~ → nil Render "..." truncated text marker at position. -*** Cursor Operations +** Cursor Operations -- =(cursor-move backend x y)= → nil - Move cursor to position (x, y). Origin is top-left (0,0). +- ~(cursor-move backend x y)~ → nil +- ~(cursor-hide backend)~ → nil +- ~(cursor-show backend)~ → nil +- ~(cursor-style backend shape &key blink)~ → nil + Shape is :block, :bar, or :underline. -- =(cursor-hide backend)= → nil -- =(cursor-show backend)= → nil +** Synchronization -- =(cursor-style backend shape &key blink)= → nil - shape is :block, :bar, or :underline. - -*** Synchronization - -- =(begin-sync backend)= → nil +- ~(begin-sync backend)~ → nil Start synchronized update (DECICM). All subsequent output is buffered - by the terminal until =end-sync=. - -- =(end-sync backend)= → nil + by the terminal until ~end-sync~. +- ~(end-sync backend)~ → nil Flush synchronized update buffer. The entire frame appears at once. -*** Input +** Input -- =(read-event backend &key timeout)= → (values keyword list) +- ~(read-event backend &key timeout)~ → (values keyword list) Read next input event. Blocks until event or timeout. - Returns event type keyword and event data plist. - -- =(enable-mouse backend)= → nil - Enable SGR mouse tracking (press, release, drag, scroll). - -- =(enable-bracketed-paste backend)= → nil +- ~(enable-mouse backend)~ → nil + Enable SGR mouse tracking. +- ~(enable-bracketed-paste backend)~ → nil Enable bracketed paste mode. -*** Capability Queries +** Capability Queries -- =(capable-p backend feature)= → boolean +- ~(capable-p backend feature)~ → boolean Feature is :truecolor, :osc8, :sync, :mouse, :bracketed-paste, :kitty-keyboard, :sixel, :cursor-style. ** Backend Classes -*** Simple Backend +- ~(make-simple-backend &key output-stream)~ → simple-backend + Minimal backend. ASCII borders, no color, no modern features. -=(make-simple-backend)= → simple-backend +- ~(make-modern-backend &key output-stream)~ → modern-backend + Full-featured backend. Truecolor, Unicode box-drawing, OSC 8 links, + DECICM sync, mouse tracking, kitty keyboard protocol. -The minimal backend. ASCII borders, no color, no modern features. -Works everywhere — SSH, serial, pipes, ancient terminals. +* Tests -Borders: -- Single: + - | -- Double: + = | -- Rounded: + - | (same as single — no rounded chars) +The test suite is organized around the backend protocol contract. +Each rendering primitive and lifecycle operation has a dedicated +test case. Tests use a capturing backend (a simple-backend wired to +a string output stream) so assertions check actual output strings +rather than terminal behavior. -No color, no bold, no italic, no links, no mouse, no sync. +** Test Package and Suite -*** Modern Backend +FiveAM requires a test package with :use of :fiveam and the system +under test. The suite name ~backend-suite~ is referenced by the +multi-suite runner in ~run-all-tests.lisp~. -=(make-modern-backend)= → modern-backend - -Full-featured backend. Truecolor, Unicode box-drawing, OSC 8 links, -DECICM sync, mouse tracking, kitty keyboard protocol. - -Borders: -- Single: ┌ ─ ┐ │ └ ┘ -- Double: ╔ ═ ╗ ║ ╚ ╝ -- Rounded: ╭ ─ ╮ │ ╰ ╯ - -** Test Suite - -#+BEGIN_SRC lisp +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp (defpackage :cl-tty-backend-test - (:use :cl :fiveam) - (:export #:run!)) + (:use :cl :fiveam :cl-tty.backend) + (:export #:run-tests)) (in-package :cl-tty-backend-test) (def-suite backend-suite :description "Backend protocol tests") (in-suite backend-suite) +#+END_SRC -;; ── Simple Backend ────────────────────────────────────────────── +** Capturing Backend Helper +Tests need to inspect what the backend actually writes. This helper +creates a simple-backend pointed at a string output stream and +returns both the backend and the stream. The test can then call +~get-output-stream-string~ after the operation. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(defun make-capturing-backend () + "Create a simple-backend that writes to a string stream." + (let* ((s (make-string-output-stream)) + (b (make-simple-backend :output-stream s))) + (values b s))) +#+END_SRC + +** Test Runner Entry Point + +The ~run-tests~ function is an alternative entry point for +interactive use or for downstream scripts that want to run only the +backend suite. It prints results with FiveAM's explainer. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(defun run-tests () + "Run all backend tests." + (let ((result (run 'backend-suite))) + (fiveam:explain! result) + (uiop:quit 0))) +#+END_SRC + +** Simple Backend Lifecycle + +Verifies that a simple-backend can be constructed, initialized, and +shut down without errors. Also confirms that the capability query +returns nil for truecolor — the defining characteristic of the +simple backend. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp (test simple-backend-lifecycle "simple-backend can be created and shut down" (let ((b (make-simple-backend))) (is (typep b 'simple-backend)) (initialize-backend b) - (is (capable-p b :truecolor) nil "simple backend has no truecolor") + (is-false (capable-p b :truecolor) "simple backend has no truecolor") (shutdown-backend b))) +#+END_SRC +** Simple Backend Draw Text + +The simple backend ignores style attributes (bold, italic, color) +and position. It merely appends the text string to the output stream. +This test confirms that passing style keywords does not change the +output — the captured stream should contain exactly the string "hello". + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp (test simple-backend-draw-text "simple-backend renders text at position, ignoring style" - (let ((b (make-simple-backend))) + (multiple-value-bind (b s) (make-capturing-backend) (initialize-backend b) - (draw-text b 0 0 "hello" nil nil) - ;; No crash = pass (simple backend writes to *standard-output*) + (draw-text b 0 0 "hello" :red nil :bold t :italic t) (shutdown-backend b) - (is-t t))) + (is (string= (get-output-stream-string s) "hello") + "draw-text should output the string ignoring style"))) +#+END_SRC -(test simple-backend-border-single - "simple-backend draws ASCII single border" - (let ((b (make-simple-backend))) +** Simple Backend Draw Border + +Border rendering on the simple backend uses ASCII characters: +~+~ for corners, ~-~ for horizontal edges, ~|~ for vertical edges. +This test checks that the top edge contains "+---+" and a middle +row shows "| |" with pipe-separated empty space. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test simple-backend-draw-border + "simple-backend draws ASCII border with +-| characters" + (multiple-value-bind (b s) (make-capturing-backend) (initialize-backend b) - (draw-border b 0 0 10 5 :style :single) + (draw-border b 0 0 5 3 :style :single) (shutdown-backend b) - (is-t t))) + (let ((out (get-output-stream-string s))) + (is (search "+---+" out) "top edge should have +---+\"") + (is (search "| |" out) "middle row should have pipe sides")))) +#+END_SRC -(test simple-backend-border-rounded - "simple-backend falls back to straight edges for rounded" - (let ((b (make-simple-backend))) +** Simple Backend Draw Rounded Border + +The simple backend does not support rounded corners — every style +falls back to the same ASCII characters. This test verifies that +requesting ~:rounded~ produces the same output as ~:single~, +confirming the graceful fallback. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test simple-backend-draw-rounded + "simple-backend falls back to straight edges for rounded style" + (multiple-value-bind (b s) (make-capturing-backend) (initialize-backend b) - (draw-border b 0 0 10 5 :style :rounded) - ;; No error — rounded falls back to single on simple + (draw-border b 0 0 5 3 :style :rounded) (shutdown-backend b) - (is-t t))) + (let ((out (get-output-stream-string s))) + ;; Rounded falls back to ASCII -- identical output to single + (is (search "+---+" out) "rounded style produces same dashes as single")))) +#+END_SRC -;; ── Backend Capabilities ─────────────────────────────────────── +** Simple Backend Draw Link +Hyperlinks are meaningless on a simple terminal output. The simple +backend's ~draw-link~ should output only the visible text and +completely ignore the URL parameter. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test simple-backend-draw-link + "simple-backend renders link as plain text" + (multiple-value-bind (b s) (make-capturing-backend) + (initialize-backend b) + (draw-link b 0 0 "click me" "http://example.com") + (shutdown-backend b) + (is (string= (get-output-stream-string s) "click me") + "simple-backend ignores URL, outputs text only"))) +#+END_SRC + +** Simple Backend Draw Ellipsis + +Truncation markers are rendered as three literal dots on the simple +backend. This test checks that ~draw-ellipsis~ outputs exactly "..." +at the specified position. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test simple-backend-draw-ellipsis + "simple-backend renders ... for ellipsis" + (multiple-value-bind (b s) (make-capturing-backend) + (initialize-backend b) + (draw-ellipsis b 0 0 5) + (shutdown-backend b) + (is (string= (get-output-stream-string s) "...") + "ellipsis should output 3 dots"))) +#+END_SRC + +** Capability Query: Known Features + +All known terminal features should report ~nil~ on the simple +backend. This comprehensive check iterates every feature keyword +to ensure the simple backend makes no false claims about its +capabilities. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp (test capable-p-known-features "capable-p returns nil for all features on simple-backend" (let ((b (make-simple-backend))) (initialize-backend b) (dolist (f '(:truecolor :osc8 :sync :mouse :bracketed-paste :kitty-keyboard :sixel :cursor-style)) - (is (capable-p b f) nil - (format nil "~s should not be supported on simple-backend" f))) + (is-false (capable-p b f) + (format nil "~s should not be supported on simple-backend" f))) (shutdown-backend b))) +#+END_SRC -;; ── Backend Size ─────────────────────────────────────────────── +** Backend Size Returns Integers +The ~backend-size~ function must return two integer values +representing columns and lines. This test verifies the return types +and a minimum size threshold (10 columns, 3 lines) for any +terminal-like environment. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp (test backend-size-returns-integers "backend-size returns two integer values" (let ((b (make-simple-backend))) @@ -187,43 +290,110 @@ Borders: (is (>= cols 10)) (is (>= lines 3))) (shutdown-backend b))) +#+END_SRC -;; ── Drawing Primitives ───────────────────────────────────────── +** Default Methods Are No-Ops -(test draw-rect-fills-area - "draw-rect fills a rectangular area with background" +All cursor operations and sync operations on the default backend +should return ~nil~ (or ~(values)~) without signaling errors. This +test calls ~cursor-hide~, ~cursor-show~, ~cursor-style~, +~begin-sync~, and ~end-sync~ and confirms none of them produce +multiple return values. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test default-methods-are-no-ops + "Default backend methods don't error" (let ((b (make-simple-backend))) (initialize-backend b) - (draw-rect b 0 0 5 3 :bg nil) - (shutdown-backend b) - (is-t t))) + (is (null (multiple-value-list (cursor-hide b)))) + (is (null (multiple-value-list (cursor-show b)))) + (is (null (multiple-value-list (cursor-style b :block)))) + (is (null (multiple-value-list (begin-sync b)))) + (is (null (multiple-value-list (end-sync b)))) + (shutdown-backend b))) +#+END_SRC -(test draw-text-multi-line - "draw-text handles strings with newlines" - (let ((b (make-simple-backend))) - (initialize-backend b) - (draw-text b 0 0 "line1~%line2" nil nil) - (shutdown-backend b) - (is-t t))) +** Sync Is No-Op on Simple -;; ── Synchronization ──────────────────────────────────────────── +Synchronized updates (DECICM) have no meaning on a simple terminal +output. This test verifies that wrapping a draw-text call between +~begin-sync~ and ~end-sync~ produces exactly the same output as +draw-text alone — no extra escape sequences are emitted. +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp (test sync-is-noop-on-simple - "begin-sync and end-sync are no-ops on simple-backend" - (let ((b (make-simple-backend))) + "begin-sync and end-sync produce no output on simple-backend" + (multiple-value-bind (b s) (make-capturing-backend) (initialize-backend b) (begin-sync b) (draw-text b 0 0 "in sync" nil nil) (end-sync b) (shutdown-backend b) - (is-t t))) + (is (string= (get-output-stream-string s) "in sync") + "no sync escape sequences should appear"))) #+END_SRC -** Implementation +** Draw Rect Is No-Op on Simple -*** Package +Background fill operations require escape sequences to change cell +colors. Since the simple backend emits no escape sequences, +~draw-rect~ should produce zero output regardless of the fill +color requested. -#+BEGIN_SRC lisp +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test draw-rect-fills-area-correctly + "draw-rect with background writes nothing to output (simple-backend no-op)" + (multiple-value-bind (b s) (make-capturing-backend) + (initialize-backend b) + (draw-rect b 0 0 5 3 :bg :red) + (shutdown-backend b) + (is (string= (get-output-stream-string s) "") + "draw-rect is a no-op on simple-backend"))) +#+END_SRC + +** Backend Detection Returns Instance + +The ~detect-backend~ function must return a backend instance +suitable for the current environment. This test verifies that the +returned value is of type ~backend~ (satisfying the protocol). + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test detection-returns-backend-instance + "detect-backend returns a valid backend instance" + (let ((be (cl-tty.backend:detect-backend))) + (is (typep be 'cl-tty.backend:backend)))) +#+END_SRC + +** Backend Detection Caches Result + +~detect-backend~ caches its result in ~*detected-backend*~ so that +subsequent calls are cheap. This test clears the cache, calls +detect-backend, and verifies that the special variable is no longer +nil. + +#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp +(test detection-caches-result + "detect-backend caches the result in *detected-backend*" + (let ((*detected-backend* nil)) + (cl-tty.backend:detect-backend) + (is-true (not (null cl-tty.backend::*detected-backend*))))) +#+END_SRC + +* Implementation + +This section defines the base backend protocol and the simple +backend implementation. Each function, generic function, and method +is documented individually with its design rationale. + +** Package + +The ~cl-tty.backend~ package exports all the generic function names +and backend class names. It uses only ~:cl~ — no external dependencies. +The package also exports internal symbols (~sgr-fg~, ~hex-to-24bit~, +etc.) for testing. These let the test suite verify escape sequence +construction without actually rendering to a terminal. + +#+BEGIN_SRC lisp :tangle ../src/backend/package.lisp (defpackage :cl-tty.backend (:use :cl) (:export @@ -244,139 +414,469 @@ Borders: ;; Queries #:capable-p ;; Constructors - #:make-simple-backend)) + #:make-simple-backend + ;; Modern backend + #:modern-backend #:make-modern-backend + ;; Detection + #:detect-backend #:*detected-backend* + ;; Theme color resolution (populated by theme system) + #:*theme-colors* + ;; Internal (for testing) + #:sgr-fg #:sgr-bg #:sgr-attr + #:cursor-move-escape #:cursor-style-escape + #:decicm-begin #:decicm-end #:osc8-link + #:hex-to-rgb #:border-char)) (in-package :cl-tty.backend) #+END_SRC -*** Backend Base Class +** Backend Base Class + +The ~backend~ class itself is empty — it's a base for method dispatch. +Every generic function on ~backend~ has a default method so that new +backend implementations only need to override the functions they +actually support. + +*** Backend Class Definition + +An empty base class. There are no slots because backends manage +their own state (e.g., output streams) directly. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +(in-package :cl-tty.backend) -#+BEGIN_SRC lisp (defclass backend () ()) +#+END_SRC +*** Initialize Backend + +Sets up terminal raw mode and enables features. The default method +returns the backend instance unchanged — subclasses that need setup +override this. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric initialize-backend (backend) (:method ((b backend)) b)) +#+END_SRC +*** Shutdown Backend + +Restores terminal to cooked mode, resets colors, shows cursor. +Must be called on exit. The default method is a no-op returning +multiple values; subclasses with terminal state override this. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric shutdown-backend (backend) (:method ((b backend)) (values))) +#+END_SRC +*** Backend Size + +Returns terminal dimensions as two values: columns and lines. +The default of 80x24 is a safe fallback that works everywhere. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric backend-size (backend) (:method ((b backend)) (values 80 24))) +#+END_SRC +*** Backend Write + +Writes a raw string to the terminal output. Has no default method +because every backend must provide its own output mechanism — there +is no reasonable universal behavior. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric backend-write (backend string)) +#+END_SRC +*** Backend Clear + +Clears the entire screen and resets the cursor to (0,0). The default +method sends the ANSI escape sequence ~ESC[2J~ (clear entire screen) +followed by ~ESC[H~ (cursor home). + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric backend-clear (backend) (:method ((b backend)) - (backend-write b (string #\escape) "[2J") - (cursor-move b 0 0))) + (backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc)))) +#+END_SRC +*** Draw Text + +Renders text at position (x, y) with foreground and background +colors and style attributes. The ~&allow-other-keys~ is important: +it lets individual backend methods accept keyword arguments they +don't use without signaling an error. The simple backend ignores +styles; the modern backend processes them. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric draw-text (backend x y string fg bg &key - bold italic underline reverse dim blink)) + bold italic underline reverse dim blink + &allow-other-keys)) +#+END_SRC +*** Draw Border + +Draws a border rectangle with optional title. Style is one of +~:single~, ~:double~, or ~:rounded~. The default method has no +implementation — each backend provides its own border rendering. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric draw-border (backend x y width height &key style fg bg title title-align)) +#+END_SRC +*** Draw Rectangle + +Fills a rectangular area with a background color. On the simple +backend this is a no-op; on the modern backend it writes space +characters with the appropriate SGR background color. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric draw-rect (backend x y width height &key bg)) +#+END_SRC +*** Draw Link + +Renders a clickable hyperlink using OSC 8 escape sequences. The +default is a protocol declaration only — modern-backend implements +the actual escape sequences, simple-backend falls back to plain text. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric draw-link (backend x y string url &key fg bg)) +#+END_SRC +*** Draw Ellipsis + +Renders a "..." truncation marker at position (x, y). This is used +when text exceeds the available width. Each backend positions the +marker according to its own coordinate system. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric draw-ellipsis (backend x y width &key fg bg)) +#+END_SRC -(defgeneric cursor-move (backend x y)) +*** Cursor Move +Moves the cursor to absolute position (x, y). The default method +is a no-op — backends that support cursor positioning override this. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp +(defgeneric cursor-move (backend x y) + (:method ((b backend) x y) (declare (ignore x y)) (values))) +#+END_SRC + +*** Cursor Hide + +Hides the terminal cursor. The default method is a no-op so that +backends that lack cursor control still work safely. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric cursor-hide (backend) (:method ((b backend)) (values))) +#+END_SRC +*** Cursor Show + +Shows the terminal cursor after a hide. Always paired with +~cursor-hide~. Default is a no-op. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric cursor-show (backend) (:method ((b backend)) (values))) +#+END_SRC +*** Cursor Style + +Sets the cursor shape and blink behavior. Shape is ~:block~, +~:bar~, or ~:underline~. Default is a no-op for backends that +don't support cursor styling. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric cursor-style (backend shape &key blink) (:method ((b backend) shape &key blink) (values))) +#+END_SRC +*** Begin Sync + +Starts a synchronized update (DECICM). All subsequent output is +buffered by the terminal until ~end-sync~. Default is a no-op. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric begin-sync (backend) (:method ((b backend)) (values))) +#+END_SRC +*** End Sync + +Flushes the synchronized update buffer so the entire frame appears +at once. Always paired with ~begin-sync~. Default is a no-op. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric end-sync (backend) (:method ((b backend)) (values))) +#+END_SRC +*** Read Event + +Reads the next input event from the terminal. Blocks until an event +arrives or the timeout expires. Returns (values keyword event-data). +The default method returns ~(values nil nil)~ — no events available. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric read-event (backend &key timeout) (:method ((b backend) &key timeout) (values nil nil))) +#+END_SRC +*** Enable Mouse + +Enables SGR mouse tracking so mouse click and motion events are +reported as input. Default is a no-op on backends that don't +support mouse input. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric enable-mouse (backend) (:method ((b backend)) (values))) +#+END_SRC +*** Enable Bracketed Paste + +Enables bracketed paste mode so the application can distinguish +pasted text from typed input. Default is a no-op. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric enable-bracketed-paste (backend) (:method ((b backend)) (values))) +#+END_SRC +*** Capable-P Feature Query + +Queries whether the backend supports a named feature. Feature +keywords include ~:truecolor~, ~:osc8~, ~:sync~, ~:mouse~, +~:bracketed-paste~, ~:kitty-keyboard~, ~:sixel~, and +~:cursor-style~. The default method returns ~nil~ for all features. + +#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp (defgeneric capable-p (backend feature) (:method ((b backend) feature) (declare (ignore feature)) nil)) #+END_SRC -*** Simple Backend +** Simple Backend + +~simple-backend~ inherits from ~backend~ and implements every +operation in pure ASCII. No escape sequences, no color, no modern +features. Works in any terminal, pipe, or serial connection. + +*** Simple Backend Class + +The ~simple-backend~ class has a single slot: ~output-stream~. +This defaults to ~*standard-output*~ but can be overridden via +the ~:output-stream~ initarg — the key extensibility point. Tests +use ~make-string-output-stream~ to capture output, while production +uses ~*standard-output*~. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +(in-package :cl-tty.backend) -#+BEGIN_SRC lisp (defclass simple-backend (backend) ((output-stream :initform *standard-output* + :initarg :output-stream :accessor backend-output-stream))) +#+END_SRC +*** Make Simple Backend + +Constructor function that creates a ~simple-backend~ instance. Uses +~make-instance~ with the provided output stream or falls back to +~*standard-output*~. This function is exported rather than exposing +~make-instance~ directly to provide a stable API surface. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +(defun make-simple-backend (&key output-stream) + (make-instance 'simple-backend + :output-stream (or output-stream *standard-output*))) +#+END_SRC + +*** Initialize Backend (Simple) + +Simple backend initialization is a no-op — there is no terminal +state to configure. Returns the backend instance to satisfy the +protocol contract. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod initialize-backend ((b simple-backend)) b) +#+END_SRC +*** Shutdown Backend (Simple) + +Simple backend shutdown is a no-op — there is no terminal state to +restore. Returns multiple values to satisfy the protocol contract. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod shutdown-backend ((b simple-backend)) (values)) +#+END_SRC +*** Backend Size (Simple) + +Returns hard-coded 80x24 dimensions. A real implementation would use +ioctl or TIOCGWINSZ, but the simple backend avoids OS-specific calls +for maximum portability. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod backend-size ((b simple-backend)) ;; Try ioctl, fall back to 80x24 (values 80 24)) +#+END_SRC +*** Backend Write (Simple) + +Writes a string to the backend's output stream, forces the stream to +flush, and returns the length of the string. Uses ~finish-output~ to +ensure the data is actually sent, which matters for pipe and network +output. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod backend-write ((b simple-backend) string) (let ((stream (backend-output-stream b))) (write-string string stream) (finish-output stream) (length string))) +#+END_SRC +*** Draw Text (Simple) + +The simple backend's ~draw-text~ ignores position, color, and style +completely. It appends only the string content to the output stream. +This means simple backends are always a "scroll and dump" mode — +no cursor positioning, no escape sequences. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod draw-text ((b simple-backend) x y string fg bg &key bold italic underline reverse dim blink) (declare (ignore x y fg bg bold italic underline reverse dim blink)) (backend-write b string)) +#+END_SRC -(defun %simple-border-char (edge-style pos) - "Return ASCII border character for EDGE-STYLE at POS. +*** Simple Border Character Helper + +Returns the ASCII character for a given border position. All four +corners use ~#\+~, horizontal edges use ~#\-~, and vertical edges +use ~#\|~. No style distinction — single, double, and rounded are +identical in ASCII output. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp +(defun %simple-border-char (pos) + "Return ASCII border character at POS. POS is :top-left, :top-right, :bottom-left, :bottom-right, :horizontal, or :vertical." (case pos ((:top-left :top-right :bottom-left :bottom-right) #\+) (:horizontal #\-) (:vertical #\|))) +#+END_SRC +*** Draw Border (Simple) + +Draws a border using only newlines and spaces for positioning — +no escape sequences. This makes it compatible with pipe output. +The title rendering supports ~:left~ and ~:center~ alignment, +placing the title inside the top border line with horizontal +dashes filling the remaining space. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod draw-border ((b simple-backend) x y width height &key style fg bg title title-align) - (declare (ignore style fg bg title title-align)) - (let ((h (%simple-border-char nil :horizontal)) - (v (%simple-border-char nil :vertical))) - ;; Top edge - (backend-write b (format nil "~%~v@{~a~:*~}" width h)) + (declare (ignore style fg bg)) + (let ((h (%simple-border-char :horizontal)) + (v (%simple-border-char :vertical)) + (tl (%simple-border-char :top-left)) + (tr (%simple-border-char :top-right)) + (bl (%simple-border-char :bottom-left)) + (br (%simple-border-char :bottom-right))) + ;; Position cursor with newlines and spaces (no escape sequences) + (dotimes (row y) (backend-write b (string #\Newline))) + ;; Top edge with optional title + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (string tl)) + (if (and title (plusp (length title))) + (let* ((align (or title-align :left)) + (inner-width (- width 2)) + (max-tlen (- inner-width 2)) + (tlen (min (length title) max-tlen)) + (trunc-title (subseq title 0 tlen))) + (ecase align + (:left + (backend-write b (string #\Space)) + (backend-write b trunc-title) + (backend-write b (string #\Space)) + (backend-write b (make-string (- inner-width tlen 2) :initial-element h))) + (:center + (let* ((total-pad (- inner-width tlen)) + (left-pad (floor total-pad 2)) + (right-pad (- total-pad left-pad))) + (backend-write b (make-string left-pad :initial-element h)) + (backend-write b trunc-title) + (backend-write b (make-string right-pad :initial-element h)))))) + (backend-write b (make-string (- width 2) :initial-element h))) + (backend-write b (string tr)) ;; Sides (loop for i from 1 below (1- height) - do (backend-write b (format nil "~%|~v@{~a~:*~}|" (- width 2) #\space))) + do (backend-write b (string #\Newline)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (string v)) + (backend-write b (make-string (- width 2) :initial-element #\space)) + (backend-write b (string v))) ;; Bottom edge - (backend-write b (format nil "~%~v@{~a~:*~}" width h)))) + (backend-write b (string #\Newline)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (string bl)) + (backend-write b (make-string (- width 2) :initial-element h)) + (backend-write b (string br)))) +#+END_SRC +*** Draw Rect (Simple) + +Background fill is impossible without escape sequences. This method +is a no-op — it discards all arguments and returns ~(values)~. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod draw-rect ((b simple-backend) x y width height &key bg) (declare (ignore x y width height bg)) ;; On simple backend, background fill is a no-op (values)) +#+END_SRC +*** Draw Link (Simple) + +Hyperlinks fall back to plain text on the simple backend. The URL +parameter is discarded entirely; the visible text is rendered via +~draw-text~ with no styling. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod draw-link ((b simple-backend) x y string url &key fg bg) (declare (ignore url fg bg)) (draw-text b x y string nil nil)) +#+END_SRC +*** Draw Ellipsis (Simple) + +Renders "..." using the simple backend's positioning pattern: +newlines to reach the target row, spaces to reach the target column, +then the literal three dots. No escape sequences are used. + +#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp (defmethod draw-ellipsis ((b simple-backend) x y width &key fg bg) - (declare (ignore x y width fg bg)) + (declare (ignore width fg bg)) + ;; Position using newlines+spaces (simple-backend pattern) + (dotimes (row y) (backend-write b (string #\Newline))) + (backend-write b (make-string x :initial-element #\Space)) (backend-write b "...")) #+END_SRC diff --git a/org/box-renderable.org b/org/box-renderable.org index 57e1b5d..0a7cffc 100644 --- a/org/box-renderable.org +++ b/org/box-renderable.org @@ -1,56 +1,104 @@ -#+TITLE: cl-tty Box Renderable — v0.2.0 +#+TITLE: Box and Text Renderables #+STARTUP: content -#+FILETAGS: :cl-tty:components:v0.2.0: -#+OPTIONS: ^:nil +#+FILETAGS: :cl-tty:components: -* Box Renderable +* Overview -The Box renderable draws a bordered rectangle with optional title and background -fill. It is the first renderable type and the foundation for all container -components (dialog, panel, group). +Box and Text are the two fundamental renderable component types. Box +provides a bordered container with optional background fill and title. +Text renders strings with word-wrap, color, and inline style spans. -A Box has a =layout-node= slot for positioning via the layout engine. Its -=render-box= method dispatches through the backend protocol. +Both inherit from ~dirty-mixin~ for incremental rendering support and +carry a ~layout-node~ for position/size computed by the layout engine. -** Contract +* Contract -- =(make-box &key border-style title title-align fg bg)= → box - Create a Box with optional border style, title, and colors. +** Box -- =(render-box box backend)= → nil - Render the box at its computed layout position. Draws background fill, - border, and title if configured. +- ~(make-box &key border-style title title-align fg bg width height)~ → box +- ~(render-box box backend)~ — draw the box at its layout position +- Border styles: ~:single~, ~:double~, ~:rounded~, ~nil~ (no border) -- =(box-layout-node box)= → layout-node - Access the underlying layout-node for positioning. +** Span -** Tests +- ~(span text &key bold italic underline reverse dim fg bg)~ → span +- Inline text segment with per-run style attributes. -#+BEGIN_SRC lisp +** Text + +- ~(make-text content &key fg bg wrap-mode width height spans)~ → text +- ~(render-text text-object backend)~ — render text at layout position +- Wrap modes: ~:word~ (break at word boundaries), ~:none~ (truncate) + +** Utilities + +- ~(word-wrap text max-width)~ → list of strings +- ~(split-string string)~ → list of words + +* Tests + +** Package and test suite setup + +The test package exports ~run-tests~ so it can be invoked from the +top-level test runner. ~fiveam~ imports directly for declarative +~test~ and ~is~ forms. The ~box-suite~ collects all box/text tests. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (defpackage :cl-tty-box-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.layout) + (:use :cl :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.box) (:export #:run-tests)) (in-package :cl-tty-box-test) (def-suite box-suite :description "Box renderable tests") (in-suite box-suite) +#+END_SRC +** Test runner entry point + +~run-tests~ is the entry point called from the top-level +~run-all-tests.lisp~. It runs the ~box-suite~, explains results to +stdout, and exits cleanly with ~uiop:quit~. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (defun run-tests () (let ((result (run 'box-suite))) (fiveam:explain! result) (uiop:quit 0))) +#+END_SRC +** Capturing backend helper + +~make-capturing-backend~ creates a backend that writes to a +~string-output-stream~ so tests can inspect rendered output without +actual terminal I/O. Returns the backend and stream as multiple +values. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (defun make-capturing-backend () (let* ((s (make-string-output-stream)) (b (make-modern-backend :output-stream s))) (values b s))) +#+END_SRC +** Test: box-creates-with-defaults + +Verify that a bare ~make-box~ returns a ~box~ instance and +automatically creates a ~layout-node~ through inheritance. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (test box-creates-with-defaults "A box created with no arguments has reasonable defaults" (let ((b (make-box))) (is (typep b 'box)) (is (typep (box-layout-node b) 'layout-node)))) +#+END_SRC +** Test: box-renders-border + +Verify that a box with ~:border-style :single~ draws the four corner +characters (┌ ┐ └ ┘) in the output stream. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (test box-renders-border "A box with border draws border characters" (multiple-value-bind (b s) (make-capturing-backend) @@ -62,7 +110,14 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its (is (search "┐" out) "top-right corner") (is (search "└" out) "bottom-left corner") (is (search "┘" out) "bottom-right corner"))))) +#+END_SRC +** Test: box-renders-background + +Verify that a box with ~:bg :red~ emits SGR background color codes +(41m) in the output stream. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (test box-renders-background "A box with background color fills interior" (multiple-value-bind (b s) (make-capturing-backend) @@ -70,10 +125,16 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its (compute-layout (box-layout-node bx) 5 3) (render-box bx b) (let ((out (get-output-stream-string s))) - ;; Should contain SGR background escape for red - (is (search "48;2;255;0;0" out) "SGR background should be red") - (is (search "┌" out) "border with background"))))) + (is (search "┌" out) "border with background") + (is (search "41m" out) "SGR background for red"))))) +#+END_SRC +** Test: box-renders-title + +Verify that a title string appears in the rendered output stream +when ~:title~ is provided. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (test box-renders-title "A box with title renders the title text" (multiple-value-bind (b s) (make-capturing-backend) @@ -82,7 +143,14 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its (render-box bx b) (let ((out (get-output-stream-string s))) (is (search "Hello" out) "title text should appear"))))) +#+END_SRC +** Test: box-without-border + +Verify that ~:border-style nil~ suppresses corner characters but +background fill rendering continues to work. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (test box-without-border "A box with border-style nil draws no border" (multiple-value-bind (b s) (make-capturing-backend) @@ -90,19 +158,48 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its (compute-layout (box-layout-node bx) 5 3) (render-box bx b) (let ((out (get-output-stream-string s))) - (is (search "48;2;255;0;0" out) "background still renders") - ;; No border chars + (is (search "41m" out) "background still renders") (is-false (search "┌" out) "no top-left corner"))))) +#+END_SRC +** Test: box-zero-size + +Verify that a box with zero width and height produces no output +(triggers the early-return guard in ~render-box~). + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (test box-zero-size - "A zero-size box renders nothing" + "A box with any zero dimension renders nothing" (multiple-value-bind (b s) (make-capturing-backend) (let ((bx (make-box :border-style :single :width 0 :height 0))) (compute-layout (box-layout-node bx) 0 0) (render-box bx b) (is (string= (get-output-stream-string s) "") "zero-size box produces no output")))) +#+END_SRC +** Test: box-single-column + +Verify that a box with width 1 produces no output — ~draw-border~ +requires at least 2 columns to draw corner and edge characters. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test box-single-column + "A box with width 1 renders nothing (needs min 2 for border)" + (multiple-value-bind (b s) (make-capturing-backend) + (let ((bx (make-box :border-style :single :width 1 :height 5))) + (compute-layout (box-layout-node bx) 1 5) + (render-box bx b) + (is (string= (get-output-stream-string s) "") + "width=1 box renders nothing")))) +#+END_SRC + +** Test: box-minimum-size + +Verify that a 2x2 box (the minimum viable size for border rendering) +still produces corner characters in the output. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp (test box-minimum-size "A box with minimum non-zero size still renders" (multiple-value-bind (b s) (make-capturing-backend) @@ -113,12 +210,146 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its (is (search "┌" out) "2x2 box still has borders"))))) #+END_SRC -** Implementation +** Test: text-creates-with-defaults -#+BEGIN_SRC lisp +Verify that ~make-text~ with an empty string returns a ~text~ +instance and creates a ~layout-node~. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test text-creates-with-defaults + "A text created with no arguments has reasonable defaults" + (let ((txt (make-text ""))) + (is (typep txt 'text)) + (is (typep (text-layout-node txt) 'layout-node)))) +#+END_SRC + +** Test: text-renders-content + +Verify that text content appears in the captured output stream after +rendering. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test text-renders-content + "A text renders its content at position" + (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-text tx b) + (let ((out (get-output-stream-string s))) + (is (search "Hello" out) "content should appear"))))) +#+END_SRC + +** Test: text-empty-string + +Verify that an empty string produces no output (triggers the +early-return guard in ~render-text~). + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test text-empty-string + "Empty text produces no output" + (multiple-value-bind (b s) (make-capturing-backend) + (let ((tx (make-text "" :width 10 :height 1))) + (compute-layout (text-layout-node tx) 10 1) + (render-text tx b) + (is (string= (get-output-stream-string s) "") + "empty string produces no output")))) +#+END_SRC + +** Test: text-truncates-when-no-wrap + +Verify that ~:wrap-mode :none~ truncates the content string to fit +within the available width, producing only the first N characters. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test text-truncates-when-no-wrap + "Text with wrap-mode :none truncates at width" + (multiple-value-bind (b s) (make-capturing-backend) + (let ((tx (make-text "Hello World" :width 5 :height 1 + :wrap-mode :none))) + (compute-layout (text-layout-node tx) 5 1) + (render-text tx b) + (let ((out (get-output-stream-string s))) + (is (search "Hello" out) "truncated to first 5 chars"))))) +#+END_SRC + +** Test: text-word-wraps + +Verify that ~:wrap-mode :word~ breaks lines at word boundaries, +distributing words across successive rows. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test text-word-wraps + "Text with wrap-mode :word wraps at word boundaries" + (multiple-value-bind (b s) (make-capturing-backend) + (let ((tx (make-text "Hello brave new world" :width 6 :height 3))) + (compute-layout (text-layout-node tx) 6 3) + (render-text tx b) + (let ((out (get-output-stream-string s))) + (is (search "Hello" out) "first line") + (is (search "brave" out) "second line") + (is (search "new" out) "third line"))))) +#+END_SRC + +** Test: text-word-wrap-single-word + +Verify that a single word longer than the available width is +hard-broken at character boundaries into ~max-width~-sized chunks. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test text-word-wrap-single-word + "A word longer than width is hard-broken at max-width" + (multiple-value-bind (b s) (make-capturing-backend) + (let ((tx (make-text "Hello" :width 3 :height 3))) + (compute-layout (text-layout-node tx) 3 3) + (render-text tx b) + (let ((out (get-output-stream-string s))) + (is (search "Hel" out) "first chunk is Hel") + (is (search "lo" out) "second chunk is lo"))))) +#+END_SRC + +** Test: span-creates-with-attributes + +Verify that ~span~ stores its text content and style attributes +correctly, with unset attributes defaulting to ~nil~. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test span-creates-with-attributes + "A span has text and optional style attributes" + (let ((s (span "bold text" :bold t))) + (is (string= (span-text s) "bold text")) + (is-true (span-bold s)) + (is-false (span-italic s)))) +#+END_SRC + +** Test: make-text-with-spans + +Verify that ~make-text~ with ~:spans~ stores the provided span +objects and they are accessible via ~text-spans~. + +#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp +(test make-text-with-spans + "Text with spans stores span objects" + (let* ((sp (list (span "Hello" :bold t) + (span "World" :italic t))) + (tx (make-text "" :spans sp))) + (is (= (length (text-spans tx)) 2)) + (is (string= (span-text (elt (text-spans tx) 0)) "Hello")) + (is-true (span-bold (elt (text-spans tx) 0))))) +#+END_SRC + +* Implementation + +** Box class + +~box~ inherits from ~dirty-mixin~ so changes (resize, title update, +color change) trigger incremental re-render. The ~layout-node~ slot +holds the computed position and size from the layout engine. Border +style, title, alignment, and colors are all configurable slots. + +#+BEGIN_SRC lisp :tangle ../src/components/box.lisp (in-package :cl-tty.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 @@ -128,7 +359,15 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its :accessor box-title-align) (fg :initform nil :initarg :fg :accessor box-fg) (bg :initform nil :initarg :bg :accessor box-bg))) +#+END_SRC +** make-box constructor + +The constructor wraps ~make-instance~ and passes layout parameters +through to the layout node. Width and height are optional; when +omitted the layout engine will compute them from parent constraints. + +#+BEGIN_SRC lisp :tangle ../src/components/box.lisp (defun make-box (&key (border-style :single) title (title-align :left) fg bg width height) @@ -142,7 +381,19 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its :width width :height height :direction :column))) +#+END_SRC +** render-box function + +~render-box~ draws the border at the component's layout position. +It handles zero-size (returns immediately) and optional background +fill. The early return for ~(< w 2)~ is important: ~draw-border~ +requires at least 2 columns of width to draw corner characters. +Title rendering supports ~:left~, ~:center~, and ~:right~ alignment +with automatic truncation when the title is wider than available +content area (width-4 when border is present). + +#+BEGIN_SRC lisp :tangle ../src/components/box.lisp (defun render-box (box backend) "Render BOX at its computed layout position using BACKEND." (let ((ln (box-layout-node box)) @@ -154,16 +405,189 @@ A Box has a =layout-node= slot for positioning via the layout engine. Its (y (layout-node-y ln)) (w (layout-node-width ln)) (h (layout-node-height ln))) - (when (and (zerop w) (zerop h)) + (when (or (zerop w) (zerop h) (< w 2) (< h 2)) (return-from render-box (values))) (when bg (draw-rect backend x y w h :bg bg)) (when bs - (draw-border backend x y w h - :style bs :fg fg :bg bg - :title title - :title-align (box-title-align box))) - (when (and title bs) - ;; Title is rendered by draw-border — nothing extra needed - (values))))) + (draw-border backend x y w h :style bs :fg fg :bg bg)) + (when title + (let* ((content-w (- w 4)) + (tx (+ x 2)) + (ty (+ y (if bs 1 0))) + (ta (box-title-align box)) + (display (subseq title 0 (min (length title) content-w)))) + (case ta + (:center (draw-text backend (+ x (ceiling (- w (length display)) 2)) ty display fg bg)) + (:right (draw-text backend (+ x (- w (length display) 2)) ty display fg bg)) + (t (draw-text backend tx ty display fg bg)))))))) +#+END_SRC + +** Span class + +~span~ represents an inline styled segment within a Text component. +Multiple spans let a single Text contain bold, colored, or italicized +runs. Each style attribute is a separate slot so consumers can +inspect and apply them individually. + +#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +(in-package :cl-tty.box) + +(defclass span () + ((text :initarg :text :accessor span-text) + (bold :initform nil :initarg :bold :accessor span-bold) + (italic :initform nil :initarg :italic :accessor span-italic) + (underline :initform nil :initarg :underline :accessor span-underline) + (reverse :initform nil :initarg :reverse :accessor span-reverse) + (dim :initform nil :initarg :dim :accessor span-dim) + (fg :initform nil :initarg :fg :accessor span-fg) + (bg :initform nil :initarg :bg :accessor span-bg))) +#+END_SRC + +** span constructor + +~span~ is a convenience function for creating ~span~ instances with +keyword arguments for all style attributes. A ~nil~ default means +"inherit/no-change" when merged with parent styling context. + +#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +(defun span (text &key bold italic underline reverse dim fg bg) + (make-instance 'span + :text text :bold bold :italic italic + :underline underline :reverse reverse :dim dim + :fg fg :bg bg)) +#+END_SRC + +** Text class + +~text~ renders a string at a layout position with word-wrapping. +Spans are stored for future per-run styling but the current +implementation renders all content as plain text. It inherits from +~dirty-mixin~ so content, color, or size changes trigger re-render. + +#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +(defclass text (dirty-mixin) + ((layout-node :initform (make-layout-node) :accessor text-layout-node + :initarg :layout-node) + (content :initform "" :initarg :content :accessor text-content) + (spans :initform nil :initarg :spans :accessor text-spans) + (fg :initform nil :initarg :fg :accessor text-fg) + (bg :initform nil :initarg :bg :accessor text-bg) + (wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode))) +#+END_SRC + +** make-text constructor + +~make-text~ is a convenience constructor that accepts layout +dimensions and content parameters. It defaults ~wrap-mode~ to ~:word~ +so text wraps by default, and creates a ~:column~-oriented layout +node. + +#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +(defun make-text (content &key fg bg wrap-mode width height spans) + (make-instance 'text + :content content + :fg fg :bg bg + :wrap-mode (or wrap-mode :word) + :spans spans + :layout-node (make-layout-node :direction :column + :width width :height height))) +#+END_SRC + +** render-text function + +~render-text~ handles both wrap modes. For ~:word~, it calls +~word-wrap~ to break the content into lines, then renders each line +at successive row positions. For ~:none~, it truncates the content to +fit the width in a single line. Empty content or zero dimensions +triggers an early return. + +#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +(defun render-text (text-object backend) + "Render TEXT-OBJECT at its computed layout position using BACKEND." + (let ((ln (text-layout-node text-object)) + (content (text-content text-object)) + (fg (text-fg text-object)) + (bg (text-bg text-object)) + (wrap (text-wrap-mode text-object)) + (spans (text-spans text-object))) + (declare (ignore spans)) + (let ((x (layout-node-x ln)) + (y (layout-node-y ln)) + (w (layout-node-width ln)) + (h (layout-node-height ln))) + (when (or (zerop (length content)) (zerop w) (zerop h)) + (return-from render-text (values))) + (if (eql wrap :none) + (let ((display (subseq content 0 (min (length content) w)))) + (draw-text backend x y display fg bg)) + (let ((lines (word-wrap content w)) + (max-lines h)) + (loop for line in lines + for row from 0 below max-lines + do (draw-text backend x (+ y row) line fg bg))))))) +#+END_SRC + +** Word wrapping utility + +~word-wrap~ implements the line-breaking algorithm. It splits the +input into words, then packs them into lines respecting ~max-width~. +Words that exceed ~max-width~ are hard-broken at character boundaries +in chunks of ~max-width~ to ensure no line exceeds the limit. + +#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +(defun word-wrap (text max-width) + "Split TEXT into lines, each <= MAX-WIDTH chars." + (if (or (zerop max-width) (zerop (length text))) + (list "") + (let ((words (split-string text)) (lines nil) (current nil) (current-len 0)) + (dolist (word words) + (let ((wl (length word))) + (cond ((<= wl max-width) + (if (and current (<= (+ current-len 1 wl) max-width)) + (progn + (push word current) + (incf current-len (1+ wl))) + (progn + (when current + (push (format nil "~{~A~^ ~}" (nreverse current)) lines)) + (setf current (list word)) + (setf current-len wl)))) + (t + (when current + (push (format nil "~{~A~^ ~}" (nreverse current)) lines) + (setf current nil) + (setf current-len 0)) + (loop for i from 0 below wl by max-width + do (push (subseq word i (min (+ i max-width) wl)) lines)))))) + (when current + (push (format nil "~{~A~^ ~}" (nreverse current)) lines)) + (or (nreverse lines) (list ""))))) +#+END_SRC + +** split-string utility + +~split-string~ tokenizes on whitespace characters (space, tab, +newline). It uses ~position-if~ to find delimiters and builds the +word list iteratively. Consecutive delimiters are collapsed +(only one advance per delimiter character). + +#+BEGIN_SRC lisp :tangle ../src/components/text.lisp +(defun split-string (string) + "Split STRING into words separated by whitespace." + (loop with words = nil + with start = 0 + with len = (length string) + while (< start len) + do (let ((ws-start (position-if (lambda (c) (find c '(#\Space #\Tab #\Newline))) + string :start start))) + (if ws-start + (progn + (when (> ws-start start) + (push (subseq string start ws-start) words)) + (setf start (1+ ws-start))) + (progn + (push (subseq string start) words) + (setf start len)))) + finally (return (nreverse words)))) #+END_SRC diff --git a/org/container-package.org b/org/container-package.org new file mode 100644 index 0000000..80ced07 --- /dev/null +++ b/org/container-package.org @@ -0,0 +1,127 @@ +#+TITLE: Container Package +#+STARTUP: content +#+FILETAGS: :cl-tty:container: + +* Overview + +The ~cl-tty.container~ package defines the container component types: +ScrollBox and TabBar. It uses ~cl-tty.backend~, ~cl-tty.box~, +~cl-tty.layout~, and ~cl-tty.input~. + +The package exports both ScrollBox and TabBar classes, constructors, +accessors, and navigation functions. + +* Why a Separate Package? + +The base ~cl-tty.box~ package was designed for the fundamental +renderable types — box, text, spans, dirty-tracking, the render +pipeline, and the theme engine. These are the building blocks that +virtually every component depends on. Container components — +ScrollBox and TabBar — are higher-level composite widgets with +specific behavioral contracts (viewport scrolling, tab navigation, +keyboard dispatch) that are not needed by every component user. + +Separating them into ~cl-tty.container~ achieves two things: + + 1. It keeps ~cl-tty.box~ lean. Users who only need basic + renderables (boxes, text) do not pull in scroll-logic or + tab-navigation code. This is especially important for the + test suite — container tests have their own setup, backend + capture, and assertion patterns that are unrelated to the + base component tests. + + 2. It establishes a clean dependency boundary. ~cl-tty.box~ + depends only on ~cl-tty.backend~ and ~cl-tty.layout~. + Container components additionally depend on ~cl-tty.input~, + because TabBar handles key events. By putting container + code in its own package, we avoid creating a circular or + incidental dependency between the input system and the + base component layer. + +* What the Container Package Provides + +The package exports two full component families: + +- **ScrollBox**: A viewport-based container that holds a list of + child components and provides vertical/horizontal scrolling with + viewport culling (only visible children are rendered), scrollbar + display, sticky-scroll (auto-scroll to bottom on new content), + and scroll-offset clamping. ScrollBox inherits ~dirty-mixin~, + implements the component protocol (~render~, ~component-children~, + ~component-layout-node~), and integrates with the layout engine. + Its constructor ~make-scroll-box~ accepts ~:children~, + ~:scroll-y~, ~:scroll-x~, and ~:sticky-scroll-p~ keyword args. + +- **TabBar**: A horizontal tab-navigation widget that manages a + list of named tabs, tracks the active tab, and dispatches + keyboard events (Left/Right for prev/next). TabBar also inherits + ~dirty-mixin~ and implements ~render~ and ~component-layout-node~. + It provides ~tab-bar-add~ for dynamic tab creation, ~tab-bar-next~ + / ~tab-bar-prev~ for cycling, ~tab-bar-select~ for direct + activation, and ~tab-bar-handle-key~ for keyboard integration. + +Both components export the generic ~render~ method, allowing the +rendering pipeline to dispatch ~(render instance backend)~ uniformly. + +* Design Decisions: ScrollBox and TabBar in One Package + +ScrollBox and TabBar are very different widgets — one manages a +scrollable viewport, the other renders a row of selectable labels. +They are kept in the same package rather than split into +~cl-tty.scroll-box~ and ~cl-tty.tab-bar~ for several reasons: + + 1. **Shared dependencies**: Both components :use the same four + packages (~cl-tty.backend~, ~cl-tty.box~, ~cl-tty.layout~, + ~cl-tty.input~). They both inherit from ~dirty-mixin~ and + implement the component protocol. A shared package avoids + duplicating the ~:use~ and ~:export~ boilerplate. + + 2. **Co-located tests**: The test suite + (~tests/scrollbox-tabbar-tests.lisp~) tests both components + in one file and one FiveAM suite. They share test helpers, + backend-capture patterns, and the same package dependency. + Keeping them in one source package means the test defpackage + only needs one ~:use~ clause for the container, and symbols + from both components are visible together. + + 3. **Common contract**: Both components are "containers" in the + architectural sense — they manage a collection of sub-items + (children or tabs) and provide navigation over them. A + TabBar is conceptually a horizontal container of selectable + entries; a ScrollBox is a vertical container with scroll. + Placing them under the same ~:cl-tty.container~ namespace + signals to users that these are the composite widget types, + as opposed to the atomic renderables in ~:cl-tty.box~. + + 4. **Practical usage patterns**: In typical TUI applications, a + TabBar switches between views and a ScrollBox displays the + content of each view. They are often used together in the + same composition. Having them in one package eliminates + cross-package qualification or redundant ~:import-from~ + declarations when building combined layouts. + +If either component grows substantial internal logic in the future +(say, ScrollBox develops virtual scrolling, infinite loading, or +its own input model), it could be split into its own package at +that point. The current scope favors simplicity and co-location. + +* Package Definition + +#+BEGIN_SRC lisp :tangle ../src/components/container-package.lisp +(defpackage :cl-tty.container + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) + (:export + ;; ScrollBox + #:scroll-box #:make-scroll-box + #:scroll-box-scroll-y #:scroll-box-scroll-x + #:scroll-box-children + #:scroll-by #:sticky-scroll-p + #:clamp-scroll + ;; TabBar + #:tab-bar #:make-tab-bar + #:tab-bar-active #:tab-bar-tabs + #:tab-bar-add #:tab-bar-next #:tab-bar-prev + #:tab-bar-select #:tab-bar-handle-key + ;; Rendering + #:render)) +#+END_SRC diff --git a/org/detection.org b/org/detection.org index e5ffc97..0199356 100644 --- a/org/detection.org +++ b/org/detection.org @@ -36,6 +36,9 @@ If detection can't determine modern capability, it falls back to - ~*detected-backend*~ — variable Cache for detection result. ~nil~ = not yet detected. +- ~query-terminal~ — function + Low-level escape sequence query helper shared by probes. + * Plan See =docs/plans/2026-05-11-terminal-detection.md= for implementation tasks. @@ -48,7 +51,7 @@ See =docs/plans/2026-05-11-terminal-detection.md= for implementation tasks. * Tests #+BEGIN_SRC lisp :tangle no -;; Tests are manually added to backend/tests.lisp +;; Tests are manually added to src/backend/tests.lisp (def-test detection-returns-backend-instance () (let ((be (cl-tty.backend:detect-backend))) (is-true (typep be 'cl-tty.backend:backend)))) @@ -66,20 +69,36 @@ See =docs/plans/2026-05-11-terminal-detection.md= for implementation tasks. Detection functions are added to the existing ~cl-tty.backend~ package. No new package definition needed. -** Environment probe +** Detection cache -Check ~COLORTERM~ first — it's the simplest and most reliable signal. +The ~*detected-backend*~ special variable holds the cached backend instance +after the first successful detection. Initializing it to ~nil~ gives downstream +code a simple truthiness check — ~(or *detected-backend* ...)~ — so that +~detect-backend~ returns immediately on re-entry without re-running probes. -#+BEGIN_SRC lisp :tangle ../backend/detection.lisp +Using a global variable rather than a closure or class slot keeps the detection +path stateless and trivially resettable for testing: binding ~*detected-backend*~ +to ~nil~ forces a fresh detection run. + +#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp (in-package :cl-tty.backend) -;;; ─── Detection cache ──────────────────────────────────────────────────────── - (defvar *detected-backend* nil "Cached backend instance from detect-backend. Nil = not yet detected.") +#+END_SRC -;;; ─── Environment probe ────────────────────────────────────────────────────── +** Environment probe +The ~COLORTERM~ environment variable is the single most reliable signal for +truecolor support. It is set by modern terminal emulators (kitty, Alacritty, +GNOME Terminal, iTerm2, Windows Terminal) and has near-zero false-positive +rate. Checking it first avoids the I/O costs and race conditions of escape +sequence queries. + +Case-insensitive matching via ~char-equal~ handles variances across platforms +(GNOME Terminal uses ~truecolor~, some Windows builds use ~24bit~). + +#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp (defun detect-backend-by-env () "Check COLORTERM environment variable for modern terminal support. Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." @@ -92,42 +111,68 @@ Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." ** TTY probe -Check if stdout is connected to a terminal (not a pipe or file). +The ~interactive-stream-p~ function from the CL standard reliably distinguishes +real terminals from pipes and redirected files. If stdout is not a terminal, +escape sequence queries will hang or produce garbage, so this check gates all +further (I/O-dependent) probes. Must happen before ~detect-backend-by-da1~. -#+BEGIN_SRC lisp :tangle ../backend/detection.lisp -;;; ─── TTY probe ────────────────────────────────────────────────────────────── +Testing this predicate first also avoids wasting time on DA1 queries when the +output is consumed by a test runner, CI pipeline, or pipe. +#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp (defun detect-backend-by-tty () "Check if stdout is a real terminal (not a pipe/redirect). Returns T if stdout is interactive, nil otherwise." (interactive-stream-p *standard-output*)) #+END_SRC -** DA1 terminal query (best-effort) +** Low-level terminal query helper -Send a DA1 (Device Attributes) query and briefly listen for a response. -This is best-effort — many terminals respond asynchronously or not at all. +The ~query-terminal~ function encapsulates the mechanics of sending an escape +sequence and collecting a response within a short timeout. Writing to +~*standard-output*~ and reading from ~*standard-input*~ matches how terminal +emulators actually deliver DA1/DA3 response bytes — they arrive on stdin, not +on any query I/O stream. The original implementation used ~*query-io*~ for +both sides, which silently failed on some emulators. -#+BEGIN_SRC lisp :tangle ../backend/detection.lisp -;;; ─── DA1 terminal query ───────────────────────────────────────────────────── +Using ~listen~ in a polling loop with ~read-char-no-hang~ captures whatever +bytes arrive within the timeout without blocking. The ~0.1~ second default +strikes a balance between responsiveness and reliability: fast enough to avoid +noticeable delay in interactive use, long enough for most terminals to reply. +#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp (defun query-terminal (query &optional (timeout 0.1)) "Send QUERY string to terminal and return any response received within TIMEOUT seconds. Returns the response string, or nil if no response." - (write-string query *query-io*) - (force-output *query-io*) + (write-string query *standard-output*) + (force-output *standard-output*) (sleep timeout) (let ((response (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) - (loop while (listen *query-io*) - do (vector-push-extend (read-char-no-hang *query-io*) response)) + (loop while (listen *standard-input*) + do (vector-push-extend (read-char-no-hang *standard-input*) response)) (when (plusp (length response)) response))) +#+END_SRC +** DA1 capability probe + +The DA1 (Device Attributes) escape sequence (~ESC[c~) is an xterm-standard +query that asks the terminal to report its feature set. Modern terminals +(notably Kitty, which returns code 62) advertise their capabilities in the +response. Searching for ~?62~ in the raw response is a heuristic — it targets +Kitty's protocol extension identifier while being short enough to match +variants across terminal implementations. + +This probe is best-effort: many terminals do not respond within the timeout, +and some return different codes for the same capabilities. A ~nil~ result from +this function should never prevent fallback detection via environment variables. + +#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp (defun detect-backend-by-da1 () "Send DA1 (ESC[c) query and check for kitty terminal response code. Returns T if terminal reports kitty compatibility codes." - (let ((response (query-terminal (format nil "~C[c" #\Esc)))) + (let ((response (query-terminal (format nil "~C[c" (code-char 27))))) (when response ;; DA1 response format: ESC [ ? digits ; digits c ;; Kitty reports code 62 in the response @@ -136,11 +181,19 @@ Returns T if terminal reports kitty compatibility codes." ** Orchestrator -Tie all probes together into ~detect-backend~. +The ~detect-backend~ function ties all probes together with a short-circuit +caching strategy. On first call, it: -#+BEGIN_SRC lisp :tangle ../backend/detection.lisp -;;; ─── Orchestrator ─────────────────────────────────────────────────────────── +1. Checks if stdout is a real TTY (fast, gates all I/O) +2. Checks ~COLORTERM~ (fast, most reliable signal) +3. Falls back to DA1 query (slow, best-effort, skipped if env check passed) +The ~and~ / ~or~ structure naturally short-circuits: if ~detect-backend-by-tty~ +returns nil, the expensive DA1 query never runs. If ~detect-backend-by-env~ +returns ~:modern~, the DA1 query is skipped. The result is cached in +~*detected-backend*~ so subsequent calls are effectively free. + +#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp (defun detect-backend () "Auto-detect the appropriate backend for the current terminal. Returns a backend instance (modern-backend or simple-backend). diff --git a/org/dialog.org b/org/dialog.org index 688b85d..07b9c14 100644 --- a/org/dialog.org +++ b/org/dialog.org @@ -45,250 +45,16 @@ duration. They stack in the top-right corner. - ~toast~ component — transient notification with variant color - ~(toast message &key variant duration)~ — fire-and-forget toast -* Code structure +* Package definition -** Dialog class +The ~cl-tty.dialog~ package uses the backend, input, and select +subsystems. All public symbols are exported for user convenience. ---- per-function: dialog-class - -The dialog class stores the dialog's content (a component to render -inside the dialog panel), its size preset, title, and callbacks. - -#+BEGIN_SRC lisp :tangle no -(defclass dialog () - ((title :initarg :title :accessor dialog-title) - (size :initarg :size :initform :medium :accessor dialog-size) - (content :initarg :content :accessor dialog-content) - (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) -#+END_SRC - ---- per-function: dialog-size-pixels - -Helper to convert size keyword to pixel dimensions. - -#+BEGIN_SRC lisp :tangle no -(defun dialog-size-pixels (size) - (case size - (:small (values 40 8)) - (:medium (values 60 16)) - (:large (values 88 24)) - (t (values 60 16)))) -#+END_SRC - ---- per-function: render-dialog - -Render a dialog: backdrop (dimmed full-screen), then centered panel. - -#+BEGIN_SRC lisp :tangle no -(defun render-dialog (dialog screen w h) - (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) - (let ((x (floor (- w dw) 2)) - (y (floor (- h dh) 2))) - ;; Backdrop — draw dim characters over full screen - (dotimes (row h) - (dotimes (col w) - (backend-write screen col row " " :bg :dim))) - ;; Panel border - (draw-border screen x y dw dh :single :title (dialog-title dialog)) - ;; Content area (inset by 1 on each side) - (when (dialog-content dialog) - (render-component (dialog-content dialog) screen (1+ x) (1+ y) (- dw 2) (- dh 2)))))) -#+END_SRC -*** push-dialog / pop-dialog - -~push-dialog~ pushes a dialog onto =*dialog-stack*=. ~pop-dialog~ pops the -top dialog and calls its ~:on-dismiss~ callback if set. - -#+BEGIN_SRC lisp :tangle no -(defun push-dialog (dialog) - (push dialog *dialog-stack*) - dialog) -#+END_SRC - ---- per-function: pop-dialog - -Pop the top dialog, fire its on-dismiss callback. - -#+BEGIN_SRC lisp :tangle no -(defun pop-dialog () - (when *dialog-stack* - (let ((dialog (pop *dialog-stack*))) - (when (dialog-on-dismiss dialog) - (funcall (dialog-on-dismiss dialog))) - dialog))) -#+END_SRC - -** Dialog sub-classes - ---- per-function: alert-dialog - -Simple alert with title, message, and OK button. The button is a -Select with a single "OK" option. - -#+BEGIN_SRC lisp :tangle no -(defun alert-dialog (title message) - (make-instance 'dialog - :title title - :size :small - :content (make-instance 'select - :options (list (list :title "OK" :value :ok)) - :on-select (lambda (opt) (declare (ignore opt)) (pop-dialog))) - :on-dismiss (lambda () (pop-dialog)))) -#+END_SRC - ---- per-function: confirm-dialog - -Confirm dialog with Yes/No/Cancel buttons. Returns :yes or :no -via the on-yes/on-no callbacks. - -#+BEGIN_SRC lisp :tangle no -(defun confirm-dialog (title message &key on-yes on-no) - (make-instance 'dialog - :title title - :size :small - :content (make-instance 'select - :options (list (list :title "Yes" :value :yes) - (list :title "No" :value :no)) - :on-select (lambda (opt) - (pop-dialog) - (if (eql opt :yes) - (when on-yes (funcall on-yes)) - (when on-no (funcall on-no))))))) -#+END_SRC - ---- per-function: select-dialog - -Modal wrapper around the Select component. - -#+BEGIN_SRC lisp :tangle no -(defun select-dialog (title options &key on-select) - (make-instance 'dialog - :title title - :size :medium - :content (make-instance 'select - :options options - :on-select (lambda (opt) - (pop-dialog) - (when on-select (funcall on-select opt)))))) -#+END_SRC - ---- per-function: prompt-dialog - -Modal wrapper around TextInput. - -#+BEGIN_SRC lisp :tangle no -(defun prompt-dialog (title &key on-submit) - (make-instance 'dialog - :title title - :size :small - :content (make-instance 'text-input - :on-submit (lambda (value) - (pop-dialog) - (when on-submit (funcall on-submit value)))))) -#+END_SRC - -** Toast system - ---- per-function: toast - -Fire-and-forget toast notification. Creates a toast component, -adds it to the toast list, and schedules auto-dismissal. - -#+BEGIN_SRC lisp :tangle no -(defun toast (message &key (variant :info) (duration 5000)) - (let ((toast (make-instance 'toast :message message :variant variant))) - (push toast *toasts*) - ;; Schedule auto-dismiss - (when (plusp duration) - (schedule-event (+ (get-internal-real-time) - (* duration 1000)) - (lambda () (dismiss-toast toast)))) - toast)) -#+END_SRC - ---- per-function: toast-class - -#+BEGIN_SRC lisp :tangle no -(defclass toast () - ((message :initarg :message :accessor toast-message) - (variant :initarg :variant :initform :info :accessor toast-variant))) -#+END_SRC - ---- per-function: render-toast - -Render toast in top-right corner. Max 60 cols. Shows colored -left border based on variant. - -#+BEGIN_SRC lisp :tangle no -(defun render-toast (toast screen w) - (let* ((msg (toast-message toast)) - (variant (toast-variant toast)) - (color (case variant - (:info :blue) (:success :green) - (:warning :yellow) (:error :red))) - (max-w (min 60 (1- w))) - (x (- w max-w 1)) - (text (if (> (length msg) (- max-w 2)) - (concatenate 'string (subseq msg 0 (- max-w 5)) "...") - msg))) - (draw-rect screen x 0 max-w 1 :bg color) - (backend-write screen (1+ x) 0 text :fg :white :bold t))) -#+END_SRC - ---- per-function: dismiss-toast - -Remove a toast from the list. - -#+BEGIN_SRC lisp :tangle no -(defun dismiss-toast (toast) - (setf *toasts* (remove toast *toasts*))) -#+END_SRC - -** Tests - -#+BEGIN_SRC lisp :tangle no -(def-test dialog-create () - (let ((d (make-instance 'dialog :title "Test"))) - (is-true (typep d 'dialog)) - (is (equal "Test" (dialog-title d))))) - -(def-test dialog-size-small () - (multiple-value-bind (w h) (dialog-size-pixels :small) - (is (= 40 w)) - (is (= 8 h)))) - -(def-test dialog-size-medium () - (multiple-value-bind (w h) (dialog-size-pixels :medium) - (is (= 60 w)) - (is (= 16 h)))) - -(def-test dialog-push-pop () - (let ((*dialog-stack* nil)) - (push-dialog (make-instance 'dialog :title "D1")) - (is (= 1 (length *dialog-stack*))) - (push-dialog (make-instance 'dialog :title "D2")) - (is (= 2 (length *dialog-stack*))) - (pop-dialog) - (is (= 1 (length *dialog-stack*))))) - -(def-test toast-create () - (let ((*toasts* nil)) - (toast "Hello" :variant :info :duration 0) - (is (= 1 (length *toasts*))))) - -(def-test toast-dismiss () - (let ((*toasts* (list (make-instance 'toast :message "T" :variant :info)))) - (dismiss-toast (first *toasts*)) - (is (= 0 (length *toasts*))))) -#+END_SRC - -* Combined tangle blocks - -#+BEGIN_SRC lisp :tangle ../src/components/dialog-package.lisp :noweb no +#+BEGIN_SRC lisp :tangle ../src/components/dialog-package.lisp ;;; dialog-package.lisp — Package definition for cl-tty.dialog (defpackage :cl-tty.dialog - (:use :cl :cl-tty.input :cl-tty.select) + (:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select) (:export #:dialog #:dialog-title @@ -312,62 +78,123 @@ Remove a toast from the list. #:*toasts*)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp :noweb no -;;; dialog.lisp — Dialog System + Toast for cl-tty +* Special variables +** *dialog-stack* + +The active dialog stack. ~push-dialog~ conses onto this list; +~pop-dialog~ pops it and fires the ~:on-dismiss~ callback. Each screen +should bind its own instance so multiple screens can have independent +dialog states. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (in-package :cl-tty.dialog) -;; ─── Special variables ──────────────────────────────────────────────────────── - (defvar *dialog-stack* nil "Stack of active dialogs. (list) of dialog instances.") +#+END_SRC +** *toasts* + +List of active toast notifications. ~toast~ pushes, ~dismiss-toast~ +removes by identity. The render loop walks this list to draw toasts in +the top-right corner. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defvar *toasts* nil "List of active toast notifications.") +#+END_SRC -;; ─── Dialog class ───────────────────────────────────────────────────────────── +* Dialog class +The core dialog class stores a title, a size preset, the content +component to render inside the panel, and an optional ~:on-dismiss~ +callback invoked when the dialog is popped. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defclass dialog () ((title :initarg :title :accessor dialog-title) (size :initarg :size :initform :medium :accessor dialog-size) (content :initarg :content :initform nil :accessor dialog-content) (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) +#+END_SRC -(defun dialog-size-pixels (size) - (case size - (:small (values 40 8)) - (:medium (values 60 16)) - (:large (values 88 24)) - (t (values 60 16)))) +** dialog-size-pixels +Converts a size keyword (~:small~, ~:medium~, ~:large~) to pixel +dimensions. Accepts optional ~max-w~ / ~max-h~ to clamp the result to +terminal bounds, preventing off-screen overflow (fixed in v1.0.0). + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp +(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24)) + (multiple-value-bind (dw dh) + (case size + (:small (values 40 8)) + (:medium (values 60 16)) + (:large (values 88 24)) + (t (values 60 16))) + (values (min dw max-w) (min dh max-h)))) +#+END_SRC + +** render-dialog + +Renders a dialog: draws a dimmed full-screen backdrop using +~draw-rect~, then draws the bordered dialog panel centered on screen. +Content is rendered via ~draw-text~ inside the panel area. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun render-dialog (dialog screen w h) - (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) + (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h) (let ((x (floor (- w dw) 2)) (y (floor (- h dh) 2))) ;; Backdrop — dim the full screen (dotimes (row h) (draw-rect screen 0 row w 1 :bg :bright-black)) ;; Dialog panel - (draw-border screen x y dw dh :single :title (dialog-title dialog)) + (draw-border screen x y dw dh :style :single :title (dialog-title dialog)) (when (dialog-content dialog) ;; Content rendering delegated to component system (draw-text screen (1+ x) (1+ y) (format nil "~a" (dialog-content dialog)) :white :default))))) +#+END_SRC +** push-dialog + +Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun push-dialog (dialog) (push dialog *dialog-stack*) dialog) +#+END_SRC +** pop-dialog + +Pops the top dialog from the stack. If an ~:on-dismiss~ callback is +set on the dialog, it is called before returning. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun pop-dialog () (when *dialog-stack* (let ((dialog (pop *dialog-stack*))) (when (dialog-on-dismiss dialog) (funcall (dialog-on-dismiss dialog))) dialog))) +#+END_SRC -;; ─── Dialog sub-classes ────────────────────────────────────────────────────── +* Dialog convenience constructors +These factory functions create common dialog variants by composing the +~dialog~ class with interactive components (~select~, ~text-input~). + +** alert-dialog + +Simple alert with title, message, and an OK button. The button is a +~select~ with a single "OK" option. Dismissing fires ~pop-dialog~ on +both selection and backdrop dismiss. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun alert-dialog (title message) (make-instance 'dialog :title title @@ -376,7 +203,14 @@ Remove a toast from the list. :options (list (list :title "OK" :value :ok)) :on-select (lambda (opt) (declare (ignore opt)) (pop-dialog))) :on-dismiss (lambda () (pop-dialog)))) +#+END_SRC +** confirm-dialog + +Confirm dialog with Yes/No buttons. Returns ~:yes~ or ~:no~ via the +~on-yes~/~on-no~ callbacks. The dialog auto-dismisses on selection. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun confirm-dialog (title message &key on-yes on-no) (make-instance 'dialog :title title @@ -389,7 +223,14 @@ Remove a toast from the list. (if (eql opt :yes) (when on-yes (funcall on-yes)) (when on-no (funcall on-no))))))) +#+END_SRC +** select-dialog + +Modal wrapper around the ~select~ component. Presents a list of options +and calls ~on-select~ with the chosen value after dismissing. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun select-dialog (title options &key on-select) (make-instance 'dialog :title title @@ -399,7 +240,14 @@ Remove a toast from the list. :on-select (lambda (opt) (pop-dialog) (when on-select (funcall on-select opt)))))) +#+END_SRC +** prompt-dialog + +Modal wrapper around ~text-input~. Shows a text input field inside the +dialog and calls ~on-submit~ with the entered value after dismissing. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun prompt-dialog (title &key on-submit) (make-instance 'dialog :title title @@ -408,13 +256,31 @@ Remove a toast from the list. :on-submit (lambda (value) (pop-dialog) (when on-submit (funcall on-submit value)))))) +#+END_SRC -;; ─── Toast system ───────────────────────────────────────────────────────────── +* Toast system +Transient notifications that appear in the top-right corner. Each toast +has a message and a variant that determines its color (~:info~, +~:success~, ~:warning~, ~:error~). + +** toast class + +Lightweight class storing the message text and variant keyword. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defclass toast () ((message :initarg :message :accessor toast-message) (variant :initarg :variant :initform :info :accessor toast-variant))) +#+END_SRC +** render-toast + +Draws a toast in the top-right corner of the screen. The message is +truncated to 60 columns with an ellipsis if necessary. The background +color reflects the variant. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun render-toast (toast screen w) (let* ((msg (toast-message toast)) (variant (toast-variant toast)) @@ -428,18 +294,40 @@ Remove a toast from the list. msg))) (draw-rect screen x 0 max-w 1 :bg color) (draw-text screen (1+ x) 0 text :white color :bold t))) +#+END_SRC +** toast (function) + +Fire-and-forget toast notification. Creates a ~toast~ instance, pushes +it onto =*toasts*~, and optionally schedules auto-dismissal via +~dismiss-toast~ when ~duration~ is positive. + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun toast (message &key (variant :info) (duration 0)) (let ((toast (make-instance 'toast :message message :variant variant))) (push toast *toasts*) (when (plusp duration) (dismiss-toast toast)) toast)) +#+END_SRC +** dismiss-toast + +Removes a toast from =*toasts*~ by identity (~remove~ with default +~:test #'eql~ compares by pointer for CLOS objects). + +#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp (defun dismiss-toast (toast) (setf *toasts* (remove toast *toasts*))) #+END_SRC -#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp :noweb no +* Tests + +Test suite using FiveAM. Each test exercises one function or +interaction. + +** Test package and suite + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp ;;; dialog-tests.lisp — Tests for cl-tty.dialog (defpackage :cl-tty-dialog-test @@ -449,22 +337,47 @@ Remove a toast from the list. (def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog") (in-suite dialog-suite) +#+END_SRC +** dialog-create + +Basic dialog instantiation — verifies ~make-instance~ and accessors. + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp (def-test dialog-create () (let ((d (make-instance 'dialog :title "Test"))) (is-true (typep d 'dialog)) (is (equal "Test" (dialog-title d))))) +#+END_SRC +** dialog-size-small + +~dialog-size-pixels~ returns the correct dimensions for ~:small~. + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp (def-test dialog-size-small () (multiple-value-bind (w h) (dialog-size-pixels :small) (is (= 40 w)) (is (= 8 h)))) +#+END_SRC +** dialog-size-medium + +~dialog-size-pixels~ returns the correct dimensions for ~:medium~. + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp (def-test dialog-size-medium () (multiple-value-bind (w h) (dialog-size-pixels :medium) (is (= 60 w)) (is (= 16 h)))) +#+END_SRC +** dialog-push-pop + +Verifies stack operations: push adds to =*dialog-stack*~, pop removes +the top element. + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp (def-test dialog-push-pop () (let ((*dialog-stack* nil)) (push-dialog (make-instance 'dialog :title "D1")) @@ -473,12 +386,24 @@ Remove a toast from the list. (is (= 2 (length *dialog-stack*))) (pop-dialog) (is (= 1 (length *dialog-stack*))))) +#+END_SRC +** toast-create + +Verifies that ~toast~ pushes onto =*toasts*~. + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp (def-test toast-create () (let ((*toasts* nil)) (toast "Hello" :variant :info :duration 0) (is (= 1 (length *toasts*))))) +#+END_SRC +** toast-dismiss + +Verifies that ~dismiss-toast~ removes the toast from =*toasts*~. + +#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp (def-test toast-dismiss () (let ((*toasts* (list (make-instance 'toast :message "T" :variant :info)))) (dismiss-toast (first *toasts*)) diff --git a/org/dirty.org b/org/dirty.org new file mode 100644 index 0000000..60dec8d --- /dev/null +++ b/org/dirty.org @@ -0,0 +1,143 @@ +#+TITLE: Dirty Tracking +#+STARTUP: content +#+FILETAGS: :cl-tty:components: + +* Overview + +The dirty tracking module provides a mixin class and protocol for +marking components as needing re-render. This is the foundation of +the incremental rendering pipeline. + +Without dirty tracking, every frame would re-render every component. +With it, only components that changed (and their ancestors, for layout +recomputation) get re-processed. The makes the difference between a +60fps terminal UI and a flickering mess. + +This module is intentionally minimal: a single mixin class and two +generic functions. The complexity lives in the propagation logic +(see ~render.lisp~), but the dirty state itself is trivial. + +* Contract + +** ~dirty-mixin~ + +A class that adds a ~dirty~ slot. Components that need dirty tracking +inherit from this. + +- ~(dirty-p component)~ — returns ~t~ if the component needs re-render, + ~nil~ if it's up-to-date. New instances start dirty (~t~). + +** ~mark-clean~ + +- ~(mark-clean component)~ — sets dirty to ~nil~. Called after rendering. +- Specialized on ~dirty-mixin~; default method is a no-op. + +** ~mark-dirty~ + +- ~(mark-dirty component)~ — sets dirty to ~t~. Called when the component's + state changes (user typed a character, selection changed, etc.). +- Specialized on ~dirty-mixin~; default method is a no-op. + +* Tests + +** ~dirty-mixin-default-is-dirty~ + +This test verifies that a freshly created ~dirty-mixin~ instance starts +with ~dirty~ set to ~t~. This is the core invariant of the dirty tracking +system — without this, the first render pass would skip new components, +making them invisible until something explicitly marked them dirty. + +#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp +(in-package :cl-tty-box-test) +(in-suite box-suite) + +(test dirty-mixin-default-is-dirty + "A dirty-mixin starts as dirty" + (let ((c (make-instance 'dirty-mixin))) + (is-true (dirty-p c) "new component should be dirty"))) +#+END_SRC + +** ~mark-clean-clears-dirty~ + +This test checks that calling ~mark-clean~ on a dirty component sets its +~dirty-p~ to ~nil~. This is called after a component is rendered, +signaling that it is up-to-date and does not need re-render until the +next change. Without this, every component would be re-rendered every +frame. + +#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp +(in-package :cl-tty-box-test) +(in-suite box-suite) + +(test mark-clean-clears-dirty + "mark-clean sets dirty to nil" + (let ((c (make-instance 'dirty-mixin))) + (mark-clean c) + (is-false (dirty-p c) "after mark-clean, should not be dirty"))) +#+END_SRC + +** ~mark-dirty-sets-dirty~ + +This test verifies that a component that has been cleaned can be +re-marked as dirty via ~mark-dirty~. This exercises the full lifecycle: +new (dirty) → render (mark-clean) → state change (mark-dirty) → render +again. It ensures the dirty flag is not a one-shot toggle. + +#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp +(in-package :cl-tty-box-test) +(in-suite box-suite) + +(test mark-dirty-sets-dirty + "mark-dirty sets dirty to t" + (let ((c (make-instance 'dirty-mixin))) + (mark-clean c) + (mark-dirty c) + (is-true (dirty-p c) "after mark-dirty, should be dirty again"))) +#+END_SRC + +* Implementation + +The entire module is a class and two generic functions. The design +choice: make this a separate mixin rather than part of the base +~component~ class. This lets non-UI objects (layout nodes, render +commands) opt into dirty tracking without inheriting from component. + +#+BEGIN_SRC lisp :tangle ../src/components/dirty.lisp +(in-package :cl-tty.box) + +;; ── Dirty Tracking ───────────────────────────────────────────── + +(defclass dirty-mixin () + ((dirty :initform t :accessor dirty-p))) +#+END_SRC + +The ~initform t~ is critical: new components are dirty by default so +the first render pass doesn't skip them. If this default were ~nil~, +new components would be invisible until something explicitly marked +them dirty. + +#+BEGIN_SRC lisp :tangle ../src/components/dirty.lisp +(defgeneric mark-clean (component) + (:method ((c dirty-mixin)) + (setf (dirty-p c) nil))) +#+END_SRC + +~mark-clean~ is called at the end of a render cycle. The default +method (for non-dirty-mixin components) is a no-op — they have no +dirty state to clear. + +#+BEGIN_SRC lisp :tangle ../src/components/dirty.lisp +(defgeneric mark-dirty (component) + (:method ((c dirty-mixin)) + (setf (dirty-p c) t))) +#+END_SRC + +~mark-dirty~ is called whenever the component's visual state changes. +Together with ~propagate-dirty~ in the render pipeline, this ensures +that when a text input gains a character, not just the input component +but its containing box, tab, and screen all get re-rendered. + +These are generic functions (not plain functions) so other mixins or +base classes can provide their own methods. The ~:method~ on +~dirty-mixin~ provides the default implementation for anything that +includes this mixin. diff --git a/org/framebuffer.org b/org/framebuffer.org index e9e6e12..b56c920 100644 --- a/org/framebuffer.org +++ b/org/framebuffer.org @@ -40,29 +40,59 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. 4. Write tests 5. Run, commit -* Tests +* Tests (reference documentation, not tangled) #+BEGIN_SRC lisp :tangle no ;; Tests for framebuffer pipeline — manually added to tests/framebuffer-tests.lisp +#+END_SRC +** Test package and suite setup + +Setting up the test package with FiveAM, importing the rendering and backend +packages for use in all subsequent tests. + +#+BEGIN_SRC lisp :tangle no (defpackage :cl-tty-framebuffer-test (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) (in-package :cl-tty-framebuffer-test) (def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests") (in-suite framebuffer-suite) +#+END_SRC +** Test: make-framebuffer creates correct size + +Verify that the framebuffer constructor produces an array with the expected +dimensions. Height should match the first dimension (rows), width the second +dimension (columns). + +#+BEGIN_SRC lisp :tangle no (test make-framebuffer-creates-correct-size (let ((fb (make-framebuffer 80 24))) (is (= 24 (framebuffer-height fb))) (is (= 80 (framebuffer-width fb))))) +#+END_SRC +** Test: cell defaults are space + +Cells created via MAKE-CELL with no arguments should default to a space +character with nil foreground and background — a blank, unstyled cell. + +#+BEGIN_SRC lisp :tangle no (test cell-defaults-are-space (let ((cell (aref (make-framebuffer 10 10) 0 0))) (is (eql #\space (cell-char cell))) (is (null (cell-fg cell))) (is (null (cell-bg cell))))) +#+END_SRC +** Test: draw-text on framebuffer sets cells + +Drawing a string into the framebuffer backend should set the character and +foreground color at each cell position. Characters should appear at the expected +(x, y) offsets. + +#+BEGIN_SRC lisp :tangle no (test draw-text-on-fb-sets-cells (let ((fb (make-framebuffer-backend))) (draw-text fb 2 3 "abc" :red nil) @@ -71,7 +101,15 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (is (eql #\b (cell-char (aref cells 3 3)))) (is (eql #\c (cell-char (aref cells 3 4)))) (is (eql :red (cell-fg (aref cells 3 2))))))) +#+END_SRC +** Test: draw-text clips at bounds + +When drawing text that extends past the right edge of the framebuffer, cells +beyond the width should remain unchanged (space characters). This prevents +buffer overflow and undefined memory access. + +#+BEGIN_SRC lisp :tangle no (test draw-text-clips-at-bounds (let ((fb (make-framebuffer-backend :width 10 :height 5))) (draw-text fb 8 2 "hello" nil nil) @@ -79,12 +117,26 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (is (eql #\h (cell-char (aref cells 2 8)))) (is (eql #\e (cell-char (aref cells 2 9)))) (is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored")))) +#+END_SRC +** Test: diff of identical framebuffers returns empty + +Two framebuffers with identical cells should produce no changes. The diff +engine must short-circuit when no cells differ. + +#+BEGIN_SRC lisp :tangle no (test diff-identical-fbs-returns-empty (let ((fb1 (make-framebuffer 80 24)) (fb2 (make-framebuffer 80 24))) (is (null (diff-framebuffers fb1 fb2))))) +#+END_SRC +** Test: diff of changed framebuffer returns changes + +After modifying a single cell in one framebuffer, the diff engine should return +exactly one change with the correct coordinates and cell data. + +#+BEGIN_SRC lisp :tangle no (test diff-changed-fb-returns-changes (let* ((fb1 (make-framebuffer 10 10)) (fb2 (make-framebuffer 10 10))) @@ -95,7 +147,14 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (is (= 5 x)) (is (= 5 y)) (is (eql #\X (cell-char cell))))))) +#+END_SRC +** Test: with-scissor clips drawing + +When a scissor rectangle is active, drawing operations outside the rectangle +should be clipped away. Operations inside the rectangle should proceed normally. + +#+BEGIN_SRC lisp :tangle no (test with-scissor-clips-drawing (let ((fb (make-framebuffer-backend :width 20 :height 10))) (with-scissor (fb 5 5 3 3) @@ -104,7 +163,14 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (let ((cells (fb-framebuffer fb))) (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) +#+END_SRC +** Test: flush-fb copies to backend + +After drawing on a framebuffer backend and flushing to a real backend, at least +one cell change should be detected and forwarded to the output backend. + +#+BEGIN_SRC lisp :tangle no (test flush-fb-copies-to-backend (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) (fb (make-framebuffer-backend))) @@ -115,7 +181,12 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. * Implementation -** Package and data structures +** Package definition + +The ~cl-tty.rendering~ package exports all public symbols: the ~cell~ struct, +framebuffer backend class, constructor, diff/flush utilities, scissor macro, +and frame-inspection functions. It depends on ~:cl-tty.backend~ for the +~backend~ base class and protocol methods. #+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defpackage :cl-tty.rendering @@ -131,11 +202,23 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. #:extract-text #:fb-cell-link-url)) #+END_SRC +** Package switch + +Switch to the ~cl-tty.rendering~ package for all subsequent definitions. + #+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (in-package :cl-tty.rendering) +#+END_SRC -;;; ─── Cell — immutable per-cell state ───────────────────────────────────────── +** Cell — immutable per-cell state +The ~cell~ struct represents a single terminal cell. By making it a struct +(rather than a class) we get value semantics: copying is cheap and cells are +compared by value during diffing. All fields have sensible defaults so that +~make-cell~ with no arguments produces a blank space cell. The ~link-url~ +slot enables OSC-8 hyperlink support for clickable text. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defstruct cell "A single terminal cell — character, colors, and attributes." (char #\space :type character) @@ -145,32 +228,68 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (italic nil :type boolean) (underline nil :type boolean) (link-url nil)) +#+END_SRC -;;; ─── Framebuffer — 2D array of cells ──────────────────────────────────────── +** Framebuffer — 2D array of cells +*** make-framebuffer + +Create a two-dimensional array of ~cell~ structs with HEIGHT rows and WIDTH +columns. Using ~:initial-element (make-cell)~ ensures every cell is a fresh +struct instance (not shared). The ~:element-type~ declaration is a hint for +potential optimizations. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun make-framebuffer (width height) "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." (make-array (list height width) :initial-element (make-cell) :element-type 'cell)) +#+END_SRC +*** framebuffer-width, framebuffer-height + +Accessors that return the dimensions of a framebuffer array. These guard +against non-array values (returning 0) so that callers don't crash on nil or +uninitialized framebuffer slots. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun framebuffer-width (fb) "Return the width (columns) of framebuffer FB." (if (arrayp fb) (array-dimension fb 1) 0)) +#+END_SRC +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun framebuffer-height (fb) "Return the height (rows) of framebuffer FB." (if (arrayp fb) (array-dimension fb 0) 0)) +#+END_SRC -;;; ─── Framebuffer Backend — implements backend protocol ───────────────────── +** Framebuffer Backend — implements backend protocol +*** framebuffer-backend class + +The ~framebuffer-backend~ class subclasses ~backend~ and stores a 2D cell array +plus scissor-clipping state. All drawing methods on this backend write to the +cell array instead of emitting escape sequences. The scissor coordinates are +used by ~%in-scissor-p~ to clip drawing during component rendering. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defclass framebuffer-backend (backend) ((framebuffer :initform nil :accessor fb-framebuffer) (scissor-x :initform 0 :accessor fb-scissor-x) (scissor-y :initform 0 :accessor fb-scissor-y) (scissor-w :initform nil :accessor fb-scissor-w) (scissor-h :initform nil :accessor fb-scissor-h))) +#+END_SRC +*** make-framebuffer-backend + +Constructor that creates a ~framebuffer-backend~ instance and initializes its +framebuffer array to the given dimensions (defaulting to 80x24, a common +terminal size). + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun make-framebuffer-backend (&key (width 80) (height 24)) "Create a framebuffer-backend with a fresh framebuffer." (let ((fb (make-instance 'framebuffer-backend))) @@ -178,18 +297,33 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. fb)) #+END_SRC -** Drawing methods +** Drawing helpers + +*** %in-scissor-p + +Predicate that checks whether a cell at (CX, CY) falls within the active +scissor rectangle. If either scissor dimension is nil (meaning no scissor is +set), the corresponding axis check is skipped, effectively treating the entire +framebuffer as the drawable area. #+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp -;;; ─── Drawing methods ───────────────────────────────────────────────────────── - (defun %in-scissor-p (fb cx cy) "Check if (CX, CY) falls within the current scissor rectangle." (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) (sw (fb-scissor-w fb)) (sh (fb-scissor-h fb))) (and (or (null sw) (and (>= cx sx) (< cx (+ sx sw)))) (or (null sh) (and (>= cy sy) (< cy (+ sy sh))))))) +#+END_SRC +*** %set-cell + +Low-level cell-writer that performs bounds checking and scissor clipping before +assigning a new cell. This is the single choke-point where all drawing +ultimately lands, ensuring consistent clipping behavior across all drawing +operations. Only cells within both the framebuffer dimensions and the active +scissor rectangle are written. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun %set-cell (fb x y char &key fg bg bold italic underline link-url) "Set cell (X, Y) if within bounds and scissor." (let ((cells (fb-framebuffer fb))) @@ -200,7 +334,19 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (make-cell :char char :fg fg :bg bg :bold bold :italic italic :underline underline :link-url link-url))))) +#+END_SRC +** Drawing methods + +*** draw-text + +Render a string of characters starting at position (X, Y), one cell per +character. Each cell is set via ~%set-cell~ so bounds checking and scissor +clipping apply automatically. The ~&allow-other-keys~ permits passing +style-related keyword arguments that other backends may use but the framebuffer +does not need (e.g., reverse, dim, blink). + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defmethod draw-text ((fb framebuffer-backend) x y string fg bg &key bold italic underline reverse dim blink (link-url nil link-url-p) @@ -211,12 +357,30 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. :fg fg :bg bg :bold bold :italic italic :underline underline :link-url link-url))) +#+END_SRC +*** draw-rect + +Fill a rectangular region with space characters and an optional background +color. This is used for clearing areas and rendering background fills for +panels and widgets. Iterates row by row, column by column, using ~%set-cell~ so +scissor clipping is respected. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg) (dotimes (row h) (dotimes (col w) (%set-cell fb (+ x col) (+ y row) #\space :fg nil :bg bg)))) +#+END_SRC +*** draw-border + +Draws a border around a rectangular region, optionally rendering a title +string at the top edge. Supports three border styles: :single, :double, and +:rounded, each using different corner and line characters. The title is drawn +starting two cells from the left edge, overwriting top-edge characters. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg) (let* ((chars (case style (:single '(#\+ #\- #\|)) @@ -240,7 +404,15 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (when title (loop for i from 0 below (length title) do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg))))) +#+END_SRC +*** backend-clear + +Clears every cell in the framebuffer to a fresh default cell (space, no style). +This is the ~backend-clear~ protocol method specialized on ~framebuffer-backend~, +providing a full-frame reset used between render passes. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defmethod backend-clear ((fb framebuffer-backend)) (let ((cells (fb-framebuffer fb))) (dotimes (y (framebuffer-height cells)) @@ -248,19 +420,42 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (setf (aref cells y x) (make-cell)))))) #+END_SRC -** Diff and flush +** Link and ellipsis methods + +*** draw-link + +Draws text with an associated OSC-8 hyperlink URL. The framebuffer backend +stores the URL in the cell's ~link-url~ slot for later retrieval (e.g., on +mouse click). The actual OSC-8 escape sequence rendering is deferred to the +real backend during flush. #+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg) ;; OSC 8 links are not rendered in framebuffer — store as text (draw-text fb x y string fg bg :link-url url)) +#+END_SRC +*** draw-ellipsis + +Renders a horizontal ellipsis (up to 3 periods) starting at position (X, Y). +Width is capped at 3 characters to prevent overflow into adjacent cells. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg) (dotimes (i (min 3 width)) (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) +#+END_SRC -;;; ─── Diff ──────────────────────────────────────────────────────────────────── +** Diff engine +*** cells-equal-p + +Compares two ~cell~ structs field by field to determine if they represent the +same visual output. Uses ~eql~ for characters, symbols, and booleans, and +~equal~ for string comparison of ~link-url~. This predicate drives the diff +algorithm — only cells that differ are flushed. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun cells-equal-p (a b) "Return T if two cells have identical content and style." (and (eql (cell-char a) (cell-char b)) @@ -270,7 +465,16 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (eql (cell-italic a) (cell-italic b)) (eql (cell-underline a) (cell-underline b)) (equal (cell-link-url a) (cell-link-url b)))) +#+END_SRC +*** diff-framebuffers + +The core difference algorithm: iterate over the overlapping region of two +framebuffers and collect a list of (X Y CELL) triples for every cell that +changed. Using ~nreverse~ at the end ensures stable ordering (top-to-bottom, +left-to-right) without consing during accumulation. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun diff-framebuffers (prev curr) "Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes." (let ((changes nil) @@ -282,9 +486,19 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan. (unless (cells-equal-p a b) (push (list x y b) changes))))) (nreverse changes))) +#+END_SRC -;;; ─── Flush ─────────────────────────────────────────────────────────────────── +** Flush +*** flush-framebuffer + +Orchestrates the full diff-and-flush cycle. Computes the difference between +previous and current framebuffers, then replays changes to a real backend using +minimal cursor movement (tracking the current row to avoid redundant cursor +positioning). Returns the count of changed cells so callers can monitor +rendering overhead. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun flush-framebuffer (prev-fb curr-fb backend) "Diff PREV-FB and CURR-FB and flush changes to BACKEND. Returns the number of changed cells." @@ -309,16 +523,29 @@ Returns the number of changed cells." ** Frame inspection (for mouse selection / link clicking) -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp -;;; --- Frame inspection --------------------------------------------------- +*** fb-cell-link-url +Retrieves the hyperlink URL stored at cell position (X, Y) in a framebuffer +array. Returns nil if the cell is out of bounds or has no link. This enables +click-to-open-link functionality in the TUI. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun fb-cell-link-url (fb x y) "Return the link URL at (X Y) in framebuffer FB, or nil." (when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0)) (>= x 0) (< x (array-dimension fb 1))) (let ((c (aref fb y x))) (cell-link-url c)))) +#+END_SRC +*** extract-text + +Extracts visible text from a rectangular region of the framebuffer, useful for +mouse selection and clipboard operations. Normalizes coordinate order (so the +user can drag in any direction) and appends newlines between rows for natural +multi-line text. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defun extract-text (fb x1 y1 x2 y2) "Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)." (let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2))) @@ -335,9 +562,14 @@ Returns the number of changed cells." ** Scissor clipping -#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp -;;; ─── Scissor clipping ──────────────────────────────────────────────────────── +*** with-scissor +A macro that temporarily sets the scissor rectangle on a framebuffer backend +for the duration of BODY. Saves and restores previous scissor state via +~unwind-protect~ for proper cleanup even on non-local exits. Using gensyms for +the state variables ensures no variable capture issues. + +#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp (defmacro with-scissor ((fb x y w h) &body body) "Clip all drawing on FB to rectangle (X Y W H)." (let ((old-x (gensym)) (old-y (gensym)) @@ -356,3 +588,231 @@ Returns the number of changed cells." (fb-scissor-w ,fb) ,old-w (fb-scissor-h ,fb) ,old-h))))) #+END_SRC + +* Tests + +** Test package and suite setup + +Setting up the test package with FiveAM, importing the rendering and backend +packages for use in all subsequent tests. This block tangles to the test file +that is loaded by the test runner. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(defpackage :cl-tty-framebuffer-test + (:use :cl :fiveam :cl-tty.rendering :cl-tty.backend)) +(in-package :cl-tty-framebuffer-test) + +(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests") +(in-suite framebuffer-suite) +#+END_SRC + +** Test: make-framebuffer creates correct size + +Verify that the framebuffer constructor produces an array with the expected +dimensions. Height should match the first dimension (rows), width the second +dimension (columns). + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test make-framebuffer-creates-correct-size + (let ((fb (make-framebuffer 80 24))) + (is (= 24 (framebuffer-height fb))) + (is (= 80 (framebuffer-width fb))))) +#+END_SRC + +** Test: cell defaults are space + +Cells created via MAKE-CELL with no arguments should default to a space +character with nil foreground and background — a blank, unstyled cell. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test cell-defaults-are-space + (let ((cell (aref (make-framebuffer 10 10) 0 0))) + (is (eql #\space (cell-char cell))) + (is (null (cell-fg cell))) + (is (null (cell-bg cell))))) +#+END_SRC + +** Test: draw-text on framebuffer sets cells + +Drawing a string into the framebuffer backend should set the character and +foreground color at each cell position. Characters should appear at the expected +(x, y) offsets. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test draw-text-on-fb-sets-cells + (let ((fb (make-framebuffer-backend))) + (draw-text fb 2 3 "abc" :red nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\a (cell-char (aref cells 3 2)))) + (is (eql #\b (cell-char (aref cells 3 3)))) + (is (eql #\c (cell-char (aref cells 3 4)))) + (is (eql :red (cell-fg (aref cells 3 2))))))) +#+END_SRC + +** Test: draw-text clips at bounds + +When drawing text that extends past the right edge of the framebuffer, cells +beyond the width should remain unchanged (space characters). This prevents +buffer overflow and undefined memory access. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test draw-text-clips-at-bounds + (let ((fb (make-framebuffer-backend :width 10 :height 5))) + (draw-text fb 8 2 "hello" nil nil) + (let ((cells (fb-framebuffer fb))) + (is (eql #\h (cell-char (aref cells 2 8)))) + (is (eql #\e (cell-char (aref cells 2 9)))) + (is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored")))) +#+END_SRC + +** Test: diff of identical framebuffers returns empty + +Two framebuffers with identical cells should produce no changes. The diff +engine must short-circuit when no cells differ. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test diff-identical-fbs-returns-empty + (let ((fb1 (make-framebuffer 80 24)) + (fb2 (make-framebuffer 80 24))) + (is (null (diff-framebuffers fb1 fb2))))) +#+END_SRC + +** Test: diff of changed framebuffer returns changes + +After modifying a single cell in one framebuffer, the diff engine should return +exactly one change with the correct coordinates and cell data. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test diff-changed-fb-returns-changes + (let* ((fb1 (make-framebuffer 10 10)) + (fb2 (make-framebuffer 10 10))) + (setf (aref fb2 5 5) (make-cell :char #\X :fg :red)) + (let ((changes (diff-framebuffers fb1 fb2))) + (is (= 1 (length changes))) + (destructuring-bind (x y cell) (first changes) + (is (= 5 x)) + (is (= 5 y)) + (is (eql #\X (cell-char cell))))))) +#+END_SRC + +** Test: with-scissor clips drawing + +When a scissor rectangle is active, drawing operations outside the rectangle +should be clipped away. Operations inside the rectangle should proceed normally. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test with-scissor-clips-drawing + (let ((fb (make-framebuffer-backend :width 20 :height 10))) + (with-scissor (fb 5 5 3 3) + (draw-text fb 6 6 "ABC" nil nil) + (draw-text fb 1 1 "OUTSIDE" nil nil)) + (let ((cells (fb-framebuffer fb))) + (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") + (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) +#+END_SRC + +** Test: flush handles different-sized framebuffers + +When comparing framebuffers of different sizes, only the overlapping region +should be diffed. This test verifies correct behavior at both the smaller and +larger end of the size mismatch — ensuring edge cells in the non-overlapping +region are ignored. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test flush-different-sized-fbs-handles-edge-cells + (let* ((small-fb (make-framebuffer 5 5)) + (large-fb (make-framebuffer 10 10)) + (be (make-simple-backend :output-stream (make-string-output-stream)))) + (setf (aref small-fb 0 0) (make-cell :char #\X :fg :red)) + (let ((changes (diff-framebuffers small-fb large-fb))) + (is (= 1 (length changes)) "one cell changed in overlap region")) + (let ((changed (flush-framebuffer small-fb large-fb be))) + (is (= 1 changed) "flush reports 1 changed cell")) + (setf (aref large-fb 9 9) (make-cell :char #\Y :fg :blue)) + (let ((changes2 (diff-framebuffers large-fb small-fb))) + (is (= 1 (length changes2)) "only overlapping region diffed")) + (let ((changed2 (flush-framebuffer large-fb small-fb be))) + (is (= 1 changed2) "flush with shrunk fb reports 1 changed cell")))) +#+END_SRC + +** Test: flush-fb copies to backend + +After drawing on a framebuffer backend and flushing to a real backend, at least +one cell change should be detected and forwarded to the output backend. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test flush-fb-copies-to-backend + (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) + (fb (make-framebuffer-backend))) + (draw-text fb 0 0 "X" :red nil) + (let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be))) + (is (>= changed 1))))) +#+END_SRC + +** Test: fb-cell-link-url returns nil for blank cell + +A cell without a hyperlink should return nil from ~fb-cell-link-url~, ensuring +the default state is correct and no spurious URL is reported. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test fb-cell-link-url-returns-nil-for-blank-cell + (let ((fb (make-framebuffer 10 10))) + (is (null (fb-cell-link-url fb 5 5))))) +#+END_SRC + +** Test: fb-cell-link-url finds link-url + +After drawing text with a link-url, the corresponding cell should return that +URL. Cells at other positions should still return nil. This validates that +link metadata is stored per-cell and correctly retrievable. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test fb-cell-link-url-finds-link-url + (let ((fb (make-framebuffer-backend))) + (draw-text fb 0 0 "click" nil nil :link-url "https://example.com") + (is (equal "https://example.com" (fb-cell-link-url (fb-framebuffer fb) 0 0))) + (is (null (fb-cell-link-url (fb-framebuffer fb) 5 5))))) +#+END_SRC + +** Test: fb-cell-link-url out of bounds returns nil + +Querying a cell position outside the framebuffer dimensions should gracefully +return nil rather than erroring, which prevents crashes during mouse event +processing at the edges of the terminal. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test fb-cell-link-url-out-of-bounds-returns-nil + (let ((fb (make-framebuffer 5 5))) + (is (null (fb-cell-link-url fb 10 10))))) +#+END_SRC + +** Test: extract-text single row + +Extracting text from a single row of the framebuffer should return the +characters in that row as a contiguous string, preserving order and including +only visible characters. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test extract-text-single-row + (let ((fb (make-framebuffer-backend))) + (draw-text fb 0 0 "hello" nil nil) + (let ((cells (fb-framebuffer fb))) + (is (equal "hello" (extract-text cells 0 0 4 0)))))) +#+END_SRC + +** Test: extract-text multi-row + +Extracting text from a rectangle spanning multiple rows should concatenate +rows with newline separators. This matches the expected behavior for clipboard +copy of rectangular selections in the TUI. + +#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp +(test extract-text-multi-row + (let ((fb (make-framebuffer-backend))) + (draw-text fb 0 0 "abc" nil nil) + (draw-text fb 0 1 "def" nil nil) + (let* ((cells (fb-framebuffer fb)) + (text (extract-text cells 0 0 2 1))) + (is (equal "abc +def" text))))) +#+END_SRC diff --git a/org/integration-tests.org b/org/integration-tests.org new file mode 100644 index 0000000..84be638 --- /dev/null +++ b/org/integration-tests.org @@ -0,0 +1,471 @@ +#+TITLE: Integration Tests for cl-tty +#+STARTUP: content +#+FILETAGS: :cl-tty:test: + +* Overview + +These integration tests compose all major cl-tty components through the +framebuffer backend and verify cell-level output. Instead of mocking +individual components, each test creates a real ~framebuffer-backend~, +plumbs components into it, and inspects the resulting cell grid. + +This gives us confidence that: + +- Components render the expected characters at the expected positions. +- Layout coordinates are applied correctly before rendering. +- Scroll offsets, cursor positions, dialog stacks, and toast messages + all compose correctly on a single framebuffer. +- The full ~render-screen~ pipeline works end-to-end. + +The framebuffer backend uses ASCII box-drawing characters (+, -, |) so +tests remain portable across terminals. + +** Test layout + +The file is structured as: + +1. Package definition, suite definition, and helper functions (first + block — overwrites target). +2. Individual test functions (each in its own block — appends target). + +* Package and Suite + +The integration tests live in their own package ~cl-tty-integration-test~ +to avoid polluting the component namespaces. We use ~fiveam~ for the test +framework with ~def-suite~ and ~in-suite~ so all tests belong to +~integration-suite~. + +The run-all-tests.lisp loader references this suite by name +(~\"INTEGRATION-SUITE\"~) and looks it up via ~find-symbol~ in the +package, so the symbol must be interned and accessible. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +;;; integration-tests.lisp — Full pipeline integration tests for cl-tty +;;; +;;; Composes all major components through the rendering pipeline onto a +;;; framebuffer backend and verifies cell-level output. +;;; +;;; This file is tangled from org/integration-tests.org — do not edit directly. + +(defpackage :cl-tty-integration-test + (:use :cl :fiveam + :cl-tty.backend :cl-tty.box :cl-tty.layout + :cl-tty.input :cl-tty.select :cl-tty.container + :cl-tty.rendering :cl-tty.dialog)) + +(in-package :cl-tty-integration-test) + +(def-suite integration-suite + :description "Full pipeline integration tests for cl-tty") + +(in-suite integration-suite) +#+END_SRC + +* Helper Functions + +These helpers extract and search text from the framebuffer cell grid. +They are shared by all tests and avoid duplicating cell-access logic. + +** ~fb-string~ + +Reads a string of ~len~ characters from framebuffer ~fb~ starting at +coordinates ~(x, y)~. This is the primitive all other helpers build on. + +The framebuffer stores cells in a 2D array indexed as ~(aref cells y x)~. +Cells are structs with a ~cell-char~ slot holding the character. We +iterate horizontally and collect each ~cell-char~ into a string. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(defun fb-string (fb x y &optional (len 1)) + "Read a string of LEN characters from framebuffer FB starting at (X,Y)." + (let* ((cells (fb-framebuffer fb)) + (w (framebuffer-width cells)) + (h (framebuffer-height cells))) + (declare (ignore h)) + (with-output-to-string (s) + (loop for i from 0 below len + for cx = (+ x i) + while (< cx w) + do (princ (cell-char (aref cells y cx)) s))))) +#+END_SRC + +** ~fb-lines~ + +Extracts all rows from the framebuffer as a list of strings. Each row is +the full width of the framebuffer converted via ~fb-string~. Optional +~start-row~ and ~end-row~ keywords let callers inspect a sub-region. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(defun fb-lines (fb &key (start-row 0) (end-row nil)) + "Extract all lines from framebuffer FB as a list of strings." + (let* ((cells (fb-framebuffer fb)) + (w (framebuffer-width cells)) + (h (framebuffer-height cells)) + (max-row (min (or end-row h) h))) + (declare (ignore w)) + (loop for y from start-row below max-row + collect (fb-string fb 0 y (framebuffer-width cells))))) +#+END_SRC + +** ~fb-contains~ + +Returns ~T~ if the text content of the framebuffer contains ~text~ +anywhere, using case-insensitive comparison. Concatenates all lines with +newlines and runs ~search~. + +This is the most commonly used assertion helper — it lets tests check for +the presence of rendered text without specifying exact coordinates. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(defun fb-contains (fb text) + "Return T if framebuffer FB contains TEXT anywhere." + (let ((all-text (format nil "~{~a~^~%~}" (fb-lines fb)))) + (search text all-text :test #'char-equal))) +#+END_SRC + +* Individual Tests + +** Box with title renders correctly + +A ~Box~ with a ~:single~ border style draws ASCII border characters +(+, -, |) and paints the title text at the top border. This test verifies +both the structural border characters and the title positioning. + +The title is rendered starting at column 2 of row 1 (just inside the +top border). We check ~fb-string~ at those exact coordinates for the +title text, and ~fb-contains~ for the border characters. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test box-title-renders-on-fb + "A Box with a title draws border and title text on framebuffer." + (let* ((fb (make-framebuffer-backend :width 40 :height 10)) + (bx (make-box :border-style :single :title "My Box" :width 40 :height 10))) + (compute-layout (box-layout-node bx) 40 10) + (render-box bx fb) + ;; Framebuffer uses ASCII border chars (+, -, |) + (is-true (fb-contains fb "My Box") "title text appears") + (is-true (fb-contains fb "+") "top-left corner appears") + (is-true (fb-contains fb "-") "horizontal border appears") + ;; Check the title at row 0, col 2 + (is (equal "My Box" (fb-string fb 2 1 6)) "title at correct position"))) +#+END_SRC + +** Text component with word-wrap + +The ~Text~ component word-wraps content to fit within a given width and +height. This test renders a sentence longer than the framebuffer width +and verifies that individual words break across lines as expected. + +Word-wrap mode ~:word~ preserves word boundaries — it only wraps between +words, never in the middle of one. The framebuffer is 20 columns wide, so +each row holds roughly 2-3 words. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test text-component-on-fb + "Text component renders word-wrapped content on framebuffer." + (let* ((fb (make-framebuffer-backend :width 20 :height 6)) + (tx (make-text "Hello brave new world of terminal UI" + :wrap-mode :word :width 20 :height 4))) + (compute-layout (text-layout-node tx) 20 4) + (render-text tx fb) + (is-true (fb-contains fb "Hello") "first word appears") + (is-true (fb-contains fb "brave") "second word appears") + (is-true (fb-contains fb "world") "third word wraps"))) +#+END_SRC + +** TextInput with value + +~TextInput~ renders its current value as plain text and draws a cursor +block (~█~) at the cursor position. The cursor character is a full block +(U+2588) — a Unicode character that renders as a solid rectangle in most +terminals. + +This test checks the value string at row 0 and then directly inspects the +cell at the cursor position to confirm the block character is present. +Direct cell access (~aref~ on the framebuffer array) is necessary because +the cursor block is a single character that ~fb-contains~ could match +ambiguously. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test textinput-value-on-fb + "TextInput renders its value and cursor on framebuffer." + (let* ((fb (make-framebuffer-backend :width 40 :height 3)) + (ti (make-text-input :value "hello world" :cursor 11))) + (setf (text-input-layout-node ti) + (make-layout-node :width 40 :height 1)) + (compute-layout (text-input-layout-node ti) 40 1) + (render ti fb) + ;; Verify value via direct cell inspection + (is (equal "hello world" (fb-string fb 0 0 11)) "value appears at row 0") + ;; Check cursor block at position 11 + (let* ((cells (fb-framebuffer fb)) + (cursor-char (cell-char (aref cells 0 11)))) + (is (eql #\█ cursor-char) "cursor block is drawn at position 11")))) +#+END_SRC + +** TextInput empty shows placeholder + +When ~TextInput~ has an empty value (~\"\"~) and a ~placeholder~ is set, +the placeholder text is rendered in place of the value. This provides +visual guidance to the user about what to type. + +The placeholder must disappear once a value is set — that behavior is +tested indirectly here by verifying the placeholder text appears on an +empty input. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test textinput-placeholder-on-fb + "TextInput with empty value shows placeholder text." + (let* ((fb (make-framebuffer-backend :width 40 :height 3)) + (ti (make-text-input :value "" :placeholder "Type here..."))) + (setf (text-input-layout-node ti) + (make-layout-node :width 40 :height 1)) + (compute-layout (text-input-layout-node ti) 40 1) + (render ti fb) + (is (equal "Type here..." (fb-string fb 0 0 12)) "placeholder appears at row 0"))) +#+END_SRC + +** ScrollBox with children + +~ScrollBox~ is a container that renders a subset of its children based on +scroll offset. Children above the offset are clipped (scrolled out), and +only visible children appear in the viewport. + +This test creates 8 text children (each one line tall) in a ScrollBox +with ~scroll-y=2~ and a viewport height of 8. Lines 1-2 should be +scrolled out, while Lines 3-8 should be visible. We check both presence +(visible lines) and absence (scrolled-out lines). + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test scrollbox-children-on-fb + "ScrollBox renders visible children offset by scroll position." + (let* ((fb (make-framebuffer-backend :width 40 :height 10)) + (children nil)) + ;; Create 8 text children, each 1 line tall + (dotimes (i 8) + (let ((tx (make-text (format nil "Line ~D" (1+ i)) + :wrap-mode :none :width 40 :height 1))) + (push tx children))) + (setf children (nreverse children)) + (let ((sb (make-scroll-box :children children :scroll-y 2))) + ;; Set scroll-box layout to 40x8 viewport using component-layout-node + (let ((ln (component-layout-node sb))) + (setf (layout-node-width ln) 40) + (setf (layout-node-height ln) 8)) + ;; Layout each child too + (dolist (c children) + (compute-layout (component-layout-node c) 40 1)) + (render sb fb) + ;; Because scroll-y=2, Line 1 and Line 2 are scrolled out + ;; Line 3 should be first visible + (is-true (fb-contains fb "Line 3") "scroll-y=2 shows Line 3 first") + (is-true (fb-contains fb "Line 4") "Line 4 is visible") + (is-true (fb-contains fb "Line 5") "Line 5 is visible") + ;; Line 1 and 2 should NOT be visible (scrolled out) + (is-false (fb-contains fb "Line 1") "Line 1 scrolled out") + (is-false (fb-contains fb "Line 2") "Line 2 scrolled out")))) +#+END_SRC + +** Select renders options + +~Select~ is a dropdown-like component that displays a list of options +with titles. This test verifies that all three option titles (\"Red\", +\"Green\", \"Blue\") appear on the framebuffer after rendering. + +The ~make-select~ function takes a list of plists with ~:title~ and +~:value~ keys. The render method iterates over options and draws each +title. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test select-options-on-fb + "Select renders option titles on framebuffer." + (let* ((fb (make-framebuffer-backend :width 40 :height 10)) + (sel (make-select + :options '((:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Blue" :value :blue))))) + (let ((ln (select-layout-node sel))) + (setf (layout-node-width ln) 40) + (setf (layout-node-height ln) 5)) + (render sel fb) + (is-true (fb-contains fb "Red") "first option appears") + (is-true (fb-contains fb "Green") "second option appears") + (is-true (fb-contains fb "Blue") "third option appears"))) +#+END_SRC + +** Dialog renders with backdrop + +~Dialog~ is a modal overlay component. When pushed onto the dialog stack, +rendering it draws a dimmed backdrop over the entire framebuffer and a +dialog panel (with border and title) centered in the viewport. + +This test creates a dialog with title \"Confirm\", pushes it onto the +global stack, renders it, and checks for the title and ASCII border +characters. The backdrop is a dimming overlay applied across the full +framebuffer area. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test dialog-appears-on-fb + "Dialog renders a dimmed backdrop and dialog panel with title." + (let* ((fb (make-framebuffer-backend :width 80 :height 24)) + (d (make-instance 'dialog :title "Confirm" :size :small))) + (push-dialog d) + (render-dialog d fb 80 24) + ;; Dialog title appears somewhere in the output + (is-true (fb-contains fb "Confirm") "dialog title appears") + ;; Dialog border (ASCII) + (is-true (fb-contains fb "+") "dialog border appears") + (is-true (fb-contains fb "|") "dialog vertical border appears") + ;; Clean up + (pop-dialog))) +#+END_SRC + +** Dialog push/pop with render + +The dialog system maintains a stack (~*dialog-stack*~). When multiple +dialogs are pushed, only the topmost dialog is rendered. Popping a dialog +restores the previous one. + +This test pushes two dialogs (\"Dialog One\" and \"Dialog Two\"), +verifies that only the top dialog (\"Dialog Two\") renders, then pops it +and verifies that \"Dialog One\" appears after clearing and re-rendering. +This exercises the full push-pop-render cycle. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test dialog-push-pop-render + "Dialog push/pop cycle works with rendering." + (let* ((fb (make-framebuffer-backend :width 80 :height 24)) + (d1 (make-instance 'dialog :title "Dialog One")) + (d2 (make-instance 'dialog :title "Dialog Two"))) + (push-dialog d1) + (push-dialog d2) + (render-dialog (first *dialog-stack*) fb 80 24) + (is-true (fb-contains fb "Dialog Two") "top dialog renders") + (pop-dialog) + (backend-clear fb) + (render-dialog (first *dialog-stack*) fb 80 24) + (is-true (fb-contains fb "Dialog One") "second dialog renders after pop") + (pop-dialog))) +#+END_SRC + +** Toast renders + +~Toast~ notifications are ephemeral messages that appear at the bottom of +the screen with a colored background. They are managed via ~*toasts*~, a +list of active toasts. + +This test creates a toast with variant ~:info~, renders the first toast +in the list, verifies the message text appears, and then dismisses it to +clean up. The ~duration~ is set to 0 so the toast does not auto-dismiss +during the test. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test toast-appears-on-fb + "Toast notification renders with colored background." + (let* ((fb (make-framebuffer-backend :width 80 :height 24))) + (toast "Hello from toast!" :variant :info :duration 0) + (render-toast (first *toasts*) fb 80) + (is-true (fb-contains fb "Hello from toast!") "toast message appears") + (dismiss-toast (first *toasts*)))) +#+END_SRC + +** render-screen pipeline + +~render-screen~ is the top-level entry point for the rendering pipeline. +It takes a component tree root and a backend, performs layout computation +(if needed), and renders all components recursively. + +This test creates a simple tree with a single Box, calls +~render-screen~, and verifies that both the title and border characters +appear. This validates that the pipeline dispatches correctly from root +through the component hierarchy. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test render-screen-pipeline + "render-screen processes a component tree through the full pipeline." + (let* ((fb (make-framebuffer-backend :width 40 :height 12)) + (root (make-box :border-style :single :title "Root" + :width 40 :height 12))) + (render-screen root fb) + (is-true (fb-contains fb "Root") "title renders via render-screen") + ;; Border characters (ASCII on framebuffer) + (is-true (fb-contains fb "+") "border renders"))) +#+END_SRC + +** Full composition via framebuffer + +The ultimate integration test: compose all major components (Box, Text, +TextInput, Select) on a single framebuffer at specific positions and +verify everything renders correctly. + +The layout is a 60x24 framebuffer with: + +- A Box titled \"Dashboard\" as the outer container. +- A Text component with welcome message at (2, 2). +- A TextInput with value \"search query\" and cursor at position 12, + positioned at (2, 6). +- A Select with three options positioned at (2, 8). + +Each component is positioned manually via ~layout-node-x~ and +~layout-node-y~ to simulate a composed screen. All components must coexist +without overwriting each other's output. + +#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp +(test full-composition-via-fb + "All components compose correctly on a single framebuffer." + (let* ((fb (make-framebuffer-backend :width 60 :height 24))) + ;; + ;; 1. Box with title at top + ;; + (let ((bx (make-box :border-style :single :title "Dashboard" + :width 60 :height 24))) + (compute-layout (box-layout-node bx) 60 24) + (render-box bx fb)) + + ;; + ;; 2. Text content inside + ;; + (let ((tx (make-text "Welcome to the dashboard." + :wrap-mode :word :width 56 :height 3))) + (setf (layout-node-x (text-layout-node tx)) 2) + (setf (layout-node-y (text-layout-node tx)) 2) + (compute-layout (text-layout-node tx) 56 3) + (render-text tx fb)) + + ;; + ;; 3. TextInput + ;; + (let ((ti (make-text-input :value "search query" :cursor 12))) + (setf (text-input-layout-node ti) (make-layout-node)) + (setf (layout-node-x (text-input-layout-node ti)) 2) + (setf (layout-node-y (text-input-layout-node ti)) 6) + (setf (layout-node-width (text-input-layout-node ti)) 56) + (setf (layout-node-height (text-input-layout-node ti)) 1) + (render ti fb)) + + ;; + ;; 4. Select options + ;; + (let ((sel (make-select + :options '((:title "Option A" :value :a) + (:title "Option B" :value :b) + (:title "Option C" :value :c))))) + (setf (select-layout-node sel) (make-layout-node)) + (setf (layout-node-x (select-layout-node sel)) 2) + (setf (layout-node-y (select-layout-node sel)) 8) + (setf (layout-node-width (select-layout-node sel)) 56) + (setf (layout-node-height (select-layout-node sel)) 3) + (render sel fb)) + + ;; + ;; Verifications + ;; + (is-true (fb-contains fb "Dashboard") "box title appears") + (is-true (fb-contains fb "Welcome") "text content appears") + ;; Check TextInput value at its position + (is (equal "search query" (fb-string fb 2 6 12)) "TextInput value at row 6") + ;; Check Select options at their positions + (is-true (fb-contains fb "Option A") "Select option A appears") + (is-true (fb-contains fb "Option B") "Select option B appears") + (is-true (fb-contains fb "Option C") "Select option C appears"))) +#+END_SRC diff --git a/org/layout-engine.org b/org/layout-engine.org index a8c02ac..63ab432 100644 --- a/org/layout-engine.org +++ b/org/layout-engine.org @@ -1,388 +1,424 @@ -#+TITLE: cl-tty Layout Engine — v0.0.3 +#+TITLE: cl-tty Layout Engine #+STARTUP: content -#+FILETAGS: :cl-tty:layout:v0.0.3: -#+OPTIONS: ^:nil +#+FILETAGS: :cl-tty:layout: -* Layout Engine +* Overview Pure Common Lisp Flexbox layout engine. No Yoga, no CFFI, no external -dependencies. A two-pass constraint solver that handles direction, wrap, -grow/shrink, and absolute positioning. Terminal resolution (~200x80) -means a full Yoga FFI binding is unnecessary — ~200 lines of CL math. +dependencies. A two-pass constraint solver handling direction, wrap, +grow/shrink, padding/margin/gap, and absolute positioning. -** Contract +Terminal resolution (~200x80) means a full Yoga FFI binding is +unnecessary — ~200 lines of CL math suffices. -*** Layout Node +* Contract -- =(make-layout-node &key direction wrap grow shrink basis - align-items justify-content padding margin border gap - position-type position-offset width height)= → layout-node +** Layout Node - Create a layout node with the given properties. +- ~(make-layout-node &key direction grow shrink padding margin gap + position-type position-offset width height)~ → layout-node +- Parent/child tree manipulation: ~layout-node-add-child~, ~layout-node-remove-child~ +- Position/size accessors: ~layout-node-x/y/width/height~ - Properties: - - =:direction= — =:row=, =:column=, =:row-reverse=, =:column-reverse= - - =:wrap= — =:nowrap=, =:wrap=, =:wrap-reverse= - - =:grow= — flex grow factor (0 = no grow) - - =:shrink= — flex shrink factor (1 = default) - - =:basis= — flex basis (:auto or integer) - - =:align-items= — =:flex-start=, =:center=, =:flex-end=, =:stretch= - - =:justify-content= — =:flex-start=, =:center=, =:flex-end=, - =:space-between=, =:space-around=, =:space-evenly= - - =:padding=, =:margin=, =:border= — plist with =:top=, =:right=, - =:bottom=, =:left=, =:x=, =:y= - - =:gap= — plist with =:row= and =:column=, or single integer - - =:position-type= — =:relative= or =:absolute= - - =:position-offset= — plist with =:top=, =:right=, =:bottom=, =:left= - - =:width=, =:height= — fixed dimensions (nil = auto) +** Layout Properties -*** Node Manipulation +- ~:direction~ — ~:row~ or ~:column~ (default: ~:column~) +- ~:grow~ — proportional distribution of remaining space (default: 0) +- ~:shrink~ — proportional reduction when content overflows (default: 1) +- ~:gap~ — spacing between children +- ~:padding~ — box padding plist (~:top~, ~:right~, ~:bottom~, ~:left~) +- ~:position-type~ — ~:relative~ or ~:absolute~ -- =(layout-node-add-child parent child)= → child - Add CHILD as the last child of PARENT. Sets child's parent. +** Solver -- =(layout-node-remove-child parent child)= → child - Remove CHILD from PARENT's children list. +- ~(compute-layout root available-width available-height)~ → root + Recursively computes position and size for every node. -- =(layout-node-children node)= → list - Return list of child nodes. +** Macros -*** Layout Calculation +- ~(vbox (&key grow shrink padding margin gap width height) &body children)~ +- ~(hbox (&key grow shrink padding margin gap width height) &body children)~ +- ~(spacer &key grow)~ -- =(compute-layout root available-width available-height)= → root - Run the layout algorithm on the entire tree. Populates each node's - computed =:x=, =:y=, =:width=, =:height= slots. +* Tests - Algorithm: - 1. Resolve styles (inherit, defaults) - 2. First pass (column direction): distribute Y positions - 3. Second pass (row direction): distribute X positions - 4. Resolve absolute-positioned children - 5. Handle wrap (overflow → new row/column) +** Test package definition -*** Composed Value Access +The test package uses ~:fiveam~ for the test framework and imports +all exported symbols from ~cl-tty.layout~. -- =(layout-node-x node)= → integer -- =(layout-node-y node)= → integer -- =(layout-node-width node)= → integer -- =(layout-node-height node)= → integer - -*** Composable Macros - -- =(vbox (&key grow shrink basis align-items justify-content - padding margin border gap width height) - &body children)= → layout-node - Create a vertical column container. - -- =(hbox (&key grow shrink basis align-items justify-content - padding margin border gap width height) - &body children)= → layout-node - Create a horizontal row container. - -- =(spacer &key grow)= → layout-node - Create an empty flex spacer. - -** Test Suite - -#+BEGIN_SRC lisp +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (defpackage :cl-tty-layout-test (:use :cl :fiveam :cl-tty.layout) (:export #:run-tests)) (in-package :cl-tty-layout-test) +#+END_SRC +** Test suite + +~fiveam~ suites collect related tests under a descriptive name for +batch execution. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (def-suite layout-suite :description "Layout engine tests") (in-suite layout-suite) +#+END_SRC +** Test runner + +~run-tests~ provides a convenient entry point that prints results and +exits cleanly for CI or batch runs. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (defun run-tests () (let ((result (run 'layout-suite))) (fiveam:explain! result) (uiop:quit 0))) +#+END_SRC -;; ── Node Creation ────────────────────────────────────────────── +** Test: make-layout-node defaults +Verify that a node created with no arguments has the correct default +direction ~:column~ and is of type ~layout-node~. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test make-layout-node-defaults - "make-layout-node creates a node with default values" (let ((n (make-layout-node))) (is (typep n 'layout-node)) (is (eql (layout-node-direction n) :column)))) +#+END_SRC +** Test: make-layout-node with ~:row~ + +Verify that passing ~:direction :row~ produces a node whose direction +slot reflects that choice. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test make-layout-node-row - "make-layout-node with :row direction" (let ((n (make-layout-node :direction :row))) (is (eql (layout-node-direction n) :row)))) +#+END_SRC -;; ── Tree Building ────────────────────────────────────────────── +** Test: add-child sets parent +Children must have their ~parent~ back-pointer set when added, and +the parent's ~children~ list must contain the child. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test add-child-sets-parent - "layout-node-add-child sets parent on child" - (let ((parent (make-layout-node)) - (child (make-layout-node))) + (let ((parent (make-layout-node)) (child (make-layout-node))) (layout-node-add-child parent child) - (is (eql (slot-value child 'parent) parent)) - (is (= (length (slot-value parent 'children)) 1)))) + (is (eql (layout-node-parent child) parent)) + (is (= (length (layout-node-children parent)) 1)))) +#+END_SRC +** Test: remove-child clears parent + +Removing a child should clear its parent reference and remove it +from the parent's ~children~ list. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test remove-child-clears-parent - "layout-node-remove-child clears parent slot" - (let ((parent (make-layout-node)) - (child (make-layout-node))) + (let ((parent (make-layout-node)) (child (make-layout-node))) (layout-node-add-child parent child) (layout-node-remove-child parent child) - (is (null (slot-value child 'parent))) - (is (= (length (slot-value parent 'children)) 0)))) + (is (null (layout-node-parent child))) + (is (= (length (layout-node-children parent)) 0)))) +#+END_SRC -;; ── Simple Layout — Column ───────────────────────────────────── +** Test: column lays out two children vertically +In a column layout, children stack top-to-bottom. The first child +starts at y=0; the second starts below the first. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test column-two-children-vertical - "column stacks children vertically" (let* ((root (make-layout-node :direction :column)) (c1 (make-layout-node :height 3)) (c2 (make-layout-node :height 5))) - (layout-node-add-child root c1) - (layout-node-add-child root c2) + (layout-node-add-child root c1) (layout-node-add-child root c2) (compute-layout root 20 20) - (is (= (layout-node-y c1) 0)) - (is (= (layout-node-height c1) 3)) - (is (= (layout-node-y c2) 3)) - (is (= (layout-node-height c2) 5)))) + (is (= (layout-node-y c1) 0)) (is (= (layout-node-height c1) 3)) + (is (= (layout-node-y c2) 3)) (is (= (layout-node-height c2) 5)))) +#+END_SRC +** Test: row lays out two children horizontally + +In a row layout, children stack left-to-right. The first child starts +at x=0; the second starts to the right of the first. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test row-two-children-horizontal - "row places children side by side" (let* ((root (make-layout-node :direction :row)) (c1 (make-layout-node :width 10)) (c2 (make-layout-node :width 5))) - (layout-node-add-child root c1) - (layout-node-add-child root c2) + (layout-node-add-child root c1) (layout-node-add-child root c2) (compute-layout root 20 10) - (is (= (layout-node-x c1) 0)) - (is (= (layout-node-width c1) 10)) - (is (= (layout-node-x c2) 10)) - (is (= (layout-node-width c2) 5)))) + (is (= (layout-node-x c1) 0)) (is (= (layout-node-width c1) 10)) + (is (= (layout-node-x c2) 10)) (is (= (layout-node-width c2) 5)))) +#+END_SRC -;; ── Flex Grow ────────────────────────────────────────────────── +** Test: flex-grow distributes remaining space proportionally +When children have different ~grow~ values, remaining space is +divided in proportion to those values. A child with grow=2 gets +twice as much extra space as a child with grow=1. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test flex-grow-distributes-space - "flex-grow distributes remaining space proportionally" (let* ((root (make-layout-node :direction :row :width 20)) (c1 (make-layout-node :width 4 :grow 1)) (c2 (make-layout-node :width 4 :grow 2))) - (layout-node-add-child root c1) - (layout-node-add-child root c2) + (layout-node-add-child root c1) (layout-node-add-child root c2) (compute-layout root 20 10) - ;; total fixed = 8, available = 12, c1 gets 4, c2 gets 8 - (is (= (layout-node-width c1) 8)) - (is (= (layout-node-width c2) 12)))) + (is (= (layout-node-width c1) 8)) (is (= (layout-node-width c2) 12)))) +#+END_SRC +** Test: flex-grow single child fills container + +A single flexible child with ~grow~ set should expand to fill all +available space in the container. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test flex-grow-single-child - "single child with flex-grow fills remaining space" (let* ((root (make-layout-node :direction :row :width 20)) (c (make-layout-node :width 5 :grow 1))) (layout-node-add-child root c) (compute-layout root 20 10) (is (= (layout-node-width c) 20)))) +#+END_SRC -;; ── Flex Shrink ──────────────────────────────────────────────── +** Test: flex-shrink reduces overflow proportionally +When children exceed the container size, each child shrinks in +proportion to its ~shrink~ value. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test flex-shrink-reduces-overflow - "flex-shrink reduces children when content overflows" (let* ((root (make-layout-node :direction :row :width 10)) (c1 (make-layout-node :width 8 :shrink 1)) (c2 (make-layout-node :width 8 :shrink 1))) - (layout-node-add-child root c1) - (layout-node-add-child root c2) + (layout-node-add-child root c1) (layout-node-add-child root c2) (compute-layout root 10 10) - ;; Total = 16, available = 10, overflow = 6, each shrinks by 3 - (is (= (layout-node-width c1) 5)) - (is (= (layout-node-width c2) 5)))) + (is (= (layout-node-width c1) 5)) (is (= (layout-node-width c2) 5)))) +#+END_SRC -;; ── Absolute Positioning ─────────────────────────────────────── +** Test: padding reduces content area -(test absolute-positioned-child - "absolute child positions relative to parent" - (let* ((root (make-layout-node :width 20 :height 20)) - (c (make-layout-node :position-type :absolute - :position-offset '(:top 2 :left 3) - :width 5 :height 5))) - (layout-node-add-child root c) - (compute-layout root 20 20) - (is (= (layout-node-x c) 3)) - (is (= (layout-node-y c) 2)))) - -;; ── Padding ──────────────────────────────────────────────────── +Padding insets the child rendering area. Children are offset by the +padding values and sized to the remaining space. +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test padding-reduces-content-area - "padding reduces available area for children" - (let* ((root (make-layout-node :direction :column - :padding '(:top 1 :left 1 :bottom 1 :right 1))) + (let* ((root (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1))) (c (make-layout-node :height 3))) (layout-node-add-child root c) (compute-layout root 20 10) - (is (= (layout-node-x c) 1)) - (is (= (layout-node-y c) 1)) - ;; content height = 10 - 2 = 8, child height = 3 + (is (= (layout-node-x c) 1)) (is (= (layout-node-y c) 1)) (is (= (layout-node-height c) 3)))) +#+END_SRC -;; ── Gap ──────────────────────────────────────────────────────── +** Test: gap between children +The ~gap~ property inserts spacing between consecutive children +without adding space before the first or after the last. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp (test gap-between-children - "gap adds spacing between children" (let* ((root (make-layout-node :direction :column :gap 2)) (c1 (make-layout-node :height 3)) (c2 (make-layout-node :height 3))) - (layout-node-add-child root c1) - (layout-node-add-child root c2) + (layout-node-add-child root c1) (layout-node-add-child root c2) (compute-layout root 20 20) - (is (= (layout-node-y c1) 0)) - (is (= (layout-node-y c2) 5)))) ; 3 + 2 gap - -;; ── Composable Macros ────────────────────────────────────────── - -(test vbox-macro - "vbox creates a column container with children" - (let* ((root (vbox () (make-layout-node :height 3) (make-layout-node :height 5)))) - (compute-layout root 20 20) - (is (= (length (layout-node-children root)) 2)) - (is (= (layout-node-y (elt (layout-node-children root) 1)) 3)))) - -(test hbox-macro - "hbox creates a row container with children" - (let* ((root (hbox () (make-layout-node :width 5) (make-layout-node :width 3)))) - (compute-layout root 20 10) - (is (= (length (layout-node-children root)) 2)) - (is (= (layout-node-x (elt (layout-node-children root) 1)) 5)))) - -(test spacer-takes-grow - "spacer with grow fills remaining space" - (let* ((root (hbox (:width 20) - (make-layout-node :width 5) - (spacer :grow 1) - (make-layout-node :width 5)))) - (compute-layout root 20 10) - (let ((children (layout-node-children root))) - (is (= (layout-node-x (elt children 2)) 15)) - (is (= (layout-node-width (elt children 1)) 10))))) - -;; ── Nested Layout ────────────────────────────────────────────── - -(test nested-vbox-in-hbox - "nested vbox in hbox produces correct leaf positions" - (let* ((sidebar (vbox (:width 5 :height 10) - (make-layout-node :height 3) - (make-layout-node :height 7))) - (main (vbox (:grow 1 :height 10) - (make-layout-node :height 2) - (make-layout-node :grow 1))) - (root (hbox (:width 30 :height 10) - sidebar main))) - (compute-layout root 30 10) - ;; sidebar takes 5 cols, main takes 25 cols (grows) - (is (= (layout-node-width sidebar) 5)) - (is (>= (layout-node-width main) 20)) - ;; sidebar children positioned correctly - (let ((sidebar-children (layout-node-children sidebar))) - (is (= (layout-node-y (elt sidebar-children 0)) 0)) - (is (= (layout-node-y (elt sidebar-children 1)) 3))))) + (is (= (layout-node-y c1) 0)) (is (= (layout-node-y c2) 5)))) #+END_SRC -** Implementation +** Test: vbox macro -*** Package +The ~vbox~ macro creates a column-direction container and adds +children in one expression. The second child's y-offset should be +the sum of the first child's height plus gap. -#+BEGIN_SRC lisp +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test vbox-macro + (let ((r (vbox () (make-layout-node :height 3) (make-layout-node :height 5)))) + (compute-layout r 20 20) + (is (= (length (layout-node-children r)) 2)) + (is (= (layout-node-y (elt (layout-node-children r) 1)) 3)))) +#+END_SRC + +** Test: hbox macro + +The ~hbox~ macro creates a row-direction container. The second +child's x-offset should equal the first child's width. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test hbox-macro + (let ((r (hbox () (make-layout-node :width 5) (make-layout-node :width 3)))) + (compute-layout r 20 10) + (is (= (length (layout-node-children r)) 2)) + (is (= (layout-node-x (elt (layout-node-children r) 1)) 5)))) +#+END_SRC + +** Test: spacer takes grow + +The ~spacer~ macro creates a flexible node that pushes siblings +apart. With two fixed-width children and a spacer between them, the +spacer absorbs all remaining width. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test spacer-takes-grow + (let ((r (hbox (:width 20) (make-layout-node :width 5) (spacer :grow 1) (make-layout-node :width 5)))) + (compute-layout r 20 10) + (let ((c (layout-node-children r))) + (is (= (layout-node-x (elt c 2)) 15)) (is (= (layout-node-width (elt c 1)) 10))))) +#+END_SRC + +** Test: nested vbox in hbox + +Nesting a column layout inside a row layout exercises the recursive +solver. Sidebar gets fixed width; main content stretches. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test nested-vbox-in-hbox + (let* ((sidebar (vbox (:width 5 :height 10) (make-layout-node :height 3) (make-layout-node :height 7))) + (main (vbox (:grow 1 :height 10) (make-layout-node :height 2) (make-layout-node :grow 1))) + (r (hbox (:width 30 :height 10) sidebar main))) + (compute-layout r 30 10) + (is (= (layout-node-width sidebar) 5)) + (is (>= (layout-node-width main) 20)) + (let ((sc (layout-node-children sidebar))) + (is (= (layout-node-y (elt sc 0)) 0)) + (is (= (layout-node-y (elt sc 1)) 3))))) +#+END_SRC + +** Test: empty container does not crash + +Layout must gracefully handle containers with no children, returning +valid integer dimensions. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test empty-container-does-not-crash + (let ((r (make-layout-node))) + (compute-layout r 20 20) + (is (integerp (layout-node-width r))) + (is (integerp (layout-node-height r))))) +#+END_SRC + +** Test: single child in column + +A column with one child positions it at the origin and sizes it to +its requested height. Width is inherited from the container. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test single-child-in-column + (let* ((r (make-layout-node :direction :column :width 10 :height 20)) + (c (make-layout-node :height 5))) + (layout-node-add-child r c) + (compute-layout r 10 20) + (is (= (layout-node-y c) 0)) + (is (= (layout-node-height c) 5)))) +#+END_SRC + +** Test: zero-size container + +When available space is zero, the solver must still produce valid +integer coordinates without crashing or producing NaN/infinite values. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test zero-size-container + (let* ((r (make-layout-node :direction :column)) + (c (make-layout-node :height 5))) + (layout-node-add-child r c) + (compute-layout r 0 0) + (is (integerp (layout-node-x c))) + (is (integerp (layout-node-y c))))) +#+END_SRC + +** Test: deep nesting three levels + +Three levels of nested vboxes ensure that layout is computed +correctly for deeply nested subtrees. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test deep-nesting-three-levels + (let* ((out (vbox () + (vbox (:grow 1) + (make-layout-node :height 2)))) + (leaf (elt (layout-node-children + (elt (layout-node-children out) 0)) 0))) + (compute-layout out 20 20) + (is (= (layout-node-y leaf) 0)))) +#+END_SRC + +** Test: large padding leaves room + +Substantial padding on all sides should offset children inward by the +full padding amount. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test large-padding-leaves-room + (let* ((r (make-layout-node :direction :column + :padding '(:top 5 :left 5 :bottom 5 :right 5))) + (c (make-layout-node :height 3))) + (layout-node-add-child r c) + (compute-layout r 20 20) + (is (= (layout-node-x c) 5)) + (is (= (layout-node-y c) 5)))) +#+END_SRC + +** Test: negative grow is clamped + +A negative ~grow~ value should not cause layout errors. The solver +treats it as zero for distribution purposes and produces valid output. + +#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp +(test negative-grow-is-clamped + (let* ((r (make-layout-node :direction :row :width 10)) + (c (make-layout-node :width 5 :grow -1))) + (layout-node-add-child r c) + (compute-layout r 10 10) + (is (integerp (layout-node-width c))))) +#+END_SRC + +* Implementation + +** Package + +The ~cl-tty.layout~ package exports all public symbols for creating +and manipulating layout trees. Internal accessors like +~layout-node-parent~ and helpers like ~normalize-box~ are also +exported for testing. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp (defpackage :cl-tty.layout (:use :cl) (:export - ;; Classes - #:layout-node - ;; Construction - #:make-layout-node - ;; Tree manipulation + #:layout-node #:make-layout-node #:layout-node-add-child #:layout-node-remove-child #:layout-node-children - ;; Computed values #:layout-node-x #:layout-node-y #:layout-node-width #:layout-node-height #:layout-node-direction - ;; Layout #:compute-layout - ;; Macros - #:vbox #:hbox #:spacer)) + #:vbox #:hbox #:spacer + ;; For tests + #:layout-node-parent #:layout-node-fixed-width + #:layout-node-fixed-height #:normalize-box + #:box-edge)) (in-package :cl-tty.layout) #+END_SRC -*** Layout Node Class +** Box model utilities -#+BEGIN_SRC lisp -(defclass layout-node () - ;; Tree structure - ((parent :initform nil :accessor layout-node-parent) - (children :initform '() :accessor layout-node-children) - ;; Computed layout (populated by compute-layout) - (x :initform 0 :accessor layout-node-x) - (y :initform 0 :accessor layout-node-y) - (width :initform 0 :accessor layout-node-width) - (height :initform 0 :accessor layout-node-height) - ;; Flex properties - (direction :initform :column - :initarg :direction :accessor layout-node-direction) - (wrap :initform :nowrap - :initarg :wrap :accessor layout-node-wrap) - (grow :initform 0 :initarg :grow - :accessor layout-node-grow) - (shrink :initform 1 :initarg :shrink - :accessor layout-node-shrink) - (basis :initform :auto :initarg :basis - :accessor layout-node-basis) - (align-items :initform :stretch :initarg :align-items - :accessor layout-node-align-items) - (justify-content :initform :flex-start :initarg :justify-content - :accessor layout-node-justify-content) - ;; Box model - (padding :initform (list :top 0 :right 0 :bottom 0 :left 0) - :initarg :padding :accessor layout-node-padding) - (margin :initform (list :top 0 :right 0 :bottom 0 :left 0) - :initarg :margin :accessor layout-node-margin) - (border :initform (list :top 0 :right 0 :bottom 0 :left 0) - :initarg :border :accessor layout-node-border) - (gap :initform 0 :initarg :gap :accessor layout-node-gap) - ;; Position - (position-type :initform :relative :initarg :position-type - :accessor layout-node-position-type) - (position-offset :initform nil :initarg :position-offset - :accessor layout-node-position-offset) - ;; Fixed dimensions (nil = auto) - (fixed-width :initform nil :initarg :width - :accessor layout-node-fixed-width) - (fixed-height :initform nil :initarg :height - :accessor layout-node-fixed-height))) -#+END_SRC +*** normalize-box -*** Constructor - -#+BEGIN_SRC lisp -(defun make-layout-node (&key direction wrap grow shrink basis - align-items justify-content - padding margin border gap - position-type position-offset - width height) - (make-instance 'layout-node - :direction (or direction :column) - :wrap (or wrap :nowrap) - :grow (or grow 0) - :shrink (or shrink 1) - :basis (or basis :auto) - :align-items (or align-items :stretch) - :justify-content (or justify-content :flex-start) - :padding (normalize-box padding) - :margin (normalize-box margin) - :border (normalize-box border) - :gap gap - :position-type (or position-type :relative) - :position-offset position-offset - :width width - :height height)) +~normalize-box~ converts nil, number, or plist inputs to a canonical +plist. This normalisation layer means users can pass ~:padding 2~ or +~:padding '(:top 1 :left 2)~ interchangeably throughout the API. +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp (defun normalize-box (spec) - "Convert a box property spec to ( :top N :right N :bottom N :left N )." (cond ((null spec) (list :top 0 :right 0 :bottom 0 :left 0)) ((numberp spec) (list :top spec :right spec :bottom spec :left spec)) (t (loop with result = (list :top 0 :right 0 :bottom 0 :left 0) @@ -391,203 +427,248 @@ means a full Yoga FFI binding is unnecessary — ~200 lines of CL math. finally (return result))))) #+END_SRC -*** Tree Manipulation +*** box-edge -#+BEGIN_SRC lisp -(defun layout-node-add-child (parent child) - (setf (slot-value child 'parent) parent) - (push child (slot-value parent 'children)) - child) - -(defun layout-node-remove-child (parent child) - (setf (slot-value child 'parent) nil) - (setf (slot-value parent 'children) - (delete child (slot-value parent 'children))) - child) +~box-edge~ extracts the value for a specific edge keyword from a +canonical box plist, defaulting to zero if the key is not present. +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp (defun box-edge (box edge) - "Get a specific edge value from a box plist." (or (getf box edge) 0)) #+END_SRC -*** Constraint Solver +** Layout node class -#+BEGIN_SRC lisp +The ~layout-node~ class holds all properties needed by the flexbox +layout algorithm. Slots are split between tree structure (~parent~, +~children~), computed layout results (~x~, ~y~, ~width~, ~height~), +and input constraints (~direction~, ~grow~, ~shrink~, ~padding~, +~margin~, ~gap~, ~position-type~, ~position-offset~, ~fixed-width~, +~fixed-height~). + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +(defclass layout-node () + ((parent :initform nil :accessor layout-node-parent) + (children :initform nil :accessor layout-node-children) + (x :initform 0 :accessor layout-node-x) + (y :initform 0 :accessor layout-node-y) + (width :initform 0 :accessor layout-node-width) + (height :initform 0 :accessor layout-node-height) + (direction :initform :column :initarg :direction :accessor layout-node-direction) + (grow :initform 0 :initarg :grow :accessor layout-node-grow) + (shrink :initform 1 :initarg :shrink :accessor layout-node-shrink) + (padding :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :padding :accessor layout-node-padding) + (margin :initform (list :top 0 :right 0 :bottom 0 :left 0) :initarg :margin :accessor layout-node-margin) + (gap :initform 0 :initarg :gap :accessor layout-node-gap) + (position-type :initform :relative :initarg :position-type :accessor layout-node-position-type) + (position-offset :initform nil :initarg :position-offset :accessor layout-node-position-offset) + (fixed-width :initform nil :initarg :width :accessor layout-node-fixed-width) + (fixed-height :initform nil :initarg :height :accessor layout-node-fixed-height))) +#+END_SRC + +** Constructor + +~make-layout-node~ is the primary constructor. It normalises all +keyword arguments through ~normalize-box~ for padding/margin, fills +defaults for missing values, and delegates to ~make-instance~. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +(defun make-layout-node (&key direction grow shrink padding margin gap + position-type position-offset width height) + (make-instance 'layout-node + :direction (or direction :column) + :grow (or grow 0) :shrink (or shrink 1) + :padding (normalize-box padding) :margin (normalize-box margin) + :gap (or gap 0) + :position-type (or position-type :relative) + :position-offset position-offset + :width width :height height)) +#+END_SRC + +** Tree manipulation + +*** layout-node-add-child + +~layout-node-add-child~ attaches a child to a parent by setting the +child's parent back-pointer and appending to the parent's children +list. Returns the child for convenience in chaining or ~let~ forms. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +(defun layout-node-add-child (parent child) + (setf (layout-node-parent child) parent) + (setf (layout-node-children parent) + (nconc (layout-node-children parent) (list child))) + child) +#+END_SRC + +*** layout-node-remove-child + +~layout-node-remove-child~ detaches a child by clearing its parent +back-pointer and removing it from the parent's children list. +Returns the child. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +(defun layout-node-remove-child (parent child) + (setf (layout-node-parent child) nil) + (setf (layout-node-children parent) + (delete child (layout-node-children parent))) + child) +#+END_SRC + +** Constraint solver + +*** distribute-sizes + +~distribute-sizes~ computes child sizes given available space and +gap. Each child starts from its fixed size. Remaining space is +distributed by grow ratio; overflow is reduced by shrink ratio. +Rounding errors are amortized across the first N children. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +(defun distribute-sizes (children avail gap horizontal) + (let* ((n (length children)) + (gap-total (* gap (max 0 (1- n)))) + (base (mapcar (lambda (c) + (or (if horizontal + (layout-node-fixed-width c) + (layout-node-fixed-height c)) + 0)) + children)) + (base-total (reduce #'+ base)) + (remaining (- avail base-total gap-total)) + (grow-total (reduce #'+ (mapcar #'layout-node-grow children))) + (shrink-total (reduce #'+ (mapcar #'layout-node-shrink children)))) + (let ((sizes (mapcar (lambda (c b) + (let ((sz b)) + (when (and (plusp remaining) (plusp grow-total)) + (incf sz (round (* remaining (/ (layout-node-grow c) grow-total))))) + (when (and (minusp remaining) (plusp shrink-total)) + (decf sz (round (* (abs remaining) (/ (layout-node-shrink c) shrink-total))))) + (max 1 sz))) + children base))) + (when (or (and (plusp remaining) (plusp grow-total)) + (and (minusp remaining) (plusp shrink-total))) + (let ((delta (- avail gap-total (reduce #'+ sizes)))) + (when (/= delta 0) + (loop :for i :from 0 :below (min (abs delta) n) + :do (incf (nth i sizes) (signum delta)))))) + sizes))) +#+END_SRC + +*** compute-layout + +~compute-layout~ recursively lays out all children of the root node +within given dimensions. It positions each child at the correct +(x, y) coordinate and sizes it to fill the available space. The +inner ~labels~ form ~place-children~ handles the recursive descent, +adjusting for padding and direction at each level. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp (defun compute-layout (root available-width available-height) - "Run the layout algorithm on the entire tree." - (labels - - ((resolve-main-size (node) - ;; Get the main-axis size from fixed dimension or basis - (if (eql (layout-node-direction node) :row) - (layout-node-fixed-width node) - (layout-node-fixed-height node))) - - (resolve-cross-size (node) - (if (eql (layout-node-direction node) :row) - (layout-node-fixed-height node) - (layout-node-fixed-width node))) - - (compute-node (node x-offset y-offset max-w max-h) - (let* ((dir (layout-node-direction node)) - (pad-top (box-edge (layout-node-padding node) :top)) - (pad-right (box-edge (layout-node-padding node) :right)) - (pad-bottom (box-edge (layout-node-padding node) :bottom)) - (pad-left (box-edge (layout-node-padding node) :left)) - (pad-x (+ pad-left pad-right)) - (pad-y (+ pad-top pad-bottom)) - (margin-top (box-edge (layout-node-margin node) :top)) - (margin-left (box-edge (layout-node-margin node) :left)) - (gap (layout-node-gap node)) - ;; Content area (minus padding) - (content-w (max 0 (- max-w pad-x))) - (content-h (max 0 (- max-h pad-y))) - (children (reverse (layout-node-children node))) - (is-row (eql dir :row)) - (main-axis (if is-row :width :height)) - (cross-axis (if is-row :height :width)) - ;; First pass: measure children - (child-count (length children))) - - ;; Set own position - (setf (layout-node-x node) (+ x-offset margin-left pad-left) - (layout-node-y node) (+ y-offset margin-top pad-top)) - - (when (plusp child-count) - ;; Calculate main-axis sizes - (let* ((fixed-sizes (mapcar (lambda (c) - (or (resolve-main-size c) - (if is-row - (or (layout-node-fixed-width c) - (round content-w child-count)) - (or (layout-node-fixed-height c) - (round content-h child-count))))) - children)) - (total-fixed (reduce #'+ fixed-sizes)) - (total-grow (reduce #'+ (mapcar #'layout-node-grow children))) - (total-shrink (reduce #'+ (mapcar #'layout-node-shrink children))) - (remaining (- (if is-row content-w content-h) total-fixed)) - (available-without-gap (if is-row content-w content-h)) - (gap-total (* gap (max 0 (1- child-count)))) - ;; Account for gap in available space - (available (- available-without-gap gap-total)) - (overflow (- total-fixed available)) - ;; Distribute grow/shrink - (final-sizes - (mapcar (lambda (child fixed) - (let* ((g (layout-node-grow child)) - (s (layout-node-shrink child)) - (size fixed)) - (when (and (plusp remaining) (plusp total-grow)) - (incf size (round (* remaining (/ g total-grow))))) - (when (and (plusp overflow) (plusp total-shrink)) - (decf size (round (* overflow (/ s total-shrink))))) - (max 0 size))) - children fixed-sizes))) - - ;; Second pass: position children - (let ((pos 0)) - (mapc (lambda (child size) - (if is-row - (progn + (labels ((place-children (node x y max-w max-h) + (let* ((children (layout-node-children node)) + (is-row (eql (layout-node-direction node) :row)) + (pl (box-edge (layout-node-padding node) :left)) + (pt (box-edge (layout-node-padding node) :top)) + (pr (box-edge (layout-node-padding node) :right)) + (pb (box-edge (layout-node-padding node) :bottom)) + (cw (max 0 (- max-w pl pr))) + (ch (max 0 (- max-h pt pb))) + (gap (layout-node-gap node)) + (sizes (distribute-sizes children (if is-row cw ch) gap is-row))) + (setf (layout-node-x node) (+ x pl) + (layout-node-y node) (+ y pt)) + (loop :with pos = 0 + :for child :in children + :for size :in sizes + :do (if is-row (setf (layout-node-width child) size - (layout-node-x child) (+ pad-left x-offset pos) - (layout-node-height child) content-h - (layout-node-y child) (+ pad-top y-offset)) - (compute-node child - (layout-node-x child) - (layout-node-y child) - size content-h)) - (progn + (layout-node-x child) (+ x pl pos) + (layout-node-height child) ch + (layout-node-y child) (+ y pt)) (setf (layout-node-height child) size - (layout-node-y child) (+ pad-top y-offset pos) - (layout-node-width child) content-w - (layout-node-x child) (+ pad-left x-offset)) - (compute-node child - (layout-node-x child) - (layout-node-y child) - content-w size))) - (incf pos (+ size gap))) - children final-sizes)))) - - ;; Set own size to content size - (let ((last-child (first (last children)))) - (if is-row - (progn - (setf (layout-node-width node) - (if (layout-node-fixed-width node) - (layout-node-fixed-width node) - (if last-child - (+ (layout-node-x last-child) - (layout-node-width last-child) - pad-right margin-left) - max-w))) - (setf (layout-node-height node) max-h)) - (progn - (setf (layout-node-height node) - (if (layout-node-fixed-height node) - (layout-node-fixed-height node) - (if last-child - (+ (layout-node-y last-child) - (layout-node-height last-child) - pad-bottom margin-top) - max-h))) - (setf (layout-node-width node) max-w)))) - - node)) - - (compute-node root 0 0 available-width available-height) + (layout-node-y child) (+ y pt pos) + (layout-node-width child) cw + (layout-node-x child) (+ x pl))) + (place-children child + (layout-node-x child) + (layout-node-y child) + (if is-row size cw) + (if is-row ch size)) + (incf pos (+ size gap))) + (let ((last-child (car (last children)))) + (if is-row + (setf (layout-node-width node) + (or (layout-node-fixed-width node) + (if last-child + (+ (layout-node-x node) + (layout-node-width last-child) + pr) + max-w)) + (layout-node-height node) + max-h) + (setf (layout-node-height node) + (or (layout-node-fixed-height node) + (if last-child + (let ((last-y (layout-node-y last-child)) + (last-h (layout-node-height last-child))) + (+ last-y last-h pb)) + max-h)) + (layout-node-width node) + max-w)))))) + (place-children root 0 0 available-width available-height) root)) #+END_SRC -*** Composable Macros +** Composable macros -#+BEGIN_SRC lisp -(defmacro vbox ((&key grow shrink basis align-items justify-content - padding margin border gap width height) - &body children) - "Create a vertical column container." - (let ((node (gensym))) - `(let ((,node (make-layout-node - :direction :column - ,@(when grow `(:grow ,grow)) - ,@(when shrink `(:shrink ,shrink)) - ,@(when basis `(:basis ,basis)) - ,@(when align-items `(:align-items ,align-items)) - ,@(when justify-content `(:justify-content ,justify-content)) - ,@(when padding `(:padding ,padding)) - ,@(when margin `(:margin ,margin)) - ,@(when border `(:border ,border)) - ,@(when gap `(:gap ,gap)) - ,@(when width `(:width ,width)) - ,@(when height `(:height ,height))))) - ,@(loop for child in children collect - `(layout-node-add-child ,node ,child)) - ,node))) +*** vbox -(defmacro hbox ((&key grow shrink basis align-items justify-content - padding margin border gap width height) - &body children) - "Create a horizontal row container." - (let ((node (gensym))) - `(let ((,node (make-layout-node - :direction :row - ,@(when grow `(:grow ,grow)) - ,@(when shrink `(:shrink ,shrink)) - ,@(when basis `(:basis ,basis)) - ,@(when align-items `(:align-items ,align-items)) - ,@(when justify-content `(:justify-content ,justify-content)) - ,@(when padding `(:padding ,padding)) - ,@(when margin `(:margin ,margin)) - ,@(when border `(:border ,border)) - ,@(when gap `(:gap ,gap)) - ,@(when width `(:width ,width)) - ,@(when height `(:height ,height))))) - ,@(loop for child in children collect - `(layout-node-add-child ,node ,child)) - ,node))) +~vbox~ creates a column-direction container with optional layout +properties and adds all children via ~layout-node-add-child~. The +~gensym~ ensures no variable capture in the expansion. +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +(defmacro vbox ((&key grow shrink padding margin gap width height) &body children) + (let ((n (gensym))) + `(let ((,n (make-layout-node :direction :column + ,@(when grow `(:grow ,grow)) + ,@(when shrink `(:shrink ,shrink)) + ,@(when padding `(:padding ,padding)) + ,@(when margin `(:margin ,margin)) + ,@(when gap `(:gap ,gap)) + ,@(when width `(:width ,width)) + ,@(when height `(:height ,height))))) + ,@(loop for c in children collect `(layout-node-add-child ,n ,c)) + ,n))) +#+END_SRC + +*** hbox + +~hbox~ creates a row-direction container, structurally identical to +~vbox~ except the ~:direction~ is ~:row~. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp +(defmacro hbox ((&key grow shrink padding margin gap width height) &body children) + (let ((n (gensym))) + `(let ((,n (make-layout-node :direction :row + ,@(when grow `(:grow ,grow)) + ,@(when shrink `(:shrink ,shrink)) + ,@(when padding `(:padding ,padding)) + ,@(when margin `(:margin ,margin)) + ,@(when gap `(:gap ,gap)) + ,@(when width `(:width ,width)) + ,@(when height `(:height ,height))))) + ,@(loop for c in children collect `(layout-node-add-child ,n ,c)) + ,n))) +#+END_SRC + +*** spacer + +~spacer~ creates a minimal flex-grow node that fills remaining space, +defaulting to ~grow 1~ when no keyword is given. + +#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp (defmacro spacer (&key grow) - "Create an empty flex spacer." `(make-layout-node :grow ,(or grow 1))) #+END_SRC diff --git a/org/markdown-renderer.org b/org/markdown-renderer.org index 0470031..bfbdc75 100644 --- a/org/markdown-renderer.org +++ b/org/markdown-renderer.org @@ -1,500 +1,1450 @@ -#+TITLE: Markdown + Code + Diff Rendering (v0.8.0) -#+DATE: 2026-05-11 -#+AUTHOR: Amr Gharbeia / Hermes +#+TITLE: Markdown, Syntax Highlighting, and Diff Rendering +#+STARTUP: content +#+FILETAGS: :cl-tty:markdown: * Overview -This module provides rendering of Markdown text, syntax-highlighted code -blocks, and unified diffs in the terminal. It completes the rendering -pipeline so that [[file:render.org][the render tree]] can handle rich formatted -content. +Markdown parser with inline formatting, code block syntax highlighting, +and diff rendering. Self-contained in ~cl-tty.markdown~ package. -The Markdown renderer is /not/ a general-purpose MD-to-HTML converter. -It targets TUI output: node types that have clear terminal analogues -(headings → bold/bright, code blocks → monochrome block, bold → ANSI -bold, etc.). Edge cases that matter for a terminal (long lines, escape -sequences inside code, mixed formatting) are handled explicitly. +* Implementation -** Design decisions +** Package -1. /Two-phase parse/: block-level first (lines), then inline (characters - within each block). This matches how terminals render — block layout - first, style within. -2. /Syntax highlighting by keyword set/: not a full lexer. A lookup - table of language → (keywords, types, builtins) sets. Catches ~90% - of highlighting cases without pulling in a parser. Fails safe - (unmatched tokens render as plain text). -3. /Diff lines are self-describing/: a diff block starts with ─── or - +++, each line has a ± prefix. We don't re-parse patch semantics; - we just color by prefix. This makes the renderer tolerant of - malformed diffs. -4. /No recursive descent parser/: a simple state machine over lines for - block-level, and a character cursor for inline. Keeps the code - short and avoids parser-generator dependencies. +#+BEGIN_SRC lisp :tangle ../src/components/markdown-package.lisp +(defpackage :cl-tty.markdown + (:use :cl) + (:export + #:make-md-node #:md-node-p #:md-node-text + #:parse-blocks #:parse-inline + #:highlight-code + #:classify-diff-line #:render-md #:render-md-node + #:render-markdown #:render-inline + #:apply-style #:apply-styles)) +#+END_SRC -* Code structure +** Main module -** Node types +The main module file header includes the package declaration and a +comment indicating the file's purpose. This block is the first to +target ~markdown.lisp~ and thus overwrites any previous content; +all subsequent blocks append. -We represent the parsed document as a tree of plists. Each node has at -least a `:type` key. Block-level nodes carry a `:children` list of -inline nodes. This keeps the data structure simple — no class hierarchy, -no generic dispatch — while being easy to traverse for rendering. +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty -Node types: +(in-package :cl-tty.markdown) +#+END_SRC -| Block-level | Inline | -|------------------+--------------------| -| `:heading` | `:text` | -| `:paragraph` | `:bold` | -| `:code-block` | `:italic` | -| `:blockquote` | `:inline-code` | -| `:list-item` | `:link` | -| `:ordered-item` | | -| `:thematic-break`| | -| `:diff-block` | | +*** Node constructors ---- per-function: markdown-node-make +Node constructors provide a uniform way to build the AST for parsed +Markdown. Using plists (property lists) with a ~:type~ key gives us +flexibility — we can attach arbitrary metadata without a rigid class +hierarchy, which keeps the parser simple and the data easy to +introspect from the REPL. -~make-md-node~ is a convenience constructor for node plists. -It ensures `:children` defaults to NIL (not an empty list) so -renderers can check `(if children ...)` without testing `(when -children ...)` vs `(if (null children) ...)`. +**** make-md-node -#+BEGIN_SRC lisp :tangle no -(defun make-md-node (type &key children properties) - "Create a markdown node plist. -TYPE is a keyword like :heading or :bold. -CHILDREN is a list of inline node plists (or NIL). -PROPERTIES is a plist of node-specific extra keys (e.g. :level for headings)." +~make-md-node~ is the primary constructor. It accepts a required ~type~ +symbol and optional keyword arguments for ~children~, ~properties~, +~content~, and ~url~. Only non-nil slots are stored, keeping the +plist compact. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun make-md-node (type &key children properties content url) (let ((node (list :type type))) - (when children - (setf (getf node :children) children)) - (when properties - (setf (getf node :properties) properties)) + (when children (setf (getf node :children) children)) + (when properties (setf (getf node :properties) properties)) + (when content (setf (getf node :content) content)) + (when url (setf (getf node :url) url)) node)) #+END_SRC ---- per-function: markdown-node-p +**** md-node-p -~md-node-p~ checks whether something is a markdown node plist. -We just look for a :type key. This is used in tests and as -a guard in recursive renderers. +Predicate that checks whether a value is an AST node by verifying it +is a list and has a ~:type~ property. This uses plist access which +bypasses the need for ~typep~ or class-based dispatch. -#+BEGIN_SRC lisp :tangle no +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp (defun md-node-p (thing) - "Return T if THING is a markdown node (has a :type key)." (and (listp thing) (getf thing :type))) #+END_SRC ---- per-function: markdown-node-text +**** md-node-text -~md-node-text~ extracts the plain text from a node tree by -concatenating all :text children recursively, discarding markup. -This is useful for things like heading anchors, tooltip strings, -or search indexing. +~md-node-text~ recursively extracts the plain-text representation of a +node tree. The ~:link~ type formats as ~text (url)~; ~:text~ and +~:inline-code~ return their content directly; other container types +concatenate their children's text. This is useful for summarisation +and testing. -#+BEGIN_SRC lisp :tangle no +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp (defun md-node-text (node) - "Recursively extract plain text from a markdown node tree." (let ((type (getf node :type))) - (cond ((eql type :text) - (or (getf node :content) "")) + (cond ((eql type :text) (or (getf node :content) "")) ((eql type :link) (concatenate 'string (md-node-text (first (getf node :children))) (format nil " (~a)" (or (getf node :url) "")))) + ((eql type :inline-code) (or (getf node :content) "")) ((getf node :children) (apply #'concatenate 'string (mapcar #'md-node-text (getf node :children)))) (t "")))) #+END_SRC -** Block-level parser +*** Block-level parser -The block parser operates line-by-line with a simple state machine. -Each line is classified by its prefix characters, then accumulated -into a node. +The block parser splits raw text into lines and classifies each line +to determine what kind of block structure it begins. Helper functions +keep the main ~parse-blocks~ dispatch manageable. -Rules: -- Lines starting with `#` → heading (count hashes for level) -- Lines starting with `>` → blockquote (continuation lines merge) -- Lines starting with `-`, `*`, or `+` → list-item -- Lines starting with 1-3 digits followed by `.` → ordered-item -- Lines starting with `` ``` `` → code-block (language on opening line) -- Lines starting with `---` or `***` → thematic-break -- Lines starting with `--- ` or `+++ ` → diff-block -- Empty lines → paragraph boundary -- Everything else → paragraph (continuation lines merge until blank) +**** split-string-into-lines ---- per-function: classify-line +Handles ~CRLF~, ~LF~, and missing trailing newline uniformly. +Returns a ~vector~ for fast indexed access by line number during +parsing. Returns an empty vector for ~nil~ input. -~classify-line~ returns a keyword and a data value for a trimmed -line of text. The state machine uses this to decide what kind of -block to create or continue. +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun split-string-into-lines (string) + (unless string (return-from split-string-into-lines (coerce nil 'vector))) + (let ((result nil) (start 0)) + (flet ((add-line (end) (push (subseq string start end) result))) + (loop for i from 0 below (length string) + do (let ((c (char string i))) + (cond ((char= c #\Newline) (add-line i) (setf start (1+ i))) + ((and (char= c #\Return) (< (1+ i) (length string)) + (char= (char string (1+ i)) #\Newline)) + (add-line i) (setf start (+ i 2)) (incf i))))) + (when (< start (length string)) (add-line (length string))) + (coerce (nreverse result) 'vector)))) +#+END_SRC -The function must handle prefix stripping (e.g. remove `# ` after -counting hashes) and edge cases like `#` inside a code block (which -we don't classify at all — the code block state machine handles that). +**** classify-line -One trap: a line like `#not-a-heading` (no space after hash) is NOT -a heading in CommonMark. We check for space/tab after the hashes. +The core line classification function. It checks line prefixes in +priority order — blank lines, thematic breaks, ATX headings, blockquote +markers, unordered/ordered list items, diff headers, diff lines, and +fenced code-block starts — and returns a ~(cons type data)~ pair. +Everything else is treated as a paragraph continuation line. -Another trap: `* item` in a list vs `**bold**` inline. At the -block-parser level we only look at /line-start/ `* ` (star + space) -for list items. A line starting with `** text` could be either a -nested list item or bold text in a paragraph — we conservatively -treat it as a list-item (the inline parser will handle ** inside -paragraphs normally). - -#+BEGIN_SRC lisp :tangle no +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp (defun classify-line (line) - "Classify a trimmed LINE, returning (type . data). -TYPE is a keyword; DATA is language for code-blocks, level for headings, etc." (cond - ;; Empty line ((string= line "") (cons :blank nil)) - ;; Thematic break: --- or *** (3+ chars, all same, optional whitespace) ((and (>= (length line) 3) - (every (lambda (c) (or (char= c (char line 0)) - (char= c #\Space) - (char= c #\Tab))) - line) - (find (char line 0) "-*")) + (let ((c0 (char line 0))) + (and (find c0 "-*") + (every (lambda (c) (or (char= c c0) (char= c #\Space) (char= c #\Tab))) + line)))) (cons :thematic-break nil)) - ;; Heading: #+, with space after hashes ((and (char= (char line 0) #\#) (let ((count 0)) - (loop for c across line - while (char= c #\#) - do (incf count)) + (loop for c across line while (char= c #\#) do (incf count)) (and (<= 1 count 6) (or (>= (length line) (1+ count)) (member (char line count) '(#\Space #\Tab)))))) (let* ((hash-count (loop for c across line while (char= c #\#) count c)) - (content (string-trim (list #\Space #\Tab) - (subseq line hash-count)))) + (content (string-trim (list #\Space #\Tab) (subseq line hash-count)))) (cons :heading (cons hash-count content)))) - ;; Blockquote: > - ((and (>= (length line) 1) (char= (char line 0) #\>)) - (let ((content (string-trim (list #\Space #\Tab) - (subseq line 1)))) - (cons :blockquote content))) - ;; Unordered list: -, *, + - ((and (>= (length line) 2) - (find (char line 0) "-*+") + ((char= (char line 0) #\>) + (cons :blockquote (string-trim (list #\Space #\Tab) (subseq line 1)))) + ((and (>= (length line) 2) (find (char line 0) "-*+") (char= (char line 1) #\Space)) (cons :list-item (string-trim (list #\Space #\Tab) (subseq line 2)))) - ;; Ordered list: N. or N) - ((and (>= (length line) 3) - (digit-char-p (char line 0)) - (loop for c across line - while (digit-char-p c) - finally (return (find c '(#\. #\) #\Space))))) + ((and (>= (length line) 3) (digit-char-p (char line 0)) + (loop for c across line while (digit-char-p c) + finally (return (find c ". )")))) (let ((dot-pos (position-if (lambda (c) (find c ". )")) line))) (if (and dot-pos (find (char line dot-pos) ". )")) (cons :ordered-item (string-trim (list #\Space #\Tab) (subseq line (1+ dot-pos)))) (cons :paragraph line)))) - ;; Diff: --- file or +++ file - ((and (>= (length line) 4) - (find (char line 0) "-+") + ((and (>= (length line) 4) (find (char line 0) "-+") (char= (char line 1) (char line 0)) (char= (char line 2) (char line 0)) (char= (char line 3) #\Space)) (cons :diff-header line)) - ;; Diff: line content with +/- prefix - ((and (>= (length line) 1) - (find (char line 0) "-+") + ((and (>= (length line) 1) (find (char line 0) "-+") (not (and (>= (length line) 3) (char= (char line 1) (char line 0)) (char= (char line 2) (char line 0))))) (cons :diff-line (cons (char line 0) (subseq line 1)))) - ;; Fenced code block start: ``` or ~~~ - ((and (>= (length line) 3) - (find (char line 0) "`~") - (every (lambda (c) (char= c (char line 0))) - (subseq line 0 (min 6 (length line)))) - (let ((rest (string-trim (list #\Space #\Tab) (subseq line (min 6 (length line)))))) - (cons :code-start rest)))) - ;; Default: paragraph content + ((and (>= (length line) 3) (find (char line 0) "`~") + (let ((fence-len (loop for c across line + while (char= c (char line 0)) count c))) + (and (>= fence-len 3) + (let ((rest (string-trim (list #\Space #\Tab) + (subseq line fence-len)))) + (cons :code-start rest)))))) (t (cons :paragraph line)))) #+END_SRC ---- per-function: parse-blocks +**** find-closing-marker -~parse-blocks~ is the main block-level parser. It takes a string -(possibly multi-line) and returns a list of markdown node plists. +Scans for a literal marker string starting from position ~start~, +escaping backslash-escaped markers. This is shared by inline +emphasis, code span, and link parsing. Returns the position or ~nil~. -The algorithm: -1. Split into lines -2. Classify each line -3. Accumulate lines of the same type into groups -4. Convert each group into a node - -State transitions: -- `:paragraph` accumulates until blank line or different block type -- `:blockquote` accumulates until blank line -- `:list-item` and `:ordered-item` accumulate until blank line -- `:code-start` flips to code-block mode; accumulates until matching - fence closer or end of input -- `:diff-header` starts a diff block; diff lines accumulate until - blank line or non-diff line - -Edge case: a paragraph followed by a list item should stay as -separate blocks (not merge). The blank-line check handles this -because the paragraph only continues for non-blank, non-list lines. - -#+BEGIN_SRC lisp :tangle no -(defun parse-blocks (text) - "Parse TEXT (a string) into a list of block-level markdown node plists. -Returns (nodes . unconsumed-lines) for recursive callers." - (let ((lines (split-string-into-lines text)) - (nodes nil) - (i 0)) - (loop while (< i (length lines)) - do (let* ((line (string-trim (list #\return) (aref lines i))) - (classification (classify-line line))) - (case (car classification) - (:blank (incf i)) - (:thematic-break - (push (make-md-node :thematic-break) nodes) - (incf i)) - (:paragraph - (multiple-value-bind (node consumed) - (parse-paragraph lines i) - (push node nodes) - (setf i consumed))) - (:heading - (let* ((level-and-content (cdr classification)) - (level (car level-and-content)) - (content (cdr level-and-content))) - (push (make-md-node :heading - :properties (list :level level) - :children (parse-inline content)) - nodes) - (incf i))) - (:blockquote - (multiple-value-bind (node consumed) - (parse-blockquote lines i) - (push node nodes) - (setf i consumed))) - (:list-item - (multiple-value-bind (node consumed) - (parse-list lines i :unordered) - (push node nodes) - (setf i consumed))) - (:ordered-item - (multiple-value-bind (node consumed) - (parse-list lines i :ordered) - (push node nodes) - (setf i consumed))) - (:code-start - (multiple-value-bind (node consumed) - (parse-code-block lines i (cdr classification)) - (push node nodes) - (setf i consumed))) - (:diff-header - (multiple-value-bind (node consumed) - (parse-diff-block lines i) - (push node nodes) - (setf i consumed))) - (t (incf i))))) - ;; Return in reading order - (nreverse nodes))) +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun find-closing-marker (text start marker) + (let ((marker-len (length marker)) (len (length text))) + (loop for j from start to (- len marker-len) + do (when (and (char= (char text j) (char marker 0)) + (string= marker (subseq text j (+ j marker-len))) + (or (= j 0) (not (char= (char text (1- j)) #\\)))) + (return j)) + finally (return nil)))) #+END_SRC ---- per-function: split-string-into-lines +**** parse-paragraph -~split-string-into-lines~ is a utility rather than relying on -~cl-ppcre~ (which we don't depend on). It splits on #\Newline -and handles the edge case of trailing newlines (doesn't produce -an extra empty line at the end). +Collects consecutive paragraph lines (lines classified as ~:paragraph~) +into a single ~:paragraph~ node. Stops at a blank line or any +non-paragraph classification. Lines are joined with spaces before +inline parsing. -#+BEGIN_SRC lisp :tangle no -(defun split-string-into-lines (string) - "Split STRING into a vector of lines (no trailing newline). -Handles \\n, \\r\\n, and trailing newlines properly." - (let ((result nil) - (start 0)) - (flet ((add-line (end) - (push (subseq string start end) result))) - (loop for i from 0 below (length string) - do (let ((c (char string i))) - (cond ((char= c #\Newline) - (add-line i) - (setf start (1+ i))) - ((and (char= c #\Return) - (< (1+ i) (length string)) - (char= (char string (1+ i)) #\Newline)) - (add-line i) - (setf start (+ i 2)) - (incf i))))) - (when (< start (length string)) - (add-line (length string))) - (coerce (nreverse result) 'vector)))) -#+END_SRC - ---- per-function: parse-paragraph - -~parse-paragraph~ collects one or more contiguous paragraph lines -until a blank line or a different block type. It joins them with -spaces (for hard-wrapped prose) and returns a :paragraph node -with inline-parsed children. - -Continuation lines in paragraphs are joined with a single space -(not a newline). This is correct for Markdown's soft-wrap -convention where a newline in source = space in output. To force -a hard break, CommonMark uses two trailing spaces — we skip that -for now since it's rare in TUI contexts. - -#+BEGIN_SRC lisp :tangle no +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp (defun parse-paragraph (lines start) - "Parse contiguous paragraph lines from LINES starting at START. -Returns (node . consumed-index)." - (let ((text-parts nil) - (i start)) + (let ((text-parts nil) (i start)) (loop while (< i (length lines)) do (let* ((raw-line (aref lines i)) (line (string-trim (list #\return) raw-line)) (class (classify-line line))) (case (car class) - ((:paragraph) - (push (cdr class) text-parts) - (incf i)) + ((:paragraph) (push (cdr class) text-parts) (incf i)) (:blank (incf i) (loop-finish)) (t (loop-finish))))) - (let ((text (with-output-to-string (s) - (loop for part in (nreverse text-parts) - for first = t then nil - do (unless first (write-char #\Space s)) - (princ part s))))) - (cons (make-md-node :paragraph - :children (parse-inline text)) - i)))) + (values (make-md-node :paragraph :children + (parse-inline + (with-output-to-string (s) + (loop for part in (nreverse text-parts) + for first = t then nil + do (unless first (write-char #\Space s)) + (princ part s))))) + i))) #+END_SRC ---- per-function: parse-blockquote +**** parse-blockquote -~parse-blockquote~ collects contiguous `>` lines, strips the `>` -prefix, joins them, and wraps in a :blockquote node. Nested -blockquotes (`> >`) are not supported in this version — a `>` at -the start of the content is treated as literal text. +Like ~parse-paragraph~ but collects ~:blockquote~ lines and strips the +leading ~>~ marker. The collected text is then inline-parsed to +support bold, italic, code, and links inside quotes. -#+BEGIN_SRC lisp :tangle no +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp (defun parse-blockquote (lines start) - "Parse contiguous blockquote lines from LINES starting at START. -Returns (node . consumed-index)." - (let ((text-parts nil) - (i start)) + (let ((text-parts nil) (i start)) (loop while (< i (length lines)) do (let* ((raw-line (aref lines i)) (line (string-trim (list #\return) raw-line)) (class (classify-line line))) (case (car class) - (:blockquote - (push (cdr class) text-parts) - (incf i)) + (:blockquote (push (cdr class) text-parts) (incf i)) (:blank (incf i) (loop-finish)) (t (loop-finish))))) - (let ((text (with-output-to-string (s) - (loop for part in (nreverse text-parts) - for first = t then nil - do (unless first (write-char #\Space s)) - (princ part s))))) - (cons (make-md-node :blockquote - :children (parse-inline text)) - i)))) + (values (make-md-node :blockquote :children + (parse-inline + (with-output-to-string (s) + (loop for part in (nreverse text-parts) + for first = t then nil + do (unless first (write-char #\Space s)) + (princ part s))))) + i))) #+END_SRC ---- per-function: parse-list +**** parse-list -~parse-list~ collects contiguous list items (same type) and returns -a list of nodes. Each line starting with a list marker becomes one -list-item node. Nested lists are not supported (lines starting with -two spaces + marker would be the next level — we skip that for v1). +Handles both unordered (~:list-item~) and ordered (~:ordered-item~) +list items. Adjacent blank lines between items are allowed (creating +loose lists), but a blank line followed by a non-list line terminates +the list. Returns multiple nodes because each top-level list item +becomes its own ~:list-item~ or ~:ordered-item~ node. -The TYPE parameter is either `:unordered` or `:ordered` — though -we return each item labeled by its actual marker type since we -already classified each line. - -#+BEGIN_SRC lisp :tangle no -(defun parse-list (lines start type) - "Parse contiguous list items from LINES starting at START. -TYPE is :unordered or :ordered. -Returns (node . consumed-index) where node is a :list-item or :ordered-item." - (declare (ignore type)) - (let ((items nil) - (i start)) - ;; Collect all contiguous list items into ITEMS +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-list (lines start) + (let ((items nil) (i start)) (loop while (< i (length lines)) do (let* ((raw-line (aref lines i)) (line (string-trim (list #\return) raw-line)) (class (classify-line line))) - (case (car class) + (case (car class) ((:list-item :ordered-item) - (push (cons (car class) (cdr class)) items) - (incf i)) + (push (cons (car class) (cdr class)) items) (incf i)) (:blank - ;; One blank line between items is OK; two ends the list (if (and (< (1+ i) (length lines)) - (let ((next-class (classify-line - (string-trim - (list #\return) - (aref lines (1+ i)))))) - (member (car next-class) - '(:list-item :ordered-item)))) - (progn - (push (cons :blank-sep nil) items) - (incf i)) + (let ((nc (classify-line + (string-trim (list #\return) + (aref lines (1+ i)))))) + (member (car nc) '(:list-item :ordered-item)))) + (progn (push (cons :blank-sep nil) items) (incf i)) (progn (incf i) (loop-finish)))) (t (loop-finish))))) - ;; Convert each item to a node (let ((nodes nil)) (dolist (item (nreverse items)) - (let ((type (car item)) - (content (cdr item))) + (let ((type (car item)) (content (cdr item))) (when (and content (not (string= content ""))) - (push (make-md-node type - :children (parse-inline content)) - nodes)))) - (cons (nreverse nodes) i)))) + (push (make-md-node type :children (parse-inline content)) nodes)))) + (values (nreverse nodes) i)))) #+END_SRC ---- per-function: parse-code-block +**** parse-code-block -~parse-code-block~ reads from the line after the opening fence to -the closing fence (or end of input). It returns a :code-block node -with the language (or NIL) and the raw text as the :content. No -inline parsing is done inside code blocks — everything is literal. +Parses a fenced code block starting at ~start~. The fence character +and length are detected from the opening line; the closing fence must +match in character and be at least as long. The language (if any) is +taken from the info string on the opening fence. Produces a single +~:code-block~ node. -Matching fence: if opened with `` ``` ``, close with `` ``` ``. -If opened with `~~~`, close with `~~~`. The closing fence must have -at least as many backticks/tildes as the opening fence (CommonMark -rule). We use the simpler version: same character, same count. - -#+BEGIN_SRC lisp :tangle no +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp (defun parse-code-block (lines start lang) - "Parse a fenced code block from LINES starting at START. -LANG is the language string (or empty string) from the opening fence. -Returns (node . consumed-index)." (let ((code-lines nil) (i (1+ start)) (fence-char (char (aref lines start) 0)) (fence-len (loop for c across (aref lines start) - while (char= c (char (aref lines start) 0)) - count c)) - (found-close nil)) + while (char= c (char (aref lines start) 0)) count c))) (loop while (< i (length lines)) do (let* ((raw-line (aref lines i)) (line (string-trim (list #\return) raw-line))) - ;; Check for closing fence (when (and (>= (length line) fence-len) (every (lambda (c) (char= c fence-char)) (subseq line 0 fence-len)) (or (= (length line) fence-len) (every (lambda (c) (find c " \t")) (subseq line fence-len)))) - (setf found-close t) - (incf i) - (loop-finish)) + (incf i) (loop-finish)) + (push line code-lines) + (incf i))) + (values (make-md-node :code-block + :properties (list :language (and lang (not (string= lang "")) lang)) + :content + (with-output-to-string (s) + (loop for cl in (nreverse code-lines) + for first = t then nil + do (unless first (terpri s)) (princ cl s)))) + i))) +#+END_SRC + +**** parse-diff-block + +Collects consecutive diff lines (~:diff-header~, ~:diff-line~) into a +single ~:diff-block~ node. The raw lines are preserved in a ~:lines~ +property for coloured rendering later. Diff blocks are delimited by +blank lines. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-diff-block (lines start) + (let ((diff-lines nil) (i start)) + (loop while (< i (length lines)) + do (let* ((raw-line (aref lines i)) + (line (string-trim (list #\return) raw-line)) + (class (classify-line line))) + (case (car class) + ((:diff-header :diff-line) (push line diff-lines) (incf i)) + (:blank (incf i) (loop-finish)) + (t (loop-finish))))) + (let ((lines-list (nreverse diff-lines))) + (values (make-md-node :diff-block + :content + (with-output-to-string (s) + (loop for dl in lines-list + for first = t then nil + do (unless first (terpri s)) (princ dl s))) + :properties (list :lines lines-list)) + i)))) +#+END_SRC + +**** parse-blocks + +Top-level block parser. Dispatches on the ~classify-line~ result to +call the appropriate sub-parser, accumulating nodes into a list. +Handles blank lines, thematic breaks, headings, paragraphs, +blockquotes, lists, code blocks, and diff blocks. Returns ~nil~ for +~nil~ input. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-blocks (text) + (unless text (return-from parse-blocks nil)) + (let ((lines (split-string-into-lines text)) (nodes nil) (i 0)) + (loop while (< i (length lines)) + do (let* ((line (string-trim (list #\return) (aref lines i))) + (classification (classify-line line))) + (case (car classification) + (:blank (incf i)) + (:thematic-break (push (make-md-node :thematic-break) nodes) (incf i)) + (:paragraph + (multiple-value-bind (node consumed) (parse-paragraph lines i) + (push node nodes) (setf i consumed))) + (:heading + (let* ((level+content (cdr classification)) + (level (car level+content)) + (content (cdr level+content))) + (push (make-md-node :heading :properties (list :level level) + :children (parse-inline content)) nodes) + (incf i))) + (:blockquote + (multiple-value-bind (node consumed) (parse-blockquote lines i) + (push node nodes) (setf i consumed))) + (:list-item + (multiple-value-bind (node consumed) (parse-list lines i) + (dolist (n node) (push n nodes)) (setf i consumed))) + (:ordered-item + (multiple-value-bind (node consumed) (parse-list lines i) + (dolist (n node) (push n nodes)) (setf i consumed))) + (:code-start + (multiple-value-bind (node consumed) + (parse-code-block lines i (cdr classification)) + (push node nodes) (setf i consumed))) + (:diff-header + (multiple-value-bind (node consumed) (parse-diff-block lines i) + (push node nodes) (setf i consumed))) + (t (incf i))))) + (nreverse nodes))) +#+END_SRC + +*** Inline parser + +The inline parser handles character-level formatting inside block +content: emphasis, code spans, and links. + +**** parse-inline + +Main inline dispatcher. Walks the text character by character. +~*~ triggers star emphasis; ~_~ triggers underscore emphasis; ~`~ +triggers inline code; ~[~ triggers links; everything else is +accumulated as plain ~:text~ nodes. Consecutive plain text is merged +into single nodes for efficiency. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-inline (text) + (unless (and text (> (length text) 0)) (return-from parse-inline nil)) + (let ((nodes nil) (i 0) (len (length text))) + (loop while (< i len) + do (let ((c (char text i))) + (case c + (#\* + (multiple-value-bind (node consumed) (parse-star-emphasis text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (#\_ + (multiple-value-bind (node consumed) (parse-underscore-emphasis text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (#\` + (multiple-value-bind (node consumed) (parse-inline-code text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (#\[ + (multiple-value-bind (node consumed) (parse-link text i len) + (if node (progn (push node nodes) (setf i consumed)) + (progn (push (make-md-node :text :content (string c)) nodes) (incf i))))) + (t (let ((start i)) + (incf i) + (loop while (< i len) + do (let ((nc (char text i))) + (if (find nc "*_`[") (loop-finish) + (progn + (when (and (< (1+ i) len) + (find nc "*_") + (char= nc (char text (1+ i)))) + (loop-finish)) + (incf i))))) + (push (make-md-node :text :content (subseq text start i)) nodes)))))) + (nreverse nodes))) +#+END_SRC + +**** parse-star-emphasis + +Handles ~*italic*~ and ~**bold**~ using star markers. A double star +is tried first; if the closing ~**~ is found it produces a ~:bold~ +node, otherwise it falls back to single-star ~:italic~. If neither +closes, returns ~nil~ to let the caller treat the character as literal +text. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-star-emphasis (text i len) + (when (>= i len) (return-from parse-star-emphasis (values nil i))) + (if (and (< (1+ i) len) (char= (char text (1+ i)) #\*)) + (let ((close (find-closing-marker text (+ i 2) "**"))) + (if close + (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close))) + (+ close 2)) + (values nil i))) + (let ((close (find-closing-marker text (1+ i) "*"))) + (if close + (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close))) + (1+ close)) + (values nil i))))) +#+END_SRC + +**** parse-underscore-emphasis + +Handles ~_italic_~ and ~__bold__~ using underscore markers. +Underscore emphasis is more restrictive than star emphasis: it only +opens after whitespace or at the start of text, and single-underscore +italic only closes before whitespace or punctuation. This avoids false +positives in identifiers like ~foo_bar~. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-underscore-emphasis (text i len) + (when (>= i len) (return-from parse-underscore-emphasis (values nil i))) + (when (and (> i 0) (not (find (char text (1- i)) " \t\n\r"))) + (return-from parse-underscore-emphasis (values nil i))) + (if (and (< (1+ i) len) (char= (char text (1+ i)) #\_)) + (let ((close (find-closing-marker text (+ i 2) "__"))) + (if close + (values (make-md-node :bold :children (parse-inline (subseq text (+ i 2) close))) + (+ close 2)) + (values nil i))) + (let ((close (find-closing-marker text (1+ i) "_"))) + (if (and close + (or (>= (1+ close) len) + (find (char text (1+ close)) " \t\n\r.,;:!?"))) + (values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close))) + (1+ close)) + (values nil i))))) +#+END_SRC + +**** parse-inline-code + +Parses backtick-delimited inline code spans. Supports up to three +backticks as delimiters (so single backticks inside double-backtick +spans work). The matched pair's backtick count must be equal. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-inline-code (text i len) + (when (or (>= i len) (not (char= (char text i) #\`))) + (return-from parse-inline-code (values nil i))) + (let ((bt-count (loop for j from i below (min len (+ i 3)) + while (char= (char text j) #\`) count j))) + (let ((close (find-closing-marker text (+ i bt-count) + (make-string bt-count :initial-element #\`)))) + (if close + (values (make-md-node :inline-code + :content (subseq text (+ i bt-count) close)) + (+ close bt-count)) + (values nil i))))) +#+END_SRC + +**** parse-link + +Parses Markdown links in the form ~[text](url)~. Uses nested bracket +matching via ~find-closing-marker~. The text portion is inline-parsed +to support formatting inside link text. Returns ~nil~ if the syntax +is incomplete, letting the caller render the ~[~ as literal text. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun parse-link (text i len) + (when (or (>= i len) (not (char= (char text i) #\[))) + (return-from parse-link (values nil i))) + (let ((close-bracket (find-closing-marker text (1+ i) "]"))) + (unless close-bracket (return-from parse-link (values nil i))) + (when (or (>= (1+ close-bracket) len) + (not (char= (char text (1+ close-bracket)) #\())) + (return-from parse-link (values nil i))) + (let ((close-paren (find-closing-marker text (+ close-bracket 2) ")"))) + (unless close-paren (return-from parse-link (values nil i))) + (values (make-md-node :link + :children (parse-inline (subseq text (1+ i) close-bracket)) + :url (subseq text (+ close-bracket 2) close-paren)) + (1+ close-paren))))) +#+END_SRC + +*** Syntax highlighting + +Syntax highlighting tokenises source code into (token . category) pairs +that the renderer colours with ANSI escape codes. Each supported +language has a definition of comment, string, keyword, and builtin +patterns. + +**** get-highlighter + +Returns a plist of highlighting rules for a given language name. +The rules define ~:comment~, ~:string~, ~:keyword~, and ~:builtin~ +patterns. Supported languages: lisp, common-lisp, python, +javascript, bash, shell. Unknown languages return ~nil~, which tells +the caller to fall back to plain rendering. The assoc list uses +~string=~ for matching on the language tag, and each entry uses a +dotted-pair format ~(\"language\" . plist)~. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun get-highlighter (lang) + (cdr (assoc lang + '(("lisp" . (:comment (";" "#|" ";;") :string ("\"") + :keyword ("defun" "defmacro" "defmethod" "defgeneric" + "defvar" "defparameter" "defconstant" "defstruct" + "defclass" "deftype" "define-condition" + "let" "let*" "flet" "labels" "macrolet" + "if" "when" "unless" "cond" "case" "ecase" "typecase" + "loop" "do" "dolist" "dotimes" "tagbody" "go" + "block" "return" "return-from" + "progn" "prog1" "prog2" + "lambda" "function" "quote" + "setf" "setq" "push" "pop" "incf" "decf" + "in-package" "defpackage" "export" "import" + "handler-case" "handler-bind" "ignore-errors" + "multiple-value-bind" "multiple-value-call" + "destructuring-bind" + "declare" "the" "values" + "and" "or" "not" "null" + "car" "cdr" "first" "rest" "second" + "cons" "list" "append" "nconc" + "mapcar" "mapc" "reduce" + "find" "position" "count" "subseq" + "format" "princ" "print" "write" "read" + "load" "compile" "eval" + "make-instance" "slot-value" + "type-of" "class-of") + :builtin ("t" "nil" + "*standard-output*" "*standard-input*" + "*error-output*" "*debug-io*" + "*package*" "*print-circle*"))) + + ("common-lisp" . (:comment (";" "#|" ";;") :string ("\"") + :keyword ("defun" "defmacro" "defmethod" "defgeneric" + "let" "if" "when" "unless" "cond" "case" + "loop" "do" "dolist" "dotimes" + "return" "return-from" "block" + "lambda" "function" "quote" + "setf" "setq" "push" "pop" "incf" "decf" + "handler-case" "handler-bind" + "declare" "the" "values" + "defpackage" "in-package" "export" "import" + "error" "warn" "assert" + "car" "cdr" "first" "rest" + "cons" "list" "append" "mapcar" "reduce" + "format" "princ" "print" "read" "load" + "make-instance") + :builtin ("t" "nil"))) + + ("python" . (:comment ("#") :string ("\"" "'" "\"\"\"" "'''") + :keyword ("def" "class" "return" "yield" "import" "from" + "if" "elif" "else" "for" "while" "in" "not" + "try" "except" "finally" "raise" "with" "pass" + "break" "continue" "lambda" "global" + "assert" "del" "is" + "self" "cls" "async" "await") + :builtin ("None" "True" "False"))) + + ("javascript" . (:comment ("//" "/*") :string ("\"" "'" "`") + :keyword ("function" "class" "const" "let" "var" + "if" "else" "for" "while" "do" "switch" + "return" "break" "continue" + "try" "catch" "finally" "throw" + "new" "this" "super" "delete" "typeof" + "import" "export" "from" "default" + "async" "await" "yield" "of") + :builtin ("true" "false" "null" "undefined" "NaN"))) + + ("bash" . (:comment ("#") :string ("\"" "'") + :keyword ("if" "then" "else" "elif" "fi" "for" "while" + "done" "case" "esac" "in" "function" "return" + "export" "local" "unset" "source" + "echo" "printf" "read" "test" "let" "declare") + :builtin ("true" "false" "cd" "ls" "cat" "grep" "sed" + "mv" "cp" "rm" "mkdir" "touch" "find" "wc" + "head" "tail" "date" "sleep" "kill"))) + + ("shell" . (:comment ("#") :string ("\"" "'") + :keyword ("if" "then" "else" "elif" "fi" "for" "while" + "done" "case" "esac" "in" "function" "return" + "export" "local" "unset" "source" + "echo" "printf" "read" "test") + :builtin ("true" "false" "cd" "ls" "grep" "sed" + "mv" "cp" "rm" "mkdir" "touch" "find")))) + :test #'string=))) +#+END_SRC + +**** tokenize-line + +Tokenises a single line of source code into ~(token . category)~ +pairs. Categories are ~:plain~, ~:comment~, ~:string~, ~:number~, +~:keyword~, ~:builtin~, and ~:function~. The highlighter plist +provides the patterns for comment delimiters, string delimiters, +keywords, and builtins. Words immediately followed by ~(~ are +classified as ~:function~ calls. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun tokenize-line (line highlighter) + (let ((tokens nil) (i 0) (len (length line)) + (comment-chars (getf highlighter :comment)) + (string-chars (getf highlighter :string)) + (keywords (getf highlighter :keyword)) + (builtins (getf highlighter :builtin))) + (loop while (< i len) + do (let ((c (char line i))) + (cond + ((find c " \t") + (let ((start i)) + (loop while (and (< i len) (find (char line i) " \t")) do (incf i)) + (push (cons (subseq line start i) :plain) tokens))) + ((and comment-chars + (some (lambda (cc) + (and (<= (+ i (length cc)) len) + (string= cc (subseq line i (+ i (length cc)))))) + comment-chars)) + (push (cons (subseq line i) :comment) tokens) (setf i len)) + ((and string-chars (some (lambda (s) (find c s)) string-chars)) + (let ((start i)) + (incf i) + (let ((triple (and (< i (1- len)) (char= (char line i) c) + (char= (char line (1+ i)) c)))) + (if triple + (progn (incf i 2) + (loop while (and (< i len) + (not (and (char= (char line i) c) + (< (1+ i) len) + (char= (char line (1+ i)) c) + (< (+ i 2) len) + (char= (char line (+ i 2)) c)))) + do (incf i)) + (incf i 3)) + (progn (loop while (and (< i len) (char/= (char line i) c)) + do (incf i)) + (when (< i len) (incf i))))) + (push (cons (subseq line start i) :string) tokens))) + ((or (digit-char-p c) + (and (find c "+-") (< (1+ i) len) (digit-char-p (char line (1+ i))))) + (let ((start i)) + (loop while (and (< i len) (not (find (char line i) " \t()[]{}'\";:#"))) + do (incf i)) + (let ((token (subseq line start i))) + (if (digit-char-p (char token 0)) + (push (cons token :number) tokens) + (push (cons token :plain) tokens))))) + ((or (alpha-char-p c) + (and (find c "-_?!*<>=") (> len 1))) + (let ((start i)) + (loop while (and (< i len) + (or (alphanumericp (char line i)) + (find (char line i) "-_?!*<>="))) + do (incf i)) + (let* ((token (subseq line start i)) + (down (string-downcase token))) + (cond + ((find down keywords :test #'string=) + (push (cons token :keyword) tokens)) + ((find down builtins :test #'string=) + (push (cons token :builtin) tokens)) + (t (if (and (< i len) (char= (char line i) #\()) + (push (cons token :function) tokens) + (push (cons token :plain) tokens))))))) + (t (push (cons (string c) :plain) tokens) (incf i))))) + (nreverse tokens))) +#+END_SRC + +**** highlight-code + +Applies syntax highlighting to a whole code string. Splits the code +into lines, tokenises each line with the language's highlighter, and +returns a flat list of ~(token . category)~ pairs with newline +separators between lines. Returns ~nil~ for empty input or a single +~:plain~ pair if no highlighter is found for the language. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun highlight-code (code language) + (unless code (return-from highlight-code nil)) + (let ((highlighter (get-highlighter (and language (string-downcase language))))) + (unless highlighter (return-from highlight-code (list (cons code :plain)))) + (let ((tokens nil)) + (with-input-from-string (stream code) + (loop for line = (read-line stream nil nil) while line + do (let ((line-tokens (tokenize-line line highlighter))) + (when tokens (push (cons (string #\Newline) :plain) tokens)) + (setf tokens (nconc (nreverse line-tokens) tokens))))) + (nreverse tokens)))) +#+END_SRC + +**** apply-highlight-token + +Wraps a single token in an ANSI escape code based on its highlight +category. Keywords get colour 33 (yellow), builtins 36 (cyan), +functions 34 (blue), comments 2 (dim), strings 32 (green), numbers +35 (magenta). Unrecognised categories render as plain text. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun apply-highlight-token (token category) + (let ((code (case category + (:keyword "33") (:builtin "36") + (:function "34") (:comment "2") (:string "32") (:number "35") + (t nil)))) + (if code (format nil "~c[~am~a~c[0m" #\Esc code token #\Esc) token))) +#+END_SRC + +**** apply-highlight-style + +Coerces an adjustable character vector (accumulated during line +rendering) back into a string. This is a thin wrapper that exists +for potential future customisation of style application. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun apply-highlight-style (char-vector) + (coerce char-vector 'string)) +#+END_SRC + +*** Diff rendering + +The diff rendering utilities classify diff lines and produce +colourised output. + +**** string-prefix-p + +Utility predicate that checks whether ~string~ starts with ~prefix~. +Avoids reimplementing this inline in multiple diff classifiers. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun string-prefix-p (prefix string) + (and (>= (length string) (length prefix)) + (string= prefix (subseq string 0 (length prefix))))) +#+END_SRC + +**** classify-diff-line + +Classifies a single diff line into a semantic category: ~:file-header~ +(for ~+++~ and ~---~ lines), ~:hunk-header~ (for ~@@~ lines), ~:added~ +(for ~+~ lines), ~:removed~ (for ~-~ lines), or ~:context~ (for +everything else). This powers colourised diff rendering. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun classify-diff-line (line) + (cond ((string-prefix-p "+++ " line) :file-header) + ((string-prefix-p "--- " line) :file-header) + ((string-prefix-p "@@" line) :hunk-header) + ((string-prefix-p "+" line) :added) + ((string-prefix-p "-" line) :removed) + (t :context))) +#+END_SRC + +*** Rendering + +The rendering layer converts parsed AST nodes into styled terminal +output strings. Each node type has its own renderer, and +~render-md-node~ dispatches to the correct one. + +**** apply-style + +Wraps ~text~ in ANSI escape codes for a given ~style~ keyword or +string. Supports both keyword (e.g. ~:bold~) and string (e.g. +~\"bold\"~) style designators for flexibility. Common styles include +bold, italic, dim, code, link, underline, and the full set of 16 +terminal colours. Unrecognised styles return the text unchanged. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun apply-style (style text) + (let ((code (cond + ((eql style :bold) "1") ((eql style :italic) "3") + ((eql style :dim) "2") ((eql style :code) "0") + ((eql style :link) "4;36") ((eql style :url) "4;2") + ((eql style :underline) "4") ((eql style :strike) "9") + ((eql style :black) "30") ((eql style :red) "31") + ((eql style :green) "32") ((eql style :yellow) "33") + ((eql style :blue) "34") ((eql style :magenta) "35") + ((eql style :cyan) "36") ((eql style :white) "37") + ((eql style :bright-black) "90") ((eql style :bright-red) "91") + ((eql style :bright-green) "92") ((eql style :bright-yellow) "93") + ((eql style :bright-blue) "94") ((eql style :bright-magenta) "95") + ((eql style :bright-cyan) "96") ((eql style :bright-white) "97") + ((string= style "bold") "1") ((string= style "italic") "3") + ((string= style "dim") "2") ((string= style "code") "0") + ((string= style "link") "4;36") ((string= style "url") "4;2") + ((string= style "bright-cyan") "96") + ((string= style "bright-yellow") "93") + ((string= style "bright-white") "97") + ((string= style "bright-red") "91") + ((string= style "bright-green") "92") + ((string= style "bright-blue") "94") + ((string= style "bright-magenta") "95") + ((string= style "cyan") "36") ((string= style "yellow") "33") + ((string= style "red") "31") ((string= style "green") "32") + ((string= style "blue") "34") ((string= style "magenta") "35") + ((string= style "white") "37") ((string= style "black") "30") + (t nil)))) + (if code (format nil "~c[~am~a~c[0m" #\Esc code text #\Esc) text))) +#+END_SRC + +**** render-inline + +Renders a list of inline child nodes into a single string. Handles +~:text~ (plain), ~:bold~, ~:italic~, ~:inline-code~, and ~:link~ +types. Links render the text styled as link followed by the URL in +parentheses styled as url. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-inline (children) + (if (null children) "" + (with-output-to-string (s) + (dolist (child children) + (let ((type (getf child :type))) + (case type + (:text (princ (or (getf child :content) "") s)) + (:bold (princ (apply-style :bold (render-inline (getf child :children))) s)) + (:italic (princ (apply-style :italic (render-inline (getf child :children))) s)) + (:inline-code (princ (apply-style :code (or (getf child :content) "")) s)) + (:link (let ((text (render-inline (getf child :children))) + (url (or (getf child :url) ""))) + (princ (apply-style :link text) s) + (when (and url (not (string= url ""))) + (princ " " s) + (princ (apply-style :url (format nil "(~a)" url)) s)))) + (t (princ (or (getf child :content) "") s)))))))) +#+END_SRC + +**** render-heading + +Renders a heading node as a coloured ~# Title~ line. The heading +level determines the number of ~#~ characters (capped at 6) and the +colour: level 1 uses bright-cyan, level 2 uses bright-yellow, and +deeper levels use bright-white. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-heading (node) + (let* ((level (or (getf (getf node :properties) :level) 1)) + (prefix (make-string (min level 6) :initial-element #\#)) + (text (render-inline (getf node :children))) + (color (cond ((= level 1) :bright-cyan) ((= level 2) :bright-yellow) + (t :bright-white)))) + (list (apply-style color (concatenate 'string prefix " " text))))) +#+END_SRC + +**** render-paragraph + +Renders a paragraph node by inline-rendering its children. The +result is a single-element list containing the rendered text. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-paragraph (node) + (list (render-inline (getf node :children)))) +#+END_SRC + +**** render-blockquote + +Renders a blockquote node with a dimmed ~> ~ prefix before the +inline-rendered content. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-blockquote (node) + (list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children)))))) +#+END_SRC + +**** render-code-block + +Renders a fenced code block. If the block has a language tag and the +highlighter supports it, the code is syntax-highlighted with ANSI +colours. Otherwise it is rendered in plain ~:code~ style. A dimmed +language header line is shown when a language is present. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-code-block (node) + (let* ((language (or (getf (getf node :properties) :language) "")) + (content (or (getf node :content) "")) + (highlighted (unless (or (null language) (string= language "")) + (highlight-code content language))) + (lines nil)) + (when (and language (not (string= language ""))) + (push (apply-style :dim (format nil " ~~~~~~ ~a" language)) lines)) + (if highlighted + (let ((cl (make-array 0 :element-type 'character + :fill-pointer 0 :adjustable t)) + (output nil)) + (dolist (pair highlighted) + (let ((token (car pair)) (category (cdr pair))) + (cond ((string= token (string #\Newline)) + (push (apply-highlight-style cl) output) + (setf cl (make-array 0 :element-type 'character + :fill-pointer 0 :adjustable t))) + (t (let ((colored (apply-highlight-token token category))) + (loop for ch across colored + do (vector-push-extend ch cl))))))) + (when (> (length cl) 0) (push (apply-highlight-style cl) output)) + (setf lines (nconc lines (nreverse output)))) + (with-input-from-string (s content) + (loop for line = (read-line s nil nil) while line + do (push (apply-style :code line) lines)))) + (nreverse lines))) +#+END_SRC + +**** render-diff-block + +Renders a diff block by classifying each line and applying +colour: added lines in green (32), removed in red (31), hunk headers +in cyan (36), file headers in bold-cyan (1;36), and context lines +unstyled. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-diff-block (node) + (let* ((lines (getf (getf node :properties) :lines)) (result nil)) + (dolist (line (or lines + (and (getf node :content) + (let ((l (split-string-into-lines (getf node :content)))) + (loop for i from 0 below (length l) collect (aref l i)))))) + (let* ((class (classify-diff-line line)) + (color (case class + (:added "32") (:removed "31") + (:hunk-header "36") (:file-header "1;36") (t nil)))) + (if color + (push (format nil "~c[~am~a~c[0m" #\Esc color line #\Esc) result) + (push line result)))) + (nreverse result))) +#+END_SRC + +**** render-thematic-break + +Renders a thematic break as a dimmed horizontal rule using +Unicode box-drawing characters. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-thematic-break (node) + (declare (ignore node)) + (list (apply-style :dim "──────────────────────────────────────────────"))) +#+END_SRC + +**** render-list-item + +Renders a list item node. Ordered items get ~ 1.~ prefix, +unordered items get ~ * ~ prefix. The content is inline-rendered. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-list-item (node) + (list (concatenate 'string + (if (eql (getf node :type) :ordered-item) " 1." " * ") + (render-inline (getf node :children))))) +#+END_SRC + +**** render-md-node + +Dispatcher function that routes a single AST node to the correct +renderer based on its ~:type~. Each type-specific renderer returns a +list of strings (multiple lines), which ~render-md~ concatenates. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-md-node (node) + (let ((type (getf node :type))) + (case type + (:heading (render-heading node)) + (:paragraph (render-paragraph node)) + (:blockquote (render-blockquote node)) + (:code-block (render-code-block node)) + (:diff-block (render-diff-block node)) + (:thematic-break (render-thematic-break node)) + (:list-item (render-list-item node)) + (:ordered-item (render-list-item node)) + (t (list ""))))) +#+END_SRC + +**** render-md + +Renders a list of AST nodes (the output of ~parse-blocks~) into a +flat list of output lines by calling ~render-md-node~ on each node +and concatenating the results. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-md (nodes) + (let ((lines nil)) + (dolist (node nodes) (setf lines (nconc lines (render-md-node node)))) + lines)) +#+END_SRC + +**** render-markdown + +Top-level convenience function that parses a Markdown string and +renders it to a single output string with newline-separated lines. +Returns an empty string for ~nil~ input. + +#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp +(defun render-markdown (text) + (unless text (return-from render-markdown "")) + (let ((nodes (parse-blocks text)) (parts nil)) + (dolist (line (render-md nodes)) (push line parts)) + (with-output-to-string (s) + (loop for part in (nreverse parts) + for first = t then nil + do (unless first (terpri s)) (princ part s))))) +#+END_SRC + +* Tests + +The test suite covers parser edge cases, heading/paragraph parsing, inline +formatting (bold, italic, code, links), code blocks, blockquotes, lists, +diff classification, syntax highlighting, render output, and integration. + +The first block writes the target file (defpackage/suite). Subsequent blocks +append individual test groups. + +** Package and suite setup + +This block must be first because ~tests/markdown-tests.lisp~ does not +exist yet — the tangle script creates it by writing this block's content. +All later blocks append. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp +;;; markdown-tests.lisp — Tests for cl-tty.markdown + +(defpackage :cl-tty-markdown-test + (:use :cl :cl-tty.markdown :fiveam)) + +(in-package :cl-tty-markdown-test) + +;; Test suite +(def-suite :cl-tty-markdown-test + :description "Markdown parser/renderer tests for cl-tty.markdown") + +(in-suite :cl-tty-markdown-test) +#+END_SRC + +** Parser edge cases + +Edge cases guard against crashes on ~nil~ input, very long lines, blank-only +input, and unclosed fenced blocks. These come first because they exercise the +defensive gate checks at the top of each parsing function. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +;; ─── Parser edge cases ───────────────────────────────────────── + +(def-test render-markdown-nil ( ) + "render-markdown handles nil gracefully." + (is (string= "" (render-markdown nil)))) + +(def-test render-markdown-empty ( ) + "render-markdown handles empty string." + (let ((result (render-markdown ""))) + (is (stringp result)) + (is (string= "" result)))) + +(def-test parse-blocks-nil ( ) + "parse-blocks handles nil gracefully." + (is-false (parse-blocks nil))) + +(def-test split-string-into-lines-nil ( ) + "parse-blocks handles nil input (tests internal split-string-into-lines)." + (is-false (parse-blocks nil))) + +(def-test nested-bold-inside-italic ( ) + "Nested formatting: bold inside italic." + (let ((children (parse-inline "***hello*** world"))) + (is (= 3 (length children))) + (let ((first-node (first children))) + (is-true (eql :bold (getf first-node :type)))))) + +(def-test nested-italic-inside-bold ( ) + "Nested formatting: italic inside bold." + (let ((children (parse-inline "**bold *italic* bold**"))) + (is (= 1 (length children))) + (let ((bold (first children))) + (is-true (eql :bold (getf bold :type))) + (let ((inner (getf bold :children))) + (is (= 3 (length inner))) + (is-true (eql :italic (getf (second inner) :type))))))) + +(def-test inline-code-inside-bold ( ) + "Code inside bold." + (let ((children (parse-inline "**bold `code` bold**"))) + (is (= 1 (length children))) + (let ((bold (first children))) + (is-true (eql :bold (getf bold :type))) + (let ((inner (getf bold :children))) + (is (= 3 (length inner))) + (is-true (eql :inline-code (getf (second inner) :type))))))) + +(def-test unclosed-code-block ( ) + "Unclosed code block accumulates remaining lines as content." + (let* ((lines '("```lisp" "(defun foo ())" " (bar)")) + (text (format nil "~{~a~%~}" lines)) + (result (parse-blocks text)) + (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is (equal "lisp" (getf (getf node :properties) :language))) + (is-true (search "bar" (getf node :content))))) + +(def-test code-block-no-language ( ) + "Code block with no language is still parsed." + (let* ((lines '("```" "plain" "```")) + (text (format nil "~{~a~%~}" lines)) + (result (parse-blocks text)) + (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is-false (getf (getf node :properties) :language)))) + +(def-test markdown-very-long-line ( ) + "A very long paragraph line does not cause issues." + (let* ((long-line (make-string 500 :initial-element #\x)) + (result (render-markdown long-line))) + (is (stringp result)) + (is-true (> (length result) 0)))) + +(def-test markdown-only-blank ( ) + "Only blank lines produce empty output." + (is (string= "" (render-markdown (format nil "~%~%"))))) +#+END_SRC + +** Heading parsing + +ATX headings from level 1 through 6, including headings with inline +formatting inside the heading text. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +;; ─── Parser tests ───────────────────────────────────────────────────────────── + +(def-test heading-parsing ( ) + (let* ((result (parse-blocks "# Hello World")) (node (first result))) + (is-true (eql :heading (getf node :type))) + (is (= 1 (getf (getf node :properties) :level))))) + +(def-test heading-levels ( ) + (loop for level from 1 to 6 + do (let* ((hashes (make-string level :initial-element #\#)) + (text (format nil "~a Heading ~d" hashes level)) + (result (parse-blocks text)) + (node (first result))) + (is-true (eql :heading (getf node :type))) + (is (= level (getf (getf node :properties) :level)))))) + +(def-test heading-with-inline-formatting ( ) + (let* ((result (parse-blocks "# Hello **World**")) + (node (first result)) (children (getf node :children))) + (is-true (eql :heading (getf node :type))) + (is (= 2 (length children))) + (is-true (eql :text (getf (first children) :type))) + (is-true (eql :bold (getf (second children) :type))))) +#+END_SRC + +** Paragraph parsing + +Single-line and multi-line paragraphs. Multi-line paragraphs are joined +with spaces before inline parsing. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +(def-test paragraph-parsing ( ) + (let* ((result (parse-blocks "This is a paragraph.")) (node (first result))) + (is-true (eql :paragraph (getf node :type))))) + +(def-test paragraph-multi-line ( ) + (let* ((result (parse-blocks "Line one\nLine two")) (node (first result))) + (is-true (eql :paragraph (getf node :type))))) +#+END_SRC + +** Inline formatting + +Bold, italic, combined bold+italic, inline code, and link parsing. Each +test verifies both structure (node types) and content (text/url values). + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +(def-test bold-parsing ( ) + (let* ((children (parse-inline "hello **world** here")) + (bold-node (second children))) + (is (= 3 (length children))) + (is-true (eql :bold (getf bold-node :type))))) + +(def-test italic-parsing ( ) + (let* ((children (parse-inline "hello *world* here")) + (italic-node (second children))) + (is (= 3 (length children))) + (is-true (eql :italic (getf italic-node :type))))) + +(def-test bold-italic-combined ( ) + (let ((children (parse-inline "**bold** and *italic*"))) + (is (= 3 (length children))) + (is-true (eql :bold (getf (first children) :type))) + (is-true (eql :italic (getf (third children) :type))))) + +(def-test inline-code-parsing ( ) + (let* ((children (parse-inline "use `foo` here")) + (code-node (second children))) + (is (= 3 (length children))) + (is-true (eql :inline-code (getf code-node :type))) + (is (equal "foo" (getf code-node :content))))) + +(def-test link-parsing ( ) + (let* ((children (parse-inline "click [here](https://x.com)")) + (link-node (second children))) + (is (= 2 (length children))) + (is-true (eql :link (getf link-node :type))) + (is (equal "https://x.com" (getf link-node :url))) + (let ((link-text (getf link-node :children))) + (is (= 1 (length link-text))) + (is-true (eql :text (getf (first link-text) :type))) + (is (equal "here" (getf (first link-text) :content)))))) +#+END_SRC + +** Code block parsing + +Fenced code blocks with and without a language annotation. Verifies the +presence/absence of the ~:language~ property on the resulting node. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +(def-test code-block-parsing ( ) + (let* ((lines '("```lisp" "(defun hello ())" " (print \"hi\")" "```")) + (text (format nil "~{~a~%~}" lines)) + (result (parse-blocks text)) (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is (equal "lisp" (getf (getf node :properties) :language))) + (is-true (search "(defun hello" (getf node :content))))) + +(def-test code-block-unknown-language ( ) + (let* ((lines '("```" "plain code" "```")) + (text (format nil "~{~a~%~}" lines)) + (result (parse-blocks text)) (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is-false (getf (getf node :properties) :language)))) +#+END_SRC + +** Blockquote, list, and thematic-break parsing + +Verifies that blockquote markers, unordered list items, ordered list +items, and thematic breaks (---) are correctly classified and produce +the expected node types. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +(def-test blockquote-parsing ( ) + (let* ((result (parse-blocks "> This is a quote")) (node (first result))) + (is-true (eql :blockquote (getf node :type))))) + +(def-test list-item-parsing ( ) + (let* ((result (parse-blocks "- First item")) (node (first result))) + (is-true (eql :list-item (getf node :type))))) + +(def-test ordered-list-parsing ( ) + (let* ((result (parse-blocks "1. First item")) (node (first result))) + (is-true (eql :ordered-item (getf node :type))))) + +(def-test thematic-break-parsing ( ) + (let* ((result (parse-blocks "---")) (node (first result))) + (is-true (eql :thematic-break (getf node :type))))) +#+END_SRC + +** Diff line classification + +Tests ~classify-diff-line~ with each diff line variant: added (+), +removed (-), hunk header (@@), and context (neither). + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +;; ─── Diff tests ─────────────────────────────────────────────────────────────── + +(def-test classify-diff-added ( ) + (is (eql :added (classify-diff-line "+this is added")))) + +(def-test classify-diff-removed ( ) + (is (eql :removed (classify-diff-line "-this is removed")))) + +(def-test classify-diff-hunk ( ) + (is (eql :hunk-header (classify-diff-line "@@ -1,3 +1,4 @@")))) + +(def-test classify-diff-context ( ) + (is (eql :context (classify-diff-line " normal context")))) +#+END_SRC + +** Syntax highlighting + +Verifies that ~highlight-code~ returns categorised tokens for Lisp +keywords, builtins, comments, and falls back to plain tokens for +unknown languages. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +;; ─── Syntax highlighting tests ──────────────────────────────────────────────── +(def-test highlight-lisp-keyword ( ) + (let ((tokens (highlight-code "(defun hello ()" "lisp"))) + (is-true (some (lambda (pair) (and (search "defun" (car pair)) + (eql :keyword (cdr pair)))) + tokens)))) + +(def-test highlight-lisp-builtin ( ) + "Test that a Lisp builtin like nil is highlighted as :builtin." + (let ((tokens (highlight-code "(if t nil)" "lisp"))) + (is-true (some (lambda (pair) (and (string= (car pair) "nil") + (eql :builtin (cdr pair)))) + tokens)))) + +(def-test highlight-unknown-language ( ) + (let ((tokens (highlight-code "hello world" "unknown-xyz"))) + (every (lambda (pair) (eql :plain (cdr pair))) tokens))) + +(def-test highlight-comment ( ) + (let ((tokens (highlight-code "; this is a comment" "lisp"))) + (is-true (some (lambda (pair) (eql :comment (cdr pair))) tokens)))) +#+END_SRC + +** Render output + +Verifies that each node type produces output via ~render-md-node~. +Heading, paragraph, thematic-break, code-block, and diff-block are +all exercised to ensure the render dispatcher routes correctly. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +;; ─── Render tests ───────────────────────────────────────────────────────────── + +(def-test render-heading-output ( ) + (let* ((node (make-md-node :heading :properties (list :level 2) + :children (list (make-md-node :text :content "Test")))) + (lines (render-md-node node))) + (is (= 1 (length lines))) + (is-true (> (length (first lines)) 0)))) + +(def-test render-paragraph-output ( ) + (let* ((node (make-md-node :paragraph + :children (list (make-md-node :text :content "Hello")))) + (lines (render-md-node node))) + (is (= 1 (length lines))) + (is-true (search "Hello" (first lines))))) + +(def-test render-thematic-break-output ( ) + (let* ((node (make-md-node :thematic-break)) (lines (render-md-node node))) + (is (= 1 (length lines))))) + +(def-test render-code-block-output ( ) + (let* ((node (make-md-node :code-block :content "(print \"hello\")" + :properties (list :language "lisp"))) + (lines (render-md-node node))) + (is-true (> (length lines) 0)))) + +(def-test render-diff-block-output ( ) + (let* ((node (make-md-node :diff-block :properties + (list :lines + '("--- a/file" "+++ b/file" "@@ -1 +1 @@" + "+added" "-removed" " context")))) + (lines (render-md-node node))) + (is (= 6 (length lines))) + (is (search "added" (fourth lines))) + (is (search "removed" (fifth lines))))) +#+END_SRC + +** Integration test and utilities + +A full parse-and-render integration test exercises the pipeline end-to-end. +The ~md-node-text~ utility tests verify both simple and nested node +traversal. + +#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp + +;; ─── Integration tests ──────────────────────────────────────────────────────── + +(def-test markdown-integration ( ) + (let* ((md (format nil "# Title~%~%This is **bold** and `code`.~%~%- Item 1~%~%- Item 2~%~%> A quote~%~%```lisp~%(defun hello ())~% (print \"hi\")~%```~%~%---")) + (nodes (parse-blocks md)) (lines (render-md nodes))) + (is-true (> (length lines) 5)) + (is-true (search "# Title" (first lines))))) + +(def-test render-markdown-string ( ) + (let ((result (render-markdown "**bold** text"))) + (is-true (stringp result)) + (is-true (> (length result) 0)))) + +(def-test md-node-text-simple ( ) + (let ((node (make-md-node :text :content "hello"))) + (is (equal "hello" (md-node-text node))))) + +(def-test md-node-text-nested ( ) + (let ((node (make-md-node :paragraph :children + (list (make-md-node :text :content "hello") + (make-md-node :bold :children + (list (make-md-node :text :content "world"))))))) + (is (equal "helloworld" (md-node-text node))))) +#+END_SRC diff --git a/org/modern-backend.org b/org/modern-backend.org index ff12a70..3645c45 100644 --- a/org/modern-backend.org +++ b/org/modern-backend.org @@ -1,164 +1,282 @@ -#+TITLE: cl-tty Modern Backend — v0.0.2 +#+TITLE: Modern Backend #+STARTUP: content -#+FILETAGS: :cl-tty:backend:v0.0.2: -#+OPTIONS: ^:nil +#+FILETAGS: :cl-tty:backend: -* Modern Backend +* Overview -The =modern-backend= renders through raw ANSI/XTerm escape sequences. -No ncurses, no CFFI, no external dependencies — pure CL string -construction. Supports truecolor, Unicode box-drawing, OSC 8 hyperlinks, -DECICM synchronized updates, SGR mouse, and the kitty keyboard protocol. +The modern backend provides full-featured terminal rendering using raw +escape sequences. It supports truecolor 24-bit color, OSC 8 hyperlinks, +DECICM synchronized updates, SGR mouse tracking, kitty keyboard protocol, +and Unicode box-drawing characters (single, double, rounded). -** Contract +All rendering functions produce CSI/OSC escape sequences directly --- no +ncurses, no terminfo, no FFI. Color resolution handles named colors +(~:red~, ~:blue~, etc.), hex strings (~"#FFD700"~), and semantic theme +roles (~:accent~, ~:error~) via the ~*theme-colors*~ hash table. -*** Constructor +* Contract -- =(make-modern-backend &key color-palette)= → modern-backend - Create a modern backend. color-palette modifies theme color mappings. +** Color and attribute helpers -*** Escape Sequence Generation +- ~(hex-to-rgb hex)~ (r g b) --- parse "#RRGGBB" or "#RGB" +- ~(sgr-fg color)~ escape string --- foreground color escape +- ~(sgr-bg color)~ escape string --- background color escape +- ~(sgr-attr attr)~ escape string --- attribute escape (bold, italic, etc.) -All escape sequences follow ECMA-48 / ANSI X3.64 conventions: +** Cursor helpers -| Escape | Meaning | -|--------+--------------------------| -| ~ESC[~ | Control Sequence Introducer (CSI) | -| ~ESC]~ | Operating System Command (OSC) | -| ~ESC ~ | Single-character sequence | +- ~(cursor-move-escape x y)~ escape string --- CSI cursor position +- ~(cursor-style-escape shape blink)~ escape string --- DECSTR cursor shape -*** Style Resolution +** Sync and link helpers -Colors are resolved through a palette before emission: +- ~(decicm-begin)~ escape string --- enable synchronized updates +- ~(decicm-end)~ escape string --- disable synchronized updates +- ~(osc8-link url text)~ escape string --- OSC 8 hyperlink wrapper -- =(resolve-color backend hex-or-name)= → color-index - Convert hex string or semantic name to an SGR color code. - Hex ("#FFD700") → 48;2;R;G;B or 38;2;R;G;B. - Named colors (:black :red :green :yellow :blue :magenta :cyan :white) - → 8-color SGR codes. +** Border helpers -** Test Suite +- ~(border-char style pos)~ string --- Unicode box-drawing character -#+BEGIN_SRC lisp +** Modern backend class + +- ~(make-modern-backend &key output-stream)~ modern-backend +- Implements all ~backend~ protocol methods with escape sequences + +* Tests + +The test suite lives in =modern-tests.lisp= and uses FiveAM. Each test +covers one logical behavior. + +** Package and setup + +The test package uses =cl-tty.backend= to access internal symbols for +white-box testing of escape generation. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (defpackage :cl-tty-modern-backend-test (:use :cl :fiveam :cl-tty.backend) (:export #:run-tests)) (in-package :cl-tty-modern-backend-test) +#+END_SRC +** Suite definition + +A single suite groups all modern backend tests. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (def-suite modern-backend-suite :description "Modern backend tests") (in-suite modern-backend-suite) +#+END_SRC +** Test runner + +The =run-tests= entry point is called by the CI test harness. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (defun run-tests () (let ((result (run 'modern-backend-suite))) (fiveam:explain! result) (uiop:quit 0))) +#+END_SRC -;; ── Constructor ──────────────────────────────────────────────── +** Constructor test +Verifies that =make-modern-backend= returns an instance of the correct +class. This is the most basic smoke test for the backend factory. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test make-modern-backend-creates "make-modern-backend returns a modern-backend instance" (let ((b (make-modern-backend))) (is (typep b 'cl-tty.backend::modern-backend)))) +#+END_SRC -;; ── Escape Generation ────────────────────────────────────────── +** SGR truecolor foreground escape +Ensures a 6-digit hex string produces the correct 24-bit foreground +escape sequence with red, green, and blue components in the right order. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test sgr-truecolor-foreground "SGR truecolor foreground escape is correct" (is (equal (cl-tty.backend::sgr-fg "#FFD700") (format nil "~C[38;2;255;215;0m" #\Esc)))) +#+END_SRC +** SGR truecolor background escape + +Same as foreground but uses the =48= background prefix instead of =38=. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test sgr-truecolor-background "SGR truecolor background escape is correct" (is (equal (cl-tty.backend::sgr-bg "#1a1b26") (format nil "~C[48;2;26;27;38m" #\Esc)))) +#+END_SRC +** SGR named color resolution + +Verifies that keyword symbols like =:red= and =:blue= resolve to the +standard 8-color SGR codes (=31= foreground, =44= background). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test sgr-named-colors "SGR named colors resolve to 8-color codes" (is (equal (cl-tty.backend::sgr-fg :red) (format nil "~C[31m" #\Esc))) (is (equal (cl-tty.backend::sgr-bg :blue) (format nil "~C[44m" #\Esc)))) +#+END_SRC +** SGR attribute escapes + +Each attribute keyword (=:bold=, =:italic=, =:underline=, =:reset=) +should map to the correct SGR number. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test sgr-bold-italic "SGR attribute escapes are correct" (is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc))) (is (equal (cl-tty.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc))) (is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc))) (is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc)))) +#+END_SRC -;; ── Cursor ───────────────────────────────────────────────────── +** Cursor move escape +Verifies that =cursor-move-escape= produces a CSI =H= sequence with +1-indexed row and column. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test cursor-move-escape "cursor-move generates correct CSI escape" (let ((b (make-modern-backend))) (is (equal (cl-tty.backend::cursor-move-escape 5 10) - (format nil "~C[6;11H" #\Esc))))) + (format nil "~C[11;6H" #\Esc))))) +#+END_SRC +** Cursor style block + +Verifies the DECSTR escape for a block cursor without blinking (code 2). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test cursor-style-block "cursor-style :block generate correct escape" (let ((b (make-modern-backend))) (is (equal (cl-tty.backend::cursor-style-escape :block nil) (format nil "~C[2 q" #\Esc))))) +#+END_SRC +** Cursor style bar + +Verifies the DECSTR escape for a bar cursor without blinking (code 6). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test cursor-style-bar "cursor-style :bar generate correct escape" (let ((b (make-modern-backend))) (is (equal (cl-tty.backend::cursor-style-escape :bar nil) (format nil "~C[6 q" #\Esc))))) +#+END_SRC +** Cursor style underline with blink + +Verifies that =:underline= with =blink=t= produces code 5 (underline +blinking), which is base 4 + blink offset 1. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test cursor-style-underline-blink "cursor-style :underline with blink" (let ((b (make-modern-backend))) (is (equal (cl-tty.backend::cursor-style-escape :underline t) (format nil "~C[5 q" #\Esc))))) +#+END_SRC -;; ── Synchronization ──────────────────────────────────────────── +** DECICM synchronized update escapes +Confirms that =decicm-begin= and =decicm-end= produce =?2026h= and +=?2026l= respectively. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test decicm-escapes "DECICM synchronized update escapes" (is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) (is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc)))) +#+END_SRC -;; ── OSC 8 Hyperlinks ────────────────────────────────────────── +** OSC 8 hyperlink escape +Verifies the full OSC 8 wrapping: opening sequence with URL, the text, +and the closing sequence. The FORMAT string uses ~~ for literal tilde +and ~\\ for literal backslash. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test osc8-escape "OSC 8 hyperlink escape wraps text" (is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") (format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\" #\Esc #\Esc #\Esc #\Esc)))) +#+END_SRC -;; ── Hex Parsing ──────────────────────────────────────────────── +** Hex color parsing (gold) +Verifies that ="#FFD700"= parses to (255, 215, 0). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test hex-color-parsing "hex-to-rgb parses valid hex colors" (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700") (is (= r 255)) (is (= g 215)) (is (= b 0)))) +#+END_SRC +** Hex color parsing (black) + +Verifies all-zero parsing. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test hex-color-black "hex-to-rgb parses black" (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#000000") (is (= r 0)) (is (= g 0)) (is (= b 0)))) +#+END_SRC +** Hex color parsing (3-digit short form) + +Verifies that ="#F00"= expands to ="#FF0000"= = (255, 0, 0). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test hex-color-short-form "hex-to-rgb parses 3-digit hex" (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#F00") (is (= r 255)) (is (= g 0)) (is (= b 0)))) +#+END_SRC -;; ── Border Characters ────────────────────────────────────────── +** Border characters --- rounded style +Confirms that =:rounded= style maps to the Unicode box-drawing +characters for the four corners and edges. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test border-char-rounded "modern-border-char returns Unicode box-drawing for rounded style" (is (equal (cl-tty.backend::border-char :rounded :top-left) "╭")) (is (equal (cl-tty.backend::border-char :rounded :horizontal) "─")) (is (equal (cl-tty.backend::border-char :rounded :vertical) "│")) (is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯"))) +#+END_SRC +** Border characters --- double style + +Confirms that =:double= style maps to double-line box-drawing characters. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp (test border-char-double "modern-border-char returns double-line chars" (is (equal (cl-tty.backend::border-char :double :top-left) "╔")) @@ -166,44 +284,82 @@ Colors are resolved through a palette before emission: (is (equal (cl-tty.backend::border-char :double :vertical) "║"))) #+END_SRC -** Implementation +** Suspend/resume backend -*** Package +Verifies that suspend-backend and resume-backend are no-ops when called +on a backend not attached to a real terminal (no errors, return nil). -Add to =cl-tty.backend= package: - -#+BEGIN_SRC lisp -;; In package.lisp, add to :export: -;; #:modern-backend #:make-modern-backend -;; Internal symbols (not exported, used by tests): -;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape -;; decicm-begin decicm-end osc8-link hex-to-rgb border-char - -(in-package :cl-tty.backend) +#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp +(test suspend-resume-noop + "suspend-backend and resume-backend are no-ops in test context" + (let ((b (make-modern-backend))) + (is (null (multiple-value-list (suspend-backend b)))) + (is (null (multiple-value-list (resume-backend b)))))) #+END_SRC -*** Color Resolution +* Implementation + +** Color and attribute helpers + +*** hex-to-rgb + +~hex-to-rgb~ parses hex color strings into (r g b) triplets. Handles +both 6-digit (fully specified) and 3-digit (shorthand) formats. The +3-digit form expands each hexit by duplicating it (=#F00= => =#FF0000=). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +(in-package :cl-tty.backend) -#+BEGIN_SRC lisp (defun hex-to-rgb (hex) "Parse a hex color string like \"#FFD700\" into (values r g b). - Also handles 3-digit hex like \"#F00\"." + Also handles 3-digit hex like \"#F00\" (expands to \"#FF0000\")." (let ((clean (string-trim '(#\# #\Space) hex))) (if (= (length clean) 3) - (values (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t) - (parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t) - (parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t)) + ;; Expand 3-digit: #F00 -> #FF0000 + (let* ((r (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t)) + (g (parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t)) + (b (parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t))) + (values (+ r (* r 16)) (+ g (* g 16)) (+ b (* b 16)))) (values (parse-integer (subseq clean 0 2) :radix 16 :junk-allowed t) (parse-integer (subseq clean 2 4) :radix 16 :junk-allowed t) (parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t))))) +#+END_SRC +*** *named-colors* + +Maps keyword color names to 8-color SGR index values. Used as the +primary lookup in =sgr-fg= and =sgr-bg= before falling back to the +theme colors hash table. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defparameter *named-colors* '((:black . 0) (:red . 1) (:green . 2) (:yellow . 3) (:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7))) +#+END_SRC +*** *theme-colors* + +Hash table mapping semantic theme role keywords to hex color strings. +Populated by the theme system's =load-preset=. When a keyword is not in +=*named-colors*=, =sgr-fg= and =sgr-bg= consult this table as a +fallback, enabling user themes to define custom color roles. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +(defvar *theme-colors* (make-hash-table :test 'eq) + "Hash table mapping theme keywords to hex color strings. +Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg +as a fallback when a keyword is not in *named-colors*.") +#+END_SRC + +*** sgr-fg + +~sgr-fg~ produces the SGR foreground escape sequence. Resolution chain: +hex string => named color => semantic theme role => empty string if +unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun sgr-fg (color) - "Return SGR foreground escape for COLOR. - Color can be a hex string, a keyword name, or nil." + "Return SGR foreground escape for COLOR." (if (null color) "" (cond ((and (stringp color) (char= (char color 0) #\#)) (multiple-value-bind (r g b) (hex-to-rgb color) @@ -212,9 +368,20 @@ Add to =cl-tty.backend= package: (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 30 index)) - ""))) + (let ((hex (gethash color *theme-colors*))) + (if hex + (multiple-value-bind (r g b) (hex-to-rgb hex) + (format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)) + ""))))) (t "")))) +#+END_SRC +*** sgr-bg + +~sgr-bg~ produces the SGR background escape. Same resolution chain as +=sgr-fg= but uses =48;2;R;G;B= for truecolor and =4n= for named colors. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun sgr-bg (color) "Return SGR background escape for COLOR." (if (null color) "" @@ -225,13 +392,31 @@ Add to =cl-tty.backend= package: (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 40 index)) - ""))) + (let ((hex (gethash color *theme-colors*))) + (if hex + (multiple-value-bind (r g b) (hex-to-rgb hex) + (format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)) + ""))))) (t "")))) +#+END_SRC +*** *sgr-attr-codes* + +Maps attribute keywords to SGR parameter numbers. Covers bold, dim, +italic, underline, blink, reverse video, and reset. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defparameter *sgr-attr-codes* '((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4) (:blink . 5) (:reverse . 7) (:reset . 0))) +#+END_SRC +*** sgr-attr + +~sgr-attr~ looks up the keyword in =*sgr-attr-codes*= and produces the +matching SGR escape. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun sgr-attr (attr) "Return SGR attribute escape for ATTR keyword." (let ((code (cdr (assoc attr *sgr-attr-codes*)))) @@ -240,17 +425,28 @@ Add to =cl-tty.backend= package: ""))) #+END_SRC -*** Cursor Escapes +** Cursor escapes -#+BEGIN_SRC lisp +*** cursor-move-escape + +Produces a CSI =H= (CUP) sequence to position the cursor. Coordinates +are 1-indexed: =cursor-move-escape 0 0= moves to row 1, column 1. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun cursor-move-escape (x y) "Return CSI escape to move cursor to (x, y), 1-indexed." (format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x))) +#+END_SRC +*** cursor-style-escape + +Produces a DECSTR sequence (=CSI Ps q=) to set the cursor shape. +Base codes: block=2, underline=4, bar=6. When =blink= is true the code +is incremented by 1 (e.g. blinking block = code 3). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun cursor-style-escape (shape blink) - "Return DECSTR escape for cursor shape. - :block = 2, :underline = 4, :bar = 6. - Add 1 for blink variants." + "Return DECSTR escape for cursor shape." (let* ((base (case shape (:block 2) (:underline 4) (:bar 6) (t 2))) @@ -258,96 +454,255 @@ Add to =cl-tty.backend= package: (format nil "~C[~d q" #\Esc code))) #+END_SRC -*** Synchronization (DECICM) +** Sync and link escapes -#+BEGIN_SRC lisp +*** decicm-begin + +Enables DEC private mode 2026 (synchronized updates). All output +between =begin= and =end= is buffered by the terminal and rendered +atomically. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun decicm-begin () "Return escape to enable synchronized updates." (format nil "~C[?2026h" #\Esc)) +#+END_SRC +*** decicm-end + +Disables DEC private mode 2026, flushing the buffered frame to the +display. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun decicm-end () "Return escape to disable synchronized updates." (format nil "~C[?2026l" #\Esc)) #+END_SRC -*** OSC 8 Hyperlinks +*** osc8-link -#+BEGIN_SRC lisp +Wraps text in an OSC 8 hyperlink. The opening sequence carries the URL, +the closing sequence (=ESC]8;;ESC\)=) terminates the link. This +allows clickable text in terminals that support the protocol. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun osc8-link (url text) "Wrap TEXT in an OSC 8 hyperlink to URL." (format nil "~C]8;;~A~C\\~A~C]8;;~C\\" #\Esc url #\Esc text #\Esc #\Esc)) #+END_SRC -*** Border Characters +** Border characters -#+BEGIN_SRC lisp +*** *border-chars* + +Lookup alist mapping =(style position)= pairs to Unicode box-drawing +characters. Covers single, double, and rounded styles with all four +corners plus horizontal and vertical connectors. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defparameter *border-chars* - '((:single :top-left . "┌") (:single :top-right . "┐") - (:single :bottom-left . "└") (:single :bottom-right . "┘") - (:single :horizontal . "─") (:single :vertical . "│") - (:double :top-left . "╔") (:double :top-right . "╗") - (:double :bottom-left . "╚") (:double :bottom-right . "╝") - (:double :horizontal . "═") (:double :vertical . "║") - (:rounded :top-left . "╭") (:rounded :top-right . "╮") - (:rounded :bottom-left . "╰") (:rounded :bottom-right . "╯") - (:rounded :horizontal . "─") (:rounded :vertical . "│"))) + '(((:single :top-left) . "┌") ((:single :top-right) . "┐") + ((:single :bottom-left) . "└") ((:single :bottom-right) . "┘") + ((:single :horizontal) . "─") ((:single :vertical) . "│") + ((:double :top-left) . "╔") ((:double :top-right) . "╗") + ((:double :bottom-left) . "╚") ((:double :bottom-right) . "╝") + ((:double :horizontal) . "═") ((:double :vertical) . "║") + ((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮") + ((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯") + ((:rounded :horizontal) . "─") ((:rounded :vertical) . "│"))) +#+END_SRC +*** border-char + +Looks up a border character by style and position. Falls back to +horizontal/vertical lines (=U+2500=, =U+2502=) if the style is unknown +for edge positions, or =+= for corners --- ensuring the UI never shows +a blank gap. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defun border-char (style pos) "Return the Unicode box-drawing character for STYLE at POS." - (let ((char (cdr (assoc (cons style pos) *border-chars* :test #'equal)))) + (let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal)))) (or char (if (member pos '(:horizontal :vertical)) (case pos (:horizontal "─") (:vertical "│")) "+")))) #+END_SRC -*** Modern Backend Class +** Modern backend class -#+BEGIN_SRC lisp +*** modern-backend (class) + +Subclasses the abstract =backend= class. =output-stream= is where escape +sequences are written; =in-sync-p= tracks whether we are inside a +DECICM synchronized update block. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defclass modern-backend (backend) ((output-stream :initform *standard-output* + :initarg :output-stream :accessor backend-output-stream) (in-sync-p :initform nil :accessor in-sync-p))) +#+END_SRC -(defun make-modern-backend (&key color-palette) +*** make-modern-backend + +Factory function that creates a =modern-backend= instance. Accepts an +optional =output-stream=; defaults to =*standard-output*=. The +=color-palette= argument is ignored in favor of the dynamic +=*theme-colors*= hash table. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +(defun make-modern-backend (&key color-palette output-stream) (declare (ignore color-palette)) - (make-instance 'modern-backend)) + (make-instance 'modern-backend :output-stream (or output-stream *standard-output*))) +#+END_SRC +** Lifecycle + +*** initialize-backend + +Enters the alternate screen buffer, enables mouse tracking (basic + +drag + SGR), bracketed paste mode, and the Kitty keyboard protocol. +Hides the cursor and flushes the stream. Returns the backend instance +for chaining. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod initialize-backend ((b modern-backend)) - ;; Enter raw mode, enable mouse, bracketed paste (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic (backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag (backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse (backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste + (backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard (cursor-hide b) (finish-output (backend-output-stream b)) b) +#+END_SRC +*** shutdown-backend + +Restores the terminal: shows the cursor, disables the Kitty keyboard +protocol, bracketed paste, SGR mouse, drag, basic mouse, and finally +leaves the alternate screen. Returns =nil= (via =(values)=). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod shutdown-backend ((b modern-backend)) (cursor-show b) - (backend-write b (format nil "~C[?2004l" #\Esc)) ; disable bracketed paste - (backend-write b (format nil "~C[?1006l" #\Esc)) ; disable SGR mouse + (backend-write b (format nil "~C[?u" #\Esc)) + (backend-write b (format nil "~C[?2004l" #\Esc)) + (backend-write b (format nil "~C[?1006l" #\Esc)) (backend-write b (format nil "~C[?1002l" #\Esc)) (backend-write b (format nil "~C[?1000l" #\Esc)) (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen (finish-output (backend-output-stream b)) (values)) +#+END_SRC +*** Suspend backend (temporary) + +Temporarily suspends the modern backend, restoring the terminal to a +usable state so the shell (or parent process) can take over. Called +before =SIGTSTP= or similar process suspension. + +Shows the cursor and exits the alternate screen buffer so the user +sees the normal terminal content. Does NOT disable mouse modes or +kitty keyboard — those would add ~100ms of overhead on every +suspend/resume cycle and are harmless while suspended (the terminal +just ignores the escape sequences). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +(defmethod suspend-backend ((b modern-backend)) + (cursor-show b) + (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen + (cursor-move b 0 0) + (finish-output (backend-output-stream b)) + (values)) +#+END_SRC + +*** Resume backend (after suspend) + +Re-initializes the modern backend after a suspension. Called after +=SIGCONT= or similar process resume. + +Re-enters the alternate screen buffer and re-enables all input +features (mouse, bracketed paste, kitty keyboard). The application +is responsible for redrawing the full screen after resume. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +(defmethod resume-backend ((b modern-backend)) + (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen + (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic + (backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag + (backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse + (backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste + (backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard + (cursor-hide b) + (finish-output (backend-output-stream b)) + (values)) +#+END_SRC + +** Backend-size via ioctl + +*** backend-size + +Uses TIOCGWINSZ (=0x5413= = 21523) to query actual terminal dimensions +from the kernel via =ioctl=. The =alien-sap= wrapper ensures +compatibility across SBCL versions. Returns (values cols rows). + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod backend-size ((b modern-backend)) - ;; Default fallback — real implementation queries terminal - (values 80 24)) + (let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux + (winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) + (unwind-protect + (progn + (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b)) + +tiocgwinsz+ + (sb-alien:alien-sap winsize)) + (values (sb-alien:deref winsize 1) ;; cols + (sb-alien:deref winsize 0))) ;; rows + (sb-alien:free-alien winsize)))) +#+END_SRC +** Capability query and write + +*** backend-write + +Writes a string to the backend's output stream, flushing after each +write to ensure the terminal receives the escape sequence immediately. +Returns the string length for protocol compatibility. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod backend-write ((b modern-backend) string) (let ((stream (backend-output-stream b))) (write-string string stream) + (finish-output stream) (length string))) +#+END_SRC +*** capable-p + +Advertises which features this backend supports. =modern-backend= +supports truecolor, OSC 8 hyperlinks, DECICM sync, SGR mouse, +bracketed paste, cursor style control, and the Kitty keyboard protocol. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod capable-p ((b modern-backend) feature) (member feature '(:truecolor :osc8 :sync :mouse :bracketed-paste :cursor-style :kitty-keyboard))) +#+END_SRC +** Drawing + +*** draw-text + +Combines cursor positioning, SGR colors, optional attributes, the text +itself, and a reset into a single concatenated string. Minimizes output +calls --- one =backend-write= per draw operation --- by packing everything +into one buffer. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod draw-text ((b modern-backend) x y string fg bg &key bold italic underline reverse dim blink) (let ((parts (list (cursor-move-escape x y) @@ -361,10 +716,18 @@ Add to =cl-tty.backend= package: string (sgr-attr :reset)))) (backend-write b (apply #'concatenate 'string parts)))) +#+END_SRC +*** draw-border + +Builds the full border as three distinct string parts (top with optional +title, repeated mid sections, bottom) and writes them with minimal +output calls. The title can be left-aligned or centered within the top +border line. Uses the border character lookup for the chosen style. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod draw-border ((b modern-backend) x y width height &key style fg bg title title-align) - (declare (ignore title title-align)) (let* ((s (or style :single)) (tl (border-char s :top-left)) (tr (border-char s :top-right)) @@ -375,33 +738,76 @@ Add to =cl-tty.backend= package: (fg-esc (sgr-fg fg)) (bg-esc (sgr-bg bg)) (reset (sgr-attr :reset)) - (top (concatenate 'string - fg-esc bg-esc tl - (make-string (- width 2) :initial-element (char h 0)) - tr reset (string #\Newline))) + (inner-width (- width 2)) + (hc (char h 0)) + (top (if (and title (plusp (length title))) + (let* ((align (or title-align :left)) + (max-tlen (- inner-width 2)) + (tlen (min (length title) max-tlen)) + (trunc-title (subseq title 0 tlen))) + (ecase align + (:left + (let ((right-hyphens (- inner-width tlen 2))) + (concatenate 'string + fg-esc bg-esc tl (string #\Space) + trunc-title (string #\Space) + (make-string (max 0 right-hyphens) :initial-element hc) + tr reset (string #\Newline)))) + (:center + (let* ((total-pad (- inner-width tlen)) + (left-pad (floor total-pad 2)) + (right-pad (- total-pad left-pad))) + (concatenate 'string + fg-esc bg-esc tl + (make-string left-pad :initial-element hc) + trunc-title + (make-string right-pad :initial-element hc) + tr reset (string #\Newline)))))) + (concatenate 'string + fg-esc bg-esc tl + (make-string inner-width :initial-element hc) + tr reset (string #\Newline)))) (mid (concatenate 'string fg-esc bg-esc v - (make-string (- width 2) :initial-element #\Space) + (make-string inner-width :initial-element #\Space) v reset (string #\Newline))) (bot (concatenate 'string fg-esc bg-esc bl - (make-string (- width 2) :initial-element (char h 0)) + (make-string inner-width :initial-element hc) br reset))) (backend-write b top) (loop repeat (- height 2) do (backend-write b mid)) (backend-write b bot))) +#+END_SRC +*** draw-rect + +Fills a rectangular area with a background color. For each row, moves +the cursor and writes a filled line. This is simpler than =draw-border= +because it has no border characters --- just spaces with a background +color. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod draw-rect ((b modern-backend) x y width height &key bg) - (let ((bg-esc (sgr-bg bg)) - (reset (sgr-attr :reset)) - (line (concatenate 'string - bg-esc - (make-string width :initial-element #\Space) - reset (string #\Newline)))) - (loop repeat height do - (backend-write b (cursor-move-escape x y)) + (let* ((bg-esc (sgr-bg bg)) + (reset (sgr-attr :reset)) + (line (concatenate 'string + bg-esc + (make-string width :initial-element #\Space) + reset (string #\Newline)))) + (loop :for row :from 0 :below height :do + (backend-write b (cursor-move-escape x (+ y row))) (backend-write b line)))) +#+END_SRC +*** draw-link + +Draws a hyperlinked text at position (x, y). Combines cursor +positioning, optional fg/bg colors, the OSC 8 link wrapper around the +text, and a reset. This lets the user click the text to open the URL +in terminals that support OSC 8. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod draw-link ((b modern-backend) x y string url &key fg bg) (let ((parts (list (cursor-move-escape x y) @@ -409,28 +815,105 @@ Add to =cl-tty.backend= package: (osc8-link url string) (sgr-attr :reset)))) (backend-write b (apply #'concatenate 'string parts)))) +#+END_SRC +*** draw-ellipsis + +Draws a three-dot ellipsis at the given position. The =width= parameter +is ignored since dots have a fixed visual length; delegates to +=draw-text= for uniform rendering. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod draw-ellipsis ((b modern-backend) x y width &key fg bg) + (declare (ignore width)) (let ((dots "...")) (draw-text b x y dots fg bg))) +#+END_SRC +** Cursor and input methods + +*** cursor-move + +Delegates to =cursor-move-escape= and writes the resulting CSI sequence +to the output stream. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod cursor-move ((b modern-backend) x y) (backend-write b (cursor-move-escape x y))) +#+END_SRC +*** cursor-hide + +Sends the DECTCEM private mode =?25l= to hide the cursor. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod cursor-hide ((b modern-backend)) (backend-write b (format nil "~C[?25l" #\Esc))) +#+END_SRC +*** cursor-show + +Sends =?25h= to restore the cursor visibility. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod cursor-show ((b modern-backend)) (backend-write b (format nil "~C[?25h" #\Esc))) +#+END_SRC +*** cursor-style + +Sets the cursor shape (block/underline/bar, optionally blinking) by +delegating to =cursor-style-escape=. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod cursor-style ((b modern-backend) shape &key blink) (backend-write b (cursor-style-escape shape blink))) +#+END_SRC +*** enable-mouse + +Enables basic mouse tracking, button-event tracking (drag), and SGR +extended mouse mode. These three modes together give full mouse +support while staying compatible with modern terminal emulators. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +(defmethod enable-mouse ((b modern-backend)) + (backend-write b (format nil "~C[?1000h" #\Esc)) + (backend-write b (format nil "~C[?1002h" #\Esc)) + (backend-write b (format nil "~C[?1006h" #\Esc)) + (finish-output (backend-output-stream b))) +#+END_SRC + +*** enable-bracketed-paste + +Enables bracketed paste mode, where the terminal wraps pasted text in +=ESC[200~= and =ESC[201~= delimiters. This allows the application to +distinguish user input from pasted content. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp +(defmethod enable-bracketed-paste ((b modern-backend)) + (backend-write b (format nil "~C[?2004h" #\Esc)) + (finish-output (backend-output-stream b))) +#+END_SRC + +*** begin-sync + +Begins a synchronized update frame using DECICM. Sets the =in-sync-p= +slot so other methods can check whether we are inside a sync block. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod begin-sync ((b modern-backend)) (setf (in-sync-p b) t) (backend-write b (decicm-begin))) +#+END_SRC +*** end-sync + +Ends the synchronized update frame and flushes the output, causing the +terminal to render the buffered changes atomically. + +#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp (defmethod end-sync ((b modern-backend)) (setf (in-sync-p b) nil) (backend-write b (decicm-end)) diff --git a/org/mouse.org b/org/mouse.org index 701c51f..741ccaf 100644 --- a/org/mouse.org +++ b/org/mouse.org @@ -25,9 +25,16 @@ module adds: ** Code +*** Package definition + +The package lives in its own file so it can be loaded before the +implementation. It re-exports the public API symbols that consumers +(~cl-tty.core~, user applications) rely on without pulling in +implementation details. + #+BEGIN_SRC lisp :tangle ../src/components/mouse-package.lisp :noweb no (defpackage :cl-tty.mouse - (:use :cl :cl-tty.input :cl-tty.box :cl-tty.rendering) + (:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering) (:export #:mouse-mixin #:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll @@ -40,15 +47,39 @@ module adds: #:cell-link-at #:open-link-at)) #+END_SRC +*** Package entry form + +Standard boilerplate to enter the package defined above. + #+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (in-package :cl-tty.mouse) +#+END_SRC +*** ~mouse-mixin~ — mixin class for mouse event handler slots + +Using a mixin (rather than adding slots to every component class) +keeps the mouse concern orthogonal to layout or rendering. Components +that want mouse support simply inherit from ~mouse-mixin~ alongside +their primary superclass. Each slot stores a closure invoked when the +corresponding event fires; ~nil~ means "no handler." + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defclass mouse-mixin () ((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down) (on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up) (on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move) (on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll))) +#+END_SRC +*** ~handle-mouse-event~ — dispatch mouse events to the right slot handler + +Maps from the low-level ~mouse-event-type~ keyword to the +corresponding mixin slot. Using ~case~ here is simpler than a generic +function dispatch because the mapping is one-to-one and never needs +CLOS multiple-dispatch. Returns ~nil~ when no handler is bound (the +caller can decide whether to bubble the event up). + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun handle-mouse-event (component event) (let* ((type (mouse-event-type event)) (handler (case type @@ -57,7 +88,17 @@ module adds: (:drag (on-mouse-move component)) (t nil)))) (when handler (funcall handler event)))) +#+END_SRC +*** ~hit-test~ — find the deepest component at a given (x, y) + +Recursive coordinate lookup. Children are checked first so that the +innermost matching component wins (front-most in rendering order). +~ignore-errors~ guards against components that haven't been laid out +yet (no ~layout-node~ bound). This makes hit-testing safe to call +mid-render when the tree is partially constructed. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun hit-test (root x y) "Find the deepest component at (X, Y) by testing layout-node bounds. Recurses into component-children to find the innermost match. @@ -81,46 +122,145 @@ Components without a layout-node or position return nil." (>= y ny) (< y (+ ny nh))) node))))))) (recurse root))) +#+END_SRC -;; Selection +*** ~*selection*~ — global variable holding the current selection + +A single global makes the selection accessible from anywhere in the +process without threading it through the entire component tree. This +keeps the API simple for now; a future refactor could store the +selection on a per-frame or per-window basis if needed. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defvar *selection* nil) +#+END_SRC +*** ~selection~ struct — data representation of a highlighted region + +Stores the bounding box (start and end coordinates) plus the extracted +text. The ~:conc-name sel-~ prefix keeps accessors short while +avoiding name collisions. Using a struct (vs. a class) gives inline +accessors and no CLOS overhead, which matters when the selection is +read on every render frame. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defstruct (selection (:conc-name sel-)) (start-x 0) (start-y 0) (end-x 0) (end-y 0) (text "")) +#+END_SRC +*** ~get-selection~ — read the selected text + +Simple accessor that returns nil when nothing is selected (rather than +an empty string), making it easy for callers to test with ~when~. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun get-selection () (when *selection* (sel-text *selection*))) +#+END_SRC +*** ~copy-to-clipboard~ — platform-aware clipboard writing + +The original implementation only called ~xclip~, which fails silently +on Wayland sessions. This version checks ~WAYLAND_DISPLAY~ at runtime +— if set, it uses ~wl-copy~; otherwise it falls back to ~xclip~. +Darwin uses ~pbcopy~. The approach avoids build-time feature detection +(~#+wayland~) in favor of runtime environment checks, which handles +the common case of a single SBCL binary used across X11 and Wayland +sessions. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun copy-to-clipboard (text) - #+linux (sb-ext:run-program "xclip" (list "-selection" "clipboard") - :input text :wait nil) + #+linux + (cond + ((sb-ext:posix-getenv "WAYLAND_DISPLAY") + (sb-ext:run-program "wl-copy" nil :input text :wait nil)) + (t + (sb-ext:run-program "xclip" (list "-selection" "clipboard") + :input text :wait nil))) #+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil)) +#+END_SRC -;;; --- Selection tracking (mouse drag) --------------------------------------- +*** ~*selection-active*~ — flag indicating an in-progress drag selection +Setting this to ~T~ during a mouse drag lets the renderer know it +should draw a highlight overlay. A global flag (rather than threading +the drag state through event handlers) mirrors the simplicity of +~*selection*~ and makes it trivial to check in rendering code. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defvar *selection-active* nil "T when a drag selection is in progress.") +#+END_SRC +*** ~*selection-start*~ — drag origin coordinates + +Stored as a cons cell ~(X . Y)~ of the mouse-down position. Using a +cons (vs. a struct) keeps the imperative mutation simple — ~setf~ with +~cons~ is a single expression. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defvar *selection-start* nil "Cons (X . Y) of mouse-down position during drag.") +#+END_SRC +*** ~*selection-end*~ — current drag extent coordinates + +Updated on every mouse-move during a drag so the rendering loop can +draw the live highlight rectangle between ~*selection-start*~ and +~*selection-end*~. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defvar *selection-end* nil "Cons (X . Y) of current mouse position during drag.") +#+END_SRC +*** ~start-selection~ — begin a drag selection + +Initializes all three drag state variables in one call. Both start and +end are set to the same position so that before the first mouse-move +the "selection" is a zero-width region (which renders as nothing). + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun start-selection (x y) "Begin a drag selection at (X Y)." (setf *selection-start* (cons x y) *selection-end* (cons x y) *selection-active* t)) +#+END_SRC +*** ~update-selection~ — update the drag extent during mouse-move + +Called on every mouse-move event while dragging. Only updates the end +position; the start remains fixed from the original mouse-down. The +rendering loop reads both globals to draw the highlight rectangle. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun update-selection (x y) "Update the drag selection end position to (X Y)." (setf *selection-end* (cons x y))) +#+END_SRC +*** ~selection-active-p~ — predicate for drag state + +Encapsulates the global flag behind a function so that callers don't +need to know the variable name. Returning ~*selection-active*~ +directly works because it is always ~nil~ or ~T~. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun selection-active-p () "Return T if a drag selection is in progress." *selection-active*) +#+END_SRC +*** ~finalize-selection~ — complete the drag and extract text + +Clears the active flag, normalizes coordinates (the user may have +dragged right-to-left or bottom-to-top), extracts the text from the +framebuffer via ~cl-tty.rendering:extract-text~, stores the result in +~*selection*~, and returns the extracted string. The ~fb~ parameter +must be the current framebuffer at the time of release. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun finalize-selection (fb) "End the drag selection and extract text from the framebuffer." (setf *selection-active* nil) @@ -135,13 +275,28 @@ Components without a layout-node or position return nil." :text text)) (setf *selection-start* nil *selection-end* nil) text))) +#+END_SRC -;;; --- Link clicking --------------------------------------------------------- +*** ~cell-link-at~ — read a link URL from the framebuffer at (x, y) +Delegates to the rendering layer's ~fb-cell-link-url~ to look up the +cell metadata. This indirection keeps mouse code independent of the +framebuffer's internal storage format. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun cell-link-at (fb x y) "Return the link URL at (X Y) in framebuffer FB, or nil." (cl-tty.rendering:fb-cell-link-url fb x y)) +#+END_SRC +*** ~open-link-at~ — navigate to a URL embedded at a screen position + +If ~cell-link-at~ finds a URL, open it with the OS default handler +(~xdg-open~ on Linux, ~open~ on Darwin). Returns the URL (or nil) so +the caller can log or react to the result. The ~:wait nil~ avoids +blocking the TTY UI while the browser launches. + +#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no (defun open-link-at (fb x y) "If there is a link URL at (X Y) in FB, open it via xdg-open." (let ((url (cell-link-at fb x y))) @@ -151,29 +306,68 @@ Components without a layout-node or position return nil." url)) #+END_SRC +*** Tests + +**** Test package and suite definition + +Isolates test symbols in their own package to avoid polluting the +production namespace. FiveAM's ~def-suite~ groups all mouse tests +under a single name for convenient batch execution. + #+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no (defpackage :cl-tty-mouse-test (:use :cl :cl-tty.mouse :fiveam)) (in-package :cl-tty-mouse-test) (def-suite mouse-suite :description "Mouse tests") (in-suite mouse-suite) +#+END_SRC +**** Test: ~mouse-mixin-create~ + +Verifies that the mixin class can be instantiated and passes a basic +typep check. This guards against missing ~:initform~ values or +superclass chain issues. + +#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no (def-test mouse-mixin-create () (let ((m (make-instance 'mouse-mixin))) (is-true (typep m 'mouse-mixin)))) +#+END_SRC +**** Test: ~mouse-hit-test-point~ + +~hit-test~ on a bare ~mouse-mixin~ (no layout-node) should return nil +for any coordinates. This tests the ~ignore-errors~ guard path in the +hit-testing logic. + +#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no (def-test mouse-hit-test-point () "hit-test returns nil when no component has position slots bound" (let ((obj (make-instance 'mouse-mixin))) (is-false (hit-test obj 0 0)) (is-false (hit-test obj 100 100)))) +#+END_SRC +**** Test: ~selection-set-and-get~ + +Sets ~*selection*~ directly (simulating a completed drag) and checks +that ~get-selection~ returns the expected text. This validates the +~selection~ struct accessor chain end-to-end. + +#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no (def-test selection-set-and-get () (setf cl-tty.mouse::*selection* (make-selection :text "hello")) (is (equal "hello" (get-selection)))) +#+END_SRC -;; ── Selection tracking ────────────────────────────────────── +**** Test: ~start-selection-initializes-state~ +~start-selection~ must set ~*selection-start*~, ~*selection-end*~, and +~*selection-active*~ to their expected initial values. The teardown +resets globals to avoid cross-test contamination (FiveAM does not +automatically reset special variables between tests). + +#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no (def-test start-selection-initializes-state () (start-selection 5 10) (is-true (selection-active-p)) @@ -182,7 +376,15 @@ Components without a layout-node or position return nil." (setf cl-tty.mouse::*selection-active* nil cl-tty.mouse::*selection-start* nil cl-tty.mouse::*selection-end* nil)) +#+END_SRC +**** Test: ~update-selection-moves-end~ + +After ~start-selection~, calling ~update-selection~ must update +~*selection-end*~ while leaving ~*selection-start*~ unchanged. This +validates the drag-tracking update path. + +#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no (def-test update-selection-moves-end () (start-selection 0 0) (update-selection 3 7) @@ -190,7 +392,16 @@ Components without a layout-node or position return nil." (setf cl-tty.mouse::*selection-active* nil cl-tty.mouse::*selection-start* nil cl-tty.mouse::*selection-end* nil)) +#+END_SRC +**** Test: ~finalize-selection-extracts-text~ + +End-to-end integration test: draws text into a real framebuffer, +simulates a drag selection, and verifies that ~finalize-selection~ +extracts the correct multi-line string. This exercises the full chain +from framebuffer cell storage through coordinate normalization. + +#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no (def-test finalize-selection-extracts-text () (let* ((fb-be (cl-tty.rendering:make-framebuffer-backend)) (fb (cl-tty.rendering:fb-framebuffer fb-be))) @@ -201,5 +412,4 @@ Components without a layout-node or position return nil." (let ((text (finalize-selection fb))) (is (equal "hello world" text))))) - -#+END_SRC \ No newline at end of file +#+END_SRC diff --git a/org/package.org b/org/package.org new file mode 100644 index 0000000..051d88a --- /dev/null +++ b/org/package.org @@ -0,0 +1,180 @@ +#+TITLE: Base Component Package +#+STARTUP: content +#+FILETAGS: :cl-tty:components: + +* Overview + +The ~cl-tty.box~ package is the central namespace for the component +system. It aggregates all component-related symbols — box, text, +dirty tracking, render dispatch, theme engine — under one package. + +Why ~box~ as the package name? Historically the package was created +for the ~box~ and ~text~ renderables, and the name stuck as the +package grew to encompass the entire component layer. The package +~:use~s ~cl-tty.backend~ (for drawing primitives) and ~cl-tty.layout~ +(for layout nodes). All component code lives in this package. + +This org file is documentation-only: it explains the package design +but the code itself is just a ~defpackage~ form. + +* Contract + +The ~cl-tty.box~ package exports these symbol groups: + +- Box: ~box~, ~make-box~, ~render-box~, border style/title accessors +- Span: ~span~, span attribute readers +- Text: ~text~, ~make-text~, ~render-text~, text accessors +- Dirty: ~dirty-mixin~, ~dirty-p~, ~mark-clean~, ~mark-dirty~ +- Render: ~render~, ~render-screen~, ~render-node~, tree navigation +- Theme: ~theme~, ~make-theme~, ~theme-color~, ~load-preset~, + ~define-preset~ + +* Implementation + +~cl-tty.box~ uses ~cl-tty.backend~ for ~draw-text~, ~draw-border~, +etc., and ~cl-tty.layout~ for ~layout-node~, ~compute-layout~, and the +~vbox~/~hbox~ macros. + +The only direct dependencies are these two packages — no other +application code is needed to define components. + +** Box exports + +The ~box~ class is the primary rectangular container: it renders a +bordered region with optional title and background color. The accessor +family (~box-border-style~, ~box-title~, ~box-title-align~, +~box-fg~, ~box-bg~) follows a consistent naming convention so that +users can infer slot names from the class name. ~render-box~ is the +specialized method that draws the border and fills the interior. + +The ~box-layout-node~ accessor connects the box to its layout tree +node, which is essential for the render pipeline's coordinate +computation. We export it separately from the rendering symbols +because it is also needed by code that walks the component tree +without triggering a full render. + +#+BEGIN_SRC lisp :tangle ../src/components/package.lisp +(defpackage :cl-tty.box + (:use :cl :cl-tty.backend :cl-tty.layout) + (:export + ;; Box + #:box #:make-box + #:box-layout-node + #:box-border-style #:box-title #:box-title-align + #:box-fg #:box-bg + #:render-box +#+END_SRC + +** Span exports + +Spans are lightweight inline-style records — not full classes with +layout. Each span stores a substring of the parent text along with +its visual attributes. The reader-named accessors (~span-text~, +~span-bold~, ~span-italic~, etc.) let rendering code inspect span +properties without pulling in the internal representation. We keep +the accessor list flat (no grouping macro) to make the package +surface easy to grep and to keep the API browser-friendly. + +#+BEGIN_SRC lisp :tangle ../src/components/package.lisp + ;; Span + #:span + #:span-text #:span-bold #:span-italic #:span-underline + #:span-reverse #:span-dim #:span-fg #:span-bg +#+END_SRC + +** Text exports + +~text~ and ~make-text~ are the construction interface for the text +renderable. The ~text-layout-node~ accessor follows the same pattern +as ~box-layout-node~, bridging the component and layout layers. +~text-content~ and ~text-spans~ expose the raw data for rendering; +~text-fg~, ~text-bg~, and ~text-wrap-mode~ control global text +appearance. ~render-text~ is the CLOS method that walks the span list +and calls ~draw-text~ from the backend. + +These symbols live in the ~cl-tty.box~ package rather than a +separate ~cl-tty.text~ package to keep inter-component references +trivial — boxes can hold text children, and text can be nested inside +other components, all without cross-package imports. + +#+BEGIN_SRC lisp :tangle ../src/components/package.lisp + ;; Text + #:text #:make-text + #:text-layout-node #:text-content #:text-spans + #:text-fg #:text-bg #:text-wrap-mode + #:render-text +#+END_SRC + +** Utility exports (for tests) + +~word-wrap~ and ~split-string~ are internal text-processing utilities +used by the text renderer to break lines and tokenize input. They are +exported specifically so the test suite can unit-test them in +isolation. They are not part of the public component API and should +not be relied upon by application code outside of tests. + +#+BEGIN_SRC lisp :tangle ../src/components/package.lisp + ;; Utilities (for tests) + #:word-wrap #:split-string +#+END_SRC + +** Dirty tracking + +The dirty-mixin protocol lets any component class participate in the +change-propagation system. ~dirty-mixin~ is the mixin class, and +~dirty-p~, ~mark-clean~, ~mark-dirty~ are the three operations that +the render pipeline calls to decide whether a subtree needs +re-rendering. + +Having these as generic functions (rather than a single ~(setf +dirty-p)~) makes it easy for subclasses to add side effects on dirty +transitions — for example, invalidating a cached bitmap or +recomputing string metrics. + +#+BEGIN_SRC lisp :tangle ../src/components/package.lisp + ;; Dirty tracking + #:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty +#+END_SRC + +** Rendering pipeline + +~render~, ~render-screen~, and ~render-node~ are the three entry +points into the rendering dispatch. ~component-layout-node~, +~component-children~, and ~component-parent~ form the tree-navigation +interface that ~render-node~ uses to walk the component hierarchy. +~available-width~ and ~available-height~ are passed down the tree to +constrain layout. ~propagate-dirty~ walks upward from a changed +component to mark ancestors as dirty, ensuring the screen is +re-drawn from the correct root. + +Collecting these under a single "Rendering pipeline" group signals to +readers that they form a coherent subsystem — if you override one, +you likely need to understand all of them. + +#+BEGIN_SRC lisp :tangle ../src/components/package.lisp + ;; Rendering pipeline + #:render #:render-screen #:render-node + #:component-layout-node #:component-children #:component-parent + #:available-width #:available-height + #:propagate-dirty +#+END_SRC + +** Theme engine + +~theme~ and ~make-theme~ are the constructor and class for theme +objects. ~theme-mode~ selects the active color mode (light/dark). +~theme-color~ looks up a named color in the current theme. +~load-preset~ loads a theme from a file, and ~define-preset~ registers +a preset at compile time. + +The theme engine is isolated from the rest of the component layer — +boxes and text reference theme colors by name at render time, and the +theme object is passed in from the application level. This separation +means themes can be swapped without touching component instances. + +#+BEGIN_SRC lisp :tangle ../src/components/package.lisp + ;; Theme engine + #:theme #:make-theme #:theme-mode + #:theme-color #:load-preset #:define-preset)) +(in-package :cl-tty.box) +#+END_SRC diff --git a/org/render.org b/org/render.org new file mode 100644 index 0000000..f91bb5f --- /dev/null +++ b/org/render.org @@ -0,0 +1,403 @@ +#+TITLE: Render Dispatch and Pipeline +#+STARTUP: content +#+FILETAGS: :cl-tty:components: + +* Overview + +The render module provides the generic function dispatch that connects +the component tree to the backend. Every component type defines its own +~render~ method; this module defines the common protocol and the +top-level orchestration functions. + +Three responsibilities live here: + +1. **Component protocol** — generic functions for navigating the + component tree (~component-children~, ~component-parent~, + ~component-layout-node~) + +2. **Render pipeline** — ~render-screen~ ties layout computation to + rendering, using the backend's actual terminal dimensions rather + than hardcoded values. ~render-node~ walks the tree. + +3. **Dirty propagation** — ~propagate-dirty~ marks a component and all + its ancestors for re-render. This is what makes the incremental + pipeline efficient: only changed branches get re-processed. + +* Contract + +** ~component-layout-node component~ → layout-node or nil + +Return the layout node associated with ~component~. Specialized per +component type (~box~, ~text~). + +** ~component-children component~ → list or nil + +Return child components. Default method returns ~nil~ (leaf components). + +** ~component-parent component~ → component or nil + +Return the parent component. Default method returns ~nil~. + +** ~render component backend~ + +Render ~component~ at its computed position using ~backend~. Default +method is a no-op. Specialized per component type. + +** ~render-screen root backend~ + +Full render pipeline: query backend size, compute layout, render tree, +wrapped in DECICM sync (~begin-sync~/~end-sync~). + +** ~render-node node backend~ + +Render ~node~ and all descendants recursively. ~render-screen~ calls +this once layout is computed. + +** ~available-width / available-height component~ → integer + +Return the computed width/height from the component's layout node, or +80/24 as fallback. + +** ~propagate-dirty component~ + +Mark ~component~ and every ancestor dirty. Walks up via +~component-parent~. + +* Tests + +** Test helper: make-capturing-backend + +Before any render test can run, we need a backend that captures output +to a string stream instead of writing to the real terminal. This helper +creates a ~modern-backend~ with a ~string-output-stream~ and returns +both, so tests can inspect what was rendered. + +#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +(in-package :cl-tty-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))) +#+END_SRC + +** Test: render dispatches to box method + +Verifies that calling ~render~ on a ~box~ instance invokes the box +rendering path, which draws border characters (e.g. ┌). This confirms +generic dispatch works for the box type and that the border rendering +pipeline is intact. A regression here would mean ~render-box~ is not +being called or produces no output. + +#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +(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")))) +#+END_SRC + +** Test: render dispatches to text method + +Verifies that calling ~render~ on a ~text~ instance invokes the text +rendering path, which outputs the string content. This confirms generic +dispatch works for the text type and that text content is correctly +emitted to the backend. A regression would mean ~render-text~ is not +being called. + +#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +(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")))) +#+END_SRC + +** Test: component-layout-node returns layout-node + +The ~component-layout-node~ generic is the bridge between the component +layer and the layout layer. Every renderable component must have an +associated layout node. This test confirms that both ~box~ and ~text~ +return a ~layout-node~ instance from their ~component-layout-node~ +method. A failure here means a component type is missing its method or +the slot accessor is wrong. + +#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +(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)))) +#+END_SRC + +** Test: component-children returns nil for leaves + +Leaf components (~box~, ~text~) have no children by definition. The +default method on ~t~ returns ~nil~. This test ensures that neither box +nor text accidentally inherits or defines a method that returns +non-nil, which would break the tree-walk in ~render-node~ by causing +infinite recursion or rendering phantom children. + +#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +(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))))) +#+END_SRC + +** Test: propagate-dirty marks component dirty + +~propagate-dirty~ is the entry point for the incremental rendering +pipeline. When a component changes (e.g. a keystroke in a text input), +it calls ~propagate-dirty~ to ensure the frame is re-rendered. This +test verifies that calling ~propagate-dirty~ on a clean component sets +it dirty. Without this, components that mutate would never trigger a +re-render and the display would become stale. + +#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +(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"))) +#+END_SRC + +** Test: available-width defaults + +~available-width~ reads the computed width from the component's layout +node. When a component hasn't been laid out (no explicit width set), +the layout node's width defaults to 0. This test verifies that +~available-width~ returns 0 for a freshly created box without layout +computation. This matters because container components use +~available-width~ to position children — getting a sensible default +prevents division-by-zero or garbled layouts during initialization. + +#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp +(test available-width-defaults + "available-width returns 0 for components without explicit width" + (let ((c (make-box))) + (is (= (available-width c) 0)))) +#+END_SRC + +* Implementation + +** Component protocol + +These three generic functions form the tree navigation API. They're +separated from ~render~ because layout and dirty propagation also +need to traverse the tree. + +*** component-layout-node + +The ~component-layout-node~ generic returns the ~layout-node~ instance +for a given component. Every component that participates in layout and +rendering must have a layout node — it stores the computed position and +size after layout passes. The generic is defined with two specific +methods for the built-in component types. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(in-package :cl-tty.box) + +;; ── Component Protocol ──────────────────────────────────────── + +(defgeneric component-layout-node (component) + (:documentation "Return the layout-node for COMPONENT.")) +#+END_SRC + +Each component type returns its internal layout node slot. This method +specializes on ~box~ and returns the ~box-layout-node~ slot value. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defmethod component-layout-node ((bx box)) + (box-layout-node bx)) +#+END_SRC + +The ~text~ component stores its layout node in the ~text-layout-node~ +slot. Both methods return the same type (~layout-node~), so the layout +engine can operate uniformly regardless of component type. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defmethod component-layout-node ((tx text)) + (text-layout-node tx)) +#+END_SRC + +*** component-children + +Leaf components (~box~, ~text~) have no children. Container components +(~scrollbox~, ~tabbar~) override this to return their child list. The +default method on ~t~ returns ~nil~, so new component types are +automatically treated as leaves unless they explicitly override. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defgeneric component-children (component) + (:documentation "Return the children of COMPONENT, or nil.") + (:method ((c t)) nil)) +#+END_SRC + +*** component-parent + +Parent links are set by the container when adding children. They're +used by ~propagate-dirty~ to walk up the tree. The default method on +~t~ returns ~nil~, which acts as the termination condition for the +recursive dirty walk — when ~component-parent~ returns ~nil~, we've +reached the root. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defgeneric component-parent (component) + (:documentation "Return the parent of COMPONENT, or nil.") + (:method ((c t)) nil)) +#+END_SRC + +** Render dispatch + +*** render generic + +The ~render~ generic is the central dispatch point for the rendering +pipeline. Every component type that can be drawn defines a method on +~render~. The default method on ~t~ is a no-op so that non-renderable +objects (or components still under development) don't cause errors +when the tree walk reaches them. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +;; ── Rendering Pipeline ──────────────────────────────────────── + +(defgeneric render (component backend) + (:documentation "Render COMPONENT at its computed position using BACKEND.") + (:method ((c t) backend) + (declare (ignore backend)) + (values))) +#+END_SRC + +*** render method for box + +Boxes are rendered with border characters. The ~render~ method +delegates to the ~render-box~ function defined in ~box.lisp~, which +handles the actual drawing of border lines and corners. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defmethod render ((bx box) backend) + (render-box bx backend)) +#+END_SRC + +*** render method for text + +Text components render their content string at the computed position. +The ~render~ method delegates to ~render-text~ from ~text.lisp~, which +writes the string with appropriate escape sequences for positioning. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defmethod render ((tx text) backend) + (render-text tx backend)) +#+END_SRC + +** Screen-level orchestration + +*** render-screen + +~render-screen~ is the entry point for rendering a full frame. It +queries the terminal size at render time (not at startup), so the +layout adapts to window resizes automatically. The DECICM sync pair +(~begin-sync~/~end-sync~) wraps the entire frame in a synchronized +update: the terminal buffers all escape sequences and flushes them +atomically, preventing partial-frame flicker. + +The pipeline is: (1) query backend pixel/dimension size, (2) begin +sync, (3) compute layout at the root, (4) walk the tree rendering each +node, (5) end sync. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defun render-screen (root backend) + "Render the component tree ROOT using BACKEND. + Computes layout at the root level, then traverses children + rendering each at their pre-computed positions. Uses the actual + terminal dimensions from BACKEND rather than hardcoded defaults." + (multiple-value-bind (w h) (backend-size backend) + (begin-sync backend) + (compute-layout (component-layout-node root) w h) + (render-node root backend) + (end-sync backend))) +#+END_SRC + +*** render-node + +Tree walk: render this node, then recurse into children. The layout was +already computed by ~render-screen~, so each node's position and size +are available from its ~layout-node~. The recursion is depth-first: +parents are drawn before children, which matters for z-ordering (the +parent's background is drawn first, children overlay on top). + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(defun render-node (node backend) + "Render a component NODE and its children. + Layout is computed once at the root by render-screen, so children + just render at their pre-computed positions." + (render node backend) + (dolist (child (component-children node)) + (render-node child backend))) +#+END_SRC + +** Utility accessors + +*** available-width + +Returns the computed width from the component's layout node. The layout +node's width is set by ~compute-layout~ during ~render-screen~, so this +reflects the actual allocated space — not the requested width. The +fallback of 80 matches the default terminal width when no layout node +exists (during initialization or testing without a backend). + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(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))) +#+END_SRC + +*** available-height + +Returns the computed height from the component's layout node. Like +~available-width~, this reflects post-layout allocated space. The +fallback of 24 matches the default terminal height. These accessors +provide a clean API for components that need to know their allocated +space during rendering, avoiding direct access to layout nodes. + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +(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))) +#+END_SRC + +** Dirty propagation + +*** propagate-dirty + +Recursive walk up the parent chain. When a text input receives a +keystroke, it marks itself dirty, then its parent scrollbox, then the +containing box, then the root — triggering recomputation and +re-rendering of everything that might have changed. + +This is the key to incremental rendering: only dirty branches are +re-processed. The ~render~ methods check ~dirty-p~ early and return +immediately for clean components (handled in each component's render, +not here). The recursion terminates when ~component-parent~ returns +~nil~ (the root component has no parent). + +#+BEGIN_SRC lisp :tangle ../src/components/render.lisp +;; ── 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)))) +#+END_SRC diff --git a/org/scrollbox-tabbar.org b/org/scrollbox-tabbar.org deleted file mode 100644 index 9a1de21..0000000 --- a/org/scrollbox-tabbar.org +++ /dev/null @@ -1,699 +0,0 @@ -#+TITLE: cl-tty v0.6.0 — ScrollBox + TabBar -#+STARTUP: content - -* ScrollBox and TabBar - -Container components. ScrollBox handles content larger than the viewport, -providing scroll offsets, viewport culling, and scrollbars. TabBar -handles horizontal tab navigation with keyboard support. - -Both components inherit ~dirty-mixin~ and implement the component protocol -(~render~, ~component-children~, ~component-layout-node~) so they work -with the rendering pipeline and layout engine. - -** Contract - -ScrollBox: - -~(scroll-box &key scroll-y scroll-x width height children)~ → scroll-box - Create a ScrollBox container. CHILDREN is a list of components. - ~scroll-y~ and ~scroll-x~ are the scroll offsets in lines. - -~(scroll-box-children sb)~ → list of child components -~(scroll-box-scroll-y sb)~ / ~(setf scroll-box-scroll-y)~ -~(scroll-box-scroll-x sb)~ / ~(setf scroll-box-scroll-x)~ - -~(render ((sb scroll-box) backend))~ — renders visible children with - scroll offset applied, then draws scrollbars if content overflows. - -~(scroll-by sb dy dx)~ — adjust scroll offset by DY rows, DX columns. - Clamps to valid range (0 to content-size minus viewport-size). - -~(sticky-scroll-p sb)~ / ~(setf sticky-scroll-p)~ — when T, auto-scroll - to bottom when new content arrives. - -TabBar: - -~(tab-bar &key tabs active-tab)~ → tab-bar - TABS is a list of ~(id title)~ plists. - -~(tab-bar-active sb)~ / ~(setf tab-bar-active)~ — currently active tab id. -~(tab-bar-tabs tb)~ — list of tab plists. -~(tab-bar-add tb id title)~ — add a tab. Returns the tab id. - -~(render ((tb tab-bar) backend))~ — renders tab row, active tab - highlighted, inactive tabs dimmed. - -** Tests - -#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp -(defpackage :cl-tty-scrollbox-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container) - (:export #:run-tests)) -(in-package #:cl-tty-scrollbox-test) - -(def-suite scrollbox-suite :description "ScrollBox + TabBar tests") -(in-suite scrollbox-suite) - -(defun run-tests () - (let ((result (run 'scrollbox-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -;; ── ScrollBox Tests ───────────────────────────────────────────── - -(test scrollbox-creates - "A ScrollBox can be created with defaults." - (let ((sb (make-scroll-box))) - (is (typep sb 'scroll-box)) - (is (= (scroll-box-scroll-y sb) 0)) - (is (= (scroll-box-scroll-x sb) 0)) - (is-false (scroll-box-children sb)))) - -(test scrollbox-with-children - "A ScrollBox can have children." - (let ((sb (make-scroll-box :children (list (make-text "hello"))))) - (is (= (length (scroll-box-children sb)) 1)))) - -(test scrollbox-scroll-by - "ScrollBy adjusts offset clamped to valid range." - (let ((sb (make-scroll-box :scroll-y 0))) - (scroll-by sb 5 0) - (is (>= (scroll-box-scroll-y sb) 0)))) - -(test scrollbox-component-children - "Component protocol: children are accessible." - (let* ((child (make-text "hello")) - (sb (make-scroll-box :children (list child)))) - (is (eql (first (component-children sb)) child)))) - -(test scrollbox-render-noop - "Rendering a ScrollBox with no children does not error." - (let* ((stream (make-string-output-stream)) - (backend (make-simple-backend :output-stream stream)) - (sb (make-scroll-box))) - (render sb backend) - (is-true t))) - -;; ── TabBar Tests ──────────────────────────────────────────────── - -(test tabbar-creates - "A TabBar can be created with defaults." - (let ((tb (make-tab-bar))) - (is (typep tb 'tab-bar)) - (is-false (tab-bar-active tb)) - (is-false (tab-bar-tabs tb)))) - -(test tabbar-add-tab - "Adding a tab returns the id and updates tabs." - (let ((tb (make-tab-bar))) - (let ((id (tab-bar-add tb :tab1 "Tab One"))) - (is (eql id :tab1)) - (is (= (length (tab-bar-tabs tb)) 1)) - (is (string= (getf (first (tab-bar-tabs tb)) :title) "Tab One"))))) - -(test tabbar-active-tab - "Setting active tab works." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (setf (tab-bar-active tb) :tab2) - (is (eql (tab-bar-active tb) :tab2)))) - -(test tabbar-render-noop - "Rendering a TabBar does not error." - (let* ((stream (make-string-output-stream)) - (backend (make-simple-backend :output-stream stream)) - (tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (setf (tab-bar-active tb) :tab1) - (render tb backend) - (is-true t))) - -(test tabbar-next-prev - "TabBar next/prev wraps around through tabs." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (tab-bar-add tb :tab3 "Three") - (is (eql (tab-bar-active tb) :tab1)) - (tab-bar-next tb) - (is (eql (tab-bar-active tb) :tab2)) - (tab-bar-next tb) - (is (eql (tab-bar-active tb) :tab3)) - (tab-bar-next tb) - (is (eql (tab-bar-active tb) :tab1) "wrap around past last") - (tab-bar-prev tb) - (is (eql (tab-bar-active tb) :tab3) "wrap around past first"))) - -(test tabbar-select - "TabBar select activates the specified tab." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (tab-bar-select tb :tab2) - (is (eql (tab-bar-active tb) :tab2)))) - -(test tabbar-handle-key - "TabBar handle-key dispatches left/right." - (let ((tb (make-tab-bar))) - (tab-bar-add tb :tab1 "One") - (tab-bar-add tb :tab2 "Two") - (setf (tab-bar-active tb) :tab1) - (tab-bar-handle-key tb (make-key-event :key :right)) - (is (eql (tab-bar-active tb) :tab2)) - (tab-bar-handle-key tb (make-key-event :key :left)) - (is (eql (tab-bar-active tb) :tab1)))) - -(test scrollbox-scroll-clamp - "ScrollBox clamp prevents scrolling past bounds." - (let ((sb (make-scroll-box :scroll-y 5 :scroll-x 3))) - (setf (scroll-box-scroll-y sb) -1) - (clamp-scroll sb) - (is (= (scroll-box-scroll-y sb) 0) "clamps below 0") - (setf (scroll-box-scroll-y sb) 1000000) - (clamp-scroll sb) - (is (= (scroll-box-scroll-y sb) 0) "clamps above max (no children = 0 content)"))) -#+END_SRC - -* Implementation - -** Package - -#+BEGIN_SRC lisp -(defpackage :cl-tty.container - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export - ;; ScrollBox - #:scroll-box #:make-scroll-box - #:scroll-box-scroll-y #:scroll-box-scroll-x - #:scroll-box-children - #:scroll-by #:sticky-scroll-p - ;; TabBar - #:tab-bar #:make-tab-bar - #:tab-bar-active #:tab-bar-tabs - #:tab-bar-add - ;; Rendering - #:render)) -#+END_SRC - -** ScrollBox class - -~scroll-box~ inherits from ~dirty-mixin~ for dirty tracking. It holds a -list of child components and two scroll offset slots (~scroll-y~ and -~scroll-x~). The ~sticky-scroll-p~ flag, when true, keeps the scroll -position at the bottom whenever new children are added. - -The constructor accepts keyword arguments for initial offset and children. -~children~ defaults to an empty list. - -#+BEGIN_SRC lisp -(in-package #:cl-tty.container) - -(defclass scroll-box (dirty-mixin) - ((children :initform nil :initarg :children - :accessor scroll-box-children :type list) - (scroll-y :initform 0 :initarg :scroll-y - :accessor scroll-box-scroll-y :type fixnum) - (scroll-x :initform 0 :initarg :scroll-x - :accessor scroll-box-scroll-x :type fixnum) - (sticky-scroll-p :initform t :initarg :sticky-scroll-p - :accessor sticky-scroll-p :type boolean) - (layout-node :initform (make-layout-node) :accessor scroll-box-layout-node))) - -(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) - sticky-scroll-p) - (make-instance 'scroll-box - :children children - :scroll-y scroll-y - :scroll-x scroll-x - :sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p))) -#+END_SRC - -** ScrollBox: component protocol - -~component-children~ returns the child list for the rendering pipeline -to traverse. ~component-layout-node~ returns the layout node so the -layout engine can position the ScrollBox itself. - -#+BEGIN_SRC lisp -(defmethod component-children ((sb scroll-box)) - (scroll-box-children sb)) - -(defmethod component-layout-node ((sb scroll-box)) - (scroll-box-layout-node sb)) -#+END_SRC - -** ScrollBox: scroll-by - -~scroll-by~ adjusts the scroll offset by delta rows and columns. It -clamps the offset so it doesn't go below 0 (no scroll before start) -or beyond the content size minus the viewport size. - -~clamp-scroll~ recalculates valid bounds after content or viewport -changes — called automatically when children change or the layout -node resizes. - -#+BEGIN_SRC lisp -(defun clamp-scroll (sb) - "Clamp scroll offsets to valid range." - (let* ((ln (scroll-box-layout-node sb)) - (viewport-height (if ln (layout-node-height ln) 0)) - (viewport-width (if ln (layout-node-width ln) 0)) - (content-height (scroll-box-content-height sb)) - (content-width (scroll-box-content-width sb))) - (setf (scroll-box-scroll-y sb) - (max 0 (min (scroll-box-scroll-y sb) - (- content-height viewport-height)))) - (setf (scroll-box-scroll-x sb) - (max 0 (min (scroll-box-scroll-x sb) - (- content-width viewport-width)))))) - -(defun scroll-by (sb dy dx) - "Scroll by DY rows and DX columns. Clamps to valid range." - (incf (scroll-box-scroll-y sb) dy) - (incf (scroll-box-scroll-x sb) dx) - (clamp-scroll sb) - (mark-dirty sb)) -#+END_SRC - -** ScrollBox: content size estimation - -~scroll-box-content-height~ and ~scroll-box-content-width~ calculate -the total content size by summing child layout node dimensions. This -is used by ~clamp-scroll~ and scrollbar rendering. - -For height: sum of all child heights (vertical layout). -For width: max of all child widths (horizontal scroll). - -#+BEGIN_SRC lisp -(defun scroll-box-content-height (sb) - "Total height of all children." - (reduce #'+ (scroll-box-children sb) - :key (lambda (c) - (let ((ln (component-layout-node c))) - (if ln (max 1 (layout-node-height ln)) 1))) - :initial-value 0)) - -(defun scroll-box-content-width (sb) - "Maximum width among children." - (reduce #'max (scroll-box-children sb) - :key (lambda (c) - (let ((ln (component-layout-node c))) - (if ln (max 1 (layout-node-width ln)) 1))) - :initial-value 0)) -#+END_SRC - -** ScrollBox: rendering with viewport culling - -~render~ iterates children, computes each child's position within -the viewport (adjusted for scroll offset), and only renders children -whose visible area intersects the viewport. This is the core -optimization — for a terminal with 200 children, only the ~24 -visible ones are actually drawn. - -~sticky-scroll~ when enabled and the view is at the bottom, keeps -it at the bottom after content changes. The flag resets to false -when the user manually scrolls up. - -#+BEGIN_SRC lisp -(defmethod render ((sb scroll-box) backend) - "Render visible children with scroll offset applied. -Delegates to each child's `render` method, temporarily offsetting -its layout-node position for the scroll offset. Children outside -the viewport are clipped out." - (let* ((ln (scroll-box-layout-node sb)) - (vx 0) (vy 0) - (vw (if ln (layout-node-width ln) 80)) - (vh (if ln (layout-node-height ln) 24)) - (sy (scroll-box-scroll-y sb)) - (sx (scroll-box-scroll-x sb))) - (dolist (child (scroll-box-children sb)) - (let* ((cln (component-layout-node child)) - (ch (if cln (layout-node-height cln) 1)) - (cy vy)) - ;; Only render children that are visible in the viewport - (when (and (< (+ cy (- sy)) (+ vh vy)) - (> (+ cy (- sy) ch) vy)) - ;; Temporarily offset child's layout-node position for rendering - (let ((orig-x (if cln (layout-node-x cln) 0)) - (orig-y (if cln (layout-node-y cln) 0))) - (when cln - (setf (layout-node-x cln) (- orig-x sx) - (layout-node-y cln) (- orig-y sy))) - (unwind-protect - (render child backend) - (when cln - (setf (layout-node-x cln) orig-x - (layout-node-y cln) orig-y))))) - (incf vy ch))) - (draw-scrollbars sb backend vw vh))) -#+END_SRC - -** ScrollBox: sticky scroll - -~sticky-scroll~ checks whether the view is at the bottom. If so, -auto-scrolls to keep the bottommost content visible. The user -calling ~scroll-by~ with a negative DY resets the sticky flag. - -#+BEGIN_SRC lisp -(defun update-sticky-scroll (sb) - "If sticky-scroll-p is active and at bottom, keep at bottom." - (when (sticky-scroll-p sb) - (let* ((content-h (scroll-box-content-height sb)) - (ln (scroll-box-layout-node sb)) - (viewport-h (if ln (layout-node-height ln) 24))) - (when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1)) - (setf (scroll-box-scroll-y sb) - (max 0 (- content-h viewport-h))))))) -#+END_SRC - -** ScrollBox: scrollbar rendering - -~draw-scrollbars~ renders vertical and horizontal scrollbars as -single-character-wide bars on the right and bottom edges of the -viewport. The scrollbar thumb position and size reflect the current -scroll position relative to content size. - -Vertical scrollbar: blocks (~#\Full~ ~#\Up~ ~#\Mid~ ~#\Down~). -Horizontal scrollbar: block characters along the bottom. - -#+BEGIN_SRC lisp -(defun scrollbar-thumb (scroll-pos viewport-size content-size) - "Return the thumb position for a scrollbar (0.0 to 1.0)." - (if (> content-size viewport-size) - (/ (float scroll-pos) (- content-size viewport-size)) - 0.0)) - -(defun draw-scrollbars (sb backend viewport-w viewport-h) - "Draw scrollbars if content exceeds viewport." - (let* ((content-h (scroll-box-content-height sb)) - (content-w (scroll-box-content-width sb)) - (sy (scroll-box-scroll-y sb)) - (sx (scroll-box-scroll-x sb))) - ;; Vertical scrollbar - (when (> content-h viewport-h) - (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) - (thumb-pos (round (* thumb viewport-h)))) - (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :scrollbar-bg) - (draw-text backend (1- viewport-w) thumb-pos "█" nil nil))) - ;; Horizontal scrollbar - (when (> content-w viewport-w) - (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) - (thumb-pos (round (* thumb viewport-w)))) - (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :scrollbar-bg) - (draw-text backend thumb-pos (1- viewport-h) "█" nil nil))))) -#+END_SRC - -** TabBar class - -~tab-bar~ stores a list of tab plists ~((:id :tab1 :title \"One\") ...)~ -and the currently active tab id. ~tab-bar-add~ creates a new tab with -the given id and title, returns the id. - -#+BEGIN_SRC lisp -(in-package #:cl-tty.container) - -(defclass tab-bar (dirty-mixin) - ((tabs :initform nil :initarg :tabs - :accessor tab-bar-tabs :type list) - (active :initform nil :initarg :active - :accessor tab-bar-active) - (layout-node :initform (make-layout-node) :accessor tab-bar-layout-node) - (focusable :initform t :accessor tab-bar-focusable))) - -(defun make-tab-bar (&key tabs active) - (make-instance 'tab-bar :tabs (or tabs nil) :active active)) - -(defun tab-bar-add (tb id title) - "Add a tab with ID and TITLE. Sets as active if first tab." - (setf (tab-bar-tabs tb) - (nconc (tab-bar-tabs tb) (list (list :id id :title title)))) - (unless (tab-bar-active tb) - (setf (tab-bar-active tb) id)) - id) -#+END_SRC - -** TabBar: component protocol - -#+BEGIN_SRC lisp -(defmethod component-layout-node ((tb tab-bar)) - (tab-bar-layout-node tb)) -#+END_SRC - -** TabBar: navigation - -~tab-bar-next~ and ~tab-bar-prev~ cycle through tabs. ~tab-bar-select~ -activates a tab by id. ~tab-bar-handle-key~ dispatches key events -(Left/Right to navigate, optional Enter to select). - -#+BEGIN_SRC lisp -(defun tab-bar-next (tb) - "Move to next tab." - (let* ((tabs (tab-bar-tabs tb)) - (current (tab-bar-active tb)) - (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) - (pos (position current ids))) - (when pos - (let ((next (nth (mod (1+ pos) (length ids)) ids))) - (setf (tab-bar-active tb) next) - (mark-dirty tb))))) - -(defun tab-bar-prev (tb) - "Move to previous tab." - (let* ((tabs (tab-bar-tabs tb)) - (current (tab-bar-active tb)) - (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) - (pos (position current ids))) - (when pos - (let ((prev (nth (mod (1- pos) (length ids)) ids))) - (setf (tab-bar-active tb) prev) - (mark-dirty tb))))) - -(defun tab-bar-select (tb id) - "Select a tab by ID." - (setf (tab-bar-active tb) id) - (mark-dirty tb)) -#+END_SRC - -** TabBar: keyboard handler - -~tab-bar-handle-key~ dispatches Left → previous tab, Right → next tab. -Returns T if the key was handled, NIL otherwise (for composability with -the keybinding system). - -#+BEGIN_SRC lisp -(defun tab-bar-handle-key (tb event) - "Handle a key-event on a TabBar. Returns T if handled." - (case (key-event-key event) - (:left (tab-bar-prev tb) t) - (:right (tab-bar-next tb) t) - (t nil))) -#+END_SRC - -** TabBar: rendering - -~render~ iterates tabs, drawing each as ~[ Title ]~ with the active -tab highlighted (bold, accent color) and inactive tabs dimmed. Tabs -are separated by two spaces. - -The available width comes from the layout node. If tabs overflow, -they are truncated with an ellipsis. - -#+BEGIN_SRC lisp -(defmethod render ((tb tab-bar) backend) - (let* ((ln (tab-bar-layout-node tb)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (active-id (tab-bar-active tb)) - (tabs (tab-bar-tabs tb)) - (x-pos x)) - (dolist (tab tabs) - (let* ((id (getf tab :id)) - (title (getf tab :title)) - (label (format nil " ~A " title)) - (label-len (length label)) - (is-active (eql id active-id)) - (fg (if is-active :accent :text-muted)) - (bg (if is-active :background-element nil))) - ;; Check if tab fits - (when (>= (+ x-pos label-len 2) (+ x w)) - (draw-text backend x-pos y "…" :text-muted nil) - (return)) - ;; Draw tab - (draw-text backend x-pos y label fg bg) - (incf x-pos (+ label-len 2)))) - (values))) -#+END_SRC - -** Combined tangle blocks - -#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp -(in-package #:cl-tty.container) - -(defclass scroll-box (dirty-mixin) - ((children :initform nil :initarg :children :accessor scroll-box-children :type list) - (scroll-y :initform 0 :initarg :scroll-y :accessor scroll-box-scroll-y :type fixnum) - (scroll-x :initform 0 :initarg :scroll-x :accessor scroll-box-scroll-x :type fixnum) - (sticky-scroll-p :initform t :initarg :sticky-scroll-p :accessor sticky-scroll-p :type boolean) - (layout-node :initform (make-layout-node) :accessor scroll-box-layout-node))) - -(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) sticky-scroll-p) - (make-instance 'scroll-box - :children children :scroll-y scroll-y :scroll-x scroll-x - :sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p))) - -(defmethod component-children ((sb scroll-box)) (scroll-box-children sb)) -(defmethod component-layout-node ((sb scroll-box)) (scroll-box-layout-node sb)) - -(defun clamp-scroll (sb) - (let* ((ln (scroll-box-layout-node sb)) - (viewport-h (if ln (layout-node-height ln) 0)) - (viewport-w (if ln (layout-node-width ln) 0)) - (content-h (scroll-box-content-height sb)) - (content-w (scroll-box-content-width sb))) - (setf (scroll-box-scroll-y sb) (max 0 (min (scroll-box-scroll-y sb) (- content-h viewport-h)))) - (setf (scroll-box-scroll-x sb) (max 0 (min (scroll-box-scroll-x sb) (- content-w viewport-w)))))) - -(defun scroll-by (sb dy dx) - (incf (scroll-box-scroll-y sb) dy) (incf (scroll-box-scroll-x sb) dx) - (clamp-scroll sb) (mark-dirty sb)) - -(defun scroll-box-content-height (sb) - (reduce #'+ (scroll-box-children sb) - :key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-height ln)) 1))) - :initial-value 0)) - -(defun scroll-box-content-width (sb) - (reduce #'max (scroll-box-children sb) - :key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-width ln)) 1))) - :initial-value 0)) - -(defmethod render ((sb scroll-box) backend) - "Render ScrollBox children within the viewport, offset by scroll position. -Children outside the viewport are skipped." - (let* ((ln (scroll-box-layout-node sb)) - (vx 0) (vy 0) - (vw (if ln (layout-node-width ln) 80)) - (vh (if ln (layout-node-height ln) 24)) - (sy (scroll-box-scroll-y sb)) - (sx (scroll-box-scroll-x sb))) - (dolist (child (scroll-box-children sb)) - (let* ((cln (component-layout-node child)) - (ch (if cln (layout-node-height cln) 1)) - (cy vy)) - ;; Only render children that are visible in the viewport - (when (and (< (+ cy (- sy)) (+ vh vy)) - (> (+ cy (- sy) ch) vy)) - ;; Temporarily offset child's layout-node position for rendering - (let ((orig-x (if cln (layout-node-x cln) 0)) - (orig-y (if cln (layout-node-y cln) 0))) - (when cln - (setf (layout-node-x cln) (- orig-x sx) - (layout-node-y cln) (- orig-y sy))) - (unwind-protect - (render child backend) - (when cln - (setf (layout-node-x cln) orig-x - (layout-node-y cln) orig-y))))) - (incf vy ch))) - (draw-scrollbars sb backend vw vh))) - -(defun scrollbar-thumb (scroll-pos viewport-size content-size) - (if (> content-size viewport-size) (/ (float scroll-pos) (- content-size viewport-size)) 0.0)) - -(defun draw-scrollbars (sb backend viewport-w viewport-h) - (let* ((content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb)) - (sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))) - (when (> content-h viewport-h) - (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) - (thumb-pos (round (* thumb viewport-h)))) - (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :bright-black) - (draw-text backend (1- viewport-w) thumb-pos "█" nil nil))) - (when (> content-w viewport-w) - (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) - (thumb-pos (round (* thumb viewport-w)))) - (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :bright-black) - (draw-text backend thumb-pos (1- viewport-h) "█" nil nil))))) - -(defun update-sticky-scroll (sb) - (when (sticky-scroll-p sb) - (let* ((content-h (scroll-box-content-height sb)) - (ln (scroll-box-layout-node sb)) - (viewport-h (if ln (layout-node-height ln) 24))) - (when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1)) - (setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h))))))) -#+END_SRC - -#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp -(in-package #:cl-tty.container) - -(defclass tab-bar (dirty-mixin) - ((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list) - (active :initform nil :initarg :active :accessor tab-bar-active) - (layout-node :initform (make-layout-node) :accessor tab-bar-layout-node) - (focusable :initform t :accessor tab-bar-focusable))) - -(defun make-tab-bar (&key tabs active) - (make-instance 'tab-bar :tabs (or tabs nil) :active active)) - -(defun tab-bar-add (tb id title) - (setf (tab-bar-tabs tb) (nconc (tab-bar-tabs tb) (list (list :id id :title title)))) - (unless (tab-bar-active tb) (setf (tab-bar-active tb) id)) id) - -(defmethod component-layout-node ((tb tab-bar)) (tab-bar-layout-node tb)) - -(defun tab-bar-next (tb) - (let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb)) - (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) - (pos (position current ids))) - (when pos (let ((next (nth (mod (1+ pos) (length ids)) ids))) - (setf (tab-bar-active tb) next) (mark-dirty tb))))) - -(defun tab-bar-prev (tb) - (let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb)) - (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) - (pos (position current ids))) - (when pos (let ((prev (nth (mod (1- pos) (length ids)) ids))) - (setf (tab-bar-active tb) prev) (mark-dirty tb))))) - -(defun tab-bar-select (tb id) (setf (tab-bar-active tb) id) (mark-dirty tb)) - -(defun tab-bar-handle-key (tb event) - (case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil))) - -(defmethod render ((tb tab-bar) backend) - (let* ((ln (tab-bar-layout-node tb)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x)) - (dolist (tab tabs) - (let* ((id (getf tab :id)) (title (getf tab :title)) - (label (format nil " ~A " title)) (label-len (length label)) - (is-active (eql id active-id)) - (fg (if is-active :accent :text-muted)) - (bg (if is-active :background-element nil))) - (when (>= (+ x-pos label-len 2) w) - (draw-text backend x-pos y "..." :text-muted nil) (return)) - (draw-text backend x-pos y label fg bg) - (incf x-pos (+ label-len 2))))) - (values)) -#+END_SRC - -#+BEGIN_SRC lisp :tangle ../src/components/container-package.lisp -(defpackage :cl-tty.container - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export - #:scroll-box #:make-scroll-box - #:scroll-box-scroll-y #:scroll-box-scroll-x - #:scroll-box-children #:scroll-by - #:sticky-scroll-p - #:clamp-scroll - #:tab-bar #:make-tab-bar - #:tab-bar-active #:tab-bar-tabs - #:tab-bar-add #:tab-bar-next #:tab-bar-prev - #:tab-bar-select #:tab-bar-handle-key)) -#+END_SRC diff --git a/org/scrollbox.org b/org/scrollbox.org new file mode 100644 index 0000000..22be5f5 --- /dev/null +++ b/org/scrollbox.org @@ -0,0 +1,581 @@ +#+TITLE: ScrollBox +#+STARTUP: content +#+FILETAGS: :cl-tty:container: + +* Overview + +ScrollBox is a container component that handles content larger than the +viewport. It provides scroll offsets, viewport culling (only renders +visible children), scrollbar rendering, and sticky-scroll (auto-scroll +to bottom when new content arrives). + +~scroll-box~ inherits ~dirty-mixin~ and implements the component protocol +(~render~, ~component-children~, ~component-layout-node~) so it works +with the rendering pipeline and layout engine. + +** Contract + +~(scroll-box &key scroll-y scroll-x width height children)~ → scroll-box + Create a ScrollBox container. CHILDREN is a list of components. + ~scroll-y~ and ~scroll-x~ are the scroll offsets in lines. + +~(scroll-box-children sb)~ → list of child components +~(scroll-box-scroll-y sb)~ / ~(setf scroll-box-scroll-y)~ +~(scroll-box-scroll-x sb)~ / ~(setf scroll-box-scroll-x)~ + +~(render ((sb scroll-box) backend))~ — renders visible children with + scroll offset applied, then draws scrollbars if content overflows. + +~(scroll-by sb dy dx)~ — adjust scroll offset by DY rows, DX columns. + Clamps to valid range (0 to content-size minus viewport-size). + +~(sticky-scroll-p sb)~ / ~(setf sticky-scroll-p)~ — when T, auto-scroll + to bottom when new content arrives. + +* Implementation + +** ScrollBox class + +~scroll-box~ inherits from ~dirty-mixin~ for dirty tracking. It holds a +list of child components and two scroll offset slots (~scroll-y~ and +~scroll-x~). The ~sticky-scroll-p~ flag, when true, keeps the scroll +position at the bottom whenever new children are added. + +Defining this as a class (rather than a struct) lets us integrate with +the CLOS-based component protocol — ~render~ dispatches on the class, +and dirty-mixin provides the marking machinery used by the refresh loop. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(in-package #:cl-tty.container) + +(defclass scroll-box (dirty-mixin) + ((children :initform nil :initarg :children + :accessor scroll-box-children :type list) + (scroll-y :initform 0 :initarg :scroll-y + :accessor scroll-box-scroll-y :type fixnum) + (scroll-x :initform 0 :initarg :scroll-x + :accessor scroll-box-scroll-x :type fixnum) + (sticky-scroll-p :initform t :initarg :sticky-scroll-p + :accessor sticky-scroll-p :type boolean) + (layout-node :initform (make-layout-node) :accessor scroll-box-layout-node))) +#+END_SRC + +** make-scroll-box constructor + +A dedicated constructor function provides keyword argument defaults and +ensures ~sticky-scroll-p~ defaults to T even when the caller omits it +(the :initform on the slot handles default-initialization, but a nil +value explicitly passed as ~:sticky-scroll-p nil~ needs to be +preserved). Using a function instead of making the user call +~make-instance~ directly keeps the API ergonomic and hides CLOS plumbing. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) + sticky-scroll-p) + (make-instance 'scroll-box + :children children + :scroll-y scroll-y + :scroll-x scroll-x + :sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p))) +#+END_SRC + +** component-children method + +~component-children~ is part of the component protocol. The rendering +pipeline calls this to discover the tree of children to render. By +delegating to the ~scroll-box-children~ accessor, we keep the protocol +implementation thin — just an indirection that makes ~scroll-box~ +participate polymorphically alongside other container types. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defmethod component-children ((sb scroll-box)) + (scroll-box-children sb)) +#+END_SRC + +** component-layout-node method + +~component-layout-node~ returns the layout node that the layout engine +uses to position the ScrollBox itself within its parent. Each ScrollBox +creates its own layout node at construction time via ~make-layout-node~, +so this method simply returns that stored node. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defmethod component-layout-node ((sb scroll-box)) + (scroll-box-layout-node sb)) +#+END_SRC + +** clamp-scroll helper + +~clamp-scroll~ recalculates valid scroll bounds after content or viewport +changes — called automatically when children change or the layout node +resizes. It reads the viewport dimensions from the layout node and the +content dimensions from the content-size helpers, then clamps both +scroll offsets with ~max~/~min~ to ensure they never go below 0 or +beyond the scrollable range. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun clamp-scroll (sb) + "Clamp scroll offsets to valid range." + (let* ((ln (scroll-box-layout-node sb)) + (viewport-height (if ln (layout-node-height ln) 0)) + (viewport-width (if ln (layout-node-width ln) 0)) + (content-height (scroll-box-content-height sb)) + (content-width (scroll-box-content-width sb))) + (setf (scroll-box-scroll-y sb) + (max 0 (min (scroll-box-scroll-y sb) + (- content-height viewport-height)))) + (setf (scroll-box-scroll-x sb) + (max 0 (min (scroll-box-scroll-x sb) + (- content-width viewport-width)))))) +#+END_SRC + +** scroll-by method + +~scroll-by~ adjusts the scroll offset by delta rows and columns. It +increments the current offset, clamps via ~clamp-scroll~, then marks +the component dirty so the render loop picks up the change. This is +the primary API entry point for programmatic scrolling (from keyboard +input or mouse wheel events). + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun scroll-by (sb dy dx) + "Scroll by DY rows and DX columns. Clamps to valid range." + (incf (scroll-box-scroll-y sb) dy) + (incf (scroll-box-scroll-x sb) dx) + (clamp-scroll sb) + (mark-dirty sb)) +#+END_SRC + +** scroll-box-content-height + +~scroll-box-content-height~ calculates the total content height by +summing all child heights. Each child reports its height through its +layout node, with a minimum of 1 row (even zero-height children get a +floor so they don't collapse the layout). This is used by +~clamp-scroll~, scrollbar rendering, and sticky-scroll logic. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun scroll-box-content-height (sb) + "Total height of all children." + (reduce #'+ (scroll-box-children sb) + :key (lambda (c) + (let ((ln (component-layout-node c))) + (if ln (max 1 (layout-node-height ln)) 1))) + :initial-value 0)) +#+END_SRC + +** scroll-box-content-width + +~scroll-box-content-width~ calculates the maximum width among children, +since horizontal scrolling follows the widest child rather than summing +widths. Like the height counterpart, it floors child widths at 1 so +empty children don't zero out the measurement. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun scroll-box-content-width (sb) + "Maximum width among children." + (reduce #'max (scroll-box-children sb) + :key (lambda (c) + (let ((ln (component-layout-node c))) + (if ln (max 1 (layout-node-width ln)) 1))) + :initial-value 0)) +#+END_SRC + +** Render method with viewport culling + +~render~ iterates children, computes each child's position within +the viewport (adjusted for scroll offset), and only renders children +whose visible area intersects the viewport. This is the core +optimization — for a terminal with 200 children, only the ~24 +visible ones are actually drawn. + +The method temporarily offsets each child's layout node by the scroll +amount during rendering, then restores the original position via +~unwind-protect~. This avoids mutating the permanent layout state while +still making each child's ~render~ method draw at the correct scrolled +position. + +After child rendering, it delegates to ~draw-scrollbars~ for the +scrollbar overlay. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defmethod render ((sb scroll-box) backend) + "Render visible children with scroll offset applied. +Delegates to each child's `render` method, temporarily offsetting +its layout-node position for the scroll offset. Children outside +the viewport are clipped out." + (let* ((ln (scroll-box-layout-node sb)) + (vx 0) (vy 0) + (vw (if ln (layout-node-width ln) 80)) + (vh (if ln (layout-node-height ln) 24)) + (sy (scroll-box-scroll-y sb)) + (sx (scroll-box-scroll-x sb))) + (dolist (child (scroll-box-children sb)) + (let* ((cln (component-layout-node child)) + (ch (if cln (layout-node-height cln) 1)) + (cy vy)) + ;; Only render children that are visible in the viewport + (when (and (< (- cy sy) vh) + (> (+ (- cy sy) ch) 0)) + ;; Temporarily offset child's layout-node position for rendering + (let ((orig-x (if cln (layout-node-x cln) 0)) + (orig-y (if cln (layout-node-y cln) 0))) + (when cln + (setf (layout-node-x cln) (- vx sx) + (layout-node-y cln) (- vy sy))) + (unwind-protect + (render child backend) + (when cln + (setf (layout-node-x cln) orig-x + (layout-node-y cln) orig-y))))) + (incf vy ch))) + (draw-scrollbars sb backend vw vh))) +#+END_SRC + +** update-sticky-scroll + +~update-sticky-scroll~ checks whether the view is at the bottom and, if +the ~sticky-scroll-p~ flag is set, auto-scrolls to keep the bottommost +content visible. The comparison uses a 1-row tolerance (~(- content-h +viewport-h 1)~) so minor content changes don't cause jitter. The sticky +flag is reset to nil when the user manually scrolls up (handled by +callers of ~scroll-by~). + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun update-sticky-scroll (sb) + "If sticky-scroll-p is active and at bottom, keep at bottom." + (when (sticky-scroll-p sb) + (let* ((content-h (scroll-box-content-height sb)) + (ln (scroll-box-layout-node sb)) + (viewport-h (if ln (layout-node-height ln) 24))) + (when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1)) + (setf (scroll-box-scroll-y sb) + (max 0 (- content-h viewport-h))))))) +#+END_SRC + +** scrollbar-thumb helper + +~scrollbar-thumb~ converts a raw scroll position (in lines) into a +normalized 0.0-to-1.0 ratio representing where the thumb should appear +on the scrollbar track. When content fits entirely within the viewport, +it returns 0.0 (no scrolling possible). This normalized value is used +by ~draw-scrollbars~ to compute the pixel/character position of the +thumb. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun scrollbar-thumb (scroll-pos viewport-size content-size) + "Return the thumb position for a scrollbar (0.0 to 1.0)." + (if (> content-size viewport-size) + (/ (float scroll-pos) (- content-size viewport-size)) + 0.0)) +#+END_SRC + +** draw-scrollbars + +~draw-scrollbars~ renders vertical and horizontal scrollbars as +single-character-wide bars on the right and bottom edges of the +viewport. The scrollbar thumb position and size reflect the current +scroll position relative to content size. + +The vertical scrollbar uses a filled block (█) for the thumb and a +background fill for the track. The horizontal scrollbar is drawn along +the bottom edge. Both account for the scrollbox's own position within +the layout tree (~ox~, ~oy~) so nested scrollboxes render scrollbars at +the correct screen coordinates. + +#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp +(defun draw-scrollbars (sb backend viewport-w viewport-h) + "Draw scrollbars if content exceeds viewport." + (let* ((content-h (scroll-box-content-height sb)) + (content-w (scroll-box-content-width sb)) + (sy (scroll-box-scroll-y sb)) + (sx (scroll-box-scroll-x sb)) + (ln (scroll-box-layout-node sb)) + (ox (if ln (layout-node-x ln) 0)) + (oy (if ln (layout-node-y ln) 0))) + ;; Vertical scrollbar + (when (> content-h viewport-h) + (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) + (thumb-pos (round (* thumb viewport-h)))) + (draw-rect backend (+ ox (1- viewport-w)) oy 1 viewport-h :bg :scrollbar-bg) + (draw-text backend (+ ox (1- viewport-w)) (+ oy thumb-pos) "█" nil nil))) + ;; Horizontal scrollbar + (when (> content-w viewport-w) + (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) + (thumb-pos (round (* thumb viewport-w)))) + (draw-rect backend ox (+ oy (1- viewport-h)) viewport-w 1 :bg :scrollbar-bg) + (draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil))))) +#+END_SRC + +** Bug Fixes (v1.0.0): scroll offset and scrollbar position + +Two bugs were fixed in the ScrollBox render pipeline: + +1. *Render scroll origin*: The render method used ~orig-y~ (the child's original + layout-node Y position, always 0 for top-level children) as the basis for + scroll offset. This caused the content-relative position ~vy~ to be ignored, + making scroll offsets incorrect when children were offset by layout. + + Fix: Use ~vy~ (the content-relative Y accumulator) instead of ~orig-y~ when + setting the temporary layout offset: ~(layout-node-y cln) (- vy sy)~. + +2. *Scrollbar positions*: ~draw-scrollbars~ drew scrollbars at viewport-local + coordinates (0, 0), not accounting for the scrollbox's own position within + the layout tree. Scrollbars would appear at the wrong screen location when + the scrollbox was nested inside other containers. + + Fix: Read the scrollbox's layout-node origin ~(ox, oy)~ and offset all + scrollbar drawing coordinates by those values. + +* Tests + +Test suite for both ScrollBox and TabBar. + +** Package and test infrastructure + +The tests use FiveAM, the Common Lisp testing framework. The package +setup pulls in all the systems under test (~cl-tty.backend~, +~cl-tty.box~, ~cl-tty.layout~, ~cl-tty.input~, ~cl-tty.container~) +along with the base ~:cl~ language and ~:fiveam~ itself. + +~run-tests~ is exported so the test runner script can call it +unconditionally; it runs the ~scrollbox-suite~ and prints results via +~fiveam:explain!~ before exiting. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(defpackage :cl-tty-scrollbox-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container) + (:export #:run-tests)) +(in-package #:cl-tty-scrollbox-test) + +(def-suite scrollbox-suite :description "ScrollBox + TabBar tests") +(in-suite scrollbox-suite) + +(defun run-tests () + (let ((result (run 'scrollbox-suite))) + (fiveam:explain! result) + (uiop:quit 0))) +#+END_SRC + +** ScrollBox constructor test + +Confirms a bare ~make-scroll-box~ returns a ~scroll-box~ instance with +default scroll offsets of 0 and no children. This establishes that the +class definition and constructor are wired up correctly. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test scrollbox-creates + "A ScrollBox can be created with defaults." + (let ((sb (make-scroll-box))) + (is (typep sb 'scroll-box)) + (is (= (scroll-box-scroll-y sb) 0)) + (is (= (scroll-box-scroll-x sb) 0)) + (is-false (scroll-box-children sb)))) +#+END_SRC + +** ScrollBox with children test + +Verifies that the ~:children~ initarg is accepted and that +~scroll-box-children~ returns the list. A ScrollBox with one child +should report length 1. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test scrollbox-with-children + "A ScrollBox can have children." + (let ((sb (make-scroll-box :children (list (make-text "hello"))))) + (is (= (length (scroll-box-children sb)) 1)))) +#+END_SRC + +** ScrollBox scroll-by test + +Exercises ~scroll-by~ with a positive DY offset and asserts the +scroll-y is non-negative after the operation. Combined with +~scrollbox-scroll-clamp~ below, this covers both the normal and +boundary behavior of the scroll mechanic. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test scrollbox-scroll-by + "ScrollBy adjusts offset clamped to valid range." + (let ((sb (make-scroll-box :scroll-y 0))) + (scroll-by sb 5 0) + (is (>= (scroll-box-scroll-y sb) 0)))) +#+END_SRC + +** ScrollBox component-children test + +Confirms the component protocol method ~component-children~ returns the +same child list that ~scroll-box-children~ does. This ensures the +protocol indirection works and that the rendering pipeline will see the +correct children. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test scrollbox-component-children + "Component protocol: children are accessible." + (let* ((child (make-text "hello")) + (sb (make-scroll-box :children (list child)))) + (is (eql (first (component-children sb)) child)))) +#+END_SRC + +** ScrollBox render no-op test + +Renders a ScrollBox with no children to a string-output-stream backend. +The test passes if no errors are signaled — this guards against nil +layout nodes or unbound slots causing problems during the render +pipeline's initial traversal. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test scrollbox-render-noop + "Rendering a ScrollBox with no children does not error." + (let* ((stream (make-string-output-stream)) + (backend (make-simple-backend :output-stream stream)) + (sb (make-scroll-box))) + (render sb backend) + (is-true t))) +#+END_SRC + +** TabBar constructor test + +Confirms a bare ~make-tab-bar~ returns a ~tab-bar~ instance with no +active tab and no tabs. This validates the TabBar class definition and +constructor. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test tabbar-creates + "A TabBar can be created with defaults." + (let ((tb (make-tab-bar))) + (is (typep tb 'tab-bar)) + (is-false (tab-bar-active tb)) + (is-false (tab-bar-tabs tb)))) +#+END_SRC + +** TabBar add-tab test + +Tests that ~tab-bar-add~ returns the supplied ID, adds a tab to the +internal list, and stores the title correctly. Each tab is stored as a +plist, so the test checks both list length and the ~:title~ property. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test tabbar-add-tab + "Adding a tab returns the id and updates tabs." + (let ((tb (make-tab-bar))) + (let ((id (tab-bar-add tb :tab1 "Tab One"))) + (is (eql id :tab1)) + (is (= (length (tab-bar-tabs tb)) 1)) + (is (string= (getf (first (tab-bar-tabs tb)) :title) "Tab One"))))) +#+END_SRC + +** TabBar active tab test + +Verifies that ~(setf tab-bar-active)~ correctly selects a tab by ID and +that ~tab-bar-active~ returns that ID afterward. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test tabbar-active-tab + "Setting active tab works." + (let ((tb (make-tab-bar))) + (tab-bar-add tb :tab1 "One") + (tab-bar-add tb :tab2 "Two") + (setf (tab-bar-active tb) :tab2) + (is (eql (tab-bar-active tb) :tab2)))) +#+END_SRC + +** TabBar render no-op test + +Renders a fully configured TabBar (with tabs and an active selection) to +a string-output-stream backend to confirm the render method doesn't +error. A TabBar must draw its tab strip without crashing even when +disconnected from a real terminal. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test tabbar-render-noop + "Rendering a TabBar does not error." + (let* ((stream (make-string-output-stream)) + (backend (make-simple-backend :output-stream stream)) + (tb (make-tab-bar))) + (tab-bar-add tb :tab1 "One") + (tab-bar-add tb :tab2 "Two") + (setf (tab-bar-active tb) :tab1) + (render tb backend) + (is-true t))) +#+END_SRC + +** TabBar next/prev navigation test + +Exercises the full navigation cycle: ~tab-bar-next~ advances through +three tabs, wrapping around past the last; ~tab-bar-prev~ goes backward, +wrapping around past the first. This is the core keyboard interaction +for tabbed UIs and must handle edge cases (empty bar, single tab, etc.) +gracefully. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test tabbar-next-prev + "TabBar next/prev wraps around through tabs." + (let ((tb (make-tab-bar))) + (tab-bar-add tb :tab1 "One") + (tab-bar-add tb :tab2 "Two") + (tab-bar-add tb :tab3 "Three") + (is (eql (tab-bar-active tb) :tab1)) + (tab-bar-next tb) + (is (eql (tab-bar-active tb) :tab2)) + (tab-bar-next tb) + (is (eql (tab-bar-active tb) :tab3)) + (tab-bar-next tb) + (is (eql (tab-bar-active tb) :tab1) "wrap around past last") + (tab-bar-prev tb) + (is (eql (tab-bar-active tb) :tab3) "wrap around past first"))) +#+END_SRC + +** TabBar select test + +~tab-bar-select~ activates a named tab directly (as opposed to relative +next/prev navigation). This test verifies that selecting ~:tab2~ from a +three-tab bar correctly sets the active tab. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test tabbar-select + "TabBar select activates the specified tab." + (let ((tb (make-tab-bar))) + (tab-bar-add tb :tab1 "One") + (tab-bar-add tb :tab2 "Two") + (tab-bar-select tb :tab2) + (is (eql (tab-bar-active tb) :tab2)))) +#+END_SRC + +** TabBar key handling test + +~tab-bar-handle-key~ maps keyboard events to navigation actions. A +~:right~ key event should advance; a ~:left~ key event should retreat. +This tests the bridge between the input event system and the TabBar +navigation API. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test tabbar-handle-key + "TabBar handle-key dispatches left/right." + (let ((tb (make-tab-bar))) + (tab-bar-add tb :tab1 "One") + (tab-bar-add tb :tab2 "Two") + (setf (tab-bar-active tb) :tab1) + (tab-bar-handle-key tb (make-key-event :key :right)) + (is (eql (tab-bar-active tb) :tab2)) + (tab-bar-handle-key tb (make-key-event :key :left)) + (is (eql (tab-bar-active tb) :tab1)))) +#+END_SRC + +** ScrollBox clamp boundary test + +Directly tests ~clamp-scroll~ by setting scroll offsets to invalid +values (negative and extremely large) and confirming they get clamped +back to 0. With no children, content size is 0 so the max scroll is +also 0 — this exercises the degenerate case. + +#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp +(test scrollbox-scroll-clamp + "ScrollBox clamp prevents scrolling past bounds." + (let ((sb (make-scroll-box :scroll-y 5 :scroll-x 3))) + (setf (scroll-box-scroll-y sb) -1) + (clamp-scroll sb) + (is (= (scroll-box-scroll-y sb) 0) "clamps below 0") + (setf (scroll-box-scroll-y sb) 1000000) + (clamp-scroll sb) + (is (= (scroll-box-scroll-y sb) 0) "clamps above max (no children = 0 content)"))) +#+END_SRC diff --git a/org/select.org b/org/select.org index d9bb177..d5b93ac 100644 --- a/org/select.org +++ b/org/select.org @@ -40,20 +40,39 @@ fallback, and category grouping with dimmed headers. ** Tests +*** Test package and suite setup + +The test file uses FiveAM. The ~defpackage~ pulls in all the dependencies needed +by the select widget tests — FiveAM itself, the backend/box/layout/input infrastructure, +and the ~cl-tty.select~ package under test. ~run-tests~ is the entry point for +CI and interactive use. + #+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (defpackage :cl-tty-select-test (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select) (:export #:run-tests)) (in-package #:cl-tty-select-test) +#+END_SRC +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (def-suite select-suite :description "Select widget tests") (in-suite select-suite) +#+END_SRC +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (defun run-tests () (let ((result (run 'select-suite))) (fiveam:explain! result) (uiop:quit 0))) +#+END_SRC +*** test select-creates + +Verifies that a select widget can be constructed with default values. The +~selected-index~ should start at 0, and both ~options~ and ~filter~ should +be nil. This establishes the baseline contract for the default constructor. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-creates "A Select can be created with defaults." (let ((sel (make-select))) @@ -61,13 +80,29 @@ fallback, and category grouping with dimmed headers. (is-false (select-options sel)) (is-false (select-filter sel)) (is (= (select-selected-index sel) 0)))) +#+END_SRC +*** test select-with-options + +Ensures that passing ~:options~ to ~make-select~ stores them correctly. The +length check is the simplest invariant — two options in, two options out. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-with-options "A Select stores options." (let ((sel (make-select :options '((:title "Red" :value :red) (:title "Blue" :value :blue))))) (is (= (length (select-options sel)) 2)))) +#+END_SRC +*** test select-filtered-exact + +Tests case-insensitive substring filtering: setting filter to ~\"bl\"~ should +match \"Blue\" but not \"Red\" or \"Green\". The return value is an alist of +~(display-index original-index option)~, so we dig into the third element +to check the ~:value~. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-filtered-exact "Filter returns case-insensitive substring matches." (let ((sel (make-select @@ -78,7 +113,15 @@ fallback, and category grouping with dimmed headers. (let ((filtered (select-filtered-options sel))) (is (= (length filtered) 1)) (is (eql (getf (third (first filtered)) :value) :blue))))) +#+END_SRC +*** test select-filtered-all + +When the filter is nil ~select-filtered-options~ must return every option +unchanged. This is the unfiltered/identity case and the most common state +when the user hasn't typed anything. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-filtered-all "Nil filter returns all options." (let ((sel (make-select @@ -86,7 +129,15 @@ fallback, and category grouping with dimmed headers. (:title "Blue" :value :blue))))) (let ((filtered (select-filtered-options sel))) (is (= (length filtered) 2))))) +#+END_SRC +*** test select-navigation + +Exercises ~select-next~ and ~select-prev~ through a three-item list, +confirming that forward and backward movement works and that both directions +wrap around at list boundaries. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-navigation "Select-next and select-prev navigate through options." (let ((sel (make-select @@ -102,7 +153,16 @@ fallback, and category grouping with dimmed headers. (is (= (select-selected-index sel) 0) "wraps forward") (select-prev sel) (is (= (select-selected-index sel) 2) "wraps backward"))) +#+END_SRC +*** test select-navigation-skips-categories + +Category headers (options with ~:category t~) should be invisible to +navigation — ~select-next~ and ~select-prev~ skip over them. This test +sets up a list with two category headers interleaved and verifies they +are transparent to movement. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-navigation-skips-categories "Navigation skips category header options." (let ((sel (make-select @@ -118,7 +178,15 @@ fallback, and category grouping with dimmed headers. (is (= (select-selected-index sel) 2)) (select-next sel) (is (= (select-selected-index sel) 4) "skipped category header at 3"))) +#+END_SRC +*** test select-handle-key + +Validates that ~select-handle-key~ dispatches correctly: Down moves forward, +Up moves backward, and Enter invokes the ~on-select~ callback with the +currently highlighted option's plist. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-handle-key "Select handle-key dispatches navigation and selection." (let* ((result (list nil)) @@ -131,7 +199,15 @@ fallback, and category grouping with dimmed headers. (is (= (select-selected-index sel) 0)) (select-handle-key sel (make-key-event :key :enter)) (is (eql (car result) :a)))) +#+END_SRC +*** test select-handle-key-ctrl + +Ctrl+N and Ctrl+P are Emacs-compatible alternatives to Down/Up. They must +produce identical navigation behavior. This test confirms the control-key +dispatch paths. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-handle-key-ctrl "Ctrl+N and Ctrl+P navigate like down/up." (let ((sel (make-select @@ -140,7 +216,15 @@ fallback, and category grouping with dimmed headers. (is (= (select-selected-index sel) 1)) (select-handle-key sel (make-key-event :key :p :ctrl t)) (is (= (select-selected-index sel) 0)))) +#+END_SRC +*** test select-visible-count + +~select-visible-options~ should never return more items than the viewport +height. This test creates 20 options, sets the layout height to 5, and +asserts the visible subset fits within that constraint. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-visible-count "Visible options respects viewport height." (let* ((ln (make-layout-node)) @@ -150,7 +234,15 @@ fallback, and category grouping with dimmed headers. (setf (layout-node-height ln) 5) (let ((visible (select-visible-options sel))) (is (<= (length visible) 5))))) +#+END_SRC +*** test select-fuzzy-fallback + +When exact substring matching fails, the filter falls back to character-set +Jaccard similarity. ~\"nrd\"~ should match ~\"Nord\"~ because the character +overlap (n, o, r, d → 3 of 4) exceeds the 0.3 threshold. + +#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp (test select-fuzzy-fallback "Fuzzy filter catches near-misses." (let ((sel (make-select @@ -167,7 +259,13 @@ fallback, and category grouping with dimmed headers. ** Package -#+BEGIN_SRC lisp +The ~cl-tty.select~ package depends on the backend, box model, layout, +and input subsystems. The exported symbols cover the public API: the +~select~ class, constructor, accessors, filtering, navigation, key +handling, rendering, and the fuzzy matching predicate (exposed for +testing and extensibility). + +#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp (defpackage :cl-tty.select (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export @@ -185,12 +283,16 @@ fallback, and category grouping with dimmed headers. ** Select class -~select~ inherits from ~dirty-mixin~. Options are stored as a list of -plists. ~selected-index~ tracks the currently highlighted option. -~filter~ is a string (or nil for unfiltered). ~on-select~ is a callback -receiving the selected option plist. +*** defclass select -#+BEGIN_SRC lisp +~select~ inherits from ~dirty-mixin~ so the rendering layer knows when +the widget state has changed (after navigation, filter updates, etc.). +Options are stored as a list of plists. ~selected-index~ tracks the +currently highlighted option. ~filter~ is a string (or nil for +unfiltered). ~on-select~ is a callback receiving the selected option +plist. ~layout-node~ positions the widget in the window. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (in-package #:cl-tty.select) (defclass select (dirty-mixin) @@ -204,7 +306,15 @@ receiving the selected option plist. :accessor select-on-select) (layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node))) +#+END_SRC +*** defun make-select + +A convenience constructor that wraps ~make-instance~ with keyword +arguments. Defaults to nil for all optional parameters, matching the +~defclass~ initforms. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun make-select (&key options filter on-select) (make-instance 'select :options (or options nil) @@ -214,16 +324,21 @@ receiving the selected option plist. ** Component protocol -~component-layout-node~ returns the layout node so the layout engine -can position the select widget. +*** defmethod component-layout-node -#+BEGIN_SRC lisp +The layout engine needs a uniform way to access a component's position. +~component-layout-node~ is part of the component protocol; this method +for ~select~ simply delegates to the ~select-layout-node~ accessor. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defmethod component-layout-node ((sel select)) (select-layout-node sel)) #+END_SRC ** Option filtering: substring match +*** defun select-filtered-options + ~select-filtered-options~ returns options whose ~:title~ contains the filter string (case-insensitive). When ~filter~ is nil, returns all options. Category headers are NOT filtered out — they remain in the @@ -232,7 +347,12 @@ list so the user can see category context. The function returns an alist of ~(filtered-index original-index option)~ to preserve the original index for selection tracking. -#+BEGIN_SRC lisp +Internally, the filter first checks for exact substring containment via +~search~. If no option matches that way, it falls through to the +character-set ~fuzzy-match-p~ predicate. Category headers short-circuit +so they always pass through the filter. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun select-filtered-options (sel) "Return list of options matching the current filter, in display order. Each item: (display-index original-index option-plist)." @@ -243,27 +363,29 @@ to preserve the original index for selection tracking. (let ((lower (string-downcase filter))) (remove-if-not (lambda (opt) - (when (getf opt :category) - (return-from select-filtered-options all-options)) - (let ((title (string-downcase (getf opt :title)))) - (or (search lower title) - (fuzzy-match-p lower title)))) + (or (getf opt :category) + (let ((title (string-downcase (getf opt :title)))) + (or (search lower title) + (fuzzy-match-p lower title))))) all-options))))) (loop for opt in filtered for i from 0 collect (list i (position opt all-options) opt)))) #+END_SRC -** Fuzzy matching: trigram Jaccard similarity +** Fuzzy matching: character-set Jaccard similarity -~trigram-score~ converts a string into a set of 3-character sliding -window n-grams. ~fuzzy-match-p~ returns T if the Jaccard similarity -between the query trigrams and the target trigrams exceeds 0.3. +*** defun string-trigrams -Trigrams capture character-level similarity without requiring exact -substring matches. "nrd" matches "Nord" because both contain ~nor~, -~ord~ and ~nrd~ contributes ~nrd~ — the overlap is enough to exceed -the threshold. +Converts a string into a set of 3-character sliding window n-grams. +Short strings (fewer than 3 characters) return the whole string as a +single trigram. Duplicates are removed so the set can be used for +Jaccard intersection/union calculations. + +Note: the running tangle does not call this function directly — the +simpler character-set ~fuzzy-match-p~ is used instead. Trigram +matching is retained here as a documented alternative for future +experimentation. #+BEGIN_SRC lisp (defun string-trigrams (str) @@ -275,7 +397,17 @@ the threshold. (loop for i from 0 to (- (length s) 3) do (push (subseq s i (+ i 3)) result)) (delete-duplicates result :test #'string=))) +#+END_SRC +*** defun trigram-score + +Jaccard similarity of two trigram sets: the size of the intersection +divided by the size of the union. A score of 1.0 means identical sets; +0.0 means no overlap. This is used by ~fuzzy-match-p~ if trigram mode +is enabled (currently unused in the default filter path — see +~string-trigrams~). + +#+BEGIN_SRC lisp (defun trigram-score (query target) "Jaccard similarity of trigram sets: |intersection| / |union|." (let* ((q-trigrams (string-trigrams query)) @@ -283,7 +415,16 @@ the threshold. (intersection (length (intersection q-trigrams t-trigrams :test #'string=))) (union (length (union q-trigrams t-trigrams :test #'string=)))) (if (zerop union) 0.0 (/ (float intersection) union)))) +#+END_SRC +*** defun fuzzy-match-p + +Returns T if the Jaccard similarity between the character sets of the +query and target exceeds 0.3. The character-set approach is simpler +and cheaper than trigrams while still catching common typos and +near-misses like ~\"nrd\"~ for ~\"Nord\"~. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun fuzzy-match-p (query target) "T if character-set Jaccard similarity exceeds threshold (0.3)." (let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list))) @@ -295,12 +436,14 @@ the threshold. ** Navigation -~select-next~ and ~select-prev~ move the selection forward/backward -through the filtered options list. They skip category headers (options -with ~:category t~). The selection wraps at list boundaries. -~select-clamp-index~ ensures the index is valid after filtering changes. +*** defun select-clamp-index -#+BEGIN_SRC lisp +After the filter changes (user types or clears input), the selected +index may point beyond the filtered list. ~select-clamp-index~ ensures +the index stays within valid bounds. If the list is empty the index +resets to 0. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun select-clamp-index (sel) "Ensure selected-index is valid. Wraps if empty." (let* ((filtered (select-filtered-options sel)) @@ -309,7 +452,16 @@ with ~:category t~). The selection wraps at list boundaries. (setf (select-selected-index sel) 0) (setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count))))))) +#+END_SRC +*** defun select-next + +Moves the selection forward to the next non-category option. Iterates +through the filtered list starting from the current index, wrapping +around at the end. Each candidate is checked for ~:category t~ and +skipped. Marks the widget dirty so the render pass picks up the change. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun select-next (sel) "Move selection to next non-category option. Wraps at end." (let* ((filtered (select-filtered-options sel)) @@ -323,7 +475,15 @@ with ~:category t~). The selection wraps at list boundaries. do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) +#+END_SRC +*** defun select-prev + +Moves the selection backward to the previous non-category option. +Mirrors ~select-next~ but decrements the index (with modular arithmetic +for wrap-around). Category headers are skipped identically. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun select-prev (sel) "Move selection to previous non-category option. Wraps at start." (let* ((filtered (select-filtered-options sel)) @@ -341,15 +501,18 @@ with ~:category t~). The selection wraps at list boundaries. ** Key event handler -~select-handle-key~ dispatches keyboard events: -- Down, Ctrl+N → select-next -- Up, Ctrl+P → select-prev -- Enter → on-select callback with the selected option -- Esc → return NIL (caller can dismiss) +*** defun select-handle-key -Returns T if the key was handled, NIL otherwise. +Dispatches keyboard events: +- Down, Ctrl+N → ~select-next~ +- Up, Ctrl+P → ~select-prev~ +- Enter → ~on-select~ callback with the selected option +- Esc → return NIL (caller can dismiss the widget) -#+BEGIN_SRC lisp +Returns T if the key was handled (consumed), NIL otherwise so the +caller knows not to propagate the event further. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun select-handle-key (sel event) "Handle a key-event. Returns T if handled." (let ((key (key-event-key event)) @@ -374,11 +537,15 @@ Returns T if the key was handled, NIL otherwise. ** Visible options (viewport culling) -~select-visible-options~ returns only the filtered options that fit -within the widget's available height. Each option occupies 1 row. -This prevents rendering hundreds of items when the viewport shows 10. +*** defun select-visible-options -#+BEGIN_SRC lisp +Returns only the filtered options that fit within the widget's +available height. Each option occupies 1 row. This prevents rendering +hundreds of items when the viewport shows only 10. The window is +centered around the currently selected index so the user always sees +context around their cursor. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defun select-visible-options (sel) "Return filtered options that fit within the viewport." (let* ((ln (select-layout-node sel)) @@ -394,12 +561,15 @@ This prevents rendering hundreds of items when the viewport shows 10. ** Rendering -~render~ draws each visible option on its own line. The selected -option is highlighted with ~:accent~ foreground and ~:background-element~ -background. Category headers are rendered dimmed (~:text-muted~) and -not selectable (visually distinct). +*** defmethod render -#+BEGIN_SRC lisp +Draws each visible option on its own line. The selected option is +highlighted with ~:accent~ foreground and ~:background-element~ +background. Category headers are rendered dimmed (~:text-muted~) and +visually distinct from selectable items. Long titles are truncated with +an ellipsis character to fit the viewport width. + +#+BEGIN_SRC lisp :tangle ../src/components/select.lisp (defmethod render ((sel select) backend) (let* ((ln (select-layout-node sel)) (x (if ln (layout-node-x ln) 0)) @@ -427,120 +597,3 @@ not selectable (visually distinct). (incf y 1))) (values))) #+END_SRC - -** Combined tangle block - -#+BEGIN_SRC lisp :tangle ../src/components/select.lisp -(in-package #:cl-tty.select) - -(defclass select (dirty-mixin) - ((options :initform nil :initarg :options :accessor select-options :type list) - (filter :initform nil :initarg :filter :accessor select-filter :type (or string null)) - (selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum) - (on-select :initform nil :initarg :on-select :accessor select-on-select) - (layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node))) - -(defun make-select (&key options filter on-select) - (make-instance 'select :options (or options nil) :filter filter :on-select on-select)) - -(defmethod component-layout-node ((sel select)) (select-layout-node sel)) - -(defun select-filtered-options (sel) - (let* ((filter (select-filter sel)) (all-options (select-options sel)) - (filtered (if (null filter) all-options - (let ((lower (string-downcase filter))) - (remove-if-not - (lambda (opt) - (or (getf opt :category) - (let ((title (string-downcase (getf opt :title)))) - (or (search lower title) (fuzzy-match-p lower title))))) - all-options))))) - (loop for opt in filtered for i from 0 - collect (list i (position opt all-options) opt)))) - -(defun fuzzy-match-p (query target) - (let* ((q (remove-duplicates (coerce (string-downcase query) 'list))) - (tg (remove-duplicates (coerce (string-downcase target) 'list))) - (intersection (length (intersection q tg))) - (union (length (union q tg)))) - (if (zerop union) nil (> (/ (float intersection) union) 0.3)))) - -(defun select-clamp-index (sel) - (let* ((filtered (select-filtered-options sel)) (count (length filtered))) - (if (zerop count) (setf (select-selected-index sel) 0) - (setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count))))))) - -(defun select-next (sel) - (let* ((filtered (select-filtered-options sel)) (count (length filtered)) - (current (select-selected-index sel))) - (when (plusp count) - (loop for i from 1 below count - for idx = (mod (+ current i) count) - for opt = (third (nth idx filtered)) - when (not (getf opt :category)) - do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) - -(defun select-prev (sel) - (let* ((filtered (select-filtered-options sel)) (count (length filtered)) - (current (select-selected-index sel))) - (when (plusp count) - (loop for i from 1 below count - for idx = (mod (- current i) count) - for opt = (third (nth idx filtered)) - when (not (getf opt :category)) - do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) - -(defun select-handle-key (sel event) - (let ((key (key-event-key event)) (ctrl (key-event-ctrl event))) - (cond - ((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t) - ((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t) - ((eql key :enter) - (let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel)) - (item (when (< idx (length filtered)) (third (nth idx filtered))))) - (when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t)) - ((eql key :escape) nil) (t nil)))) - -(defun select-visible-options (sel) - (let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80)) - (filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel)) - (half (floor (1- height) 2)) (start (max 0 (- sel-idx half))) - (end (min (length filtered) (+ start height)))) - (subseq filtered start end))) - -(defmethod render ((sel select) backend) - (let* ((ln (select-layout-node sel)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (visible (select-visible-options sel)) (sel-idx (select-selected-index sel))) - (dolist (item visible) - (let* ((display-idx (first item)) (option (third item)) - (title (getf option :title)) (cat (getf option :category)) - (selected (eql display-idx sel-idx)) - (display (if (> (length title) (1- w)) - (concatenate 'string (subseq title 0 (1- w)) "…") title))) - (cond (cat (draw-text backend x y display :text-muted nil)) - (selected - (draw-rect backend x y w 1 :bg :accent) - (draw-text backend x y display :background :accent)) - (t (draw-text backend x y display nil nil))) - (incf y 1))) - (values))) -#+END_SRC - -#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp -(defpackage :cl-tty.select - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export - #:select #:make-select - #:select-options #:select-filter - #:select-selected-index #:select-on-select - #:select-layout-node - #:select-filtered-options - #:select-next #:select-prev - #:select-visible-options - #:select-handle-key - #:render - #:fuzzy-match-p)) -#+END_SRC diff --git a/org/slot.org b/org/slot.org index d3e28d7..5f5e0e0 100644 --- a/org/slot.org +++ b/org/slot.org @@ -1,6 +1,7 @@ #+TITLE: Plugin / Slot System (v0.11.0) #+DATE: 2026-05-11 #+AUTHOR: Amr Gharbeia / Hermes +#+STARTUP: content * Overview @@ -12,20 +13,44 @@ pieces without tight coupling — a sidebar, a logo, a prompt area, etc. ** Contract -- ~defslot name &key order render-fn~ — register a render function for a slot +- ~defslot name &key order render-fn mode~ — register a render function for a slot - ~slot-render slot-name &rest args~ — call all registered render-fns, return combined output - ~slot-p slot-name~ — check if a slot has registrations - ~clear-slot slot-name~ — remove all registrations for a slot - ~list-slots~ — return all slot names with registrations -Slot modes: -- ~:stack~ (default) — render all registered functions in ~:order~ sequence -- ~:replace~ — last registration wins, earlier ones are discarded -- ~:single-winner~ — first matching registration wins, rest are skipped +** Slot modes -** Implementation +- ~:stack~ (default) — render all registered functions in ~:order~ sequence. + Each ~defslot~ adds to the list. ~slot-render~ calls every function and + returns a list of results. Use this for composable slots where multiple + plugins contribute content (e.g., toolbar buttons, status bar segments). -#+BEGIN_SRC lisp :tangle ../src/components/slot-package.lisp :noweb no +- ~:replace~ — last registration wins, previous ones are discarded. + Each ~defslot~ replaces the slot's entire entry list with the new + registration. ~slot-render~ calls only the most recently registered + function. Use this for exclusive slots where only one renderer should + be active at a time (e.g., main content area, active panel). + +- ~:single-winner~ — first registration wins, subsequent ones are ignored. + Once a slot has an entry, further ~defslot~ calls for the same slot are + no-ops. ~slot-render~ calls only the first (lowest-order) registered + function. Use this for slots where the first plugin to register should + own the spot (e.g., logo area, command palette). + +The mode is set on the first ~defslot~ call for a slot. Subsequent calls +for the same slot ignore the ~:mode~ argument and use the established +mode — this prevents confusion when multiple plugins register into the +same slot with conflicting mode specifications. + +* Implementation + +** Package + +The package provides the public API and exports all slot system symbols. +Clients :use this package or refer to symbols qualified. + +#+BEGIN_SRC lisp :tangle ../src/components/slot-package.lisp (defpackage :cl-tty.slot (:use :cl) (:export @@ -37,61 +62,247 @@ Slot modes: #:*slots*)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no +** Slot Storage: *slots* + +The central registry is a hash table keyed by slot name (strings, for +case-insensitive lookup via ~equal~). Each value is a plist: + +- ~:mode~ — the slot's mode keyword (~:stack~, ~:replace~, ~:single-winner~) +- ~:entries~ — list of ~(order . render-fn)~ cons cells, sorted by order + +The ~:test #'equal~ ensures that ~:sidebar~ and ~"sidebar"~ map to the +same key. + +#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp (in-package :cl-tty.slot) -(defvar *slots* (make-hash-table :test #'equal) - "Hash table mapping slot name (string) -> list of (order . render-fn) pairs.") +(defvar *slots* (make-hash-table :test 'equal) + "Hash table mapping slot name (string) -> plist of slot data. +Each entry: (:mode :entries <(order . render-fn) list>).") +#+END_SRC -(defun defslot (name &key (order 0) render-fn) +** defslot: Register a Render Function + +~defslot~ inserts a new ~(order . render-fn)~ entry into the slot's +entry list. The behavior depends on the slot's mode, which is set on +the first call and frozen for subsequent calls: + +- ~:stack~ — merge into existing entries, sorted by order +- ~:replace~ — clear all previous entries, keep only the new one +- ~:single-winner~ — no-op if the slot already has entries + +The ~render-fn~ itself is returned so callers can use it inline. + +The mode parameter is validated on first call via ~assert~ and then +frozen for subsequent calls. This prevents a later registration from +changing the slot's semantics out from under earlier registrations. + +#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp +(defun defslot (name &key (order 0) render-fn (mode :stack)) (let* ((key (string name)) - (entries (gethash key *slots*))) - (if (null entries) - (setf (gethash key *slots*) (list (cons order render-fn))) - (setf (gethash key *slots*) - (sort (cons (cons order render-fn) entries) #'< :key #'car)))) + (slot (gethash key *slots*))) + (if (null slot) + ;; First registration — validate and set mode, create entry + (progn + (assert (member mode '(:stack :replace :single-winner)) () + "Invalid slot mode: ~S (use :stack, :replace, or :single-winner)" + mode) + (setf (gethash key *slots*) + (list :mode mode + :entries (list (cons order render-fn))))) + ;; Existing slot — respect frozen mode + (let ((entries (getf slot :entries))) + (ecase (getf slot :mode) + (:stack + (setf (getf slot :entries) + (sort (cons (cons order render-fn) entries) + #'< :key #'car))) + (:replace + (setf (getf slot :entries) + (list (cons order render-fn)))) + (:single-winner + ;; First registration already present — no-op + (values)))))) render-fn) +#+END_SRC +** slot-render: Invoke Render Functions Per Mode + +~slot-render~ dispatches on the slot's mode: + +- ~:stack~ — call every non-nil render function in order, return a list + of results. This is the most flexible mode, supporting multiple + contributors per slot. + +- ~:replace~ — call only the single registered function (the last one + registered, since :replace clears earlier entries). Returns a single + value, not a list. + +- ~:single-winner~ — call only the first registered function (lowest + order). Subsequent registrations were silently dropped during defslot. + +Returns ~nil~ if the slot has no registrations or if the handler is nil. + +#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp (defun slot-render (slot-name &rest args) - (let ((entries (gethash (string slot-name) *slots*))) - (when entries - (mapcar (lambda (entry) (apply (cdr entry) args)) entries)))) + (let ((slot (gethash (string slot-name) *slots*))) + (when slot + (let ((mode (getf slot :mode)) + (entries (getf slot :entries))) + (ecase mode + (:stack + (mapcar (lambda (entry) + (let ((fn (cdr entry))) + (when fn (apply fn args)))) + entries)) + (:replace + (let ((fn (cdar (last entries)))) + (when fn (apply fn args)))) + (:single-winner + (let ((fn (cdar entries))) + (when fn (apply fn args))))))))) +#+END_SRC +** slot-p: Check Slot Existence + +Uses ~nth-value 1~ of ~gethash~ which returns ~t~ if the key is +present (even if the value is ~nil~) or ~nil~ if absent. This is the +canonical Common Lisp idiom for testing hash-table membership. + +#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp (defun slot-p (slot-name) (nth-value 1 (gethash (string slot-name) *slots*))) +#+END_SRC +** clear-slot: Remove All Registrations + +Calls ~remhash~ to delete the slot's entry from the hash table +entirely. After this call ~slot-p~ returns false and ~slot-render~ +returns nil for the given slot name. + +#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp (defun clear-slot (slot-name) (remhash (string slot-name) *slots*)) +#+END_SRC +** list-slots: Enumerate Registered Slots + +Iterates over all hash keys in ~*slots*~ and returns them as a list. +Only slots that have been registered (i.e. have at least one entry) +appear in the result. + +#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp (defun list-slots () (loop for key being the hash-keys of *slots* collect key)) #+END_SRC -#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp :noweb no +** Tests + +The test suite uses FiveAM and exercises each public function, +including mode-specific behavior. + +*** Test Package and Suite + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp (defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam)) (in-package :cl-tty-slot-test) (def-suite slot-suite :description "Slot system tests") (in-suite slot-suite) +#+END_SRC +*** defslot-register: Registering a slot makes it visible + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp (def-test defslot-register () (clear-slot :test-slot) (defslot :test-slot :order 1 :render-fn (lambda () "hello")) (is-true (slot-p :test-slot))) +#+END_SRC +*** slot-render-calls: Stack mode calls all functions in order + +Verifies that ~:stack~ mode preserves multiple registrations and calls +them in ascending order sequence. + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp (def-test slot-render-calls () (clear-slot :test-slot) (defslot :test-slot :order 1 :render-fn (lambda () "a")) (defslot :test-slot :order 2 :render-fn (lambda () "b")) (is (equal '("a" "b") (slot-render :test-slot)))) +#+END_SRC +*** slot-render-empty: Unregistered slot returns nil + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp (def-test slot-render-empty () (clear-slot :ghost) (is-false (slot-render :ghost))) +#+END_SRC +*** clear-slot-removes: Clearing a slot makes it absent + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp (def-test clear-slot-removes () (clear-slot :test-slot) (defslot :test-slot :order 1 :render-fn (lambda () "x")) (clear-slot :test-slot) (is-false (slot-p :test-slot))) #+END_SRC + +*** stack-mode-multiple-entries: Stack keeps all registrations + +Verifies that ~:stack~ mode (default) accumulates entries across +multiple ~defslot~ calls. + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +(def-test stack-mode-multiple-entries () + (clear-slot :stack-test) + (defslot :stack-test :order 1 :render-fn (lambda () "first")) + (defslot :stack-test :order 2 :render-fn (lambda () "second")) + (defslot :stack-test :order 3 :render-fn (lambda () "third")) + (is (equal '("first" "second" "third") (slot-render :stack-test)))) +#+END_SRC + +*** replace-mode-last-wins: Replace keeps only the last registration + +Verifies that ~:replace~ mode discards previous entries on each new +~defslot~ call. + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +(def-test replace-mode-last-wins () + (clear-slot :replace-test) + (defslot :replace-test :mode :replace :order 1 :render-fn (lambda () "old")) + (defslot :replace-test :mode :replace :order 2 :render-fn (lambda () "new")) + (is (equal "new" (slot-render :replace-test)))) +#+END_SRC + +*** single-winner-mode-first-wins: Single-winner keeps only the first + +Verifies that ~:single-winner~ mode ignores subsequent registrations. + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +(def-test single-winner-mode-first-wins () + (clear-slot :winner-test) + (defslot :winner-test :mode :single-winner :order 1 + :render-fn (lambda () "alpha")) + (defslot :winner-test :mode :single-winner :order 2 + :render-fn (lambda () "beta")) + (is (equal "alpha" (slot-render :winner-test)))) +#+END_SRC + +*** clear-slot-removes-mode: Clearing resets mode, allowing new mode + +Verifies that clearing a slot removes the mode lock, so a subsequent +~defslot~ can set a new mode. + +#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp +(def-test clear-slot-removes-mode () + (clear-slot :mode-test) + (defslot :mode-test :mode :replace :render-fn (lambda () "only")) + (clear-slot :mode-test) + (defslot :mode-test :mode :stack :render-fn (lambda () "fresh")) + (is-true (slot-p :mode-test)) + (is (equal '("fresh") (slot-render :mode-test)))) +#+END_SRC diff --git a/org/tabbar.org b/org/tabbar.org new file mode 100644 index 0000000..b23e377 --- /dev/null +++ b/org/tabbar.org @@ -0,0 +1,219 @@ +#+TITLE: TabBar +#+STARTUP: content +#+FILETAGS: :cl-tty:container: + +* Overview + +TabBar handles horizontal tab navigation with keyboard support. +Tabs are rendered as labeled items; the active tab is highlighted. + +~tab-bar~ inherits ~dirty-mixin~ and implements the component protocol +(~render~, ~component-layout-node~) so it integrates with the rendering +pipeline and layout engine. + +** Contract + +~(tab-bar &key tabs active-tab)~ → tab-bar + TABS is a list of ~(id title)~ plists. + +~(tab-bar-active tb)~ / ~(setf tab-bar-active)~ — currently active tab id. +~(tab-bar-tabs tb)~ — list of tab plists. +~(tab-bar-add tb id title)~ — add a tab. Returns the tab id. + +~(render ((tb tab-bar) backend))~ — renders tab row, active tab + highlighted, inactive tabs dimmed. + +* Implementation + +** Package declaration + +All TabBar code lives in the ~cl-tty.container~ package alongside the +other container components (scrollbox, box, slot, etc.). This keeps +the symbol namespace clean and avoids accidental collisions with +user-level code. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(in-package #:cl-tty.container) +#+END_SRC + +** TabBar class + +~tab-bar~ stores a list of tab plists ~((:id :tab1 :title "One") ...)~ +and the currently active tab id. It inherits from ~dirty-mixin~ so that +any mutation (adding a tab, switching tabs) automatically marks the +component for re-render. A layout node holds its geometry; the +~focusable~ slot allows the keyboard navigation system to discover it. + +The ~tabs~ slot is a simple plist list rather than a hash table or +alist because the total number of tabs in a UI is typically small +(< 20) and we need ordered iteration for rendering. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defclass tab-bar (dirty-mixin) + ((tabs :initform nil :initarg :tabs + :accessor tab-bar-tabs :type list) + (active :initform nil :initarg :active + :accessor tab-bar-active) + (layout-node :initform (make-layout-node) :accessor tab-bar-layout-node) + (focusable :initform t :accessor tab-bar-focusable))) +#+END_SRC + +** make-tab-bar constructor + +Convenience constructor that forwards keyword arguments to +~make-instance~. Using a dedicated function instead of inlining +~make-instance~ everywhere gives us a single place to add +defaulting, validation, or initialization hooks in the future. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defun make-tab-bar (&key tabs active) + (make-instance 'tab-bar :tabs (or tabs nil) :active active)) +#+END_SRC + +** tab-bar-add: adding tabs + +~tab-bar-add~ appends a new tab plist to the end of the tab list. +The callers supply both an ~id~ (for programmatic selection) and a +~title~ (for display). If no tab is currently active, the newly added +tab becomes active automatically — this ensures there is always a +sensible default when the first tab is created. Returns the ~id~ so +callers can chain or store it. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defun tab-bar-add (tb id title) + "Add a tab with ID and TITLE. Sets as active if first tab." + (setf (tab-bar-tabs tb) + (nconc (tab-bar-tabs tb) (list (list :id id :title title)))) + (unless (tab-bar-active tb) + (setf (tab-bar-active tb) id)) + id) +#+END_SRC + +** component-layout-node protocol + +Returns the layout node so the layout engine can position and size +the tab bar within its parent. Every component that participates in +automatic layout must implement this method. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defmethod component-layout-node ((tb tab-bar)) + (tab-bar-layout-node tb)) +#+END_SRC + +** tab-bar-next: cycling forward + +~tab-bar-next~ moves the active cursor to the next tab in the list, +wrapping around from the last tab to the first (~mod~ arithmetic). +It calls ~mark-dirty~ so the rendering pass picks up the change. + +The lookup strategy — mapcar ids, position, mod — is O(n) but +acceptable since tab lists are small. A hash-based index would be +premature optimization at this scale. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defun tab-bar-next (tb) + "Move to next tab." + (let* ((tabs (tab-bar-tabs tb)) + (current (tab-bar-active tb)) + (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) + (pos (position current ids))) + (when pos + (let ((next (nth (mod (1+ pos) (length ids)) ids))) + (setf (tab-bar-active tb) next) + (mark-dirty tb))))) +#+END_SRC + +** tab-bar-prev: cycling backward + +Mirror of ~tab-bar-next~; decrements the position index instead of +incrementing it. ~mod~ handles negative wrap-around correctly in +Common Lisp (returns a non-negative remainder), so ~(mod (1- 0) 3)~ +produces 2 rather than −1. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defun tab-bar-prev (tb) + "Move to previous tab." + (let* ((tabs (tab-bar-tabs tb)) + (current (tab-bar-active tb)) + (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) + (pos (position current ids))) + (when pos + (let ((prev (nth (mod (1- pos) (length ids)) ids))) + (setf (tab-bar-active tb) prev) + (mark-dirty tb))))) +#+END_SRC + +** tab-bar-select: direct tab selection + +~tab-bar-select~ sets the active tab directly by id, bypassing the +cyclic navigation. This is used when a user clicks a tab (via mouse +binding), when a programmatic action needs to switch views, or when +activating a tab from outside the keyboard flow. Always marks dirty. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defun tab-bar-select (tb id) + "Select a tab by ID." + (setf (tab-bar-active tb) id) + (mark-dirty tb)) +#+END_SRC + +** tab-bar-handle-key: keyboard dispatch + +Dispatches key events for tab navigation. Left arrow goes to the +previous tab, right arrow to the next. Returns ~t~ when the key was +consumed and ~nil~ otherwise, which lets the keybinding system fall +through to other handlers — important for composable UIs where a tab +bar lives alongside other focusable elements. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defun tab-bar-handle-key (tb event) + "Handle a key-event on a TabBar. Returns T if handled." + (case (key-event-key event) + (:left (tab-bar-prev tb) t) + (:right (tab-bar-next tb) t) + (t nil))) +#+END_SRC + +** render: drawing the tab row + +~render~ iterates the tab list and draws each one as ~[ Title ]~. +The active tab uses the ~:accent~ foreground color and +~:background-element~ background for visual prominence; inactive tabs +are rendered in ~:text-muted~. Tabs are separated by two spaces. + +Available width comes from the layout node. If the total tab width +exceeds the available space, tabs are truncated and an ellipsis +~...~ is drawn at the overflow point. This prevents the tab bar from +breaking the layout on narrow terminals. + +#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp +(defmethod render ((tb tab-bar) backend) + (let* ((ln (tab-bar-layout-node tb)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (active-id (tab-bar-active tb)) + (tabs (tab-bar-tabs tb)) + (x-pos x)) + (dolist (tab tabs) + (let* ((id (getf tab :id)) + (title (getf tab :title)) + (label (format nil " ~A " title)) + (label-len (length label)) + (is-active (eql id active-id)) + (fg (if is-active :accent :text-muted)) + (bg (if is-active :background-element nil))) + ;; Check if tab fits + (when (>= (+ x-pos label-len 2) (+ x w)) + (draw-text backend x-pos y "..." :text-muted nil) + (return)) + ;; Draw tab + (draw-text backend x-pos y label fg bg) + (incf x-pos (+ label-len 2)))) + (values))) +#+END_SRC + +* Tests + +TabBar tests are part of the combined scrollbox-tabbar test suite +defined in ~org/scrollbox.org~ (tangled to ~tests/scrollbox-tabbar-tests.lisp~). diff --git a/org/text-input.org b/org/text-input.org index 0d95004..f6c5615 100644 --- a/org/text-input.org +++ b/org/text-input.org @@ -31,6 +31,25 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, handles arbitrary interleaving of terminal output with input. - SBCL's ~defstruct~ generates keyword constructors by default — we use them directly without custom ~:constructor~ overrides. +- CSI sequences are parsed via a two-pass approach: first collect params + and terminator, then look up in tables. This separates concerns — the + byte-level parsing is distinct from the semantic mapping. +- The 50ms timeout on escape sequence detection resolves the classic + ambiguity between a lone Escape key press and the start of a CSI/SS3 + sequence. If a byte arrives within 50ms, it's an escape sequence; if + not, the user pressed Escape. +- UTF-8 decoding uses a direct bit-manipulation approach rather than a + table-driven decoder. For the terminal input use case (short sequences + of 2-4 bytes), the simpler code is both faster and more readable. +- ~key-event-code~ exists alongside ~key-event-key~ to carry the raw + character code. ~:key~ is a semantic keyword (:a, :enter, :up) while + ~:code~ is the numeric code point or byte value. This separation is + essential for printable character insertion — ~handle-text-input~ uses + ~key-event-code~ with ~code-char~, not ~key-event-key~ which is always + uppercased (and thus useless for case-sensitive insertion). +- The undo/redo system uses fill-pointer vectors as stacks, capped at 100 + entries. Oldest entries are evicted when the stack fills. This avoids + consing on every keystroke while bounding memory use. * Contract @@ -57,9 +76,10 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, ~with-raw-terminal &body body~ — macro. Save → set raw → body → restore (via ~unwind-protect~). -~read-raw-byte &key timeout~ → byte or NIL. +~read-raw-byte &key timeout~ → (values byte-or-nil reason). Read one byte from fd 0. Blocks indefinitely when timeout=NIL. - Returns NIL on timeout. Uses ~sb-posix:read~. + Returns (values byte NIL) on success, (values NIL :TIMEOUT) on timeout, + (values NIL :EOF) when stdin is closed or /dev/null. ~parse-csi-params~ → (values params final-byte raw-string). Read bytes from stdin until a final CSI byte (0x40-0x7E). @@ -70,14 +90,17 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, Converts button codes (0=left, 1=middle, 2=right, 32=motion) and tracks press vs release vs drag. -~%read-escape-sequence~ → key-event. - Called after reading ESC (0x1b). Dispatches: +~%read-escape-sequence~ → key-event or :eof. + Called after reading ESC (0x1b). Uses a 50ms timeout on the first + follow-up byte to resolve Escape ambiguity (lone Escape vs start of + CSI/SS3 sequence). Dispatches: + - timeout → :escape key event - ESC O X → SS3 (F1-F4) - ESC [ ... → CSI (cursors, function keys, mouse) - ESC ESC → Alt+Escape - ESC printable → Alt+letter -~%read-event &key timeout~ → key-event, mouse-event, or NIL. +~%read-event &key timeout~ → key-event, mouse-event, :eof, or NIL. Top-level reader. Handles: - Printable ASCII (0x20-0x7e) → key :A, :B, ..., :~ - Ctrl letters (0x01-0x1a) → :A with ctrl=T @@ -137,10 +160,1527 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, Registers a keymap. Each binding: ~(:ctrl+p . handler-fn)~. ~component-keymap component~ — generic (returns nil by default). -** Tests +* Package -#+BEGIN_SRC lisp -(in-package #:cl-tty-input-test) +** input-package.lisp + +The package uses ~:cl-tty.backend~ for backend protocol (draw-text, etc.), +~:cl-tty.box~ for dirty-mixin and rendering pipeline, +and ~:cl-tty.layout~ for layout-node. + +I export everything users of the input system need: key events, mouse events, +terminal raw mode, TextInput, Textarea, and the keybinding system. + +~save-terminal-state~, ~set-raw-mode~, ~restore-terminal-state~, and +~with-raw-terminal~ are declared in the export list for forward compatibility +— they belong in this module once implemented, and exporting them from the +start avoids package redefinition churn. The current system does not yet call +raw mode from within the input module; consumers manage raw mode themselves +via ~sb-posix~ directly. + +#+BEGIN_SRC lisp :tangle ../src/components/input-package.lisp +(defpackage :cl-tty.input + (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) + (:export + ;; Key events + #:key-event #:make-key-event + #:key-event-p #:key-event-key #:key-event-ctrl + #:key-event-alt #:key-event-shift #:key-event-code + #:key-event-raw #:key-event-text + ;; Mouse events + #:mouse-event #:make-mouse-event + #:mouse-event-p #:mouse-event-type #:mouse-event-button + #:mouse-event-x #:mouse-event-y + ;; Terminal raw mode + #:save-terminal-state #:set-raw-mode #:restore-terminal-state + #:with-raw-terminal + ;; Event reading + #:read-event + #:*terminal-resized-p* + ;; UTF-8 input support + #:utf8-decode + ;; TextInput + #:text-input #:make-text-input + #:text-input-value #:text-input-cursor + #:text-input-placeholder #:text-input-max-length + #:text-input-on-submit #:text-input-layout-node + #:handle-text-input #:render-text-input + ;; Textarea + #:textarea #:make-textarea + #:textarea-value #:textarea-cursor-row #:textarea-cursor-col + #:textarea-lines + #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack + #:textarea-layout-node + #:handle-textarea-input #:render-textarea + ;; Keybindings + #:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent + #:*keymaps* #:*chord-timeout* + #:defkeymap #:dispatch-key-event #:key-match-p + #:component-keymap)) +#+END_SRC + +* Input Reader Core + +This section contains all the terminal input reading machinery: +raw byte reads, escape sequence parsing, CSI sequence handling, +UTF-8 decoding, and the top-level event dispatch. + +All blocks tangle to ~../src/components/input.lisp~. The first block +includes the ~in-package~ form; subsequent blocks contain only the +individual definition. + +** Utility: %split-string + +A simple loop-based split. I avoid using ~split-sequence~ from Quicklisp +to keep dependencies minimal — the framework already depends on ~fiveam~ and +~sb-posix~, and adding another dep just for one function is wasteful. + +The loop collects subsequences between occurrences of SEPARATOR. The +~while pos~ guard prevents an empty trailing element. For an empty string, +this returns ~("")~ (one empty string), which is the correct behavior for +textarea line splitting — a blank document has one empty line. + +This is the first block tangling to input.lisp, so it includes the +~in-package~ form that all subsequent blocks share. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(in-package #:cl-tty.input) + +(defun %split-string (string separator) + "Split STRING at each occurrence of SEPARATOR. Returns list of strings." + (loop with start = 0 + for pos = (position separator string :start start) + collect (subseq string start pos) + while pos + do (setf start (1+ pos)))) +#+END_SRC + +** Global rendering variables + +~*current-backend*~ and ~*current-theme*~ are special variables set by the +application's main loop. Widget ~render~ methods use them to draw themselves. +Defining them here rather than in the rendering module keeps the dependency +clean — input widgets depend on rendering, not the other way around. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defvar *current-backend* nil + "The active backend used for rendering.") +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defvar *current-theme* nil + "The active theme used for semantic color resolution.") +#+END_SRC + +** Key Event Struct + +I chose ~defstruct~ over ~defclass~ for key events because structs give +inline accessors and value semantics. Every keystroke creates one, and +in the hot path (terminal parsing) we don't want CLOS dispatch overhead. + +Key observation about SBCL's ~defstruct~: it generates a keyword constructor +by default. ~(make-key-event :key :a :ctrl t)~ is valid out of the box. +I initially wrote a custom ~(:constructor ...)~ wrapper and spent hours +debugging argument mismatches — avoid that trap. + +The ~code~ slot carries the raw character code (or code point for UTF-8 +sequences). The ~raw~ slot carries the raw byte(s) as a string for debugging +or passthrough. The ~text~ slot is reserved for composed text input (IME). + +~key-event-key~ is always a keyword interned in the KEYWORD package, +uppercased. This means ~:a~ (not ~:A~) for the letter 'a', ~:enter~ for +Enter, ~:up~ for the up arrow. The uppercasing convention matches how the +Common Lisp reader interns keyword literals, so ~(eql (key-event-key e) +:a)~ works exactly as written. + +~key-event-code~ exists alongside ~key-event-key~ because the key keyword +loses information needed for character insertion: ~:a~ could be uppercase +or lowercase, but ~code~ preserves the actual code point. The +~handle-text-input~ function uses ~code-char~ on the code slot to get the +true character for insertion. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defstruct key-event + (key nil :type (or keyword null)) + (ctrl nil :type boolean) + (alt nil :type boolean) + (shift nil :type boolean) + (code nil :type (or fixnum null)) + (raw nil :type (or string null)) + (text nil :type (or string null))) +#+END_SRC + +** Mouse Event Struct + +Mouse events are a separate struct because they carry fundamentally +different data: button (left/middle/right/wheel), coordinates (x, y), +and event type (press/release/drag). Combining them with key-event +would waste slots and complicate accessor semantics. + +The mouse parser (~parse-sgr-mouse~) converts from the SGR extended +mouse protocol format (~ESC[ (length params) 1) (not (find terminator '(#\~ #\u)))) + (second params))) + (actual-modifier (when (> (length extended) 1) (second extended))) + (ctrl nil) (alt nil) (shift nil)) + (when modifier + (setf shift (logtest modifier 1) + alt (logtest modifier 2) + ctrl (logtest modifier 4))) + (when actual-modifier + (setf shift (or shift (logtest actual-modifier 1)) + alt (or alt (logtest actual-modifier 2)) + ctrl (or ctrl (logtest actual-modifier 4)))) + (if (eql terminator #\u) + (let ((code (first params))) + (make-key-event :key :codepoint :code code + :ctrl ctrl :alt alt :shift shift + :raw (string (code-char code)))) + (make-key-event :key (or key :unknown) + :ctrl ctrl :alt alt :shift shift + :raw (format nil "~C[~{~d~};~d~C" #\Esc params terminator))))) +#+END_SRC + +** Raw byte reader + +~read-raw-byte~ is the lowest-level I/O function in the input system. +It reads exactly one byte from file descriptor 0 (stdin) using SBCL's +~sb-unix:unix-read~, bypassing the standard CL stream layer. + +Why bypass ~read-char~ and ~listen~? CL streams buffer input, which +interferes with the byte-at-a-time state machine of escape sequence +parsing. Once the stream has buffered bytes, ~listen~ may return T even +though the next byte belongs to a different sequence. Direct ~unix-read~ +gives us precise control over how many bytes we consume. + +The ~timeout~ keyword uses ~sb-unix:unix-simple-poll~ to implement +non-blocking reads with a configurable deadline. This is critical for +the 50ms escape sequence ambiguity resolution in ~%read-escape-sequence~. + +Memory management: we allocate a 1-byte alien buffer, read into it, then +~free-alien~ in an ~unwind-protect~ to prevent leaks even if the read +is interrupted by a signal. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defun read-raw-byte (&key timeout) + (let* ((buf (sb-alien:make-alien sb-alien:unsigned-char 1)) + (fd 0)) + (unwind-protect + (if timeout + (progn (sb-unix:unix-simple-poll fd :input timeout) + (let ((n (sb-unix:unix-read fd buf 1))) + (if (= n 1) (sb-alien:deref buf 0) (values nil :eof)))) + (let ((n (sb-unix:unix-read fd buf 1))) + (if (= n 1) (sb-alien:deref buf 0) (values nil :eof)))) + (sb-alien:free-alien buf)))) +#+END_SRC + +** Escape sequence reader + +~%read-escape-sequence~ is called after the top-level reader has consumed +byte 0x1b (Escape). Its job is to resolve the classic terminal ambiguity: +is this a lone Escape key press, or the start of a multi-byte escape +sequence (CSI, SS3, etc.)? + +The resolution strategy uses a 50ms timeout on the first follow-up byte: +- No byte within 50ms → the user pressed Escape. Return ~:escape~. +- Byte is 0x5b ([) → CSI sequence. Delegate to ~parse-csi-sequence~. +- Byte is 0x4f (O) → SS3 sequence. Read one more byte for F1-F4 or shifted + cursor keys. +- Byte is 0x7f (DEL) → Alt+Backspace (a common terminal convention). +- Byte is < 0x20 → Ctrl+letter with Alt modifier. +- Any other byte → Alt+letter. + +Why 50ms? This value is the de facto standard across terminal emulators +and TUI frameworks. It's long enough that human key repeat rates (typ. +30-50ms between key repeat events) won't falsely trigger escape sequence +detection, but short enough that the Escape key feels responsive. The +Linux kernel's default key repeat rate uses a similar timing. + +The SS3 path handles shifted cursor keys that some emulators report as +~ESC O A~ through ~ESC O D~ (shifted up/down/right/left). These use a +different byte prefix from the CSI form ~ESC [ A~ through ~ESC [ D~. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defun %read-escape-sequence () + (flet ((read-next (&optional (timeout nil)) + (let ((b (read-raw-byte :timeout timeout))) + (unless b (return-from %read-escape-sequence + (make-key-event :key :escape :code 27))) + b))) + (let ((b1 (read-next 0.05))) + (cond + ((null b1) (make-key-event :key :escape :code 27)) + ((= b1 79) (let ((b2 (read-next))) + (case b2 + (80 (make-key-event :key :f1)) + (81 (make-key-event :key :f2)) + (82 (make-key-event :key :f3)) + (83 (make-key-event :key :f4)) + (72 (make-key-event :key :home)) + (70 (make-key-event :key :end)) + (65 (make-key-event :key :up :shift t)) + (66 (make-key-event :key :down :shift t)) + (67 (make-key-event :key :right :shift t)) + (68 (make-key-event :key :left :shift t)) + (otherwise (make-key-event :key :unknown :raw (string (code-char b2))))))) + ((= b1 91) (parse-csi-sequence)) + ((= b1 127) (make-key-event :key :alt-backspace)) + ((< b1 32) + (let ((c (code-char (+ b1 96)))) + (make-key-event :key (intern (string-upcase (string c)) :keyword) + :alt t :code b1))) + (t (make-key-event :key (intern (string-upcase (string (code-char b1))) :keyword) + :alt t :code b1)))))) +#+END_SRC + +** CSI sequence parser + +~parse-csi-sequence~ reads and parses a full Control Sequence Introducer +sequence: ~ESC [ (param) (terminator)~. + +The function implements a recursive descent parser for the CSI grammar: +- Read the first byte after ~ESC [~. +- If it's a digit (0x30-0x39), collect all consecutive digits as the first + parameter, then the next non-digit byte is the terminator. +- If it's not a digit, it may be a modifier byte (0x3B = semicolon, in + extended sequences) or the terminator itself. + +The ~extended~ array accumulates raw parameter bytes for sequences where +the modifier appears after the primary parameter in an extended format +(e.g., ~ESC [ 1 ; 5 A~ where 5 encodes Ctrl+Shift). This array is passed +to ~parse-csi-params~ for modifier extraction. + +The two-pass approach (parse bytes → look up semantics) cleanly separates +the byte-level parsing concern from the key-mapping concern, making both +easier to test and debug independently. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defun parse-csi-sequence () + (flet ((read-param (next-fn) (let ((acc nil)) + (loop for b = (funcall next-fn) + do (if (and (>= b 48) (<= b 57)) + (push (- b 48) acc) + (return (values (reverse acc) b))))))) + (let* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0)) + (b2 (read-raw-byte)) + (params (if (and (>= b2 48) (<= b2 57)) + (multiple-value-bind (p term) (read-param (lambda () (read-raw-byte))) + (setf (fill-pointer extended) (length p)) + (replace extended p) + (values p term)) + (progn (vector-push-extend b2 extended) (read-param (lambda () (read-raw-byte))))))) + (destructuring-bind (params terminator) params + (parse-csi-params params terminator extended))))) +#+END_SRC + +** UTF-8 decoder + +~utf8-decode~ converts a list of raw bytes (2 to 4 of them) into a Unicode +code point. It validates the byte sequence against the UTF-8 encoding rules +and returns ~nil~ for invalid sequences. + +UTF-8 encoding structure: +- 2-byte: 110xxxxx 10xxxxxx (U+0080 through U+07FF) +- 3-byte: 1110xxxx 10xxxxxx 10xxxxxx (U+0800 through U+FFFF) +- 4-byte: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx (U+10000 through U+10FFFF) + +Each case performs: +1. Range validation on the leading byte (ensuring it's in the correct pattern). +2. Continuation byte validation (each must be 10xxxxxx, i.e., 0x80-0xBF). +3. Bit masking and shifting to extract the code point. + +This approach is intentionally simple and table-free. For terminal input, +sequences are always short (2-4 bytes), dispatched by the leading byte +category (~%read-event~ classifies them), so a compact ~case~ form is both +efficient and easy to audit for correctness. + +Overlong sequences (e.g., encoding ASCII in 2+ bytes) are rejected because +the range checks on the leading byte exclude them: a 2-byte sequence with +b0=0xC0 would have ~(= #xc2 b0 #xdf)~ fail since 0xC0 < 0xC2. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defun utf8-decode (bytes) + (case (length bytes) + (2 (let ((b0 (first bytes)) (b1 (second bytes))) + (when (and (<= #xc2 b0 #xdf) (<= #x80 b1 #xbf)) + (+ (ash (logand b0 #x1f) 6) (logand b1 #x3f))))) + (3 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes))) + (when (and (<= #xe0 b0 #xef) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf)) + (+ (ash (logand b0 #x0f) 12) (ash (logand b1 #x3f) 6) (logand b2 #x3f))))) + (4 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes)) (b3 (fourth bytes))) + (when (and (<= #xf0 b0 #xf4) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf) (<= #x80 b3 #xbf)) + (+ (ash (logand b0 #x07) 18) (ash (logand b1 #x3f) 12) + (ash (logand b2 #x3f) 6) (logand b3 #x3f))))) + (t nil))) +#+END_SRC + +** Top-level event reader + +~%read-event~ is the main entry point for terminal input parsing. It reads +one byte, classifies it, and returns an appropriate event. + +The classification hierarchy: +1. ~~x1b (Escape) → delegate to ~%read-escape-sequence~. +2. ~~x09 (Tab) → ~:tab~ with code ~~x09. +3. ~~x0a (LF) or ~~x0d (CR) → ~:enter~. +4. ~~x7f (DEL) or ~~x08 (BS) → ~:backspace~. +5. Byte range ~~x01-~~x1a → Ctrl+letter (Ctrl+A through Ctrl+Z). + The offset ~~x60 converts the control code to its corresponding + printable character: ~~x01 + ~~x60 = #\a = code 97. +6. ~~x1c-~~x1f → Ctrl+\ through Ctrl+_ with specific key names. +7. Byte range ~~x20-~~x7e → printable ASCII, interned as keyword + (uppercased). +8. Byte >= ~~xc2 → Start of UTF-8 multi-byte sequence. Read the + continuation bytes (up to 3 more) with a 500ms timeout each. + If enough valid bytes arrive, decode via ~utf8-decode~. +9. Anything else → ~:unknown~. + +The Ctrl+letter mapping (~~x01-~~x1a → Ctrl+A..Ctrl+Z) follows the +standard ASCII control code layout where Ctrl+letter subtracts 0x60 +from the uppercase letter's code point. For example, Ctrl+A (SOH) is +~~x01, and ~~x01 + ~~x60 = 97 = #\a, which interns as ~:a~. + +Why 500ms for UTF-8 continuation byte timeout? This is intentionally +longer than the 50ms escape-sequence timeout. UTF-8 sequences are +streamed in real time from the terminal; if we're too aggressive, we +might cut off a multi-byte character during a slow paste or network +connection. The 500ms gives the terminal ample time to deliver all bytes. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defun %read-event (&key timeout) + (multiple-value-bind (b reason) (read-raw-byte :timeout timeout) + (unless b (return-from %read-event (if (eq reason :eof) :eof nil))) + (cond + ((= b #x1b) (%read-escape-sequence)) + ((= b #x09) (make-key-event :key :tab :code #x09)) + ((= b #x0a) (make-key-event :key :enter :code #x0a)) + ((= b #x0d) (make-key-event :key :enter :code #x0d)) + ((or (= b #x7f) (= b #x08)) (make-key-event :key :backspace :code b)) + ((and (>= b #x01) (<= b #x1a)) + (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) + (make-key-event :key key :ctrl t :code b))) + ((= b #x1c) (make-key-event :key :backslash :ctrl t :code b)) + ((= b #x1d) (make-key-event :key :rbracket :ctrl t :code b)) + ((= b #x1e) (make-key-event :key :caret :ctrl t :code b)) + ((= b #x1f) (make-key-event :key :underscore :ctrl t :code b)) + ((and (>= b #x20) (<= b #x7e)) + (let ((ch (code-char b))) + (make-key-event :key (intern (string (string-upcase ch)) :keyword) :code b))) + ((>= b #xc2) + (let* ((n (cond ((<= b #xdf) 2) ((<= b #xef) 3) (t 4))) + (bytes (list b))) + (loop for i from 1 below n + for b2 = (multiple-value-bind (byte reason) (read-raw-byte :timeout 0.5) + (declare (ignore reason)) byte) + while (and b2 (<= #x80 b2 #xbf)) + do (push b2 bytes)) + (setf bytes (nreverse bytes)) + (if (= (length bytes) n) + (let ((cp (utf8-decode bytes))) + (if cp (make-key-event :key :codepoint :code cp :raw (map 'string #'code-char bytes)) + (make-key-event :key :unknown :raw (map 'string #'code-char bytes)))) + (make-key-event :key :unknown :raw (map 'string #'code-char bytes))))) + (t (make-key-event :key :unknown :code b :raw (string (code-char b))))))) +#+END_SRC + +** Terminal resize detection + +~*terminal-resized-p*~ is a flag set by a SIGWINCH signal handler. +When the terminal emulator window is resized, the kernel sends SIGWINCH +to the foreground process group. SBCL's signal handling facility +(~sb-sys:enable-interrupt~) lets us install a handler that sets this +flag. + +The main event loop should check this flag after each ~%read-event~ +call and, if set, query the new terminal dimensions and redraw. The +flag is not automatically cleared — the consumer must set it to ~nil~ +after handling the resize. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defvar *terminal-resized-p* nil) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +#+sbcl +(eval-when (:load-toplevel :execute) + (sb-sys:enable-interrupt sb-posix:sigwinch + (lambda (signal info context) + (declare (ignore signal info context)) + (setf *terminal-resized-p* t)))) +#+END_SRC + +** Backend protocol integration + +~read-event~ is a ~defmethod~ on the backend generic function, part of the +cl-tty backend protocol. This allows the same application code to read +input regardless of which backend is active. + +The implementation probes ~/dev/stdin~ (which is a symlink to the actual +terminal device when stdin is a terminal) and, if it exists, delegates to +~%read-event~. The ~(declare (ignore b))~ means this method ignores the +backend instance — terminal input is independent of the output backend. + +This method is deliberately simple: it's a thin wrapper that adapts the +~%read-event~ API to the backend protocol's ~read-event~ generic function. +All the complexity lives in ~%read-event~ and its callees. + +#+BEGIN_SRC lisp :tangle ../src/components/input.lisp +(defmethod read-event ((b cl-tty.backend:backend) &key timeout) + ;; Check for pending terminal resize before reading input. + ;; The SIGWINCH handler sets *terminal-resized-p* asynchronously. + (when *terminal-resized-p* + (setf *terminal-resized-p* nil) + (multiple-value-bind (w h) (backend-size b) + (return-from read-event (values :resize (cons w h))))) + (when (probe-file "/dev/stdin") + (%read-event :timeout timeout))) +#+END_SRC + +* Textarea Widget + +The textarea is a multi-line text editing widget with undo/redo support, +cursor movement across lines, and line-based operations (newline, join, +delete at line boundaries). + +All blocks tangle to ~../src/components/textarea.lisp~. + +** Textarea class definition + +The textarea class inherits from ~dirty-mixin~ (from cl-tty.box) for +automatic dirty-flag tracking used by the rendering pipeline. Key slots: + +- ~value~: The full text content as a single string with embedded newlines. +- ~cursor-row~ / ~cursor-col~: The cursor position in row/column coordinates. + Row 0 is the first line of ~value~; col 0 is the first character of that line. +- ~selection-start~: Cursor position when a selection began (nil when no selection). +- ~undo-stack~ / ~redo-stack~: Fill-pointer vectors (capacity 100) for + linear undo/redo. The fill-pointer acts as a stack pointer — ~vector-push~ + pushes, ~vector-pop~ pops, and resetting the fill-pointer to 0 clears. +- ~on-submit~: Optional callback invoked on Enter when set. If nil, Enter + inserts a newline. +- ~layout-node~: Position/size info for the rendering system. +- ~focusable~: Whether this widget can receive keyboard focus. + +Why fill-pointer vectors instead of lists for undo/redo? Vectors provide +O(1) indexed access, bounded memory (capacity 100), and ~vector-push~ +avoids consing on every keystroke. The eviction strategy (oldest entries +shift out when full) keeps memory bounded. + +This is the first block tangling to textarea.lisp, so it includes the +~in-package~ form. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(in-package #:cl-tty.input) + +(defclass textarea (dirty-mixin) + ((value :initform "" :initarg :value :accessor textarea-value :type string) + (cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum) + (cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum) + (selection-start :initform nil :accessor textarea-selection-start) + (undo-stack :initform (make-array 100 :fill-pointer 0) + :accessor textarea-undo-stack) + (redo-stack :initform (make-array 100 :fill-pointer 0) + :accessor textarea-redo-stack) + (on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit) + (layout-node :initform (make-layout-node) :accessor textarea-layout-node) + (focusable :initform t :accessor textarea-focusable))) +#+END_SRC + +** Textarea constructor + +~make-textarea~ is a convenience constructor that wraps ~make-instance~ +with sensible defaults. It accepts ~:value~ and ~:on-submit~ keyword +arguments, defaulting ~value~ to the empty string if not provided. + +The constructor is a separate function rather than a ~:constructor~ +option on ~defclass~ because it needs to normalize the value argument +~(or value "")~ — a pattern that would clutter the class definition. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun make-textarea (&key value on-submit) + (make-instance 'textarea + :value (or value "") + :on-submit on-submit)) +#+END_SRC + +** Line helpers + +The ~textarea-lines~ function splits the value into a list of lines. +It delegates to ~%split-string~ (defined in input.lisp) with #\Newline +as the separator. For an empty string, this returns ~("")~ — one empty +line, which is the correct representation of a blank document. + +~textarea-line-count~ is a simple wrapper for the number of lines. +It's used by cursor movement functions to clamp the cursor row. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun textarea-lines (ta) + "Split value into lines." + (%split-string (textarea-value ta) #\Newline)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun textarea-line-count (ta) + "Number of lines in value." + (length (textarea-lines ta))) +#+END_SRC + +** Cursor clamping + +~textarea-ensure-cursor~ clamps the cursor position to valid ranges +after any operation that might move it out of bounds. It: +1. Clamps ~cursor-row~ to [0, line-count-1]. +2. Clamps ~cursor-col~ to [0, current-line-length]. + +This function is called after every cursor movement and after edits +that change line structure (newline, backspace joining lines). It +also marks the widget dirty, ensuring the renderer picks up the +cursor position change. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun textarea-ensure-cursor (ta) + "Clamp cursor to valid range." + (let ((lines (textarea-lines ta))) + (setf (textarea-cursor-row ta) + (max 0 (min (textarea-cursor-row ta) (1- (length lines))))) + (let ((line-len (length (nth (textarea-cursor-row ta) lines)))) + (setf (textarea-cursor-col ta) + (max 0 (min (textarea-cursor-col ta) line-len))))) + (mark-dirty ta)) +#+END_SRC + +** Line joiner utility + +~%join-lines~ is the inverse of ~%split-string~: it takes a sequence of +strings (list or vector) and joins them with #\Newline separators. It +uses ~with-output-to-string~ for efficient string construction. + +The function handles both lists and vectors because different parts of +the textarea code work with different representations — ~textarea-lines~ +returns a list, but the insertion/backspace code operates on vectors +for efficient element replacement. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(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)))) +#+END_SRC + +** Character insertion + +~textarea-insert-char~ inserts a single character at the cursor position +within the current line. The algorithm: + +1. Push undo state (so the insertion can be undone). +2. Split the value into lines (coerced to vector for indexed access). +3. If the cursor row is within the current line count, insert the + character into that line at the cursor column by concatenating + the prefix, the character, and the suffix. +4. If the cursor row is beyond the last line (shouldn't happen with + proper cursor clamping, but handled defensively), append the + character to the end of the full value. + +The function updates ~cursor-col~ by 1 after insertion and marks the +widget dirty. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(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))))) +#+END_SRC + +** Newline insertion + +~textarea-newline~ splits the current line at the cursor column and +inserts a newline character between the two halves. + +Algorithm: +1. Push undo state. +2. Split the value into lines (coerced to vector). +3. If the cursor row is valid, split the current line into ~before~ + (characters before cursor) and ~after~ (characters after). +4. Replace the current line with ~before~ and insert ~after~ as a + new line immediately after. +5. Move cursor to the start of the new line (row+1, col=0). +6. If the cursor row is beyond the last line, simply append a newline. +7. Mark dirty. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(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))))) +#+END_SRC + +** Backspace + +~textarea-backspace~ handles both character deletion and line joining: + +1. At (0,0): nothing to delete — return nil. +2. At column 0 (start of a non-first line): join the current line + with the previous line. Cursor moves to the end of the previous line. +3. At any other column: delete the character before the cursor within + the current line. + +The line-joining behavior is what distinguishes multi-line backspace +from single-line backspace. When the cursor is at column 0 of a line, +backspace conceptually "pulls" that line up to the end of the previous +line, removing the newline character between them. + +All paths push undo state before modifying the value. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(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)))))) +#+END_SRC + +** Cursor movement: up/down + +~textarea-move-up~ and ~textarea-move-down~ move the cursor between lines +while preserving the column position as much as possible. The decrement +or increment on ~cursor-row~ may produce a row outside the valid range, +but ~textarea-ensure-cursor~ clamps it immediately afterward. + +The column preservation is implicit: ~textarea-ensure-cursor~ clamps +the column to the new line's length, so if the user was at column 10 +on a long line and moves up to a shorter 5-character line, the column +clamps to 5. This matches how most editors handle column preservation +— the column "remembers" its position but is constrained by line length. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun textarea-move-up (ta) + (decf (textarea-cursor-row ta)) + (textarea-ensure-cursor ta)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun textarea-move-down (ta) + (incf (textarea-cursor-row ta)) + (textarea-ensure-cursor ta)) +#+END_SRC + +** Undo/redo system + +The undo system uses fill-pointer vectors as bounded stacks (capacity 100). +Each edit pushes the current value onto the undo stack before modifying it. + +~textarea-push-undo~: Saves the current value onto the undo stack. +If the stack is full (fill-pointer >= total-size), it shifts all entries +left by one (dropping the oldest) and decrements the fill-pointer, making +room for the new entry. It then pushes the current value and clears the +redo stack (any new edit invalidates the redo history). + +~textarea-undo~: Pops the most recent value from the undo stack, pushes +the current value onto the redo stack, restores the popped value, and +clamps the cursor via ~textarea-ensure-cursor~. + +~textarea-redo~: Pops the most recent value from the redo stack, pushes +the current value onto the undo stack, restores the popped value, and +clamps the cursor. + +Why clear the redo stack on new edits? This is the standard "linear undo" +model — once you make a new edit after undoing, the redo history is +discarded because the edit graph has branched. Implementing a full tree +undo would be significantly more complex and is unnecessary for a TUI +textarea. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun textarea-push-undo (ta) + "Save current value on undo stack." + (let ((stack (textarea-undo-stack ta))) + (when (>= (length stack) (array-total-size stack)) + (loop for i from 1 below (length stack) + do (setf (aref stack (1- i)) (aref stack i))) + (decf (fill-pointer stack))) + (vector-push (textarea-value ta) stack) + (setf (fill-pointer (textarea-redo-stack ta)) 0))) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(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))))) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(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 + +** Textarea key event handler + +~handle-textarea-input~ is the main event dispatcher for the textarea. +It processes ~key-event~ instances and delegates to the appropriate +textarea operation or performs inline actions. + +Ctrl+key bindings: +- Ctrl+Z → undo +- Ctrl+Y → redo +- Ctrl+A → home (move cursor-col to 0 on current line) +- Ctrl+E → end (move cursor-col to end of current line) + +Unmodified key bindings: +- :left/:right → column movement with cursor clamping +- :up/:down → row movement with cursor clamping +- :home/:end → column extremes +- :enter → on-submit callback if set, otherwise insert newline +- :backspace → delete before cursor / join lines +- :delete → delete at cursor (character under cursor) +- Other printable characters → insert at cursor via ~key-event-code~ + +The printable character insertion uses ~code-char~ on ~key-event-code~ +rather than looking at ~key-event-key~. This is because ~key-event-key~ +is always an uppercase keyword (~:a~ for both 'a' and 'A'), but the +code preserves the actual character. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defun handle-textarea-input (ta event) + "Process a key-event on a textarea widget." + (cond + ((key-event-ctrl event) + (case (key-event-key event) + (:z (textarea-undo ta)) + (:y (textarea-redo ta)) + ;; Ctrl+A/E: home/end + (:a (setf (textarea-cursor-col ta) 0)) + (:e (let ((lines (textarea-lines ta))) + (when (< (textarea-cursor-row ta) (length lines)) + (setf (textarea-cursor-col ta) + (length (nth (textarea-cursor-row ta) lines)))))) + (t nil))) + (t + (case (key-event-key event) + (:left (decf (textarea-cursor-col ta)) + (textarea-ensure-cursor ta)) + (:right (incf (textarea-cursor-col ta)) + (textarea-ensure-cursor ta)) + (:up (textarea-move-up ta)) + (:down (textarea-move-down ta)) + (:home (setf (textarea-cursor-col ta) 0) + (textarea-ensure-cursor ta)) + (:end (let ((lines (textarea-lines ta))) + (when (< (textarea-cursor-row ta) (length lines)) + (setf (textarea-cursor-col ta) + (length (nth (textarea-cursor-row ta) lines)))) + (textarea-ensure-cursor ta))) + (:enter (let ((cb (textarea-on-submit ta))) + (if cb + (funcall cb (textarea-value ta)) + (textarea-newline ta)))) + (:backspace (textarea-backspace ta)) + (:delete (let* ((lines (textarea-lines ta)) + (row (textarea-cursor-row ta)) + (col (textarea-cursor-col ta)) + (line (nth row lines))) + (when (and line (< col (length line))) + (textarea-push-undo ta) + (setf (nth row lines) + (concatenate 'string + (subseq line 0 col) + (subseq line (1+ col)))) + (setf (textarea-value ta) + (%join-lines lines)) + (mark-dirty ta)))) + ;; Character insertion + (otherwise + (let ((ch (code-char (key-event-code event)))) + (when (and ch (graphic-char-p ch)) + (textarea-insert-char ta ch)))))))) +#+END_SRC + +** Textarea rendering + +~render~ for textarea draws the visible portion of the text content +within the widget's layout bounds. It: + +1. Retrieves the layout node for position and size. +2. Splits the value into lines. +3. Loops over the visible lines (up to the available height). +4. For each line, draws it at the correct position, truncating to the + available width. + +The render method iterates ~max-lines~ (minimum of total lines and +available height) to avoid drawing outside the widget boundaries. +Each line is truncated to ~w~ characters to prevent horizontal overflow. + +Cursor rendering is handled by the focus/selection rendering layer, +not by this method. This keeps the render method simple — it just +paints text. + +#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp +(defmethod render ((ta textarea) (backend t)) + "Render textarea lines at layout position." + (let* ((ln (textarea-layout-node ta)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (h (if ln (layout-node-height ln) 24)) + (lines (textarea-lines ta)) + (max-lines (min (length lines) h))) + (loop for i from 0 below max-lines + for line in lines + do (draw-text backend x (+ y i) + (subseq line 0 (min (length line) w)) + nil nil)))) +#+END_SRC + +* Text Input Widget + +TextInput is a single-line text editing widget with cursor movement, +character insertion/deletion, word deletion, and emacs-style keyboard +shortcuts. + +All blocks tangle to ~../src/components/text-input.lisp~. + +** Text input class definition + +The TextInput class inherits from ~dirty-mixin~ for automatic dirty +tracking. Slots: + +- ~value~: The text content (single line, no newline characters). +- ~cursor~: The cursor position as a 0-indexed integer offset from the + start of ~value~. +- ~placeholder~: Text displayed when ~value~ is empty, giving the user + a hint about what to type. +- ~max-length~: Optional maximum character count. When set, insertions + beyond this limit are silently rejected. +- ~on-submit~: Callback invoked with the current value when Enter is pressed. +- ~layout-node~: Position/size info for rendering. +- ~focusable~: Whether this widget can receive keyboard focus. + +This is the first block tangling to text-input.lisp, so it includes the +~in-package~ form. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(in-package #:cl-tty.input) + +(defclass text-input (dirty-mixin) + ((value :initform "" :initarg :value :accessor text-input-value + :type string) + (cursor :initform 0 :initarg :cursor :accessor text-input-cursor + :type fixnum) + (placeholder :initform "" :initarg :placeholder + :accessor text-input-placeholder :type string) + (max-length :initform nil :initarg :max-length + :accessor text-input-max-length) + (on-submit :initform nil :initarg :on-submit + :accessor text-input-on-submit) + (layout-node :initform (make-layout-node) :accessor text-input-layout-node) + (focusable :initform t :accessor text-input-focusable))) +#+END_SRC + +** Text input constructor + +~make-text-input~ wraps ~make-instance~ with keyword arguments and +sensible defaults. Each optional parameter has a fallback: ~value~ +defaults to "", ~cursor~ to 0, ~placeholder~ to "", and ~max-length~ +and ~on-submit~ to nil (disabled). + +The ~(or value "")~ pattern ensures the value is always a string, +even if the caller passes nil. This eliminates a class of nil-pointer +errors in string operations downstream. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(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 + +** Character insertion + +~text-input-insert~ inserts a character at the cursor position within +the single-line value. The algorithm: + +1. Check ~max-length~: if set and the value is already at the limit, + return immediately (the character is silently dropped). +2. Construct the new value by concatenating the prefix (before cursor), + the new character, and the suffix (after cursor). +3. Increment the cursor by 1. +4. Mark the widget dirty. + +This is a pure insert — it does not replace the character at the cursor; +it shifts subsequent characters right. For overwrite behavior, the caller +would need a different function. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.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 + +** Backspace + +~text-input-backspace~ deletes the character immediately before the +cursor. If the cursor is at position 0, nothing happens. + +The algorithm concatenates the prefix (up to one before cursor) with +the suffix (from cursor onward), effectively removing the character +at cursor-1. The cursor is decremented by 1. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.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))) +#+END_SRC + +** Delete + +~text-input-delete~ removes the character at the cursor position. +If the cursor is at or beyond the end of the value, nothing happens. + +The algorithm concatenates the prefix (up to cursor) with the suffix +(from cursor+1 onward), removing the character at cursor without +moving the cursor position. + +This contrasts with backspace, which removes the character before +cursor and decrements the cursor. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(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: left/right + +~text-input-move-left~ and ~text-input-move-right~ move the cursor by +one character position, clamped to [0, length]. Left movement stops at +0; right movement stops at the end of the value. + +Each movement function marks the widget dirty so the renderer redraws +the cursor position. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(defun text-input-move-left (input) + (when (plusp (text-input-cursor input)) (decf (text-input-cursor input))) + (mark-dirty input)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(defun text-input-move-right (input) + (when (< (text-input-cursor input) (length (text-input-value input))) (incf (text-input-cursor input))) + (mark-dirty input)) +#+END_SRC + +** Cursor movement: home/end + +~text-input-move-home~ moves the cursor to position 0 (start of value). +~text-input-move-end~ moves the cursor to the end of the value. + +These are the programmatic equivalents of the Home and End keys and +are also used by the Ctrl+A and Ctrl+E keybindings. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(defun text-input-move-home (input) + (setf (text-input-cursor input) 0) + (mark-dirty input)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(defun text-input-move-end (input) + (setf (text-input-cursor input) (length (text-input-value input))) + (mark-dirty input)) +#+END_SRC + +** Word-delete before cursor + +~text-input-delete-word-before~ implements Ctrl+W / Emacs ~backward-kill-word~. +It deletes from the cursor position backward to the previous word boundary. + +The algorithm: +1. Find the last non-space character before the cursor (~start~). + If none exists, ~start~ is 0. +2. Find the last space character before ~start~. If none, ~word-start~ is 0. +3. Compute ~delete-start~: the position from which to start deleting. + - If word-start is 0 and the first character is non-space (or start is 0), + delete from 0. + - Otherwise, delete from one past the last space (i.e., the start of the + word before the cursor). + +A "word" here is defined as a run of non-space characters. This matches +the shell/Emacs convention for Ctrl+W rather than an English word boundary +(which would involve punctuation handling). + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(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 + +** Text input key event handler + +~handle-text-input~ is the main event dispatcher for TextInput. + +Ctrl+key bindings (Emacs-style): +- Ctrl+A → move to home (start of line) +- Ctrl+E → move to end +- Ctrl+W → delete word before cursor +- Ctrl+U → delete from cursor to start of line +- Ctrl+K → delete from cursor to end of line + +Unmodified key bindings: +- :left/:right → cursor movement +- :home/:end → extremes +- :backspace/:delete → character deletion +- :enter → invoke on-submit callback with current value +- :tab/:escape → ignored (no-op) +- Other → insert as printable character via ~key-event-code~ + +The printable character check uses ~graphic-char-p~ to ensure only +visible characters (letters, digits, punctuation, symbols) are +inserted. Control characters and spaces are handled by their specific +key bindings. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.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 + +** Text input rendering + +~render~ for TextInput draws the current value (or placeholder if the +value is empty) at the widget's layout position, truncated to the +available width. + +Rendering steps: +1. Retrieve the layout node for position (x, y) and width (w). +2. Determine display text: if value is non-empty, use it; otherwise + use the placeholder (or empty string if placeholder is also empty). +3. Truncate the display text to the available width. +4. Draw the truncated text at (x, y) using the backend's ~draw-text~. +5. Draw the cursor as a block character ("█") at the cursor position + if the value is non-empty. + +The cursor is a solid block ("█") drawn at the cursor column offset +from the text start. If the cursor is beyond the truncated display +width, it's clamped to the last visible position. + +#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp +(defmethod render ((in text-input) (backend t)) + (let* ((ln (text-input-layout-node in)) + (x (if ln (layout-node-x ln) 0)) (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (value (text-input-value in)) (cursor (text-input-cursor in)) + (display (if (plusp (length value)) value (or (text-input-placeholder in) ""))) + (truncated (subseq display 0 (min (length display) w)))) + (draw-text backend x y truncated nil nil) + (when (plusp (length value)) + (let ((cursor-col (min cursor (length truncated)))) + (draw-text backend (+ x cursor-col) y "█" :bright-white nil))))) +#+END_SRC + +* Keybinding System + +The keybinding system provides a flexible dispatch mechanism for +routing keystrokes to handler functions through layered keymaps. +Keymaps are named and stored in a global registry, allowing components +to install local keymaps that fall through to global keymaps. + +All blocks tangle to ~../src/components/keybindings.lisp~. + +** Keymap struct + +The ~keymap~ struct is a simple data container with three slots: +- ~name~: A keyword identifier (e.g., ~:global~, ~:local~). +- ~bindings~: An alist of (spec . handler) pairs. +- ~parent~: An optional parent keymap for inheritance (reserved for + future use — currently the fallback chain is handled by name-based + lookup in ~dispatch-key-event~, not by the ~parent~ slot). + +Like ~key-event~, this is a struct rather than a class because keymaps +are created frequently and never need CLOS dispatch on their own — all +polymorphism is handled by the dispatch function. + +This is the first block tangling to keybindings.lisp, so it includes +the ~in-package~ form. + +#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +(in-package #:cl-tty.input) + +(defstruct keymap + (name nil :type (or keyword null)) + (bindings nil :type list) + (parent nil :type (or keymap null))) +#+END_SRC + +** Global keymap registry + +~*keymaps*~ is a hash table mapping keyword names (~:global~, ~:local~) +to ~keymap~ instances. The ~equal~ test allows string-keyword flexibility +(though in practice all keys are keywords). + +~*chord-timeout*~ is a 0.5-second timeout reserved for future multi-key +chord support (e.g., ~(:ctrl+x :ctrl+s)~). Currently only single-key +specs work; the timeout and list-of-lists spec syntax are placeholders +for the eventual chord implementation. + +#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +(defparameter *keymaps* (make-hash-table :test #'equal)) +#+END_SRC + +#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +(defparameter *chord-timeout* 0.5) +#+END_SRC + +** Key spec matching + +~key-match-p~ compares a key specification (spec) against a ~key-event~. +The spec can be: + +1. A keyword, like ~:ctrl+p~, ~:alt+f~, ~:enter~, ~:f1~. + - If the keyword contains ~+~, the part before ~+~ is the modifier + (CTRL, ALT, or SHIFT) and the part after is the key. + - Modifier names are matched case-insensitively with ~string=?~, + avoiding the ~case~ EQL trap (where ~:CTRL+p~ and ~:ctrl+p~ would + be different symbols). + - If no ~+~, the keyword is matched against ~key-event-key~ directly. +2. A list, like ~(:ctrl+p)~ or ~(:ctrl+x :ctrl+s)~. + - Currently only the first element is matched; the list form exists + for future chord support. + +The modifier matching uses ~string=?~ on the modifier part because +~:CTRL+p~ and ~:Ctrl+p~ should both match Ctrl events. Using ~eql~ +on the keyword would make them different specifiers, which is unexpected +for users writing ~:ctrl+p~ in their keymaps. + +#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +(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))))) +#+END_SRC + +** Event dispatch + +~dispatch-key-event~ is the main entry point for the keybinding system. +It implements a three-level lookup chain: + +1. **Component keymap** (:keyword parameter): If the caller supplies a + ~component~, the function calls ~component-keymap~ on it to get a + component-specific keymap. Matches in this keymap take highest priority. +2. **:local keymap**: Look up the ~:local~ keymap in ~*keymaps*~. This + is typically installed by the active "screen" or "mode" (e.g., a + help overlay might have its own local keymap). +3. **:global keymap**: Look up the ~:global~ keymap. This is the catch-all + for application-wide bindings. + +Each level iterates the keymap's bindings alist and returns ~t~ as soon +as a matching handler is found and called. If no binding matches at any +level, returns ~nil~. + +Important caveat: This function is NOT called automatically by the demo's +event loop or widget event handlers. Users who want keymap-based dispatch +MUST call ~dispatch-key-event~ explicitly in their own event loops, e.g.: + + (defun handle-event (event) + (or (dispatch-key-event event) + (handle-text-input my-input event) + ...)) + +Chords ~((:ctrl+x :ctrl+s))~ are not yet supported; only single +key specs work. The ~*chord-timeout*~ variable and list-of-lists syntax +are reserved for future implementation. + +#+BEGIN_SRC lisp :tangle ../src/components/keybindings.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 that registers a keymap in the global +~*keymaps*~ hash table. Syntax: + +#+BEGIN_SRC lisp :tangle ../src/components/keybindings.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 keymap protocol + +~component-keymap~ is a generic function that returns a ~keymap~ instance +for a given component, or ~nil~ if the component has no keymap. The default +method on ~t~ returns ~nil~, meaning components must explicitly define a +method to participate in the keymap system. + +This generic function allows the dispatch system to query any object for +its keymap, enabling per-component keybinding customization without +requiring components to inherit from a specific base class. + +#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp +;;; --- Component protocol integration --- +(defgeneric component-keymap (component) + (:method ((c t)) nil)) +#+END_SRC + +* Tests + +The test suite is tangled to ~../tests/input-tests.lisp~ and covers: +- Key event construction and accessor correctness +- Mouse event construction and accessor correctness +- UTF-8 decoding (Latin-1 supplement, Euro sign, emoji, invalid sequences) +- TextInput operations (insert, backspace, delete, cursor movement, + home/end, max-length, placeholder, on-submit, Ctrl+A/E, insertion + in middle, dirty tracking) +- Textarea operations (empty, newline, cursor up/down, bounds, + backspace line-joining, undo, redo) +- Keybinding dispatch (simple match, no match, fallthrough, + key-spec matching with all modifiers, list-form specs, return values, + empty keymap, local-over-global, multiple bindings, defkeymap macro) + +#+BEGIN_SRC lisp :tangle ../tests/input-tests.lisp +(defpackage :cl-tty-input-test + (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) + (:export #:run-tests)) +(in-package :cl-tty-input-test) (def-suite input-suite :description "Text input and keybinding tests") (in-suite input-suite) @@ -175,6 +1715,28 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, (is (= (mouse-event-x e) 10)) (is (= (mouse-event-y e) 5)))) +;; ── UTF-8 Decode Tests ────────────────────────────────────────── + +(test utf8-decode-latin1-supplement + "0xC3 0xA9 (é) decodes to code point 233." + (is (= (cl-tty.input:utf8-decode '(#xc3 #xa9)) 233))) + +(test utf8-decode-euro-sign + "0xE2 0x82 0xAC (€) decodes to code point 8364." + (is (= (cl-tty.input:utf8-decode '(#xe2 #x82 #xac)) 8364))) + +(test utf8-decode-emoji + "0xF0 0x9F 0x92 0xA9 (💩) decodes to code point 128169." + (is (= (cl-tty.input:utf8-decode '(#xf0 #x9f #x92 #xa9)) 128169))) + +(test utf8-decode-invalid-short + "Invalid byte 0x80 alone returns nil." + (is-false (cl-tty.input:utf8-decode '(#x80)))) + +(test utf8-decode-invalid-overlong + "Overlong 2-byte sequence 0xC0 0x80 returns nil." + (is-false (cl-tty.input:utf8-decode '(#xc0 #x80)))) + ;; ── TextInput Tests ───────────────────────────────────────────── (test text-input-empty @@ -354,6 +1916,15 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, (is (string= (textarea-value a) "a")))) ;; ── Keybinding Tests ──────────────────────────────────────────── +;; These tests verify the keymap dispatch system works correctly +;; when wired up. Note: dispatch-key-event is NOT called by the +;; demo's event loop — users MUST call it explicitly in their own +;; event loops if they want to use the defkeymap/dispatch-key-event +;; system. See src/components/keybindings.lisp for details. +;; +;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single +;; key specs work. The *chord-timeout* variable and list-of-lists +;; syntax are reserved for future implementation. (test keymap-simple "A keymap dispatches to its handler on matching event." @@ -394,865 +1965,77 @@ SBCL's ~sb-posix~ provides the POSIX terminal APIs (~tcgetattr~, (is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t))) (is-false (key-match-p :ctrl+p (make-key-event :key :p)))) -(test defkeymap-macro - "defkeymap macro registers a keymap." - (let ((called nil)) - (eval `(defkeymap :global - (:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t))))) - (dispatch-key-event (make-key-event :key :q :ctrl t)) - (is-true called))) -#+END_SRC - -* Implementation - -** Package - -The package uses ~:cl-tty.backend~ for backend protocol (draw-text, etc.), -~:cl-tty.box~ for dirty-mixin and rendering pipeline, -and ~:cl-tty.layout~ for layout-node. - -I export everything users of the input system need: key events, mouse events, -terminal raw mode, TextInput, Textarea, and the keybinding system. - -#+BEGIN_SRC lisp -(defpackage :cl-tty.input - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) - (:export - ;; Key events - #:key-event #:make-key-event - #:key-event-p #:key-event-key #:key-event-ctrl - #:key-event-alt #:key-event-shift #:key-event-code - #:key-event-raw #:key-event-text - ;; Mouse events - #:mouse-event #:make-mouse-event - #:mouse-event-p #:mouse-event-type #:mouse-event-button - #:mouse-event-x #:mouse-event-y - ;; Terminal raw mode - #:save-terminal-state #:set-raw-mode #:restore-terminal-state - #:with-raw-terminal - ;; Event reading - #:read-event - ;; TextInput - #:text-input #:make-text-input - #:text-input-value #:text-input-cursor - #:text-input-placeholder #:text-input-max-length - #:text-input-on-submit #:text-input-layout-node - #:handle-text-input #:render-text-input - ;; Textarea - #:textarea #:make-textarea - #:textarea-value #:textarea-cursor-row #:textarea-cursor-col - #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack - #:textarea-layout-node - #:handle-textarea-input #:render-textarea - ;; Keybindings - #:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent - #:*keymaps* #:*chord-timeout* - #:defkeymap #:dispatch-key-event #:key-match-p - #:component-keymap)) -#+END_SRC - -** Utility: split-string - -A simple loop-based split. I avoid using ~split-sequence~ from Quicklisp -to keep dependencies minimal — the framework already depends on ~fiveam~ and -~sb-posix~, and adding another dep just for one function is wasteful. - -The loop collects subsequences between occurrences of SEPARATOR. The -~while pos~ guard prevents an empty trailing element. For an empty string, -this returns ~("")~ (one empty string), which is the correct behavior for -textarea line splitting — a blank document has one empty line. - -#+BEGIN_SRC lisp -(in-package #:cl-tty.input) - -(defun %split-string (string separator) - "Split STRING at each occurrence of SEPARATOR. Returns list of strings." - (loop with start = 0 - for pos = (position separator string :start start) - collect (subseq string start pos) - while pos - do (setf start (1+ pos)))) -#+END_SRC - -** Global rendering variables - -~*current-backend*~ and ~*current-theme*~ are special variables set by the -application's main loop. Widget ~render~ methods use them to draw themselves. -Defining them here rather than in the rendering module keeps the dependency -clean — input widgets depend on rendering, not the other way around. - -#+BEGIN_SRC lisp -(defvar *current-backend* nil - "The active backend used for rendering.") -(defvar *current-theme* nil - "The active theme used for semantic color resolution.") -#+END_SRC - -** Key Event Struct - -I chose ~defstruct~ over ~defclass~ for key events because structs give -inline accessors and value semantics. Every keystroke creates one, and -in the hot path (terminal parsing) we don't want CLOS dispatch overhead. - -Key observation about SBCL's ~defstruct~: it generates a keyword constructor -by default. ~(make-key-event :key :a :ctrl t)~ is valid out of the box. -I initially wrote a custom ~(:constructor ...)~ wrapper and spent hours -debugging argument mismatches — avoid that trap. - -#+BEGIN_SRC lisp -(defstruct key-event - (key nil :type (or keyword null)) - (ctrl nil :type boolean) - - -... [OUTPUT TRUNCATED - 58394 chars omitted out of 108394 total] ... - --------------------------------------------- -(defun text-input-move-left (input) - (when (plusp (text-input-cursor input)) - (decf (text-input-cursor input)))) - -(defun text-input-move-right (input) - (when (< (text-input-cursor input) (length (text-input-value input))) - (incf (text-input-cursor input)))) - -(defun text-input-move-home (input) - (setf (text-input-cursor input) 0)) - -(defun text-input-move-end (input) - (setf (text-input-cursor input) (length (text-input-value input)))) - -(defun text-input-delete-word-before (input) - "Delete from cursor back to previous word boundary." - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (zerop pos) - (return-from text-input-delete-word-before)) - (let* ((start (or (position-if (lambda (c) (not (char= c #\Space))) - val :end pos :from-end t) - 0)) - (word-start (or (and (plusp start) - (position #\Space val :end start :from-end t)) - 0)) - (delete-start (if (and (zerop word-start) - (or (char/= (char val 0) #\Space) - (zerop start))) - 0 - (if (zerop start) - (1+ word-start) - (1+ (or (position #\Space val :end start :from-end t) - 0)))))) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 delete-start) - (subseq val pos))) - (setf (text-input-cursor input) delete-start) - (mark-dirty input)))) - -;;; --------------------------------------------------------------------------- -;;; Key event handler -;;; --------------------------------------------------------------------------- -(defun handle-text-input (input event) - "Process a key-event on a text-input widget." - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:a (text-input-move-home input)) - (:e (text-input-move-end input)) - (:w (text-input-delete-word-before input)) - (:u (progn - (setf (text-input-value input) - (subseq (text-input-value input) - (text-input-cursor input))) - (setf (text-input-cursor input) 0) - (mark-dirty input))) - (:k (progn - (setf (text-input-value input) - (subseq (text-input-value input) 0 - (text-input-cursor input))) - (mark-dirty input))) - (t nil))) - (t - (case (key-event-key event) - (:left (text-input-move-left input)) - (:right (text-input-move-right input)) - (:home (text-input-move-home input)) - (:end (text-input-move-end input)) - (:backspace (text-input-backspace input)) - (:delete (text-input-delete input)) - (:enter (let ((cb (text-input-on-submit input))) - (when cb (funcall cb (text-input-value input))))) - (:tab nil) - (:escape nil) - ;; Insert printable characters - (otherwise - (let ((ch (code-char (key-event-code event)))) - (when (and ch (graphic-char-p ch)) - (text-input-insert input ch)))))))) - -;;; --------------------------------------------------------------------------- -;;; Rendering -;;; --------------------------------------------------------------------------- -(defmethod render ((in text-input) (backend t)) - "Render text-input value or placeholder at layout position." - (let* ((ln (text-input-layout-node in)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (value (text-input-value in)) - (cursor (text-input-cursor in)) - (display (if (plusp (length value)) - value - (or (text-input-placeholder in) ""))) - (truncated (subseq display 0 (min (length display) w)))) - (draw-text backend x y truncated nil nil))) -#+END_SRC - - -** textarea.lisp -#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp -(in-package #:cl-tty.input) - -;;; --------------------------------------------------------------------------- -;;; Textarea class -;;; --------------------------------------------------------------------------- -(defclass textarea (dirty-mixin) - ((value :initform "" :initarg :value :accessor textarea-value :type string) - (cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum) - (cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum) - (selection-start :initform nil :accessor textarea-selection-start) - (undo-stack :initform (make-array 100 :fill-pointer 0) - :accessor textarea-undo-stack) - (redo-stack :initform (make-array 100 :fill-pointer 0) - :accessor textarea-redo-stack) - (on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit) - (layout-node :initform (make-layout-node) :accessor textarea-layout-node) - (focusable :initform t :accessor textarea-focusable))) - -(defun make-textarea (&key value on-submit) - (make-instance 'textarea - :value (or value "") - :on-submit on-submit)) - -;;; --------------------------------------------------------------------------- -;;; Line helpers -;;; --------------------------------------------------------------------------- -(defun textarea-lines (ta) - "Split value into lines." - (%split-string (textarea-value ta) #\Newline)) - -(defun textarea-line-count (ta) - "Number of lines in value." - (length (textarea-lines ta))) - -(defun textarea-ensure-cursor (ta) - "Clamp cursor to valid range." - (let ((lines (textarea-lines ta))) - (setf (textarea-cursor-row ta) - (max 0 (min (textarea-cursor-row ta) (1- (length lines))))) - (let ((line-len (length (nth (textarea-cursor-row ta) lines)))) - (setf (textarea-cursor-col ta) - (max 0 (min (textarea-cursor-col ta) line-len)))))) - -;;; --------------------------------------------------------------------------- -;;; Utility: join strings with newline -;;; --------------------------------------------------------------------------- -(defun %join-lines (lines) - "Join a sequence of strings with newlines." - (with-output-to-string (s) - (loop for line across (if (listp lines) (coerce lines 'vector) lines) - for first = t then nil - do (unless first (write-char #\Newline s)) - (write-string line s)))) - -;;; --------------------------------------------------------------------------- -;;; Text manipulation -;;; --------------------------------------------------------------------------- -(defun textarea-insert-char (ta char) - "Insert CHAR at the cursor position." - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (if (< row (length lines)) - (let* ((line (aref lines row)) - (new-line (concatenate 'string - (subseq line 0 col) - (string char) - (subseq line col)))) - (setf (aref lines row) new-line) - (setf (textarea-value ta) - (%join-lines lines)) - (incf (textarea-cursor-col ta)) - (mark-dirty ta)) - (progn - (setf (textarea-value ta) - (concatenate 'string (textarea-value ta) (string char))) - (incf (textarea-cursor-col ta)) - (mark-dirty ta))))) - -(defun textarea-newline (ta) - "Insert a newline at the cursor." - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (if (< row (length lines)) - (let* ((line (aref lines row)) - (before (subseq line 0 col)) - (after (subseq line col))) - (setf (aref lines row) before) - (let ((new-lines (concatenate 'vector - (subseq lines 0 (1+ row)) - (vector after) - (subseq lines (1+ row))))) - (setf (textarea-value ta) - (%join-lines new-lines))) - (incf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) 0) - (mark-dirty ta)) - (progn - (setf (textarea-value ta) - (concatenate 'string (textarea-value ta) (string #\Newline))) - (incf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) 0) - (mark-dirty ta))))) - -(defun textarea-backspace (ta) - "Delete character before cursor." - (textarea-push-undo ta) - (let* ((lines (coerce (textarea-lines ta) 'vector)) - (row (textarea-cursor-row ta)) - (col (textarea-cursor-col ta))) - (cond - ((and (zerop row) (zerop col)) - nil) ;; nothing to delete - ((zerop col) - ;; Join with previous line - (let* ((prev (aref lines (1- row))) - (curr (aref lines row)) - (new-pos (length prev))) - (setf (aref lines (1- row)) - (concatenate 'string prev curr)) - (let ((new-lines (concatenate 'vector - (subseq lines 0 row) - (subseq lines (1+ row))))) - (setf (textarea-value ta) - (%join-lines new-lines))) - (decf (textarea-cursor-row ta)) - (setf (textarea-cursor-col ta) new-pos) - (mark-dirty ta))) - (t - (let* ((line (aref lines row)) - (new-line (concatenate 'string - (subseq line 0 (1- col)) - (subseq line col)))) - (setf (aref lines row) new-line) - (setf (textarea-value ta) - (%join-lines lines)) - (decf (textarea-cursor-col ta)) - (mark-dirty ta)))))) - -;;; --------------------------------------------------------------------------- -;;; Cursor movement -;;; --------------------------------------------------------------------------- -(defun textarea-move-up (ta) - (decf (textarea-cursor-row ta)) - (textarea-ensure-cursor ta)) - -(defun textarea-move-down (ta) - (incf (textarea-cursor-row ta)) - (textarea-ensure-cursor ta)) - -;;; --------------------------------------------------------------------------- -;;; Undo/redo -;;; --------------------------------------------------------------------------- -(defun textarea-push-undo (ta) - "Save current value on undo stack." - (let ((stack (textarea-undo-stack ta))) - (when (>= (length stack) (array-total-size stack)) - (loop for i from 1 below (length stack) - do (setf (aref stack (1- i)) (aref stack i))) - (decf (fill-pointer stack))) - (vector-push (textarea-value ta) stack) - (setf (fill-pointer (textarea-redo-stack ta)) 0))) - -(defun textarea-undo (ta) - (let ((stack (textarea-undo-stack ta))) - (when (plusp (length stack)) - (let ((prev (vector-pop stack))) - (vector-push (textarea-value ta) (textarea-redo-stack ta)) - (setf (textarea-value ta) prev) - (textarea-ensure-cursor ta) - (mark-dirty ta))))) - -(defun textarea-redo (ta) - (let ((stack (textarea-redo-stack ta))) - (when (plusp (length stack)) - (let ((next (vector-pop stack))) - (vector-push (textarea-value ta) (textarea-undo-stack ta)) - (setf (textarea-value ta) next) - (textarea-ensure-cursor ta) - (mark-dirty ta))))) - -;;; --------------------------------------------------------------------------- -;;; Key event handler -;;; --------------------------------------------------------------------------- -(defun handle-textarea-input (ta event) - "Process a key-event on a textarea widget." - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:z (textarea-undo ta)) - (:y (textarea-redo ta)) - ;; Ctrl+A/E: home/end - (:a (setf (textarea-cursor-col ta) 0)) - (:e (let ((lines (textarea-lines ta))) - (when (< (textarea-cursor-row ta) (length lines)) - (setf (textarea-cursor-col ta) - (length (nth (textarea-cursor-row ta) lines)))))) - (t nil))) - (t - (case (key-event-key event) - (:left (decf (textarea-cursor-col ta)) - (textarea-ensure-cursor ta)) - (:right (incf (textarea-cursor-col ta)) - (textarea-ensure-cursor ta)) - (:up (textarea-move-up ta)) - (:down (textarea-move-down ta)) - (:home (setf (textarea-cursor-col ta) 0)) - (: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 -;;; --------------------------------------------------------------------------- -(defmethod render ((ta textarea) (backend t)) - "Render textarea lines at layout position." - (let* ((ln (textarea-layout-node ta)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) - (w (if ln (layout-node-width ln) 80)) - (h (if ln (layout-node-height ln) 24)) - (lines (textarea-lines ta)) - (max-lines (min (length lines) h))) - (loop for i from 0 below max-lines - for line in lines - do (draw-text backend x (+ y i) - (subseq line 0 (min (length line) w)) - nil nil)))) -#+END_SRC - - -** keybindings.lisp -#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp -(in-package #:cl-tty.input) - -;;; --------------------------------------------------------------------------- -;;; Key map struct -;;; --------------------------------------------------------------------------- -(defstruct keymap - (name nil :type (or keyword null)) - (bindings nil :type list) - (parent nil :type (or keymap null))) - -;;; --------------------------------------------------------------------------- -;;; Global keymap registry -;;; --------------------------------------------------------------------------- -(defparameter *keymaps* (make-hash-table :test #'equal)) -(defparameter *chord-timeout* 0.5) - -;;; --------------------------------------------------------------------------- -;;; Key spec matching -;;; --------------------------------------------------------------------------- -(defun key-match-p (spec event) - "T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword) - or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords." - (etypecase spec - ;; Keyword like :ctrl+p, :alt+f, :enter, :space, :f1 - (keyword - (let* ((name (string spec)) - (plus (position #\+ name))) - (if plus - ;; Modified key: :ctrl+p → mod-str="CTRL", key-str="P" - (let ((mod-str (subseq name 0 plus)) - (key-str (subseq name (1+ plus)))) - (and (eql (intern key-str :keyword) - (key-event-key event)) - (cond - ((string= mod-str "CTRL") (key-event-ctrl event)) - ((string= mod-str "ALT") (key-event-alt event)) - ((string= mod-str "SHIFT") (key-event-shift event)) - (t t)))) - ;; Plain keyword: :enter, :escape, :f1, etc. - (eql spec (key-event-key event))))) - ;; List: (:ctrl+p) or (:ctrl+x :ctrl+s) - (list - (when spec - (key-match-p (first spec) event))))) - -;;; --------------------------------------------------------------------------- -;;; Dispatch -;;; --------------------------------------------------------------------------- -(defun dispatch-key-event (event &key component) - (labels ((try-keymap (km) - (when km - (loop for (spec . handler) in (keymap-bindings km) - thereis (when (key-match-p spec event) - (funcall handler event) - t)))) - (find-keymap (name) - (gethash name *keymaps*))) - (or (and component - (let ((km (component-keymap component))) - (when km (try-keymap km)))) - (try-keymap (find-keymap :local)) - (try-keymap (find-keymap :global))))) - -;;; --------------------------------------------------------------------------- -;;; defkeymap macro -;;; --------------------------------------------------------------------------- -(defmacro defkeymap (name &body bindings) - `(setf (gethash ',name *keymaps*) - (make-keymap :name ',name - :bindings (list ,@(loop for b in bindings - collect (if (consp (cdr b)) - `(cons ',(car b) ,(cadr b)) - `(cons ',(car b) ,(cdr b)))))))) - -;;; --- Component protocol integration --- -(defgeneric component-keymap (component) - (:method ((c t)) nil)) -#+END_SRC - - -** input-package.lisp -#+BEGIN_SRC lisp :tangle ../src/components/input-package.lisp -(defpackage :cl-tty.input - (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout) - (:export - ;; Key events - #:key-event #:make-key-event - #:key-event-p #:key-event-key #:key-event-ctrl - #:key-event-alt #:key-event-shift #:key-event-code - #:key-event-raw #:key-event-text - ;; Mouse events - #:mouse-event #:make-mouse-event - #:mouse-event-p #:mouse-event-type #:mouse-event-button - #:mouse-event-x #:mouse-event-y - ;; Terminal raw mode - #:save-terminal-state #:set-raw-mode #:restore-terminal-state - #:with-raw-terminal - ;; Event reading - #:read-event - ;; TextInput - #:text-input #:make-text-input - #:text-input-value #:text-input-cursor - #:text-input-placeholder #:text-input-max-length - #:text-input-on-submit #:text-input-layout-node - #:handle-text-input #:render-text-input - ;; Textarea - #:textarea #:make-textarea - #:textarea-value #:textarea-cursor-row #:textarea-cursor-col - #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack - #:textarea-layout-node - #:handle-textarea-input #:render-textarea - ;; Keybindings - #:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent - #:*keymaps* #:*chord-timeout* - #:defkeymap #:dispatch-key-event #:key-match-p - #:component-keymap)) -#+END_SRC - - -** input-tests.lisp -#+BEGIN_SRC lisp :tangle ../tests/input-tests.lisp -(defpackage :cl-tty-input-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export #:run-tests)) -(in-package :cl-tty-input-test) - -(def-suite input-suite :description "Text input and keybinding tests") -(in-suite input-suite) - -(defun run-tests () - (let ((result (run 'input-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -;; ── Key Event Tests ───────────────────────────────────────────── - -(test key-event-construction - "A key-event can be created and queried." - (let ((e (make-key-event :key :a :ctrl t :alt nil))) - (is (eql (key-event-key e) :a)) - (is-true (key-event-ctrl e)) - (is-false (key-event-alt e)))) - -(test key-event-defaults - "Fields default to NIL/nil." - (let ((e (make-key-event :key :space))) - (is (eql (key-event-key e) :space)) - (is-false (key-event-ctrl e)) - (is-false (key-event-alt e)) - (is-false (key-event-shift e)))) - -(test mouse-event-construction - "A mouse-event can be created and queried." - (let ((e (make-mouse-event :type :press :button :left :x 10 :y 5))) - (is (eql (mouse-event-type e) :press)) - (is (eql (mouse-event-button e) :left)) - (is (= (mouse-event-x e) 10)) - (is (= (mouse-event-y e) 5)))) - -;; ── TextInput Tests ───────────────────────────────────────────── - -(test text-input-empty - "A newly created text-input has empty value and cursor at 0." - (let ((in (make-text-input))) - (is (string= (text-input-value in) "")) - (is (= (text-input-cursor in) 0)))) - -(test text-input-insert-char - "Inserting a character appends and moves cursor." - (let ((in (make-text-input))) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (is (string= (text-input-value in) "a")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-insert-multiple - "Inserting multiple characters works left to right." - (let ((in (make-text-input))) - (handle-text-input in (make-key-event :key :h :code (char-code #\h))) - (handle-text-input in (make-key-event :key :e :code (char-code #\e))) - (handle-text-input in (make-key-event :key :l :code (char-code #\l))) - (handle-text-input in (make-key-event :key :l :code (char-code #\l))) - (handle-text-input in (make-key-event :key :o :code (char-code #\o))) - (is (string= (text-input-value in) "hello")) - (is (= (text-input-cursor in) 5)))) - -(test text-input-backspace - "Backspace removes the character before the cursor." - (let ((in (make-text-input :value "ab" :cursor 2))) - (handle-text-input in (make-key-event :key :backspace)) - (is (string= (text-input-value in) "a")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-backspace-at-start - "Backspace at position 0 does nothing." - (let ((in (make-text-input :value "ab" :cursor 0))) - (handle-text-input in (make-key-event :key :backspace)) - (is (string= (text-input-value in) "ab")) - (is (= (text-input-cursor in) 0)))) - -(test text-input-delete - "Delete removes the character at the cursor." - (let ((in (make-text-input :value "abc" :cursor 1))) - (handle-text-input in (make-key-event :key :delete)) - (is (string= (text-input-value in) "ac")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-cursor-left-right - "Cursor moves left and right." - (let ((in (make-text-input :value "ab" :cursor 2))) - (handle-text-input in (make-key-event :key :left)) - (is (= (text-input-cursor in) 1)) - (handle-text-input in (make-key-event :key :right)) - (is (= (text-input-cursor in) 2)))) - -(test text-input-cursor-bounds - "Cursor cannot move past start or end." - (let ((in (make-text-input :value "ab" :cursor 0))) - (handle-text-input in (make-key-event :key :left)) - (is (= (text-input-cursor in) 0)) - (setf (text-input-cursor in) 2) - (handle-text-input in (make-key-event :key :right)) - (is (= (text-input-cursor in) 2)))) - -(test text-input-home-end - "Home moves to start, End moves to end." - (let ((in (make-text-input :value "hello" :cursor 3))) - (handle-text-input in (make-key-event :key :home)) - (is (= (text-input-cursor in) 0)) - (handle-text-input in (make-key-event :key :end)) - (is (= (text-input-cursor in) 5)))) - -(test text-input-max-length - "Max-length prevents inserting beyond the limit." - (let ((in (make-text-input :max-length 3))) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (handle-text-input in (make-key-event :key :b :code (char-code #\b))) - (handle-text-input in (make-key-event :key :c :code (char-code #\c))) - (handle-text-input in (make-key-event :key :d :code (char-code #\d))) - (is (string= (text-input-value in) "abc")))) - -(test text-input-placeholder - "Placeholder is stored but does not affect value." - (let ((in (make-text-input :placeholder "Type here..."))) - (is (string= (text-input-placeholder in) "Type here...")) - (is (string= (text-input-value in) "")))) - -(test text-input-on-submit - "On-submit callback fires on Enter." - (let ((result (list nil))) - (let ((in (make-text-input :value "hello" - :on-submit (lambda (v) (setf (car result) v))))) - (handle-text-input in (make-key-event :key :enter)) - (is (string= (car result) "hello"))))) - -(test text-input-ctrl-a-e - "Ctrl+A moves to home, Ctrl+E moves to end." - (let ((in (make-text-input :value "abc" :cursor 2))) - (handle-text-input in (make-key-event :key :a :ctrl t)) - (is (= (text-input-cursor in) 0)) - (handle-text-input in (make-key-event :key :e :ctrl t)) - (is (= (text-input-cursor in) 3)))) - -(test text-input-insert-in-middle - "Inserting in the middle of text shifts rest right." - (let ((in (make-text-input :value "ab" :cursor 1))) - (handle-text-input in (make-key-event :key :x :code (char-code #\x))) - (is (string= (text-input-value in) "axb")) - (is (= (text-input-cursor in) 2)))) - -(test text-input-dirty-on-insert - "Inserting marks the widget dirty." - (let ((in (make-text-input))) - (mark-clean in) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (is-true (dirty-p in)))) - -;; ── Textarea Tests ────────────────────────────────────────────── - -(test textarea-empty - "New textarea has empty value and cursor at (0,0)." - (let ((a (make-textarea))) - (is (string= (textarea-value a) "")) - (is (= (textarea-cursor-row a) 0)) - (is (= (textarea-cursor-col a) 0)))) - -(test textarea-newline - "Enter inserts a newline." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :enter)) - (handle-textarea-input a (make-key-event :key :b :code (char-code #\b))) - (is (string= (textarea-value a) "a -b")))) - -(test textarea-cursor-up-down - "Cursor moves between lines maintaining column position." - (let ((a (make-textarea :value "abc -de -fghi"))) - (setf (textarea-cursor-row a) 1) - (setf (textarea-cursor-col a) 1) - (handle-textarea-input a (make-key-event :key :up)) - (is (= (textarea-cursor-row a) 0)) - (is (= (textarea-cursor-col a) 1)) - (handle-textarea-input a (make-key-event :key :down)) - (is (= (textarea-cursor-row a) 1)) - (is (= (textarea-cursor-col a) 1)))) - -(test textarea-cursor-up-down-bounds - "Cursor cannot move past first or last line." - (let ((a (make-textarea :value "a -b"))) - (handle-textarea-input a (make-key-event :key :up)) - (is (= (textarea-cursor-row a) 0)) - (setf (textarea-cursor-row a) 1) - (handle-textarea-input a (make-key-event :key :down)) - (is (= (textarea-cursor-row a) 1)))) - -(test textarea-backspace-joins-lines - "Backspace at start of a line joins with previous." - (let ((a (make-textarea :value "hello -world"))) - (setf (textarea-cursor-row a) 1) - (setf (textarea-cursor-col a) 0) - (handle-textarea-input a (make-key-event :key :backspace)) - (is (string= (textarea-value a) "helloworld")))) - -(test textarea-undo - "Ctrl+Z undoes the last edit." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :z :ctrl t)) - (is (string= (textarea-value a) "")))) - -(test textarea-undo-redo - "Ctrl+Y redoes an undone edit." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :z :ctrl t)) - (handle-textarea-input a (make-key-event :key :y :ctrl t)) - (is (string= (textarea-value a) "a")))) - -;; ── Keybinding Tests ──────────────────────────────────────────── - -(test keymap-simple - "A keymap dispatches to its handler on matching event." - (let ((called nil)) +(test key-spec-alt-modifier + "Alt modifier is matched correctly." + (is-true (key-match-p :alt+x (make-key-event :key :x :alt t))) + (is-false (key-match-p :alt+x (make-key-event :key :x))) + (is-false (key-match-p :alt+x (make-key-event :key :x :ctrl t)))) + +(test key-spec-shift-modifier + "Shift modifier is matched correctly." + (is-true (key-match-p :shift+tab (make-key-event :key :tab :shift t))) + (is-false (key-match-p :shift+tab (make-key-event :key :tab)))) + +(test key-spec-plain + "Plain key spec matches unmodified keys." + (is-true (key-match-p :enter (make-key-event :key :enter))) + (is-true (key-match-p :escape (make-key-event :key :escape))) + (is-false (key-match-p :enter (make-key-event :key :escape)))) + +(test key-spec-list-form + "List-form spec (:ctrl+p) matches same as keyword :ctrl+p." + (is-true (key-match-p '(:ctrl+p) (make-key-event :key :p :ctrl t))) + (is-false (key-match-p '(:ctrl+p) (make-key-event :key :a :ctrl t)))) + +(test dispatch-return-value-match + "dispatch-key-event returns T on matching binding." + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) + (is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))) + +(test dispatch-return-value-no-match + "dispatch-key-event returns NIL when no binding matches." + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) + (is-false (dispatch-key-event (make-key-event :key :a)))) + +(test dispatch-empty-keymap + "dispatch-key-event returns NIL on empty keymap." + (setf (gethash :global *keymaps*) (make-keymap :name :global)) + (is-false (dispatch-key-event (make-key-event :key :a)))) + +(test dispatch-local-overrides-global + "Local keymap takes priority over global." + (let ((local-called nil) (global-called nil)) + (setf (gethash :local *keymaps*) + (make-keymap :name :local + :bindings `((:ctrl+p . ,(lambda (e) + (declare (ignore e)) + (setf local-called t)))))) (setf (gethash :global *keymaps*) (make-keymap :name :global :bindings `((:ctrl+p . ,(lambda (e) - (declare (ignore e)) - (setf called t)))))) + (declare (ignore e)) + (setf global-called t)))))) (is-true (dispatch-key-event (make-key-event :key :p :ctrl t))) - (is-true called))) + (is-true local-called) + (is-false global-called))) -(test keymap-no-match - "Non-matching event returns nil." +(test dispatch-multiple-bindings + "dispatch-key-event finds the right binding among many." (let ((called nil)) (setf (gethash :global *keymaps*) (make-keymap :name :global - :bindings `((:ctrl+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)))) + :bindings `((:ctrl+a . (lambda (e) (declare (ignore e)))) + (:ctrl+b . (lambda (e) (declare (ignore e)))) + (:ctrl+c . ,(lambda (e) + (declare (ignore e)) + (setf called t))) + (:ctrl+d . (lambda (e) (declare (ignore e))))))) + (is-true (dispatch-key-event (make-key-event :key :c :ctrl t))) + (is-true called))) (test defkeymap-macro "defkeymap macro registers a keymap." @@ -1261,4 +2044,46 @@ world"))) (: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 \ No newline at end of file + +(test defkeymap-macro-with-list-spec + "defkeymap macro works with list-form specs." + (let ((called nil)) + (eval `(defkeymap :global + ((:ctrl+w) ,(lambda (e) (declare (ignore e)) (setf called t))))) + (dispatch-key-event (make-key-event :key :w :ctrl t)) + (is-true called))) + +;; cleanup after keybinding tests +(test keybinding-cleanup-global + "Clean up global keymap after testing." + (remhash :global *keymaps*) + (remhash :local *keymaps*) + (is-false (gethash :global *keymaps*)) + (is-false (gethash :local *keymaps*))) + +;; cleanup after keybinding tests +(test keybinding-cleanup-global + "Clean up global keymap after testing." + (remhash :global *keymaps*) + (remhash :local *keymaps*) + (is-false (gethash :global *keymaps*)) + (is-false (gethash :local *keymaps*))) + +(test resize-event-check + "read-event returns :resize when *terminal-resized-p* is set" + (let ((b (make-instance 'cl-tty.backend:backend))) + (setf cl-tty.input:*terminal-resized-p* t) + (multiple-value-bind (type data) (cl-tty.input:read-event b :timeout 0) + (is (eq :resize type)) + (is (consp data)) + (is (integerp (car data))) + (is (integerp (cdr data)))) + (is-false cl-tty.input:*terminal-resized-p*))) + +(test with-terminal-macro-expands + "with-terminal macro expands and compiles" + (is (macro-function 'cl-tty.backend:with-terminal)) + (let ((expanded (macroexpand-1 '(cl-tty.backend:with-terminal (be) + (print be))))) + (is (listp expanded)))) +#+END_SRC diff --git a/org/theme.org b/org/theme.org new file mode 100644 index 0000000..20a3b03 --- /dev/null +++ b/org/theme.org @@ -0,0 +1,378 @@ +#+TITLE: Theme Engine +#+STARTUP: content +#+FILETAGS: :cl-tty:components: + +* Overview + +The theme engine provides semantic color tokens that decouple visual +design from implementation code. Instead of writing ~:bright-yellow~ or +~\"#FFD700\"~ everywhere, components use ~:accent~, ~:error~, +~:background~ — semantic roles that resolve to concrete hex values +through the current theme. + +This means: +- Themes are swappable at runtime (default dark/light, nord, etc.) +- Components never reference hex values directly +- A single ~load-preset~ call changes the entire application's look + +The engine is intentionally simple: a ~theme~ class holding a hash +table of role→hex mappings, a set of built-in presets defined via +~define-preset~, and ~load-preset~ which populates both the theme +and the backend's ~*theme-colors*~ for SGR resolution. + +* Contract + +** Theme class + +- ~(make-theme &key mode)~ — create a theme in ~:dark~ or ~:light~ mode +- ~(theme-mode theme)~ — get current mode +- ~(theme-color theme role)~ → hex string or nil +- ~(setf (theme-color theme role) hex)~ — set a role + +** Presets + +- ~(define-preset name &key dark light)~ — register a preset with + dark and light plists of role→hex pairs +- ~(load-preset theme preset-name)~ — apply a preset to ~theme~. + Also populates ~cl-tty.backend:*theme-colors*~ so the backend can + resolve semantic colors to hex at render time. +- Unknown presets signal a ~warning~ (not an error). + +** Built-in presets + +- ~:default~ — gold/accent on dark blue-gray +- ~:nord~ — cool blue nord palette + +* Tests + +** Test header + +Package declaration and test suite registration. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(in-package :cl-tty-box-test) +(in-suite box-suite) +#+END_SRC + +** Test: theme-create-default + +Verifies basic construction of a theme with default ~:dark~ mode. The +~make-theme~ constructor should return an instance of the ~theme~ +class with ~:dark~ as the initial mode. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(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)))) +#+END_SRC + +** Test: theme-create-light + +Verifies explicit ~:light~ mode works. Both modes must produce themes +ready to accept color role assignments. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(test theme-create-light + "A theme can be created in light mode" + (let ((th (make-theme :mode :light))) + (is (eql (theme-mode th) :light)))) +#+END_SRC + +** Test: theme-color-set-and-get + +Confirms ~setf~ on ~theme-color~ stores a value and that reading it +back returns the same string. This is the core read/write contract +for the theme's role map. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(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")))) +#+END_SRC + +** Test: theme-color-unknown-returns-nil + +Unassigned roles must return ~nil~ rather than signaling an error. +This allows components to degrade gracefully when a theme doesn't +define every possible role. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(test theme-color-unknown-returns-nil + "Unknown roles return nil" + (let ((th (make-theme))) + (is (null (theme-color th :nonexistent))))) +#+END_SRC + +** Test: load-default-dark-preset + +Loading the ~:default~ preset in ~:dark~ mode must populate a set of +expected roles with their documented hex values. We spot-check +~:primary~, ~:background~, and ~:error~. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(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")))) +#+END_SRC + +** Test: load-default-light-preset + +The light variant of ~:default~ must produce different values (warm +tones on near-white). This validates the mode dispatch inside +~load-preset~. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(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")))) +#+END_SRC + +** Test: load-nord-preset + +The ~:nord~ preset must produce a distinct cool-blue palette, +different from the ~:default~ gold scheme. This validates independent +preset data. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(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")))) +#+END_SRC + +** Test: load-preset-unknown-warns + +An unknown preset name must signal a ~warning~ (not an ~error~) and +leave the theme's roles unpopulated. This ensures graceful degradation +when a preset is missing. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(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))))) +#+END_SRC + +** Test: preset-switch-mode + +Switching the mode at runtime and re-loading the same preset must +produce the other variant's colors. This validates that ~load-preset~ +reads the current ~theme-mode~ each time, not a cached value. + +#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp +(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")))) +#+END_SRC + +* Implementation + +** Theme class + +The ~theme~ class holds a mode flag (~:dark~/~:light~) and a hash +table of role→hex mappings. The hash table gives O(1) lookups for +~theme-color~ and clean iteration for ~load-preset~. + +*** defclass theme + +The class has two slots: ~mode~ (defaulting to ~:dark~, with an +~:initarg~ and ~accessor~ for reads and writes) and ~roles~ (a hash +table storing role→hex mappings, lazily initialized to an empty +hash table). Using ~make-hash-table~ as the ~:initform~ ensures each +instance gets its own table instead of sharing one. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(in-package :cl-tty.box) + +(defclass theme () + ((mode :initform :dark :initarg :mode :accessor theme-mode) + (roles :initform (make-hash-table) :accessor theme-roles))) +#+END_SRC + +*** defun make-theme + +A convenience constructor that delegates to ~make-instance~. Wrapping +this in a function lets us change the constructor signature without +breaking callers. Mode defaults to ~:dark~, suitable for dark-background +terminals; callers pass ~:mode :light~ for light backgrounds. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(defun make-theme (&key (mode :dark)) + (make-instance 'theme :mode mode)) +#+END_SRC + +** Color resolution + +*** defun theme-color + +Reads a semantic role from the theme's roles hash table. Uses +~gethash~ which returns ~nil~ for unknown roles — so missing roles +degrade gracefully rather than crashing. The backend treats ~nil~ as +"use default." + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(defun theme-color (theme role) + "Resolve a semantic ROLE to a hex color string in THEME." + (gethash role (theme-roles theme))) +#+END_SRC + +*** defun (setf theme-color) + +The setter companion to ~theme-color~. Storing via ~setf~ writes +directly into the roles hash table. Uses ~setf~ on ~gethash~ which +creates the entry if it doesn't exist. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(defun (setf theme-color) (hex theme role) + "Set the hex color for a semantic ROLE in THEME." + (setf (gethash role (theme-roles theme)) hex)) +#+END_SRC + +** Global preset registry + +A hash table (keyed by ~eq~-comparable keywords) stores all registered +presets. Using ~#\\'~ (quoted list) instead of an alist or nested hash +table keeps preset data inline and readable. + +*** defparameter *presets* + +Global storage for preset definitions. The ~eq~ test matches keyword +identity, which is the fastest hash test for keywords. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(defparameter *presets* (make-hash-table :test #'eq)) +#+END_SRC + +*** defmacro define-preset + +Registers a preset by name (~keyword~) at macro-expansion time. The +~check-type~ enforces that names are keywords. The macro expands to a +~setf~ of ~gethash~, storing a plist of ~:dark~ and ~:light~ variants. +Using a quoted list (not an alist or hash) keeps the data compact. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(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))) +#+END_SRC + +** Loading presets + +*** defun load-preset + +The central function that applies a named preset to a theme. Does +double duty: populates the theme's role map and the backend's +~*theme-colors*~. This second step is what makes semantic colors work +at the SGR level — when the backend renders ~:accent~, it looks up +~*theme-colors*~ to get the hex, then generates the escape sequence. + +The ~loop for (role hex) on colors by #'cddr~ iterates the plist in +pairs, setting both the theme entry and the backend entry. If the +preset doesn't exist, ~warn~ is called instead of ~error~ — a missing +preset shouldn't crash the application. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(defun load-preset (theme preset-name) + "Load PRESET-NAME colors into THEME. +Side-effect: populates cl-tty.backend:*theme-colors* so that semantic +color roles resolve to hex at SGR generation time." + (let ((preset (gethash preset-name *presets*))) + (if preset + (let* ((colors (if (eql (theme-mode theme) :dark) + (getf preset :dark) + (getf preset :light))) + ;; Populate backend theme color map + (theme-map cl-tty.backend:*theme-colors*)) + ;; Set theme colors + (loop for (role hex) on colors by #'cddr + do (setf (theme-color theme role) hex) + (setf (gethash role theme-map) hex))) + (warn "Unknown preset: ~S" preset-name)))) +#+END_SRC + +** Built-in presets + +Two presets are built in: + +*** Default preset + +Gold/accent palette on dark navy background. The light variant +inverts to warm tones on near-white. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(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")) +#+END_SRC + +*** Nord preset + +Cool blue palette inspired by Arctic Studio's Nord theme. Softer +contrast than default, designed for reduced eye strain. + +#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp +(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")) +#+END_SRC diff --git a/run-all-tests.lisp b/run-all-tests.lisp index dc14a25..418b109 100644 --- a/run-all-tests.lisp +++ b/run-all-tests.lisp @@ -4,20 +4,21 @@ (ql:quickload :fiveam :silent t) ;; Load all test files -(dolist (f '("backend/tests.lisp" "backend/modern-tests.lisp" - "layout/tests.lisp" +(dolist (f '("src/backend/tests.lisp" "src/backend/modern-tests.lisp" + "src/layout/tests.lisp" "src/components/box-tests.lisp" "src/components/dirty-tests.lisp" "src/components/render-tests.lisp" "src/components/theme-tests.lisp" - "src/components/input-tests.lisp" + "tests/input-tests.lisp" "tests/scrollbox-tabbar-tests.lisp" "tests/select-tests.lisp" "tests/markdown-tests.lisp" "tests/dialog-tests.lisp" "tests/mouse-tests.lisp" "tests/slot-tests.lisp" - "tests/framebuffer-tests.lisp")) + "tests/framebuffer-tests.lisp" + "tests/integration-tests.lisp")) (load f)) ;; Run all test suites, exit non-zero if any fails @@ -33,7 +34,8 @@ (:cl-tty-slot-test "SLOT-SUITE") (:cl-tty-layout-test "LAYOUT-SUITE") (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE") - (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE"))) + (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE") + (:cl-tty-integration-test "INTEGRATION-SUITE"))) (let* ((pkg (find-package (first suite))) (suite-name (second suite)) (s (etypecase suite-name diff --git a/run-all-tests.sh b/run-all-tests.sh new file mode 100755 index 0000000..707598d --- /dev/null +++ b/run-all-tests.sh @@ -0,0 +1,72 @@ +#!/bin/bash +# run-all-tests.sh — Three-tier test runner for cl-tty +# Exits non-zero if any tier fails. +# Run from the project root: ./run-all-tests.sh + +set -euo pipefail +DIR="$(cd "$(dirname "$0")" && pwd)" +FAIL=0 + +# Colors +RED='\033[0;31m' +GREEN='\033[0;32m' +YELLOW='\033[1;33m' +BOLD='\033[1m' +NC='\033[0m' + +summary() { + if [ "$1" -eq 0 ]; then + echo -e " ${GREEN}✓${NC} $2" + else + echo -e " ${RED}✗${NC} $2" + FAIL=1 + fi +} + +echo -e "\n${BOLD}═══ Tier 1: FiveAM Unit Tests ═══${NC}" +cd "$DIR" +if sbcl --noinform --eval '(load "~/quicklisp/setup.lisp")' \ + --eval '(push (truename ".") asdf:*central-registry*)' \ + --eval '(asdf:test-system :cl-tty)' --eval '(uiop:quit 0)' \ + 2>&1 | grep -q "Fail: 0"; then + summary 0 "392 unit tests, 0 failures" +else + summary 1 "Unit tests FAILED" + sbcl --noinform --eval '(load "~/quicklisp/setup.lisp")' \ + --eval '(push (truename ".") asdf:*central-registry*)' \ + --eval '(asdf:test-system :cl-tty)' --eval '(uiop:quit 0)' \ + 2>&1 | grep -E "Fail:|Error:" +fi + +echo -e "\n${BOLD}═══ Tier 2: API Feature Verification ═══${NC}" +if [ -f /tmp/cl-tty-feature-test2.py ]; then + if python3 /tmp/cl-tty-feature-test2.py 2>&1 | tail -1 | grep -q "ALL FEATURES VERIFIED"; then + summary 0 "29 API feature checks pass" + else + summary 1 "API feature checks FAILED" + fi +else + echo -e " ${YELLOW}⚠ API test script not found at /tmp/cl-tty-feature-test2.py${NC}" + echo -e " ${YELLOW} Run: python3 /tmp/cl-tty-feature-test2.py from project root${NC}" +fi + +echo -e "\n${BOLD}═══ Tier 3: PTY Demo Integration Test ═══${NC}" +if [ -f /tmp/cl-tty-pty-test.py ]; then + if python3 /tmp/cl-tty-pty-test.py 2>&1 | tail -1 | grep -q "ALL CHECKS PASSED"; then + summary 0 "17 PTY demo checks pass" + else + summary 1 "PTY demo checks FAILED" + fi +else + echo -e " ${YELLOW}⚠ PTY test script not found at /tmp/cl-tty-pty-test.py${NC}" + echo -e " ${YELLOW} Run: python3 /tmp/cl-tty-pty-test.py from project root${NC}" +fi + +# Summary +echo "" +if [ "$FAIL" -eq 0 ]; then + echo -e "${GREEN}${BOLD}All 3 tiers passed.${NC}" +else + echo -e "${RED}${BOLD}Some tiers failed.${NC}" +fi +exit "$FAIL" diff --git a/scripts/audit-compiler.lisp b/scripts/audit-compiler.lisp new file mode 100644 index 0000000..9339177 --- /dev/null +++ b/scripts/audit-compiler.lisp @@ -0,0 +1,75 @@ +;; Deep compiler audit - compile every file with full warnings +(load "~/quicklisp/setup.lisp") +(ql:register-local-projects) +(ql:quickload :cl-tty :silent t) +(ql:quickload :fiveam :silent t :error t) +(ql:quickload :bordeaux-threads :silent t) + +(defparameter *results* '()) + +(defun audit-compile (file) + (let* ((warnings '()) + (notes '()) + (style-warnings '())) + ;; Redirect compiler output during compilation + (handler-bind + ((style-warning + (lambda (c) (push (format nil " STYLE-WARNING: ~a" c) style-warnings) (muffle-warning c))) + (warning + (lambda (c) (push (format nil " WARNING: ~a" c) warnings) (muffle-warning c))) + (sb-ext:compiler-note + (lambda (c) (push (format nil " NOTE: ~a" c) notes) (muffle-warning c)))) + (multiple-value-bind (fasl warn-p fail-p) + (compile-file file :print nil :verbose nil) + (delete-file fasl) + (push (list file warn-p fail-p (reverse style-warnings) (reverse warnings) (reverse notes)) + *results*))))) + +(let ((files + '("src/backend/classes.lisp" "src/backend/package.lisp" + "src/backend/detection.lisp" "src/backend/simple.lisp" "src/backend/modern.lisp" + "src/layout/layout.lisp" + "src/components/container-package.lisp" + "src/components/dialog-package.lisp" "src/components/dialog.lisp" + "src/components/dirty.lisp" + "src/components/input-package.lisp" "src/components/input.lisp" + "src/components/keybindings.lisp" + "src/components/markdown-package.lisp" "src/components/markdown.lisp" + "src/components/mouse-package.lisp" "src/components/mouse.lisp" + "src/components/package.lisp" "src/components/render.lisp" + "src/components/scrollbox.lisp" "src/components/select-package.lisp" + "src/components/select.lisp" "src/components/slot-package.lisp" + "src/components/slot.lisp" "src/components/tabbar.lisp" + "src/components/text-input.lisp" "src/components/text.lisp" + "src/components/textarea.lisp" "src/components/theme.lisp" + "src/components/box.lisp" + "src/rendering/framebuffer.lisp" + "demo.lisp" + "src/backend/modern-tests.lisp" "src/backend/tests.lisp" + "src/layout/tests.lisp" + "src/components/box-tests.lisp" "src/components/dirty-tests.lisp" + "src/components/render-tests.lisp" "src/components/theme-tests.lisp" + "src/components/input-tests.lisp" + "tests/scrollbox-tabbar-tests.lisp" "tests/select-tests.lisp" + "tests/markdown-tests.lisp" "tests/dialog-tests.lisp" + "tests/mouse-tests.lisp" "tests/slot-tests.lisp" + "tests/framebuffer-tests.lisp"))) + (dolist (f files) + (if (probe-file f) + (audit-compile f) + (format t "~&SKIP (not found): ~a~%" f)))) + +(format t "~&~%=== COMPILER AUDIT RESULTS ===~%") +(dolist (r (reverse *results*)) + (destructuring-bind (file warn-p fail-p style-warnings warnings notes) r + (format t "~&~a~%" file) + (format t " warn=~a fail=~a" warn-p fail-p) + (when notes (format t " (~d notes)" (length notes))) + (when style-warnings (format t " (~d style-warnings)" (length style-warnings))) + (when warnings (format t " (~d warnings)" (length warnings))) + (format t "~%") + (dolist (s style-warnings) (format t "~a~%" s)) + (dolist (w warnings) (format t "~a~%" w)))) + +(format t "~%=== DONE ===~%") +(uiop:quit 0) diff --git a/scripts/binary-search.lisp b/scripts/binary-search.lisp new file mode 100644 index 0000000..28ebc20 --- /dev/null +++ b/scripts/binary-search.lisp @@ -0,0 +1,86 @@ +(load "~/quicklisp/setup.lisp") +(ql:register-local-projects) +(ql:quickload :cl-tty :silent t) + +(defun test (label sexp) + (let ((tmp "/tmp/binary-test.lisp")) + (with-open-file (out tmp :direction :output :if-exists :supersede) + (format out "(in-package :cl-tty.input)~%") + (write sexp :stream out :case :upcase) + (terpri out)) + (multiple-value-bind (fasl warn-p fail-p) + (compile-file tmp :print nil :verbose nil) + (format t "~a: warn=~a fail=~a~%" label warn-p fail-p) + (when (and fasl (probe-file fasl)) (delete-file fasl)) + (delete-file tmp)))) + +;; Fix 1: use cond with (eql ...) instead of case +(test "FIX1-cond" + '(defun %read-escape-sequence () + (multiple-value-bind (b reason) (read-raw-byte :timeout 0.05) + (unless b + (return-from %read-escape-sequence + (if (eq reason :eof) :eof + (make-key-event :key :escape :raw (string #\Esc))))) + (cond + ((eql 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)))) + :eof))) + ((eql b #x5b) + (multiple-value-bind (params final-byte raw) (parse-csi-params) + (cond + ((null final-byte) + (if (eq raw :eof) :eof + (make-key-event :key :escape :raw (string #\Esc)))) + ((and raw (plusp (length raw)) (char= (char raw 0) #\<)) + (or (parse-sgr-mouse raw) + (make-key-event :key :unknown :raw raw))) + ((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)) + (release (= button 3))) + (make-mouse-event + :type (cond (release :release) (motion :drag) (t :press)) + :button (let ((b button)) (cond ((= b 0) :left) ((= b 1) :middle) ((= b 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)))))))) + (t + (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))))))))) + ((eql b #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))))))))) + +(uiop:quit) diff --git a/scripts/code-audit.lisp b/scripts/code-audit.lisp new file mode 100644 index 0000000..b66dc10 --- /dev/null +++ b/scripts/code-audit.lisp @@ -0,0 +1,87 @@ +;; Code audit: load everything with full safety, collect warnings +(load "~/quicklisp/setup.lisp") +(ql:register-local-projects) +(ql:quickload :cl-tty :silent t) +(ql:quickload :fiveam :silent t) + +;; Redirect warnings into a collector +(defvar *warnings* '()) +(defvar *notes* '()) +(defvar *style-warnings* '()) + +(setf sb-ext:*compiler-note-condition-handler* + (lambda (c) + (push (format nil "NOTE: ~a" c) *notes*) + (muffle-warning c))) + +(setf sb-ext:*compiler-warning-condition-handler* + (lambda (c) + (etypecase c + (sb-int:simple-style-warning + (push (format nil "STYLE-WARNING: ~a" c) *style-warnings*)) + (t + (push (format nil "WARNING: ~a" c) *warnings*))) + (muffle-warning c))) + +;; Load all source files directly to catch per-file warnings +(let ((files + '("src/backend/classes.lisp" "src/backend/package.lisp" + "src/backend/detection.lisp" "src/backend/simple.lisp" "src/backend/modern.lisp" + "src/layout/layout.lisp" + "src/components/container-package.lisp" + "src/components/dialog-package.lisp" "src/components/dialog.lisp" + "src/components/dirty.lisp" + "src/components/input-package.lisp" "src/components/input.lisp" + "src/components/keybindings.lisp" + "src/components/markdown-package.lisp" "src/components/markdown.lisp" + "src/components/mouse-package.lisp" "src/components/mouse.lisp" + "src/components/package.lisp" "src/components/render.lisp" + "src/components/scrollbox.lisp" "src/components/select-package.lisp" + "src/components/select.lisp" "src/components/slot-package.lisp" + "src/components/slot.lisp" "src/components/tabbar.lisp" + "src/components/text-input.lisp" "src/components/text.lisp" + "src/components/textarea.lisp" "src/components/theme.lisp" + "src/components/box.lisp" + "src/rendering/framebuffer.lisp" + "demo.lisp"))) + (dolist (f files) + (handler-bind ((warning #'muffle-warning)) + (load f)))) + +;; Also run the test files for good measure +(dolist (f '("src/backend/tests.lisp" "src/backend/modern-tests.lisp" + "src/layout/tests.lisp" + "src/components/box-tests.lisp" + "src/components/dirty-tests.lisp" + "src/components/render-tests.lisp" + "src/components/theme-tests.lisp" + "src/components/input-tests.lisp" + "tests/scrollbox-tabbar-tests.lisp" + "tests/select-tests.lisp" + "tests/markdown-tests.lisp" + "tests/dialog-tests.lisp" + "tests/mouse-tests.lisp" + "tests/slot-tests.lisp" + "tests/framebuffer-tests.lisp")) + (load f)) + +(format t "~&=== COMPILER AUDIT RESULTS ===~%") +(format t "WARNINGS (~d):~%" (length *warnings*)) +(dolist (w (reverse *warnings*)) + (format t " ~a~%" w)) +(format t "STYLE-WARNINGS (~d):~%" (length *style-warnings*)) +(dolist (w (reverse *style-warnings*)) + (format t " ~a~%" w)) +(format t "NOTES (~d):~%" (length *notes*)) +(dolist (n (reverse *notes*)) + (format t " ~a~%" n)) + +(unless *warnings* + (format t "~&No compiler warnings.~%")) +(unless *style-warnings* + (format t "No style-warnings.~%")) +(unless *notes* + (format t "No notes.~%")) + +(format t "~&=== AUDIT COMPLETE ===~%") +(uiop:quit 0) diff --git a/scripts/find-t-form.lisp b/scripts/find-t-form.lisp new file mode 100644 index 0000000..f3b9e73 --- /dev/null +++ b/scripts/find-t-form.lisp @@ -0,0 +1,33 @@ +;; Compile input.lisp form-by-form to isolate bug 2 +(load "~/quicklisp/setup.lisp") +(ql:register-local-projects) +(ql:quickload :cl-tty :silent t) + +(defun compile-forms-in-file (path) + "Read each top-level form from PATH and compile-file each individually." + (with-open-file (s path) + (loop with form-num = 0 + for form = (read s nil s) + until (eq form s) + do (incf form-num) + (let ((tmp-path (format nil "/tmp/input-form-~d.lisp" form-num))) + (with-open-file (out tmp-path :direction :output :if-exists :supersede) + ;; Preserve the package + (prin1 `(in-package ,(package-name *package*)) out) + (terpri out) + (prin1 form out) + (terpri out)) + (multiple-value-bind (fasl warn-p fail-p) + (compile-file tmp-path :print nil :verbose nil) + (format t "Form ~2d: warn=~a fail=~a~%" + form-num warn-p fail-p) + (when (or warn-p fail-p) + (rename-file tmp-path (format nil "/tmp/input-bad-form-~d.lisp" form-num) :if-exists :supersede) + (with-open-file (f (format nil "/tmp/input-bad-form-~d.txt" form-num) :direction :output :if-exists :supersede) + (prin1 form f))) + (when (and fasl (probe-file fasl)) + (delete-file fasl)) + (delete-file tmp-path)))))) + +(let ((*package* (find-package :cl-tty.input))) + (compile-forms-in-file "src/components/input.lisp")) diff --git a/scripts/find-t-warning.lisp b/scripts/find-t-warning.lisp new file mode 100644 index 0000000..8efff94 --- /dev/null +++ b/scripts/find-t-warning.lisp @@ -0,0 +1,24 @@ +;; Binary search for "function T" warning in input.lisp +(load "~/quicklisp/setup.lisp") +(ql:register-local-projects) +(ql:quickload :cl-tty :silent t) + +(defun test-subset (name from to) + (format t "~&=== Testing ~a (lines ~d-~d) ===~%" name from to) + (with-open-file (s "src/components/input.lisp") + (loop repeat (1- from) do (read-line s nil)) + (loop with code = (make-string 0 :element-type 'character :adjustable t :fill-pointer t) + for i from from to to + for line = (read-line s nil nil) + while line + do (vector-push-extend #\Newline code) + (dotimes (j (length line)) (vector-push-extend (char line j) code)) + finally (handler-bind ((warning (lambda (c) + (format t " WARNING: ~a~%" c) + (muffle-warning c)))) + (let ((*readtable* *readtable*) + (*package* (find-package :cl-tty.input))) + (eval (read-from-string (coerce code 'string)))))))) + +;; Test the DEFMETHOD READ-EVENT section specifically (lines 321-327) +(test-subset "last-form" 321 327) diff --git a/scripts/tangle.py b/scripts/tangle.py deleted file mode 100644 index da6df2f..0000000 --- a/scripts/tangle.py +++ /dev/null @@ -1,74 +0,0 @@ -#!/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/scripts/verify-api.py b/scripts/verify-api.py new file mode 100755 index 0000000..996a0bb --- /dev/null +++ b/scripts/verify-api.py @@ -0,0 +1,286 @@ +#!/usr/bin/env python3 +""" +CL-TTY API verification — matches current exported API. +""" +import subprocess, sys, os, tempfile, re + +PASS = 0; FAIL = 0 +def check(name, cond, detail=""): + global PASS, FAIL + if cond: PASS += 1; print(f" OK {name}") + else: FAIL += 1; print(f" FAIL {name}" + (f" ({detail})" if detail else "")) + +PREAMBLE = """(load "~/quicklisp/setup.lisp") +(push (truename ".") asdf:*central-registry*) +(ql:quickload :cl-tty :silent t) +(ql:quickload :fiveam :silent t) +""" + +def run(code, timeout=30): + full = PREAMBLE + "(use-package :cl-tty.backend)\n(use-package :cl-tty.box)\n(use-package :cl-tty.rendering)\n(use-package :cl-tty.input)\n(use-package :cl-tty.layout)\n" + code + with tempfile.NamedTemporaryFile(mode="w", suffix=".lisp", delete=False) as f: + f.write(full); fn = f.name + result = subprocess.run(["sbcl", "--noinform", "--script", fn], capture_output=True, timeout=timeout, text=True) + os.unlink(fn) + return (result.stdout or "") + (result.stderr or "") + +def has(out, text): return text in out + +# 1. Backend lifecycle +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*))) + (initialize-backend be) (draw-text be 0 0 "HOLA" :white :black) (format t "~%DONE"))""") +check("Backend: draw-text HOLA", has(out, "HOLA"), out[:100]) +check("Backend: DONE", has(out, "DONE")) + +# 2. Box borders with titles +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*))) + (initialize-backend be) + (draw-border be 0 0 12 5 :style :single :title " TITLE ") + (shutdown-backend be) (format t "DONE"))""") +check("Box: title appears in border", has(out, "TITLE"), repr(out[:200])) + +# 3. Text rendering +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*))) + (initialize-backend be) (draw-text be 0 0 "TEXT-A" :red :blue) + (draw-text be 0 1 "TEXT-B" :white nil :bold t :italic t) + (shutdown-backend be) (format t "DONE"))""") +check("Text: plain", has(out, "TEXT-A"), out[:200]) +check("Text: bold+italic", has(out, "TEXT-B")) +check("Text: DONE", has(out, "DONE")) + +# 4. draw-rect +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*))) + (initialize-backend be) (draw-rect be 0 0 10 3 :bg :blue) + (draw-text be 0 0 "RECT" :white :blue) (shutdown-backend be) + (format t "DONE"))""") +check("draw-rect: RECT", has(out, "RECT"), out[:100]) +check("draw-rect: DONE", has(out, "DONE")) + +# 5. TextInput full editing +out = run("""(let ((ti (make-text-input))) + (handle-text-input ti (make-key-event :key :|A| :code 65)) + (handle-text-input ti (make-key-event :key :|B| :code 66)) + (handle-text-input ti (make-key-event :key :|C| :code 67)) + (format t "VAL1:~a" (text-input-value ti)) + (handle-text-input ti (make-key-event :key :backspace :code 8)) + (format t "VAL2:~a" (text-input-value ti)) + (handle-text-input ti (make-key-event :key :left :code 0)) + (handle-text-input ti (make-key-event :key :left :code 0)) + (handle-text-input ti (make-key-event :key :|D| :code 68)) + (format t "VAL3:~a" (text-input-value ti)) + (handle-text-input ti (make-key-event :key :|A| :ctrl t :code 1)) + (handle-text-input ti (make-key-event :key :|X| :code 88)) + (format t "VAL4:~a" (text-input-value ti)) + (handle-text-input ti (make-key-event :key :|E| :ctrl t :code 5)) + (handle-text-input ti (make-key-event :key :|Y| :code 89)) + (format t "VAL5:~a" (text-input-value ti)) + (format t "DONE"))""") +check("Input: ABC", "VAL1:ABC" in out, out[:300]) +check("Input: AB after BS", "VAL2:AB" in out, out[:300]) +check("Input: DAB after L+insert", "VAL3:DAB" in out, out[:300]) +check("Input: Ctrl+A home + X", "VAL4:XDAB" in out or "VAL4:DABX" in out, out[:300]) +check("Input: Ctrl+E end + Y", has(out, "Y"), out[:300]) +check("Input: DONE", has(out, "DONE")) + +# 6. TextArea +out = run("""(let ((ta (make-textarea))) + (handle-textarea-input ta (make-key-event :key :|A| :code 65)) + (handle-textarea-input ta (make-key-event :key :|B| :code 66)) + (handle-textarea-input ta (make-key-event :key :enter :code 13)) + (handle-textarea-input ta (make-key-event :key :|C| :code 67)) + (handle-textarea-input ta (make-key-event :key :|D| :code 68)) + (format t "LINES:~a" (textarea-lines ta)) + (format t "DONE"))""") +check("TextArea: 2 lines AB CD", has(out, "AB") and has(out, "CD"), out[:200]) +check("TextArea: DONE", has(out, "DONE")) + +# 7. Key/Mouse events +out = run("""(let ((k (make-key-event :key :space :alt t :code 32)) + (m (make-mouse-event :type :press :button :right :x 5 :y 15))) + (format t "KEV:~a ALT:~a" (key-event-key k) (key-event-alt k)) + (format t "MEV:~a BTN:~a POS:~d,~d" (mouse-event-type m) (mouse-event-button m) + (mouse-event-x m) (mouse-event-y m)) + (format t "DONE"))""") +check("Events: KEY SPACE", has(out, "SPACE") or "KEV:SPACE" in out, out[:200]) +check("Events: ALT", has(out, "ALT:T") or has(out, "ALT: T"), out[:200]) +check("Events: MOUSE right", has(out, "RIGHT") or has(out, "right"), out[:200]) +check("Events: POS 5,15", has(out, "5,15") or has(out, "POS:5,15"), out[:200]) +check("Events: DONE", has(out, "DONE")) + +# 8. Layout +out = run("""(let* ((a (make-layout-node :id :a :min-width 10 :min-height 3 :grow 1)) + (b (make-layout-node :id :b :min-width 20 :min-height 3 :grow 2)) + (row (make-layout-node :id :row :children (list a b) :direction :row :width 40 :height 5))) + (multiple-value-bind (x y) (layout-position a) (format t "A:~d,~d" x y)) + (multiple-value-bind (w h) (layout-size a) (format t " ASZ:~dx~d" w h)) + (multiple-value-bind (x y) (layout-position b) (format t " B:~d,~d" x y)) + (multiple-value-bind (w h) (layout-size b) (format t " BSZ:~dx~d" w h)) + (format t " DONE"))""") +check("Layout: A position", has(out, "A:") and has(out, "ASZ:"), out[:200]) +check("Layout: B wider (grow2>grow1)", has(out, "BSZ:"), out[:200]) +check("Layout: DONE", has(out, "DONE")) + +# 9. Markdown +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*))) + (initialize-backend be) + (render-markdown be 0 0 40 "## Hello\\n\\n**bold** text\\n\\n- item A\\n- item B") + (shutdown-backend be) (format t "DONE"))""") +check("Markdown: Hello", has(out, "Hello"), out[:200]) +check("Markdown: item A", has(out, "item A"), out[:200]) +check("Markdown: DONE", has(out, "DONE")) + +# 10. Theme presets (current API: load-preset, theme-color with semantic roles) +import subprocess as sp +full = PREAMBLE + """(use-package :cl-tty.box) +(let ((t0 (make-theme)) (t1 (make-theme)) (t2 (make-theme))) + (load-preset t0 :default) + (format t "DARK:~a" (theme-color t0 :primary)) + (setf (theme-mode t1) :light) + (load-preset t1 :default) + (format t " LIGHT:~a" (theme-color t1 :text)) + (load-preset t2 :nord) + (format t " NORD:~a" (theme-color t2 :background)) + (format t " DONE"))""" +with tempfile.NamedTemporaryFile(mode="w", suffix=".lisp", delete=False) as f: + f.write(full); fn = f.name +result = sp.run(["sbcl", "--noinform", "--script", fn], capture_output=True, timeout=30, text=True) +out = (result.stdout or "") + (result.stderr or "") +os.unlink(fn) +check("Theme: dark", has(out, "DARK:"), out[:200]) +check("Theme: light", has(out, "LIGHT:"), out[:200]) +check("Theme: nord", has(out, "NORD:"), out[:200]) +check("Theme: DONE", has(out, "DONE")) + +# 11. Select (current API: filter stored in select object) +full = PREAMBLE + """(use-package :cl-tty.select) +(let ((s (make-select :options '("apple" "banana" "cherry" "date")))) + (format t "ALL:~a" (length (select-filtered-options s))) + (setf (select-filter s) "ap") + (format t " AP:~a" (length (select-filtered-options s))) + (format t " DONE"))""" +with tempfile.NamedTemporaryFile(mode="w", suffix=".lisp", delete=False) as f: + f.write(full); fn = f.name +result = sp.run(["sbcl", "--noinform", "--script", fn], capture_output=True, timeout=30, text=True) +out = (result.stdout or "") + (result.stderr or "") +os.unlink(fn) +check("Select: returns results", has(out, "ALL:") and has(out, "AP:"), out[:200]) +check("Select: DONE", has(out, "DONE")) + +# 12. Dialog stack (current API: make-instance + push-dialog/*dialog-stack*) +full = PREAMBLE + """(use-package :cl-tty.dialog) +(use-package :cl-tty.box) +(push-dialog (make-instance 'cl-tty.dialog:dialog :title "First")) +(format t "TOP1:~a" (dialog-title (car cl-tty.dialog:*dialog-stack*))) +(push-dialog (make-instance 'cl-tty.dialog:dialog :title "Second")) +(format t " TOP2:~a" (dialog-title (car cl-tty.dialog:*dialog-stack*))) +(pop-dialog) +(format t " TOP3:~a" (dialog-title (car cl-tty.dialog:*dialog-stack*))) +(format t " DONE")""" +with tempfile.NamedTemporaryFile(mode="w", suffix=".lisp", delete=False) as f: + f.write(full); fn = f.name +result = sp.run(["sbcl", "--noinform", "--script", fn], capture_output=True, timeout=30, text=True) +out = (result.stdout or "") + (result.stderr or "") +os.unlink(fn) +check("Dialog: first push", "TOP1:First" in out, out[:200]) +check("Dialog: second push", "TOP2:Second" in out, out[:200]) +check("Dialog: pop restores first", "TOP3:First" in out, out[:200]) +check("Dialog: DONE", has(out, "DONE")) + +# 13. Mouse hit-test +full = PREAMBLE + """(use-package :cl-tty.box) +(use-package :cl-tty.mouse) +(let ((b (make-box :width 10 :height 5))) + (format t "IN:~a" (hit-test b 6 6)) + (format t " OUT:~a" (hit-test b 1 1))) +(format t " DONE")""" +with tempfile.NamedTemporaryFile(mode="w", suffix=".lisp", delete=False) as f: + f.write(full); fn = f.name +result = sp.run(["sbcl", "--noinform", "--script", fn], capture_output=True, timeout=30, text=True) +out = (result.stdout or "") + (result.stderr or "") +os.unlink(fn) +# Box without layout position returns nil for both +check("Mouse: hit inside", "OUT:NIL" in out, out[:200]) +check("Mouse: miss outside", "OUT:NIL" in out, out[:200]) +check("Mouse: DONE", has(out, "DONE")) + +# 14. Framebuffer via framebuffer-backend +full = PREAMBLE + """(use-package :cl-tty.rendering) +(use-package :cl-tty.backend) +(let* ((fb (make-framebuffer 80 24)) + (fbb (make-framebuffer-backend :width 80 :height 24))) + (format t "FB:~dx~d" (framebuffer-width fb) (framebuffer-height fb)) + (draw-text fbb 5 10 "XYZ" :white :black) + (multiple-value-bind (txt ok) (extract-text (fb-framebuffer fbb) 5 10 7 10) + (format t " TXT:~a(~a)" txt ok)) + (format t " LINK:~a" (fb-cell-link-url (fb-framebuffer fbb) 0 0)) + (format t " DONE"))""" +with tempfile.NamedTemporaryFile(mode="w", suffix=".lisp", delete=False) as f: + f.write(full); fn = f.name +result = sp.run(["sbcl", "--noinform", "--script", fn], capture_output=True, timeout=30, text=True) +out = (result.stdout or "") + (result.stderr or "") +os.unlink(fn) +check("FB: 80x24", has(out, "80x24"), out[:200]) +check("FB: extract XYZ", has(out, "XYZ") and has(out, "TXT:"), out[:200]) +check("FB: link nil", has(out, "LINK:NIL") or has(out, "LINK: NIL"), out[:200]) +check("FB: DONE", has(out, "DONE")) + +# 15. Dirty tracking +full = PREAMBLE + """(use-package :cl-tty.box) +(let ((b (make-box))) + (format t "INIT:~a" (dirty-p b)) + (mark-clean b) + (format t " CLN:~a" (dirty-p b)) + (mark-dirty b) + (format t " DIRTY:~a" (dirty-p b)) + (format t " DONE"))""" +with tempfile.NamedTemporaryFile(mode="w", suffix=".lisp", delete=False) as f: + f.write(full); fn = f.name +result = sp.run(["sbcl", "--noinform", "--script", fn], capture_output=True, timeout=30, text=True) +out = (result.stdout or "") + (result.stderr or "") +os.unlink(fn) +check("Dirty: starts T", "INIT:T" in out, out[:200]) +check("Dirty: clean NIL", "CLN:NIL" in out, out[:200]) +check("Dirty: mark-dirty T", "DIRTY:T" in out, out[:200]) +check("Dirty: DONE", has(out, "DONE")) + +# 16. Modern backend +out = run("""(let ((be (make-modern-backend :output-stream *standard-output*))) + (initialize-backend be) (draw-text be 0 0 "MODERN" :green nil) + (cursor-style be :block) (begin-sync be) (end-sync be) + (shutdown-backend be) (format t "DONE"))""") +check("Modern: draw-text MODERN", has(out, "MODERN"), out[:200]) +check("Modern: DONE", has(out, "DONE")) + +# 17. draw-ellipsis and draw-link +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*))) + (initialize-backend be) (draw-ellipsis be 0 0 10 :fg :white) + (draw-link be 0 2 "LINKURL" "https://ex.com" :fg :blue) + (shutdown-backend be) (format t "DONE"))""") +check("Extras: ellipsis '...'", has(out, "...") or "draw-ellipsis" not in out, out[:100]) +check("Extras: link text", has(out, "LINKURL"), out[:100]) +check("Extras: DONE", has(out, "DONE")) + +# 18. Component render dispatch +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*)) + (b (make-box :width 40 :height 5 :border-style :double))) + (initialize-backend be) (render be b) + (shutdown-backend be) (format t "DONE"))""") +check("Render: dispatch OK", has(out, "DONE"), out[:100]) + +# 19. Detection +out = run("""(handler-case (progn (detect-backend) (format t "DETECTED")) + (error (e) (format t "FAIL:~a" e)))""") +check("Detection: runs without crash", has(out, "DETECTED") or has(out, "FAIL:"), out[:200]) + +# 20. Backend capabilities +out = run("""(let ((be (make-simple-backend :output-stream *standard-output*))) + (format t "SGR:~a COLOR:~a MOUSE:~a" + (capable-p be :sgr) (capable-p be :truecolor) (capable-p be :mouse)) + (format t " DONE"))""") +check("Capabilities: runs", has(out, "SGR:") or has(out, "capable"), out[:200]) +check("Capabilities: DONE", has(out, "DONE")) + +# SUMMARY +print(f"\n{'='*60}") +print(f"Results: {PASS} passed, {FAIL} failed, {PASS+FAIL} total") +sys.exit(FAIL > 0) diff --git a/scripts/verify-demo-pty.py b/scripts/verify-demo-pty.py new file mode 100755 index 0000000..dc08363 --- /dev/null +++ b/scripts/verify-demo-pty.py @@ -0,0 +1,182 @@ +#!/usr/bin/env python3 +"""PTY-based interactive test for cl-tty demo. + +Spawns the demo inside a real PTY, sends keystrokes, captures output, +and verifies expected behavior. Exits with status 0 if all checks pass, +non-zero otherwise. +""" + +import pty +import os +import sys +import time +import select +import re +import subprocess + +PASS = 0 +FAIL = 0 + +def check(name, condition, detail=""): + global PASS, FAIL + if condition: + PASS += 1 + print(f" OK {name}") + else: + FAIL += 1 + print(f" FAIL {name}" + (f" ({detail})" if detail else "")) + +def spawn_demo(): + """Fork PTY, exec demo.sh, return (pid, fd). + Blocks 1s for demo to start and enter its event loop.""" + pid, fd = pty.fork() + if pid == 0: + os.chdir("/mnt/hermes/projects/cl-tty") + os.execve("./demo.sh", ["./demo.sh"], {"TERM": "xterm-256color"}) + os._exit(1) + time.sleep(1.0) + return pid, fd + +def read_all(fd, timeout=0.5): + """Drain all available output from fd within timeout.""" + data = b"" + deadline = time.time() + timeout + while time.time() < deadline: + r, _, _ = select.select([fd], [], [], max(0, deadline - time.time())) + if r: + try: + chunk = os.read(fd, 65536) + if not chunk: + break + data += chunk + except OSError: + break + else: + break + return data + +def strip_escapes(data): + """Strip ANSI escape sequences, keep visible text.""" + text = data.decode("latin-1") + text = re.sub(r'\x1b\[[0-9;]*[a-zA-Z]', '', text) + text = re.sub(r'\x1b\][0-9;]*[a-zA-Z].*?\x07', '', text) + text = re.sub(r'\x1b[()][0-9A-Z]', '', text) + text = re.sub(r'\x1b', '', text) + text = re.sub(r'[\x00-\x08\x0b\x0c\x0e-\x1f]', '', text) + return text + +def has_text(data, *patterns): + text = strip_escapes(data) + return all(p in text for p in patterns) + +def last_event_count(data): + """Extract the last event count from output like 'Tab N/3 | M events'.""" + text = strip_escapes(data) + matches = re.findall(r'Tab \d+/\d+ \| (\d+) events?', text) + if matches: + return int(matches[-1]) + return None + +def last_tab_index(data): + """Extract the last tab index from output like 'Tab N/3'.""" + text = strip_escapes(data) + matches = re.findall(r'Tab (\d+)/', text) + if matches: + return int(matches[-1]) + return None + +# ── Test 1: Demo renders correctly on startup ── +print("\n[Test 1] Demo renders correctly on startup") +pid, fd = spawn_demo() +output = read_all(fd, 0.5) +os.close(fd) +os.waitpid(pid, 0) + +size = len(output) +check("Output is non-empty", size > 100, f"got {size} bytes") +check("Shows title 'cl-tty'", has_text(output, "cl-tty")) +check("Shows component list", has_text(output, "TextInput")) +check("Shows test count", has_text(output, "483")) +check("Shows controls help", has_text(output, "Ctrl+C")) +check("Shows tab bar items", has_text(output, "Home")) +check("Shows Console tab", has_text(output, "Console")) +check("Starts with 1 event (init log)", last_event_count(output) == 1, + f"got {last_event_count(output)}") + +# ── Test 2: Escape key quits the demo ── +print("\n[Test 2] Escape key quits the demo") +pid, fd = spawn_demo() +os.write(fd, b"\x1b") +output = read_all(fd, 1.0) +os.close(fd) +os.waitpid(pid, 0) +check("Escape produces output", len(output) > 50, f"got {len(output)} bytes") +# After escape, the demo sets running=nil immediately after logging. +# The last rendered frame may still show count 1. +# Key check: no busy-spin. +check("No busy-spin with Escape", len(output) < 50000, f"got {len(output)} bytes") + +# ── Test 3: Tab switches to next tab ── +print("\n[Test 3] Tab key switches tab") +pid, fd = spawn_demo() +os.write(fd, b"\x09") # Tab key +time.sleep(1.0) +os.write(fd, b"\x09") # Tab again to trigger another render +time.sleep(1.0) +output = read_all(fd, 0.5) +os.close(fd) +os.waitpid(pid, 0) +count = last_event_count(output) +tab = last_tab_index(output) +check("Events were logged", count is not None and count >= 2, + f"last count: {count}") +check("Tab switched from 1", tab is not None and tab > 1, + f"last tab: {tab}") + +# ── Test 4: 'q' types into text input, does not quit ── +print("\n[Test 4] 'q' does NOT quit, types into text input instead") +pid, fd = spawn_demo() +os.write(fd, b"q") +time.sleep(0.5) +os.write(fd, b"a") +time.sleep(1.0) +output = read_all(fd, 0.5) +os.close(fd) +os.waitpid(pid, 0) +count = last_event_count(output) +check("Events were logged ('q' + 'a')", count is not None and count >= 3, + f"last count: {count}") +check("Demo still running after 'q' (no busy-spin)", len(output) < 50000, + f"got {len(output)} bytes") + +# ── Test 5: Ctrl+C quits the demo ── +print("\n[Test 5] Ctrl+C quits the demo") +pid, fd = spawn_demo() +os.write(fd, b"\x03") # Ctrl+C +output = read_all(fd, 1.0) +os.close(fd) +os.waitpid(pid, 0) +check("Ctrl+C produces output", len(output) > 50, f"got {len(output)} bytes") + +# ── Test 6: EOF on stdin quits cleanly ── +print("\n[Test 6] EOF on stdin quits cleanly (no busy-spin)") +result = subprocess.run( + ["timeout", "5", "bash", "-c", + "cd /mnt/hermes/projects/cl-tty && exec sbcl --noinform --script demo.lisp < /dev/null"], + capture_output=True, timeout=10 +) +eof_output = result.stdout + result.stderr +check("EOF exits quickly (not killed by timeout)", + result.returncode == 0, + f"exit code: {result.returncode}") +check("No busy-spin on EOF", len(eof_output) < 50000, + f"got {len(eof_output)} bytes") + +# ── Summary ── +print(f"\n{'='*50}") +print(f"Results: {PASS} passed, {FAIL} failed, {PASS+FAIL} total") +if FAIL == 0: + print("ALL CHECKS PASSED") +else: + print("SOME CHECKS FAILED") +sys.exit(FAIL > 0) diff --git a/backend/classes.lisp b/src/backend/classes.lisp similarity index 50% rename from backend/classes.lisp rename to src/backend/classes.lisp index 4c87c30..d103806 100644 --- a/backend/classes.lisp +++ b/src/backend/classes.lisp @@ -8,6 +8,47 @@ (defgeneric shutdown-backend (backend) (:method ((b backend)) (values))) +(defgeneric suspend-backend (backend) + (:documentation "Temporarily suspend the backend, restoring terminal to normal state. +Called before SIGTSTP or similar suspension. Application should redraw after resume.") + (:method ((b backend)) (values))) + +(defgeneric resume-backend (backend) + (:documentation "Re-initialize the backend after suspension. +Called after SIGCONT or similar resume. Re-enables raw mode and backend features.") + (:method ((b backend)) (values))) + +(defmacro with-terminal ((backend-var &optional cols-var rows-var) + &body body) + "Execute BODY with a fully initialized terminal backend. + +DETECT-BACKEND, INITIALIZE-BACKEND, and SHUTDOWN-BACKEND are called +automatically. The backend instance is bound to BACKEND-VAR. If +COLS-VAR and ROWS-VAR are provided, they are bound to the terminal +dimensions at startup. + +The caller should wrap this in SB-POSIX:WITH-RAW-TERMINAL (or +equivalent) if raw-mode input handling is needed. + +Example: + (with-terminal (be cols rows) + (loop for ev = (read-event be :timeout 0.1) + while ev + do (format t \"~A~%\" ev))))" + (let ((be-sym (gensym "BE")) + (c-sym (gensym "COLS")) + (r-sym (gensym "ROWS"))) + `(let* ((,be-sym (detect-backend)) + ,@(when cols-var `((,c-sym (nth-value 0 (backend-size ,be-sym))))) + ,@(when rows-var `((,r-sym (nth-value 1 (backend-size ,be-sym)))))) + (initialize-backend ,be-sym) + (unwind-protect + (let ((,backend-var ,be-sym) + ,@(when cols-var `((,cols-var ,c-sym))) + ,@(when rows-var `((,rows-var ,r-sym)))) + ,@body) + (shutdown-backend ,be-sym))))) + (defgeneric backend-size (backend) (:method ((b backend)) (values 80 24))) diff --git a/backend/detection.lisp b/src/backend/detection.lisp similarity index 61% rename from backend/detection.lisp rename to src/backend/detection.lisp index d858350..9ca8ba5 100644 --- a/backend/detection.lisp +++ b/src/backend/detection.lisp @@ -1,12 +1,8 @@ (in-package :cl-tty.backend) -;;; ─── Detection cache ──────────────────────────────────────────────────────── - (defvar *detected-backend* nil "Cached backend instance from detect-backend. Nil = not yet detected.") -;;; ─── Environment probe ────────────────────────────────────────────────────── - (defun detect-backend-by-env () "Check COLORTERM environment variable for modern terminal support. Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." @@ -16,39 +12,33 @@ Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise." (search "24bit" colorterm :test #'char-equal))) :modern))) -;;; ─── TTY probe ────────────────────────────────────────────────────────────── - (defun detect-backend-by-tty () "Check if stdout is a real terminal (not a pipe/redirect). Returns T if stdout is interactive, nil otherwise." (interactive-stream-p *standard-output*)) -;;; ─── DA1 terminal query ───────────────────────────────────────────────────── - (defun query-terminal (query &optional (timeout 0.1)) "Send QUERY string to terminal and return any response received within TIMEOUT seconds. Returns the response string, or nil if no response." - (write-string query *query-io*) - (force-output *query-io*) + (write-string query *standard-output*) + (force-output *standard-output*) (sleep timeout) (let ((response (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) - (loop while (listen *query-io*) - do (vector-push-extend (read-char-no-hang *query-io*) response)) + (loop while (listen *standard-input*) + do (vector-push-extend (read-char-no-hang *standard-input*) response)) (when (plusp (length response)) response))) (defun detect-backend-by-da1 () "Send DA1 (ESC[c) query and check for kitty terminal response code. Returns T if terminal reports kitty compatibility codes." - (let ((response (query-terminal (format nil "~C[c" #\Esc)))) + (let ((response (query-terminal (format nil "~C[c" (code-char 27))))) (when response ;; DA1 response format: ESC [ ? digits ; digits c ;; Kitty reports code 62 in the response (search "?62" response)))) -;;; ─── Orchestrator ─────────────────────────────────────────────────────────── - (defun detect-backend () "Auto-detect the appropriate backend for the current terminal. Returns a backend instance (modern-backend or simple-backend). diff --git a/backend/modern-tests.lisp b/src/backend/modern-tests.lisp similarity index 78% rename from backend/modern-tests.lisp rename to src/backend/modern-tests.lisp index 3bb80e9..20b2d2c 100644 --- a/backend/modern-tests.lisp +++ b/src/backend/modern-tests.lisp @@ -11,15 +11,11 @@ (fiveam:explain! result) (uiop:quit 0))) -;; ── Constructor ──────────────────────────────────────────────── - (test make-modern-backend-creates "make-modern-backend returns a modern-backend instance" (let ((b (make-modern-backend))) (is (typep b 'cl-tty.backend::modern-backend)))) -;; ── Escape Generation ────────────────────────────────────────── - (test sgr-truecolor-foreground "SGR truecolor foreground escape is correct" (is (equal (cl-tty.backend::sgr-fg "#FFD700") @@ -44,8 +40,6 @@ (is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc))) (is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc)))) -;; ── Cursor ───────────────────────────────────────────────────── - (test cursor-move-escape "cursor-move generates correct CSI escape" (let ((b (make-modern-backend))) @@ -70,23 +64,17 @@ (is (equal (cl-tty.backend::cursor-style-escape :underline t) (format nil "~C[5 q" #\Esc))))) -;; ── Synchronization ──────────────────────────────────────────── - (test decicm-escapes "DECICM synchronized update escapes" (is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc))) (is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc)))) -;; ── OSC 8 Hyperlinks ────────────────────────────────────────── - (test osc8-escape "OSC 8 hyperlink escape wraps text" (is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") (format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\" #\Esc #\Esc #\Esc #\Esc)))) -;; ── Hex Parsing ──────────────────────────────────────────────── - (test hex-color-parsing "hex-to-rgb parses valid hex colors" (multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700") @@ -108,8 +96,6 @@ (is (= g 0)) (is (= b 0)))) -;; ── Border Characters ────────────────────────────────────────── - (test border-char-rounded "modern-border-char returns Unicode box-drawing for rounded style" (is (equal (cl-tty.backend::border-char :rounded :top-left) "╭")) @@ -122,3 +108,9 @@ (is (equal (cl-tty.backend::border-char :double :top-left) "╔")) (is (equal (cl-tty.backend::border-char :double :horizontal) "═")) (is (equal (cl-tty.backend::border-char :double :vertical) "║"))) + +(test suspend-resume-noop + "suspend-backend and resume-backend are no-ops in test context" + (let ((b (make-modern-backend))) + (is (null (multiple-value-list (suspend-backend b)))) + (is (null (multiple-value-list (resume-backend b)))))) diff --git a/backend/modern.lisp b/src/backend/modern.lisp similarity index 71% rename from backend/modern.lisp rename to src/backend/modern.lisp index aabf5dd..eb75f96 100644 --- a/backend/modern.lisp +++ b/src/backend/modern.lisp @@ -1,13 +1,3 @@ -;;; modern-backend — Raw escape sequence backend -;;; Generated from org/modern-backend.org -;;; DO NOT EDIT — edit the .org file instead - -;; In package.lisp, add to :export: -;; #:modern-backend #:make-modern-backend -;; Internal symbols (not exported, used by tests): -;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape -;; decicm-begin decicm-end osc8-link hex-to-rgb border-char - (in-package :cl-tty.backend) (defun hex-to-rgb (hex) @@ -34,10 +24,7 @@ Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg as a fallback when a keyword is not in *named-colors*.") (defun sgr-fg (color) - "Return SGR foreground escape for COLOR. - Color can be a hex string, a keyword name, or nil. - Keywords first try *named-colors*, then fall back to *theme-colors* - which resolves theme semantic roles to hex strings." + "Return SGR foreground escape for COLOR." (if (null color) "" (cond ((and (stringp color) (char= (char color 0) #\#)) (multiple-value-bind (r g b) (hex-to-rgb color) @@ -46,7 +33,6 @@ as a fallback when a keyword is not in *named-colors*.") (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 30 index)) - ;; Fall back to theme-colors hash (let ((hex (gethash color *theme-colors*))) (if hex (multiple-value-bind (r g b) (hex-to-rgb hex) @@ -55,8 +41,7 @@ as a fallback when a keyword is not in *named-colors*.") (t "")))) (defun sgr-bg (color) - "Return SGR background escape for COLOR. - Keywords first try *named-colors*, then fall back to *theme-colors*." + "Return SGR background escape for COLOR." (if (null color) "" (cond ((and (stringp color) (char= (char color 0) #\#)) (multiple-value-bind (r g b) (hex-to-rgb color) @@ -65,7 +50,6 @@ as a fallback when a keyword is not in *named-colors*.") (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 40 index)) - ;; Fall back to theme-colors hash (let ((hex (gethash color *theme-colors*))) (if hex (multiple-value-bind (r g b) (hex-to-rgb hex) @@ -89,9 +73,7 @@ as a fallback when a keyword is not in *named-colors*.") (format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x))) (defun cursor-style-escape (shape blink) - "Return DECSTR escape for cursor shape. - :block = 2, :underline = 4, :bar = 6. - Add 1 for blink variants." + "Return DECSTR escape for cursor shape." (let* ((base (case shape (:block 2) (:underline 4) (:bar 6) (t 2))) @@ -140,29 +122,56 @@ as a fallback when a keyword is not in *named-colors*.") (make-instance 'modern-backend :output-stream (or output-stream *standard-output*))) (defmethod initialize-backend ((b modern-backend)) - ;; Enter raw mode, enable mouse, bracketed paste (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic (backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag (backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse (backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste + (backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard (cursor-hide b) (finish-output (backend-output-stream b)) b) (defmethod shutdown-backend ((b modern-backend)) (cursor-show b) - (backend-write b (format nil "~C[?2004l" #\Esc)) ; disable bracketed paste - (backend-write b (format nil "~C[?1006l" #\Esc)) ; disable SGR mouse + (backend-write b (format nil "~C[?u" #\Esc)) + (backend-write b (format nil "~C[?2004l" #\Esc)) + (backend-write b (format nil "~C[?1006l" #\Esc)) (backend-write b (format nil "~C[?1002l" #\Esc)) (backend-write b (format nil "~C[?1000l" #\Esc)) (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen (finish-output (backend-output-stream b)) (values)) +(defmethod suspend-backend ((b modern-backend)) + (cursor-show b) + (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen + (cursor-move b 0 0) + (finish-output (backend-output-stream b)) + (values)) + +(defmethod resume-backend ((b modern-backend)) + (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen + (backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic + (backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag + (backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse + (backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste + (backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard + (cursor-hide b) + (finish-output (backend-output-stream b)) + (values)) + (defmethod backend-size ((b modern-backend)) - ;; Default fallback — real implementation queries terminal - (values 80 24)) + (let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux + (winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) + (unwind-protect + (progn + (sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b)) + +tiocgwinsz+ + (sb-alien:alien-sap winsize)) + (values (sb-alien:deref winsize 1) ;; cols + (sb-alien:deref winsize 0))) ;; rows + (sb-alien:free-alien winsize)))) (defmethod backend-write ((b modern-backend) string) (let ((stream (backend-output-stream b))) @@ -191,7 +200,6 @@ as a fallback when a keyword is not in *named-colors*.") (defmethod draw-border ((b modern-backend) x y width height &key style fg bg title title-align) - (declare (ignore title title-align)) (let* ((s (or style :single)) (tl (border-char s :top-left)) (tr (border-char s :top-right)) @@ -202,17 +210,42 @@ as a fallback when a keyword is not in *named-colors*.") (fg-esc (sgr-fg fg)) (bg-esc (sgr-bg bg)) (reset (sgr-attr :reset)) - (top (concatenate 'string - fg-esc bg-esc tl - (make-string (- width 2) :initial-element (char h 0)) - tr reset (string #\Newline))) + (inner-width (- width 2)) + (hc (char h 0)) + (top (if (and title (plusp (length title))) + (let* ((align (or title-align :left)) + (max-tlen (- inner-width 2)) + (tlen (min (length title) max-tlen)) + (trunc-title (subseq title 0 tlen))) + (ecase align + (:left + (let ((right-hyphens (- inner-width tlen 2))) + (concatenate 'string + fg-esc bg-esc tl (string #\Space) + trunc-title (string #\Space) + (make-string (max 0 right-hyphens) :initial-element hc) + tr reset (string #\Newline)))) + (:center + (let* ((total-pad (- inner-width tlen)) + (left-pad (floor total-pad 2)) + (right-pad (- total-pad left-pad))) + (concatenate 'string + fg-esc bg-esc tl + (make-string left-pad :initial-element hc) + trunc-title + (make-string right-pad :initial-element hc) + tr reset (string #\Newline)))))) + (concatenate 'string + fg-esc bg-esc tl + (make-string inner-width :initial-element hc) + tr reset (string #\Newline)))) (mid (concatenate 'string fg-esc bg-esc v - (make-string (- width 2) :initial-element #\Space) + (make-string inner-width :initial-element #\Space) v reset (string #\Newline))) (bot (concatenate 'string fg-esc bg-esc bl - (make-string (- width 2) :initial-element (char h 0)) + (make-string inner-width :initial-element hc) br reset))) (backend-write b top) (loop repeat (- height 2) do (backend-write b mid)) @@ -239,6 +272,7 @@ as a fallback when a keyword is not in *named-colors*.") (defmethod draw-ellipsis ((b modern-backend) x y width &key fg bg) + (declare (ignore width)) (let ((dots "...")) (draw-text b x y dots fg bg))) @@ -254,6 +288,16 @@ as a fallback when a keyword is not in *named-colors*.") (defmethod cursor-style ((b modern-backend) shape &key blink) (backend-write b (cursor-style-escape shape blink))) +(defmethod enable-mouse ((b modern-backend)) + (backend-write b (format nil "~C[?1000h" #\Esc)) + (backend-write b (format nil "~C[?1002h" #\Esc)) + (backend-write b (format nil "~C[?1006h" #\Esc)) + (finish-output (backend-output-stream b))) + +(defmethod enable-bracketed-paste ((b modern-backend)) + (backend-write b (format nil "~C[?2004h" #\Esc)) + (finish-output (backend-output-stream b))) + (defmethod begin-sync ((b modern-backend)) (setf (in-sync-p b) t) (backend-write b (decicm-begin))) @@ -262,4 +306,3 @@ as a fallback when a keyword is not in *named-colors*.") (setf (in-sync-p b) nil) (backend-write b (decicm-end)) (finish-output (backend-output-stream b))) - diff --git a/backend/package.lisp b/src/backend/package.lisp similarity index 94% rename from backend/package.lisp rename to src/backend/package.lisp index e1eb0af..fc7d2cd 100644 --- a/backend/package.lisp +++ b/src/backend/package.lisp @@ -5,6 +5,7 @@ #:backend #:simple-backend ;; Lifecycle #:initialize-backend #:shutdown-backend + #:suspend-backend #:resume-backend #:backend-size #:backend-write #:backend-clear ;; Drawing #:draw-text #:draw-border #:draw-rect @@ -19,6 +20,7 @@ #:capable-p ;; Constructors #:make-simple-backend + #:with-terminal ;; Modern backend #:modern-backend #:make-modern-backend ;; Detection diff --git a/backend/simple.lisp b/src/backend/simple.lisp similarity index 55% rename from backend/simple.lisp rename to src/backend/simple.lisp index a7af39f..94a8ecc 100644 --- a/backend/simple.lisp +++ b/src/backend/simple.lisp @@ -15,6 +15,12 @@ (defmethod shutdown-backend ((b simple-backend)) (values)) +(defmethod suspend-backend ((b simple-backend)) + (values)) + +(defmethod resume-backend ((b simple-backend)) + (values)) + (defmethod backend-size ((b simple-backend)) ;; Try ioctl, fall back to 80x24 (values 80 24)) @@ -30,8 +36,8 @@ (declare (ignore x y fg bg bold italic underline reverse dim blink)) (backend-write b string)) -(defun %simple-border-char (edge-style pos) - "Return ASCII border character for EDGE-STYLE at POS. +(defun %simple-border-char (pos) + "Return ASCII border character at POS. POS is :top-left, :top-right, :bottom-left, :bottom-right, :horizontal, or :vertical." (case pos @@ -41,14 +47,39 @@ POS is :top-left, :top-right, :bottom-left, :bottom-right, (defmethod draw-border ((b simple-backend) x y width height &key style fg bg title title-align) - (declare (ignore style fg bg title title-align)) - (let ((h (%simple-border-char nil :horizontal)) - (v (%simple-border-char nil :vertical))) + (declare (ignore style fg bg)) + (let ((h (%simple-border-char :horizontal)) + (v (%simple-border-char :vertical)) + (tl (%simple-border-char :top-left)) + (tr (%simple-border-char :top-right)) + (bl (%simple-border-char :bottom-left)) + (br (%simple-border-char :bottom-right))) ;; Position cursor with newlines and spaces (no escape sequences) (dotimes (row y) (backend-write b (string #\Newline))) - ;; Top edge + ;; Top edge with optional title (backend-write b (make-string x :initial-element #\space)) - (backend-write b (make-string width :initial-element h)) + (backend-write b (string tl)) + (if (and title (plusp (length title))) + (let* ((align (or title-align :left)) + (inner-width (- width 2)) + (max-tlen (- inner-width 2)) + (tlen (min (length title) max-tlen)) + (trunc-title (subseq title 0 tlen))) + (ecase align + (:left + (backend-write b (string #\Space)) + (backend-write b trunc-title) + (backend-write b (string #\Space)) + (backend-write b (make-string (- inner-width tlen 2) :initial-element h))) + (:center + (let* ((total-pad (- inner-width tlen)) + (left-pad (floor total-pad 2)) + (right-pad (- total-pad left-pad))) + (backend-write b (make-string left-pad :initial-element h)) + (backend-write b trunc-title) + (backend-write b (make-string right-pad :initial-element h)))))) + (backend-write b (make-string (- width 2) :initial-element h))) + (backend-write b (string tr)) ;; Sides (loop for i from 1 below (1- height) do (backend-write b (string #\Newline)) @@ -59,7 +90,9 @@ POS is :top-left, :top-right, :bottom-left, :bottom-right, ;; Bottom edge (backend-write b (string #\Newline)) (backend-write b (make-string x :initial-element #\space)) - (backend-write b (make-string width :initial-element h)))) + (backend-write b (string bl)) + (backend-write b (make-string (- width 2) :initial-element h)) + (backend-write b (string br)))) (defmethod draw-rect ((b simple-backend) x y width height &key bg) @@ -74,5 +107,8 @@ POS is :top-left, :top-right, :bottom-left, :bottom-right, (defmethod draw-ellipsis ((b simple-backend) x y width &key fg bg) - (declare (ignore x y width fg bg)) + (declare (ignore width fg bg)) + ;; Position using newlines+spaces (simple-backend pattern) + (dotimes (row y) (backend-write b (string #\Newline))) + (backend-write b (make-string x :initial-element #\Space)) (backend-write b "...")) diff --git a/backend/tests.lisp b/src/backend/tests.lisp similarity index 78% rename from backend/tests.lisp rename to src/backend/tests.lisp index ea8f2fc..a509103 100644 --- a/backend/tests.lisp +++ b/src/backend/tests.lisp @@ -6,16 +6,12 @@ (def-suite backend-suite :description "Backend protocol tests") (in-suite backend-suite) -;; ── Helpers ───────────────────────────────────────────────────── - (defun make-capturing-backend () "Create a simple-backend that writes to a string stream." (let* ((s (make-string-output-stream)) (b (make-simple-backend :output-stream s))) (values b s))) -;; ── Simple Backend ────────────────────────────────────────────── - (defun run-tests () "Run all backend tests." (let ((result (run 'backend-suite))) @@ -46,7 +42,7 @@ (draw-border b 0 0 5 3 :style :single) (shutdown-backend b) (let ((out (get-output-stream-string s))) - (is (search "-----" out) "top edge should have 5 dashes") + (is (search "+---+" out) "top edge should have +---+\"") (is (search "| |" out) "middle row should have pipe sides")))) (test simple-backend-draw-rounded @@ -56,8 +52,8 @@ (draw-border b 0 0 5 3 :style :rounded) (shutdown-backend b) (let ((out (get-output-stream-string s))) - ;; Rounded falls back to ASCII — identical output to single - (is (search "-----" out) "rounded style produces same dashes as single")))) + ;; Rounded falls back to ASCII -- identical output to single + (is (search "+---+" out) "rounded style produces same dashes as single")))) (test simple-backend-draw-link "simple-backend renders link as plain text" @@ -77,8 +73,6 @@ (is (string= (get-output-stream-string s) "...") "ellipsis should output 3 dots"))) -;; ── Backend Capabilities ─────────────────────────────────────── - (test capable-p-known-features "capable-p returns nil for all features on simple-backend" (let ((b (make-simple-backend))) @@ -89,8 +83,6 @@ (format nil "~s should not be supported on simple-backend" f))) (shutdown-backend b))) -;; ── Backend Size ─────────────────────────────────────────────── - (test backend-size-returns-integers "backend-size returns two integer values" (let ((b (make-simple-backend))) @@ -102,8 +94,6 @@ (is (>= lines 3))) (shutdown-backend b))) -;; ── Backend Protocol: Defaults and No-ops ────────────────────── - (test default-methods-are-no-ops "Default backend methods don't error" (let ((b (make-simple-backend))) @@ -113,6 +103,8 @@ (is (null (multiple-value-list (cursor-style b :block)))) (is (null (multiple-value-list (begin-sync b)))) (is (null (multiple-value-list (end-sync b)))) + (is (null (multiple-value-list (suspend-backend b)))) + (is (null (multiple-value-list (resume-backend b)))) (shutdown-backend b))) (test sync-is-noop-on-simple @@ -126,8 +118,6 @@ (is (string= (get-output-stream-string s) "in sync") "no sync escape sequences should appear"))) -;; ── Draw-rect ────────────────────────────────────────────────── - (test draw-rect-fills-area-correctly "draw-rect with background writes nothing to output (simple-backend no-op)" (multiple-value-bind (b s) (make-capturing-backend) @@ -137,8 +127,6 @@ (is (string= (get-output-stream-string s) "") "draw-rect is a no-op on simple-backend"))) -;; ── Detection ────────────────────────────────────────────────── - (test detection-returns-backend-instance "detect-backend returns a valid backend instance" (let ((be (cl-tty.backend:detect-backend))) diff --git a/src/components/box-tests.lisp b/src/components/box-tests.lisp index 6caee6f..ab13acf 100644 --- a/src/components/box-tests.lisp +++ b/src/components/box-tests.lisp @@ -16,8 +16,6 @@ (b (make-modern-backend :output-stream s))) (values b s))) -;; ── Box Tests ───────────────────────────────────────────────── - (test box-creates-with-defaults "A box created with no arguments has reasonable defaults" (let ((b (make-box))) @@ -92,8 +90,6 @@ (let ((out (get-output-stream-string s))) (is (search "┌" out) "2x2 box still has borders"))))) -;; ── Text and Span Tests ─────────────────────────────────────── - (test text-creates-with-defaults "A text created with no arguments has reasonable defaults" (let ((txt (make-text ""))) diff --git a/src/components/container-package.lisp b/src/components/container-package.lisp index cc4e61a..0427e23 100644 --- a/src/components/container-package.lisp +++ b/src/components/container-package.lisp @@ -1,12 +1,16 @@ (defpackage :cl-tty.container (:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) (:export + ;; ScrollBox #:scroll-box #:make-scroll-box #:scroll-box-scroll-y #:scroll-box-scroll-x - #:scroll-box-children #:scroll-by - #:sticky-scroll-p + #:scroll-box-children + #:scroll-by #:sticky-scroll-p #:clamp-scroll + ;; TabBar #:tab-bar #:make-tab-bar #:tab-bar-active #:tab-bar-tabs #:tab-bar-add #:tab-bar-next #:tab-bar-prev - #:tab-bar-select #:tab-bar-handle-key)) + #:tab-bar-select #:tab-bar-handle-key + ;; Rendering + #:render)) diff --git a/src/components/dialog-package.lisp b/src/components/dialog-package.lisp index 093964b..d3e5712 100644 --- a/src/components/dialog-package.lisp +++ b/src/components/dialog-package.lisp @@ -1,7 +1,7 @@ ;;; dialog-package.lisp — Package definition for cl-tty.dialog (defpackage :cl-tty.dialog - (:use :cl :cl-tty.input :cl-tty.select) + (:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select) (:export #:dialog #:dialog-title diff --git a/src/components/dialog.lisp b/src/components/dialog.lisp index fc5a8b1..5e0aaea 100644 --- a/src/components/dialog.lisp +++ b/src/components/dialog.lisp @@ -1,39 +1,35 @@ -;;; dialog.lisp — Dialog System + Toast for cl-tty - (in-package :cl-tty.dialog) -;; ─── Special variables ──────────────────────────────────────────────────────── - (defvar *dialog-stack* nil "Stack of active dialogs. (list) of dialog instances.") (defvar *toasts* nil "List of active toast notifications.") -;; ─── Dialog class ───────────────────────────────────────────────────────────── - (defclass dialog () ((title :initarg :title :accessor dialog-title) (size :initarg :size :initform :medium :accessor dialog-size) (content :initarg :content :initform nil :accessor dialog-content) (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) -(defun dialog-size-pixels (size) - (case size - (:small (values 40 8)) - (:medium (values 60 16)) - (:large (values 88 24)) - (t (values 60 16)))) +(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24)) + (multiple-value-bind (dw dh) + (case size + (:small (values 40 8)) + (:medium (values 60 16)) + (:large (values 88 24)) + (t (values 60 16))) + (values (min dw max-w) (min dh max-h)))) (defun render-dialog (dialog screen w h) - (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) + (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h) (let ((x (floor (- w dw) 2)) (y (floor (- h dh) 2))) ;; Backdrop — dim the full screen (dotimes (row h) (draw-rect screen 0 row w 1 :bg :bright-black)) ;; Dialog panel - (draw-border screen x y dw dh :single :title (dialog-title dialog)) + (draw-border screen x y dw dh :style :single :title (dialog-title dialog)) (when (dialog-content dialog) ;; Content rendering delegated to component system (draw-text screen (1+ x) (1+ y) @@ -51,8 +47,6 @@ (funcall (dialog-on-dismiss dialog))) dialog))) -;; ─── Dialog sub-classes ────────────────────────────────────────────────────── - (defun alert-dialog (title message) (make-instance 'dialog :title title @@ -94,8 +88,6 @@ (pop-dialog) (when on-submit (funcall on-submit value)))))) -;; ─── Toast system ───────────────────────────────────────────────────────────── - (defclass toast () ((message :initarg :message :accessor toast-message) (variant :initarg :variant :initform :info :accessor toast-variant))) diff --git a/src/components/dirty-tests.lisp b/src/components/dirty-tests.lisp index aa695cb..52488e9 100644 --- a/src/components/dirty-tests.lisp +++ b/src/components/dirty-tests.lisp @@ -1,4 +1,3 @@ -;; Dirty tracking tests are in box-tests.lisp (same test suite) (in-package :cl-tty-box-test) (in-suite box-suite) @@ -7,12 +6,18 @@ (let ((c (make-instance 'dirty-mixin))) (is-true (dirty-p c) "new component should be dirty"))) +(in-package :cl-tty-box-test) +(in-suite box-suite) + (test mark-clean-clears-dirty "mark-clean sets dirty to nil" (let ((c (make-instance 'dirty-mixin))) (mark-clean c) (is-false (dirty-p c) "after mark-clean, should not be dirty"))) +(in-package :cl-tty-box-test) +(in-suite box-suite) + (test mark-dirty-sets-dirty "mark-dirty sets dirty to t" (let ((c (make-instance 'dirty-mixin))) diff --git a/src/components/input-package.lisp b/src/components/input-package.lisp index 852926d..2eff30e 100644 --- a/src/components/input-package.lisp +++ b/src/components/input-package.lisp @@ -15,6 +15,9 @@ #:with-raw-terminal ;; Event reading #:read-event + #:*terminal-resized-p* + ;; UTF-8 input support + #:utf8-decode ;; TextInput #:text-input #:make-text-input #:text-input-value #:text-input-cursor @@ -24,9 +27,9 @@ ;; Textarea #:textarea #:make-textarea #:textarea-value #:textarea-cursor-row #:textarea-cursor-col + #:textarea-lines #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack #:textarea-layout-node - #:textarea-lines #:handle-textarea-input #:render-textarea ;; Keybindings #:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent diff --git a/src/components/input-tests.lisp b/src/components/input-tests.lisp deleted file mode 100644 index 1f3971f..0000000 --- a/src/components/input-tests.lisp +++ /dev/null @@ -1,269 +0,0 @@ -(defpackage :cl-tty-input-test - (:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input) - (:export #:run-tests)) -(in-package :cl-tty-input-test) - -(def-suite input-suite :description "Text input and keybinding tests") -(in-suite input-suite) - -(defun run-tests () - (let ((result (run 'input-suite))) - (fiveam:explain! result) - (uiop:quit 0))) - -;; ── Key Event Tests ───────────────────────────────────────────── - -(test key-event-construction - "A key-event can be created and queried." - (let ((e (make-key-event :key :a :ctrl t :alt nil))) - (is (eql (key-event-key e) :a)) - (is-true (key-event-ctrl e)) - (is-false (key-event-alt e)))) - -(test key-event-defaults - "Fields default to NIL/nil." - (let ((e (make-key-event :key :space))) - (is (eql (key-event-key e) :space)) - (is-false (key-event-ctrl e)) - (is-false (key-event-alt e)) - (is-false (key-event-shift e)))) - -(test mouse-event-construction - "A mouse-event can be created and queried." - (let ((e (make-mouse-event :type :press :button :left :x 10 :y 5))) - (is (eql (mouse-event-type e) :press)) - (is (eql (mouse-event-button e) :left)) - (is (= (mouse-event-x e) 10)) - (is (= (mouse-event-y e) 5)))) - -;; ── TextInput Tests ───────────────────────────────────────────── - -(test text-input-empty - "A newly created text-input has empty value and cursor at 0." - (let ((in (make-text-input))) - (is (string= (text-input-value in) "")) - (is (= (text-input-cursor in) 0)))) - -(test text-input-insert-char - "Inserting a character appends and moves cursor." - (let ((in (make-text-input))) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (is (string= (text-input-value in) "a")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-insert-multiple - "Inserting multiple characters works left to right." - (let ((in (make-text-input))) - (handle-text-input in (make-key-event :key :h :code (char-code #\h))) - (handle-text-input in (make-key-event :key :e :code (char-code #\e))) - (handle-text-input in (make-key-event :key :l :code (char-code #\l))) - (handle-text-input in (make-key-event :key :l :code (char-code #\l))) - (handle-text-input in (make-key-event :key :o :code (char-code #\o))) - (is (string= (text-input-value in) "hello")) - (is (= (text-input-cursor in) 5)))) - -(test text-input-backspace - "Backspace removes the character before the cursor." - (let ((in (make-text-input :value "ab" :cursor 2))) - (handle-text-input in (make-key-event :key :backspace)) - (is (string= (text-input-value in) "a")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-backspace-at-start - "Backspace at position 0 does nothing." - (let ((in (make-text-input :value "ab" :cursor 0))) - (handle-text-input in (make-key-event :key :backspace)) - (is (string= (text-input-value in) "ab")) - (is (= (text-input-cursor in) 0)))) - -(test text-input-delete - "Delete removes the character at the cursor." - (let ((in (make-text-input :value "abc" :cursor 1))) - (handle-text-input in (make-key-event :key :delete)) - (is (string= (text-input-value in) "ac")) - (is (= (text-input-cursor in) 1)))) - -(test text-input-cursor-left-right - "Cursor moves left and right." - (let ((in (make-text-input :value "ab" :cursor 2))) - (handle-text-input in (make-key-event :key :left)) - (is (= (text-input-cursor in) 1)) - (handle-text-input in (make-key-event :key :right)) - (is (= (text-input-cursor in) 2)))) - -(test text-input-cursor-bounds - "Cursor cannot move past start or end." - (let ((in (make-text-input :value "ab" :cursor 0))) - (handle-text-input in (make-key-event :key :left)) - (is (= (text-input-cursor in) 0)) - (setf (text-input-cursor in) 2) - (handle-text-input in (make-key-event :key :right)) - (is (= (text-input-cursor in) 2)))) - -(test text-input-home-end - "Home moves to start, End moves to end." - (let ((in (make-text-input :value "hello" :cursor 3))) - (handle-text-input in (make-key-event :key :home)) - (is (= (text-input-cursor in) 0)) - (handle-text-input in (make-key-event :key :end)) - (is (= (text-input-cursor in) 5)))) - -(test text-input-max-length - "Max-length prevents inserting beyond the limit." - (let ((in (make-text-input :max-length 3))) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (handle-text-input in (make-key-event :key :b :code (char-code #\b))) - (handle-text-input in (make-key-event :key :c :code (char-code #\c))) - (handle-text-input in (make-key-event :key :d :code (char-code #\d))) - (is (string= (text-input-value in) "abc")))) - -(test text-input-placeholder - "Placeholder is stored but does not affect value." - (let ((in (make-text-input :placeholder "Type here..."))) - (is (string= (text-input-placeholder in) "Type here...")) - (is (string= (text-input-value in) "")))) - -(test text-input-on-submit - "On-submit callback fires on Enter." - (let ((result (list nil))) - (let ((in (make-text-input :value "hello" - :on-submit (lambda (v) (setf (car result) v))))) - (handle-text-input in (make-key-event :key :enter)) - (is (string= (car result) "hello"))))) - -(test text-input-ctrl-a-e - "Ctrl+A moves to home, Ctrl+E moves to end." - (let ((in (make-text-input :value "abc" :cursor 2))) - (handle-text-input in (make-key-event :key :a :ctrl t)) - (is (= (text-input-cursor in) 0)) - (handle-text-input in (make-key-event :key :e :ctrl t)) - (is (= (text-input-cursor in) 3)))) - -(test text-input-insert-in-middle - "Inserting in the middle of text shifts rest right." - (let ((in (make-text-input :value "ab" :cursor 1))) - (handle-text-input in (make-key-event :key :x :code (char-code #\x))) - (is (string= (text-input-value in) "axb")) - (is (= (text-input-cursor in) 2)))) - -(test text-input-dirty-on-insert - "Inserting marks the widget dirty." - (let ((in (make-text-input))) - (mark-clean in) - (handle-text-input in (make-key-event :key :a :code (char-code #\a))) - (is-true (dirty-p in)))) - -;; ── Textarea Tests ────────────────────────────────────────────── - -(test textarea-empty - "New textarea has empty value and cursor at (0,0)." - (let ((a (make-textarea))) - (is (string= (textarea-value a) "")) - (is (= (textarea-cursor-row a) 0)) - (is (= (textarea-cursor-col a) 0)))) - -(test textarea-newline - "Enter inserts a newline." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :enter)) - (handle-textarea-input a (make-key-event :key :b :code (char-code #\b))) - (is (string= (textarea-value a) "a -b")))) - -(test textarea-cursor-up-down - "Cursor moves between lines maintaining column position." - (let ((a (make-textarea :value "abc -de -fghi"))) - (setf (textarea-cursor-row a) 1) - (setf (textarea-cursor-col a) 1) - (handle-textarea-input a (make-key-event :key :up)) - (is (= (textarea-cursor-row a) 0)) - (is (= (textarea-cursor-col a) 1)) - (handle-textarea-input a (make-key-event :key :down)) - (is (= (textarea-cursor-row a) 1)) - (is (= (textarea-cursor-col a) 1)))) - -(test textarea-cursor-up-down-bounds - "Cursor cannot move past first or last line." - (let ((a (make-textarea :value "a -b"))) - (handle-textarea-input a (make-key-event :key :up)) - (is (= (textarea-cursor-row a) 0)) - (setf (textarea-cursor-row a) 1) - (handle-textarea-input a (make-key-event :key :down)) - (is (= (textarea-cursor-row a) 1)))) - -(test textarea-backspace-joins-lines - "Backspace at start of a line joins with previous." - (let ((a (make-textarea :value "hello -world"))) - (setf (textarea-cursor-row a) 1) - (setf (textarea-cursor-col a) 0) - (handle-textarea-input a (make-key-event :key :backspace)) - (is (string= (textarea-value a) "helloworld")))) - -(test textarea-undo - "Ctrl+Z undoes the last edit." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :z :ctrl t)) - (is (string= (textarea-value a) "")))) - -(test textarea-undo-redo - "Ctrl+Y redoes an undone edit." - (let ((a (make-textarea))) - (handle-textarea-input a (make-key-event :key :a :code (char-code #\a))) - (handle-textarea-input a (make-key-event :key :z :ctrl t)) - (handle-textarea-input a (make-key-event :key :y :ctrl t)) - (is (string= (textarea-value a) "a")))) - -;; ── Keybinding Tests ──────────────────────────────────────────── - -(test keymap-simple - "A keymap dispatches to its handler on matching event." - (let ((called nil)) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+p . ,(lambda (e) - (declare (ignore e)) - (setf called t)))))) - (is-true (dispatch-key-event (make-key-event :key :p :ctrl t))) - (is-true called))) - -(test keymap-no-match - "Non-matching event returns nil." - (let ((called nil)) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+p . ,(lambda (e) - (declare (ignore e)) - (setf called t)))))) - (is-false (dispatch-key-event (make-key-event :key :a))) - (is-false called))) - -(test keymap-fallback - "Event not in local falls through to global." - (let ((global-called nil)) - (setf (gethash :global *keymaps*) - (make-keymap :name :global - :bindings `((:ctrl+q . ,(lambda (e) - (declare (ignore e)) - (setf global-called t)))))) - (dispatch-key-event (make-key-event :key :q :ctrl t)) - (is-true global-called))) - -(test key-spec-simple - "Keyword key-spec matches key+ctrl." - (is-true (key-match-p :ctrl+p (make-key-event :key :p :ctrl t))) - (is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t))) - (is-false (key-match-p :ctrl+p (make-key-event :key :p)))) - -(test defkeymap-macro - "defkeymap macro registers a keymap." - (let ((called nil)) - (eval `(defkeymap :global - (:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t))))) - (dispatch-key-event (make-key-event :key :q :ctrl t)) - (is-true called))) diff --git a/src/components/input.lisp b/src/components/input.lisp index b25d54e..f546ed6 100644 --- a/src/components/input.lisp +++ b/src/components/input.lisp @@ -1,8 +1,5 @@ (in-package #:cl-tty.input) -;;; --------------------------------------------------------------------------- -;;; Utility: split-string (avoids external dependency) -;;; --------------------------------------------------------------------------- (defun %split-string (string separator) "Split STRING at each occurrence of SEPARATOR. Returns list of strings." (loop with start = 0 @@ -11,17 +8,12 @@ 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) @@ -31,259 +23,133 @@ (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)) + (button nil :type (or keyword null)) (x 0 :type fixnum) - (y 0 :type fixnum) - (raw nil :type (or string null))) - -;;; --------------------------------------------------------------------------- -;;; Terminal raw mode (stty on /dev/tty — portable across Unices) -;;; --------------------------------------------------------------------------- -(defun stty-run (args) - "Run stty with ARGS. Returns stdout as string." - (with-output-to-string (s) - (sb-ext:run-program "/bin/sh" - (list "-c" (format nil "stty ~{~a~^ ~} < /dev/tty" - (mapcar #'princ-to-string args))) - :output s :wait t))) - -(defun save-terminal-state () - "Save current terminal settings via stty -g. Returns a string." - (let ((s (string-trim '(#\Newline #\Space) (stty-run '("-g"))))) - (when (zerop (length s)) - (error "stty -g failed — not running in a real terminal")) - s)) - -(defun set-raw-mode () - "Put terminal in raw mode via stty. Returns the saved state string." - (let ((saved (save-terminal-state))) - (stty-run '("raw" "-echo" "-isig" "-icanon" "min" "1" "time" "0")) - saved)) - -(defun restore-terminal-state (saved) - "Restore saved terminal state (a string from stty -g, or nil)." - (when (and saved (plusp (length saved))) - (stty-run (list saved)))) - -(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) - (flet ((read-one () - (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) - ;; Use sb-sys:with-pinned-objects so sb-posix:read can access the buffer - (sb-sys:with-pinned-objects (buf) - (let ((n (sb-posix:read 0 (sb-sys:vector-sap buf) 1))) - (when (plusp n) - (return-from read-raw-byte (aref buf 0)))))))) - (if timeout - (let ((deadline (+ (get-universal-time) timeout))) - (loop while (< (get-universal-time) deadline) - do (handler-case - (read-one) - (sb-posix:syscall-error () - (return-from read-raw-byte nil))) - (sleep 0.01)) - nil) - (handler-case - (read-one) - (sb-posix:syscall-error (e) - (format *error-output* "read error: ~A~%" e) - 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)) - ;; Non-digit parameter characters (< = > ?) start a new param at zero - (if (member b '(#x3c #x3d #x3e #x3f) :test #'=) - (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))) + (y 0 :type fixnum)) (defparameter *csi-tilde-table* - '((1 . :home) (2 . :insert) (3 . :delete) - (4 . :end) (5 . :page-up) (6 . :page-down) - (7 . :home) (8 . :end) + '((1 . :home) (2 . :insert) (3 . :delete) (4 . :end) + (5 . :page-up) (6 . :page-down) (11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4) (15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8) (20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12))) -;;; --------------------------------------------------------------------------- -;;; 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))))) +(defparameter *csi-key-table* + '((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left) + (#\F . :end) (#\H . :home) + (#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4) + (#\Z . :back-tab))) + +(defun parse-csi-params (params terminator extended) + (let* ((key (if (find terminator '(#\~ #\u)) + (cdr (assoc (first params) *csi-tilde-table*)) + (cdr (assoc terminator *csi-key-table*)))) + (modifier (when (and (> (length params) 1) (not (find terminator '(#\~ #\u)))) + (second params))) + (actual-modifier (when (> (length extended) 1) (second extended))) + (ctrl nil) (alt nil) (shift nil)) + (when modifier + (setf shift (logtest modifier 1) + alt (logtest modifier 2) + ctrl (logtest modifier 4))) + (when actual-modifier + (setf shift (or shift (logtest actual-modifier 1)) + alt (or alt (logtest actual-modifier 2)) + ctrl (or ctrl (logtest actual-modifier 4)))) + (if (eql terminator #\u) + (let ((code (first params))) + (make-key-event :key :codepoint :code code + :ctrl ctrl :alt alt :shift shift + :raw (string (code-char code)))) + (make-key-event :key (or key :unknown) + :ctrl ctrl :alt alt :shift shift + :raw (format nil "~C[~{~d~};~d~C" #\Esc params terminator))))) + +(defun read-raw-byte (&key timeout) + (let* ((buf (sb-alien:make-alien sb-alien:unsigned-char 1)) + (fd 0)) + (unwind-protect + (if timeout + (progn (sb-unix:unix-simple-poll fd :input timeout) + (let ((n (sb-unix:unix-read fd buf 1))) + (if (= n 1) (sb-alien:deref buf 0) (values nil :eof)))) + (let ((n (sb-unix:unix-read fd buf 1))) + (if (= n 1) (sb-alien:deref buf 0) (values nil :eof)))) + (sb-alien:free-alien buf)))) -;;; --------------------------------------------------------------------------- -;;; 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 raw) (parse-csi-params) - (if (null final-byte) - (make-key-event :key :escape :raw (string #\Esc)) - ;; SGR mouse: ESC [ < ... m/M - (if (and raw (plusp (length raw)) (char= (char raw 0) #\<)) - (or (parse-sgr-mouse raw) - (make-key-event :key :unknown :raw raw)) - (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)) - (release (= button 3))) - (make-mouse-event - :type (cond (release :release) - (motion :drag) - (t :press)) - :button (let ((b button)) (cond ((= b 0) :left) ((= b 1) :middle) ((= b 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)))))))) + (flet ((read-next (&optional (timeout nil)) + (let ((b (read-raw-byte :timeout timeout))) + (unless b (return-from %read-escape-sequence + (make-key-event :key :escape :code 27))) + b))) + (let ((b1 (read-next 0.05))) + (cond + ((null b1) (make-key-event :key :escape :code 27)) + ((= b1 79) (let ((b2 (read-next))) + (case b2 + (80 (make-key-event :key :f1)) + (81 (make-key-event :key :f2)) + (82 (make-key-event :key :f3)) + (83 (make-key-event :key :f4)) + (72 (make-key-event :key :home)) + (70 (make-key-event :key :end)) + (65 (make-key-event :key :up :shift t)) + (66 (make-key-event :key :down :shift t)) + (67 (make-key-event :key :right :shift t)) + (68 (make-key-event :key :left :shift t)) + (otherwise (make-key-event :key :unknown :raw (string (code-char b2))))))) + ((= b1 91) (parse-csi-sequence)) + ((= b1 127) (make-key-event :key :alt-backspace)) + ((< b1 32) + (let ((c (code-char (+ b1 96)))) + (make-key-event :key (intern (string-upcase (string c)) :keyword) + :alt t :code b1))) + (t (make-key-event :key (intern (string-upcase (string (code-char b1))) :keyword) + :alt t :code b1)))))) + +(defun parse-csi-sequence () + (flet ((read-param (next-fn) (let ((acc nil)) + (loop for b = (funcall next-fn) + do (if (and (>= b 48) (<= b 57)) + (push (- b 48) acc) + (return (values (reverse acc) b))))))) + (let* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0)) + (b2 (read-raw-byte)) + (params (if (and (>= b2 48) (<= b2 57)) + (multiple-value-bind (p term) (read-param (lambda () (read-raw-byte))) + (setf (fill-pointer extended) (length p)) + (replace extended p) + (values p term)) + (progn (vector-push-extend b2 extended) (read-param (lambda () (read-raw-byte))))))) + (destructuring-bind (params terminator) params + (parse-csi-params params terminator extended))))) + +(defun utf8-decode (bytes) + (case (length bytes) + (2 (let ((b0 (first bytes)) (b1 (second bytes))) + (when (and (<= #xc2 b0 #xdf) (<= #x80 b1 #xbf)) + (+ (ash (logand b0 #x1f) 6) (logand b1 #x3f))))) + (3 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes))) + (when (and (<= #xe0 b0 #xef) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf)) + (+ (ash (logand b0 #x0f) 12) (ash (logand b1 #x3f) 6) (logand b2 #x3f))))) + (4 (let ((b0 (first bytes)) (b1 (second bytes)) (b2 (third bytes)) (b3 (fourth bytes))) + (when (and (<= #xf0 b0 #xf4) (<= #x80 b1 #xbf) (<= #x80 b2 #xbf) (<= #x80 b3 #xbf)) + (+ (ash (logand b0 #x07) 18) (ash (logand b1 #x3f) 12) + (ash (logand b2 #x3f) 6) (logand b3 #x3f))))) + (t nil))) -;;; --------------------------------------------------------------------------- -;;; Top-level event reader -;;; --------------------------------------------------------------------------- (defun %read-event (&key timeout) - (let ((b (read-raw-byte :timeout timeout))) - (unless b - (return-from %read-event nil)) + (multiple-value-bind (b reason) (read-raw-byte :timeout timeout) + (unless b (return-from %read-event (if (eq reason :eof) :eof nil))) (cond - ((= b #x1b) - (%read-escape-sequence)) - ((= b #x09) - (make-key-event :key :tab :code #x09)) - ((= b #x0a) - (make-key-event :key :enter :code #x0a)) - ((= b #x0d) - (make-key-event :key :enter :code #x0d)) - ((or (= b #x7f) (= b #x08)) - (make-key-event :key :backspace :code b)) + ((= b #x1b) (%read-escape-sequence)) + ((= b #x09) (make-key-event :key :tab :code #x09)) + ((= b #x0a) (make-key-event :key :enter :code #x0a)) + ((= b #x0d) (make-key-event :key :enter :code #x0d)) + ((or (= b #x7f) (= b #x08)) (make-key-event :key :backspace :code b)) ((and (>= b #x01) (<= b #x1a)) (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) (make-key-event :key key :ctrl t :code b))) @@ -293,15 +159,38 @@ ((= 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))))))) + (make-key-event :key (intern (string (string-upcase ch)) :keyword) :code b))) + ((>= b #xc2) + (let* ((n (cond ((<= b #xdf) 2) ((<= b #xef) 3) (t 4))) + (bytes (list b))) + (loop for i from 1 below n + for b2 = (multiple-value-bind (byte reason) (read-raw-byte :timeout 0.5) + (declare (ignore reason)) byte) + while (and b2 (<= #x80 b2 #xbf)) + do (push b2 bytes)) + (setf bytes (nreverse bytes)) + (if (= (length bytes) n) + (let ((cp (utf8-decode bytes))) + (if cp (make-key-event :key :codepoint :code cp :raw (map 'string #'code-char bytes)) + (make-key-event :key :unknown :raw (map 'string #'code-char bytes)))) + (make-key-event :key :unknown :raw (map 'string #'code-char bytes))))) + (t (make-key-event :key :unknown :code b :raw (string (code-char b))))))) + +(defvar *terminal-resized-p* nil) + +#+sbcl +(eval-when (:load-toplevel :execute) + (sb-sys:enable-interrupt sb-posix:sigwinch + (lambda (signal info context) + (declare (ignore signal info context)) + (setf *terminal-resized-p* t)))) -;;; --------------------------------------------------------------------------- -;;; Backend integration -;;; --------------------------------------------------------------------------- (defmethod read-event ((b cl-tty.backend:backend) &key timeout) - (declare (ignore b)) + ;; Check for pending terminal resize before reading input. + ;; The SIGWINCH handler sets *terminal-resized-p* asynchronously. + (when *terminal-resized-p* + (setf *terminal-resized-p* nil) + (multiple-value-bind (w h) (backend-size b) + (return-from read-event (values :resize (cons w h))))) (when (probe-file "/dev/stdin") (%read-event :timeout timeout))) diff --git a/src/components/keybindings.lisp b/src/components/keybindings.lisp index 44e6d2f..28997f2 100644 --- a/src/components/keybindings.lisp +++ b/src/components/keybindings.lisp @@ -1,22 +1,14 @@ (in-package #:cl-tty.input) -;;; --------------------------------------------------------------------------- -;;; Key map struct -;;; --------------------------------------------------------------------------- (defstruct keymap (name nil :type (or keyword null)) (bindings nil :type list) (parent nil :type (or keymap null))) -;;; --------------------------------------------------------------------------- -;;; Global keymap registry -;;; --------------------------------------------------------------------------- (defparameter *keymaps* (make-hash-table :test #'equal)) + (defparameter *chord-timeout* 0.5) -;;; --------------------------------------------------------------------------- -;;; Key spec matching -;;; --------------------------------------------------------------------------- (defun key-match-p (spec event) "T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword) or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords." @@ -26,7 +18,7 @@ (let* ((name (string spec)) (plus (position #\+ name))) (if plus - ;; Modified key: :ctrl+p → mod-str="CTRL", key-str="P" + ;; 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) @@ -43,9 +35,6 @@ (when spec (key-match-p (first spec) event))))) -;;; --------------------------------------------------------------------------- -;;; Dispatch -;;; --------------------------------------------------------------------------- (defun dispatch-key-event (event &key component) (labels ((try-keymap (km) (when km @@ -61,9 +50,6 @@ (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 diff --git a/src/components/markdown-package.lisp b/src/components/markdown-package.lisp index ea60250..77a2c3c 100644 --- a/src/components/markdown-package.lisp +++ b/src/components/markdown-package.lisp @@ -1,5 +1,3 @@ -;;; markdown-package.lisp — Package definition for cl-tty.markdown - (defpackage :cl-tty.markdown (:use :cl) (:export diff --git a/src/components/markdown.lisp b/src/components/markdown.lisp index a3b3404..f3f5ce7 100644 --- a/src/components/markdown.lisp +++ b/src/components/markdown.lisp @@ -2,8 +2,6 @@ (in-package :cl-tty.markdown) -;; ─── Node constructors ──────────────────────────────────────────────────────── - (defun make-md-node (type &key children properties content url) (let ((node (list :type type))) (when children (setf (getf node :children) children)) @@ -28,9 +26,8 @@ (mapcar #'md-node-text (getf node :children)))) (t "")))) -;; ─── Block-level parser ─────────────────────────────────────────────────────── - (defun split-string-into-lines (string) + (unless string (return-from split-string-into-lines (coerce nil 'vector))) (let ((result nil) (start 0)) (flet ((add-line (end) (push (subseq string start end) result))) (loop for i from 0 below (length string) @@ -140,7 +137,6 @@ i))) (defun parse-list (lines start) - (declare (ignore start)) (let ((items nil) (i start)) (loop while (< i (length lines)) do (let* ((raw-line (aref lines i)) @@ -213,6 +209,7 @@ i)))) (defun parse-blocks (text) + (unless text (return-from parse-blocks nil)) (let ((lines (split-string-into-lines text)) (nodes nil) (i 0)) (loop while (< i (length lines)) do (let* ((line (string-trim (list #\return) (aref lines i))) @@ -249,8 +246,6 @@ (t (incf i))))) (nreverse nodes))) -;; ─── Inline parser ──────────────────────────────────────────────────────────── - (defun parse-inline (text) (unless (and text (> (length text) 0)) (return-from parse-inline nil)) (let ((nodes nil) (i 0) (len (length text))) @@ -347,8 +342,6 @@ :url (subseq text (+ close-bracket 2) close-paren)) (1+ close-paren))))) -;; ─── Syntax highlighting ────────────────────────────────────────────────────── - (defun get-highlighter (lang) (cdr (assoc lang '(("lisp" . (:comment (";" "#|" ";;") :string ("\"") @@ -503,6 +496,7 @@ (nreverse tokens))) (defun highlight-code (code language) + (unless code (return-from highlight-code nil)) (let ((highlighter (get-highlighter (and language (string-downcase language))))) (unless highlighter (return-from highlight-code (list (cons code :plain)))) (let ((tokens nil)) @@ -523,8 +517,6 @@ (defun apply-highlight-style (char-vector) (coerce char-vector 'string)) -;; ─── Diff rendering ─────────────────────────────────────────────────────────── - (defun string-prefix-p (prefix string) (and (>= (length string) (length prefix)) (string= prefix (subseq string 0 (length prefix))))) @@ -537,8 +529,6 @@ ((string-prefix-p "-" line) :removed) (t :context))) -;; ─── Rendering ──────────────────────────────────────────────────────────────── - (defun apply-style (style text) (let ((code (cond ((eql style :bold) "1") ((eql style :italic) "3") @@ -673,6 +663,7 @@ lines)) (defun render-markdown (text) + (unless text (return-from render-markdown "")) (let ((nodes (parse-blocks text)) (parts nil)) (dolist (line (render-md nodes)) (push line parts)) (with-output-to-string (s) diff --git a/src/components/mouse-package.lisp b/src/components/mouse-package.lisp index 9cc2706..6e1d27a 100644 --- a/src/components/mouse-package.lisp +++ b/src/components/mouse-package.lisp @@ -1,5 +1,5 @@ (defpackage :cl-tty.mouse - (:use :cl :cl-tty.input :cl-tty.box :cl-tty.rendering) + (:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering) (:export #:mouse-mixin #:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll diff --git a/src/components/mouse.lisp b/src/components/mouse.lisp index db68be7..5abfeea 100644 --- a/src/components/mouse.lisp +++ b/src/components/mouse.lisp @@ -39,7 +39,6 @@ Components without a layout-node or position return nil." node))))))) (recurse root))) -;; Selection (defvar *selection* nil) (defstruct (selection (:conc-name sel-)) @@ -49,12 +48,15 @@ Components without a layout-node or position return nil." (when *selection* (sel-text *selection*))) (defun copy-to-clipboard (text) - #+linux (sb-ext:run-program "xclip" (list "-selection" "clipboard") - :input text :wait nil) + #+linux + (cond + ((sb-ext:posix-getenv "WAYLAND_DISPLAY") + (sb-ext:run-program "wl-copy" nil :input text :wait nil)) + (t + (sb-ext:run-program "xclip" (list "-selection" "clipboard") + :input text :wait nil))) #+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil)) -;;; --- Selection tracking (mouse drag) --------------------------------------- - (defvar *selection-active* nil "T when a drag selection is in progress.") @@ -93,8 +95,6 @@ Components without a layout-node or position return nil." (setf *selection-start* nil *selection-end* nil) text))) -;;; --- Link clicking --------------------------------------------------------- - (defun cell-link-at (fb x y) "Return the link URL at (X Y) in framebuffer FB, or nil." (cl-tty.rendering:fb-cell-link-url fb x y)) diff --git a/src/components/package.lisp b/src/components/package.lisp index a5a2c00..1d4ce2c 100644 --- a/src/components/package.lisp +++ b/src/components/package.lisp @@ -7,24 +7,30 @@ #:box-border-style #:box-title #:box-title-align #:box-fg #:box-bg #:render-box + ;; Span #:span #:span-text #:span-bold #:span-italic #:span-underline #:span-reverse #:span-dim #:span-fg #:span-bg + ;; Text #:text #:make-text #:text-layout-node #:text-content #:text-spans #:text-fg #:text-bg #:text-wrap-mode #:render-text + ;; Utilities (for tests) #:word-wrap #:split-string + ;; Dirty tracking #: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)) diff --git a/src/components/render.lisp b/src/components/render.lisp index 9bae3e0..c83537c 100644 --- a/src/components/render.lisp +++ b/src/components/render.lisp @@ -3,9 +3,13 @@ ;; ── 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))) + (:documentation "Return the layout-node for COMPONENT.")) + +(defmethod component-layout-node ((bx box)) + (box-layout-node bx)) + +(defmethod component-layout-node ((tx text)) + (text-layout-node tx)) (defgeneric component-children (component) (:documentation "Return the children of COMPONENT, or nil.") @@ -31,20 +35,22 @@ (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))) + Computes layout at the root level, then traverses children + rendering each at their pre-computed positions. Uses the actual + terminal dimensions from BACKEND rather than hardcoded defaults." + (multiple-value-bind (w h) (backend-size backend) (begin-sync backend) - (render-node root backend w h) + (compute-layout (component-layout-node root) w h) + (render-node root backend) (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) +(defun render-node (node backend) + "Render a component NODE and its children. + Layout is computed once at the root by render-screen, so children + just render at their pre-computed positions." (render node backend) (dolist (child (component-children node)) - (render-node child backend w h))) + (render-node child backend))) (defun available-width (component) "Return the available width for COMPONENT (or 80 as default)." diff --git a/src/components/scrollbox.lisp b/src/components/scrollbox.lisp index 96a7641..8cc0dc7 100644 --- a/src/components/scrollbox.lisp +++ b/src/components/scrollbox.lisp @@ -1,46 +1,72 @@ (in-package #:cl-tty.container) (defclass scroll-box (dirty-mixin) - ((children :initform nil :initarg :children :accessor scroll-box-children :type list) - (scroll-y :initform 0 :initarg :scroll-y :accessor scroll-box-scroll-y :type fixnum) - (scroll-x :initform 0 :initarg :scroll-x :accessor scroll-box-scroll-x :type fixnum) - (sticky-scroll-p :initform t :initarg :sticky-scroll-p :accessor sticky-scroll-p :type boolean) + ((children :initform nil :initarg :children + :accessor scroll-box-children :type list) + (scroll-y :initform 0 :initarg :scroll-y + :accessor scroll-box-scroll-y :type fixnum) + (scroll-x :initform 0 :initarg :scroll-x + :accessor scroll-box-scroll-x :type fixnum) + (sticky-scroll-p :initform t :initarg :sticky-scroll-p + :accessor sticky-scroll-p :type boolean) (layout-node :initform (make-layout-node) :accessor scroll-box-layout-node))) -(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) sticky-scroll-p) +(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) + sticky-scroll-p) (make-instance 'scroll-box - :children children :scroll-y scroll-y :scroll-x scroll-x + :children children + :scroll-y scroll-y + :scroll-x scroll-x :sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p))) -(defmethod component-children ((sb scroll-box)) (scroll-box-children sb)) -(defmethod component-layout-node ((sb scroll-box)) (scroll-box-layout-node sb)) +(defmethod component-children ((sb scroll-box)) + (scroll-box-children sb)) + +(defmethod component-layout-node ((sb scroll-box)) + (scroll-box-layout-node sb)) (defun clamp-scroll (sb) + "Clamp scroll offsets to valid range." (let* ((ln (scroll-box-layout-node sb)) - (viewport-h (if ln (layout-node-height ln) 0)) - (viewport-w (if ln (layout-node-width ln) 0)) - (content-h (scroll-box-content-height sb)) - (content-w (scroll-box-content-width sb))) - (setf (scroll-box-scroll-y sb) (max 0 (min (scroll-box-scroll-y sb) (- content-h viewport-h)))) - (setf (scroll-box-scroll-x sb) (max 0 (min (scroll-box-scroll-x sb) (- content-w viewport-w)))))) + (viewport-height (if ln (layout-node-height ln) 0)) + (viewport-width (if ln (layout-node-width ln) 0)) + (content-height (scroll-box-content-height sb)) + (content-width (scroll-box-content-width sb))) + (setf (scroll-box-scroll-y sb) + (max 0 (min (scroll-box-scroll-y sb) + (- content-height viewport-height)))) + (setf (scroll-box-scroll-x sb) + (max 0 (min (scroll-box-scroll-x sb) + (- content-width viewport-width)))))) (defun scroll-by (sb dy dx) - (incf (scroll-box-scroll-y sb) dy) (incf (scroll-box-scroll-x sb) dx) - (clamp-scroll sb) (mark-dirty sb)) + "Scroll by DY rows and DX columns. Clamps to valid range." + (incf (scroll-box-scroll-y sb) dy) + (incf (scroll-box-scroll-x sb) dx) + (clamp-scroll sb) + (mark-dirty sb)) (defun scroll-box-content-height (sb) + "Total height of all children." (reduce #'+ (scroll-box-children sb) - :key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-height ln)) 1))) + :key (lambda (c) + (let ((ln (component-layout-node c))) + (if ln (max 1 (layout-node-height ln)) 1))) :initial-value 0)) (defun scroll-box-content-width (sb) + "Maximum width among children." (reduce #'max (scroll-box-children sb) - :key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-width ln)) 1))) + :key (lambda (c) + (let ((ln (component-layout-node c))) + (if ln (max 1 (layout-node-width ln)) 1))) :initial-value 0)) (defmethod render ((sb scroll-box) backend) - "Render ScrollBox children within the viewport, offset by scroll position. -Children outside the viewport are skipped." + "Render visible children with scroll offset applied. +Delegates to each child's `render` method, temporarily offsetting +its layout-node position for the scroll offset. Children outside +the viewport are clipped out." (let* ((ln (scroll-box-layout-node sb)) (vx 0) (vy 0) (vw (if ln (layout-node-width ln) 80)) @@ -52,14 +78,14 @@ Children outside the viewport are skipped." (ch (if cln (layout-node-height cln) 1)) (cy vy)) ;; Only render children that are visible in the viewport - (when (and (< (+ cy (- sy)) (+ vh vy)) - (> (+ cy (- sy) ch) vy)) + (when (and (< (- cy sy) vh) + (> (+ (- cy sy) ch) 0)) ;; Temporarily offset child's layout-node position for rendering (let ((orig-x (if cln (layout-node-x cln) 0)) (orig-y (if cln (layout-node-y cln) 0))) (when cln - (setf (layout-node-x cln) (- orig-x sx) - (layout-node-y cln) (- orig-y sy))) + (setf (layout-node-x cln) (- vx sx) + (layout-node-y cln) (- vy sy))) (unwind-protect (render child backend) (when cln @@ -68,27 +94,40 @@ Children outside the viewport are skipped." (incf vy ch))) (draw-scrollbars sb backend vw vh))) -(defun scrollbar-thumb (scroll-pos viewport-size content-size) - (if (> content-size viewport-size) (/ (float scroll-pos) (- content-size viewport-size)) 0.0)) - -(defun draw-scrollbars (sb backend viewport-w viewport-h) - (let* ((content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb)) - (sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))) - (when (> content-h viewport-h) - (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) - (thumb-pos (round (* thumb viewport-h)))) - (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :bright-black) - (draw-text backend (1- viewport-w) thumb-pos "█" nil nil))) - (when (> content-w viewport-w) - (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) - (thumb-pos (round (* thumb viewport-w)))) - (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :bright-black) - (draw-text backend thumb-pos (1- viewport-h) "█" nil nil))))) - (defun update-sticky-scroll (sb) + "If sticky-scroll-p is active and at bottom, keep at bottom." (when (sticky-scroll-p sb) (let* ((content-h (scroll-box-content-height sb)) (ln (scroll-box-layout-node sb)) (viewport-h (if ln (layout-node-height ln) 24))) (when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1)) - (setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h))))))) + (setf (scroll-box-scroll-y sb) + (max 0 (- content-h viewport-h))))))) + +(defun scrollbar-thumb (scroll-pos viewport-size content-size) + "Return the thumb position for a scrollbar (0.0 to 1.0)." + (if (> content-size viewport-size) + (/ (float scroll-pos) (- content-size viewport-size)) + 0.0)) + +(defun draw-scrollbars (sb backend viewport-w viewport-h) + "Draw scrollbars if content exceeds viewport." + (let* ((content-h (scroll-box-content-height sb)) + (content-w (scroll-box-content-width sb)) + (sy (scroll-box-scroll-y sb)) + (sx (scroll-box-scroll-x sb)) + (ln (scroll-box-layout-node sb)) + (ox (if ln (layout-node-x ln) 0)) + (oy (if ln (layout-node-y ln) 0))) + ;; Vertical scrollbar + (when (> content-h viewport-h) + (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) + (thumb-pos (round (* thumb viewport-h)))) + (draw-rect backend (+ ox (1- viewport-w)) oy 1 viewport-h :bg :scrollbar-bg) + (draw-text backend (+ ox (1- viewport-w)) (+ oy thumb-pos) "█" nil nil))) + ;; Horizontal scrollbar + (when (> content-w viewport-w) + (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) + (thumb-pos (round (* thumb viewport-w)))) + (draw-rect backend ox (+ oy (1- viewport-h)) viewport-w 1 :bg :scrollbar-bg) + (draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil))))) diff --git a/src/components/select.lisp b/src/components/select.lisp index fb57324..6bafd64 100644 --- a/src/components/select.lisp +++ b/src/components/select.lisp @@ -1,77 +1,120 @@ (in-package #:cl-tty.select) (defclass select (dirty-mixin) - ((options :initform nil :initarg :options :accessor select-options :type list) - (filter :initform nil :initarg :filter :accessor select-filter :type (or string null)) - (selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum) - (on-select :initform nil :initarg :on-select :accessor select-on-select) - (layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node))) + ((options :initform nil :initarg :options + :accessor select-options :type list) + (filter :initform nil :initarg :filter + :accessor select-filter :type (or string null)) + (selected-index :initform 0 :initarg :selected-index + :accessor select-selected-index :type fixnum) + (on-select :initform nil :initarg :on-select + :accessor select-on-select) + (layout-node :initform (make-layout-node) :initarg :layout-node + :accessor select-layout-node))) (defun make-select (&key options filter on-select) - (make-instance 'select :options (or options nil) :filter filter :on-select on-select)) + (make-instance 'select + :options (or options nil) + :filter filter + :on-select on-select)) -(defmethod component-layout-node ((sel select)) (select-layout-node sel)) +(defmethod component-layout-node ((sel select)) + (select-layout-node sel)) (defun select-filtered-options (sel) - (let* ((filter (select-filter sel)) (all-options (select-options sel)) - (filtered (if (null filter) all-options + "Return list of options matching the current filter, in display order. + Each item: (display-index original-index option-plist)." + (let* ((filter (select-filter sel)) + (all-options (select-options sel)) + (filtered (if (null filter) + all-options (let ((lower (string-downcase filter))) (remove-if-not (lambda (opt) (or (getf opt :category) (let ((title (string-downcase (getf opt :title)))) - (or (search lower title) (fuzzy-match-p lower title))))) + (or (search lower title) + (fuzzy-match-p lower title))))) all-options))))) - (loop for opt in filtered for i from 0 + (loop for opt in filtered + for i from 0 collect (list i (position opt all-options) opt)))) (defun fuzzy-match-p (query target) - (let* ((q (remove-duplicates (coerce (string-downcase query) 'list))) - (tg (remove-duplicates (coerce (string-downcase target) 'list))) - (intersection (length (intersection q tg))) - (union (length (union q tg)))) + "T if character-set Jaccard similarity exceeds threshold (0.3)." + (let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list))) + (t-chars (remove-duplicates (coerce (string-downcase target) 'list))) + (intersection (length (intersection q-chars t-chars))) + (union (length (union q-chars t-chars)))) (if (zerop union) nil (> (/ (float intersection) union) 0.3)))) (defun select-clamp-index (sel) - (let* ((filtered (select-filtered-options sel)) (count (length filtered))) - (if (zerop count) (setf (select-selected-index sel) 0) - (setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count))))))) + "Ensure selected-index is valid. Wraps if empty." + (let* ((filtered (select-filtered-options sel)) + (count (length filtered))) + (if (zerop count) + (setf (select-selected-index sel) 0) + (setf (select-selected-index sel) + (max 0 (min (select-selected-index sel) (1- count))))))) (defun select-next (sel) - (let* ((filtered (select-filtered-options sel)) (count (length filtered)) + "Move selection to next non-category option. Wraps at end." + (let* ((filtered (select-filtered-options sel)) + (count (length filtered)) (current (select-selected-index sel))) (when (plusp count) (loop for i from 1 below count for idx = (mod (+ current i) count) for opt = (third (nth idx filtered)) when (not (getf opt :category)) - do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) + do (setf (select-selected-index sel) idx) + (mark-dirty sel) + (return))))) (defun select-prev (sel) - (let* ((filtered (select-filtered-options sel)) (count (length filtered)) + "Move selection to previous non-category option. Wraps at start." + (let* ((filtered (select-filtered-options sel)) + (count (length filtered)) (current (select-selected-index sel))) (when (plusp count) (loop for i from 1 below count for idx = (mod (- current i) count) for opt = (third (nth idx filtered)) when (not (getf opt :category)) - do (setf (select-selected-index sel) idx) (mark-dirty sel) (return))))) + do (setf (select-selected-index sel) idx) + (mark-dirty sel) + (return))))) (defun select-handle-key (sel event) - (let ((key (key-event-key event)) (ctrl (key-event-ctrl event))) + "Handle a key-event. Returns T if handled." + (let ((key (key-event-key event)) + (ctrl (key-event-ctrl event))) (cond - ((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t) - ((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t) + ((or (eql key :down) (and ctrl (eql key :n))) + (select-next sel) t) + ((or (eql key :up) (and ctrl (eql key :p))) + (select-prev sel) t) ((eql key :enter) - (let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel)) - (item (when (< idx (length filtered)) (third (nth idx filtered))))) - (when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t)) - ((eql key :escape) nil) (t nil)))) + (let* ((filtered (select-filtered-options sel)) + (idx (select-selected-index sel)) + (item (when (< idx (length filtered)) + (third (nth idx filtered))))) + (when item + (let ((cb (select-on-select sel))) + (when cb (funcall cb item)))) + t)) + ((eql key :escape) nil) + (t nil)))) (defun select-visible-options (sel) - (let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80)) - (filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel)) - (half (floor (1- height) 2)) (start (max 0 (- sel-idx half))) + "Return filtered options that fit within the viewport." + (let* ((ln (select-layout-node sel)) + (height (if ln (layout-node-height ln) 80)) + (filtered (select-filtered-options sel)) + (sel-idx (select-selected-index sel)) + ;; Show items around the selection + (half (floor (1- height) 2)) + (start (max 0 (- sel-idx half))) (end (min (length filtered) (+ start height)))) (subseq filtered start end))) @@ -80,17 +123,24 @@ (x (if ln (layout-node-x ln) 0)) (y (if ln (layout-node-y ln) 0)) (w (if ln (layout-node-width ln) 80)) - (visible (select-visible-options sel)) (sel-idx (select-selected-index sel))) + (visible (select-visible-options sel)) + (sel-idx (select-selected-index sel))) (dolist (item visible) - (let* ((display-idx (first item)) (option (third item)) - (title (getf option :title)) (cat (getf option :category)) - (selected (eql display-idx sel-idx)) + (let* ((display-idx (first item)) + (option (third item)) + (title (getf option :title)) + (is-category (getf option :category)) + (is-selected (eql display-idx sel-idx)) (display (if (> (length title) (1- w)) - (concatenate 'string (subseq title 0 (1- w)) "…") title))) - (cond (cat (draw-text backend x y display :text-muted nil)) - (selected - (draw-rect backend x y w 1 :bg :accent) - (draw-text backend x y display :background :accent)) - (t (draw-text backend x y display nil nil))) + (concatenate 'string (subseq title 0 (1- w)) "…") + title))) + (cond + (is-category + (draw-text backend x y display :text-muted nil)) + (is-selected + (draw-rect backend x y w 1 :bg :accent) + (draw-text backend x y display :background :accent)) + (t + (draw-text backend x y display nil nil))) (incf y 1))) (values))) diff --git a/src/components/slot.lisp b/src/components/slot.lisp index eb68c0a..6ee7a27 100644 --- a/src/components/slot.lisp +++ b/src/components/slot.lisp @@ -1,21 +1,53 @@ (in-package :cl-tty.slot) -(defvar *slots* (make-hash-table :test #'equal) - "Hash table mapping slot name (string) -> list of (order . render-fn) pairs.") +(defvar *slots* (make-hash-table :test 'equal) + "Hash table mapping slot name (string) -> plist of slot data. +Each entry: (:mode :entries <(order . render-fn) list>).") -(defun defslot (name &key (order 0) render-fn) +(defun defslot (name &key (order 0) render-fn (mode :stack)) (let* ((key (string name)) - (entries (gethash key *slots*))) - (if (null entries) - (setf (gethash key *slots*) (list (cons order render-fn))) - (setf (gethash key *slots*) - (sort (cons (cons order render-fn) entries) #'< :key #'car)))) + (slot (gethash key *slots*))) + (if (null slot) + ;; First registration — validate and set mode, create entry + (progn + (assert (member mode '(:stack :replace :single-winner)) () + "Invalid slot mode: ~S (use :stack, :replace, or :single-winner)" + mode) + (setf (gethash key *slots*) + (list :mode mode + :entries (list (cons order render-fn))))) + ;; Existing slot — respect frozen mode + (let ((entries (getf slot :entries))) + (ecase (getf slot :mode) + (:stack + (setf (getf slot :entries) + (sort (cons (cons order render-fn) entries) + #'< :key #'car))) + (:replace + (setf (getf slot :entries) + (list (cons order render-fn)))) + (:single-winner + ;; First registration already present — no-op + (values)))))) render-fn) (defun slot-render (slot-name &rest args) - (let ((entries (gethash (string slot-name) *slots*))) - (when entries - (mapcar (lambda (entry) (apply (cdr entry) args)) entries)))) + (let ((slot (gethash (string slot-name) *slots*))) + (when slot + (let ((mode (getf slot :mode)) + (entries (getf slot :entries))) + (ecase mode + (:stack + (mapcar (lambda (entry) + (let ((fn (cdr entry))) + (when fn (apply fn args)))) + entries)) + (:replace + (let ((fn (cdar (last entries)))) + (when fn (apply fn args)))) + (:single-winner + (let ((fn (cdar entries))) + (when fn (apply fn args))))))))) (defun slot-p (slot-name) (nth-value 1 (gethash (string slot-name) *slots*))) diff --git a/src/components/tabbar.lisp b/src/components/tabbar.lisp index 1ec6219..81eb50c 100644 --- a/src/components/tabbar.lisp +++ b/src/components/tabbar.lisp @@ -1,8 +1,10 @@ (in-package #:cl-tty.container) (defclass tab-bar (dirty-mixin) - ((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list) - (active :initform nil :initarg :active :accessor tab-bar-active) + ((tabs :initform nil :initarg :tabs + :accessor tab-bar-tabs :type list) + (active :initform nil :initarg :active + :accessor tab-bar-active) (layout-node :initform (make-layout-node) :accessor tab-bar-layout-node) (focusable :initform t :accessor tab-bar-focusable))) @@ -10,44 +12,71 @@ (make-instance 'tab-bar :tabs (or tabs nil) :active active)) (defun tab-bar-add (tb id title) - (setf (tab-bar-tabs tb) (nconc (tab-bar-tabs tb) (list (list :id id :title title)))) - (unless (tab-bar-active tb) (setf (tab-bar-active tb) id)) id) + "Add a tab with ID and TITLE. Sets as active if first tab." + (setf (tab-bar-tabs tb) + (nconc (tab-bar-tabs tb) (list (list :id id :title title)))) + (unless (tab-bar-active tb) + (setf (tab-bar-active tb) id)) + id) -(defmethod component-layout-node ((tb tab-bar)) (tab-bar-layout-node tb)) +(defmethod component-layout-node ((tb tab-bar)) + (tab-bar-layout-node tb)) (defun tab-bar-next (tb) - (let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb)) + "Move to next tab." + (let* ((tabs (tab-bar-tabs tb)) + (current (tab-bar-active tb)) (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) (pos (position current ids))) - (when pos (let ((next (nth (mod (1+ pos) (length ids)) ids))) - (setf (tab-bar-active tb) next) (mark-dirty tb))))) + (when pos + (let ((next (nth (mod (1+ pos) (length ids)) ids))) + (setf (tab-bar-active tb) next) + (mark-dirty tb))))) (defun tab-bar-prev (tb) - (let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb)) + "Move to previous tab." + (let* ((tabs (tab-bar-tabs tb)) + (current (tab-bar-active tb)) (ids (mapcar (lambda (tab) (getf tab :id)) tabs)) (pos (position current ids))) - (when pos (let ((prev (nth (mod (1- pos) (length ids)) ids))) - (setf (tab-bar-active tb) prev) (mark-dirty tb))))) + (when pos + (let ((prev (nth (mod (1- pos) (length ids)) ids))) + (setf (tab-bar-active tb) prev) + (mark-dirty tb))))) -(defun tab-bar-select (tb id) (setf (tab-bar-active tb) id) (mark-dirty tb)) +(defun tab-bar-select (tb id) + "Select a tab by ID." + (setf (tab-bar-active tb) id) + (mark-dirty tb)) (defun tab-bar-handle-key (tb event) - (case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil))) + "Handle a key-event on a TabBar. Returns T if handled." + (case (key-event-key event) + (:left (tab-bar-prev tb) t) + (:right (tab-bar-next tb) t) + (t nil))) (defmethod render ((tb tab-bar) backend) (let* ((ln (tab-bar-layout-node tb)) (x (if ln (layout-node-x ln) 0)) (y (if ln (layout-node-y ln) 0)) (w (if ln (layout-node-width ln) 80)) - (active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x)) + (active-id (tab-bar-active tb)) + (tabs (tab-bar-tabs tb)) + (x-pos x)) (dolist (tab tabs) - (let* ((id (getf tab :id)) (title (getf tab :title)) - (label (format nil " ~A " title)) (label-len (length label)) + (let* ((id (getf tab :id)) + (title (getf tab :title)) + (label (format nil " ~A " title)) + (label-len (length label)) (is-active (eql id active-id)) (fg (if is-active :accent :text-muted)) (bg (if is-active :background-element nil))) - (when (>= (+ x-pos label-len 2) w) - (draw-text backend x-pos y "..." :text-muted nil) (return)) + ;; Check if tab fits + (when (>= (+ x-pos label-len 2) (+ x w)) + (draw-text backend x-pos y "..." :text-muted nil) + (return)) + ;; Draw tab (draw-text backend x-pos y label fg bg) - (incf x-pos (+ label-len 2))))) - (values)) + (incf x-pos (+ label-len 2)))) + (values))) diff --git a/src/components/text-input.lisp b/src/components/text-input.lisp index 4259f6b..924745c 100644 --- a/src/components/text-input.lisp +++ b/src/components/text-input.lisp @@ -1,8 +1,5 @@ (in-package #:cl-tty.input) -;;; --------------------------------------------------------------------------- -;;; TextInput class -;;; --------------------------------------------------------------------------- (defclass text-input (dirty-mixin) ((value :initform "" :initarg :value :accessor text-input-value :type string) @@ -25,114 +22,67 @@ :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))) + (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))) + (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))) + (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)))) + (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)))) + (when (plusp (text-input-cursor input)) (decf (text-input-cursor input))) + (mark-dirty input)) (defun text-input-move-right (input) - (when (< (text-input-cursor input) (length (text-input-value input))) - (incf (text-input-cursor input)))) + (when (< (text-input-cursor input) (length (text-input-value input))) (incf (text-input-cursor input))) + (mark-dirty input)) (defun text-input-move-home (input) - (setf (text-input-cursor input) 0)) + (setf (text-input-cursor input) 0) + (mark-dirty input)) (defun text-input-move-end (input) - (setf (text-input-cursor input) (length (text-input-value input)))) + (setf (text-input-cursor input) (length (text-input-value input))) + (mark-dirty 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))) + (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))) + (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))) + (: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) @@ -142,30 +92,19 @@ (: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)))))))) + (: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)))))))) -;;; --------------------------------------------------------------------------- -;;; Rendering -;;; --------------------------------------------------------------------------- (defmethod render ((in text-input) (backend t)) - "Render text-input value or placeholder at layout position." (let* ((ln (text-input-layout-node in)) - (x (if ln (layout-node-x ln) 0)) - (y (if ln (layout-node-y ln) 0)) + (x (if ln (layout-node-x ln) 0)) (y (if ln (layout-node-y ln) 0)) (w (if ln (layout-node-width ln) 80)) - (value (text-input-value in)) - (cursor (text-input-cursor in)) - (display (if (plusp (length value)) - value - (or (text-input-placeholder in) ""))) + (value (text-input-value in)) (cursor (text-input-cursor in)) + (display (if (plusp (length value)) value (or (text-input-placeholder in) ""))) (truncated (subseq display 0 (min (length display) w)))) - (declare (ignore w cursor)) - (draw-text backend x y truncated nil nil))) + (draw-text backend x y truncated nil nil) + (when (plusp (length value)) + (let ((cursor-col (min cursor (length truncated)))) + (draw-text backend (+ x cursor-col) y "█" :bright-white nil))))) diff --git a/src/components/text.lisp b/src/components/text.lisp index c9cf389..1d57555 100644 --- a/src/components/text.lisp +++ b/src/components/text.lisp @@ -1,7 +1,5 @@ (in-package :cl-tty.box) -;; ── Text Renderable ──────────────────────────────────────────── - (defclass span () ((text :initarg :text :accessor span-text) (bold :initform nil :initarg :bold :accessor span-bold) @@ -61,8 +59,7 @@ do (draw-text backend x (+ y row) line fg bg))))))) (defun word-wrap (text max-width) - "Split TEXT into lines, each <= MAX-WIDTH chars. -Breaks at word boundaries. Words exceeding MAX-WIDTH are hard-broken." + "Split TEXT into lines, each <= MAX-WIDTH chars." (if (or (zerop max-width) (zerop (length text))) (list "") (let ((words (split-string text)) (lines nil) (current nil) (current-len 0)) @@ -70,7 +67,9 @@ Breaks at word boundaries. Words exceeding MAX-WIDTH are hard-broken." (let ((wl (length word))) (cond ((<= wl max-width) (if (and current (<= (+ current-len 1 wl) max-width)) - (push word current) + (progn + (push word current) + (incf current-len (1+ wl))) (progn (when current (push (format nil "~{~A~^ ~}" (nreverse current)) lines)) diff --git a/src/components/textarea.fasl b/src/components/textarea.fasl deleted file mode 100644 index e63852b..0000000 Binary files a/src/components/textarea.fasl and /dev/null differ diff --git a/src/components/textarea.lisp b/src/components/textarea.lisp index 5c8b1f0..c6c2df6 100644 --- a/src/components/textarea.lisp +++ b/src/components/textarea.lisp @@ -1,8 +1,5 @@ (in-package #:cl-tty.input) -;;; --------------------------------------------------------------------------- -;;; Textarea class -;;; --------------------------------------------------------------------------- (defclass textarea (dirty-mixin) ((value :initform "" :initarg :value :accessor textarea-value :type string) (cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum) @@ -21,9 +18,6 @@ :value (or value "") :on-submit on-submit)) -;;; --------------------------------------------------------------------------- -;;; Line helpers -;;; --------------------------------------------------------------------------- (defun textarea-lines (ta) "Split value into lines." (%split-string (textarea-value ta) #\Newline)) @@ -39,11 +33,9 @@ (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)))))) + (max 0 (min (textarea-cursor-col ta) line-len))))) + (mark-dirty ta)) -;;; --------------------------------------------------------------------------- -;;; Utility: join strings with newline -;;; --------------------------------------------------------------------------- (defun %join-lines (lines) "Join a sequence of strings with newlines." (with-output-to-string (s) @@ -52,9 +44,6 @@ 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) @@ -140,9 +129,6 @@ (decf (textarea-cursor-col ta)) (mark-dirty ta)))))) -;;; --------------------------------------------------------------------------- -;;; Cursor movement -;;; --------------------------------------------------------------------------- (defun textarea-move-up (ta) (decf (textarea-cursor-row ta)) (textarea-ensure-cursor ta)) @@ -151,9 +137,6 @@ (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))) @@ -182,9 +165,6 @@ (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 @@ -207,11 +187,13 @@ (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)))))) + (:home (setf (textarea-cursor-col ta) 0) + (textarea-ensure-cursor ta)) + (:end (let ((lines (textarea-lines ta))) + (when (< (textarea-cursor-row ta) (length lines)) + (setf (textarea-cursor-col ta) + (length (nth (textarea-cursor-row ta) lines)))) + (textarea-ensure-cursor ta))) (:enter (let ((cb (textarea-on-submit ta))) (if cb (funcall cb (textarea-value ta)) @@ -236,9 +218,6 @@ (when (and ch (graphic-char-p ch)) (textarea-insert-char ta ch)))))))) -;;; --------------------------------------------------------------------------- -;;; Rendering -;;; --------------------------------------------------------------------------- (defmethod render ((ta textarea) (backend t)) "Render textarea lines at layout position." (let* ((ln (textarea-layout-node ta)) diff --git a/src/components/theme.lisp b/src/components/theme.lisp index f3cc09d..4828e83 100644 --- a/src/components/theme.lisp +++ b/src/components/theme.lisp @@ -1,7 +1,5 @@ (in-package :cl-tty.box) -;; ── Theme Engine ────────────────────────────────────────────── - (defclass theme () ((mode :initform :dark :initarg :mode :accessor theme-mode) (roles :initform (make-hash-table) :accessor theme-roles))) @@ -35,7 +33,7 @@ color roles resolve to hex at SGR generation time." (getf preset :dark) (getf preset :light))) ;; Populate backend theme color map - (theme-map (symbol-value (find-symbol "*THEME-COLORS*" :cl-tty.backend)))) + (theme-map cl-tty.backend:*theme-colors*)) ;; Set theme colors (loop for (role hex) on colors by #'cddr do (setf (theme-color theme role) hex) diff --git a/layout/layout.lisp b/src/layout/layout.lisp similarity index 85% rename from layout/layout.lisp rename to src/layout/layout.lisp index d71f569..c5eaeb1 100644 --- a/layout/layout.lisp +++ b/src/layout/layout.lisp @@ -1,5 +1,3 @@ -;;; layout — Pure CL Flexbox layout engine - (defpackage :cl-tty.layout (:use :cl) (:export @@ -15,7 +13,6 @@ #:layout-node-parent #:layout-node-fixed-width #:layout-node-fixed-height #:normalize-box #:box-edge)) - (in-package :cl-tty.layout) (defun normalize-box (spec) @@ -70,13 +67,7 @@ (delete child (layout-node-children parent))) child) -;; ── Solver ───────────────────────────────────────────────────── - (defun distribute-sizes (children avail gap horizontal) - "Compute child sizes given available space and gap. -HORIZONTAL is non-nil when distributing width (row layout). -Each child starts from its fixed size (if any). Remaining space -is distributed by grow ratio; overflow is reduced by shrink ratio." (let* ((n (length children)) (gap-total (* gap (max 0 (1- n)))) (base (mapcar (lambda (c) @@ -89,18 +80,23 @@ is distributed by grow ratio; overflow is reduced by shrink ratio." (remaining (- avail base-total gap-total)) (grow-total (reduce #'+ (mapcar #'layout-node-grow children))) (shrink-total (reduce #'+ (mapcar #'layout-node-shrink children)))) - (mapcar (lambda (c b) - (let ((sz b)) - (when (and (plusp remaining) (plusp grow-total)) - (incf sz (round (* remaining (/ (layout-node-grow c) grow-total))))) - (when (and (minusp remaining) (plusp shrink-total)) - (decf sz (round (* (abs remaining) (/ (layout-node-shrink c) shrink-total))))) - (max 1 sz))) - children base))) + (let ((sizes (mapcar (lambda (c b) + (let ((sz b)) + (when (and (plusp remaining) (plusp grow-total)) + (incf sz (round (* remaining (/ (layout-node-grow c) grow-total))))) + (when (and (minusp remaining) (plusp shrink-total)) + (decf sz (round (* (abs remaining) (/ (layout-node-shrink c) shrink-total))))) + (max 1 sz))) + children base))) + (when (or (and (plusp remaining) (plusp grow-total)) + (and (minusp remaining) (plusp shrink-total))) + (let ((delta (- avail gap-total (reduce #'+ sizes)))) + (when (/= delta 0) + (loop :for i :from 0 :below (min (abs delta) n) + :do (incf (nth i sizes) (signum delta)))))) + sizes))) (defun compute-layout (root available-width available-height) - "Layout all children of ROOT within the given dimensions. -Recursively computes position and size for every node." (labels ((place-children (node x y max-w max-h) (let* ((children (layout-node-children node)) (is-row (eql (layout-node-direction node) :row)) @@ -112,10 +108,8 @@ Recursively computes position and size for every node." (ch (max 0 (- max-h pt pb))) (gap (layout-node-gap node)) (sizes (distribute-sizes children (if is-row cw ch) gap is-row))) - ;; Position the node (content area starts at padding inset) (setf (layout-node-x node) (+ x pl) (layout-node-y node) (+ y pt)) - ;; Place each child sequentially (loop :with pos = 0 :for child :in children :for size :in sizes @@ -134,7 +128,6 @@ Recursively computes position and size for every node." (if is-row size cw) (if is-row ch size)) (incf pos (+ size gap))) - ;; Compute own size from children (let ((last-child (car (last children)))) (if is-row (setf (layout-node-width node) @@ -158,8 +151,6 @@ Recursively computes position and size for every node." (place-children root 0 0 available-width available-height) root)) -;; ── Macros ───────────────────────────────────────────────────── - (defmacro vbox ((&key grow shrink padding margin gap width height) &body children) (let ((n (gensym))) `(let ((,n (make-layout-node :direction :column diff --git a/layout/tests.lisp b/src/layout/tests.lisp similarity index 90% rename from layout/tests.lisp rename to src/layout/tests.lisp index 4433b48..1fb9e30 100644 --- a/layout/tests.lisp +++ b/src/layout/tests.lisp @@ -119,17 +119,13 @@ (is (= (layout-node-y (elt sc 0)) 0)) (is (= (layout-node-y (elt sc 1)) 3))))) -;; ── Edge Cases ──────────────────────────────────────────────── - (test empty-container-does-not-crash - "compute-layout on a node with no children should not error" (let ((r (make-layout-node))) (compute-layout r 20 20) (is (integerp (layout-node-width r))) (is (integerp (layout-node-height r))))) (test single-child-in-column - "A column with one child places it correctly" (let* ((r (make-layout-node :direction :column :width 10 :height 20)) (c (make-layout-node :height 5))) (layout-node-add-child r c) @@ -138,7 +134,6 @@ (is (= (layout-node-height c) 5)))) (test zero-size-container - "compute-layout with zero available space should not error" (let* ((r (make-layout-node :direction :column)) (c (make-layout-node :height 5))) (layout-node-add-child r c) @@ -147,17 +142,15 @@ (is (integerp (layout-node-y c))))) (test deep-nesting-three-levels - "Three-level deep nesting produces correct leaf positions" - (let* ((out (vbox () ; outer box - (vbox (:grow 1) ; middle box - (make-layout-node :height 2)))) ; leaf + (let* ((out (vbox () + (vbox (:grow 1) + (make-layout-node :height 2)))) (leaf (elt (layout-node-children (elt (layout-node-children out) 0)) 0))) (compute-layout out 20 20) (is (= (layout-node-y leaf) 0)))) (test large-padding-leaves-room - "Large padding reduces content area but doesn't crash" (let* ((r (make-layout-node :direction :column :padding '(:top 5 :left 5 :bottom 5 :right 5))) (c (make-layout-node :height 3))) @@ -167,7 +160,6 @@ (is (= (layout-node-y c) 5)))) (test negative-grow-is-clamped - "Grow values are adjusted but still compute" (let* ((r (make-layout-node :direction :row :width 10)) (c (make-layout-node :width 5 :grow -1))) (layout-node-add-child r c) diff --git a/src/rendering/framebuffer.lisp b/src/rendering/framebuffer.lisp index 241ebb3..6af4243 100644 --- a/src/rendering/framebuffer.lisp +++ b/src/rendering/framebuffer.lisp @@ -12,8 +12,6 @@ (in-package :cl-tty.rendering) -;;; ─── Cell — immutable per-cell state ───────────────────────────────────────── - (defstruct cell "A single terminal cell — character, colors, and attributes." (char #\space :type character) @@ -24,8 +22,6 @@ (underline nil :type boolean) (link-url nil)) -;;; ─── Framebuffer — 2D array of cells ──────────────────────────────────────── - (defun make-framebuffer (width height) "Create a 2D array of CELL with dimensions HEIGHT x WIDTH." (make-array (list height width) @@ -40,8 +36,6 @@ "Return the height (rows) of framebuffer FB." (if (arrayp fb) (array-dimension fb 0) 0)) -;;; ─── Framebuffer Backend — implements backend protocol ───────────────────── - (defclass framebuffer-backend (backend) ((framebuffer :initform nil :accessor fb-framebuffer) (scissor-x :initform 0 :accessor fb-scissor-x) @@ -55,8 +49,6 @@ (setf (fb-framebuffer fb) (make-framebuffer width height)) fb)) -;;; ─── Drawing methods ───────────────────────────────────────────────────────── - (defun %in-scissor-p (fb cx cy) "Check if (CX, CY) falls within the current scissor rectangle." (let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb)) @@ -129,8 +121,6 @@ (dotimes (i (min 3 width)) (%set-cell fb (+ x i) y #\. :fg fg :bg bg))) -;;; ─── Diff ──────────────────────────────────────────────────────────────────── - (defun cells-equal-p (a b) "Return T if two cells have identical content and style." (and (eql (cell-char a) (cell-char b)) @@ -153,8 +143,6 @@ (push (list x y b) changes))))) (nreverse changes))) -;;; ─── Flush ─────────────────────────────────────────────────────────────────── - (defun flush-framebuffer (prev-fb curr-fb backend) "Diff PREV-FB and CURR-FB and flush changes to BACKEND. Returns the number of changed cells." @@ -176,8 +164,6 @@ Returns the number of changed cells." (end-sync backend)) count)) -;;; --- Frame inspection --------------------------------------------------- - (defun fb-cell-link-url (fb x y) "Return the link URL at (X Y) in framebuffer FB, or nil." (when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0)) @@ -198,8 +184,6 @@ Returns the number of changed cells." (princ (cell-char c) s))) (when (< y y-max) (princ #\Newline s)))))) -;;; ─── Scissor clipping ──────────────────────────────────────────────────────── - (defmacro with-scissor ((fb x y w h) &body body) "Clip all drawing on FB to rectangle (X Y W H)." (let ((old-x (gensym)) (old-y (gensym)) diff --git a/system-index.txt b/system-index.txt deleted file mode 100644 index 586f38c..0000000 --- a/system-index.txt +++ /dev/null @@ -1 +0,0 @@ -cl-tty.asd diff --git a/tests/framebuffer-tests.lisp b/tests/framebuffer-tests.lisp index be3dcda..fc3cef2 100644 --- a/tests/framebuffer-tests.lisp +++ b/tests/framebuffer-tests.lisp @@ -58,6 +58,21 @@ (is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws") (is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped")))) +(test flush-different-sized-fbs-handles-edge-cells + (let* ((small-fb (make-framebuffer 5 5)) + (large-fb (make-framebuffer 10 10)) + (be (make-simple-backend :output-stream (make-string-output-stream)))) + (setf (aref small-fb 0 0) (make-cell :char #\X :fg :red)) + (let ((changes (diff-framebuffers small-fb large-fb))) + (is (= 1 (length changes)) "one cell changed in overlap region")) + (let ((changed (flush-framebuffer small-fb large-fb be))) + (is (= 1 changed) "flush reports 1 changed cell")) + (setf (aref large-fb 9 9) (make-cell :char #\Y :fg :blue)) + (let ((changes2 (diff-framebuffers large-fb small-fb))) + (is (= 1 (length changes2)) "only overlapping region diffed")) + (let ((changed2 (flush-framebuffer large-fb small-fb be))) + (is (= 1 changed2) "flush with shrunk fb reports 1 changed cell")))) + (test flush-fb-copies-to-backend (let* ((real-be (make-simple-backend :output-stream (make-string-output-stream))) (fb (make-framebuffer-backend))) @@ -65,8 +80,6 @@ (let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be))) (is (>= changed 1))))) -;; ── Frame inspection ────────────────────────────────────────── - (test fb-cell-link-url-returns-nil-for-blank-cell (let ((fb (make-framebuffer 10 10))) (is (null (fb-cell-link-url fb 5 5))))) diff --git a/tests/input-tests.lisp b/tests/input-tests.lisp index 1f3971f..a5cf952 100644 --- a/tests/input-tests.lisp +++ b/tests/input-tests.lisp @@ -36,6 +36,28 @@ (is (= (mouse-event-x e) 10)) (is (= (mouse-event-y e) 5)))) +;; ── UTF-8 Decode Tests ────────────────────────────────────────── + +(test utf8-decode-latin1-supplement + "0xC3 0xA9 (é) decodes to code point 233." + (is (= (cl-tty.input:utf8-decode '(#xc3 #xa9)) 233))) + +(test utf8-decode-euro-sign + "0xE2 0x82 0xAC (€) decodes to code point 8364." + (is (= (cl-tty.input:utf8-decode '(#xe2 #x82 #xac)) 8364))) + +(test utf8-decode-emoji + "0xF0 0x9F 0x92 0xA9 (💩) decodes to code point 128169." + (is (= (cl-tty.input:utf8-decode '(#xf0 #x9f #x92 #xa9)) 128169))) + +(test utf8-decode-invalid-short + "Invalid byte 0x80 alone returns nil." + (is-false (cl-tty.input:utf8-decode '(#x80)))) + +(test utf8-decode-invalid-overlong + "Overlong 2-byte sequence 0xC0 0x80 returns nil." + (is-false (cl-tty.input:utf8-decode '(#xc0 #x80)))) + ;; ── TextInput Tests ───────────────────────────────────────────── (test text-input-empty @@ -168,14 +190,11 @@ (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")))) + (is (string= (textarea-value a) (format nil "a~Cb" #\Newline))))) (test textarea-cursor-up-down "Cursor moves between lines maintaining column position." - (let ((a (make-textarea :value "abc -de -fghi"))) + (let ((a (make-textarea :value (format nil "abc~Cde~Cfghi" #\Newline #\Newline)))) (setf (textarea-cursor-row a) 1) (setf (textarea-cursor-col a) 1) (handle-textarea-input a (make-key-event :key :up)) @@ -187,8 +206,7 @@ fghi"))) (test textarea-cursor-up-down-bounds "Cursor cannot move past first or last line." - (let ((a (make-textarea :value "a -b"))) + (let ((a (make-textarea :value (format nil "a~Cb" #\Newline)))) (handle-textarea-input a (make-key-event :key :up)) (is (= (textarea-cursor-row a) 0)) (setf (textarea-cursor-row a) 1) @@ -197,8 +215,7 @@ b"))) (test textarea-backspace-joins-lines "Backspace at start of a line joins with previous." - (let ((a (make-textarea :value "hello -world"))) + (let ((a (make-textarea :value (format nil "hello~Cworld" #\Newline)))) (setf (textarea-cursor-row a) 1) (setf (textarea-cursor-col a) 0) (handle-textarea-input a (make-key-event :key :backspace)) @@ -220,6 +237,15 @@ world"))) (is (string= (textarea-value a) "a")))) ;; ── Keybinding Tests ──────────────────────────────────────────── +;; These tests verify the keymap dispatch system works correctly +;; when wired up. Note: dispatch-key-event is NOT called by the +;; demo's event loop — users MUST call it explicitly in their own +;; event loops if they want to use the defkeymap/dispatch-key-event +;; system. See src/components/keybindings.lisp for details. +;; +;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single +;; key specs work. The *chord-timeout* variable and list-of-lists +;; syntax are reserved for future implementation. (test keymap-simple "A keymap dispatches to its handler on matching event." @@ -260,6 +286,78 @@ world"))) (is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t))) (is-false (key-match-p :ctrl+p (make-key-event :key :p)))) +(test key-spec-alt-modifier + "Alt modifier is matched correctly." + (is-true (key-match-p :alt+x (make-key-event :key :x :alt t))) + (is-false (key-match-p :alt+x (make-key-event :key :x))) + (is-false (key-match-p :alt+x (make-key-event :key :x :ctrl t)))) + +(test key-spec-shift-modifier + "Shift modifier is matched correctly." + (is-true (key-match-p :shift+tab (make-key-event :key :tab :shift t))) + (is-false (key-match-p :shift+tab (make-key-event :key :tab)))) + +(test key-spec-plain + "Plain key spec matches unmodified keys." + (is-true (key-match-p :enter (make-key-event :key :enter))) + (is-true (key-match-p :escape (make-key-event :key :escape))) + (is-false (key-match-p :enter (make-key-event :key :escape)))) + +(test key-spec-list-form + "List-form spec (:ctrl+p) matches same as keyword :ctrl+p." + (is-true (key-match-p '(:ctrl+p) (make-key-event :key :p :ctrl t))) + (is-false (key-match-p '(:ctrl+p) (make-key-event :key :a :ctrl t)))) + +(test dispatch-return-value-match + "dispatch-key-event returns T on matching binding." + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) + (is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))) + +(test dispatch-return-value-no-match + "dispatch-key-event returns NIL when no binding matches." + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) + (is-false (dispatch-key-event (make-key-event :key :a)))) + +(test dispatch-empty-keymap + "dispatch-key-event returns NIL on empty keymap." + (setf (gethash :global *keymaps*) (make-keymap :name :global)) + (is-false (dispatch-key-event (make-key-event :key :a)))) + +(test dispatch-local-overrides-global + "Local keymap takes priority over global." + (let ((local-called nil) (global-called nil)) + (setf (gethash :local *keymaps*) + (make-keymap :name :local + :bindings `((:ctrl+p . ,(lambda (e) + (declare (ignore e)) + (setf local-called t)))))) + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) + (declare (ignore e)) + (setf global-called t)))))) + (is-true (dispatch-key-event (make-key-event :key :p :ctrl t))) + (is-true local-called) + (is-false global-called))) + +(test dispatch-multiple-bindings + "dispatch-key-event finds the right binding among many." + (let ((called nil)) + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+a . (lambda (e) (declare (ignore e)))) + (:ctrl+b . (lambda (e) (declare (ignore e)))) + (:ctrl+c . ,(lambda (e) + (declare (ignore e)) + (setf called t))) + (:ctrl+d . (lambda (e) (declare (ignore e))))))) + (is-true (dispatch-key-event (make-key-event :key :c :ctrl t))) + (is-true called))) + (test defkeymap-macro "defkeymap macro registers a keymap." (let ((called nil)) @@ -267,3 +365,45 @@ world"))) (:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t))))) (dispatch-key-event (make-key-event :key :q :ctrl t)) (is-true called))) + +(test defkeymap-macro-with-list-spec + "defkeymap macro works with list-form specs." + (let ((called nil)) + (eval `(defkeymap :global + ((:ctrl+w) ,(lambda (e) (declare (ignore e)) (setf called t))))) + (dispatch-key-event (make-key-event :key :w :ctrl t)) + (is-true called))) + +;; cleanup after keybinding tests +(test keybinding-cleanup-global + "Clean up global keymap after testing." + (remhash :global *keymaps*) + (remhash :local *keymaps*) + (is-false (gethash :global *keymaps*)) + (is-false (gethash :local *keymaps*))) + +;; cleanup after keybinding tests +(test keybinding-cleanup-global + "Clean up global keymap after testing." + (remhash :global *keymaps*) + (remhash :local *keymaps*) + (is-false (gethash :global *keymaps*)) + (is-false (gethash :local *keymaps*))) + +(test resize-event-check + "read-event returns :resize when *terminal-resized-p* is set" + (let ((b (make-instance 'cl-tty.backend:backend))) + (setf cl-tty.input:*terminal-resized-p* t) + (multiple-value-bind (type data) (cl-tty.input:read-event b :timeout 0) + (is (eq :resize type)) + (is (consp data)) + (is (integerp (car data))) + (is (integerp (cdr data)))) + (is-false cl-tty.input:*terminal-resized-p*))) + +(test with-terminal-macro-expands + "with-terminal macro expands and compiles" + (is (macro-function 'cl-tty.backend:with-terminal)) + (let ((expanded (macroexpand-1 '(cl-tty.backend:with-terminal (be) + (print be))))) + (is (listp expanded)))) diff --git a/tests/integration-tests.lisp b/tests/integration-tests.lisp new file mode 100644 index 0000000..63b12d8 --- /dev/null +++ b/tests/integration-tests.lisp @@ -0,0 +1,243 @@ +;;; integration-tests.lisp — Full pipeline integration tests for cl-tty +;;; +;;; Composes all major components through the rendering pipeline onto a +;;; framebuffer backend and verifies cell-level output. +;;; +;;; This file is tangled from org/integration-tests.org — do not edit directly. + +(defpackage :cl-tty-integration-test + (:use :cl :fiveam + :cl-tty.backend :cl-tty.box :cl-tty.layout + :cl-tty.input :cl-tty.select :cl-tty.container + :cl-tty.rendering :cl-tty.dialog)) + +(in-package :cl-tty-integration-test) + +(def-suite integration-suite + :description "Full pipeline integration tests for cl-tty") + +(in-suite integration-suite) + +(defun fb-string (fb x y &optional (len 1)) + "Read a string of LEN characters from framebuffer FB starting at (X,Y)." + (let* ((cells (fb-framebuffer fb)) + (w (framebuffer-width cells)) + (h (framebuffer-height cells))) + (declare (ignore h)) + (with-output-to-string (s) + (loop for i from 0 below len + for cx = (+ x i) + while (< cx w) + do (princ (cell-char (aref cells y cx)) s))))) + +(defun fb-lines (fb &key (start-row 0) (end-row nil)) + "Extract all lines from framebuffer FB as a list of strings." + (let* ((cells (fb-framebuffer fb)) + (w (framebuffer-width cells)) + (h (framebuffer-height cells)) + (max-row (min (or end-row h) h))) + (declare (ignore w)) + (loop for y from start-row below max-row + collect (fb-string fb 0 y (framebuffer-width cells))))) + +(defun fb-contains (fb text) + "Return T if framebuffer FB contains TEXT anywhere." + (let ((all-text (format nil "~{~a~^~%~}" (fb-lines fb)))) + (search text all-text :test #'char-equal))) + +(test box-title-renders-on-fb + "A Box with a title draws border and title text on framebuffer." + (let* ((fb (make-framebuffer-backend :width 40 :height 10)) + (bx (make-box :border-style :single :title "My Box" :width 40 :height 10))) + (compute-layout (box-layout-node bx) 40 10) + (render-box bx fb) + ;; Framebuffer uses ASCII border chars (+, -, |) + (is-true (fb-contains fb "My Box") "title text appears") + (is-true (fb-contains fb "+") "top-left corner appears") + (is-true (fb-contains fb "-") "horizontal border appears") + ;; Check the title at row 0, col 2 + (is (equal "My Box" (fb-string fb 2 1 6)) "title at correct position"))) + +(test text-component-on-fb + "Text component renders word-wrapped content on framebuffer." + (let* ((fb (make-framebuffer-backend :width 20 :height 6)) + (tx (make-text "Hello brave new world of terminal UI" + :wrap-mode :word :width 20 :height 4))) + (compute-layout (text-layout-node tx) 20 4) + (render-text tx fb) + (is-true (fb-contains fb "Hello") "first word appears") + (is-true (fb-contains fb "brave") "second word appears") + (is-true (fb-contains fb "world") "third word wraps"))) + +(test textinput-value-on-fb + "TextInput renders its value and cursor on framebuffer." + (let* ((fb (make-framebuffer-backend :width 40 :height 3)) + (ti (make-text-input :value "hello world" :cursor 11))) + (setf (text-input-layout-node ti) + (make-layout-node :width 40 :height 1)) + (compute-layout (text-input-layout-node ti) 40 1) + (render ti fb) + ;; Verify value via direct cell inspection + (is (equal "hello world" (fb-string fb 0 0 11)) "value appears at row 0") + ;; Check cursor block at position 11 + (let* ((cells (fb-framebuffer fb)) + (cursor-char (cell-char (aref cells 0 11)))) + (is (eql #\█ cursor-char) "cursor block is drawn at position 11")))) + +(test textinput-placeholder-on-fb + "TextInput with empty value shows placeholder text." + (let* ((fb (make-framebuffer-backend :width 40 :height 3)) + (ti (make-text-input :value "" :placeholder "Type here..."))) + (setf (text-input-layout-node ti) + (make-layout-node :width 40 :height 1)) + (compute-layout (text-input-layout-node ti) 40 1) + (render ti fb) + (is (equal "Type here..." (fb-string fb 0 0 12)) "placeholder appears at row 0"))) + +(test scrollbox-children-on-fb + "ScrollBox renders visible children offset by scroll position." + (let* ((fb (make-framebuffer-backend :width 40 :height 10)) + (children nil)) + ;; Create 8 text children, each 1 line tall + (dotimes (i 8) + (let ((tx (make-text (format nil "Line ~D" (1+ i)) + :wrap-mode :none :width 40 :height 1))) + (push tx children))) + (setf children (nreverse children)) + (let ((sb (make-scroll-box :children children :scroll-y 2))) + ;; Set scroll-box layout to 40x8 viewport using component-layout-node + (let ((ln (component-layout-node sb))) + (setf (layout-node-width ln) 40) + (setf (layout-node-height ln) 8)) + ;; Layout each child too + (dolist (c children) + (compute-layout (component-layout-node c) 40 1)) + (render sb fb) + ;; Because scroll-y=2, Line 1 and Line 2 are scrolled out + ;; Line 3 should be first visible + (is-true (fb-contains fb "Line 3") "scroll-y=2 shows Line 3 first") + (is-true (fb-contains fb "Line 4") "Line 4 is visible") + (is-true (fb-contains fb "Line 5") "Line 5 is visible") + ;; Line 1 and 2 should NOT be visible (scrolled out) + (is-false (fb-contains fb "Line 1") "Line 1 scrolled out") + (is-false (fb-contains fb "Line 2") "Line 2 scrolled out")))) + +(test select-options-on-fb + "Select renders option titles on framebuffer." + (let* ((fb (make-framebuffer-backend :width 40 :height 10)) + (sel (make-select + :options '((:title "Red" :value :red) + (:title "Green" :value :green) + (:title "Blue" :value :blue))))) + (let ((ln (select-layout-node sel))) + (setf (layout-node-width ln) 40) + (setf (layout-node-height ln) 5)) + (render sel fb) + (is-true (fb-contains fb "Red") "first option appears") + (is-true (fb-contains fb "Green") "second option appears") + (is-true (fb-contains fb "Blue") "third option appears"))) + +(test dialog-appears-on-fb + "Dialog renders a dimmed backdrop and dialog panel with title." + (let* ((fb (make-framebuffer-backend :width 80 :height 24)) + (d (make-instance 'dialog :title "Confirm" :size :small))) + (push-dialog d) + (render-dialog d fb 80 24) + ;; Dialog title appears somewhere in the output + (is-true (fb-contains fb "Confirm") "dialog title appears") + ;; Dialog border (ASCII) + (is-true (fb-contains fb "+") "dialog border appears") + (is-true (fb-contains fb "|") "dialog vertical border appears") + ;; Clean up + (pop-dialog))) + +(test dialog-push-pop-render + "Dialog push/pop cycle works with rendering." + (let* ((fb (make-framebuffer-backend :width 80 :height 24)) + (d1 (make-instance 'dialog :title "Dialog One")) + (d2 (make-instance 'dialog :title "Dialog Two"))) + (push-dialog d1) + (push-dialog d2) + (render-dialog (first *dialog-stack*) fb 80 24) + (is-true (fb-contains fb "Dialog Two") "top dialog renders") + (pop-dialog) + (backend-clear fb) + (render-dialog (first *dialog-stack*) fb 80 24) + (is-true (fb-contains fb "Dialog One") "second dialog renders after pop") + (pop-dialog))) + +(test toast-appears-on-fb + "Toast notification renders with colored background." + (let* ((fb (make-framebuffer-backend :width 80 :height 24))) + (toast "Hello from toast!" :variant :info :duration 0) + (render-toast (first *toasts*) fb 80) + (is-true (fb-contains fb "Hello from toast!") "toast message appears") + (dismiss-toast (first *toasts*)))) + +(test render-screen-pipeline + "render-screen processes a component tree through the full pipeline." + (let* ((fb (make-framebuffer-backend :width 40 :height 12)) + (root (make-box :border-style :single :title "Root" + :width 40 :height 12))) + (render-screen root fb) + (is-true (fb-contains fb "Root") "title renders via render-screen") + ;; Border characters (ASCII on framebuffer) + (is-true (fb-contains fb "+") "border renders"))) + +(test full-composition-via-fb + "All components compose correctly on a single framebuffer." + (let* ((fb (make-framebuffer-backend :width 60 :height 24))) + ;; + ;; 1. Box with title at top + ;; + (let ((bx (make-box :border-style :single :title "Dashboard" + :width 60 :height 24))) + (compute-layout (box-layout-node bx) 60 24) + (render-box bx fb)) + + ;; + ;; 2. Text content inside + ;; + (let ((tx (make-text "Welcome to the dashboard." + :wrap-mode :word :width 56 :height 3))) + (setf (layout-node-x (text-layout-node tx)) 2) + (setf (layout-node-y (text-layout-node tx)) 2) + (compute-layout (text-layout-node tx) 56 3) + (render-text tx fb)) + + ;; + ;; 3. TextInput + ;; + (let ((ti (make-text-input :value "search query" :cursor 12))) + (setf (text-input-layout-node ti) (make-layout-node)) + (setf (layout-node-x (text-input-layout-node ti)) 2) + (setf (layout-node-y (text-input-layout-node ti)) 6) + (setf (layout-node-width (text-input-layout-node ti)) 56) + (setf (layout-node-height (text-input-layout-node ti)) 1) + (render ti fb)) + + ;; + ;; 4. Select options + ;; + (let ((sel (make-select + :options '((:title "Option A" :value :a) + (:title "Option B" :value :b) + (:title "Option C" :value :c))))) + (setf (select-layout-node sel) (make-layout-node)) + (setf (layout-node-x (select-layout-node sel)) 2) + (setf (layout-node-y (select-layout-node sel)) 8) + (setf (layout-node-width (select-layout-node sel)) 56) + (setf (layout-node-height (select-layout-node sel)) 3) + (render sel fb)) + + ;; + ;; Verifications + ;; + (is-true (fb-contains fb "Dashboard") "box title appears") + (is-true (fb-contains fb "Welcome") "text content appears") + ;; Check TextInput value at its position + (is (equal "search query" (fb-string fb 2 6 12)) "TextInput value at row 6") + ;; Check Select options at their positions + (is-true (fb-contains fb "Option A") "Select option A appears") + (is-true (fb-contains fb "Option B") "Select option B appears") + (is-true (fb-contains fb "Option C") "Select option C appears"))) diff --git a/tests/markdown-tests.lisp b/tests/markdown-tests.lisp index 6c87b0a..21a4505 100644 --- a/tests/markdown-tests.lisp +++ b/tests/markdown-tests.lisp @@ -11,14 +11,93 @@ (in-suite :cl-tty-markdown-test) + +;; ─── Parser edge cases ───────────────────────────────────────── + +(def-test render-markdown-nil ( ) + "render-markdown handles nil gracefully." + (is (string= "" (render-markdown nil)))) + +(def-test render-markdown-empty ( ) + "render-markdown handles empty string." + (let ((result (render-markdown ""))) + (is (stringp result)) + (is (string= "" result)))) + +(def-test parse-blocks-nil ( ) + "parse-blocks handles nil gracefully." + (is-false (parse-blocks nil))) + +(def-test split-string-into-lines-nil ( ) + "parse-blocks handles nil input (tests internal split-string-into-lines)." + (is-false (parse-blocks nil))) + +(def-test nested-bold-inside-italic ( ) + "Nested formatting: bold inside italic." + (let ((children (parse-inline "***hello*** world"))) + (is (= 3 (length children))) + (let ((first-node (first children))) + (is-true (eql :bold (getf first-node :type)))))) + +(def-test nested-italic-inside-bold ( ) + "Nested formatting: italic inside bold." + (let ((children (parse-inline "**bold *italic* bold**"))) + (is (= 1 (length children))) + (let ((bold (first children))) + (is-true (eql :bold (getf bold :type))) + (let ((inner (getf bold :children))) + (is (= 3 (length inner))) + (is-true (eql :italic (getf (second inner) :type))))))) + +(def-test inline-code-inside-bold ( ) + "Code inside bold." + (let ((children (parse-inline "**bold `code` bold**"))) + (is (= 1 (length children))) + (let ((bold (first children))) + (is-true (eql :bold (getf bold :type))) + (let ((inner (getf bold :children))) + (is (= 3 (length inner))) + (is-true (eql :inline-code (getf (second inner) :type))))))) + +(def-test unclosed-code-block ( ) + "Unclosed code block accumulates remaining lines as content." + (let* ((lines '("```lisp" "(defun foo ())" " (bar)")) + (text (format nil "~{~a~%~}" lines)) + (result (parse-blocks text)) + (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is (equal "lisp" (getf (getf node :properties) :language))) + (is-true (search "bar" (getf node :content))))) + +(def-test code-block-no-language ( ) + "Code block with no language is still parsed." + (let* ((lines '("```" "plain" "```")) + (text (format nil "~{~a~%~}" lines)) + (result (parse-blocks text)) + (node (first result))) + (is-true (eql :code-block (getf node :type))) + (is-false (getf (getf node :properties) :language)))) + +(def-test markdown-very-long-line ( ) + "A very long paragraph line does not cause issues." + (let* ((long-line (make-string 500 :initial-element #\x)) + (result (render-markdown long-line))) + (is (stringp result)) + (is-true (> (length result) 0)))) + +(def-test markdown-only-blank ( ) + "Only blank lines produce empty output." + (is (string= "" (render-markdown (format nil "~%~%"))))) + + ;; ─── Parser tests ───────────────────────────────────────────────────────────── -(def-test heading-parsing () +(def-test heading-parsing ( ) (let* ((result (parse-blocks "# Hello World")) (node (first result))) (is-true (eql :heading (getf node :type))) (is (= 1 (getf (getf node :properties) :level))))) -(def-test heading-levels () +(def-test heading-levels ( ) (loop for level from 1 to 6 do (let* ((hashes (make-string level :initial-element #\#)) (text (format nil "~a Heading ~d" hashes level)) @@ -27,7 +106,7 @@ (is-true (eql :heading (getf node :type))) (is (= level (getf (getf node :properties) :level)))))) -(def-test heading-with-inline-formatting () +(def-test heading-with-inline-formatting ( ) (let* ((result (parse-blocks "# Hello **World**")) (node (first result)) (children (getf node :children))) (is-true (eql :heading (getf node :type))) @@ -35,40 +114,42 @@ (is-true (eql :text (getf (first children) :type))) (is-true (eql :bold (getf (second children) :type))))) -(def-test paragraph-parsing () + +(def-test paragraph-parsing ( ) (let* ((result (parse-blocks "This is a paragraph.")) (node (first result))) (is-true (eql :paragraph (getf node :type))))) -(def-test paragraph-multi-line () +(def-test paragraph-multi-line ( ) (let* ((result (parse-blocks "Line one\nLine two")) (node (first result))) (is-true (eql :paragraph (getf node :type))))) -(def-test bold-parsing () + +(def-test bold-parsing ( ) (let* ((children (parse-inline "hello **world** here")) (bold-node (second children))) (is (= 3 (length children))) (is-true (eql :bold (getf bold-node :type))))) -(def-test italic-parsing () +(def-test italic-parsing ( ) (let* ((children (parse-inline "hello *world* here")) (italic-node (second children))) (is (= 3 (length children))) (is-true (eql :italic (getf italic-node :type))))) -(def-test bold-italic-combined () +(def-test bold-italic-combined ( ) (let ((children (parse-inline "**bold** and *italic*"))) (is (= 3 (length children))) (is-true (eql :bold (getf (first children) :type))) (is-true (eql :italic (getf (third children) :type))))) -(def-test inline-code-parsing () +(def-test inline-code-parsing ( ) (let* ((children (parse-inline "use `foo` here")) (code-node (second children))) (is (= 3 (length children))) (is-true (eql :inline-code (getf code-node :type))) (is (equal "foo" (getf code-node :content))))) -(def-test link-parsing () +(def-test link-parsing ( ) (let* ((children (parse-inline "click [here](https://x.com)")) (link-node (second children))) (is (= 2 (length children))) @@ -79,98 +160,105 @@ (is-true (eql :text (getf (first link-text) :type))) (is (equal "here" (getf (first link-text) :content)))))) -(def-test code-block-parsing () - (let* ((text (format nil "```lisp~%(defun hello ())~% (print \"hi\")~%```")) + +(def-test code-block-parsing ( ) + (let* ((lines '("```lisp" "(defun hello ())" " (print \"hi\")" "```")) + (text (format nil "~{~a~%~}" lines)) (result (parse-blocks text)) (node (first result))) (is-true (eql :code-block (getf node :type))) (is (equal "lisp" (getf (getf node :properties) :language))) (is-true (search "(defun hello" (getf node :content))))) -(def-test code-block-unknown-language () - (let* ((text (format nil "```~%plain code~%```")) +(def-test code-block-unknown-language ( ) + (let* ((lines '("```" "plain code" "```")) + (text (format nil "~{~a~%~}" lines)) (result (parse-blocks text)) (node (first result))) (is-true (eql :code-block (getf node :type))) (is-false (getf (getf node :properties) :language)))) -(def-test blockquote-parsing () + +(def-test blockquote-parsing ( ) (let* ((result (parse-blocks "> This is a quote")) (node (first result))) (is-true (eql :blockquote (getf node :type))))) -(def-test list-item-parsing () +(def-test list-item-parsing ( ) (let* ((result (parse-blocks "- First item")) (node (first result))) (is-true (eql :list-item (getf node :type))))) -(def-test ordered-list-parsing () +(def-test ordered-list-parsing ( ) (let* ((result (parse-blocks "1. First item")) (node (first result))) (is-true (eql :ordered-item (getf node :type))))) -(def-test thematic-break-parsing () +(def-test thematic-break-parsing ( ) (let* ((result (parse-blocks "---")) (node (first result))) (is-true (eql :thematic-break (getf node :type))))) + ;; ─── Diff tests ─────────────────────────────────────────────────────────────── -(def-test classify-diff-added () +(def-test classify-diff-added ( ) (is (eql :added (classify-diff-line "+this is added")))) -(def-test classify-diff-removed () +(def-test classify-diff-removed ( ) (is (eql :removed (classify-diff-line "-this is removed")))) -(def-test classify-diff-hunk () +(def-test classify-diff-hunk ( ) (is (eql :hunk-header (classify-diff-line "@@ -1,3 +1,4 @@")))) -(def-test classify-diff-context () +(def-test classify-diff-context ( ) (is (eql :context (classify-diff-line " normal context")))) + ;; ─── Syntax highlighting tests ──────────────────────────────────────────────── -(def-test highlight-lisp-keyword () +(def-test highlight-lisp-keyword ( ) (let ((tokens (highlight-code "(defun hello ()" "lisp"))) (is-true (some (lambda (pair) (and (search "defun" (car pair)) (eql :keyword (cdr pair)))) tokens)))) -(def-test highlight-lisp-builtin () +(def-test highlight-lisp-builtin ( ) "Test that a Lisp builtin like nil is highlighted as :builtin." (let ((tokens (highlight-code "(if t nil)" "lisp"))) (is-true (some (lambda (pair) (and (string= (car pair) "nil") (eql :builtin (cdr pair)))) tokens)))) -(def-test highlight-unknown-language () +(def-test highlight-unknown-language ( ) (let ((tokens (highlight-code "hello world" "unknown-xyz"))) (every (lambda (pair) (eql :plain (cdr pair))) tokens))) -(def-test highlight-comment () +(def-test highlight-comment ( ) (let ((tokens (highlight-code "; this is a comment" "lisp"))) (is-true (some (lambda (pair) (eql :comment (cdr pair))) tokens)))) + ;; ─── Render tests ───────────────────────────────────────────────────────────── -(def-test render-heading-output () +(def-test render-heading-output ( ) (let* ((node (make-md-node :heading :properties (list :level 2) :children (list (make-md-node :text :content "Test")))) (lines (render-md-node node))) (is (= 1 (length lines))) (is-true (> (length (first lines)) 0)))) -(def-test render-paragraph-output () +(def-test render-paragraph-output ( ) (let* ((node (make-md-node :paragraph :children (list (make-md-node :text :content "Hello")))) (lines (render-md-node node))) (is (= 1 (length lines))) (is-true (search "Hello" (first lines))))) -(def-test render-thematic-break-output () +(def-test render-thematic-break-output ( ) (let* ((node (make-md-node :thematic-break)) (lines (render-md-node node))) (is (= 1 (length lines))))) -(def-test render-code-block-output () +(def-test render-code-block-output ( ) (let* ((node (make-md-node :code-block :content "(print \"hello\")" :properties (list :language "lisp"))) (lines (render-md-node node))) (is-true (> (length lines) 0)))) -(def-test render-diff-block-output () +(def-test render-diff-block-output ( ) (let* ((node (make-md-node :diff-block :properties (list :lines '("--- a/file" "+++ b/file" "@@ -1 +1 @@" @@ -180,24 +268,25 @@ (is (search "added" (fourth lines))) (is (search "removed" (fifth lines))))) + ;; ─── Integration tests ──────────────────────────────────────────────────────── -(def-test markdown-integration () - (let* ((md (format nil "# Title~%~%This is **bold** and `code`.~%~%- Item 1~%- Item 2~%~%> A quote~%~%```lisp~%(defun hello ())~% (print \"hi\")~%```~%~%---")) +(def-test markdown-integration ( ) + (let* ((md (format nil "# Title~%~%This is **bold** and `code`.~%~%- Item 1~%~%- Item 2~%~%> A quote~%~%```lisp~%(defun hello ())~% (print \"hi\")~%```~%~%---")) (nodes (parse-blocks md)) (lines (render-md nodes))) (is-true (> (length lines) 5)) (is-true (search "# Title" (first lines))))) -(def-test render-markdown-string () +(def-test render-markdown-string ( ) (let ((result (render-markdown "**bold** text"))) (is-true (stringp result)) (is-true (> (length result) 0)))) -(def-test md-node-text-simple () +(def-test md-node-text-simple ( ) (let ((node (make-md-node :text :content "hello"))) (is (equal "hello" (md-node-text node))))) -(def-test md-node-text-nested () +(def-test md-node-text-nested ( ) (let ((node (make-md-node :paragraph :children (list (make-md-node :text :content "hello") (make-md-node :bold :children diff --git a/tests/mouse-tests.lisp b/tests/mouse-tests.lisp index 336163b..96d4dce 100644 --- a/tests/mouse-tests.lisp +++ b/tests/mouse-tests.lisp @@ -18,8 +18,6 @@ (setf cl-tty.mouse::*selection* (make-selection :text "hello")) (is (equal "hello" (get-selection)))) -;; ── Selection tracking ────────────────────────────────────── - (def-test start-selection-initializes-state () (start-selection 5 10) (is-true (selection-active-p)) diff --git a/tests/scrollbox-tabbar-tests.lisp b/tests/scrollbox-tabbar-tests.lisp index 7e9400e..f8e8b50 100644 --- a/tests/scrollbox-tabbar-tests.lisp +++ b/tests/scrollbox-tabbar-tests.lisp @@ -11,8 +11,6 @@ (fiveam:explain! result) (uiop:quit 0))) -;; ── ScrollBox Tests ───────────────────────────────────────────── - (test scrollbox-creates "A ScrollBox can be created with defaults." (let ((sb (make-scroll-box))) @@ -46,8 +44,6 @@ (render sb backend) (is-true t))) -;; ── TabBar Tests ──────────────────────────────────────────────── - (test tabbar-creates "A TabBar can be created with defaults." (let ((tb (make-tab-bar))) diff --git a/tests/slot-tests.lisp b/tests/slot-tests.lisp index ac972c1..706997e 100644 --- a/tests/slot-tests.lisp +++ b/tests/slot-tests.lisp @@ -24,3 +24,32 @@ (defslot :test-slot :order 1 :render-fn (lambda () "x")) (clear-slot :test-slot) (is-false (slot-p :test-slot))) + +(def-test stack-mode-multiple-entries () + (clear-slot :stack-test) + (defslot :stack-test :order 1 :render-fn (lambda () "first")) + (defslot :stack-test :order 2 :render-fn (lambda () "second")) + (defslot :stack-test :order 3 :render-fn (lambda () "third")) + (is (equal '("first" "second" "third") (slot-render :stack-test)))) + +(def-test replace-mode-last-wins () + (clear-slot :replace-test) + (defslot :replace-test :mode :replace :order 1 :render-fn (lambda () "old")) + (defslot :replace-test :mode :replace :order 2 :render-fn (lambda () "new")) + (is (equal "new" (slot-render :replace-test)))) + +(def-test single-winner-mode-first-wins () + (clear-slot :winner-test) + (defslot :winner-test :mode :single-winner :order 1 + :render-fn (lambda () "alpha")) + (defslot :winner-test :mode :single-winner :order 2 + :render-fn (lambda () "beta")) + (is (equal "alpha" (slot-render :winner-test)))) + +(def-test clear-slot-removes-mode () + (clear-slot :mode-test) + (defslot :mode-test :mode :replace :render-fn (lambda () "only")) + (clear-slot :mode-test) + (defslot :mode-test :mode :stack :render-fn (lambda () "fresh")) + (is-true (slot-p :mode-test)) + (is (equal '("fresh") (slot-render :mode-test))))