76 Commits

Author SHA1 Message Date
94df17a7b9 Add render-select-minibuffer, fix CSI parser nil-code crash
- render-select-minibuffer: new function for bottom-anchored dialog
  panel (minibuffer style), accepts colors plist for theme integration
- handle-text-input: guard code-char against nil key-event-code
  to prevent crash on CSI escape sequences (arrow keys)
2026-05-20 16:27:53 -04:00
ef26220df7 add text-input callback slots (on-cancel, on-tab, on-history), update XDG .asd 2026-05-20 13:36:30 -04:00
4e54737659 add save-theme/load-theme persistence 2026-05-20 12:34:16 -04:00
4e0b825fcc v1.2.0: remove spurious \n from draw-rect
draw-rect wrote \n after each row's fill, including the last row at
the bottom of the frame. This caused a terminal scroll, shifting all
content up by 1 and leaving the last row blank (terminal default bg).
cursor-move-escape at the start of each iteration already repositions
the cursor — the \n was never needed.
2026-05-20 09:57:49 -04:00
e53939844c v1.1.1: fix format No more arguments on CSI key press
parse-csi-params format string had ~C[~{~d~};~d~C — the trailing ~C
had no matching argument (terminator already consumed by ~d). Removed
the spurious ~C. Bug triggered on every arrow key, home, end, etc.
2026-05-20 09:39:56 -04:00
9b8ac8b770 v1.1.0: fix CSI parser destructuring-bind crash on nil params
parse-csi-sequence used destructuring-bind on a single return value,
failing when the CSI sequence had no parameters (e.g. plain arrow keys ESC[A).
Capture multiple return values via multiple-value-list instead of relying
on let* which only captures the primary value.
2026-05-18 20:59:11 -04:00
4c3f5fe65a v1.0.0: extract theme from cl-tty.box to own cl-tty.theme package
The theme system (theme class, define-preset, load-preset, theme-color)
was part of the bloated cl-tty.box package even though it had nothing
to do with boxes, spans, or component rendering. It only used cl-tty.backend
for the *theme-colors* hash table.

Changes:
- added defpackage :cl-tty.theme as the first block in theme.lisp
  (inline defpackage avoids ASDF dependency ordering issues with
   separate package files)
- removed theme exports from cl-tty.box defpackage
- theme tests now run in their own THEME-SUITE (16 tests) instead of
  part of BOX-SUITE
- box suite drops from 64 to 48 tests (16 moved to theme suite)
- updated ASDF, run-all-tests.lisp

All 15 test suites pass at 100%.
2026-05-18 16:50:48 -04:00
ef613927e6 v1.0.0: merge container (scrollbox + tabbar) into cl-tty.box
Eliminates the cl-tty.container package by merging scrollbox and tabbar
components directly into cl-tty.box, where the component system lives.

Changes:
- added scrollbox/tabbar exports to cl-tty.box defpackage in package.org
- changed scrollbox.org in-package from cl-tty.container to cl-tty.box
- changed tabbar.org in-package from cl-tty.container to cl-tty.box
- tabbar's key-event-key references are qualified with cl-tty.input:
  (avoids circular :use dependency with cl-tty.input which :uses cl-tty.box)
- deleted container-package.org
- updated test packages, integration tests, scripts, ASDF
- all 14 test suites pass at 100%
2026-05-18 16:45:50 -04:00
108abd054f v1.0.0: add word-wrap support to text-input.render method
The text-input widget now renders multi-line word-wrapped text using
cl-tty.box:word-wrap instead of single-line truncation. The cursor
position is computed from the wrapped lines using the same algorithm
as position-cursor but now lives in the library where it belongs.

This is the critical step that enables passepartout to replace its
ad-hoc view-input + position-cursor with a simple (render input be) call.

Placeholder text is shown when value is empty, drawn with :dim style.
Block cursor (█) at the correct word-wrapped position. All tests pass
at 100% including integration tests.
2026-05-18 16:30:50 -04:00
d0382f9290 v1.0.0: merge mouse → input — eliminate cl-tty.mouse package
The mouse-event struct was already in cl-tty.input. All mouse handling
logic (mouse-mixin, hit-test, selection, clipboard, link detection)
was in a separate cl-tty.mouse package. Moved everything into the
input package where the struct lives, eliminating one package boundary.

Changes:
- absorb mouse-mixin, handle-mouse-event, hit-test, selection struct,
  selection variables/functions, cell-link-at, open-link-at into
  text-input.org (tangled to input.lisp)
- update cl-tty.input defpackage with mouse exports
- mouse tests merged into INPUT-SUITE (appended to input-tests.lisp)
- delete mouse.org, mouse-package.lisp, mouse.lisp, mouse-tests.lisp
- update ASDF, run-all-tests.lisp, scripts to drop mouse references

All test suites pass at 100% (INPUT-SUITE: 102 tests, +6 from mouse)
2026-05-18 16:18:58 -04:00
9a4d117eee v1.0.0: merge select → dialog — eliminate cl-tty.select package
The select widget (filtered option list) was only used by the dialog
system. Merging removes an entire package boundary, simplifies the
dependency chain, and reduces the library from 12 packages to 11.

Changes:
- absorb select class, accessors, filter, navigation, key handling,
  rendering, fuzzy matching, and all tests into dialog.org
- update cl-tty.dialog package to use cl-tty.box (for dirty-mixin)
  and cl-tty.layout (for layout-node)
- remove select.org, select-package.lisp, select.lisp, select-tests
- update ASDF, run-all-tests.lisp, scripts to drop select references
- update integration tests to use cl-tty.dialog instead of cl-tty.select

All 13 test suites pass at 100%.
2026-05-18 16:12:43 -04:00
ff7eb4d6e1 v1.0.0: export text-input manipulation functions from cl-tty.input 2026-05-18 15:58:53 -04:00
ff5b7a5fea v1.0.0: add char-width tests to box-tests suite 2026-05-18 15:50:35 -04:00
0b076c8def v1.0.0: add char-width and search-highlight to cl-tty library
char-width → cl-tty.box (text.lisp): terminal column width for Unicode
  characters including CJK, emoji, combining marks, and tab.

search-highlight → cl-tty.markdown: wraps query matches in **bold**
  markers for search result emphasis. Pure function, zero dependencies.
2026-05-18 15:48:15 -04:00
af572d5a8c v0.8.0: tangle to XDG (~/.local/share/cl-tty/), remove stale memex .lisp files 2026-05-18 13:04:10 -04:00
e3415cee73 simple backend: ANSI colors, cursor positioning, bold — no longer a no-op
- draw-text: uses cursor-move-escape, sgr-fg/sgr-bg, sgr-attr for
  bold/italic/underline/reverse/dim/blink (was: just dumped string)
- draw-rect: fills with background color (was: complete no-op)
- draw-link: forwards to draw-text with fg/bg (was: ignored them)
- draw-ellipsis: uses positioned draw-text (was: newline+space)
- Added end-sync with finish-output (was: missing, output never flushed)
2026-05-17 15:37:33 -04:00
f76f637548 fix: restore cursor-hide in initialize-backend (no more cursor-style) 2026-05-16 18:22:07 -04:00
e115a88690 fix: cursor-style called before cursor-show to avoid style reset 2026-05-16 17:56:49 -04:00
2785d6913f fix: draw-text/draw-rect use style-only reset (\e[22-27m) instead of full reset (\e[0m)
Preserves foreground and background colors across draw calls.
Without this, every draw-text resets terminal to default grey
background, causing grey-background artifacts in the TUI.
2026-05-16 08:03:00 -04:00
1df078a235 fix: all CSI parser reads need timeout, select-next skips all categorized items
- %read-escape-sequence: increase b1 timeout 0.05→0.1, pass timeout to
  parse-csi-sequence and all read-next calls (OCR branch was using nil
  timeout, blocking forever)
- parse-csi-sequence: accept :timeout keyword, pass to all read-raw-byte
  calls, return :escape on timeout instead of blocking
- %read-digits: accept timeout, check nil from read-raw-byte before (>= b 48)
- %parse-sgr-mouse: accept timeout, return nil if first byte times out
- read-param in parse-csi-sequence: check b for nil before comparing
- parse-csi-params: map Kitty protocol u-terminator cursor codes (1=up,
  2=down, 3=right, 4=left, 5=page-up, 6=page-down) before falling to
  :codepoint. Convert terminator byte to char via code-char for key table
  lookups.
- select-next/select-prev: remove (not (getf opt :category)) check.
  All items have :category in the unified command list, so navigation
  skipped every item and selection stayed at index 0 permanently.
2026-05-15 13:43:42 -04:00
26e55e652f fix: unix-simple-poll returns T not integer, use if poll-result 2026-05-15 13:10:02 -04:00
ce9bf7781a fix: parse-csi-sequence multi-value capture, read-raw-byte timeout, format args
- parse-csi-sequence: use multiple-value-bind to capture both params
  list and terminator byte (let* only takes primary value, discarding
  terminator, causing destructuring-bind to fail on empty list)
- parse-csi-params: convert terminator byte to char via code-char
  for key table lookups and comparisons
- read-raw-byte: check unix-simple-poll result before calling
  unix-read. When poll times out, returns nil immediately instead
  of blocking forever on unix-read
2026-05-15 13:09:09 -04:00
de1864bd94 fix: backend-size returns both cols and rows via multi-value-bind (or discards secondary values)
The OR pattern inside backend-size used (or (multiple-value-bind ...)
...), but multiple-value-bind only returns the primary value of its
body. When the env-var shortcut was removed, both calls to backend-size
(the cols nth-value 0 and rows nth-value 1) returned the same primary
value, making rows always nil.

Restructure with nested multiple-value-bind/values chains so both
return values propagate correctly through all fallback stages.
Also remove MY_TERM_COLS/ROWS env-var pre-check — it returned stale
startup dimensions after terminal resize.
2026-05-15 08:51:13 -04:00
bb579be207 fix: remove per-call finish-output from backend-write (flush once per frame via end-sync)
backend-write flushed output after every single draw-text/draw-rect
call, causing hundreds of individual flushes per frame. This caused
visible flicker on slow terminals.

Remove finish-output from backend-write — all critical flush points
(initialize-backend, shutdown-backend, enable-mouse, enable-bracketed-paste,
end-sync) already call finish-output explicitly.

DECICM sync (begin-sync/end-sync) wraps every frame boundary,
making the frame render atomically with a single flush at end-sync.
2026-05-14 19:36:21 -04:00
916f473107 docs: sync .org with implementation for backend-size, read-raw-byte, SIGWINCH
backend-protocol.org / simple.lisp:
- Replace hard-coded 80x24 prose with full 5-step fallback chain
  (MY_TERM env vars → ioctl fd 0 → ioctl stdout → /dev/tty → 80x24)
- Document return-from pattern (or discards secondary values)

modern-backend.org / modern.lisp:
- Replace simple ioctl-only prose with 4-step fallback chain
- Document env-var pre-check and /dev/tty fallback

text-input.org / input.lisp:
- Update read-raw-byte prose: with-pinned-objects/vector-sap
  instead of alien buffer (code was already correct, prose stale)
- Add missing (require :sb-posix) to SIGWINCH handler code block
- Document :sb-posix requirement in prose
2026-05-14 16:25:45 -04:00
b44b4b6aa0 fix: use return-from for env var fallback (or discards secondary values)
or in Common Lisp only preserves the primary value — secondary
values from the truthy branch are lost. return-from preserves
all values, so both cols and rows are returned correctly.
2026-05-14 15:03:00 -04:00
36fbe81441 fix: use MY_TERM_COLS/LINES instead of COLUMNS/LINES
SBCL unconditionally strips COLUMNS and LINES from the
environment. MY_TERM_COLS/MY_TERM_LINES bypass this filter.
2026-05-14 14:55:37 -04:00
8cb269dfee fix: add COLUMNS/LINES env var fallback in backend-size
When all ioctl methods return rows=0 (SBCL process context), try
/ from the shell environment. These are set by bash
and may survive SBCL's env filtering in some configurations.
2026-05-14 14:53:02 -04:00
11a70956a0 fix: use ioctl on fd 0 (stdin) as primary sizing method
The parent's fd 0 IS the real terminal when running from a shell.
This directly queries the terminal size without subprocess or
alien complexity. Added proper when guard on the unix-ioctl result.
2026-05-14 14:48:54 -04:00
9a54b7ade6 fix: check unix-ioctl return value before reading winsize
unix-ioctl returns NIL on failure, but the code still reads the
uninitialized alien winsize buffer, getting garbage values for
cols and rows (often 0 for rows). Now checks 'ok' before reading.
2026-05-14 14:47:43 -04:00
aa73171c30 fix: use :input :interactive for stty size subprocess
:input :interactive opens /dev/tty for the child's stdin, giving
stty access to the real terminal for its ioctl query.
2026-05-14 14:44:15 -04:00
eedf065e6e fix: use :input :inherit for stty size subprocess
:input :inherit preserves the parent's fd 0 (the terminal) in the
child process, so stty can query it via ioctl. Previous approaches
(:input :interactive, /dev/tty) all failed because uiop's process
setup redirects stdin away from the terminal.
2026-05-14 14:41:45 -04:00
21c7b1c2d9 fix: replace stty size with tput cols/lines in backend-size
stty size returns incomplete data when run through uiop:run-program
(the child may not have terminal access). tput is a terminfo utility
that outputs a single number per call, avoiding parsing issues.
Works reliably in any subprocess context.
2026-05-14 14:40:11 -04:00
733ba7c1b8 fix: remove :input :interactive from stty size subprocess
:input :interactive causes uiop to block on /dev/tty in the parent.
stty size queries terminal via ioctl, not stdin — no input
redirection needed.
2026-05-14 14:30:17 -04:00
ce7af16b13 fix: restore ioctl block in simple.lisp (was lost in edit) 2026-05-14 14:25:23 -04:00
31f864471c fix: use :input :interactive for stty size subprocess
SBCL's stdin during --load is the load file, NOT the terminal.
When uiop:run-program creates a subprocess, it inherits this
stdin, so 'stty size' reads from the load file and fails.
:input :interactive opens /dev/tty for the child's stdin,
matching the behavior of 'stty size' from an interactive shell.
2026-05-14 14:24:55 -04:00
4b1ff3ed0f fix: move stty size to first priority in backend-size
stty size via subprocess is the most reliable method — it
returns the correct 59x83 from the user's terminal. Move it
before ioctl to ensure it's tried first.
2026-05-14 14:22:27 -04:00
fe301dc25b fix: run stty size via 'sh -c' with /dev/tty redirection
uiop:run-program may redirect the child's stdin, preventing stty
from querying the terminal. 'stty size < /dev/tty' explicitly
reads from the controlling terminal regardless of stdin setup.
2026-05-14 14:20:22 -04:00
4df3048a13 fix: add stty size subprocess fallback in both backends
stty size via uiop:run-program is the most reliable method —
it works from the shell on every Unix system and bypasses
alien/ioctl quirks. Placed between stdout ioctl and /dev/tty
ioctl in the fallback chain.
2026-05-14 14:15:30 -04:00
41e2b867be fix: use O_RDONLY (0) for /dev/tty open, guard invalid fd 2026-05-14 14:10:58 -04:00
a227a52c48 fix: use raw O_RDWR=2 constant (sb-unix:o-rdwr doesn't exist) 2026-05-14 13:57:03 -04:00
37f83db35e fix: replace stty/tput fallback with direct ioctl on /dev/tty
uiop:run-program can inherit different terminal state than the
interactive shell. Opening /dev/tty directly and calling ioctl
on that fd is equivalent to what the shell's stty does, and
works regardless of SBCL's fd inheritance quirks.
2026-05-14 13:56:16 -04:00
9b472e281f fix: remove env var fallback for COLUMNS/LINES (SBCL strips them)
SBCL unconditionally strips COLUMNS and LINES from the environment,
so posix-getenv always returns nil for those names. stty size is
the reliable cross-platform fallback for terminal dimensions.
2026-05-14 13:46:13 -04:00
4fa7e98b80 fix: set both dimensions from stty, add tput fallback, export shell vars
- stty size returns 'rows cols'. Old code set only one dimension
  when both env vars were missing; new code sets both.
- Added tput cols/lines as final env-var fallback for systems
  where COLUMNS/LINES are not exported and stty is unavailable.
- Added 'export COLUMNS LINES' to the passepartout script so
  SBCL can read them from the environment.
2026-05-14 13:36:54 -04:00
03ffec75c8 fix: add (require :sb-posix) before SIGWINCH handler
sb-posix is a built-in SBCL contrib, available via require.
Without it, sb-posix:sigwinch causes a reader error and the
eval-when for the SIGWINCH handler never executes, making
*terminal-resized-p* always nil and resize detection broken.
2026-05-14 13:30:38 -04:00
5e9a974981 fix: fill missing env dimension from stty size
When only COLUMNS or only LINES is set, run 'stty size' to get the
other dimension. This handles tmux/screen where only one env var
is exported.
2026-05-14 13:14:22 -04:00
4b9482c09a fix: add env var fallback to backend-size in both backends
ioctl on stdout's fd can return 80x24 even when the terminal is
larger. Add COLUMNS/LINES from the shell as a fallback. Also adds
ioctl-based sizing to simple-backend (was hardcoded 80x24).
2026-05-14 13:12:49 -04:00
83a6e87720 fix: simplify backend-size with direct when guard on values
The try-ioctl function returns (values cols rows) only when both
are valid integers > 0. or propagates complete pairs. This avoids
the nil-in-h crash from partial ioctl results.
2026-05-14 13:11:16 -04:00
db07f8c3a7 fix: guard ioctl results with when to avoid partial values
ignore-errors + ioctl can return (values 80 nil) when the fd exists
but isn't a terminal. or propagates partial values, causing nil in
w or h. Wrap with multiple-value-bind + when to filter.
2026-05-14 13:07:55 -04:00
4a86ae3274 fix: ioctl on stdin fd (0) first, then stdout fd, then env vars
The user's terminal reports 186x60 via stty (which uses stdin fd)
and via COLUMNS/LINES, but ioctl on stdout's fd returns 80x24.
Priority: fd 0 → backend output fd → env vars → 80x24 fallback.
2026-05-14 13:07:05 -04:00
7813e27907 fix: revert to simple ioctl-first with env var fallback
The previous logic (check ioctl result, prefer env when 80x24)
added complexity and crashes. Simple or with env vars after ioctl
is safe: ioctl returns 80x24 on stdout fd mismatch, env vars
(COLUMNS/LINES from shell) provide the correct initial size.
2026-05-14 13:05:53 -04:00
abe4edaffc fix: fallback to stty size when LINES env var is missing
Some environments (tmux) export COLUMNS but not LINES. Use
'stty size' as a fallback for the missing dimension.
2026-05-14 13:04:57 -04:00
1ac6ca02ee fix: handle nil env vars in backend-size
parse-integer errors on nil input. Guard with when before parsing.
2026-05-14 13:03:42 -04:00
0e0151664e fix: prefer env vars over ioctl when ioctl returns 80x24
ioctl on stdout's fd can return the default 80x24 even when the
terminal is much larger (fd mismatch). The new logic:

1. Try ioctl — if it returns >80x24, trust it (correct at runtime).
2. If ioctl returned 80x24 (suspicious default), try COLUMNS/LINES
   from the shell environment instead.
3. If both fail, return whatever ioctl gave us (80x24).

This fixes initial sizing on terminals where ioctl disagrees with
the real TTY size, without breaking runtime SIGWINCH resize
(which always re-queries ioctl, and that is correct after resize).
2026-05-14 13:02:09 -04:00
5c8a253171 fix: add / env var fallback in backend-size
ioctl on stdout's fd can disagree with the real terminal size when
the process is started with stdout redirected or in some terminal
multiplexer configurations. / are set by every POSIX
shell at process start and reflect the actual terminal dimensions.

Priority: ioctl → env vars → 80x24 fallback.
This covers both initial sizing and dynamic SIGWINCH-driven resize.
2026-05-14 12:57:01 -04:00
7cdb556531 fix: remove %query-terminal-size completely
The CSI 18t query leaks into the threaded keyboard reader because
the response arrives on stdin after the reader thread starts. The
response bytes get queued as key events and inserted as text into
the TUI input buffer. Removing the query entirely — ioctl is
sufficient for terminal size detection on all modern terminals.
2026-05-14 11:22:12 -04:00
920545dafb fix: wrap CSI terminal query in with-timeout 0.3s
The blocking read-char in %query-terminal-size could hang if the
terminal doesn't respond to CSI 18 t. Wrapped in
sb-ext:with-timeout 0.3 to abort if no response.
2026-05-14 10:17:59 -04:00
5a3b882f93 fix: add blocking-read-based CSI 18t terminal size query fallback
%query-terminal-size uses blocking read-char on an fd 0 stream
to read the terminal's response to \033[18t. This works even when
unix-simple-poll on fd 0 returns NIL (unlike read-char-no-hang).
Added as fallback in both modern and simple backends.
2026-05-14 10:14:40 -04:00
21d9890374 fix: revert read-raw-byte poll check (unix-read must block)
The earlier fix that checked unix-simple-poll before unix-read
broke input: poll on fd 0 always returns NIL in this SBCL, so
read-raw-byte always returned nil. Reverted to original: call
unix-simple-poll (for timeout) then unix-read unconditionally.
unix-read blocks until data arrives, which is correct for a TUI.
2026-05-14 10:12:24 -04:00
b80bd77d84 fix: remove CSI 18t terminal query (read-char-no-hang on fd 0 never returns)
The %query-terminal-size function sent \033[18t and tried to read
the response via read-char-no-hang on fd 0, which always returns nil
in this SBCL environment. The response leaked into user input,
displaying garbled CSI sequences. Rely on ioctl only.
2026-05-14 09:32:25 -04:00
14b41831c3 fix: disable kitty keyboard, fix CSI parser crashes
- Disabled \033[?u kitty keyboard protocol in modern-backend
  (converts all keys to escape sequences, breaking Ctrl+letter dispatch)
- Fixed parse-csi-sequence: use multiple-value-bind instead of let*
  with destructuring-bind (lost secondary return value from read-param)
- Fixed parse-csi-params format string: pass char-code of terminator
  as distinct argument for ~d, keeping the character for ~C
- Added %query-terminal-size in classes.lisp: ANSI CSI 18t fallback
  for terminal size detection when ioctl fails or returns zero
2026-05-14 09:31:09 -04:00
e8b37f6268 fix: add CSI positioning and ioctl sizing to simple-backend
- backend-size now uses TIOCGWINSZ ioctl (like modern-backend)
- draw-text adds \033[row;colH CSI cursor positioning
- draw-rect fills background with space characters at position
- draw-border uses CSI positioning instead of raw newlines+spaces
- Added cursor-hide/cursor-show, cursor-move, initialize/shutdown
- Detection: broader DA1 check (any ANSI response, not just kitty)
- Detection: added TERM-based fallback for modern terminal detection
2026-05-14 08:55:56 -04:00
1637c3352c fix: read-raw-byte checks poll result before unix-read
The original code called unix-simple-poll then unconditionally
called unix-read, ignoring the poll result. When poll returned
nil (no data), unix-read would block indefinitely. Fixed by
checking poll result: only read if poll says data is ready.
2026-05-14 08:53:16 -04:00
07cea571ef fix: add backend-clear method for raw 2D arrays
Same pattern as the draw-text array fix. Application code may call
backend-clear with a framebuffer array instead of a backend instance.
The array method clears all cells to default blank state.
2026-05-13 16:29:50 -04:00
3bc6df6fd0 fix: read-raw-byte alien type mismatch and timeout ms conversion
- Replace make-alien unsigned-char buffer with make-array + vector-sap
  to avoid SBCL alien type mismatch between signed-char and unsigned-char
- Convert timeout seconds to fixnum milliseconds for unix-simple-poll
  (was passing float 0.1, broke on fixnum-typed sb-unix:to-msec)
- Both fixes make read-raw-byte work on SBCL 2.5.2.debian
2026-05-13 16:15:09 -04:00
22886c1794 fix: add draw-text method for raw 2D arrays
Application code (passepartout TUI) calls draw-text with a framebuffer
(2D array) as the first argument, but draw-text only had methods for
framebuffer-backend CLOS instances. Added a method on array that sets
cells directly on the framebuffer array, matching make-framebuffer's
return type.
2026-05-13 16:06:05 -04:00
66e86734cb literate: add with-terminal, suspend-backend, resume-backend to org source
with-terminal macro was only in tangled .lisp (not .org). suspend-backend
and resume-backend generics + simple-backend methods + tests were also
in hand-edited .lisp only. All three added to org/backend-protocol.org
with proper prose, following the literate programming discipline.

Also added suspend/resume assertions to simple-backend-lifecycle test suite.
2026-05-13 13:14:24 -04:00
c30917056c Merge pull request 'v1.1.0: SGR Mouse Event Parsing' (#9) from feature/v0.11.0-slots into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tty/pulls/9
2026-05-12 18:43:20 -04:00
Hermes Agent
d4aba6ef06 docs: add v1.1.0 SGR mouse parsing to ROADMAP.org 2026-05-12 22:22:06 +00:00
07c29290d4 Merge pull request 'v1.0.0 — Stable release + TUI support' (#8) from feature/v0.11.0-slots into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tty/pulls/8
2026-05-12 16:34:48 -04:00
9e5b1ee8c6 Merge pull request 'v0.15.0: Critical input/rendering fixes, subagent-reviewed' (#7) from feature/v0.11.0-slots into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/7
2026-05-11 22:03:18 -04:00
e887e9bf88 Merge pull request 'v0.6.0: ScrollBox + TabBar' (#6) from feature/v0.6.0-scrollbox-tabbar into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/6
2026-05-11 22:03:02 -04:00
915e4f9d2c Merge pull request 'v0.4.0: Theme engine — semantic colors, presets, dark/light' (#5) from feature/v0.4.0-theme-engine into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/5
2026-05-11 22:02:45 -04:00
5271f5a2ab Merge pull request 'v0.3.0: Rendering pipeline — render dispatch, tree walk, dirty propagation' (#4) from feature/v0.3.0-rendering-engine into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/4
2026-05-11 22:02:33 -04:00
419c8df653 Merge pull request 'v0.2.0: Box and Text renderables + dirty tracking' (#3) from feature/v0.2.0-box-and-text into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/3
2026-05-11 22:02:21 -04:00
76f4477313 Merge pull request 'v0.0.1: Backend Protocol — abstraction layer + simple backend' (#2) from feature/v0.0.1-backend-protocol into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/2
2026-05-11 10:30:53 -04:00
73 changed files with 1674 additions and 7401 deletions

View File

@@ -16,40 +16,33 @@
(:module "src/layout"
:components
((:file "layout")))
(:module "src/rendering"
:components
((:file "framebuffer")))
(:module "src/components"
(:module "src/rendering"
:components
((:file "framebuffer")))
(:module "src/components"
:components
((:file "package")
(:file "dirty")
(:file "box" :depends-on ("package"))
(:file "text" :depends-on ("package" "box"))
(:file "render" :depends-on ("package" "box" "text"))
(:file "theme" :depends-on ("package"))
;; Input system (v0.5.0)
(:file "text" :depends-on ("package" "box"))
(:file "render" :depends-on ("package" "box" "text"))
(:file "theme" :depends-on ("package"))
;; Input system (v0.5.0)
(:file "input-package" :depends-on ("package"))
(:file "input" :depends-on ("input-package" "dirty" "box"))
(:file "text-input" :depends-on ("input-package" "input" "box"))
(:file "textarea" :depends-on ("input-package" "input" "box"))
(:file "keybindings" :depends-on ("input-package" "input"))
;; Container components (v0.6.0)
(:file "container-package" :depends-on ("package" "input-package"))
(:file "scrollbox" :depends-on ("container-package" "dirty" "box"))
(:file "tabbar" :depends-on ("container-package" "dirty" "box"))
;; Select widget (v0.7.0)
(:file "select-package" :depends-on ("package" "input-package"))
(:file "select" :depends-on ("select-package" "dirty" "box"))
;; Markdown + Code + Diff rendering (v0.8.0)
(:file "markdown-package" :depends-on ("package"))
(:file "markdown" :depends-on ("markdown-package"))
;; Dialog + Toast (v0.9.0)
(:file "dialog-package" :depends-on ("package" "select-package" "input-package"))
(:file "dialog" :depends-on ("dialog-package" "dirty" "select" "text-input"))
;; Mouse support (v0.10.0)
(:file "mouse-package" :depends-on ("package" "input-package"))
(:file "mouse" :depends-on ("mouse-package" "dirty" "input"))
;; Slot system (v0.11.0)
;; Container components merged into box (v0.6.0)
(:file "scrollbox" :depends-on ("package" "dirty" "box"))
(:file "tabbar" :depends-on ("package" "dirty" "box"))
;; Markdown + Code + Diff rendering (v0.8.0)
(:file "markdown-package" :depends-on ("package"))
(:file "markdown" :depends-on ("markdown-package"))
;; Dialog + Toast (v0.9.0)
(:file "dialog-package" :depends-on ("package" "input-package"))
(:file "dialog" :depends-on ("dialog-package" "dirty" "text-input"))
;; Slot system (v0.11.0)
(:file "slot-package" :depends-on ("package"))
(:file "slot" :depends-on ("slot-package")))))
:in-order-to ((test-op (test-op :cl-tty/test))))
@@ -71,13 +64,11 @@
(:file "dirty-tests")
(:file "render-tests")
(:file "theme-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")
(:file "dialog-tests" :pathname "../../tests/dialog-tests")
(:file "mouse-tests" :pathname "../../tests/mouse-tests")
(:file "slot-tests" :pathname "../../tests/slot-tests")))
(:file "input-tests" :pathname "../../tests/input-tests")
(:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests")
(:file "markdown-tests" :pathname "../../tests/markdown-tests")
(:file "dialog-tests" :pathname "../../tests/dialog-tests")
(:file "slot-tests" :pathname "../../tests/slot-tests")))
(:module "src/rendering"
:components
((:file "framebuffer-tests" :pathname "../../tests/framebuffer-tests"))))
@@ -87,14 +78,13 @@
(status (find-symbol "RESULTS-STATUS" :fiveam))
(all-passed t))
(dolist (suite '((:cl-tty-backend-test "BACKEND-SUITE")
(:cl-tty-box-test "BOX-SUITE")
(:cl-tty-input-test "INPUT-SUITE")
(:cl-tty-scrollbox-test "SCROLLBOX-SUITE")
(:cl-tty-select-test "SELECT-SUITE")
(:cl-tty-markdown-test)
(:cl-tty-dialog-test "DIALOG-SUITE")
(:cl-tty-mouse-test "MOUSE-SUITE")
(:cl-tty-slot-test "SLOT-SUITE")
(:cl-tty-box-test "BOX-SUITE")
(:cl-tty-input-test "INPUT-SUITE")
(:cl-tty-scrollbox-test "SCROLLBOX-SUITE")
(:cl-tty-markdown-test)
(:cl-tty-dialog-test "DIALOG-SUITE")
(:cl-tty-theme-test "THEME-SUITE")
(: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")))

View File

@@ -201,6 +201,28 @@ Checklist:
- [X] Suspend/resume-backend protocol methods (ARCHITECTURE.org spec)
- [X] Slot modes (defslot :mode parameter)
** v1.1.0: SGR Mouse Event Parsing
DONE. ~read-event~ now decodes SGR extended mouse sequences
(~ESC[<Cb;Cx;CyM/m~) into structured ~mouse-event~ structs, where previously
they fell through as ~:unknown~ key events and printed as control characters.
What was added:
- ~%read-digits~ — reads multi-digit numeric parameters from raw terminal
bytes, handling arbitrary-length values (e.g. coordinates > 99)
- ~%parse-sgr-mouse~ — full SGR mouse decoder: button code → keyword
(~:left~, ~:middle~, ~:right~, ~:scroll-up~, ~:scroll-down~, ~:drag~),
press/release detection, 1-based → 0-based coordinate conversion
- ~parse-csi-sequence~ detects the ~~<~~ marker byte (0x3C) and delegates
to ~%parse-sgr-mouse~ instead of treating the sequence as keyboard input
The mouse enable/disable sequences were already sent by
~initialize-backend~/~shutdown-backend~ (lines 126-128, 139-141 of
~modern.lisp~). The parsing gap was the only missing piece.
Test coverage: 461 unit tests + 32 integration tests, all at 100%.
Org source: ~org/text-input.org~ (tangled to ~src/components/input.lisp~).
** Feature Reference
| Phase | Component | Lines | Release | Status |

View File

@@ -107,7 +107,7 @@ 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~.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(defpackage :cl-tty-backend-test
(:use :cl :fiveam :cl-tty.backend)
(:export #:run-tests))
@@ -124,7 +124,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(defun make-capturing-backend ()
"Create a simple-backend that writes to a string stream."
(let* ((s (make-string-output-stream))
@@ -138,7 +138,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(defun run-tests ()
"Run all backend tests."
(let ((result (run 'backend-suite)))
@@ -153,13 +153,15 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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-false (capable-p b :truecolor) "simple backend has no truecolor")
(is (null (multiple-value-list (suspend-backend b))))
(is (null (multiple-value-list (resume-backend b))))
(shutdown-backend b)))
#+END_SRC
@@ -170,7 +172,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test simple-backend-draw-text
"simple-backend renders text at position, ignoring style"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -188,7 +190,7 @@ Border rendering on the simple backend uses ASCII characters:
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test simple-backend-draw-border
"simple-backend draws ASCII border with +-| characters"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -207,7 +209,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -225,7 +227,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test simple-backend-draw-link
"simple-backend renders link as plain text"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -242,7 +244,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test simple-backend-draw-ellipsis
"simple-backend renders ... for ellipsis"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -260,7 +262,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test capable-p-known-features
"capable-p returns nil for all features on simple-backend"
(let ((b (make-simple-backend)))
@@ -279,7 +281,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test backend-size-returns-integers
"backend-size returns two integer values"
(let ((b (make-simple-backend)))
@@ -300,7 +302,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test default-methods-are-no-ops
"Default backend methods don't error"
(let ((b (make-simple-backend)))
@@ -320,7 +322,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test sync-is-noop-on-simple
"begin-sync and end-sync produce no output on simple-backend"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -340,7 +342,7 @@ colors. Since the simple backend emits no escape sequences,
~draw-rect~ should produce zero output regardless of the fill
color requested.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -357,7 +359,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test detection-returns-backend-instance
"detect-backend returns a valid backend instance"
(let ((be (cl-tty.backend:detect-backend)))
@@ -371,7 +373,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/tests.lisp
(test detection-caches-result
"detect-backend caches the result in *detected-backend*"
(let ((*detected-backend* nil))
@@ -393,7 +395,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/package.lisp
(defpackage :cl-tty.backend
(:use :cl)
(:export
@@ -401,6 +403,7 @@ construction without actually rendering to a terminal.
#: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
@@ -414,8 +417,9 @@ construction without actually rendering to a terminal.
;; Queries
#:capable-p
;; Constructors
#:make-simple-backend
;; Modern backend
#:make-simple-backend
#:with-terminal
;; Modern backend
#:modern-backend #:make-modern-backend
;; Detection
#:detect-backend #:*detected-backend*
@@ -441,7 +445,7 @@ actually support.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(in-package :cl-tty.backend)
(defclass backend () ())
@@ -453,7 +457,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric initialize-backend (backend)
(:method ((b backend)) b))
#+END_SRC
@@ -464,7 +468,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric shutdown-backend (backend)
(:method ((b backend)) (values)))
#+END_SRC
@@ -474,7 +478,7 @@ multiple values; subclasses with terminal state override this.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric backend-size (backend)
(:method ((b backend))
(values 80 24)))
@@ -486,7 +490,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric backend-write (backend string))
#+END_SRC
@@ -496,7 +500,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric backend-clear (backend)
(:method ((b backend))
(backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc))))
@@ -510,7 +514,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric draw-text (backend x y string fg bg &key
bold italic underline reverse dim blink
&allow-other-keys))
@@ -522,7 +526,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric draw-border (backend x y width height
&key style fg bg title title-align))
#+END_SRC
@@ -533,7 +537,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric draw-rect (backend x y width height &key bg))
#+END_SRC
@@ -543,7 +547,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric draw-link (backend x y string url &key fg bg))
#+END_SRC
@@ -553,7 +557,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric draw-ellipsis (backend x y width &key fg bg))
#+END_SRC
@@ -562,7 +566,7 @@ marker according to its own coordinate system.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric cursor-move (backend x y)
(:method ((b backend) x y) (declare (ignore x y)) (values)))
#+END_SRC
@@ -572,7 +576,7 @@ is a no-op — backends that support cursor positioning override this.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric cursor-hide (backend)
(:method ((b backend)) (values)))
#+END_SRC
@@ -582,7 +586,7 @@ backends that lack cursor control still work safely.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric cursor-show (backend)
(:method ((b backend)) (values)))
#+END_SRC
@@ -593,7 +597,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric cursor-style (backend shape &key blink)
(:method ((b backend) shape &key blink) (values)))
#+END_SRC
@@ -603,7 +607,7 @@ don't support cursor styling.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric begin-sync (backend)
(:method ((b backend)) (values)))
#+END_SRC
@@ -613,7 +617,7 @@ buffered by the terminal until ~end-sync~. Default is a no-op.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric end-sync (backend)
(:method ((b backend)) (values)))
#+END_SRC
@@ -624,7 +628,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric read-event (backend &key timeout)
(:method ((b backend) &key timeout) (values nil nil)))
#+END_SRC
@@ -635,7 +639,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric enable-mouse (backend)
(:method ((b backend)) (values)))
#+END_SRC
@@ -645,7 +649,7 @@ support mouse input.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric enable-bracketed-paste (backend)
(:method ((b backend)) (values)))
#+END_SRC
@@ -657,13 +661,85 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(defgeneric capable-p (backend feature)
(:method ((b backend) feature)
(declare (ignore feature))
nil))
#+END_SRC
*** Suspend and Resume
Temporary terminal suspension and re-initialization. Used when the
application receives SIGTSTP (suspend) or SIGCONT (resume) signals.
The default methods are no-ops; backends with terminal state override
these to restore cooked mode on suspend and raw mode on resume.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(in-package :cl-tty.backend)
(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)))
#+END_SRC
*** With Terminal
A convenience macro that initializes a terminal backend, executes body,
and guarantees cleanup on exit via ~unwind-protect~.
The macro detects a suitable backend, initializes it, captures the
terminal dimensions, binds them to the provided variables, executes the
body, and always calls ~shutdown-backend~ when the body exits (whether
normally or by a non-local control transfer).
Arguments:
- ~backend-var~ — bound to the detected backend instance.
- ~cols-var~, ~rows-var~ (optional) — bound to terminal columns and
lines captured after initialization.
- ~&body body~ — executed with the above bindings.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/classes.lisp
(in-package :cl-tty.backend)
(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)))))
#+END_SRC
** Simple Backend
~simple-backend~ inherits from ~backend~ and implements every
@@ -678,7 +754,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(in-package :cl-tty.backend)
(defclass simple-backend (backend)
@@ -694,7 +770,7 @@ Constructor function that creates a ~simple-backend~ instance. Uses
~*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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defun make-simple-backend (&key output-stream)
(make-instance 'simple-backend
:output-stream (or output-stream *standard-output*)))
@@ -706,7 +782,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod initialize-backend ((b simple-backend))
b)
#+END_SRC
@@ -716,35 +792,101 @@ protocol contract.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod shutdown-backend ((b simple-backend))
(values))
#+END_SRC
*** Suspend (simple-backend)
No-op — simple backend has no terminal state to save.
#+begin_src lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod suspend-backend ((b simple-backend))
(values))
#+end_src
*** Resume (simple-backend)
No-op — simple backend has no terminal state to restore.
#+begin_src lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod resume-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.
Queries actual terminal dimensions through a fallback chain, with
a hard-coded 80x24 at the end:
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
1. **ioctl on fd 0 (stdin)** — the parent's real terminal fd.
2. **ioctl on stdout** — fast and correct after SIGWINCH at runtime.
3. **ioctl on ~/dev/tty~** — fallback when stdin/stdout are pipes.
4. **~(values 80 24)~** — last resort.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod backend-size ((b simple-backend))
;; Try ioctl, fall back to 80x24
(values 80 24))
;; Try ioctl on fd 0 (stdin), then stdout, then /dev/tty, then 80x24.
;; Use multiple-value-bind/values to preserve both cols and rows
;; (or discards secondary values).
(multiple-value-bind (cols rows)
(ignore-errors
(let ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(unwind-protect
(let ((ok (sb-unix:unix-ioctl 0 21523
(sb-alien:alien-sap winsize))))
(when ok
(let ((c (sb-alien:deref winsize 1))
(r (sb-alien:deref winsize 0)))
(when (and c r (> c 0) (> r 0))
(values c r)))))
(sb-alien:free-alien winsize))))
(if (and cols rows (> cols 0) (> rows 0))
(values cols rows)
;; ioctl on stdout fd
(multiple-value-bind (cols rows)
(ignore-errors
(let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(unwind-protect
(let ((ok (sb-unix:unix-ioctl
(sb-sys:fd-stream-fd (backend-output-stream b))
21523 (sb-alien:alien-sap winsize))))
(when ok
(values (sb-alien:deref winsize 1)
(sb-alien:deref winsize 0))))
(sb-alien:free-alien winsize))))
(if (and cols rows (> cols 0) (> rows 0))
(values cols rows)
;; Direct ioctl on /dev/tty
(multiple-value-bind (cols rows)
(ignore-errors
(let ((tty-fd (sb-unix:unix-open "/dev/tty" 0 0)))
(when (and tty-fd (numberp tty-fd) (> tty-fd 0))
(unwind-protect
(let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(let ((ok (sb-unix:unix-ioctl tty-fd 21523
(sb-alien:alien-sap winsize))))
(when ok
(values (sb-alien:deref winsize 1)
(sb-alien:deref winsize 0))))
(sb-alien:free-alien winsize))
(sb-unix:unix-close tty-fd)))))
(if (and cols rows (> cols 0) (> rows 0))
(values cols rows)
(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.
Writes a string to the backend's output stream and returns its length.
Does NOT flush — explicit sync points (~initialize-backend~,
~end-sync~, etc.) call ~finish-output~ as needed.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -755,9 +897,10 @@ 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod draw-text ((b simple-backend) x y string fg bg
&key bold italic underline reverse dim blink
&allow-other-keys)
(declare (ignore x y fg bg bold italic underline reverse dim blink))
(backend-write b string))
#+END_SRC
@@ -769,7 +912,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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,
@@ -788,7 +931,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -844,7 +987,7 @@ dashes filling the remaining space.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod draw-rect ((b simple-backend) x y width height
&key bg)
(declare (ignore x y width height bg))
@@ -858,7 +1001,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod draw-link ((b simple-backend) x y string url
&key fg bg)
(declare (ignore url fg bg))
@@ -871,7 +1014,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/simple.lisp
(defmethod draw-ellipsis ((b simple-backend) x y width
&key fg bg)
(declare (ignore width fg bg))

View File

@@ -43,7 +43,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(defpackage :cl-tty-box-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.box)
(:export #:run-tests))
@@ -59,7 +59,7 @@ top-level test runner. ~fiveam~ imports directly for declarative
~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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(defun run-tests ()
(let ((result (run 'box-suite)))
(fiveam:explain! result)
@@ -73,7 +73,7 @@ stdout, and exits cleanly with ~uiop:quit~.
actual terminal I/O. Returns the backend and stream as multiple
values.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(defun make-capturing-backend ()
(let* ((s (make-string-output-stream))
(b (make-modern-backend :output-stream s)))
@@ -85,7 +85,7 @@ values.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test box-creates-with-defaults
"A box created with no arguments has reasonable defaults"
(let ((b (make-box)))
@@ -98,7 +98,7 @@ automatically creates a ~layout-node~ through inheritance.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test box-renders-border
"A box with border draws border characters"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -117,7 +117,7 @@ characters (┌ ┐ └ ┘) in the output stream.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test box-renders-background
"A box with background color fills interior"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -134,7 +134,7 @@ Verify that a box with ~:bg :red~ emits SGR background color codes
Verify that a title string appears in the rendered output stream
when ~:title~ is provided.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -150,7 +150,7 @@ when ~:title~ is provided.
Verify that ~:border-style nil~ suppresses corner characters but
background fill rendering continues to work.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -167,7 +167,7 @@ background fill rendering continues to work.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test box-zero-size
"A box with any zero dimension renders nothing"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -183,7 +183,7 @@ Verify that a box with zero width and height produces no output
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -199,7 +199,7 @@ requires at least 2 columns to draw corner and edge characters.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -215,7 +215,7 @@ still produces corner characters in the output.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test text-creates-with-defaults
"A text created with no arguments has reasonable defaults"
(let ((txt (make-text "")))
@@ -228,7 +228,7 @@ instance and creates a ~layout-node~.
Verify that text content appears in the captured output stream after
rendering.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test text-renders-content
"A text renders its content at position"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -244,7 +244,7 @@ rendering.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test text-empty-string
"Empty text produces no output"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -260,7 +260,7 @@ early-return guard in ~render-text~).
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -277,7 +277,7 @@ within the available width, producing only the first N characters.
Verify that ~:wrap-mode :word~ breaks lines at word boundaries,
distributing words across successive rows.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -295,7 +295,7 @@ distributing words across successive rows.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -312,7 +312,7 @@ hard-broken at character boundaries into ~max-width~-sized chunks.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -326,7 +326,7 @@ correctly, with unset attributes defaulting to ~nil~.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box-tests.lisp
(test make-text-with-spans
"Text with spans stores span objects"
(let* ((sp (list (span "Hello" :bold t)
@@ -335,6 +335,24 @@ objects and they are accessible via ~text-spans~.
(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)))))
(test test-char-width-ascii
"ASCII characters (< 128) have width 1."
(is (= 1 (char-width #\a)))
(is (= 1 (char-width #\Space)))
(is (= 1 (char-width #\@))))
(test test-char-width-tab
"Tab character has width 8."
(is (= 8 (char-width #\Tab))))
(test test-char-width-cjk
"CJK characters have width 2."
(is (= 2 (char-width #\日))))
(test test-char-width-null
"Null character has width 0."
(is (= 0 (char-width #\Nul))))
#+END_SRC
* Implementation
@@ -346,7 +364,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box.lisp
(in-package :cl-tty.box)
(defclass box (dirty-mixin)
@@ -367,7 +385,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box.lisp
(defun make-box (&key (border-style :single) title
(title-align :left) fg bg
width height)
@@ -393,7 +411,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/box.lisp
(defun render-box (box backend)
"Render BOX at its computed layout position using BACKEND."
(let ((ln (box-layout-node box))
@@ -430,7 +448,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp
(in-package :cl-tty.box)
(defclass span ()
@@ -450,7 +468,7 @@ inspect and apply them individually.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp
(defun span (text &key bold italic underline reverse dim fg bg)
(make-instance 'span
:text text :bold bold :italic italic
@@ -465,7 +483,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp
(defclass text (dirty-mixin)
((layout-node :initform (make-layout-node) :accessor text-layout-node
:initarg :layout-node)
@@ -483,7 +501,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp
(defun make-text (content &key fg bg wrap-mode width height spans)
(make-instance 'text
:content content
@@ -502,7 +520,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -535,7 +553,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -572,7 +590,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp
(defun split-string (string)
"Split STRING into words separated by whitespace."
(loop with words = nil
@@ -591,3 +609,33 @@ word list iteratively. Consecutive delimiters are collapsed
(setf start len))))
finally (return (nreverse words))))
#+END_SRC
** char-width utility
~char-width~ returns the terminal column width of a character.
ASCII < 128 = 1. CJK, fullwidth, emoji = 2. Combining marks = 0.
Tab = 8. Used by layout calculations that need to handle
variable-width characters.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text.lisp
(defun char-width (ch)
"Returns the terminal column width of character CH."
(let ((code (char-code ch)))
(cond
((= code 9) 8)
((< code 32) 0)
((<= code 127) 1)
((<= #x4E00 code #x9FFF) 2)
((<= #x3400 code #x4DBF) 2)
((<= #x3040 code #x309F) 2)
((<= #x30A0 code #x30FF) 2)
((<= #xAC00 code #xD7AF) 2)
((<= #xFF01 code #xFF60) 2)
((<= #xFFE0 code #xFFE6) 2)
((<= #x1F300 code #x1F9FF) 2)
((<= #x2600 code #x27BF) 2)
((<= #x0300 code #x036F) 0)
((<= #x20D0 code #x20FF) 0)
((<= #xFE00 code #xFE0F) 0)
(t 1))))
#+END_SRC

View File

@@ -1,127 +0,0 @@
#+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

View File

@@ -80,7 +80,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/detection.lisp
(in-package :cl-tty.backend)
(defvar *detected-backend* nil
@@ -98,7 +98,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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."
@@ -119,7 +119,7 @@ further (I/O-dependent) probes. Must happen before ~detect-backend-by-da1~.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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."
@@ -140,7 +140,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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."
@@ -168,7 +168,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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."
@@ -193,7 +193,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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).

View File

@@ -50,32 +50,46 @@ duration. They stack in the top-right corner.
The ~cl-tty.dialog~ package uses the backend, input, and select
subsystems. All public symbols are exported for user convenience.
#+BEGIN_SRC lisp :tangle ../src/components/dialog-package.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog-package.lisp
;;; dialog-package.lisp — Package definition for cl-tty.dialog
(defpackage :cl-tty.dialog
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select)
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.box :cl-tty.layout)
(:export
;; Dialog
#:dialog
#:dialog-title
#:dialog-content
#:dialog-on-dismiss
#:dialog-size
#:dialog-size-pixels
#:render-dialog
#:push-dialog
#:render-dialog
#:render-select-minibuffer
#:push-dialog
#:pop-dialog
#:*dialog-stack*
#:alert-dialog
#:confirm-dialog
#:select-dialog
#:prompt-dialog
;; Toast
#:toast
#:toast-message
#:toast-variant
#:render-toast
#:dismiss-toast
#:*toasts*))
#:*toasts*
;; Select widget (merged from cl-tty.select)
#: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
* Special variables
@@ -87,7 +101,7 @@ The active dialog stack. ~push-dialog~ conses onto this list;
should bind its own instance so multiple screens can have independent
dialog states.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(in-package :cl-tty.dialog)
(defvar *dialog-stack* nil
@@ -100,7 +114,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defvar *toasts* nil
"List of active toast notifications.")
#+END_SRC
@@ -111,7 +125,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defclass dialog ()
((title :initarg :title :accessor dialog-title)
(size :initarg :size :initform :medium :accessor dialog-size)
@@ -125,7 +139,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
(multiple-value-bind (dw dh)
(case size
@@ -142,7 +156,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun render-dialog (dialog screen w h)
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
(let ((x (floor (- w dw) 2))
@@ -159,11 +173,63 @@ Content is rendered via ~draw-text~ inside the panel area.
:white :default)))))
#+END_SRC
** render-select-minibuffer
Renders a ~select~ widget as a bottom-anchored minibuffer panel at the
given position. The panel fills a rectangular area, draws a separator
line with the title at the top, the filtered options in the middle,
and a filter input line (>= ~...~) at the bottom. ~colors~ is a plist
with keys ~:bg-panel~, ~:separator~, ~:accent~, ~:text-muted~,
~:agent-fg~, ~:input-fg~, ~:bg-input~, ~:input-prompt~.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun render-select-minibuffer (be x y width height select title colors)
(let* ((filtered (select-filtered-options select))
(sel-idx (or (select-selected-index select) 0))
(filter (select-filter select))
(bg-p (getf colors :bg-panel))
(sep-c (getf colors :separator)))
(dotimes (r height)
(draw-rect be x (+ y r) width 1 :bg bg-p))
(draw-text be x y (make-string width :initial-element #\─) sep-c bg-p)
(draw-text be (1+ x) y title (getf colors :accent) bg-p)
(loop for item in filtered
for i from 1
for display-idx = (first item)
for option = (third item)
for opt-title = (getf option :title)
for cat = (getf option :category)
for sel-p = (eql display-idx sel-idx)
for row = (+ y i)
while (< row (+ y (min height (length filtered))))
do (cond
(sel-p
(draw-rect be (1+ x) row (1- width) 1
:bg (getf colors :input-fg))
(draw-text be (1+ x) row
(format nil " >> ~a" opt-title)
(getf colors :bg-input)
(getf colors :input-fg)))
(cat
(draw-text be (1+ x) row
(format nil " ~a" opt-title)
(getf colors :text-muted) bg-p))
(t
(draw-text be (1+ x) row
(format nil " ~a" opt-title)
(getf colors :agent-fg) bg-p))))
(let ((filter-y (+ y (- height 3))))
(draw-rect be x filter-y width 1 :bg bg-p)
(draw-text be x filter-y
(format nil "> ~a" (or filter ""))
(getf colors :input-prompt) bg-p))))
#+END_SRC
** push-dialog
Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun push-dialog (dialog)
(push dialog *dialog-stack*)
dialog)
@@ -174,7 +240,7 @@ Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun pop-dialog ()
(when *dialog-stack*
(let ((dialog (pop *dialog-stack*)))
@@ -194,7 +260,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun alert-dialog (title message)
(make-instance 'dialog
:title title
@@ -210,7 +276,7 @@ both selection and backdrop dismiss.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun confirm-dialog (title message &key on-yes on-no)
(make-instance 'dialog
:title title
@@ -230,7 +296,7 @@ Confirm dialog with Yes/No buttons. Returns ~:yes~ or ~:no~ via the
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun select-dialog (title options &key on-select)
(make-instance 'dialog
:title title
@@ -247,7 +313,7 @@ and calls ~on-select~ with the chosen value after dismissing.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun prompt-dialog (title &key on-submit)
(make-instance 'dialog
:title title
@@ -258,6 +324,196 @@ dialog and calls ~on-submit~ with the entered value after dismissing.
(when on-submit (funcall on-submit value))))))
#+END_SRC
* Select widget (absorbed from cl-tty.select)
A selection list component — the building block for command palettes, theme
pickers, and file pickers. Options are plists with ~:title~, ~:value~, and
optional ~:category~ fields.
** Select class
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(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)))
#+END_SRC
** make-select
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun make-select (&key options filter on-select)
(make-instance 'select
:options (or options nil)
:filter filter
:on-select on-select))
#+END_SRC
** component-layout-node
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defmethod component-layout-node ((sel select))
(select-layout-node sel))
#+END_SRC
** select-filtered-options
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.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)."
(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))))
#+END_SRC
** fuzzy-match-p
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.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)))
(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))))
#+END_SRC
** select-clamp-index
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun select-clamp-index (sel)
"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)))))))
#+END_SRC
** select-next / select-prev
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun select-next (sel)
"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)))))
(defun select-prev (sel)
"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)))))
#+END_SRC
** select-handle-key
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun select-handle-key (sel 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)
((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))))
#+END_SRC
** select-visible-options
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun select-visible-options (sel)
"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))
(half (floor (1- height) 2))
(start (max 0 (- sel-idx half)))
(end (min (length filtered) (+ start height))))
(subseq filtered start end)))
#+END_SRC
** Render method for select
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(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))
(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
(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)))
#+END_SRC
* Toast system
Transient notifications that appear in the top-right corner. Each toast
@@ -268,7 +524,7 @@ has a message and a variant that determines its color (~:info~,
Lightweight class storing the message text and variant keyword.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defclass toast ()
((message :initarg :message :accessor toast-message)
(variant :initarg :variant :initform :info :accessor toast-variant)))
@@ -280,7 +536,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun render-toast (toast screen w)
(let* ((msg (toast-message toast))
(variant (toast-variant toast))
@@ -302,7 +558,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun toast (message &key (variant :info) (duration 0))
(let ((toast (make-instance 'toast :message message :variant variant)))
(push toast *toasts*)
@@ -315,7 +571,7 @@ it onto =*toasts*~, and optionally schedules auto-dismissal via
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dialog.lisp
(defun dismiss-toast (toast)
(setf *toasts* (remove toast *toasts*)))
#+END_SRC
@@ -327,23 +583,29 @@ interaction.
** Test package and suite
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
;;; dialog-tests.lisp — Tests for cl-tty.dialog
(defpackage :cl-tty-dialog-test
(:use :cl :cl-tty.dialog :fiveam))
(:use :cl :cl-tty.dialog :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.input)
(:export #:run-tests))
(in-package :cl-tty-dialog-test)
(def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog")
(def-suite dialog-suite :description "Dialog + Toast + Select tests")
(in-suite dialog-suite)
(defun run-tests ()
(let ((result (run 'dialog-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
** dialog-create
Basic dialog instantiation — verifies ~make-instance~ and accessors.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(def-test dialog-create ()
(let ((d (make-instance 'dialog :title "Test")))
(is-true (typep d 'dialog))
@@ -354,7 +616,7 @@ Basic dialog instantiation — verifies ~make-instance~ and accessors.
~dialog-size-pixels~ returns the correct dimensions for ~:small~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(def-test dialog-size-small ()
(multiple-value-bind (w h) (dialog-size-pixels :small)
(is (= 40 w))
@@ -365,7 +627,7 @@ Basic dialog instantiation — verifies ~make-instance~ and accessors.
~dialog-size-pixels~ returns the correct dimensions for ~:medium~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(def-test dialog-size-medium ()
(multiple-value-bind (w h) (dialog-size-pixels :medium)
(is (= 60 w))
@@ -377,7 +639,7 @@ Basic dialog instantiation — verifies ~make-instance~ and accessors.
Verifies stack operations: push adds to =*dialog-stack*~, pop removes
the top element.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(def-test dialog-push-pop ()
(let ((*dialog-stack* nil))
(push-dialog (make-instance 'dialog :title "D1"))
@@ -392,7 +654,7 @@ the top element.
Verifies that ~toast~ pushes onto =*toasts*~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(def-test toast-create ()
(let ((*toasts* nil))
(toast "Hello" :variant :info :duration 0)
@@ -403,9 +665,159 @@ Verifies that ~toast~ pushes onto =*toasts*~.
Verifies that ~dismiss-toast~ removes the toast from =*toasts*~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(def-test toast-dismiss ()
(let ((*toasts* (list (make-instance 'toast :message "T" :variant :info))))
(dismiss-toast (first *toasts*))
(is (= 0 (length *toasts*)))))
#+END_SRC
** Select tests (merged from cl-tty.select)
*** select-creates
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-creates
"A Select can be created with defaults."
(let ((sel (make-select)))
(is (typep sel 'select))
(is-false (select-options sel))
(is-false (select-filter sel))
(is (= (select-selected-index sel) 0))))
#+END_SRC
*** select-with-options
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-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
*** select-filtered-exact
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-filtered-exact
"Filter returns case-insensitive substring matches."
(let ((sel (make-select
:options '((:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Blue" :value :blue)))))
(setf (select-filter sel) "bl")
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :blue)))))
#+END_SRC
*** select-filtered-all
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-filtered-all
"Nil filter returns all options."
(let ((sel (make-select
:options '((:title "Red" :value :red)
(:title "Blue" :value :blue)))))
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 2)))))
#+END_SRC
*** select-navigation
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-navigation
"Select-next and select-prev navigate through options."
(let ((sel (make-select
:options '((:title "A" :value :a)
(:title "B" :value :b)
(:title "C" :value :c)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1))
(select-next sel)
(is (= (select-selected-index sel) 2))
(select-next sel)
(is (= (select-selected-index sel) 0) "wraps forward")
(select-prev sel)
(is (= (select-selected-index sel) 2) "wraps backward")))
#+END_SRC
*** select-navigation-skips-categories
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-navigation-skips-categories
"Navigation skips category header options."
(let ((sel (make-select
:options '((:title "Colors" :category t)
(:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Shapes" :category t)
(:title "Circle" :value :circle)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1) "skipped category header at 0")
(select-next sel)
(is (= (select-selected-index sel) 2))
(select-next sel)
(is (= (select-selected-index sel) 4) "skipped category header at 3")))
#+END_SRC
*** select-handle-key
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-handle-key
"Select handle-key dispatches navigation and selection."
(let* ((result (list nil))
(sel (make-select
:options '((:title "A" :value :a) (:title "B" :value :b))
:on-select (lambda (opt) (setf (car result) (getf opt :value))))))
(select-handle-key sel (make-key-event :key :down))
(is (= (select-selected-index sel) 1))
(select-handle-key sel (make-key-event :key :up))
(is (= (select-selected-index sel) 0))
(select-handle-key sel (make-key-event :key :enter))
(is (eql (car result) :a))))
#+END_SRC
*** select-handle-key-ctrl
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-handle-key-ctrl
"Ctrl+N and Ctrl+P navigate like down/up."
(let ((sel (make-select
:options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c)))))
(select-handle-key sel (make-key-event :key :n :ctrl t))
(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
*** select-visible-count
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-visible-count
"Visible options respects viewport height."
(let* ((ln (make-layout-node))
(sel (make-select
:options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i)))))
(setf (select-layout-node sel) ln)
(setf (layout-node-height ln) 5)
(let ((visible (select-visible-options sel)))
(is (<= (length visible) 5)))))
#+END_SRC
*** select-fuzzy-fallback
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/dialog-tests.lisp
(test select-fuzzy-fallback
"Fuzzy filter catches near-misses."
(let ((sel (make-select
:options '((:title "Nord" :value :nord)
(:title "Tokyo Night" :value :tokyo)
(:title "Catppuccin" :value :cat)))))
(setf (select-filter sel) "nrd")
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :nord)))))
#+END_SRC

View File

@@ -47,7 +47,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
@@ -65,7 +65,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
@@ -83,7 +83,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
@@ -102,7 +102,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty.lisp
(in-package :cl-tty.box)
;; ── Dirty Tracking ─────────────────────────────────────────────
@@ -116,7 +116,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty.lisp
(defgeneric mark-clean (component)
(:method ((c dirty-mixin))
(setf (dirty-p c) nil)))
@@ -126,7 +126,7 @@ them dirty.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/dirty.lisp
(defgeneric mark-dirty (component)
(:method ((c dirty-mixin))
(setf (dirty-p c) t)))

View File

@@ -188,7 +188,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defpackage :cl-tty.rendering
(:use :cl :cl-tty.backend)
(:export
@@ -206,7 +206,7 @@ and frame-inspection functions. It depends on ~:cl-tty.backend~ for the
Switch to the ~cl-tty.rendering~ package for all subsequent definitions.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(in-package :cl-tty.rendering)
#+END_SRC
@@ -218,7 +218,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defstruct cell
"A single terminal cell — character, colors, and attributes."
(char #\space :type character)
@@ -239,7 +239,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -253,13 +253,13 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defun framebuffer-height (fb)
"Return the height (rows) of framebuffer FB."
(if (arrayp fb) (array-dimension fb 0) 0))
@@ -274,7 +274,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defclass framebuffer-backend (backend)
((framebuffer :initform nil :accessor fb-framebuffer)
(scissor-x :initform 0 :accessor fb-scissor-x)
@@ -289,7 +289,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -306,7 +306,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(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))
@@ -323,7 +323,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -346,7 +346,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -356,9 +356,44 @@ does not need (e.g., reverse, dim, blink).
do (%set-cell fb (+ x i) y (char string i)
:fg fg :bg bg
:bold bold :italic italic :underline underline
:link-url link-url)))
:link-url link-url)))
#+END_SRC
*** draw-text (raw array)
Direct rendering onto a raw 2D framebuffer array (the type returned by
~make-framebuffer~). This lets application code call ~draw-text~ directly on a
framebuffer without wrapping it in a ~framebuffer-backend~.
#+begin_src lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defmethod draw-text ((fb array) x y string fg bg
&key bold italic underline reverse dim blink
&allow-other-keys)
(declare (ignore reverse dim blink))
(let ((h (array-dimension fb 0))
(w (array-dimension fb 1)))
(loop for i from 0 below (length string)
for cx from x
while (< cx w)
when (and (< y h) (>= cx 0) (>= y 0))
do (setf (aref fb y cx)
(make-cell :char (char string i)
:fg fg :bg bg
:bold bold :italic italic :underline underline)))))
#+end_src
*** backend-clear (raw array)
Allow clearing a raw 2D framebuffer array directly (same type as returned by
~make-framebuffer~). Resets all cells to blank defaults.
#+begin_src lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defmethod backend-clear ((fb array))
(dotimes (y (array-dimension fb 0))
(dotimes (x (array-dimension fb 1))
(setf (aref fb y x) (make-cell)))))
#+end_src
*** draw-rect
Fill a rectangular region with space characters and an optional background
@@ -366,7 +401,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg)
(dotimes (row h)
(dotimes (col w)
@@ -380,7 +415,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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 '(#\+ #\- #\|))
@@ -412,7 +447,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/rendering/framebuffer.lisp
(defmethod backend-clear ((fb framebuffer-backend))
(let ((cells (fb-framebuffer fb)))
(dotimes (y (framebuffer-height cells))
@@ -429,7 +464,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -440,7 +475,7 @@ real backend during flush.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -455,7 +490,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -474,7 +509,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -498,7 +533,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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."
@@ -529,7 +564,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -545,7 +580,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -569,7 +604,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -597,7 +632,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(defpackage :cl-tty-framebuffer-test
(:use :cl :fiveam :cl-tty.rendering :cl-tty.backend))
(in-package :cl-tty-framebuffer-test)
@@ -612,7 +647,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(test make-framebuffer-creates-correct-size
(let ((fb (make-framebuffer 80 24)))
(is (= 24 (framebuffer-height fb)))
@@ -624,7 +659,7 @@ dimension (columns).
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(test cell-defaults-are-space
(let ((cell (aref (make-framebuffer 10 10) 0 0)))
(is (eql #\space (cell-char cell)))
@@ -638,7 +673,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(test draw-text-on-fb-sets-cells
(let ((fb (make-framebuffer-backend)))
(draw-text fb 2 3 "abc" :red nil)
@@ -655,7 +690,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -670,7 +705,7 @@ buffer overflow and undefined memory access.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(test diff-identical-fbs-returns-empty
(let ((fb1 (make-framebuffer 80 24))
(fb2 (make-framebuffer 80 24)))
@@ -682,7 +717,7 @@ engine must short-circuit when no cells differ.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(test diff-changed-fb-returns-changes
(let* ((fb1 (make-framebuffer 10 10))
(fb2 (make-framebuffer 10 10)))
@@ -700,7 +735,7 @@ exactly one change with the correct coordinates and cell data.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -718,7 +753,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -740,7 +775,7 @@ region are ignored.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -754,7 +789,7 @@ one cell change should be detected and forwarded to the output backend.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))))
@@ -766,7 +801,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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")
@@ -780,7 +815,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))))
@@ -792,7 +827,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(test extract-text-single-row
(let ((fb (make-framebuffer-backend)))
(draw-text fb 0 0 "hello" nil nil)
@@ -806,7 +841,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/framebuffer-tests.lisp
(test extract-text-multi-row
(let ((fb (make-framebuffer-backend)))
(draw-text fb 0 0 "abc" nil nil)

View File

@@ -39,7 +39,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp
;;; integration-tests.lisp — Full pipeline integration tests for cl-tty
;;;
;;; Composes all major components through the rendering pipeline onto a
@@ -50,7 +50,7 @@ package, so the symbol must be interned and accessible.
(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.input
:cl-tty.rendering :cl-tty.dialog))
(in-package :cl-tty-integration-test)
@@ -75,7 +75,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -95,7 +95,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -116,7 +116,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))))
@@ -135,7 +135,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -160,7 +160,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -186,7 +186,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -213,7 +213,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -236,7 +236,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -276,7 +276,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp
(test select-options-on-fb
"Select renders option titles on framebuffer."
(let* ((fb (make-framebuffer-backend :width 40 :height 10))
@@ -304,7 +304,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -331,7 +331,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -359,7 +359,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/integration-tests.lisp
(test toast-appears-on-fb
"Toast notification renders with colored background."
(let* ((fb (make-framebuffer-backend :width 80 :height 24)))
@@ -380,7 +380,7 @@ This test creates a simple tree with a single Box, calls
appear. This validates that the pipeline dispatches correctly from root
through the component hierarchy.
#+BEGIN_SRC lisp :tangle ../tests/integration-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -410,7 +410,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))

View File

@@ -47,7 +47,7 @@ unnecessary — ~200 lines of CL math suffices.
The test package uses ~:fiveam~ for the test framework and imports
all exported symbols from ~cl-tty.layout~.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(defpackage :cl-tty-layout-test
(:use :cl :fiveam :cl-tty.layout)
(:export #:run-tests))
@@ -59,7 +59,7 @@ all exported symbols from ~cl-tty.layout~.
~fiveam~ suites collect related tests under a descriptive name for
batch execution.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(def-suite layout-suite :description "Layout engine tests")
(in-suite layout-suite)
#+END_SRC
@@ -69,7 +69,7 @@ batch execution.
~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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(defun run-tests ()
(let ((result (run 'layout-suite)))
(fiveam:explain! result)
@@ -81,7 +81,7 @@ exits cleanly for CI or batch runs.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test make-layout-node-defaults
(let ((n (make-layout-node)))
(is (typep n 'layout-node))
@@ -93,7 +93,7 @@ direction ~:column~ and is of type ~layout-node~.
Verify that passing ~:direction :row~ produces a node whose direction
slot reflects that choice.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test make-layout-node-row
(let ((n (make-layout-node :direction :row)))
(is (eql (layout-node-direction n) :row))))
@@ -104,7 +104,7 @@ slot reflects that choice.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test add-child-sets-parent
(let ((parent (make-layout-node)) (child (make-layout-node)))
(layout-node-add-child parent child)
@@ -117,7 +117,7 @@ the parent's ~children~ list must contain the child.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test remove-child-clears-parent
(let ((parent (make-layout-node)) (child (make-layout-node)))
(layout-node-add-child parent child)
@@ -131,7 +131,7 @@ from the parent's ~children~ list.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test column-two-children-vertical
(let* ((root (make-layout-node :direction :column))
(c1 (make-layout-node :height 3))
@@ -147,7 +147,7 @@ starts at y=0; the second starts below the first.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test row-two-children-horizontal
(let* ((root (make-layout-node :direction :row))
(c1 (make-layout-node :width 10))
@@ -164,7 +164,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test flex-grow-distributes-space
(let* ((root (make-layout-node :direction :row :width 20))
(c1 (make-layout-node :width 4 :grow 1))
@@ -179,7 +179,7 @@ twice as much extra space as a child with grow=1.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test flex-grow-single-child
(let* ((root (make-layout-node :direction :row :width 20))
(c (make-layout-node :width 5 :grow 1)))
@@ -193,7 +193,7 @@ available space in the container.
When children exceed the container size, each child shrinks in
proportion to its ~shrink~ value.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test flex-shrink-reduces-overflow
(let* ((root (make-layout-node :direction :row :width 10))
(c1 (make-layout-node :width 8 :shrink 1))
@@ -208,7 +208,7 @@ proportion to its ~shrink~ value.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test padding-reduces-content-area
(let* ((root (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1)))
(c (make-layout-node :height 3)))
@@ -223,7 +223,7 @@ padding values and sized to the remaining space.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test gap-between-children
(let* ((root (make-layout-node :direction :column :gap 2))
(c1 (make-layout-node :height 3))
@@ -239,7 +239,7 @@ 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 :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -252,7 +252,7 @@ the sum of the first child's height plus gap.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -266,7 +266,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -279,7 +279,7 @@ spacer absorbs all remaining width.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -297,7 +297,7 @@ solver. Sidebar gets fixed width; main content stretches.
Layout must gracefully handle containers with no children, returning
valid integer dimensions.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test empty-container-does-not-crash
(let ((r (make-layout-node)))
(compute-layout r 20 20)
@@ -310,7 +310,7 @@ valid integer dimensions.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -325,7 +325,7 @@ its requested height. Width is inherited from the 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test zero-size-container
(let* ((r (make-layout-node :direction :column))
(c (make-layout-node :height 5)))
@@ -340,7 +340,7 @@ integer coordinates without crashing or producing NaN/infinite values.
Three levels of nested vboxes ensure that layout is computed
correctly for deeply nested subtrees.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/tests.lisp
(test deep-nesting-three-levels
(let* ((out (vbox ()
(vbox (:grow 1)
@@ -356,7 +356,7 @@ correctly for deeply nested subtrees.
Substantial padding on all sides should offset children inward by the
full padding amount.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -372,7 +372,7 @@ full padding amount.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -390,7 +390,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defpackage :cl-tty.layout
(:use :cl)
(:export
@@ -417,7 +417,7 @@ exported for testing.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defun normalize-box (spec)
(cond ((null spec) (list :top 0 :right 0 :bottom 0 :left 0))
((numberp spec) (list :top spec :right spec :bottom spec :left spec))
@@ -432,7 +432,7 @@ plist. This normalisation layer means users can pass ~:padding 2~ or
~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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defun box-edge (box edge)
(or (getf box edge) 0))
#+END_SRC
@@ -446,7 +446,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defclass layout-node ()
((parent :initform nil :accessor layout-node-parent)
(children :initform nil :accessor layout-node-children)
@@ -472,7 +472,7 @@ and input constraints (~direction~, ~grow~, ~shrink~, ~padding~,
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -493,7 +493,7 @@ defaults for missing values, and delegates to ~make-instance~.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defun layout-node-add-child (parent child)
(setf (layout-node-parent child) parent)
(setf (layout-node-children parent)
@@ -507,7 +507,7 @@ list. Returns the child for convenience in chaining or ~let~ forms.
back-pointer and removing it from the parent's children list.
Returns the child.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defun layout-node-remove-child (parent child)
(setf (layout-node-parent child) nil)
(setf (layout-node-children parent)
@@ -524,7 +524,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defun distribute-sizes (children avail gap horizontal)
(let* ((n (length children))
(gap-total (* gap (max 0 (1- n))))
@@ -563,7 +563,7 @@ within given dimensions. It positions each child at the correct
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defun compute-layout (root available-width available-height)
(labels ((place-children (node x y max-w max-h)
(let* ((children (layout-node-children node))
@@ -628,7 +628,7 @@ adjusting for padding and direction at each level.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -648,7 +648,7 @@ properties and adds all children via ~layout-node-add-child~. The
~hbox~ creates a row-direction container, structurally identical to
~vbox~ except the ~:direction~ is ~:row~.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -668,7 +668,7 @@ properties and adds all children via ~layout-node-add-child~. The
~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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/layout/layout.lisp
(defmacro spacer (&key grow)
`(make-layout-node :grow ,(or grow 1)))
#+END_SRC

View File

@@ -11,13 +11,14 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
** Package
#+BEGIN_SRC lisp :tangle ../src/components/markdown-package.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
#:search-highlight
#:classify-diff-line #:render-md #:render-md-node
#:render-markdown #:render-inline
#:apply-style #:apply-styles))
@@ -30,7 +31,7 @@ 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.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty
(in-package :cl-tty.markdown)
@@ -51,7 +52,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -67,7 +68,7 @@ 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 ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun md-node-p (thing)
(and (listp thing) (getf thing :type)))
#+END_SRC
@@ -80,7 +81,7 @@ node tree. The ~:link~ type formats as ~text (url)~; ~:text~ and
concatenate their children's text. This is useful for summarisation
and testing.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun md-node-text (node)
(let ((type (getf node :type)))
(cond ((eql type :text) (or (getf node :content) ""))
@@ -107,7 +108,7 @@ 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.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -130,7 +131,7 @@ 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.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun classify-line (line)
(cond
((string= line "") (cons :blank nil))
@@ -188,7 +189,7 @@ 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~.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -206,7 +207,7 @@ 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 ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun parse-paragraph (lines start)
(let ((text-parts nil) (i start))
(loop while (< i (length lines))
@@ -233,7 +234,7 @@ 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 ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun parse-blockquote (lines start)
(let ((text-parts nil) (i start))
(loop while (< i (length lines))
@@ -262,7 +263,7 @@ 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.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun parse-list (lines start)
(let ((items nil) (i start))
(loop while (< i (length lines))
@@ -297,7 +298,7 @@ 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.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun parse-code-block (lines start lang)
(let ((code-lines nil)
(i (1+ start))
@@ -333,7 +334,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun parse-diff-block (lines start)
(let ((diff-lines nil) (i start))
(loop while (< i (length lines))
@@ -363,7 +364,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -416,7 +417,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -462,7 +463,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)) #\*))
@@ -486,7 +487,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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")))
@@ -512,7 +513,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -534,7 +535,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -568,7 +569,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun get-highlighter (lang)
(cdr (assoc lang
'(("lisp" . (:comment (";" "#|" ";;") :string ("\"")
@@ -665,7 +666,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun tokenize-line (line highlighter)
(let ((tokens nil) (i 0) (len (length line))
(comment-chars (getf highlighter :comment))
@@ -742,7 +743,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))))
@@ -763,7 +764,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun apply-highlight-token (token category)
(let ((code (case category
(:keyword "33") (:builtin "36")
@@ -778,7 +779,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun apply-highlight-style (char-vector)
(coerce char-vector 'string))
#+END_SRC
@@ -793,7 +794,7 @@ colourised output.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun string-prefix-p (prefix string)
(and (>= (length string) (length prefix))
(string= prefix (subseq string 0 (length prefix)))))
@@ -806,7 +807,7 @@ Classifies a single diff line into a semantic category: ~:file-header~
(for ~+~ lines), ~:removed~ (for ~-~ lines), or ~:context~ (for
everything else). This powers colourised diff rendering.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun classify-diff-line (line)
(cond ((string-prefix-p "+++ " line) :file-header)
((string-prefix-p "--- " line) :file-header)
@@ -830,7 +831,7 @@ string. Supports both keyword (e.g. ~:bold~) and string (e.g.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun apply-style (style text)
(let ((code (cond
((eql style :bold) "1") ((eql style :italic) "3")
@@ -870,7 +871,7 @@ Renders a list of inline child nodes into a single string. Handles
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-inline (children)
(if (null children) ""
(with-output-to-string (s)
@@ -897,7 +898,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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 #\#))
@@ -912,7 +913,7 @@ deeper levels use bright-white.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-paragraph (node)
(list (render-inline (getf node :children))))
#+END_SRC
@@ -922,7 +923,7 @@ result is a single-element list containing the rendered text.
Renders a blockquote node with a dimmed ~> ~ prefix before the
inline-rendered content.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-blockquote (node)
(list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children))))))
#+END_SRC
@@ -934,7 +935,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-code-block (node)
(let* ((language (or (getf (getf node :properties) :language) ""))
(content (or (getf node :content) ""))
@@ -971,7 +972,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-diff-block (node)
(let* ((lines (getf (getf node :properties) :lines)) (result nil))
(dolist (line (or lines
@@ -993,7 +994,7 @@ unstyled.
Renders a thematic break as a dimmed horizontal rule using
Unicode box-drawing characters.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-thematic-break (node)
(declare (ignore node))
(list (apply-style :dim "──────────────────────────────────────────────")))
@@ -1004,7 +1005,7 @@ Unicode box-drawing characters.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-list-item (node)
(list (concatenate 'string
(if (eql (getf node :type) :ordered-item) " 1." " * ")
@@ -1017,7 +1018,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-md-node (node)
(let ((type (getf node :type)))
(case type
@@ -1038,7 +1039,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-md (nodes)
(let ((lines nil))
(dolist (node nodes) (setf lines (nconc lines (render-md-node node))))
@@ -1051,7 +1052,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun render-markdown (text)
(unless text (return-from render-markdown ""))
(let ((nodes (parse-blocks text)) (parts nil))
@@ -1062,6 +1063,30 @@ Returns an empty string for ~nil~ input.
do (unless first (terpri s)) (princ part s)))))
#+END_SRC
*** search-highlight
~search-highlight~ wraps occurrences of a query string in a text with
**bold** markers for emphasis display. Case-insensitive matching.
Returns the original text if query is nil or empty.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/markdown.lisp
(defun search-highlight (content query)
"Wrap occurrences of QUERY in CONTENT with **bold** markers."
(let ((lower-content (string-downcase content))
(lower-query (string-downcase query))
(result "") (pos 0))
(when (and query (> (length query) 0))
(loop
(let ((found (search lower-query lower-content :start2 pos)))
(unless found (return))
(setf result (concatenate 'string result
(subseq content pos found)
"**" (subseq content found (+ found (length query))) "**"))
(setf pos (+ found (length query)))))
(setf result (concatenate 'string result (subseq content pos)))
(if (string= result "") content result))))
#+END_SRC
* Tests
The test suite covers parser edge cases, heading/paragraph parsing, inline
@@ -1077,7 +1102,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
;;; markdown-tests.lisp — Tests for cl-tty.markdown
(defpackage :cl-tty-markdown-test
@@ -1098,7 +1123,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
;; ─── Parser edge cases ─────────────────────────────────────────
@@ -1183,7 +1208,7 @@ defensive gate checks at the top of each parsing function.
ATX headings from level 1 through 6, including headings with inline
formatting inside the heading text.
#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
;; ─── Parser tests ─────────────────────────────────────────────────────────────
@@ -1215,7 +1240,7 @@ formatting inside the heading text.
Single-line and multi-line paragraphs. Multi-line paragraphs are joined
with spaces before inline parsing.
#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
(def-test paragraph-parsing ( )
(let* ((result (parse-blocks "This is a paragraph.")) (node (first result)))
@@ -1231,7 +1256,7 @@ with spaces before inline parsing.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
(def-test bold-parsing ( )
(let* ((children (parse-inline "hello **world** here"))
@@ -1275,7 +1300,7 @@ test verifies both structure (node types) and content (text/url values).
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
(def-test code-block-parsing ( )
(let* ((lines '("```lisp" "(defun hello ())" " (print \"hi\")" "```"))
@@ -1299,7 +1324,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
(def-test blockquote-parsing ( )
(let* ((result (parse-blocks "> This is a quote")) (node (first result)))
@@ -1323,7 +1348,7 @@ the expected node types.
Tests ~classify-diff-line~ with each diff line variant: added (+),
removed (-), hunk header (@@), and context (neither).
#+BEGIN_SRC lisp :tangle ../tests/markdown-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
;; ─── Diff tests ───────────────────────────────────────────────────────────────
@@ -1346,7 +1371,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
;; ─── Syntax highlighting tests ────────────────────────────────────────────────
(def-test highlight-lisp-keyword ( )
@@ -1377,7 +1402,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
;; ─── Render tests ─────────────────────────────────────────────────────────────
@@ -1422,7 +1447,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/markdown-tests.lisp
;; ─── Integration tests ────────────────────────────────────────────────────────

View File

@@ -53,7 +53,7 @@ covers one logical behavior.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(defpackage :cl-tty-modern-backend-test
(:use :cl :fiveam :cl-tty.backend)
(:export #:run-tests))
@@ -64,7 +64,7 @@ white-box testing of escape generation.
A single suite groups all modern backend tests.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(def-suite modern-backend-suite :description "Modern backend tests")
(in-suite modern-backend-suite)
#+END_SRC
@@ -73,7 +73,7 @@ A single suite groups all modern backend tests.
The =run-tests= entry point is called by the CI test harness.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(defun run-tests ()
(let ((result (run 'modern-backend-suite)))
(fiveam:explain! result)
@@ -85,7 +85,7 @@ The =run-tests= entry point is called by the CI test harness.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test make-modern-backend-creates
"make-modern-backend returns a modern-backend instance"
(let ((b (make-modern-backend)))
@@ -97,7 +97,7 @@ class. This is the most basic smoke test for the backend factory.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test sgr-truecolor-foreground
"SGR truecolor foreground escape is correct"
(is (equal (cl-tty.backend::sgr-fg "#FFD700")
@@ -108,7 +108,7 @@ escape sequence with red, green, and blue components in the right order.
Same as foreground but uses the =48= background prefix instead of =38=.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test sgr-truecolor-background
"SGR truecolor background escape is correct"
(is (equal (cl-tty.backend::sgr-bg "#1a1b26")
@@ -120,7 +120,7 @@ Same as foreground but uses the =48= background prefix instead of =38=.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -134,7 +134,7 @@ standard 8-color SGR codes (=31= foreground, =44= background).
Each attribute keyword (=:bold=, =:italic=, =:underline=, =:reset=)
should map to the correct SGR number.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -148,7 +148,7 @@ should map to the correct SGR number.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test cursor-move-escape
"cursor-move generates correct CSI escape"
(let ((b (make-modern-backend)))
@@ -160,7 +160,7 @@ Verifies that =cursor-move-escape= produces a CSI =H= sequence with
Verifies the DECSTR escape for a block cursor without blinking (code 2).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test cursor-style-block
"cursor-style :block generate correct escape"
(let ((b (make-modern-backend)))
@@ -172,7 +172,7 @@ Verifies the DECSTR escape for a block cursor without blinking (code 2).
Verifies the DECSTR escape for a bar cursor without blinking (code 6).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test cursor-style-bar
"cursor-style :bar generate correct escape"
(let ((b (make-modern-backend)))
@@ -185,7 +185,7 @@ Verifies the DECSTR escape for a bar cursor without blinking (code 6).
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test cursor-style-underline-blink
"cursor-style :underline with blink"
(let ((b (make-modern-backend)))
@@ -198,7 +198,7 @@ blinking), which is base 4 + blink offset 1.
Confirms that =decicm-begin= and =decicm-end= produce =?2026h= and
=?2026l= respectively.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern-tests.lisp
(test decicm-escapes
"DECICM synchronized update escapes"
(is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc)))
@@ -211,7 +211,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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")
@@ -223,7 +223,7 @@ and ~\\ for literal backslash.
Verifies that ="#FFD700"= parses to (255, 215, 0).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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")
@@ -236,7 +236,7 @@ Verifies that ="#FFD700"= parses to (255, 215, 0).
Verifies all-zero parsing.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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")
@@ -249,7 +249,7 @@ Verifies all-zero parsing.
Verifies that ="#F00"= expands to ="#FF0000"= = (255, 0, 0).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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")
@@ -263,7 +263,7 @@ Verifies that ="#F00"= expands to ="#FF0000"= = (255, 0, 0).
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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) "╭"))
@@ -276,7 +276,7 @@ characters for the four corners and edges.
Confirms that =:double= style maps to double-line box-drawing characters.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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) "╔"))
@@ -289,7 +289,7 @@ Confirms that =:double= style maps to double-line box-drawing characters.
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).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -307,7 +307,7 @@ on a backend not attached to a real terminal (no errors, return nil).
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(in-package :cl-tty.backend)
(defun hex-to-rgb (hex)
@@ -331,7 +331,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defparameter *named-colors*
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
@@ -344,7 +344,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -357,7 +357,7 @@ as a fallback when a keyword is not in *named-colors*.")
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun sgr-fg (color)
"Return SGR foreground escape for COLOR."
(if (null color) ""
@@ -381,7 +381,7 @@ unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=.
~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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun sgr-bg (color)
"Return SGR background escape for COLOR."
(if (null color) ""
@@ -405,7 +405,7 @@ unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defparameter *sgr-attr-codes*
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
(:blink . 5) (:reverse . 7) (:reset . 0)))
@@ -416,7 +416,7 @@ italic, underline, blink, reverse video, and reset.
~sgr-attr~ looks up the keyword in =*sgr-attr-codes*= and produces the
matching SGR escape.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun sgr-attr (attr)
"Return SGR attribute escape for ATTR keyword."
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
@@ -432,7 +432,7 @@ matching SGR 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -444,7 +444,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape."
(let* ((base (case shape
@@ -462,7 +462,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun decicm-begin ()
"Return escape to enable synchronized updates."
(format nil "~C[?2026h" #\Esc))
@@ -473,7 +473,7 @@ atomically.
Disables DEC private mode 2026, flushing the buffered frame to the
display.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun decicm-end ()
"Return escape to disable synchronized updates."
(format nil "~C[?2026l" #\Esc))
@@ -485,7 +485,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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\\"
@@ -500,7 +500,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defparameter *border-chars*
'(((:single :top-left) . "┌") ((:single :top-right) . "┐")
((:single :bottom-left) . "└") ((:single :bottom-right) . "┘")
@@ -520,7 +520,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun border-char (style pos)
"Return the Unicode box-drawing character for STYLE at POS."
(let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
@@ -537,7 +537,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defclass modern-backend (backend)
((output-stream :initform *standard-output*
:initarg :output-stream
@@ -552,7 +552,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defun make-modern-backend (&key color-palette output-stream)
(declare (ignore color-palette))
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
@@ -567,7 +567,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod initialize-backend ((b modern-backend))
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen
(backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic
@@ -586,7 +586,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod shutdown-backend ((b modern-backend))
(cursor-show b)
(backend-write b (format nil "~C[?u" #\Esc))
@@ -611,7 +611,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod suspend-backend ((b modern-backend))
(cursor-show b)
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
@@ -629,7 +629,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -646,37 +646,59 @@ is responsible for redrawing the full screen after resume.
*** 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).
Uses ioctl (TIOCGWINSZ = 21523) to query actual terminal dimensions
from the kernel, with a ~/dev/tty~ fallback and 80x24 last resort.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod backend-size ((b modern-backend))
(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))))
;; Try ioctl on stdout, fall back to /dev/tty, then 80x24.
;; Each arm uses multiple-value-bind/values to preserve both cols and rows
;; (or discards secondary values, so we avoid it for multi-value returns).
(multiple-value-bind (cols rows)
(ignore-errors
(let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(unwind-protect
(let ((ok (sb-unix:unix-ioctl
(sb-sys:fd-stream-fd (backend-output-stream b))
21523 (sb-alien:alien-sap winsize))))
(when ok
(values (sb-alien:deref winsize 1) ;; cols
(sb-alien:deref winsize 0)))) ;; rows
(sb-alien:free-alien winsize))))
(if (and cols rows (> cols 0) (> rows 0))
(values cols rows)
;; Direct ioctl on /dev/tty.
(multiple-value-bind (cols rows)
(ignore-errors
(let ((tty-fd (sb-unix:unix-open "/dev/tty" 0 0)))
(when (and tty-fd (numberp tty-fd) (> tty-fd 0))
(unwind-protect
(let* ((winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(let ((ok (sb-unix:unix-ioctl tty-fd 21523
(sb-alien:alien-sap winsize))))
(when ok
(let ((cols (sb-alien:deref winsize 1))
(rows (sb-alien:deref winsize 0)))
(values cols rows)))))
(sb-unix:unix-close tty-fd)))))
(if (and cols rows (> cols 0) (> rows 0))
(values cols rows)
(values 80 24))))))
#+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.
Writes a string to the backend's output stream. Does NOT flush — the
caller is responsible for calling ~finish-output~ at appropriate sync
points (frame boundaries via ~end-sync~, initialization, shutdown).
Returns the string length for protocol compatibility.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -686,7 +708,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod capable-p ((b modern-backend) feature)
(member feature '(:truecolor :osc8 :sync :mouse
:bracketed-paste :cursor-style
@@ -702,9 +724,10 @@ 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod draw-text ((b modern-backend) x y string fg bg
&key bold italic underline reverse dim blink
&allow-other-keys)
(let ((parts (list (cursor-move-escape x y)
(sgr-fg fg) (sgr-bg bg)
(when bold (sgr-attr :bold))
@@ -725,7 +748,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod draw-border ((b modern-backend) x y width height
&key style fg bg title title-align)
(let* ((s (or style :single))
@@ -787,14 +810,14 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))))
reset "")))
(loop :for row :from 0 :below height :do
(backend-write b (cursor-move-escape x (+ y row)))
(backend-write b line))))
@@ -807,7 +830,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -823,7 +846,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod draw-ellipsis ((b modern-backend) x y width
&key fg bg)
(declare (ignore width))
@@ -838,7 +861,7 @@ is ignored since dots have a fixed visual length; delegates to
Delegates to =cursor-move-escape= and writes the resulting CSI sequence
to the output stream.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod cursor-move ((b modern-backend) x y)
(backend-write b (cursor-move-escape x y)))
#+END_SRC
@@ -847,7 +870,7 @@ to the output stream.
Sends the DECTCEM private mode =?25l= to hide the cursor.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod cursor-hide ((b modern-backend))
(backend-write b (format nil "~C[?25l" #\Esc)))
#+END_SRC
@@ -856,7 +879,7 @@ Sends the DECTCEM private mode =?25l= to hide the cursor.
Sends =?25h= to restore the cursor visibility.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod cursor-show ((b modern-backend))
(backend-write b (format nil "~C[?25h" #\Esc)))
#+END_SRC
@@ -866,7 +889,7 @@ Sends =?25h= to restore the cursor visibility.
Sets the cursor shape (block/underline/bar, optionally blinking) by
delegating to =cursor-style-escape=.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod cursor-style ((b modern-backend) shape &key blink)
(backend-write b (cursor-style-escape shape blink)))
#+END_SRC
@@ -877,7 +900,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -891,7 +914,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -902,7 +925,7 @@ distinguish user input from pasted content.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod begin-sync ((b modern-backend))
(setf (in-sync-p b) t)
(backend-write b (decicm-begin)))
@@ -913,7 +936,7 @@ slot so other methods can check whether we are inside a sync block.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/backend/modern.lisp
(defmethod end-sync ((b modern-backend))
(setf (in-sync-p b) nil)
(backend-write b (decicm-end))

View File

@@ -1,415 +0,0 @@
#+TITLE: Mouse Support (v0.10.0)
#+DATE: 2026-05-11
#+AUTHOR: Amr Gharbeia / Hermes
* Overview
Mouse event propagation through the component tree. The input system
already parses SGR mouse sequences into ~mouse-event~ structs. This
module adds:
1. A ~mouse-mixin~ class with event handler slots
2. Hit-testing: given (x,y), find the deepest component owning that cell
3. Event dispatch: route ~mouse-event~ → component handlers, bubble up
4. ScrollBox integration: wheel → scroll
5. Text selection: drag highlight + clipboard copy
** Contract
- ~mouse-mixin~ — mixin class with ~:on-mouse-down/up/move/scroll~ slots
- ~handle-mouse-event component event~ — dispatch to the right handler
- ~hit-test root x y~ → deepest component at (x,y)
- ~selection~ — highlighted text region (start-x, start-y, end-x, end-y)
- ~get-selection~ → selected text as string
- ~copy-to-clipboard text~ → pipe to xclip/wl-copy
** 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.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
#:handle-mouse-event
#:hit-test
#:selection #:get-selection #:copy-to-clipboard
#:make-selection #:selection-p
#:start-selection #:update-selection #:finalize-selection
#:selection-active-p
#: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
(:press (on-mouse-down component))
(:release (on-mouse-up component))
(: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.
Components without a layout-node or position return nil."
(labels ((recurse (node)
(let ((ln (ignore-errors (component-layout-node node)))
(best nil))
(when ln
(let ((nx (layout-node-x ln))
(ny (layout-node-y ln))
(nw (layout-node-width ln))
(nh (layout-node-height ln)))
;; Check children first for deeper match
(dolist (child (ignore-errors (component-children node)))
(let ((child-hit (recurse child)))
(when child-hit
(setf best child-hit))))
;; If no child matched, check self
(or best
(when (and (>= x nx) (< x (+ nx nw))
(>= y ny) (< y (+ ny nh)))
node)))))))
(recurse root)))
#+END_SRC
*** ~*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
(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-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)
(when (and *selection-start* *selection-end* fb)
(let* ((x1 (car *selection-start*))
(y1 (cdr *selection-start*))
(x2 (car *selection-end*))
(y2 (cdr *selection-end*))
(text (cl-tty.rendering:extract-text fb x1 y1 x2 y2)))
(setf *selection* (make-selection :start-x x1 :start-y y1
:end-x x2 :end-y y2
:text text))
(setf *selection-start* nil *selection-end* nil)
text)))
#+END_SRC
*** ~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)))
(when url
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
#+darwin (sb-ext:run-program "open" (list url) :wait 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
**** 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))
(is (equal '(5 . 10) cl-tty.mouse::*selection-start*))
(is (equal '(5 . 10) cl-tty.mouse::*selection-end*))
(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)
(is (equal '(3 . 7) cl-tty.mouse::*selection-end*))
(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)))
(cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil)
(cl-tty.backend:draw-text fb-be 0 1 "world" nil nil)
(start-selection 0 0)
(update-selection 4 1)
(let ((text (finalize-selection fb)))
(is (equal "hello
world" text)))))
#+END_SRC

View File

@@ -53,7 +53,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp
(defpackage :cl-tty.box
(:use :cl :cl-tty.backend :cl-tty.layout)
(:export
@@ -75,7 +75,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp
;; Span
#:span
#:span-text #:span-bold #:span-italic #:span-underline
@@ -97,7 +97,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp
;; Text
#:text #:make-text
#:text-layout-node #:text-content #:text-spans
@@ -113,9 +113,9 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp
;; Utilities (for tests)
#:word-wrap #:split-string
#:word-wrap #:split-string #:char-width
#+END_SRC
** Dirty tracking
@@ -131,7 +131,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp
;; Dirty tracking
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty
#+END_SRC
@@ -151,7 +151,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp
;; Rendering pipeline
#:render #:render-screen #:render-node
#:component-layout-node #:component-children #:component-parent
@@ -172,9 +172,15 @@ 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/package.lisp
;; Container components (merged from cl-tty.container)
#: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

View File

@@ -72,7 +72,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
@@ -90,7 +90,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -108,7 +108,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -127,7 +127,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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 "")))
@@ -143,7 +143,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp
(test component-children-returns-nil
"Leaf components have no children"
(let ((bx (make-box)) (tx (make-text "")))
@@ -160,7 +160,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp
(test propagate-dirty-marks-component
"propagate-dirty marks the component dirty"
(let ((c (make-box)))
@@ -180,7 +180,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render-tests.lisp
(test available-width-defaults
"available-width returns 0 for components without explicit width"
(let ((c (make-box)))
@@ -203,7 +203,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(in-package :cl-tty.box)
;; ── Component Protocol ────────────────────────────────────────
@@ -215,7 +215,7 @@ methods for the built-in component types.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defmethod component-layout-node ((bx box))
(box-layout-node bx))
#+END_SRC
@@ -224,7 +224,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defmethod component-layout-node ((tx text))
(text-layout-node tx))
#+END_SRC
@@ -236,7 +236,7 @@ Leaf components (~box~, ~text~) have no children. Container components
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defgeneric component-children (component)
(:documentation "Return the children of COMPONENT, or nil.")
(:method ((c t)) nil))
@@ -250,7 +250,7 @@ used by ~propagate-dirty~ to walk up the tree. The default method on
recursive dirty walk — when ~component-parent~ returns ~nil~, we've
reached the root.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defgeneric component-parent (component)
(:documentation "Return the parent of COMPONENT, or nil.")
(:method ((c t)) nil))
@@ -266,7 +266,7 @@ pipeline. Every component type that can be drawn defines a method on
objects (or components still under development) don't cause errors
when the tree walk reaches them.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
;; ── Rendering Pipeline ────────────────────────────────────────
(defgeneric render (component backend)
@@ -282,7 +282,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defmethod render ((bx box) backend)
(render-box bx backend))
#+END_SRC
@@ -293,7 +293,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defmethod render ((tx text) backend)
(render-text tx backend))
#+END_SRC
@@ -313,7 +313,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -334,7 +334,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -354,7 +354,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defun available-width (component)
"Return the available width for COMPONENT (or 80 as default)."
(let ((ln (component-layout-node component)))
@@ -369,7 +369,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
(defun available-height (component)
"Return the available height for COMPONENT (or 24 as default)."
(let ((ln (component-layout-node component)))
@@ -391,7 +391,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/render.lisp
;; ── Dirty Propagation ─────────────────────────────────────────
(defun propagate-dirty (component)

View File

@@ -45,8 +45,8 @@ 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp
(in-package :cl-tty.box)
(defclass scroll-box (dirty-mixin)
((children :initform nil :initarg :children
@@ -69,7 +69,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp
(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0)
sticky-scroll-p)
(make-instance 'scroll-box
@@ -87,7 +87,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp
(defmethod component-children ((sb scroll-box))
(scroll-box-children sb))
#+END_SRC
@@ -99,7 +99,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp
(defmethod component-layout-node ((sb scroll-box))
(scroll-box-layout-node sb))
#+END_SRC
@@ -113,7 +113,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp
(defun clamp-scroll (sb)
"Clamp scroll offsets to valid range."
(let* ((ln (scroll-box-layout-node sb))
@@ -137,7 +137,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -154,7 +154,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp
(defun scroll-box-content-height (sb)
"Total height of all children."
(reduce #'+ (scroll-box-children sb)
@@ -171,7 +171,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/scrollbox.lisp
(defun scroll-box-content-width (sb)
"Maximum width among children."
(reduce #'max (scroll-box-children sb)
@@ -198,7 +198,7 @@ position.
After child rendering, it delegates to ~draw-scrollbars~ for the
scrollbar overlay.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -241,7 +241,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -262,7 +262,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -283,7 +283,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -342,9 +342,9 @@ along with the base ~:cl~ language and ~:fiveam~ itself.
unconditionally; it runs the ~scrollbox-suite~ and prints results via
~fiveam:explain!~ before exiting.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
(:export #:run-tests))
(in-package #:cl-tty-scrollbox-test)
@@ -363,7 +363,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test scrollbox-creates
"A ScrollBox can be created with defaults."
(let ((sb (make-scroll-box)))
@@ -379,7 +379,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test scrollbox-with-children
"A ScrollBox can have children."
(let ((sb (make-scroll-box :children (list (make-text "hello")))))
@@ -393,7 +393,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test scrollbox-scroll-by
"ScrollBy adjusts offset clamped to valid range."
(let ((sb (make-scroll-box :scroll-y 0)))
@@ -408,7 +408,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test scrollbox-component-children
"Component protocol: children are accessible."
(let* ((child (make-text "hello"))
@@ -423,7 +423,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test scrollbox-render-noop
"Rendering a ScrollBox with no children does not error."
(let* ((stream (make-string-output-stream))
@@ -439,7 +439,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test tabbar-creates
"A TabBar can be created with defaults."
(let ((tb (make-tab-bar)))
@@ -454,7 +454,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test tabbar-add-tab
"Adding a tab returns the id and updates tabs."
(let ((tb (make-tab-bar)))
@@ -469,7 +469,7 @@ plist, so the test checks both list length and the ~:title~ property.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test tabbar-active-tab
"Setting active tab works."
(let ((tb (make-tab-bar)))
@@ -486,7 +486,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test tabbar-render-noop
"Rendering a TabBar does not error."
(let* ((stream (make-string-output-stream))
@@ -507,7 +507,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test tabbar-next-prev
"TabBar next/prev wraps around through tabs."
(let ((tb (make-tab-bar)))
@@ -531,7 +531,7 @@ gracefully.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test tabbar-select
"TabBar select activates the specified tab."
(let ((tb (make-tab-bar)))
@@ -548,7 +548,7 @@ three-tab bar correctly sets the active tab.
This tests the bridge between the input event system and the TabBar
navigation API.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/scrollbox-tabbar-tests.lisp
(test tabbar-handle-key
"TabBar handle-key dispatches left/right."
(let ((tb (make-tab-bar)))
@@ -568,7 +568,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))

View File

@@ -1,599 +0,0 @@
#+TITLE: cl-tty v0.7.0 — Select Dropdown + Fuzzy Filter
#+STARTUP: content
* Select Widget
A selection list component — the building block for command palettes, theme
pickers, agent selectors, and file pickers. Options are plists with ~:title~,
~:value~, and optional ~:category~ fields.
The widget supports keyboard navigation (Up/Down, Ctrl+P/N, Enter, Esc),
option filtering by case-insensitive substring match with trigram fuzzy
fallback, and category grouping with dimmed headers.
** Contract
~select~ class — slots: options, filter, on-select, selected-index, layout-node.
~make-select &key options filter on-select~ → select instance.
~select-options sel~ / ~(setf select-options)~ — list of option plists.
~select-filter sel~ / ~(setf select-filter)~ — filter string or nil.
~select-selected-index sel~ / ~(setf select-selected-index)~ — currently highlighted index.
~select-on-select sel~ / ~(setf select-on-select)~ — callback fn (receives option plist).
~select-layout-node sel~ / ~(setf select-layout-node)~ — layout node.
~select-filtered-options sel~ → list of options matching the filter.
Returns all options when filter is nil. Matches title (case-insensitive).
Falls back to trigram fuzzy matching when no exact substring matches.
~select-next sel~ / ~select-prev sel~ — move selection forward/backward,
skipping category headers. Wraps around at boundaries.
~select-visible-options sel~ → filtered options visible in viewport.
Uses available-height from layout node. Culls like ScrollBox.
~select-handle-key sel event~ → T if handled.
Down/Ctrl+N → next. Up/Ctrl+P → prev. Enter → on-select callback. Esc → nil.
~render ((sel select) backend)~ — renders visible options with selection highlight.
** 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)))
(is (typep sel 'select))
(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
:options '((:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Blue" :value :blue)))))
(setf (select-filter sel) "bl")
(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
:options '((:title "Red" :value :red)
(: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
:options '((:title "A" :value :a)
(:title "B" :value :b)
(:title "C" :value :c)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1))
(select-next sel)
(is (= (select-selected-index sel) 2))
(select-next sel)
(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
:options '((:title "Colors" :category t)
(:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Shapes" :category t)
(:title "Circle" :value :circle)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1) "skipped category header at 0")
(select-next sel)
(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))
(sel (make-select
:options '((:title "A" :value :a) (:title "B" :value :b))
:on-select (lambda (opt) (setf (car result) (getf opt :value))))))
(select-handle-key sel (make-key-event :key :down))
(is (= (select-selected-index sel) 1))
(select-handle-key sel (make-key-event :key :up))
(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
:options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c)))))
(select-handle-key sel (make-key-event :key :n :ctrl t))
(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))
(sel (make-select
:options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i)))))
(setf (select-layout-node sel) ln)
(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
:options '((:title "Nord" :value :nord)
(:title "Tokyo Night" :value :tokyo)
(:title "Catppuccin" :value :cat)))))
(setf (select-filter sel) "nrd")
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :nord)))))
#+END_SRC
* Implementation
** Package
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
#: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
** Select class
*** defclass select
~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)
((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)))
#+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)
:filter filter
:on-select on-select))
#+END_SRC
** Component protocol
*** defmethod component-layout-node
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
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.
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)."
(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))))
#+END_SRC
** Fuzzy matching: character-set Jaccard similarity
*** defun string-trigrams
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)
"Return a list of 3-character trigrams from STR."
(let ((s (string-downcase str))
(result nil))
(when (< (length s) 3)
(return-from string-trigrams (list s)))
(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))
(t-trigrams (string-trigrams target))
(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)))
(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))))
#+END_SRC
** Navigation
*** defun select-clamp-index
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))
(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)))))))
#+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))
(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)))))
#+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))
(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)))))
#+END_SRC
** Key event handler
*** defun 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 the widget)
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))
(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))))
#+END_SRC
** Visible options (viewport culling)
*** defun 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 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))
(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)))
#+END_SRC
** Rendering
*** defmethod 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
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))
(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))
(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
(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)))
#+END_SRC

View File

@@ -50,7 +50,7 @@ same slot with conflicting mode specifications.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot-package.lisp
(defpackage :cl-tty.slot
(:use :cl)
(:export
@@ -73,7 +73,7 @@ case-insensitive lookup via ~equal~). Each value is a plist:
The ~:test #'equal~ ensures that ~:sidebar~ and ~"sidebar"~ map to the
same key.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp
(in-package :cl-tty.slot)
(defvar *slots* (make-hash-table :test 'equal)
@@ -97,7 +97,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp
(defun defslot (name &key (order 0) render-fn (mode :stack))
(let* ((key (string name))
(slot (gethash key *slots*)))
@@ -143,7 +143,7 @@ changing the slot's semantics out from under earlier registrations.
Returns ~nil~ if the slot has no registrations or if the handler is nil.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp
(defun slot-render (slot-name &rest args)
(let ((slot (gethash (string slot-name) *slots*)))
(when slot
@@ -169,7 +169,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp
(defun slot-p (slot-name)
(nth-value 1 (gethash (string slot-name) *slots*)))
#+END_SRC
@@ -180,7 +180,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp
(defun clear-slot (slot-name)
(remhash (string slot-name) *slots*))
#+END_SRC
@@ -191,7 +191,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/slot.lisp
(defun list-slots ()
(loop for key being the hash-keys of *slots* collect key))
#+END_SRC
@@ -203,7 +203,7 @@ including mode-specific behavior.
*** Test Package and Suite
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam))
(in-package :cl-tty-slot-test)
@@ -213,7 +213,7 @@ including mode-specific behavior.
*** defslot-register: Registering a slot makes it visible
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(def-test defslot-register ()
(clear-slot :test-slot)
(defslot :test-slot :order 1 :render-fn (lambda () "hello"))
@@ -225,7 +225,7 @@ including mode-specific behavior.
Verifies that ~:stack~ mode preserves multiple registrations and calls
them in ascending order sequence.
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(def-test slot-render-calls ()
(clear-slot :test-slot)
(defslot :test-slot :order 1 :render-fn (lambda () "a"))
@@ -235,7 +235,7 @@ them in ascending order sequence.
*** slot-render-empty: Unregistered slot returns nil
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(def-test slot-render-empty ()
(clear-slot :ghost)
(is-false (slot-render :ghost)))
@@ -243,7 +243,7 @@ them in ascending order sequence.
*** clear-slot-removes: Clearing a slot makes it absent
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(def-test clear-slot-removes ()
(clear-slot :test-slot)
(defslot :test-slot :order 1 :render-fn (lambda () "x"))
@@ -256,7 +256,7 @@ them in ascending order sequence.
Verifies that ~:stack~ mode (default) accumulates entries across
multiple ~defslot~ calls.
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(def-test stack-mode-multiple-entries ()
(clear-slot :stack-test)
(defslot :stack-test :order 1 :render-fn (lambda () "first"))
@@ -270,7 +270,7 @@ multiple ~defslot~ calls.
Verifies that ~:replace~ mode discards previous entries on each new
~defslot~ call.
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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"))
@@ -282,7 +282,7 @@ Verifies that ~:replace~ mode discards previous entries on each new
Verifies that ~:single-winner~ mode ignores subsequent registrations.
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(def-test single-winner-mode-first-wins ()
(clear-slot :winner-test)
(defslot :winner-test :mode :single-winner :order 1
@@ -297,7 +297,7 @@ Verifies that ~:single-winner~ mode ignores subsequent registrations.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/slot-tests.lisp
(def-test clear-slot-removes-mode ()
(clear-slot :mode-test)
(defslot :mode-test :mode :replace :render-fn (lambda () "only"))

View File

@@ -32,8 +32,8 @@ 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp
(in-package :cl-tty.box)
#+END_SRC
** TabBar class
@@ -48,7 +48,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp
(defclass tab-bar (dirty-mixin)
((tabs :initform nil :initarg :tabs
:accessor tab-bar-tabs :type list)
@@ -65,7 +65,7 @@ Convenience constructor that forwards keyword arguments to
~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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp
(defun make-tab-bar (&key tabs active)
(make-instance 'tab-bar :tabs (or tabs nil) :active active))
#+END_SRC
@@ -79,7 +79,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
@@ -95,7 +95,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp
(defmethod component-layout-node ((tb tab-bar))
(tab-bar-layout-node tb))
#+END_SRC
@@ -110,7 +110,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp
(defun tab-bar-next (tb)
"Move to next tab."
(let* ((tabs (tab-bar-tabs tb))
@@ -130,7 +130,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp
(defun tab-bar-prev (tb)
"Move to previous tab."
(let* ((tabs (tab-bar-tabs tb))
@@ -150,7 +150,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/tabbar.lisp
(defun tab-bar-select (tb id)
"Select a tab by ID."
(setf (tab-bar-active tb) id)
@@ -165,10 +165,10 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)
(case (cl-tty.input:key-event-key event)
(:left (tab-bar-prev tb) t)
(:right (tab-bar-next tb) t)
(t nil)))
@@ -186,7 +186,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))

View File

@@ -178,7 +178,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input-package.lisp
(defpackage :cl-tty.input
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout)
(:export
@@ -199,12 +199,18 @@ via ~sb-posix~ directly.
#:*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
;; 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-on-cancel
#:text-input-on-tab #:text-input-on-history
#:text-input-layout-node
#:text-input-insert #:text-input-backspace #:text-input-delete
#:text-input-move-left #:text-input-move-right
#:text-input-move-home #:text-input-move-end
#:text-input-delete-word-before
#:handle-text-input #:render-text-input
;; Textarea
#:textarea #:make-textarea
#:textarea-value #:textarea-cursor-row #:textarea-cursor-col
@@ -216,7 +222,18 @@ via ~sb-posix~ directly.
#:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent
#:*keymaps* #:*chord-timeout*
#:defkeymap #:dispatch-key-event #:key-match-p
#:component-keymap))
#:component-keymap
;; Mouse (merged from cl-tty.mouse)
#:mouse-mixin
#:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll
#:handle-mouse-event
#:hit-test
#:selection #:get-selection #:copy-to-clipboard
#:make-selection #:selection-p
#:start-selection #:update-selection #:finalize-selection
#:selection-active-p
#:*selection* #:*selection-active* #:*selection-start* #:*selection-end*
#:cell-link-at #:open-link-at))
#+END_SRC
* Input Reader Core
@@ -243,7 +260,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(in-package #:cl-tty.input)
(defun %split-string (string separator)
@@ -262,12 +279,12 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *current-backend* nil
"The active backend used for rendering.")
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *current-theme* nil
"The active theme used for semantic color resolution.")
#+END_SRC
@@ -299,7 +316,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defstruct key-event
(key nil :type (or keyword null))
(ctrl nil :type boolean)
@@ -323,7 +340,7 @@ field is :press, :release, or :drag, determined by whether the button
code includes the motion bit (bit 5). Coordinates are 1-indexed from
the terminal; no adjustment is performed here.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defstruct mouse-event
(type nil :type (or keyword null))
(button nil :type (or keyword null))
@@ -342,7 +359,7 @@ the modern xterm format, as opposed to the single-letter terminators used
by VT100-style sequences (~ESC[H~ = Home, ~ESC[F~ = End). Modern terminal
emulators emit the tilde form for most keys; we handle both.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defparameter *csi-tilde-table*
'((1 . :home) (2 . :insert) (3 . :delete) (4 . :end)
(5 . :page-up) (6 . :page-down)
@@ -363,7 +380,7 @@ emitted by most terminal emulators in "normal" (non-application) cursor
key mode. The ~:back-tab~ mapping for Z handles Shift+Tab, which some
emulators report as ~ESC[Z~.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defparameter *csi-key-table*
'((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left)
(#\F . :end) (#\H . :home)
@@ -391,11 +408,12 @@ Modifier encoding follows the xterm convention: Shift=1, Alt=2, Ctrl=4.
The extended parameter vector carries the raw parameter bytes for
sequences where modifiers appear in a non-standard position.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun parse-csi-params (params terminator extended)
(let* ((key (if (find terminator '(#\~ #\u))
(let* ((terminator-char (code-char terminator))
(key (if (and terminator-char (find terminator-char '(#\~ #\u)))
(cdr (assoc (first params) *csi-tilde-table*))
(cdr (assoc terminator *csi-key-table*))))
(cdr (assoc terminator-char *csi-key-table*))))
(modifier (when (and (> (length params) 1) (not (find terminator '(#\~ #\u))))
(second params)))
(actual-modifier (when (> (length extended) 1) (second extended)))
@@ -415,7 +433,7 @@ sequences where modifiers appear in a non-standard position.
: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)))))
:raw (format nil "~C[~{~d~};~d" #\Esc params terminator)))))
#+END_SRC
** Raw byte reader
@@ -434,22 +452,45 @@ 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.
Memory management: we use ~sb-sys:with-pinned-objects~ to pin a 1-byte
~make-array~ vector in memory, obtain its SAP via ~sb-sys:vector-sap~,
and read directly into the backing storage. This avoids alien allocation
and manual ~free-alien~ while keeping the GC from moving the buffer
during the ~unix-read~ syscall.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun get-input-fd ()
"Return a file descriptor suitable for reading terminal input.
Prefers fd 0 (stdin) if it's a TTY, otherwise opens /dev/tty.
Falls back to fd 0 if /dev/tty is not available."
(or (and (sb-unix:unix-isatty 0) 0)
(handler-case
(let ((fd (sb-unix:unix-open "/dev/tty" sb-unix:o_rdonly)))
(if (and fd (>= fd 0)) fd 0))
(error () 0))))
#+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))))
(let* ((buf (make-array 1 :element-type '(unsigned-byte 8)))
(fd-stream (get-input-fd))
(timeout-ms (when timeout (max 1 (round (* timeout 1000))))))
(sb-sys:with-pinned-objects (buf)
(let ((sap (sb-sys:vector-sap buf)))
(if timeout-ms
(let ((poll-result (sb-unix:unix-simple-poll fd-stream :input timeout-ms)))
(if poll-result
(let ((n (sb-unix:unix-read fd-stream sap 1)))
(if (= n 1)
(aref buf 0)
;; EOF on fd — try opening /dev/tty
(let ((tty-fd (sb-unix:unix-open "/dev/tty" sb-unix:o_rdonly)))
(if (and tty-fd (>= tty-fd 0))
(let ((m (sb-unix:unix-read tty-fd sap 1)))
(sb-unix:unix-close tty-fd)
(if (= m 1) (aref buf 0) (values nil nil)))
(values nil nil)))))
(values nil nil)))
(let ((n (sb-unix:unix-read fd-stream sap 1)))
(if (= n 1) (aref buf 0) (values nil :eof))))))))
#+END_SRC
** Escape sequence reader
@@ -478,7 +519,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %read-escape-sequence ()
(flet ((read-next (&optional (timeout nil))
(let ((b (read-raw-byte :timeout timeout)))
@@ -533,7 +574,7 @@ non-digit byte, handling an optional list of initial bytes that were
already consumed by the caller. Returns the parsed integer and the
terminator byte.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %read-digits (&optional (initial-bytes nil))
"Read bytes until a non-digit is encountered.
Returns (values number terminator-byte)."
@@ -561,7 +602,7 @@ a ~mouse-event~ struct with proper button and type classification.
Coordinates are converted from 1-based (terminal protocol) to 0-based
(framebuffer convention) by subtracting 1 from both x and y.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %parse-sgr-mouse ()
"Parse SGR mouse escape sequence: ESC [ < Cb ; Cx ; Cy M/m
Returns a mouse-event struct."
@@ -606,25 +647,30 @@ 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.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))))))
(loop for b = (funcall next-fn)
do (if (and (>= b 48) (<= b 57))
(push (- b 48) acc)
(return (values (reverse acc) b)))))))
(let* ((b2 (read-raw-byte)))
(if (= b2 60) ;; < — SGR mouse marker
(%parse-sgr-mouse)
(let* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0))
(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)))))))
(parsed (if (and (>= b2 48) (<= b2 57))
;; Digit branch: read params with their digits
(let ((r (multiple-value-list (read-param (lambda () (read-raw-byte))))))
(let ((p (first r)))
(setf (fill-pointer extended) (length p))
(replace extended p))
r)
;; Non-digit branch: b2 is a direct CSI terminator
(progn (vector-push-extend b2 extended)
(list nil b2)))))
(let ((params (first parsed))
(terminator (or (second parsed) 0)))
(parse-csi-params (or params '()) terminator extended)))))))
#+END_SRC
** UTF-8 decoder
@@ -652,7 +698,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun utf8-decode (bytes)
(case (length bytes)
(2 (let ((b0 (first bytes)) (b1 (second bytes)))
@@ -700,7 +746,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -743,20 +789,22 @@ connection. The 500ms gives the terminal ample time to deliver all bytes.
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.
flag. The ~:sb-posix~ module must be ~require~d first so that the
~sb-posix:sigwinch~ constant is available.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *terminal-resized-p* nil)
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
#+sbcl
(eval-when (:load-toplevel :execute)
(require :sb-posix)
(sb-sys:enable-interrupt sb-posix:sigwinch
(lambda (signal info context)
(declare (ignore signal info context))
@@ -770,12 +818,14 @@ input). SBCL's ~SB-POSIX:WITH-RAW-TERMINAL~ is not available in all builds
(e.g. Debian-packaged SBCL 2.5.x). This implementation uses ~stty~ for
portability.
#+BEGIN_SRC lisp :tangle ../src/components/input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun %raw-mode-on ()
(uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr") :output nil :error-output nil))
(uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr")
:output nil :error-output nil :ignore-error-status t))
(defun %raw-mode-off ()
(uiop:run-program '("stty" "sane") :output nil :error-output nil))
(uiop:run-program '("stty" "sane")
:output nil :error-output nil :ignore-error-status t))
(defmacro with-raw-terminal (&body body)
"Execute BODY with the terminal in raw mode."
@@ -799,7 +849,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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.
@@ -844,7 +894,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(in-package #:cl-tty.input)
(defclass textarea (dirty-mixin)
@@ -871,7 +921,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun make-textarea (&key value on-submit)
(make-instance 'textarea
:value (or value "")
@@ -888,13 +938,13 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-line-count (ta)
"Number of lines in value."
(length (textarea-lines ta)))
@@ -912,7 +962,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-ensure-cursor (ta)
"Clamp cursor to valid range."
(let ((lines (textarea-lines ta)))
@@ -935,7 +985,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun %join-lines (lines)
"Join a sequence of strings with newlines."
(with-output-to-string (s)
@@ -962,7 +1012,7 @@ within the current line. The algorithm:
The function updates ~cursor-col~ by 1 after insertion and marks the
widget dirty.
#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-insert-char (ta char)
"Insert CHAR at the cursor position."
(textarea-push-undo ta)
@@ -1003,7 +1053,7 @@ Algorithm:
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-newline (ta)
"Insert a newline at the cursor."
(textarea-push-undo ta)
@@ -1049,7 +1099,7 @@ line, removing the newline character between them.
All paths push undo state before modifying the value.
#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-backspace (ta)
"Delete character before cursor."
(textarea-push-undo ta)
@@ -1099,13 +1149,13 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-move-down (ta)
(incf (textarea-cursor-row ta))
(textarea-ensure-cursor ta))
@@ -1136,7 +1186,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-push-undo (ta)
"Save current value on undo stack."
(let ((stack (textarea-undo-stack ta)))
@@ -1148,7 +1198,7 @@ textarea.
(setf (fill-pointer (textarea-redo-stack ta)) 0)))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-undo (ta)
(let ((stack (textarea-undo-stack ta)))
(when (plusp (length stack))
@@ -1159,7 +1209,7 @@ textarea.
(mark-dirty ta)))))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/textarea.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun textarea-redo (ta)
(let ((stack (textarea-redo-stack ta)))
(when (plusp (length stack))
@@ -1196,7 +1246,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defun handle-textarea-input (ta event)
"Process a key-event on a textarea widget."
(cond
@@ -1270,7 +1320,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/textarea.lisp
(defmethod render ((ta textarea) (backend t))
"Render textarea lines at layout position."
(let* ((ln (textarea-layout-node ta))
@@ -1314,7 +1364,7 @@ tracking. Slots:
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(in-package #:cl-tty.input)
(defclass text-input (dirty-mixin)
@@ -1328,6 +1378,12 @@ This is the first block tangling to text-input.lisp, so it includes the
:accessor text-input-max-length)
(on-submit :initform nil :initarg :on-submit
:accessor text-input-on-submit)
(on-cancel :initform nil :initarg :on-cancel
:accessor text-input-on-cancel)
(on-tab :initform nil :initarg :on-tab
:accessor text-input-on-tab)
(on-history :initform nil :initarg :on-history
:accessor text-input-on-history)
(layout-node :initform (make-layout-node) :accessor text-input-layout-node)
(focusable :initform t :accessor text-input-focusable)))
#+END_SRC
@@ -1343,14 +1399,18 @@ 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun make-text-input (&key value cursor placeholder max-length
on-submit on-cancel on-tab on-history)
(make-instance 'text-input
:value (or value "")
:cursor (or cursor 0)
:placeholder (or placeholder "")
:max-length max-length
:on-submit on-submit))
:on-submit on-submit
:on-cancel on-cancel
:on-tab on-tab
:on-history on-history))
#+END_SRC
** Character insertion
@@ -1369,7 +1429,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-insert (input char)
(let* ((val (text-input-value input))
(pos (text-input-cursor input))
@@ -1389,7 +1449,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -1410,7 +1470,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -1427,13 +1487,13 @@ one character position, clamped to [0, length]. Left movement stops at
Each movement function marks the widget dirty so the renderer redraws
the cursor position.
#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -1447,13 +1507,13 @@ the cursor position.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun text-input-move-end (input)
(setf (text-input-cursor input) (length (text-input-value input)))
(mark-dirty input))
@@ -1478,7 +1538,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -1516,7 +1576,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/text-input.lisp
(defun handle-text-input (input event)
(cond
((key-event-ctrl event)
@@ -1537,10 +1597,37 @@ key bindings.
(: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))))))))
(:enter (let ((cb (text-input-on-submit input))) (when cb (funcall cb (text-input-value input)))))
(:tab (let ((cb (text-input-on-tab input)))
(when cb
(multiple-value-bind (new-text new-pos)
(funcall cb (text-input-value input) (text-input-cursor input))
(when new-text
(setf (text-input-value input) new-text
(text-input-cursor input) (or new-pos (length new-text)))
(mark-dirty input))))))
(:escape (let ((cb (text-input-on-cancel input))) (when cb (funcall cb))))
(:up (let ((cb (text-input-on-history input)))
(when cb
(multiple-value-bind (new-text new-pos)
(funcall cb :up)
(when new-text
(setf (text-input-value input) new-text
(text-input-cursor input) (or new-pos (length new-text)))
(mark-dirty input))))))
(:down (let ((cb (text-input-on-history input)))
(when cb
(multiple-value-bind (new-text new-pos)
(funcall cb :down)
(when new-text
(setf (text-input-value input) new-text
(text-input-cursor input) (or new-pos (length new-text)))
(mark-dirty input))))))
(otherwise (let ((code (key-event-code event)))
(when code
(let ((ch (code-char code)))
(when (and ch (graphic-char-p ch))
(text-input-insert input ch))))))))))
#+END_SRC
** Text input rendering
@@ -1562,18 +1649,32 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))))
(display (if (plusp (length value)) value (or (text-input-placeholder in) ""))))
(when (zerop (length display)) (return-from render (values)))
(let* ((lines (cl-tty.box:word-wrap display w))
(n-lines (length lines)))
;; Draw each wrapped line
(loop for line in lines
for row from 0
do (let ((fg (if (plusp (length value)) nil :dim)))
(draw-text backend x (+ y row) line fg nil)))
;; Draw block cursor at the right position when value is non-empty
(when (plusp (length value))
(let ((cl 0) (cc 0) (accum 0))
(dotimes (i n-lines)
(let ((len (length (nth i lines))))
(when (and (>= cursor accum) (or (< cursor (+ accum len)) (= i (1- n-lines))))
(setf cl i cc (- cursor accum)))
(incf accum (1+ len))))
(let ((cx (+ x cc))
(cy (+ y cl)))
(draw-text backend cx cy "█" :bright-white nil)))))))
#+END_SRC
* Keybinding System
@@ -1601,7 +1702,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(in-package #:cl-tty.input)
(defstruct keymap
@@ -1621,11 +1722,11 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defparameter *keymaps* (make-hash-table :test #'equal))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defparameter *chord-timeout* 0.5)
#+END_SRC
@@ -1650,7 +1751,7 @@ The modifier matching uses ~string=?~ on the modifier part because
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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."
@@ -1664,7 +1765,7 @@ for users writing ~:ctrl+p~ in their keymaps.
(let ((mod-str (subseq name 0 plus))
(key-str (subseq name (1+ plus))))
(and (eql (intern key-str :keyword)
(key-event-key event))
(intern (string-upcase (symbol-name (key-event-key event))) :keyword))
(cond
((string= mod-str "CTRL") (key-event-ctrl event))
((string= mod-str "ALT") (key-event-alt event))
@@ -1709,7 +1810,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defun dispatch-key-event (event &key component)
(labels ((try-keymap (km)
(when km
@@ -1731,7 +1832,7 @@ are reserved for future implementation.
~defkeymap~ is a convenience macro that registers a keymap in the global
~*keymaps*~ hash table. Syntax:
#+BEGIN_SRC lisp :tangle ../src/components/keybindings.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
(defmacro defkeymap (name &body bindings)
`(setf (gethash ',name *keymaps*)
(make-keymap :name ',name
@@ -1752,12 +1853,159 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/keybindings.lisp
;;; --- Component protocol integration ---
(defgeneric component-keymap (component)
(:method ((c t)) nil))
#+END_SRC
* Mouse support (merged from cl-tty.mouse)
Mouse event propagation through the component tree. The input system
already parses SGR mouse sequences into ~mouse-event~ structs. This
section adds:
1. A ~mouse-mixin~ class with event handler slots
2. Hit-testing: given (x,y), find the deepest component owning that cell
3. Event dispatch: route ~mouse-event~ → component handlers, bubble up
4. Text selection: drag highlight + clipboard copy
** mouse-mixin — mixin class for mouse event handler slots
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun handle-mouse-event (component event)
(let* ((type (mouse-event-type event))
(handler (case type
(:press (on-mouse-down component))
(:release (on-mouse-up component))
(: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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun hit-test (root x y)
"Find the deepest component at (X, Y) by testing layout-node bounds."
(labels ((recurse (node)
(let ((ln (ignore-errors (component-layout-node node)))
(best nil))
(when ln
(let ((nx (layout-node-x ln))
(ny (layout-node-y ln))
(nw (layout-node-width ln))
(nh (layout-node-height ln)))
(dolist (child (ignore-errors (component-children node)))
(let ((child-hit (recurse child)))
(when child-hit (setf best child-hit))))
(or best
(when (and (>= x nx) (< x (+ nx nw))
(>= y ny) (< y (+ ny nh)))
node)))))))
(recurse root)))
#+END_SRC
** Selection state
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defvar *selection* nil)
(defvar *selection-active* nil "T when a drag selection is in progress.")
(defvar *selection-start* nil "Cons (X . Y) of mouse-down position during drag.")
(defvar *selection-end* nil "Cons (X . Y) of current mouse position during drag.")
#+END_SRC
** selection struct
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defstruct (selection (:conc-name sel-))
(start-x 0) (start-y 0) (end-x 0) (end-y 0) (text ""))
#+END_SRC
** get-selection / copy-to-clipboard
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun get-selection ()
(when *selection* (sel-text *selection*)))
(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))
#+END_SRC
** start-selection / update-selection
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(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))
(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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun selection-active-p ()
"Return T if a drag selection is in progress."
*selection-active*)
#+END_SRC
** finalize-selection
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(defun finalize-selection (fb)
"End the drag selection and extract text from the framebuffer."
(setf *selection-active* nil)
(when (and *selection-start* *selection-end* fb)
(let* ((x1 (car *selection-start*))
(y1 (cdr *selection-start*))
(x2 (car *selection-end*))
(y2 (cdr *selection-end*))
(text (cl-tty.rendering:extract-text fb x1 y1 x2 y2)))
(setf *selection* (make-selection :start-x x1 :start-y y1
:end-x x2 :end-y y2
:text text))
(setf *selection-start* nil *selection-end* nil)
text)))
#+END_SRC
** cell-link-at / open-link-at
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/input.lisp
(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))
(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)))
(when url
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
url))
#+END_SRC
* Tests
The test suite is tangled to ~../tests/input-tests.lisp~ and covers:
@@ -1773,7 +2021,7 @@ The test suite is tangled to ~../tests/input-tests.lisp~ and covers:
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -2184,3 +2432,44 @@ The test suite is tangled to ~../tests/input-tests.lisp~ and covers:
(print be)))))
(is (listp expanded))))
#+END_SRC
;; ─── Mouse tests (merged from cl-tty.mouse) ───────────────────
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/tests/input-tests.lisp
(def-test mouse-mixin-create ()
(let ((m (make-instance 'mouse-mixin)))
(is-true (typep m 'mouse-mixin))))
(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))))
(def-test selection-set-and-get ()
(setf *selection* (make-selection :text "hello"))
(is (equal "hello" (get-selection))))
(def-test start-selection-initializes-state ()
(start-selection 5 10)
(is-true (selection-active-p))
(is (equal '(5 . 10) *selection-start*))
(is (equal '(5 . 10) *selection-end*))
(setf *selection-active* nil *selection-start* nil *selection-end* nil))
(def-test update-selection-moves-end ()
(start-selection 0 0)
(update-selection 3 7)
(is (equal '(3 . 7) *selection-end*))
(setf *selection-active* nil *selection-start* nil *selection-end* nil))
(def-test finalize-selection-extracts-text ()
(let* ((fb-be (cl-tty.rendering:make-framebuffer-backend))
(fb (cl-tty.rendering:fb-framebuffer fb-be)))
(cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil)
(cl-tty.backend:draw-text fb-be 0 1 "world" nil nil)
(start-selection 0 0)
(update-selection 4 1)
(let ((text (finalize-selection fb)))
(is (equal "hello
world" text)))))
#+END_SRC

View File

@@ -43,15 +43,37 @@ and the backend's ~*theme-colors*~ for SGR resolution.
- ~:default~ — gold/accent on dark blue-gray
- ~:nord~ — cool blue nord palette
* Package definition
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(defpackage :cl-tty.theme
(:use :cl :cl-tty.backend)
(:export
#:theme #:make-theme #:theme-mode
#:theme-color #:load-preset #:define-preset
#:save-theme #:load-theme))
(in-package :cl-tty.theme)
#+END_SRC
* 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(defpackage :cl-tty-theme-test
(:use :cl :cl-tty.theme :fiveam)
(:export #:run-tests))
(in-package :cl-tty-theme-test)
(def-suite theme-suite :description "Theme engine tests")
(in-suite theme-suite)
(defun run-tests ()
(let ((result (run 'theme-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
** Test: theme-create-default
@@ -60,7 +82,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test theme-create-default
"A theme can be created with default mode"
(let ((th (make-theme)))
@@ -73,7 +95,7 @@ class with ~:dark~ as the initial mode.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test theme-create-light
"A theme can be created in light mode"
(let ((th (make-theme :mode :light)))
@@ -86,7 +108,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test theme-color-set-and-get
"theme-color setf/get works"
(let ((th (make-theme)))
@@ -100,7 +122,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test theme-color-unknown-returns-nil
"Unknown roles return nil"
(let ((th (make-theme)))
@@ -113,7 +135,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test load-default-dark-preset
"Loading the default dark preset populates roles"
(let ((th (make-theme :mode :dark)))
@@ -129,7 +151,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test load-default-light-preset
"Light variant has different colors"
(let ((th (make-theme :mode :light)))
@@ -144,7 +166,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test load-nord-preset
"Nord preset has different colors than default"
(let ((th (make-theme :mode :dark)))
@@ -159,7 +181,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test load-preset-unknown-warns
"Unknown preset warns but doesn't error"
(let ((th (make-theme)))
@@ -173,7 +195,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme-tests.lisp
(test preset-switch-mode
"Switching mode and reloading changes colors"
(let ((th (make-theme :mode :dark)))
@@ -200,8 +222,8 @@ 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)
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(in-package :cl-tty.theme)
(defclass theme ()
((mode :initform :dark :initarg :mode :accessor theme-mode)
@@ -215,7 +237,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(defun make-theme (&key (mode :dark))
(make-instance 'theme :mode mode))
#+END_SRC
@@ -229,7 +251,7 @@ Reads a semantic role from the theme's roles hash table. Uses
degrade gracefully rather than crashing. The backend treats ~nil~ as
"use default."
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)))
@@ -241,7 +263,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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))
@@ -258,7 +280,7 @@ table keeps preset data inline and readable.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(defparameter *presets* (make-hash-table :test #'eq))
#+END_SRC
@@ -269,7 +291,7 @@ Registers a preset by name (~keyword~) at macro-expansion time. The
~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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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)."
@@ -292,7 +314,7 @@ 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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/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
@@ -320,7 +342,7 @@ Two presets are built in:
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(define-preset :default
:dark (:primary "#FFD700" :secondary "#B8860B" :accent "#FFA500"
:error "#FF4444" :warning "#FF8800" :success "#44BB44" :info "#4488FF"
@@ -351,7 +373,7 @@ inverts to warm tones on near-white.
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
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(define-preset :nord
:dark (:primary "#88C0D0" :secondary "#81A1C1" :accent "#5E81AC"
:error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD"
@@ -374,5 +396,43 @@ contrast than default, designed for reduced eye strain.
:markdown-link "#81A1C1" :markdown-quote "#8F9BB3"
:syntax-keyword "#81A1C1" :syntax-function "#A3BE8C"
:syntax-string "#D08770" :syntax-number "#B48EAD"
:syntax-comment "#8F9BB3" :syntax-type "#88C0D0"))
:syntax-comment "#8F9BB3" :syntax-type "#88C0D0"))
#+END_SRC
** Persistence
The theme system provides functions to save and restore a theme's role
map to and from a Lisp data file. The file format is an alist of
~(role . hex)~ pairs, written by ~prin1~ and read with ~read~.
*** defun save-theme
Serialises the theme's role hash table to a file. Each ~(role . hex)~
pair is written as a cons cell in an alist.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(defun save-theme (theme path)
"Persist THEME's role map to file at PATH as an alist."
(ensure-directories-exist path)
(with-open-file (out path :direction :output :if-exists :supersede)
(let (alist)
(maphash (lambda (k v) (push (cons k v) alist)) (theme-roles theme))
(prin1 (nreverse alist) out))
t))
#+END_SRC
*** defun load-theme
Restores a theme's role map from a file previously written by
~save-theme~. The file is an alist of ~(role . hex)~ pairs. If the
file does not exist, returns nil silently.
#+BEGIN_SRC lisp :tangle ~/.local/share/cl-tty/src/components/theme.lisp
(defun load-theme (theme path)
"Restore THEME's role map from file at PATH.
Returns T on success, nil if the file does not exist."
(when (probe-file path)
(with-open-file (in path :direction :input)
(dolist (pair (read in) t)
(setf (gethash (car pair) (theme-roles theme)) (cdr pair))))))
#+END_SRC

View File

@@ -12,10 +12,8 @@
"src/components/theme-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/integration-tests.lisp"))
@@ -27,11 +25,10 @@
(:cl-tty-box-test "BOX-SUITE")
(:cl-tty-input-test "INPUT-SUITE")
(:cl-tty-scrollbox-test "SCROLLBOX-SUITE")
(:cl-tty-select-test "SELECT-SUITE")
(:cl-tty-markdown-test :cl-tty-markdown-test)
(:cl-tty-dialog-test "DIALOG-SUITE")
(:cl-tty-mouse-test "MOUSE-SUITE")
(:cl-tty-slot-test "SLOT-SUITE")
(:cl-tty-markdown-test :cl-tty-markdown-test)
(:cl-tty-dialog-test "DIALOG-SUITE")
(:cl-tty-theme-test "THEME-SUITE")
(: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")

View File

@@ -29,16 +29,13 @@
'("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/keybindings.lisp"
"src/components/markdown-package.lisp" "src/components/markdown.lisp"
"src/components/package.lisp" "src/components/render.lisp"
"src/components/scrollbox.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"
@@ -50,9 +47,9 @@
"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/scrollbox-tabbar-tests.lisp" "tests/dialog-tests.lisp"
"tests/markdown-tests.lisp" "tests/dialog-tests.lisp"
"tests/mouse-tests.lisp" "tests/slot-tests.lisp"
"tests/dialog-tests.lisp" "tests/slot-tests.lisp"
"tests/framebuffer-tests.lisp")))
(dolist (f files)
(if (probe-file f)

View File

@@ -28,16 +28,13 @@
'("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/keybindings.lisp"
"src/components/markdown-package.lisp" "src/components/markdown.lisp"
"src/components/package.lisp" "src/components/render.lisp"
"src/components/scrollbox.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"
@@ -57,10 +54,8 @@
"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))

View File

@@ -152,7 +152,7 @@ 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)
full = PREAMBLE + """(use-package :cl-tty.dialog)
(let ((s (make-select :options '("apple" "banana" "cherry" "date"))))
(format t "ALL:~a" (length (select-filtered-options s)))
(setf (select-filter s) "ap")

View File

@@ -1,105 +0,0 @@
(in-package :cl-tty.backend)
(defclass backend () ())
(defgeneric initialize-backend (backend)
(:method ((b backend)) b))
(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)))
(defgeneric backend-write (backend string))
(defgeneric backend-clear (backend)
(:method ((b backend))
(backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc))))
(defgeneric draw-text (backend x y string fg bg &key
bold italic underline reverse dim blink
&allow-other-keys))
(defgeneric draw-border (backend x y width height
&key style fg bg title title-align))
(defgeneric draw-rect (backend x y width height &key bg))
(defgeneric draw-link (backend x y string url &key fg bg))
(defgeneric draw-ellipsis (backend x y width &key fg bg))
(defgeneric cursor-move (backend x y)
(:method ((b backend) x y) (declare (ignore x y)) (values)))
(defgeneric cursor-hide (backend)
(:method ((b backend)) (values)))
(defgeneric cursor-show (backend)
(:method ((b backend)) (values)))
(defgeneric cursor-style (backend shape &key blink)
(:method ((b backend) shape &key blink) (values)))
(defgeneric begin-sync (backend)
(:method ((b backend)) (values)))
(defgeneric end-sync (backend)
(:method ((b backend)) (values)))
(defgeneric read-event (backend &key timeout)
(:method ((b backend) &key timeout) (values nil nil)))
(defgeneric enable-mouse (backend)
(:method ((b backend)) (values)))
(defgeneric enable-bracketed-paste (backend)
(:method ((b backend)) (values)))
(defgeneric capable-p (backend feature)
(:method ((b backend) feature)
(declare (ignore feature))
nil))

View File

@@ -1,52 +0,0 @@
(in-package :cl-tty.backend)
(defvar *detected-backend* nil
"Cached backend instance from detect-backend. Nil = not yet detected.")
(defun detect-backend-by-env ()
"Check COLORTERM environment variable for modern terminal support.
Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise."
(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/redirect).
Returns T if stdout is interactive, nil otherwise."
(interactive-stream-p *standard-output*))
(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 *standard-output*)
(force-output *standard-output*)
(sleep timeout)
(let ((response (make-array 0 :element-type 'character
:fill-pointer 0 :adjustable t)))
(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" (code-char 27)))))
(when response
;; DA1 response format: ESC [ ? digits ; digits c
;; Kitty reports code 62 in the response
(search "?62" response))))
(defun detect-backend ()
"Auto-detect the appropriate backend for the current terminal.
Returns a backend instance (modern-backend or simple-backend).
Result is cached in *detected-backend* for subsequent calls."
(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)))))

View File

@@ -1,116 +0,0 @@
(defpackage :cl-tty-modern-backend-test
(:use :cl :fiveam :cl-tty.backend)
(:export #:run-tests))
(in-package :cl-tty-modern-backend-test)
(def-suite modern-backend-suite :description "Modern backend tests")
(in-suite modern-backend-suite)
(defun run-tests ()
(let ((result (run 'modern-backend-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(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))))
(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))))
(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))))
(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))))
(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))))
(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[11;6H" #\Esc)))))
(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)))))
(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)))))
(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)))))
(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))))
(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))))
(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))))
(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))))
(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))))
(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) "╯")))
(test border-char-double
"modern-border-char returns double-line chars"
(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))))))

View File

@@ -1,308 +0,0 @@
(in-package :cl-tty.backend)
(defun hex-to-rgb (hex)
"Parse a hex color string like \"#FFD700\" into (values r g b).
Also handles 3-digit hex like \"#F00\" (expands to \"#FF0000\")."
(let ((clean (string-trim '(#\# #\Space) hex)))
(if (= (length clean) 3)
;; 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)))))
(defparameter *named-colors*
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
(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*.")
(defun sgr-fg (color)
"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)
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)))
((keywordp color)
(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 ""))))
(defun sgr-bg (color)
"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)
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)))
((keywordp color)
(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 ""))))
(defparameter *sgr-attr-codes*
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
(:blink . 5) (:reverse . 7) (:reset . 0)))
(defun sgr-attr (attr)
"Return SGR attribute escape for ATTR keyword."
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
(if code
(format nil "~C[~dm" #\Esc code)
"")))
(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)))
(defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape."
(let* ((base (case shape
(:block 2) (:underline 4) (:bar 6)
(t 2)))
(code (if blink (1+ base) base)))
(format nil "~C[~d q" #\Esc code)))
(defun decicm-begin ()
"Return escape to enable synchronized updates."
(format nil "~C[?2026h" #\Esc))
(defun decicm-end ()
"Return escape to disable synchronized updates."
(format nil "~C[?2026l" #\Esc))
(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))
(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) . "│")))
(defun border-char (style pos)
"Return the Unicode box-drawing character for STYLE at POS."
(let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
(or char (if (member pos '(:horizontal :vertical))
(case pos (:horizontal "─") (:vertical "│"))
"+"))))
(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)))
(defun make-modern-backend (&key color-palette output-stream)
(declare (ignore color-palette))
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
(defmethod initialize-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))
b)
(defmethod shutdown-backend ((b modern-backend))
(cursor-show b)
(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))
(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)))
(write-string string stream)
(finish-output stream)
(length string)))
(defmethod capable-p ((b modern-backend) feature)
(member feature '(:truecolor :osc8 :sync :mouse
:bracketed-paste :cursor-style
:kitty-keyboard)))
(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)
(sgr-fg fg) (sgr-bg bg)
(when bold (sgr-attr :bold))
(when italic (sgr-attr :italic))
(when underline (sgr-attr :underline))
(when reverse (sgr-attr :reverse))
(when dim (sgr-attr :dim))
(when blink (sgr-attr :blink))
string
(sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
(defmethod draw-border ((b modern-backend) x y width height
&key style fg bg title title-align)
(let* ((s (or style :single))
(tl (border-char s :top-left))
(tr (border-char s :top-right))
(bl (border-char s :bottom-left))
(br (border-char s :bottom-right))
(h (border-char s :horizontal))
(v (border-char s :vertical))
(fg-esc (sgr-fg fg))
(bg-esc (sgr-bg bg))
(reset (sgr-attr :reset))
(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 inner-width :initial-element #\Space)
v reset (string #\Newline)))
(bot (concatenate 'string
fg-esc bg-esc bl
(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)))
(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 :for row :from 0 :below height :do
(backend-write b (cursor-move-escape x (+ y row)))
(backend-write b line))))
(defmethod draw-link ((b modern-backend) x y string url
&key fg bg)
(let ((parts (list (cursor-move-escape x y)
(sgr-fg fg) (sgr-bg bg)
(osc8-link url string)
(sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
(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)))
(defmethod cursor-move ((b modern-backend) x y)
(backend-write b (cursor-move-escape x y)))
(defmethod cursor-hide ((b modern-backend))
(backend-write b (format nil "~C[?25l" #\Esc)))
(defmethod cursor-show ((b modern-backend))
(backend-write b (format nil "~C[?25h" #\Esc)))
(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)))
(defmethod end-sync ((b modern-backend))
(setf (in-sync-p b) nil)
(backend-write b (decicm-end))
(finish-output (backend-output-stream b)))

View File

@@ -1,35 +0,0 @@
(defpackage :cl-tty.backend
(:use :cl)
(:export
;; Backend classes
#: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
#:draw-link #:draw-ellipsis
;; Cursor
#:cursor-move #:cursor-hide #:cursor-show #:cursor-style
;; Sync
#:begin-sync #:end-sync
;; Input
#:read-event #:enable-mouse #:enable-bracketed-paste
;; Queries
#:capable-p
;; Constructors
#:make-simple-backend
#:with-terminal
;; 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)

View File

@@ -1,114 +0,0 @@
(in-package :cl-tty.backend)
(defclass simple-backend (backend)
((output-stream :initform *standard-output*
:initarg :output-stream
:accessor backend-output-stream)))
(defun make-simple-backend (&key output-stream)
(make-instance 'simple-backend
:output-stream (or output-stream *standard-output*)))
(defmethod initialize-backend ((b simple-backend))
b)
(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))
(defmethod backend-write ((b simple-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(finish-output stream)
(length string)))
(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))
(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 #\|)))
(defmethod draw-border ((b simple-backend) x y width height
&key style fg bg title title-align)
(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 (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 (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))))
(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))
(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))
(defmethod draw-ellipsis ((b simple-backend) x y width
&key 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 "..."))

View File

@@ -1,139 +0,0 @@
(defpackage :cl-tty-backend-test
(: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)
(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)))
(defun run-tests ()
"Run all backend tests."
(let ((result (run 'backend-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(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-false (capable-p b :truecolor) "simple backend has no truecolor")
(shutdown-backend b)))
(test simple-backend-draw-text
"simple-backend renders text at position, ignoring style"
(multiple-value-bind (b s) (make-capturing-backend)
(initialize-backend b)
(draw-text b 0 0 "hello" :red nil :bold t :italic t)
(shutdown-backend b)
(is (string= (get-output-stream-string s) "hello")
"draw-text should output the string ignoring style")))
(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 5 3 :style :single)
(shutdown-backend b)
(let ((out (get-output-stream-string s)))
(is (search "+---+" out) "top edge should have +---+\"")
(is (search "| |" out) "middle row should have pipe sides"))))
(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 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"))))
(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")))
(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")))
(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-false (capable-p b f)
(format nil "~s should not be supported on simple-backend" f)))
(shutdown-backend b)))
(test backend-size-returns-integers
"backend-size returns two integer values"
(let ((b (make-simple-backend)))
(initialize-backend b)
(multiple-value-bind (cols lines) (backend-size b)
(is (integerp cols))
(is (integerp lines))
(is (>= cols 10))
(is (>= lines 3)))
(shutdown-backend b)))
(test default-methods-are-no-ops
"Default backend methods don't error"
(let ((b (make-simple-backend)))
(initialize-backend b)
(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))))
(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
"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 (string= (get-output-stream-string s) "in sync")
"no sync escape sequences should appear")))
(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")))
(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))))
(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*)))))

View File

@@ -1,162 +0,0 @@
(defpackage :cl-tty-box-test
(: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)
(defun run-tests ()
(let ((result (run 'box-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(defun make-capturing-backend ()
(let* ((s (make-string-output-stream))
(b (make-modern-backend :output-stream s)))
(values b s)))
(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))))
(test box-renders-border
"A box with border draws border characters"
(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-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "top-left corner")
(is (search "┐" out) "top-right corner")
(is (search "└" out) "bottom-left corner")
(is (search "┘" out) "bottom-right corner")))))
(test box-renders-background
"A box with background color fills interior"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "border with background")
(is (search "41m" out) "SGR background for red")))))
(test box-renders-title
"A box with title renders the title text"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :title "Hello" :width 12 :height 3)))
(compute-layout (box-layout-node bx) 12 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "title text should appear")))))
(test box-without-border
"A box with border-style nil draws no border"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style nil :bg :red :width 5 :height 3)))
(compute-layout (box-layout-node bx) 5 3)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "41m" out) "background still renders")
(is-false (search "┌" out) "no top-left corner")))))
(test box-zero-size
"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"))))
(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"))))
(test box-minimum-size
"A box with minimum non-zero size still renders"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 2 :height 2)))
(compute-layout (box-layout-node bx) 2 2)
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "2x2 box still has borders")))))
(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))))
(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")))))
(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"))))
(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")))))
(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")))))
(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")))))
(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))))
(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)))))

View File

@@ -1,54 +0,0 @@
(in-package :cl-tty.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
: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)))
(defun make-box (&key (border-style :single) title
(title-align :left) fg bg
width height)
(make-instance 'box
:border-style border-style
:title title
:title-align title-align
:fg fg
:bg bg
:layout-node (make-layout-node
:width width
:height height
:direction :column)))
(defun render-box (box backend)
"Render BOX at its computed layout position using BACKEND."
(let ((ln (box-layout-node box))
(bs (box-border-style box))
(title (box-title box))
(fg (box-fg box))
(bg (box-bg box)))
(let ((x (layout-node-x ln))
(y (layout-node-y ln))
(w (layout-node-width ln))
(h (layout-node-height ln)))
(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))
(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))))))))

View File

@@ -1,16 +0,0 @@
(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))

View File

@@ -1,25 +0,0 @@
;;; dialog-package.lisp — Package definition for cl-tty.dialog
(defpackage :cl-tty.dialog
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select)
(:export
#:dialog
#:dialog-title
#:dialog-content
#:dialog-on-dismiss
#:dialog-size
#:dialog-size-pixels
#:render-dialog
#:push-dialog
#:pop-dialog
#:*dialog-stack*
#:alert-dialog
#:confirm-dialog
#:select-dialog
#:prompt-dialog
#:toast
#:toast-message
#:toast-variant
#:render-toast
#:dismiss-toast
#:*toasts*))

View File

@@ -1,116 +0,0 @@
(in-package :cl-tty.dialog)
(defvar *dialog-stack* nil
"Stack of active dialogs. (list) of dialog instances.")
(defvar *toasts* nil
"List of active toast notifications.")
(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 &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) 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 :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)))))
(defun push-dialog (dialog)
(push dialog *dialog-stack*)
dialog)
(defun pop-dialog ()
(when *dialog-stack*
(let ((dialog (pop *dialog-stack*)))
(when (dialog-on-dismiss dialog)
(funcall (dialog-on-dismiss dialog)))
dialog)))
(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))))
(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)))))))
(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))))))
(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))))))
(defclass toast ()
((message :initarg :message :accessor toast-message)
(variant :initarg :variant :initform :info :accessor toast-variant)))
(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)
(draw-text screen (1+ x) 0 text :white color :bold t)))
(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))
(defun dismiss-toast (toast)
(setf *toasts* (remove toast *toasts*)))

View File

@@ -1,26 +0,0 @@
(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")))
(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)))
(mark-clean c)
(mark-dirty c)
(is-true (dirty-p c) "after mark-dirty, should be dirty again")))

View File

@@ -1,14 +0,0 @@
(in-package :cl-tty.box)
;; ── Dirty Tracking ─────────────────────────────────────────────
(defclass dirty-mixin ()
((dirty :initform t :accessor dirty-p)))
(defgeneric mark-clean (component)
(:method ((c dirty-mixin))
(setf (dirty-p c) nil)))
(defgeneric mark-dirty (component)
(:method ((c dirty-mixin))
(setf (dirty-p c) t)))

View File

@@ -1,38 +0,0 @@
(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))

View File

@@ -1,250 +0,0 @@
(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))))
(defvar *current-backend* nil
"The active backend used for rendering.")
(defvar *current-theme* nil
"The active theme used for semantic color resolution.")
(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)))
(defstruct mouse-event
(type nil :type (or keyword null))
(button nil :type (or keyword null))
(x 0 :type fixnum)
(y 0 :type fixnum))
(defparameter *csi-tilde-table*
'((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)))
(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))))
(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))))))
(defun %read-digits (&optional (initial-bytes nil))
"Read bytes until a non-digit is encountered.
Returns (values number terminator-byte)."
(let ((acc nil))
(dolist (b initial-bytes)
(when (and (>= b 48) (<= b 57))
(push (- b 48) acc)))
(loop for b = (read-raw-byte)
while (and (>= b 48) (<= b 57))
do (push (- b 48) acc)
finally (return (values (if acc
(reduce (lambda (n d) (+ (* n 10) d))
(reverse acc))
0)
b)))))
(defun %parse-sgr-mouse ()
"Parse SGR mouse escape sequence: ESC [ < Cb ; Cx ; Cy M/m
Returns a mouse-event struct."
(let ((b (read-raw-byte)))
(multiple-value-bind (cb sep1) (%read-digits (list b))
(declare (ignore sep1))
(multiple-value-bind (cx sep2) (%read-digits)
(declare (ignore sep2))
(multiple-value-bind (cy term) (%read-digits)
(let ((button (cond
((= cb 0) :left)
((= cb 1) :middle)
((= cb 2) :right)
((= cb 64) :scroll-up)
((= cb 65) :scroll-down)
((>= cb 32) :drag)
(t :left)))
(type (cond
((= term 77) :press)
((= term 109) :release)
(t :press))))
(make-mouse-event :type type :button button
:x (- cx 1) :y (- cy 1))))))))
(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* ((b2 (read-raw-byte)))
(if (= b2 60) ;; < — SGR mouse marker
(%parse-sgr-mouse)
(let* ((extended (make-array 8 :element-type 'fixnum :fill-pointer 0))
(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)))
(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)))))))
(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))))
(defun %raw-mode-on ()
(uiop:run-program '("stty" "raw" "-echo" "-echoe" "-echok" "-onlcr") :output nil :error-output nil))
(defun %raw-mode-off ()
(uiop:run-program '("stty" "sane") :output nil :error-output nil))
(defmacro with-raw-terminal (&body body)
"Execute BODY with the terminal in raw mode."
`(unwind-protect
(progn (%raw-mode-on) ,@body)
(%raw-mode-off)))
(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)))

View File

@@ -1,63 +0,0 @@
(in-package #:cl-tty.input)
(defstruct keymap
(name nil :type (or keyword null))
(bindings nil :type list)
(parent nil :type (or keymap null)))
(defparameter *keymaps* (make-hash-table :test #'equal))
(defparameter *chord-timeout* 0.5)
(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)))))
(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)))))
(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))

View File

@@ -1,9 +0,0 @@
(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))

View File

@@ -1,672 +0,0 @@
;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty
(in-package :cl-tty.markdown)
(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 content (setf (getf node :content) content))
(when url (setf (getf node :url) url))
node))
(defun md-node-p (thing)
(and (listp thing) (getf thing :type)))
(defun md-node-text (node)
(let ((type (getf node :type)))
(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 ""))))
(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))))
(defun classify-line (line)
(cond
((string= line "") (cons :blank nil))
((and (>= (length line) 3)
(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))
((and (char= (char line 0) #\#)
(let ((count 0))
(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))))
(cons :heading (cons hash-count content))))
((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))))
((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))))
((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))
((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))))
((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))))
(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))))
(defun parse-paragraph (lines 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))
(:blank (incf i) (loop-finish))
(t (loop-finish)))))
(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)))
(defun parse-blockquote (lines 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))
(:blank (incf i) (loop-finish))
(t (loop-finish)))))
(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)))
(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)
((:list-item :ordered-item)
(push (cons (car class) (cdr class)) items) (incf i))
(:blank
(if (and (< (1+ i) (length lines))
(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)))))
(let ((nodes nil))
(dolist (item (nreverse items))
(let ((type (car item)) (content (cdr item)))
(when (and content (not (string= content "")))
(push (make-md-node type :children (parse-inline content)) nodes))))
(values (nreverse nodes) i))))
(defun parse-code-block (lines start lang)
(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)))
(loop while (< i (length lines))
do (let* ((raw-line (aref lines i))
(line (string-trim (list #\return) raw-line)))
(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))))
(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)))
(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))))
(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)))
(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)))
(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)))))
(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)))))
(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)))))
(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)))))
(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=)))
(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)))
(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))))
(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)))
(defun apply-highlight-style (char-vector)
(coerce char-vector 'string))
(defun string-prefix-p (prefix string)
(and (>= (length string) (length prefix))
(string= prefix (subseq string 0 (length prefix)))))
(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)))
(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)))
(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))))))))
(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)))))
(defun render-paragraph (node)
(list (render-inline (getf node :children))))
(defun render-blockquote (node)
(list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children))))))
(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)))
(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)))
(defun render-thematic-break (node)
(declare (ignore node))
(list (apply-style :dim "──────────────────────────────────────────────")))
(defun render-list-item (node)
(list (concatenate 'string
(if (eql (getf node :type) :ordered-item) " 1." " * ")
(render-inline (getf node :children)))))
(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 "")))))
(defun render-md (nodes)
(let ((lines nil))
(dolist (node nodes) (setf lines (nconc lines (render-md-node node))))
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)
(loop for part in (nreverse parts)
for first = t then nil
do (unless first (terpri s)) (princ part s)))))

View File

@@ -1,12 +0,0 @@
(defpackage :cl-tty.mouse
(: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
#:handle-mouse-event
#:hit-test
#:selection #:get-selection #:copy-to-clipboard
#:make-selection #:selection-p
#:start-selection #:update-selection #:finalize-selection
#:selection-active-p
#:cell-link-at #:open-link-at))

View File

@@ -1,108 +0,0 @@
(in-package :cl-tty.mouse)
(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)))
(defun handle-mouse-event (component event)
(let* ((type (mouse-event-type event))
(handler (case type
(:press (on-mouse-down component))
(:release (on-mouse-up component))
(:drag (on-mouse-move component))
(t nil))))
(when handler (funcall handler event))))
(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.
Components without a layout-node or position return nil."
(labels ((recurse (node)
(let ((ln (ignore-errors (component-layout-node node)))
(best nil))
(when ln
(let ((nx (layout-node-x ln))
(ny (layout-node-y ln))
(nw (layout-node-width ln))
(nh (layout-node-height ln)))
;; Check children first for deeper match
(dolist (child (ignore-errors (component-children node)))
(let ((child-hit (recurse child)))
(when child-hit
(setf best child-hit))))
;; If no child matched, check self
(or best
(when (and (>= x nx) (< x (+ nx nw))
(>= y ny) (< y (+ ny nh)))
node)))))))
(recurse root)))
(defvar *selection* nil)
(defstruct (selection (:conc-name sel-))
(start-x 0) (start-y 0) (end-x 0) (end-y 0) (text ""))
(defun get-selection ()
(when *selection* (sel-text *selection*)))
(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))
(defvar *selection-active* nil
"T when a drag selection is in progress.")
(defvar *selection-start* nil
"Cons (X . Y) of mouse-down position during drag.")
(defvar *selection-end* nil
"Cons (X . Y) of current mouse position during drag.")
(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))
(defun update-selection (x y)
"Update the drag selection end position to (X Y)."
(setf *selection-end* (cons x y)))
(defun selection-active-p ()
"Return T if a drag selection is in progress."
*selection-active*)
(defun finalize-selection (fb)
"End the drag selection and extract text from the framebuffer."
(setf *selection-active* nil)
(when (and *selection-start* *selection-end* fb)
(let* ((x1 (car *selection-start*))
(y1 (cdr *selection-start*))
(x2 (car *selection-end*))
(y2 (cdr *selection-end*))
(text (cl-tty.rendering:extract-text fb x1 y1 x2 y2)))
(setf *selection* (make-selection :start-x x1 :start-y y1
:end-x x2 :end-y y2
:text text))
(setf *selection-start* nil *selection-end* nil)
text)))
(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))
(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)))
(when url
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
url))

View File

@@ -1,37 +0,0 @@
(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
;; 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))
(in-package :cl-tty.box)

View File

@@ -1,48 +0,0 @@
(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)))
(test render-generic-dispatches-box
"render dispatches to render-box for box instances"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((bx (make-box :border-style :single :width 10 :height 5)))
(compute-layout (box-layout-node bx) 10 5)
(render bx b)
(is (search "┌" (get-output-stream-string s)) "box renders border"))))
(test render-generic-dispatches-text
"render dispatches to render-text for text instances"
(multiple-value-bind (b s) (make-capturing-backend)
(let ((tx (make-text "Hello" :width 10 :height 1)))
(compute-layout (text-layout-node tx) 10 1)
(render tx b)
(is (search "Hello" (get-output-stream-string s)) "text renders content"))))
(test component-layout-node-works
"component-layout-node returns the right slot for each type"
(let ((bx (make-box)) (tx (make-text "")))
(is (typep (component-layout-node bx) 'layout-node))
(is (typep (component-layout-node tx) 'layout-node))))
(test component-children-returns-nil
"Leaf components have no children"
(let ((bx (make-box)) (tx (make-text "")))
(is (null (component-children bx)))
(is (null (component-children tx)))))
(test propagate-dirty-marks-component
"propagate-dirty marks the component dirty"
(let ((c (make-box)))
(mark-clean c)
(is-false (dirty-p c) "should be clean after mark-clean")
(propagate-dirty c)
(is-true (dirty-p c) "should be dirty after propagate-dirty")))
(test available-width-defaults
"available-width returns 0 for components without explicit width"
(let ((c (make-box)))
(is (= (available-width c) 0))))

View File

@@ -1,72 +0,0 @@
(in-package :cl-tty.box)
;; ── Component Protocol ────────────────────────────────────────
(defgeneric component-layout-node (component)
(: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.")
(:method ((c t)) nil))
(defgeneric component-parent (component)
(:documentation "Return the parent of COMPONENT, or nil.")
(:method ((c t)) nil))
;; ── Rendering Pipeline ────────────────────────────────────────
(defgeneric render (component backend)
(:documentation "Render COMPONENT at its computed position using BACKEND.")
(:method ((c t) backend)
(declare (ignore backend))
(values)))
(defmethod render ((bx box) backend)
(render-box bx backend))
(defmethod render ((tx text) backend)
(render-text tx backend))
(defun render-screen (root backend)
"Render the component tree ROOT using BACKEND.
Computes layout 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)))
(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)))
(defun available-width (component)
"Return the available width for COMPONENT (or 80 as default)."
(let ((ln (component-layout-node component)))
(if ln (layout-node-width ln) 80)))
(defun available-height (component)
"Return the available height for COMPONENT (or 24 as default)."
(let ((ln (component-layout-node component)))
(if ln (layout-node-height ln) 24)))
;; ── Dirty Propagation ─────────────────────────────────────────
(defun propagate-dirty (component)
"Mark COMPONENT and all ancestors dirty."
(mark-dirty component)
(let ((parent (component-parent component)))
(when parent
(propagate-dirty parent))))

View File

@@ -1,133 +0,0 @@
(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)
"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))
(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))
(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)))
(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)))))))
(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)))))

View File

@@ -1,13 +0,0 @@
(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))

View File

@@ -1,146 +0,0 @@
(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)
"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)))))
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)
"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)
"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)
"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)))))
(defun select-prev (sel)
"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)))))
(defun select-handle-key (sel 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)
((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)
"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)))
(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))
(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
(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)))

View File

@@ -1,9 +0,0 @@
(defpackage :cl-tty.slot
(:use :cl)
(:export
#:defslot
#:slot-render
#:slot-p
#:clear-slot
#:list-slots
#:*slots*))

View File

@@ -1,59 +0,0 @@
(in-package :cl-tty.slot)
(defvar *slots* (make-hash-table :test 'equal)
"Hash table mapping slot name (string) -> plist of slot data.
Each entry: (:mode <mode> :entries <(order . render-fn) list>).")
(defun defslot (name &key (order 0) render-fn (mode :stack))
(let* ((key (string name))
(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 ((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*)))
(defun clear-slot (slot-name)
(remhash (string slot-name) *slots*))
(defun list-slots ()
(loop for key being the hash-keys of *slots* collect key))

View File

@@ -1,82 +0,0 @@
(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)
(defmethod component-layout-node ((tb tab-bar))
(tab-bar-layout-node tb))
(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))
(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)))
(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)))

View File

@@ -1,110 +0,0 @@
(in-package #:cl-tty.input)
(defclass text-input (dirty-mixin)
((value :initform "" :initarg :value :accessor text-input-value
:type string)
(cursor :initform 0 :initarg :cursor :accessor text-input-cursor
:type fixnum)
(placeholder :initform "" :initarg :placeholder
:accessor text-input-placeholder :type string)
(max-length :initform nil :initarg :max-length
:accessor text-input-max-length)
(on-submit :initform nil :initarg :on-submit
:accessor text-input-on-submit)
(layout-node :initform (make-layout-node) :accessor text-input-layout-node)
(focusable :initform t :accessor text-input-focusable)))
(defun make-text-input (&key value cursor placeholder max-length on-submit)
(make-instance 'text-input
:value (or value "")
:cursor (or cursor 0)
:placeholder (or placeholder "")
:max-length max-length
:on-submit on-submit))
(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)))
(defun text-input-backspace (input)
(let* ((val (text-input-value input)) (pos (text-input-cursor input)))
(when (zerop pos) (return-from text-input-backspace))
(setf (text-input-value input) (concatenate 'string (subseq val 0 (1- pos)) (subseq val pos)))
(decf (text-input-cursor input))
(mark-dirty input)))
(defun text-input-delete (input)
(let* ((val (text-input-value input)) (pos (text-input-cursor input)))
(when (>= pos (length val)) (return-from text-input-delete))
(setf (text-input-value input) (concatenate 'string (subseq val 0 pos) (subseq val (1+ pos))))
(mark-dirty input)))
(defun text-input-move-left (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)))
(mark-dirty input))
(defun text-input-move-home (input)
(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)))
(mark-dirty input))
(defun text-input-delete-word-before (input)
(let* ((val (text-input-value input)) (pos (text-input-cursor input)))
(when (zerop pos) (return-from text-input-delete-word-before))
(let* ((start (or (position-if (lambda (c) (not (char= c #\Space))) val :end pos :from-end t) 0))
(word-start (or (and (plusp start) (position #\Space val :end start :from-end t)) 0))
(delete-start (if (and (zerop word-start) (or (char/= (char val 0) #\Space) (zerop start)))
0
(if (zerop start) (1+ word-start) (1+ (or (position #\Space val :end start :from-end t) 0))))))
(setf (text-input-value input) (concatenate 'string (subseq val 0 delete-start) (subseq val pos)))
(setf (text-input-cursor input) delete-start)
(mark-dirty input))))
(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))))))))
(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)))))

View File

@@ -1,105 +0,0 @@
(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)))
(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))
(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)))
(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)))
(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)))))))
(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 "")))))
(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))))

View File

@@ -1,234 +0,0 @@
(in-package #:cl-tty.input)
(defclass textarea (dirty-mixin)
((value :initform "" :initarg :value :accessor textarea-value :type string)
(cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum)
(cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum)
(selection-start :initform nil :accessor textarea-selection-start)
(undo-stack :initform (make-array 100 :fill-pointer 0)
:accessor textarea-undo-stack)
(redo-stack :initform (make-array 100 :fill-pointer 0)
:accessor textarea-redo-stack)
(on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit)
(layout-node :initform (make-layout-node) :accessor textarea-layout-node)
(focusable :initform t :accessor textarea-focusable)))
(defun make-textarea (&key value on-submit)
(make-instance 'textarea
:value (or value "")
:on-submit on-submit))
(defun textarea-lines (ta)
"Split value into lines."
(%split-string (textarea-value ta) #\Newline))
(defun textarea-line-count (ta)
"Number of lines in value."
(length (textarea-lines ta)))
(defun textarea-ensure-cursor (ta)
"Clamp cursor to valid range."
(let ((lines (textarea-lines ta)))
(setf (textarea-cursor-row ta)
(max 0 (min (textarea-cursor-row ta) (1- (length lines)))))
(let ((line-len (length (nth (textarea-cursor-row ta) lines))))
(setf (textarea-cursor-col ta)
(max 0 (min (textarea-cursor-col ta) line-len)))))
(mark-dirty ta))
(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))))
(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))))))
(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))
(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)))))
(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))))))))
(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))))

View File

@@ -1,61 +0,0 @@
(in-package :cl-tty-box-test)
(in-suite box-suite)
(test theme-create-default
"A theme can be created with default mode"
(let ((th (make-theme)))
(is (typep th 'theme))
(is (eql (theme-mode th) :dark))))
(test theme-create-light
"A theme can be created in light mode"
(let ((th (make-theme :mode :light)))
(is (eql (theme-mode th) :light))))
(test theme-color-set-and-get
"theme-color setf/get works"
(let ((th (make-theme)))
(setf (theme-color th :primary) "#FFD700")
(is (string= (theme-color th :primary) "#FFD700"))))
(test theme-color-unknown-returns-nil
"Unknown roles return nil"
(let ((th (make-theme)))
(is (null (theme-color th :nonexistent)))))
(test load-default-dark-preset
"Loading the default dark preset populates roles"
(let ((th (make-theme :mode :dark)))
(load-preset th :default)
(is (string= (theme-color th :primary) "#FFD700"))
(is (string= (theme-color th :background) "#1A1A2E"))
(is (string= (theme-color th :error) "#FF4444"))))
(test load-default-light-preset
"Light variant has different colors"
(let ((th (make-theme :mode :light)))
(load-preset th :default)
(is (string= (theme-color th :primary) "#B8860B"))
(is (string= (theme-color th :background) "#F8F9FA"))))
(test load-nord-preset
"Nord preset has different colors than default"
(let ((th (make-theme :mode :dark)))
(load-preset th :nord)
(is (string= (theme-color th :primary) "#88C0D0"))
(is (string= (theme-color th :background) "#2E3440"))))
(test load-preset-unknown-warns
"Unknown preset warns but doesn't error"
(let ((th (make-theme)))
(signals warning (load-preset th :nonexistent))
(is (null (theme-color th :primary)))))
(test preset-switch-mode
"Switching mode and reloading changes colors"
(let ((th (make-theme :mode :dark)))
(load-preset th :default)
(is (string= (theme-color th :background) "#1A1A2E"))
(setf (theme-mode th) :light)
(load-preset th :default)
(is (string= (theme-color th :background) "#F8F9FA"))))

View File

@@ -1,89 +0,0 @@
(in-package :cl-tty.box)
(defclass theme ()
((mode :initform :dark :initarg :mode :accessor theme-mode)
(roles :initform (make-hash-table) :accessor theme-roles)))
(defun make-theme (&key (mode :dark))
(make-instance 'theme :mode mode))
(defun theme-color (theme role)
"Resolve a semantic ROLE to a hex color string in THEME."
(gethash role (theme-roles theme)))
(defun (setf theme-color) (hex theme role)
"Set the hex color for a semantic ROLE in THEME."
(setf (gethash role (theme-roles theme)) hex))
(defparameter *presets* (make-hash-table :test #'eq))
(defmacro define-preset (name &key dark light)
"Define a theme preset with DARK and LIGHT variants.
NAME should be a keyword (e.g., :default, :nord)."
(check-type name keyword)
`(setf (gethash ,name *presets*) '(:dark ,dark :light ,light)))
(defun load-preset (theme preset-name)
"Load PRESET-NAME 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))))
(define-preset :default
:dark (:primary "#FFD700" :secondary "#B8860B" :accent "#FFA500"
:error "#FF4444" :warning "#FF8800" :success "#44BB44" :info "#4488FF"
:text "#FFFFFF" :text-muted "#888888"
:background "#1A1A2E" :background-panel "#16213E" :background-element "#0F3460"
:border "#334155" :border-active "#FFD700"
:diff-added "#164B16" :diff-removed "#4B1616" :diff-context "#1A1A2E"
:markdown-heading "#FFD700" :markdown-code "#334155"
:markdown-link "#4488FF" :markdown-quote "#888888"
:syntax-keyword "#FF79C6" :syntax-function "#50FA7B"
:syntax-string "#F1FA8C" :syntax-number "#BD93F9"
:syntax-comment "#6272A4" :syntax-type "#8BE9FD")
:light (:primary "#B8860B" :secondary "#8B6914" :accent "#FF8C00"
:error "#CC0000" :warning "#CC6600" :success "#228B22" :info "#0055CC"
:text "#1A1A2E" :text-muted "#888888"
:background "#F8F9FA" :background-panel "#FFFFFF" :background-element "#E9ECEF"
:border "#DEE2E6" :border-active "#B8860B"
:diff-added "#DFD" :diff-removed "#FDD" :diff-context "#F8F9FA"
:markdown-heading "#B8860B" :markdown-code "#E9ECEF"
:markdown-link "#0055CC" :markdown-quote "#888888"
:syntax-keyword "#D63384" :syntax-function "#198754"
:syntax-string "#FFC107" :syntax-number "#6F42C1"
:syntax-comment "#6C757D" :syntax-type "#0DCAF0"))
(define-preset :nord
:dark (:primary "#88C0D0" :secondary "#81A1C1" :accent "#5E81AC"
:error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD"
:text "#ECEFF4" :text-muted "#616E88"
:background "#2E3440" :background-panel "#3B4252" :background-element "#434C5E"
:border "#4C566A" :border-active "#88C0D0"
:diff-added "#164B16" :diff-removed "#4B1616" :diff-context "#2E3440"
:markdown-heading "#88C0D0" :markdown-code "#3B4252"
:markdown-link "#81A1C1" :markdown-quote "#616E88"
:syntax-keyword "#81A1C1" :syntax-function "#A3BE8C"
:syntax-string "#EBCB8B" :syntax-number "#B48EAD"
:syntax-comment "#616E88" :syntax-type "#88C0D0")
:light (:primary "#5E81AC" :secondary "#81A1C1" :accent "#88C0D0"
:error "#BF616A" :warning "#D08770" :success "#A3BE8C" :info "#B48EAD"
:text "#2E3440" :text-muted "#8F9BB3"
:background "#ECEFF4" :background-panel "#FFFFFF" :background-element "#E5E9F0"
:border "#D8DEE9" :border-active "#5E81AC"
:diff-added "#DFD" :diff-removed "#FDD" :diff-context "#ECEFF4"
:markdown-heading "#5E81AC" :markdown-code "#E5E9F0"
:markdown-link "#81A1C1" :markdown-quote "#8F9BB3"
:syntax-keyword "#81A1C1" :syntax-function "#A3BE8C"
:syntax-string "#D08770" :syntax-number "#B48EAD"
:syntax-comment "#8F9BB3" :syntax-type "#88C0D0"))

View File

@@ -1,181 +0,0 @@
(defpackage :cl-tty.layout
(:use :cl)
(:export
#:layout-node #:make-layout-node
#:layout-node-add-child #:layout-node-remove-child
#:layout-node-children
#:layout-node-x #:layout-node-y
#:layout-node-width #:layout-node-height
#:layout-node-direction
#:compute-layout
#: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)
(defun normalize-box (spec)
(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)
for (key val) on spec by #'cddr
do (setf (getf result key) val)
finally (return result)))))
(defun box-edge (box edge)
(or (getf box edge) 0))
(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)))
(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))
(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)
(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)
(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)))
(defun compute-layout (root available-width available-height)
(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) (+ 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)))
(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))
(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)))
(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)))
(defmacro spacer (&key grow)
`(make-layout-node :grow ,(or grow 1)))

View File

@@ -1,167 +0,0 @@
(defpackage :cl-tty-layout-test
(:use :cl :fiveam :cl-tty.layout)
(:export #:run-tests))
(in-package :cl-tty-layout-test)
(def-suite layout-suite :description "Layout engine tests")
(in-suite layout-suite)
(defun run-tests ()
(let ((result (run 'layout-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(test make-layout-node-defaults
(let ((n (make-layout-node)))
(is (typep n 'layout-node))
(is (eql (layout-node-direction n) :column))))
(test make-layout-node-row
(let ((n (make-layout-node :direction :row)))
(is (eql (layout-node-direction n) :row))))
(test add-child-sets-parent
(let ((parent (make-layout-node)) (child (make-layout-node)))
(layout-node-add-child parent child)
(is (eql (layout-node-parent child) parent))
(is (= (length (layout-node-children parent)) 1))))
(test remove-child-clears-parent
(let ((parent (make-layout-node)) (child (make-layout-node)))
(layout-node-add-child parent child)
(layout-node-remove-child parent child)
(is (null (layout-node-parent child)))
(is (= (length (layout-node-children parent)) 0))))
(test column-two-children-vertical
(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)
(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))))
(test row-two-children-horizontal
(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)
(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))))
(test flex-grow-distributes-space
(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)
(compute-layout root 20 10)
(is (= (layout-node-width c1) 8)) (is (= (layout-node-width c2) 12))))
(test 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)
(compute-layout root 20 10)
(is (= (layout-node-width c) 20))))
(test flex-shrink-reduces-overflow
(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)
(compute-layout root 10 10)
(is (= (layout-node-width c1) 5)) (is (= (layout-node-width c2) 5))))
(test padding-reduces-content-area
(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))
(is (= (layout-node-height c) 3))))
(test gap-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)
(compute-layout root 20 20)
(is (= (layout-node-y c1) 0)) (is (= (layout-node-y c2) 5))))
(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))))
(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))))
(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)))))
(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)))))
(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)))))
(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))))
(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)))))
(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))))
(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))))
(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)))))

View File

@@ -1,203 +0,0 @@
(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 #:fb-framebuffer
#:framebuffer-width #:framebuffer-height
#:diff-framebuffers #:flush-framebuffer
#:with-scissor
#:extract-text #:fb-cell-link-url))
(in-package :cl-tty.rendering)
(defstruct cell
"A single terminal cell — character, colors, and attributes."
(char #\space :type character)
(fg nil)
(bg nil)
(bold nil :type boolean)
(italic nil :type boolean)
(underline nil :type boolean)
(link-url nil))
(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))
(defun framebuffer-width (fb)
"Return the width (columns) of framebuffer FB."
(if (arrayp fb) (array-dimension fb 1) 0))
(defun framebuffer-height (fb)
"Return the height (rows) of framebuffer FB."
(if (arrayp fb) (array-dimension fb 0) 0))
(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-backend (&key (width 80) (height 24))
"Create a framebuffer-backend with a fresh framebuffer."
(let ((fb (make-instance 'framebuffer-backend)))
(setf (fb-framebuffer fb) (make-framebuffer width height))
fb))
(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)))))))
(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)))
(when (and (>= y 0) (< y (framebuffer-height cells))
(>= x 0) (< x (framebuffer-width cells))
(%in-scissor-p fb x y))
(setf (aref cells y x)
(make-cell :char char :fg fg :bg bg
:bold bold :italic italic :underline underline
:link-url link-url)))))
(defmethod draw-text ((fb framebuffer-backend) x y string fg bg
&key bold italic underline reverse dim blink
(link-url nil link-url-p)
&allow-other-keys)
(declare (ignore reverse dim blink link-url-p))
(loop for i from 0 below (length string)
do (%set-cell fb (+ x i) y (char string i)
:fg fg :bg bg
:bold bold :italic italic :underline underline
:link-url link-url)))
(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))))
(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg)
(let* ((chars (case style
(:single '(#\+ #\- #\|))
(:double '(#\+ #\= #\|))
(:rounded '(#\. #\- #\|))
(t '(#\+ #\- #\|))))
(tc (first chars)) (hc (second chars)) (vc (third chars)))
;; Top edge
(%set-cell fb x y tc :fg fg :bg bg)
(loop for i from 1 below (1- w) do (%set-cell fb (+ x i) y hc :fg fg :bg bg))
(%set-cell fb (1- (+ x w)) y tc :fg fg :bg bg)
;; Sides
(dotimes (row (- h 2))
(%set-cell fb x (+ y row 1) vc :fg fg :bg bg)
(%set-cell fb (1- (+ x w)) (+ y row 1) vc :fg fg :bg bg))
;; Bottom edge
(%set-cell fb x (+ y h -1) tc :fg fg :bg bg)
(loop for i from 1 below (1- w) do (%set-cell fb (+ x i) (+ y h -1) hc :fg fg :bg bg))
(%set-cell fb (1- (+ x w)) (+ y h -1) tc :fg fg :bg bg)
;; Title
(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)))))
(defmethod backend-clear ((fb framebuffer-backend))
(let ((cells (fb-framebuffer fb)))
(dotimes (y (framebuffer-height cells))
(dotimes (x (framebuffer-width cells))
(setf (aref cells y x) (make-cell))))))
(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))
(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)))
(defun cells-equal-p (a b)
"Return T if two cells have identical content and style."
(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))))
(defun diff-framebuffers (prev curr)
"Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes."
(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 (cells-equal-p a b)
(push (list x y b) changes)))))
(nreverse changes)))
(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."
(let* ((changes (diff-framebuffers prev-fb curr-fb))
(count (length changes))
(current-row -1))
(when (plusp count)
(begin-sync backend)
(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))))
(end-sync backend))
count))
(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))))
(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)))
(y-min (max 0 (min y1 y2))) (y-max (max 0 (max y1 y2)))
(h (if (arrayp fb) (array-dimension fb 0) 0))
(w (if (arrayp fb) (array-dimension fb 1) 0)))
(with-output-to-string (s)
(loop for y from y-min to (min y-max (1- h))
do (loop for x from x-min to (min x-max (1- w))
do (let ((c (aref fb y x)))
(princ (cell-char c) s)))
(when (< y y-max) (princ #\Newline s))))))
(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))
(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)))))

View File

@@ -1,43 +0,0 @@
;;; dialog-tests.lisp — Tests for cl-tty.dialog
(defpackage :cl-tty-dialog-test
(:use :cl :cl-tty.dialog :fiveam))
(in-package :cl-tty-dialog-test)
(def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog")
(in-suite dialog-suite)
(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*)))))

View File

@@ -1,110 +0,0 @@
(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)
(test make-framebuffer-creates-correct-size
(let ((fb (make-framebuffer 80 24)))
(is (= 24 (framebuffer-height fb)))
(is (= 80 (framebuffer-width fb)))))
(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)))))
(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)))))))
(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"))))
(test diff-identical-fbs-returns-empty
(let ((fb1 (make-framebuffer 80 24))
(fb2 (make-framebuffer 80 24)))
(is (null (diff-framebuffers fb1 fb2)))))
(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)))))))
(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"))))
(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)))
(draw-text fb 0 0 "X" :red nil)
(let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be)))
(is (>= changed 1)))))
(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)))))
(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)))))
(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)))))
(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))))))
(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)))))

View File

@@ -1,409 +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))))
;; ── UTF-8 Decode Tests ──────────────────────────────────────────
(test utf8-decode-latin1-supplement
"0xC3 0xA9 (é) decodes to code point 233."
(is (= (cl-tty.input:utf8-decode '(#xc3 #xa9)) 233)))
(test utf8-decode-euro-sign
"0xE2 0x82 0xAC (€) decodes to code point 8364."
(is (= (cl-tty.input:utf8-decode '(#xe2 #x82 #xac)) 8364)))
(test utf8-decode-emoji
"0xF0 0x9F 0x92 0xA9 (💩) decodes to code point 128169."
(is (= (cl-tty.input:utf8-decode '(#xf0 #x9f #x92 #xa9)) 128169)))
(test utf8-decode-invalid-short
"Invalid byte 0x80 alone returns nil."
(is-false (cl-tty.input:utf8-decode '(#x80))))
(test utf8-decode-invalid-overlong
"Overlong 2-byte sequence 0xC0 0x80 returns nil."
(is-false (cl-tty.input:utf8-decode '(#xc0 #x80))))
;; ── TextInput Tests ─────────────────────────────────────────────
(test text-input-empty
"A newly created text-input has empty value and cursor at 0."
(let ((in (make-text-input)))
(is (string= (text-input-value in) ""))
(is (= (text-input-cursor in) 0))))
(test text-input-insert-char
"Inserting a character appends and moves cursor."
(let ((in (make-text-input)))
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
(is (string= (text-input-value in) "a"))
(is (= (text-input-cursor in) 1))))
(test text-input-insert-multiple
"Inserting multiple characters works left to right."
(let ((in (make-text-input)))
(handle-text-input in (make-key-event :key :h :code (char-code #\h)))
(handle-text-input in (make-key-event :key :e :code (char-code #\e)))
(handle-text-input in (make-key-event :key :l :code (char-code #\l)))
(handle-text-input in (make-key-event :key :l :code (char-code #\l)))
(handle-text-input in (make-key-event :key :o :code (char-code #\o)))
(is (string= (text-input-value in) "hello"))
(is (= (text-input-cursor in) 5))))
(test text-input-backspace
"Backspace removes the character before the cursor."
(let ((in (make-text-input :value "ab" :cursor 2)))
(handle-text-input in (make-key-event :key :backspace))
(is (string= (text-input-value in) "a"))
(is (= (text-input-cursor in) 1))))
(test text-input-backspace-at-start
"Backspace at position 0 does nothing."
(let ((in (make-text-input :value "ab" :cursor 0)))
(handle-text-input in (make-key-event :key :backspace))
(is (string= (text-input-value in) "ab"))
(is (= (text-input-cursor in) 0))))
(test text-input-delete
"Delete removes the character at the cursor."
(let ((in (make-text-input :value "abc" :cursor 1)))
(handle-text-input in (make-key-event :key :delete))
(is (string= (text-input-value in) "ac"))
(is (= (text-input-cursor in) 1))))
(test text-input-cursor-left-right
"Cursor moves left and right."
(let ((in (make-text-input :value "ab" :cursor 2)))
(handle-text-input in (make-key-event :key :left))
(is (= (text-input-cursor in) 1))
(handle-text-input in (make-key-event :key :right))
(is (= (text-input-cursor in) 2))))
(test text-input-cursor-bounds
"Cursor cannot move past start or end."
(let ((in (make-text-input :value "ab" :cursor 0)))
(handle-text-input in (make-key-event :key :left))
(is (= (text-input-cursor in) 0))
(setf (text-input-cursor in) 2)
(handle-text-input in (make-key-event :key :right))
(is (= (text-input-cursor in) 2))))
(test text-input-home-end
"Home moves to start, End moves to end."
(let ((in (make-text-input :value "hello" :cursor 3)))
(handle-text-input in (make-key-event :key :home))
(is (= (text-input-cursor in) 0))
(handle-text-input in (make-key-event :key :end))
(is (= (text-input-cursor in) 5))))
(test text-input-max-length
"Max-length prevents inserting beyond the limit."
(let ((in (make-text-input :max-length 3)))
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
(handle-text-input in (make-key-event :key :b :code (char-code #\b)))
(handle-text-input in (make-key-event :key :c :code (char-code #\c)))
(handle-text-input in (make-key-event :key :d :code (char-code #\d)))
(is (string= (text-input-value in) "abc"))))
(test text-input-placeholder
"Placeholder is stored but does not affect value."
(let ((in (make-text-input :placeholder "Type here...")))
(is (string= (text-input-placeholder in) "Type here..."))
(is (string= (text-input-value in) ""))))
(test text-input-on-submit
"On-submit callback fires on Enter."
(let ((result (list nil)))
(let ((in (make-text-input :value "hello"
:on-submit (lambda (v) (setf (car result) v)))))
(handle-text-input in (make-key-event :key :enter))
(is (string= (car result) "hello")))))
(test text-input-ctrl-a-e
"Ctrl+A moves to home, Ctrl+E moves to end."
(let ((in (make-text-input :value "abc" :cursor 2)))
(handle-text-input in (make-key-event :key :a :ctrl t))
(is (= (text-input-cursor in) 0))
(handle-text-input in (make-key-event :key :e :ctrl t))
(is (= (text-input-cursor in) 3))))
(test text-input-insert-in-middle
"Inserting in the middle of text shifts rest right."
(let ((in (make-text-input :value "ab" :cursor 1)))
(handle-text-input in (make-key-event :key :x :code (char-code #\x)))
(is (string= (text-input-value in) "axb"))
(is (= (text-input-cursor in) 2))))
(test text-input-dirty-on-insert
"Inserting marks the widget dirty."
(let ((in (make-text-input)))
(mark-clean in)
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
(is-true (dirty-p in))))
;; ── Textarea Tests ──────────────────────────────────────────────
(test textarea-empty
"New textarea has empty value and cursor at (0,0)."
(let ((a (make-textarea)))
(is (string= (textarea-value a) ""))
(is (= (textarea-cursor-row a) 0))
(is (= (textarea-cursor-col a) 0))))
(test textarea-newline
"Enter inserts a newline."
(let ((a (make-textarea)))
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
(handle-textarea-input a (make-key-event :key :enter))
(handle-textarea-input a (make-key-event :key :b :code (char-code #\b)))
(is (string= (textarea-value a) (format nil "a~Cb" #\Newline)))))
(test textarea-cursor-up-down
"Cursor moves between lines maintaining column position."
(let ((a (make-textarea :value (format nil "abc~Cde~Cfghi" #\Newline #\Newline))))
(setf (textarea-cursor-row a) 1)
(setf (textarea-cursor-col a) 1)
(handle-textarea-input a (make-key-event :key :up))
(is (= (textarea-cursor-row a) 0))
(is (= (textarea-cursor-col a) 1))
(handle-textarea-input a (make-key-event :key :down))
(is (= (textarea-cursor-row a) 1))
(is (= (textarea-cursor-col a) 1))))
(test textarea-cursor-up-down-bounds
"Cursor cannot move past first or last line."
(let ((a (make-textarea :value (format nil "a~Cb" #\Newline))))
(handle-textarea-input a (make-key-event :key :up))
(is (= (textarea-cursor-row a) 0))
(setf (textarea-cursor-row a) 1)
(handle-textarea-input a (make-key-event :key :down))
(is (= (textarea-cursor-row a) 1))))
(test textarea-backspace-joins-lines
"Backspace at start of a line joins with previous."
(let ((a (make-textarea :value (format nil "hello~Cworld" #\Newline))))
(setf (textarea-cursor-row a) 1)
(setf (textarea-cursor-col a) 0)
(handle-textarea-input a (make-key-event :key :backspace))
(is (string= (textarea-value a) "helloworld"))))
(test textarea-undo
"Ctrl+Z undoes the last edit."
(let ((a (make-textarea)))
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
(handle-textarea-input a (make-key-event :key :z :ctrl t))
(is (string= (textarea-value a) ""))))
(test textarea-undo-redo
"Ctrl+Y redoes an undone edit."
(let ((a (make-textarea)))
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
(handle-textarea-input a (make-key-event :key :z :ctrl t))
(handle-textarea-input a (make-key-event :key :y :ctrl t))
(is (string= (textarea-value a) "a"))))
;; ── Keybinding Tests ────────────────────────────────────────────
;; These tests verify the keymap dispatch system works correctly
;; when wired up. Note: dispatch-key-event is NOT called by the
;; demo's event loop — users MUST call it explicitly in their own
;; event loops if they want to use the defkeymap/dispatch-key-event
;; system. See src/components/keybindings.lisp for details.
;;
;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single
;; key specs work. The *chord-timeout* variable and list-of-lists
;; syntax are reserved for future implementation.
(test keymap-simple
"A keymap dispatches to its handler on matching event."
(let ((called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf called t))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))
(is-true called)))
(test keymap-no-match
"Non-matching event returns nil."
(let ((called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf called t))))))
(is-false (dispatch-key-event (make-key-event :key :a)))
(is-false called)))
(test keymap-fallback
"Event not in local falls through to global."
(let ((global-called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+q . ,(lambda (e)
(declare (ignore e))
(setf global-called t))))))
(dispatch-key-event (make-key-event :key :q :ctrl t))
(is-true global-called)))
(test key-spec-simple
"Keyword key-spec matches key+ctrl."
(is-true (key-match-p :ctrl+p (make-key-event :key :p :ctrl t)))
(is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t)))
(is-false (key-match-p :ctrl+p (make-key-event :key :p))))
(test key-spec-alt-modifier
"Alt modifier is matched correctly."
(is-true (key-match-p :alt+x (make-key-event :key :x :alt t)))
(is-false (key-match-p :alt+x (make-key-event :key :x)))
(is-false (key-match-p :alt+x (make-key-event :key :x :ctrl t))))
(test key-spec-shift-modifier
"Shift modifier is matched correctly."
(is-true (key-match-p :shift+tab (make-key-event :key :tab :shift t)))
(is-false (key-match-p :shift+tab (make-key-event :key :tab))))
(test key-spec-plain
"Plain key spec matches unmodified keys."
(is-true (key-match-p :enter (make-key-event :key :enter)))
(is-true (key-match-p :escape (make-key-event :key :escape)))
(is-false (key-match-p :enter (make-key-event :key :escape))))
(test key-spec-list-form
"List-form spec (:ctrl+p) matches same as keyword :ctrl+p."
(is-true (key-match-p '(:ctrl+p) (make-key-event :key :p :ctrl t)))
(is-false (key-match-p '(:ctrl+p) (make-key-event :key :a :ctrl t))))
(test dispatch-return-value-match
"dispatch-key-event returns T on matching binding."
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e)))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t))))
(test dispatch-return-value-no-match
"dispatch-key-event returns NIL when no binding matches."
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e)))))))
(is-false (dispatch-key-event (make-key-event :key :a))))
(test dispatch-empty-keymap
"dispatch-key-event returns NIL on empty keymap."
(setf (gethash :global *keymaps*) (make-keymap :name :global))
(is-false (dispatch-key-event (make-key-event :key :a))))
(test dispatch-local-overrides-global
"Local keymap takes priority over global."
(let ((local-called nil) (global-called nil))
(setf (gethash :local *keymaps*)
(make-keymap :name :local
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf local-called t))))))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf global-called t))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))
(is-true local-called)
(is-false global-called)))
(test dispatch-multiple-bindings
"dispatch-key-event finds the right binding among many."
(let ((called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+a . (lambda (e) (declare (ignore e))))
(:ctrl+b . (lambda (e) (declare (ignore e))))
(:ctrl+c . ,(lambda (e)
(declare (ignore e))
(setf called t)))
(:ctrl+d . (lambda (e) (declare (ignore e)))))))
(is-true (dispatch-key-event (make-key-event :key :c :ctrl t)))
(is-true called)))
(test defkeymap-macro
"defkeymap macro registers a keymap."
(let ((called nil))
(eval `(defkeymap :global
(:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t)))))
(dispatch-key-event (make-key-event :key :q :ctrl t))
(is-true called)))
(test defkeymap-macro-with-list-spec
"defkeymap macro works with list-form specs."
(let ((called nil))
(eval `(defkeymap :global
((:ctrl+w) ,(lambda (e) (declare (ignore e)) (setf called t)))))
(dispatch-key-event (make-key-event :key :w :ctrl t))
(is-true called)))
;; cleanup after keybinding tests
(test keybinding-cleanup-global
"Clean up global keymap after testing."
(remhash :global *keymaps*)
(remhash :local *keymaps*)
(is-false (gethash :global *keymaps*))
(is-false (gethash :local *keymaps*)))
;; 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))))

View File

@@ -1,243 +0,0 @@
;;; 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")))

View File

@@ -1,294 +0,0 @@
;;; 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)
;; ─── 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 ( )
(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)))))
(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)))))
(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))))))
(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))))
(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)))))
;; ─── 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"))))
;; ─── 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))))
;; ─── 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)))))
;; ─── 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)))))

View File

@@ -1,47 +0,0 @@
(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)
(def-test mouse-mixin-create ()
(let ((m (make-instance 'mouse-mixin)))
(is-true (typep m 'mouse-mixin))))
(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))))
(def-test selection-set-and-get ()
(setf cl-tty.mouse::*selection* (make-selection :text "hello"))
(is (equal "hello" (get-selection))))
(def-test start-selection-initializes-state ()
(start-selection 5 10)
(is-true (selection-active-p))
(is (equal '(5 . 10) cl-tty.mouse::*selection-start*))
(is (equal '(5 . 10) cl-tty.mouse::*selection-end*))
(setf cl-tty.mouse::*selection-active* nil
cl-tty.mouse::*selection-start* nil
cl-tty.mouse::*selection-end* nil))
(def-test update-selection-moves-end ()
(start-selection 0 0)
(update-selection 3 7)
(is (equal '(3 . 7) cl-tty.mouse::*selection-end*))
(setf cl-tty.mouse::*selection-active* nil
cl-tty.mouse::*selection-start* nil
cl-tty.mouse::*selection-end* nil))
(def-test finalize-selection-extracts-text ()
(let* ((fb-be (cl-tty.rendering:make-framebuffer-backend))
(fb (cl-tty.rendering:fb-framebuffer fb-be)))
(cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil)
(cl-tty.backend:draw-text fb-be 0 1 "world" nil nil)
(start-selection 0 0)
(update-selection 4 1)
(let ((text (finalize-selection fb)))
(is (equal "hello
world" text)))))

View File

@@ -1,124 +0,0 @@
(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)))
(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)))
(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)")))

View File

@@ -1,120 +0,0 @@
(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)
(def-suite select-suite :description "Select widget tests")
(in-suite select-suite)
(defun run-tests ()
(let ((result (run 'select-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(test select-creates
"A Select can be created with defaults."
(let ((sel (make-select)))
(is (typep sel 'select))
(is-false (select-options sel))
(is-false (select-filter sel))
(is (= (select-selected-index sel) 0))))
(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))))
(test select-filtered-exact
"Filter returns case-insensitive substring matches."
(let ((sel (make-select
:options '((:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Blue" :value :blue)))))
(setf (select-filter sel) "bl")
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :blue)))))
(test select-filtered-all
"Nil filter returns all options."
(let ((sel (make-select
:options '((:title "Red" :value :red)
(:title "Blue" :value :blue)))))
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 2)))))
(test select-navigation
"Select-next and select-prev navigate through options."
(let ((sel (make-select
:options '((:title "A" :value :a)
(:title "B" :value :b)
(:title "C" :value :c)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1))
(select-next sel)
(is (= (select-selected-index sel) 2))
(select-next sel)
(is (= (select-selected-index sel) 0) "wraps forward")
(select-prev sel)
(is (= (select-selected-index sel) 2) "wraps backward")))
(test select-navigation-skips-categories
"Navigation skips category header options."
(let ((sel (make-select
:options '((:title "Colors" :category t)
(:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Shapes" :category t)
(:title "Circle" :value :circle)))))
(is (= (select-selected-index sel) 0))
(select-next sel)
(is (= (select-selected-index sel) 1) "skipped category header at 0")
(select-next sel)
(is (= (select-selected-index sel) 2))
(select-next sel)
(is (= (select-selected-index sel) 4) "skipped category header at 3")))
(test select-handle-key
"Select handle-key dispatches navigation and selection."
(let* ((result (list nil))
(sel (make-select
:options '((:title "A" :value :a) (:title "B" :value :b))
:on-select (lambda (opt) (setf (car result) (getf opt :value))))))
(select-handle-key sel (make-key-event :key :down))
(is (= (select-selected-index sel) 1))
(select-handle-key sel (make-key-event :key :up))
(is (= (select-selected-index sel) 0))
(select-handle-key sel (make-key-event :key :enter))
(is (eql (car result) :a))))
(test select-handle-key-ctrl
"Ctrl+N and Ctrl+P navigate like down/up."
(let ((sel (make-select
:options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c)))))
(select-handle-key sel (make-key-event :key :n :ctrl t))
(is (= (select-selected-index sel) 1))
(select-handle-key sel (make-key-event :key :p :ctrl t))
(is (= (select-selected-index sel) 0))))
(test select-visible-count
"Visible options respects viewport height."
(let* ((ln (make-layout-node))
(sel (make-select
:options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i)))))
(setf (select-layout-node sel) ln)
(setf (layout-node-height ln) 5)
(let ((visible (select-visible-options sel)))
(is (<= (length visible) 5)))))
(test select-fuzzy-fallback
"Fuzzy filter catches near-misses."
(let ((sel (make-select
:options '((:title "Nord" :value :nord)
(:title "Tokyo Night" :value :tokyo)
(:title "Catppuccin" :value :cat)))))
(setf (select-filter sel) "nrd")
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :nord)))))

View File

@@ -1,55 +0,0 @@
(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)
(def-test defslot-register ()
(clear-slot :test-slot)
(defslot :test-slot :order 1 :render-fn (lambda () "hello"))
(is-true (slot-p :test-slot)))
(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))))
(def-test slot-render-empty ()
(clear-slot :ghost)
(is-false (slot-render :ghost)))
(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)))
(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))))