amr/cl-tty
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

v1.0.0 — Stable release + TUI support #8

Merged
amr merged 46 commits from feature/v0.11.0-slots into main 2026-05-12 16:34:48 -04:00
Conversation 0 Commits 46 Files Changed 86 +4730 -1745
42 changed files with 4730 additions and 1745 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit 29f99a576d - Show all commits

429
org/backend-protocol.org
View File

@@ -95,6 +95,18 @@ class. Application code never calls terminal escape sequences directly.
* Tests
The test suite is organized around the backend protocol contract.
Each rendering primitive and lifecycle operation has a dedicated
test case. Tests use a capturing backend (a simple-backend wired to
a string output stream) so assertions check actual output strings
rather than terminal behavior.
** Test Package and Suite
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
(defpackage :cl-tty-backend-test
(:use :cl :fiveam :cl-tty.backend)
@@ -103,23 +115,45 @@ class. Application code never calls terminal escape sequences directly.
(def-suite backend-suite :description "Backend protocol tests")
(in-suite backend-suite)
#+END_SRC
;; ── Helpers ─────────────────────────────────────────────────────
** Capturing Backend Helper
Tests need to inspect what the backend actually writes. This helper
creates a simple-backend pointed at a string output stream and
returns both the backend and the stream. The test can then call
~get-output-stream-string~ after the operation.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(defun make-capturing-backend ()
"Create a simple-backend that writes to a string stream."
(let* ((s (make-string-output-stream))
(b (make-simple-backend :output-stream s)))
(values b s)))
#+END_SRC
;; ── Simple Backend ──────────────────────────────────────────────
** Test Runner Entry Point
The ~run-tests~ function is an alternative entry point for
interactive use or for downstream scripts that want to run only the
backend suite. It prints results with FiveAM's explainer.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(defun run-tests ()
"Run all backend tests."
(let ((result (run 'backend-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
** Simple Backend Lifecycle
Verifies that a simple-backend can be constructed, initialized, and
shut down without errors. Also confirms that the capability query
returns nil for truecolor — the defining characteristic of the
simple backend.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test simple-backend-lifecycle
"simple-backend can be created and shut down"
(let ((b (make-simple-backend)))
@@ -127,7 +161,16 @@ class. Application code never calls terminal escape sequences directly.
(initialize-backend b)
(is-false (capable-p b :truecolor) "simple backend has no truecolor")
(shutdown-backend b)))
#+END_SRC
** Simple Backend Draw Text
The simple backend ignores style attributes (bold, italic, color)
and position. It merely appends the text string to the output stream.
This test confirms that passing style keywords does not change the
output — the captured stream should contain exactly the string "hello".
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test simple-backend-draw-text
"simple-backend renders text at position, ignoring style"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -136,7 +179,16 @@ class. Application code never calls terminal escape sequences directly.
(shutdown-backend b)
(is (string= (get-output-stream-string s) "hello")
"draw-text should output the string ignoring style")))
#+END_SRC
** Simple Backend Draw Border
Border rendering on the simple backend uses ASCII characters:
~+~ for corners, ~-~ for horizontal edges, ~|~ for vertical edges.
This test checks that the top edge contains "+---+" and a middle
row shows "| |" with pipe-separated empty space.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test simple-backend-draw-border
"simple-backend draws ASCII border with +-| characters"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -144,9 +196,18 @@ class. Application code never calls terminal escape sequences directly.
(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) "top edge should have +---+\"")
(is (search "| |" out) "middle row should have pipe sides"))))
#+END_SRC
** Simple Backend Draw Rounded Border
The simple backend does not support rounded corners — every style
falls back to the same ASCII characters. This test verifies that
requesting ~:rounded~ produces the same output as ~:single~,
confirming the graceful fallback.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test simple-backend-draw-rounded
"simple-backend falls back to straight edges for rounded style"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -154,9 +215,17 @@ class. Application code never calls terminal escape sequences directly.
(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
;; Rounded falls back to ASCII -- identical output to single
(is (search "+---+" out) "rounded style produces same dashes as single"))))
#+END_SRC
** Simple Backend Draw Link
Hyperlinks are meaningless on a simple terminal output. The simple
backend's ~draw-link~ should output only the visible text and
completely ignore the URL parameter.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test simple-backend-draw-link
"simple-backend renders link as plain text"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -165,7 +234,15 @@ class. Application code never calls terminal escape sequences directly.
(shutdown-backend b)
(is (string= (get-output-stream-string s) "click me")
"simple-backend ignores URL, outputs text only")))
#+END_SRC
** Simple Backend Draw Ellipsis
Truncation markers are rendered as three literal dots on the simple
backend. This test checks that ~draw-ellipsis~ outputs exactly "..."
at the specified position.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test simple-backend-draw-ellipsis
"simple-backend renders ... for ellipsis"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -174,9 +251,16 @@ class. Application code never calls terminal escape sequences directly.
(shutdown-backend b)
(is (string= (get-output-stream-string s) "...")
"ellipsis should output 3 dots")))
#+END_SRC
;; ── Backend Capabilities ───────────────────────────────────────
** Capability Query: Known Features
All known terminal features should report ~nil~ on the simple
backend. This comprehensive check iterates every feature keyword
to ensure the simple backend makes no false claims about its
capabilities.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test capable-p-known-features
"capable-p returns nil for all features on simple-backend"
(let ((b (make-simple-backend)))
@@ -186,9 +270,16 @@ class. Application code never calls terminal escape sequences directly.
(is-false (capable-p b f)
(format nil "~s should not be supported on simple-backend" f)))
(shutdown-backend b)))
#+END_SRC
;; ── Backend Size ───────────────────────────────────────────────
** Backend Size Returns Integers
The ~backend-size~ function must return two integer values
representing columns and lines. This test verifies the return types
and a minimum size threshold (10 columns, 3 lines) for any
terminal-like environment.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test backend-size-returns-integers
"backend-size returns two integer values"
(let ((b (make-simple-backend)))
@@ -199,9 +290,17 @@ class. Application code never calls terminal escape sequences directly.
(is (>= cols 10))
(is (>= lines 3)))
(shutdown-backend b)))
#+END_SRC
;; ── Backend Protocol: Defaults and No-ops ──────────────────────
** Default Methods Are No-Ops
All cursor operations and sync operations on the default backend
should return ~nil~ (or ~(values)~) without signaling errors. This
test calls ~cursor-hide~, ~cursor-show~, ~cursor-style~,
~begin-sync~, and ~end-sync~ and confirms none of them produce
multiple return values.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test default-methods-are-no-ops
"Default backend methods don't error"
(let ((b (make-simple-backend)))
@@ -212,7 +311,16 @@ class. Application code never calls terminal escape sequences directly.
(is (null (multiple-value-list (begin-sync b))))
(is (null (multiple-value-list (end-sync b))))
(shutdown-backend b)))
#+END_SRC
** Sync Is No-Op on Simple
Synchronized updates (DECICM) have no meaning on a simple terminal
output. This test verifies that wrapping a draw-text call between
~begin-sync~ and ~end-sync~ produces exactly the same output as
draw-text alone — no extra escape sequences are emitted.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test sync-is-noop-on-simple
"begin-sync and end-sync produce no output on simple-backend"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -223,9 +331,16 @@ class. Application code never calls terminal escape sequences directly.
(shutdown-backend b)
(is (string= (get-output-stream-string s) "in sync")
"no sync escape sequences should appear")))
#+END_SRC
;; ── Draw-rect ──────────────────────────────────────────────────
** Draw Rect Is No-Op on Simple
Background fill operations require escape sequences to change cell
colors. Since the simple backend emits no escape sequences,
~draw-rect~ should produce zero output regardless of the fill
color requested.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test draw-rect-fills-area-correctly
"draw-rect with background writes nothing to output (simple-backend no-op)"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -234,14 +349,29 @@ class. Application code never calls terminal escape sequences directly.
(shutdown-backend b)
(is (string= (get-output-stream-string s) "")
"draw-rect is a no-op on simple-backend")))
#+END_SRC
;; ── Detection ──────────────────────────────────────────────────
** Backend Detection Returns Instance
The ~detect-backend~ function must return a backend instance
suitable for the current environment. This test verifies that the
returned value is of type ~backend~ (satisfying the protocol).
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test detection-returns-backend-instance
"detect-backend returns a valid backend instance"
(let ((be (cl-tty.backend:detect-backend)))
(is (typep be 'cl-tty.backend:backend))))
#+END_SRC
** Backend Detection Caches Result
~detect-backend~ caches its result in ~*detected-backend*~ so that
subsequent calls are cheap. This test clears the cache, calls
detect-backend, and verifies that the special variable is no longer
nil.
#+BEGIN_SRC lisp :tangle ../src/backend/tests.lisp
(test detection-caches-result
"detect-backend caches the result in *detected-backend*"
(let ((*detected-backend* nil))
@@ -251,10 +381,17 @@ class. Application code never calls terminal escape sequences directly.
* Implementation
This section defines the base backend protocol and the simple
backend implementation. Each function, generic function, and method
is documented individually with its design rationale.
** Package
The ~cl-tty.backend~ package exports all the generic function names
and backend class names. It uses only ~:cl~ — no external dependencies.
The package also exports internal symbols (~sgr-fg~, ~hex-to-24bit~,
etc.) for testing. These let the test suite verify escape sequence
construction without actually rendering to a terminal.
#+BEGIN_SRC lisp :tangle ../src/backend/package.lisp
(defpackage :cl-tty.backend
@@ -292,10 +429,6 @@ and backend class names. It uses only ~:cl~ — no external dependencies.
(in-package :cl-tty.backend)
#+END_SRC
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.
** Backend Base Class
The ~backend~ class itself is empty — it's a base for method dispatch.
@@ -303,84 +436,248 @@ Every generic function on ~backend~ has a default method so that new
backend implementations only need to override the functions they
actually support.
*** Backend Class Definition
An empty base class. There are no slots because backends manage
their own state (e.g., output streams) directly.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(in-package :cl-tty.backend)
(defclass backend () ())
#+END_SRC
*** Initialize Backend
Sets up terminal raw mode and enables features. The default method
returns the backend instance unchanged — subclasses that need setup
override this.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric initialize-backend (backend)
(:method ((b backend)) b))
#+END_SRC
*** Shutdown Backend
Restores terminal to cooked mode, resets colors, shows cursor.
Must be called on exit. The default method is a no-op returning
multiple values; subclasses with terminal state override this.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric shutdown-backend (backend)
(:method ((b backend)) (values)))
#+END_SRC
*** Backend Size
Returns terminal dimensions as two values: columns and lines.
The default of 80x24 is a safe fallback that works everywhere.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric backend-size (backend)
(:method ((b backend))
(values 80 24)))
#+END_SRC
*** Backend Write
Writes a raw string to the terminal output. Has no default method
because every backend must provide its own output mechanism — there
is no reasonable universal behavior.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric backend-write (backend string))
#+END_SRC
*** Backend Clear
Clears the entire screen and resets the cursor to (0,0). The default
method sends the ANSI escape sequence ~ESC[2J~ (clear entire screen)
followed by ~ESC[H~ (cursor home).
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric backend-clear (backend)
(:method ((b backend))
(backend-write b (format nil "~C[2J~C[H" #\Esc #\Esc))))
#+END_SRC
*** Draw Text
Renders text at position (x, y) with foreground and background
colors and style attributes. The ~&allow-other-keys~ is important:
it lets individual backend methods accept keyword arguments they
don't use without signaling an error. The simple backend ignores
styles; the modern backend processes them.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric draw-text (backend x y string fg bg &key
bold italic underline reverse dim blink
&allow-other-keys))
#+END_SRC
*** Draw Border
Draws a border rectangle with optional title. Style is one of
~:single~, ~:double~, or ~:rounded~. The default method has no
implementation — each backend provides its own border rendering.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric draw-border (backend x y width height
&key style fg bg title title-align))
#+END_SRC
*** Draw Rectangle
Fills a rectangular area with a background color. On the simple
backend this is a no-op; on the modern backend it writes space
characters with the appropriate SGR background color.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric draw-rect (backend x y width height &key bg))
#+END_SRC
*** Draw Link
Renders a clickable hyperlink using OSC 8 escape sequences. The
default is a protocol declaration only — modern-backend implements
the actual escape sequences, simple-backend falls back to plain text.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric draw-link (backend x y string url &key fg bg))
#+END_SRC
*** Draw Ellipsis
Renders a "..." truncation marker at position (x, y). This is used
when text exceeds the available width. Each backend positions the
marker according to its own coordinate system.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric draw-ellipsis (backend x y width &key fg bg))
#+END_SRC
*** Cursor Move
Moves the cursor to absolute position (x, y). The default method
is a no-op — backends that support cursor positioning override this.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric cursor-move (backend x y)
(:method ((b backend) x y) (declare (ignore x y)) (values)))
#+END_SRC
*** Cursor Hide
Hides the terminal cursor. The default method is a no-op so that
backends that lack cursor control still work safely.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric cursor-hide (backend)
(:method ((b backend)) (values)))
#+END_SRC
*** Cursor Show
Shows the terminal cursor after a hide. Always paired with
~cursor-hide~. Default is a no-op.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric cursor-show (backend)
(:method ((b backend)) (values)))
#+END_SRC
*** Cursor Style
Sets the cursor shape and blink behavior. Shape is ~:block~,
~:bar~, or ~:underline~. Default is a no-op for backends that
don't support cursor styling.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric cursor-style (backend shape &key blink)
(:method ((b backend) shape &key blink) (values)))
#+END_SRC
*** Begin Sync
Starts a synchronized update (DECICM). All subsequent output is
buffered by the terminal until ~end-sync~. Default is a no-op.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric begin-sync (backend)
(:method ((b backend)) (values)))
#+END_SRC
*** End Sync
Flushes the synchronized update buffer so the entire frame appears
at once. Always paired with ~begin-sync~. Default is a no-op.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric end-sync (backend)
(:method ((b backend)) (values)))
#+END_SRC
*** Read Event
Reads the next input event from the terminal. Blocks until an event
arrives or the timeout expires. Returns (values keyword event-data).
The default method returns ~(values nil nil)~ — no events available.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric read-event (backend &key timeout)
(:method ((b backend) &key timeout) (values nil nil)))
#+END_SRC
*** Enable Mouse
Enables SGR mouse tracking so mouse click and motion events are
reported as input. Default is a no-op on backends that don't
support mouse input.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric enable-mouse (backend)
(:method ((b backend)) (values)))
#+END_SRC
*** Enable Bracketed Paste
Enables bracketed paste mode so the application can distinguish
pasted text from typed input. Default is a no-op.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric enable-bracketed-paste (backend)
(:method ((b backend)) (values)))
#+END_SRC
*** Capable-P Feature Query
Queries whether the backend supports a named feature. Feature
keywords include ~:truecolor~, ~:osc8~, ~:sync~, ~:mouse~,
~:bracketed-paste~, ~:kitty-keyboard~, ~:sixel~, and
~:cursor-style~. The default method returns ~nil~ for all features.
#+BEGIN_SRC lisp :tangle ../src/backend/classes.lisp
(defgeneric capable-p (backend feature)
(:method ((b backend) feature)
(declare (ignore feature))
nil))
#+END_SRC
The ~&allow-other-keys~ on ~draw-text~ is important: it lets
individual backend methods accept keyword arguments they don't use
without signaling an error. The simple backend ignores styles; the
modern backend processes them.
** Simple Backend
~simple-backend~ inherits from ~backend~ and implements every
operation in pure ASCII. No escape sequences, no color, no modern
features. Works in any terminal, pipe, or serial connection.
*** Simple Backend Class
The ~simple-backend~ class has a single slot: ~output-stream~.
This defaults to ~*standard-output*~ but can be overridden via
the ~:output-stream~ initarg — the key extensibility point. Tests
use ~make-string-output-stream~ to capture output, while production
uses ~*standard-output*~.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(in-package :cl-tty.backend)
@@ -388,44 +685,89 @@ features. Works in any terminal, pipe, or serial connection.
((output-stream :initform *standard-output*
:initarg :output-stream
:accessor backend-output-stream)))
#+END_SRC
*** Make Simple Backend
Constructor function that creates a ~simple-backend~ instance. Uses
~make-instance~ with the provided output stream or falls back to
~*standard-output*~. This function is exported rather than exposing
~make-instance~ directly to provide a stable API surface.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defun make-simple-backend (&key output-stream)
(make-instance 'simple-backend
:output-stream (or output-stream *standard-output*)))
#+END_SRC
The ~output-stream~ initarg is the key extensibility point: tests use
~make-string-output-stream~ to capture output, while production uses
~*standard-output*~.
*** Initialize Backend (Simple)
Simple backend initialization is a no-op — there is no terminal
state to configure. Returns the backend instance to satisfy the
protocol contract.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod initialize-backend ((b simple-backend))
b)
#+END_SRC
*** Shutdown Backend (Simple)
Simple backend shutdown is a no-op — there is no terminal state to
restore. Returns multiple values to satisfy the protocol contract.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod shutdown-backend ((b simple-backend))
(values))
#+END_SRC
*** Backend Size (Simple)
Returns hard-coded 80x24 dimensions. A real implementation would use
ioctl or TIOCGWINSZ, but the simple backend avoids OS-specific calls
for maximum portability.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod backend-size ((b simple-backend))
;; Try ioctl, fall back to 80x24
(values 80 24))
#+END_SRC
*** Backend Write (Simple)
Writes a string to the backend's output stream, forces the stream to
flush, and returns the length of the string. Uses ~finish-output~ to
ensure the data is actually sent, which matters for pipe and network
output.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod backend-write ((b simple-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(finish-output stream)
(length string)))
#+END_SRC
*** Draw Text (Simple)
The simple backend's ~draw-text~ ignores position, color, and style
completely. It appends only the string content to the output stream.
This means simple backends are always a "scroll and dump" mode —
no cursor positioning, no escape sequences.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod draw-text ((b simple-backend) x y string fg bg
&key bold italic underline reverse dim blink)
(declare (ignore x y fg bg bold italic underline reverse dim blink))
(backend-write b string))
#+END_SRC
~draw-text~ on simple-backend ignores position and style completely.
It just appends the string to the output stream. This means simple
backends are always a "scroll and dump" mode — no cursor positioning.
*** Simple Border Character Helper
** Border drawing
Returns the ASCII character for a given border position. All four
corners use ~#\+~, horizontal edges use ~#\-~, and vertical edges
use ~#\|~. No style distinction — single, double, and rounded are
identical in ASCII output.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defun %simple-border-char (pos)
@@ -438,8 +780,13 @@ POS is :top-left, :top-right, :bottom-left, :bottom-right,
(:vertical #\|)))
#+END_SRC
All four corners use ~#\+~, edges use ~#\-~ and ~#\|~. No style
distinction — single, double, and rounded are identical in ASCII.
*** Draw Border (Simple)
Draws a border using only newlines and spaces for positioning —
no escape sequences. This makes it compatible with pipe output.
The title rendering supports ~:left~ and ~:center~ alignment,
placing the title inside the top border line with horizontal
dashes filling the remaining space.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod draw-border ((b simple-backend) x y width height
@@ -492,12 +839,10 @@ distinction — single, double, and rounded are identical in ASCII.
(backend-write b (string br))))
#+END_SRC
~draw-border~ on the simple backend uses newlines and spaces for
positioning instead of ~cursor-move~ escape sequences. This makes it
compatible with pipe output. The title rendering supports ~:left~ and
~:center~ alignment, placing the title inside the top border line.
*** Draw Rect (Simple)
** Remaining primitives
Background fill is impossible without escape sequences. This method
is a no-op — it discards all arguments and returns ~(values)~.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod draw-rect ((b simple-backend) x y width height
@@ -505,12 +850,28 @@ compatible with pipe output. The title rendering supports ~:left~ and
(declare (ignore x y width height bg))
;; On simple backend, background fill is a no-op
(values))
#+END_SRC
*** Draw Link (Simple)
Hyperlinks fall back to plain text on the simple backend. The URL
parameter is discarded entirely; the visible text is rendered via
~draw-text~ with no styling.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod draw-link ((b simple-backend) x y string url
&key fg bg)
(declare (ignore url fg bg))
(draw-text b x y string nil nil))
#+END_SRC
*** Draw Ellipsis (Simple)
Renders "..." using the simple backend's positioning pattern:
newlines to reach the target row, spaces to reach the target column,
then the literal three dots. No escape sequences are used.
#+BEGIN_SRC lisp :tangle ../src/backend/simple.lisp
(defmethod draw-ellipsis ((b simple-backend) x y width
&key fg bg)
(declare (ignore width fg bg))
@@ -519,7 +880,3 @@ compatible with pipe output. The title rendering supports ~:left~ and
(backend-write b (make-string x :initial-element #\Space))
(backend-write b "..."))
#+END_SRC
~draw-rect~ is a no-op on simple-backend (no background fill possible
without escape sequences). ~draw-link~ falls back to plain text.
~draw-ellipsis~ positions and writes "...".

197
org/box-renderable.org
View File

@@ -37,6 +37,12 @@ carry a ~layout-node~ for position/size computed by the layout engine.
* Tests
** Package and test suite setup
The test package exports ~run-tests~ so it can be invoked from the
top-level test runner. ~fiveam~ imports directly for declarative
~test~ and ~is~ forms. The ~box-suite~ collects all box/text tests.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(defpackage :cl-tty-box-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.layout :cl-tty.box)
@@ -45,25 +51,54 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(def-suite box-suite :description "Box renderable tests")
(in-suite box-suite)
#+END_SRC
** Test runner entry point
~run-tests~ is the entry point called from the top-level
~run-all-tests.lisp~. It runs the ~box-suite~, explains results to
stdout, and exits cleanly with ~uiop:quit~.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(defun run-tests ()
(let ((result (run 'box-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
** Capturing backend helper
~make-capturing-backend~ creates a backend that writes to a
~string-output-stream~ so tests can inspect rendered output without
actual terminal I/O. Returns the backend and stream as multiple
values.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(defun make-capturing-backend ()
(let* ((s (make-string-output-stream))
(b (make-modern-backend :output-stream s)))
(values b s)))
#+END_SRC
;; ── Box Tests ─────────────────────────────────────────────────
** Test: box-creates-with-defaults
Verify that a bare ~make-box~ returns a ~box~ instance and
automatically creates a ~layout-node~ through inheritance.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-creates-with-defaults
"A box created with no arguments has reasonable defaults"
(let ((b (make-box)))
(is (typep b 'box))
(is (typep (box-layout-node b) 'layout-node))))
#+END_SRC
** Test: box-renders-border
Verify that a box with ~:border-style :single~ draws the four corner
characters (┌ ┐ └ ┘) in the output stream.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-renders-border
"A box with border draws border characters"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -75,7 +110,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(is (search "┐" out) "top-right corner")
(is (search "└" out) "bottom-left corner")
(is (search "┘" out) "bottom-right corner")))))
#+END_SRC
** Test: box-renders-background
Verify that a box with ~:bg :red~ emits SGR background color codes
(41m) in the output stream.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-renders-background
"A box with background color fills interior"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -85,7 +127,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "border with background")
(is (search "41m" out) "SGR background for red")))))
#+END_SRC
** Test: box-renders-title
Verify that a title string appears in the rendered output stream
when ~:title~ is provided.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-renders-title
"A box with title renders the title text"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -94,7 +143,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "title text should appear")))))
#+END_SRC
** Test: box-without-border
Verify that ~:border-style nil~ suppresses corner characters but
background fill rendering continues to work.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-without-border
"A box with border-style nil draws no border"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -104,7 +160,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(let ((out (get-output-stream-string s)))
(is (search "41m" out) "background still renders")
(is-false (search "┌" out) "no top-left corner")))))
#+END_SRC
** Test: box-zero-size
Verify that a box with zero width and height produces no output
(triggers the early-return guard in ~render-box~).
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-zero-size
"A box with any zero dimension renders nothing"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -113,7 +176,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(render-box bx b)
(is (string= (get-output-stream-string s) "")
"zero-size box produces no output"))))
#+END_SRC
** Test: box-single-column
Verify that a box with width 1 produces no output — ~draw-border~
requires at least 2 columns to draw corner and edge characters.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-single-column
"A box with width 1 renders nothing (needs min 2 for border)"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -122,7 +192,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(render-box bx b)
(is (string= (get-output-stream-string s) "")
"width=1 box renders nothing"))))
#+END_SRC
** Test: box-minimum-size
Verify that a 2x2 box (the minimum viable size for border rendering)
still produces corner characters in the output.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test box-minimum-size
"A box with minimum non-zero size still renders"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -131,15 +208,27 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(render-box bx b)
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "2x2 box still has borders")))))
#+END_SRC
;; ── Text and Span Tests ───────────────────────────────────────
** Test: text-creates-with-defaults
Verify that ~make-text~ with an empty string returns a ~text~
instance and creates a ~layout-node~.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test text-creates-with-defaults
"A text created with no arguments has reasonable defaults"
(let ((txt (make-text "")))
(is (typep txt 'text))
(is (typep (text-layout-node txt) 'layout-node))))
#+END_SRC
** Test: text-renders-content
Verify that text content appears in the captured output stream after
rendering.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test text-renders-content
"A text renders its content at position"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -148,7 +237,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "content should appear")))))
#+END_SRC
** Test: text-empty-string
Verify that an empty string produces no output (triggers the
early-return guard in ~render-text~).
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test text-empty-string
"Empty text produces no output"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -157,7 +253,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(render-text tx b)
(is (string= (get-output-stream-string s) "")
"empty string produces no output"))))
#+END_SRC
** Test: text-truncates-when-no-wrap
Verify that ~:wrap-mode :none~ truncates the content string to fit
within the available width, producing only the first N characters.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test text-truncates-when-no-wrap
"Text with wrap-mode :none truncates at width"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -167,7 +270,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(render-text tx b)
(let ((out (get-output-stream-string s)))
(is (search "Hello" out) "truncated to first 5 chars")))))
#+END_SRC
** Test: text-word-wraps
Verify that ~:wrap-mode :word~ breaks lines at word boundaries,
distributing words across successive rows.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test text-word-wraps
"Text with wrap-mode :word wraps at word boundaries"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -178,7 +288,14 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(is (search "Hello" out) "first line")
(is (search "brave" out) "second line")
(is (search "new" out) "third line")))))
#+END_SRC
** Test: text-word-wrap-single-word
Verify that a single word longer than the available width is
hard-broken at character boundaries into ~max-width~-sized chunks.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test text-word-wrap-single-word
"A word longer than width is hard-broken at max-width"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -188,14 +305,28 @@ carry a ~layout-node~ for position/size computed by the layout engine.
(let ((out (get-output-stream-string s)))
(is (search "Hel" out) "first chunk is Hel")
(is (search "lo" out) "second chunk is lo")))))
#+END_SRC
** Test: span-creates-with-attributes
Verify that ~span~ stores its text content and style attributes
correctly, with unset attributes defaulting to ~nil~.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test span-creates-with-attributes
"A span has text and optional style attributes"
(let ((s (span "bold text" :bold t)))
(is (string= (span-text s) "bold text"))
(is-true (span-bold s))
(is-false (span-italic s))))
#+END_SRC
** Test: make-text-with-spans
Verify that ~make-text~ with ~:spans~ stores the provided span
objects and they are accessible via ~text-spans~.
#+BEGIN_SRC lisp :tangle ../src/components/box-tests.lisp
(test make-text-with-spans
"Text with spans stores span objects"
(let* ((sp (list (span "Hello" :bold t)
@@ -212,7 +343,8 @@ carry a ~layout-node~ for position/size computed by the layout engine.
~box~ inherits from ~dirty-mixin~ so changes (resize, title update,
color change) trigger incremental re-render. The ~layout-node~ slot
holds the computed position and size from the layout engine.
holds the computed position and size from the layout engine. Border
style, title, alignment, and colors are all configurable slots.
#+BEGIN_SRC lisp :tangle ../src/components/box.lisp
(in-package :cl-tty.box)
@@ -229,8 +361,11 @@ holds the computed position and size from the layout engine.
(bg :initform nil :initarg :bg :accessor box-bg)))
#+END_SRC
** make-box constructor
The constructor wraps ~make-instance~ and passes layout parameters
through to the layout node:
through to the layout node. Width and height are optional; when
omitted the layout engine will compute them from parent constraints.
#+BEGIN_SRC lisp :tangle ../src/components/box.lisp
(defun make-box (&key (border-style :single) title
@@ -248,9 +383,15 @@ through to the layout node:
:direction :column)))
#+END_SRC
** render-box function
~render-box~ draws the border at the component's layout position.
It handles zero-size (returns immediately) and optional background
fill.
fill. The early return for ~(< w 2)~ is important: ~draw-border~
requires at least 2 columns of width to draw corner characters.
Title rendering supports ~:left~, ~:center~, and ~:right~ alignment
with automatic truncation when the title is wider than available
content area (width-4 when border is present).
#+BEGIN_SRC lisp :tangle ../src/components/box.lisp
(defun render-box (box backend)
@@ -282,20 +423,16 @@ fill.
(t (draw-text backend tx ty display fg bg))))))))
#+END_SRC
The early return for ~(< w 2)~ is important: ~draw-border~ requires
at least 2 columns of width to draw corner characters.
** Span class
~span~ represents an inline styled segment within a Text component.
Multiple spans let a single Text contain bold, colored, or italicized
runs.
runs. Each style attribute is a separate slot so consumers can
inspect and apply them individually.
#+BEGIN_SRC lisp :tangle ../src/components/text.lisp
(in-package :cl-tty.box)
;; ── Text Renderable ────────────────────────────────────────────
(defclass span ()
((text :initarg :text :accessor span-text)
(bold :initform nil :initarg :bold :accessor span-bold)
@@ -305,7 +442,15 @@ runs.
(dim :initform nil :initarg :dim :accessor span-dim)
(fg :initform nil :initarg :fg :accessor span-fg)
(bg :initform nil :initarg :bg :accessor span-bg)))
#+END_SRC
** span constructor
~span~ is a convenience function for creating ~span~ instances with
keyword arguments for all style attributes. A ~nil~ default means
"inherit/no-change" when merged with parent styling context.
#+BEGIN_SRC lisp :tangle ../src/components/text.lisp
(defun span (text &key bold italic underline reverse dim fg bg)
(make-instance 'span
:text text :bold bold :italic italic
@@ -316,8 +461,9 @@ runs.
** Text class
~text~ renders a string at a layout position with word-wrapping.
Spans are stored but not yet rendered with per-run styling in the
current implementation.
Spans are stored for future per-run styling but the current
implementation renders all content as plain text. It inherits from
~dirty-mixin~ so content, color, or size changes trigger re-render.
#+BEGIN_SRC lisp :tangle ../src/components/text.lisp
(defclass text (dirty-mixin)
@@ -328,7 +474,16 @@ current implementation.
(fg :initform nil :initarg :fg :accessor text-fg)
(bg :initform nil :initarg :bg :accessor text-bg)
(wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode)))
#+END_SRC
** make-text constructor
~make-text~ is a convenience constructor that accepts layout
dimensions and content parameters. It defaults ~wrap-mode~ to ~:word~
so text wraps by default, and creates a ~:column~-oriented layout
node.
#+BEGIN_SRC lisp :tangle ../src/components/text.lisp
(defun make-text (content &key fg bg wrap-mode width height spans)
(make-instance 'text
:content content
@@ -339,9 +494,13 @@ current implementation.
:width width :height height)))
#+END_SRC
** render-text function
~render-text~ handles both wrap modes. For ~:word~, it calls
~word-wrap~ to break the content into lines, then renders each line
at successive row positions.
at successive row positions. For ~:none~, it truncates the content to
fit the width in a single line. Empty content or zero dimensions
triggers an early return.
#+BEGIN_SRC lisp :tangle ../src/components/text.lisp
(defun render-text (text-object backend)
@@ -373,7 +532,8 @@ at successive row positions.
~word-wrap~ implements the line-breaking algorithm. It splits the
input into words, then packs them into lines respecting ~max-width~.
Words that exceed ~max-width~ are hard-broken at character boundaries.
Words that exceed ~max-width~ are hard-broken at character boundaries
in chunks of ~max-width~ to ensure no line exceeds the limit.
#+BEGIN_SRC lisp :tangle ../src/components/text.lisp
(defun word-wrap (text max-width)
@@ -405,7 +565,12 @@ Words that exceed ~max-width~ are hard-broken at character boundaries.
(or (nreverse lines) (list "")))))
#+END_SRC
~split-string~ tokenizes on whitespace (space, tab, newline):
** split-string utility
~split-string~ tokenizes on whitespace characters (space, tab,
newline). It uses ~position-if~ to find delimiters and builds the
word list iteratively. Consecutive delimiters are collapsed
(only one advance per delimiter character).
#+BEGIN_SRC lisp :tangle ../src/components/text.lisp
(defun split-string (string)

94
org/container-package.org
View File

@@ -11,6 +11,100 @@ ScrollBox and TabBar. It uses ~cl-tty.backend~, ~cl-tty.box~,
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

96
org/detection.org
View File

@@ -36,6 +36,9 @@ If detection can't determine modern capability, it falls back to
- ~*detected-backend*~ — variable
Cache for detection result. ~nil~ = not yet detected.
- ~query-terminal~ — function
Low-level escape sequence query helper shared by probes.
* Plan
See =docs/plans/2026-05-11-terminal-detection.md= for implementation tasks.
@@ -66,20 +69,36 @@ See =docs/plans/2026-05-11-terminal-detection.md= for implementation tasks.
Detection functions are added to the existing ~cl-tty.backend~ package.
No new package definition needed.
** Environment probe
** Detection cache
Check ~COLORTERM~ first — it's the simplest and most reliable signal.
The ~*detected-backend*~ special variable holds the cached backend instance
after the first successful detection. Initializing it to ~nil~ gives downstream
code a simple truthiness check — ~(or *detected-backend* ...)~ — so that
~detect-backend~ returns immediately on re-entry without re-running probes.
Using a global variable rather than a closure or class slot keeps the detection
path stateless and trivially resettable for testing: binding ~*detected-backend*~
to ~nil~ forces a fresh detection run.
#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp
(in-package :cl-tty.backend)
;;; ─── Detection cache ────────────────────────────────────────────────────────
(defvar *detected-backend* nil
"Cached backend instance from detect-backend. Nil = not yet detected.")
#+END_SRC
;;; ─── Environment probe ──────────────────────────────────────────────────────
** Environment probe
The ~COLORTERM~ environment variable is the single most reliable signal for
truecolor support. It is set by modern terminal emulators (kitty, Alacritty,
GNOME Terminal, iTerm2, Windows Terminal) and has near-zero false-positive
rate. Checking it first avoids the I/O costs and race conditions of escape
sequence queries.
Case-insensitive matching via ~char-equal~ handles variances across platforms
(GNOME Terminal uses ~truecolor~, some Windows builds use ~24bit~).
#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp
(defun detect-backend-by-env ()
"Check COLORTERM environment variable for modern terminal support.
Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise."
@@ -92,36 +111,36 @@ Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise."
** TTY probe
Check if stdout is connected to a terminal (not a pipe or file).
The ~interactive-stream-p~ function from the CL standard reliably distinguishes
real terminals from pipes and redirected files. If stdout is not a terminal,
escape sequence queries will hang or produce garbage, so this check gates all
further (I/O-dependent) probes. Must happen before ~detect-backend-by-da1~.
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
;;; ─── TTY probe ──────────────────────────────────────────────────────────────
(defun detect-backend-by-tty ()
"Check if stdout is a real terminal (not a pipe/redirect).
Returns T if stdout is interactive, nil otherwise."
(interactive-stream-p *standard-output*))
#+END_SRC
** DA1 terminal query (best-effort)
** Low-level terminal query helper
Send a DA1 (Device Attributes) query and briefly listen for a response.
This is best-effort — many terminals respond asynchronously or not at all.
The ~query-terminal~ function encapsulates the mechanics of sending an escape
sequence and collecting a response within a short timeout. Writing to
~*standard-output*~ and reading from ~*standard-input*~ matches how terminal
emulators actually deliver DA1/DA3 response bytes — they arrive on stdin, not
on any query I/O stream. The original implementation used ~*query-io*~ for
both sides, which silently failed on some emulators.
*** Bug Fixes (v1.0.0): query-terminal stream fix
~query-terminal~ originally used ~*query-io*~ for both writing the query and
reading the response. In raw terminal mode, the terminal's response arrives on
stdin, not on the query I/O stream. This caused ~query-terminal~ to never
receive a response on certain terminal emulators.
Fix: Write queries to ~*standard-output*~ and read responses from
~*standard-input*~. This matches where the terminal actually delivers its
DA1/DA3 response bytes.
Using ~listen~ in a polling loop with ~read-char-no-hang~ captures whatever
bytes arrive within the timeout without blocking. The ~0.1~ second default
strikes a balance between responsiveness and reliability: fast enough to avoid
noticeable delay in interactive use, long enough for most terminals to reply.
#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp
;;; ─── DA1 terminal query ─────────────────────────────────────────────────────
(defun query-terminal (query &optional (timeout 0.1))
"Send QUERY string to terminal and return any response received within
TIMEOUT seconds. Returns the response string, or nil if no response."
@@ -134,11 +153,26 @@ TIMEOUT seconds. Returns the response string, or nil if no response."
do (vector-push-extend (read-char-no-hang *standard-input*) response))
(when (plusp (length response))
response)))
#+END_SRC
** DA1 capability probe
The DA1 (Device Attributes) escape sequence (~ESC[c~) is an xterm-standard
query that asks the terminal to report its feature set. Modern terminals
(notably Kitty, which returns code 62) advertise their capabilities in the
response. Searching for ~?62~ in the raw response is a heuristic — it targets
Kitty's protocol extension identifier while being short enough to match
variants across terminal implementations.
This probe is best-effort: many terminals do not respond within the timeout,
and some return different codes for the same capabilities. A ~nil~ result from
this function should never prevent fallback detection via environment variables.
#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp
(defun detect-backend-by-da1 ()
"Send DA1 (ESC[c) query and check for kitty terminal response code.
Returns T if terminal reports kitty compatibility codes."
(let ((response (query-terminal (format nil "~C[c" #\Esc))))
(let ((response (query-terminal (format nil "~C[c" (code-char 27)))))
(when response
;; DA1 response format: ESC [ ? digits ; digits c
;; Kitty reports code 62 in the response
@@ -147,11 +181,19 @@ Returns T if terminal reports kitty compatibility codes."
** Orchestrator
Tie all probes together into ~detect-backend~.
The ~detect-backend~ function ties all probes together with a short-circuit
caching strategy. On first call, it:
1. Checks if stdout is a real TTY (fast, gates all I/O)
2. Checks ~COLORTERM~ (fast, most reliable signal)
3. Falls back to DA1 query (slow, best-effort, skipped if env check passed)
The ~and~ / ~or~ structure naturally short-circuits: if ~detect-backend-by-tty~
returns nil, the expensive DA1 query never runs. If ~detect-backend-by-env~
returns ~:modern~, the DA1 query is skipped. The result is cached in
~*detected-backend*~ so subsequent calls are effectively free.
#+BEGIN_SRC lisp :tangle ../src/backend/detection.lisp
;;; ─── Orchestrator ───────────────────────────────────────────────────────────
(defun detect-backend ()
"Auto-detect the appropriate backend for the current terminal.
Returns a backend instance (modern-backend or simple-backend).

440
org/dialog.org
View File

@@ -45,271 +45,12 @@ duration. They stack in the top-right corner.
- ~toast~ component — transient notification with variant color
- ~(toast message &key variant duration)~ — fire-and-forget toast
* Code structure
* Package definition
** Dialog class
The ~cl-tty.dialog~ package uses the backend, input, and select
subsystems. All public symbols are exported for user convenience.
--- per-function: dialog-class
The dialog class stores the dialog's content (a component to render
inside the dialog panel), its size preset, title, and callbacks.
#+BEGIN_SRC lisp :tangle no
(defclass dialog ()
((title :initarg :title :accessor dialog-title)
(size :initarg :size :initform :medium :accessor dialog-size)
(content :initarg :content :accessor dialog-content)
(on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss)))
#+END_SRC
--- per-function: dialog-size-pixels
Helper to convert size keyword to pixel dimensions, clamped to available
terminal dimensions.
*** Bug Fixes (v1.0.0): dialog size clamp and draw-border keyword
Three bugs were fixed:
1. *Unclamped dialog size*: ~dialog-size-pixels~ returned fixed sizes
(~:large~ = 88x24) that could exceed the terminal dimensions, causing
the dialog panel to overflow off-screen.
Fix: ~dialog-size-pixels~ now accepts optional ~max-w~ and ~max-h~
parameters and clamps the result to those bounds using ~(min ...)~.
2. *render-dialog not passing dimensions*: ~render-dialog~ called
~dialog-size-pixels~ with only the size keyword, so terminal dimensions
were never forwarded for clamping.
Fix: ~render-dialog~ now passes ~w h~ to ~dialog-size-pixels~.
3. *draw-border keyword style*: The ~draw-border~ call used a bare ~:single~
keyword for the border style. The function signature expects ~:style :single~.
Fix: Changed ~:single~ to ~:style :single~.
#+BEGIN_SRC lisp :tangle no
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
(multiple-value-bind (dw dh)
(case size
(:small (values 40 8))
(:medium (values 60 16))
(:large (values 88 24))
(t (values 60 16)))
(values (min dw max-w) (min dh max-h))))
#+END_SRC
|--- per-function: render-dialog
Render a dialog: backdrop (dimmed full-screen), then centered panel.
#+BEGIN_SRC lisp :tangle no
(defun render-dialog (dialog screen w h)
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
(let ((x (floor (- w dw) 2))
(y (floor (- h dh) 2)))
;; Backdrop — draw dim characters over full screen
(dotimes (row h)
(dotimes (col w)
(backend-write screen col row " " :bg :dim)))
;; Panel border
(draw-border screen x y dw dh :style :single :title (dialog-title dialog))
;; Content area (inset by 1 on each side)
(when (dialog-content dialog)
(render-component (dialog-content dialog) screen (1+ x) (1+ y) (- dw 2) (- dh 2))))))
#+END_SRC
*** push-dialog / pop-dialog
~push-dialog~ pushes a dialog onto =*dialog-stack*=. ~pop-dialog~ pops the
top dialog and calls its ~:on-dismiss~ callback if set.
#+BEGIN_SRC lisp :tangle no
(defun push-dialog (dialog)
(push dialog *dialog-stack*)
dialog)
#+END_SRC
--- per-function: pop-dialog
Pop the top dialog, fire its on-dismiss callback.
#+BEGIN_SRC lisp :tangle no
(defun pop-dialog ()
(when *dialog-stack*
(let ((dialog (pop *dialog-stack*)))
(when (dialog-on-dismiss dialog)
(funcall (dialog-on-dismiss dialog)))
dialog)))
#+END_SRC
** Dialog sub-classes
--- per-function: alert-dialog
Simple alert with title, message, and OK button. The button is a
Select with a single "OK" option.
#+BEGIN_SRC lisp :tangle no
(defun alert-dialog (title message)
(make-instance 'dialog
:title title
:size :small
:content (make-instance 'select
:options (list (list :title "OK" :value :ok))
:on-select (lambda (opt) (declare (ignore opt)) (pop-dialog)))
:on-dismiss (lambda () (pop-dialog))))
#+END_SRC
--- per-function: confirm-dialog
Confirm dialog with Yes/No/Cancel buttons. Returns :yes or :no
via the on-yes/on-no callbacks.
#+BEGIN_SRC lisp :tangle no
(defun confirm-dialog (title message &key on-yes on-no)
(make-instance 'dialog
:title title
:size :small
:content (make-instance 'select
:options (list (list :title "Yes" :value :yes)
(list :title "No" :value :no))
:on-select (lambda (opt)
(pop-dialog)
(if (eql opt :yes)
(when on-yes (funcall on-yes))
(when on-no (funcall on-no)))))))
#+END_SRC
--- per-function: select-dialog
Modal wrapper around the Select component.
#+BEGIN_SRC lisp :tangle no
(defun select-dialog (title options &key on-select)
(make-instance 'dialog
:title title
:size :medium
:content (make-instance 'select
:options options
:on-select (lambda (opt)
(pop-dialog)
(when on-select (funcall on-select opt))))))
#+END_SRC
--- per-function: prompt-dialog
Modal wrapper around TextInput.
#+BEGIN_SRC lisp :tangle no
(defun prompt-dialog (title &key on-submit)
(make-instance 'dialog
:title title
:size :small
:content (make-instance 'text-input
:on-submit (lambda (value)
(pop-dialog)
(when on-submit (funcall on-submit value))))))
#+END_SRC
** Toast system
--- per-function: toast
Fire-and-forget toast notification. Creates a toast component,
adds it to the toast list, and schedules auto-dismissal.
#+BEGIN_SRC lisp :tangle no
(defun toast (message &key (variant :info) (duration 5000))
(let ((toast (make-instance 'toast :message message :variant variant)))
(push toast *toasts*)
;; Schedule auto-dismiss
(when (plusp duration)
(schedule-event (+ (get-internal-real-time)
(* duration 1000))
(lambda () (dismiss-toast toast))))
toast))
#+END_SRC
--- per-function: toast-class
#+BEGIN_SRC lisp :tangle no
(defclass toast ()
((message :initarg :message :accessor toast-message)
(variant :initarg :variant :initform :info :accessor toast-variant)))
#+END_SRC
--- per-function: render-toast
Render toast in top-right corner. Max 60 cols. Shows colored
left border based on variant.
#+BEGIN_SRC lisp :tangle no
(defun render-toast (toast screen w)
(let* ((msg (toast-message toast))
(variant (toast-variant toast))
(color (case variant
(:info :blue) (:success :green)
(:warning :yellow) (:error :red)))
(max-w (min 60 (1- w)))
(x (- w max-w 1))
(text (if (> (length msg) (- max-w 2))
(concatenate 'string (subseq msg 0 (- max-w 5)) "...")
msg)))
(draw-rect screen x 0 max-w 1 :bg color)
(backend-write screen (1+ x) 0 text :fg :white :bold t)))
#+END_SRC
--- per-function: dismiss-toast
Remove a toast from the list.
#+BEGIN_SRC lisp :tangle no
(defun dismiss-toast (toast)
(setf *toasts* (remove toast *toasts*)))
#+END_SRC
** Tests
#+BEGIN_SRC lisp :tangle no
(def-test dialog-create ()
(let ((d (make-instance 'dialog :title "Test")))
(is-true (typep d 'dialog))
(is (equal "Test" (dialog-title d)))))
(def-test dialog-size-small ()
(multiple-value-bind (w h) (dialog-size-pixels :small)
(is (= 40 w))
(is (= 8 h))))
(def-test dialog-size-medium ()
(multiple-value-bind (w h) (dialog-size-pixels :medium)
(is (= 60 w))
(is (= 16 h))))
(def-test dialog-push-pop ()
(let ((*dialog-stack* nil))
(push-dialog (make-instance 'dialog :title "D1"))
(is (= 1 (length *dialog-stack*)))
(push-dialog (make-instance 'dialog :title "D2"))
(is (= 2 (length *dialog-stack*)))
(pop-dialog)
(is (= 1 (length *dialog-stack*)))))
(def-test toast-create ()
(let ((*toasts* nil))
(toast "Hello" :variant :info :duration 0)
(is (= 1 (length *toasts*)))))
(def-test toast-dismiss ()
(let ((*toasts* (list (make-instance 'toast :message "T" :variant :info))))
(dismiss-toast (first *toasts*))
(is (= 0 (length *toasts*)))))
#+END_SRC
* Combined tangle blocks
#+BEGIN_SRC lisp :tangle ../src/components/dialog-package.lisp :noweb no
#+BEGIN_SRC lisp :tangle ../src/components/dialog-package.lisp
;;; dialog-package.lisp — Package definition for cl-tty.dialog
(defpackage :cl-tty.dialog
@@ -337,27 +78,54 @@ Remove a toast from the list.
#:*toasts*))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp :noweb no
;;; dialog.lisp — Dialog System + Toast for cl-tty
* Special variables
** *dialog-stack*
The active dialog stack. ~push-dialog~ conses onto this list;
~pop-dialog~ pops it and fires the ~:on-dismiss~ callback. Each screen
should bind its own instance so multiple screens can have independent
dialog states.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(in-package :cl-tty.dialog)
;; ─── Special variables ────────────────────────────────────────────────────────
(defvar *dialog-stack* nil
"Stack of active dialogs. (list) of dialog instances.")
#+END_SRC
** *toasts*
List of active toast notifications. ~toast~ pushes, ~dismiss-toast~
removes by identity. The render loop walks this list to draw toasts in
the top-right corner.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defvar *toasts* nil
"List of active toast notifications.")
#+END_SRC
;; ─── Dialog class ─────────────────────────────────────────────────────────────
* Dialog class
The core dialog class stores a title, a size preset, the content
component to render inside the panel, and an optional ~:on-dismiss~
callback invoked when the dialog is popped.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defclass dialog ()
((title :initarg :title :accessor dialog-title)
(size :initarg :size :initform :medium :accessor dialog-size)
(content :initarg :content :initform nil :accessor dialog-content)
(on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss)))
#+END_SRC
** dialog-size-pixels
Converts a size keyword (~:small~, ~:medium~, ~:large~) to pixel
dimensions. Accepts optional ~max-w~ / ~max-h~ to clamp the result to
terminal bounds, preventing off-screen overflow (fixed in v1.0.0).
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
(multiple-value-bind (dw dh)
(case size
@@ -366,7 +134,15 @@ Remove a toast from the list.
(:large (values 88 24))
(t (values 60 16)))
(values (min dw max-w) (min dh max-h))))
#+END_SRC
** render-dialog
Renders a dialog: draws a dimmed full-screen backdrop using
~draw-rect~, then draws the bordered dialog panel centered on screen.
Content is rendered via ~draw-text~ inside the panel area.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun render-dialog (dialog screen w h)
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
(let ((x (floor (- w dw) 2))
@@ -381,20 +157,44 @@ Remove a toast from the list.
(draw-text screen (1+ x) (1+ y)
(format nil "~a" (dialog-content dialog))
:white :default)))))
#+END_SRC
** push-dialog
Pushes a dialog onto =*dialog-stack*=. Returns the dialog for chaining.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun push-dialog (dialog)
(push dialog *dialog-stack*)
dialog)
#+END_SRC
** pop-dialog
Pops the top dialog from the stack. If an ~:on-dismiss~ callback is
set on the dialog, it is called before returning.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun pop-dialog ()
(when *dialog-stack*
(let ((dialog (pop *dialog-stack*)))
(when (dialog-on-dismiss dialog)
(funcall (dialog-on-dismiss dialog)))
dialog)))
#+END_SRC
;; ─── Dialog sub-classes ──────────────────────────────────────────────────────
* Dialog convenience constructors
These factory functions create common dialog variants by composing the
~dialog~ class with interactive components (~select~, ~text-input~).
** alert-dialog
Simple alert with title, message, and an OK button. The button is a
~select~ with a single "OK" option. Dismissing fires ~pop-dialog~ on
both selection and backdrop dismiss.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun alert-dialog (title message)
(make-instance 'dialog
:title title
@@ -403,7 +203,14 @@ Remove a toast from the list.
:options (list (list :title "OK" :value :ok))
:on-select (lambda (opt) (declare (ignore opt)) (pop-dialog)))
:on-dismiss (lambda () (pop-dialog))))
#+END_SRC
** confirm-dialog
Confirm dialog with Yes/No buttons. Returns ~:yes~ or ~:no~ via the
~on-yes~/~on-no~ callbacks. The dialog auto-dismisses on selection.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun confirm-dialog (title message &key on-yes on-no)
(make-instance 'dialog
:title title
@@ -416,7 +223,14 @@ Remove a toast from the list.
(if (eql opt :yes)
(when on-yes (funcall on-yes))
(when on-no (funcall on-no)))))))
#+END_SRC
** select-dialog
Modal wrapper around the ~select~ component. Presents a list of options
and calls ~on-select~ with the chosen value after dismissing.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun select-dialog (title options &key on-select)
(make-instance 'dialog
:title title
@@ -426,7 +240,14 @@ Remove a toast from the list.
:on-select (lambda (opt)
(pop-dialog)
(when on-select (funcall on-select opt))))))
#+END_SRC
** prompt-dialog
Modal wrapper around ~text-input~. Shows a text input field inside the
dialog and calls ~on-submit~ with the entered value after dismissing.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun prompt-dialog (title &key on-submit)
(make-instance 'dialog
:title title
@@ -435,13 +256,31 @@ Remove a toast from the list.
:on-submit (lambda (value)
(pop-dialog)
(when on-submit (funcall on-submit value))))))
#+END_SRC
;; ─── Toast system ─────────────────────────────────────────────────────────────
* Toast system
Transient notifications that appear in the top-right corner. Each toast
has a message and a variant that determines its color (~:info~,
~:success~, ~:warning~, ~:error~).
** toast class
Lightweight class storing the message text and variant keyword.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defclass toast ()
((message :initarg :message :accessor toast-message)
(variant :initarg :variant :initform :info :accessor toast-variant)))
#+END_SRC
** render-toast
Draws a toast in the top-right corner of the screen. The message is
truncated to 60 columns with an ellipsis if necessary. The background
color reflects the variant.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun render-toast (toast screen w)
(let* ((msg (toast-message toast))
(variant (toast-variant toast))
@@ -455,18 +294,40 @@ Remove a toast from the list.
msg)))
(draw-rect screen x 0 max-w 1 :bg color)
(draw-text screen (1+ x) 0 text :white color :bold t)))
#+END_SRC
** toast (function)
Fire-and-forget toast notification. Creates a ~toast~ instance, pushes
it onto =*toasts*~, and optionally schedules auto-dismissal via
~dismiss-toast~ when ~duration~ is positive.
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun toast (message &key (variant :info) (duration 0))
(let ((toast (make-instance 'toast :message message :variant variant)))
(push toast *toasts*)
(when (plusp duration) (dismiss-toast toast))
toast))
#+END_SRC
** dismiss-toast
Removes a toast from =*toasts*~ by identity (~remove~ with default
~:test #'eql~ compares by pointer for CLOS objects).
#+BEGIN_SRC lisp :tangle ../src/components/dialog.lisp
(defun dismiss-toast (toast)
(setf *toasts* (remove toast *toasts*)))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp :noweb no
* Tests
Test suite using FiveAM. Each test exercises one function or
interaction.
** Test package and suite
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
;;; dialog-tests.lisp — Tests for cl-tty.dialog
(defpackage :cl-tty-dialog-test
@@ -476,22 +337,47 @@ Remove a toast from the list.
(def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog")
(in-suite dialog-suite)
#+END_SRC
** dialog-create
Basic dialog instantiation — verifies ~make-instance~ and accessors.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
(def-test dialog-create ()
(let ((d (make-instance 'dialog :title "Test")))
(is-true (typep d 'dialog))
(is (equal "Test" (dialog-title d)))))
#+END_SRC
** dialog-size-small
~dialog-size-pixels~ returns the correct dimensions for ~:small~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
(def-test dialog-size-small ()
(multiple-value-bind (w h) (dialog-size-pixels :small)
(is (= 40 w))
(is (= 8 h))))
#+END_SRC
** dialog-size-medium
~dialog-size-pixels~ returns the correct dimensions for ~:medium~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
(def-test dialog-size-medium ()
(multiple-value-bind (w h) (dialog-size-pixels :medium)
(is (= 60 w))
(is (= 16 h))))
#+END_SRC
** dialog-push-pop
Verifies stack operations: push adds to =*dialog-stack*~, pop removes
the top element.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
(def-test dialog-push-pop ()
(let ((*dialog-stack* nil))
(push-dialog (make-instance 'dialog :title "D1"))
@@ -500,12 +386,24 @@ Remove a toast from the list.
(is (= 2 (length *dialog-stack*)))
(pop-dialog)
(is (= 1 (length *dialog-stack*)))))
#+END_SRC
** toast-create
Verifies that ~toast~ pushes onto =*toasts*~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
(def-test toast-create ()
(let ((*toasts* nil))
(toast "Hello" :variant :info :duration 0)
(is (= 1 (length *toasts*)))))
#+END_SRC
** toast-dismiss
Verifies that ~dismiss-toast~ removes the toast from =*toasts*~.
#+BEGIN_SRC lisp :tangle ../tests/dialog-tests.lisp
(def-test toast-dismiss ()
(let ((*toasts* (list (make-instance 'toast :message "T" :variant :info))))
(dismiss-toast (first *toasts*))

33
org/dirty.org
View File

@@ -40,8 +40,14 @@ inherit from this.
* Tests
** ~dirty-mixin-default-is-dirty~
This test verifies that a freshly created ~dirty-mixin~ instance starts
with ~dirty~ set to ~t~. This is the core invariant of the dirty tracking
system — without this, the first render pass would skip new components,
making them invisible until something explicitly marked them dirty.
#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp
;; Dirty tracking tests are in box-tests.lisp (same test suite)
(in-package :cl-tty-box-test)
(in-suite box-suite)
@@ -49,12 +55,37 @@ inherit from this.
"A dirty-mixin starts as dirty"
(let ((c (make-instance 'dirty-mixin)))
(is-true (dirty-p c) "new component should be dirty")))
#+END_SRC
** ~mark-clean-clears-dirty~
This test checks that calling ~mark-clean~ on a dirty component sets its
~dirty-p~ to ~nil~. This is called after a component is rendered,
signaling that it is up-to-date and does not need re-render until the
next change. Without this, every component would be re-rendered every
frame.
#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
(test mark-clean-clears-dirty
"mark-clean sets dirty to nil"
(let ((c (make-instance 'dirty-mixin)))
(mark-clean c)
(is-false (dirty-p c) "after mark-clean, should not be dirty")))
#+END_SRC
** ~mark-dirty-sets-dirty~
This test verifies that a component that has been cleaned can be
re-marked as dirty via ~mark-dirty~. This exercises the full lifecycle:
new (dirty) → render (mark-clean) → state change (mark-dirty) → render
again. It ensures the dirty flag is not a one-shot toggle.
#+BEGIN_SRC lisp :tangle ../src/components/dirty-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
(test mark-dirty-sets-dirty
"mark-dirty sets dirty to t"

377
org/framebuffer.org
View File

@@ -40,29 +40,59 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
4. Write tests
5. Run, commit
* Tests
* Tests (reference documentation, not tangled)
#+BEGIN_SRC lisp :tangle no
;; Tests for framebuffer pipeline — manually added to tests/framebuffer-tests.lisp
#+END_SRC
** Test package and suite setup
Setting up the test package with FiveAM, importing the rendering and backend
packages for use in all subsequent tests.
#+BEGIN_SRC lisp :tangle no
(defpackage :cl-tty-framebuffer-test
(:use :cl :fiveam :cl-tty.rendering :cl-tty.backend))
(in-package :cl-tty-framebuffer-test)
(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests")
(in-suite framebuffer-suite)
#+END_SRC
** Test: make-framebuffer creates correct size
Verify that the framebuffer constructor produces an array with the expected
dimensions. Height should match the first dimension (rows), width the second
dimension (columns).
#+BEGIN_SRC lisp :tangle no
(test make-framebuffer-creates-correct-size
(let ((fb (make-framebuffer 80 24)))
(is (= 24 (framebuffer-height fb)))
(is (= 80 (framebuffer-width fb)))))
#+END_SRC
** Test: cell defaults are space
Cells created via MAKE-CELL with no arguments should default to a space
character with nil foreground and background — a blank, unstyled cell.
#+BEGIN_SRC lisp :tangle no
(test cell-defaults-are-space
(let ((cell (aref (make-framebuffer 10 10) 0 0)))
(is (eql #\space (cell-char cell)))
(is (null (cell-fg cell)))
(is (null (cell-bg cell)))))
#+END_SRC
** Test: draw-text on framebuffer sets cells
Drawing a string into the framebuffer backend should set the character and
foreground color at each cell position. Characters should appear at the expected
(x, y) offsets.
#+BEGIN_SRC lisp :tangle no
(test draw-text-on-fb-sets-cells
(let ((fb (make-framebuffer-backend)))
(draw-text fb 2 3 "abc" :red nil)
@@ -71,7 +101,15 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(is (eql #\b (cell-char (aref cells 3 3))))
(is (eql #\c (cell-char (aref cells 3 4))))
(is (eql :red (cell-fg (aref cells 3 2)))))))
#+END_SRC
** Test: draw-text clips at bounds
When drawing text that extends past the right edge of the framebuffer, cells
beyond the width should remain unchanged (space characters). This prevents
buffer overflow and undefined memory access.
#+BEGIN_SRC lisp :tangle no
(test draw-text-clips-at-bounds
(let ((fb (make-framebuffer-backend :width 10 :height 5)))
(draw-text fb 8 2 "hello" nil nil)
@@ -79,12 +117,26 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(is (eql #\h (cell-char (aref cells 2 8))))
(is (eql #\e (cell-char (aref cells 2 9))))
(is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored"))))
#+END_SRC
** Test: diff of identical framebuffers returns empty
Two framebuffers with identical cells should produce no changes. The diff
engine must short-circuit when no cells differ.
#+BEGIN_SRC lisp :tangle no
(test diff-identical-fbs-returns-empty
(let ((fb1 (make-framebuffer 80 24))
(fb2 (make-framebuffer 80 24)))
(is (null (diff-framebuffers fb1 fb2)))))
#+END_SRC
** Test: diff of changed framebuffer returns changes
After modifying a single cell in one framebuffer, the diff engine should return
exactly one change with the correct coordinates and cell data.
#+BEGIN_SRC lisp :tangle no
(test diff-changed-fb-returns-changes
(let* ((fb1 (make-framebuffer 10 10))
(fb2 (make-framebuffer 10 10)))
@@ -95,7 +147,14 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(is (= 5 x))
(is (= 5 y))
(is (eql #\X (cell-char cell)))))))
#+END_SRC
** Test: with-scissor clips drawing
When a scissor rectangle is active, drawing operations outside the rectangle
should be clipped away. Operations inside the rectangle should proceed normally.
#+BEGIN_SRC lisp :tangle no
(test with-scissor-clips-drawing
(let ((fb (make-framebuffer-backend :width 20 :height 10)))
(with-scissor (fb 5 5 3 3)
@@ -104,7 +163,14 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(let ((cells (fb-framebuffer fb)))
(is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws")
(is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped"))))
#+END_SRC
** Test: flush-fb copies to backend
After drawing on a framebuffer backend and flushing to a real backend, at least
one cell change should be detected and forwarded to the output backend.
#+BEGIN_SRC lisp :tangle no
(test flush-fb-copies-to-backend
(let* ((real-be (make-simple-backend :output-stream (make-string-output-stream)))
(fb (make-framebuffer-backend)))
@@ -115,7 +181,12 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
* Implementation
** Package and data structures
** Package definition
The ~cl-tty.rendering~ package exports all public symbols: the ~cell~ struct,
framebuffer backend class, constructor, diff/flush utilities, scissor macro,
and frame-inspection functions. It depends on ~:cl-tty.backend~ for the
~backend~ base class and protocol methods.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defpackage :cl-tty.rendering
@@ -131,11 +202,23 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
#:extract-text #:fb-cell-link-url))
#+END_SRC
** Package switch
Switch to the ~cl-tty.rendering~ package for all subsequent definitions.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(in-package :cl-tty.rendering)
#+END_SRC
;;; ─── Cell — immutable per-cell state ─────────────────────────────────────────
** Cell — immutable per-cell state
The ~cell~ struct represents a single terminal cell. By making it a struct
(rather than a class) we get value semantics: copying is cheap and cells are
compared by value during diffing. All fields have sensible defaults so that
~make-cell~ with no arguments produces a blank space cell. The ~link-url~
slot enables OSC-8 hyperlink support for clickable text.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defstruct cell
"A single terminal cell — character, colors, and attributes."
(char #\space :type character)
@@ -145,32 +228,68 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(italic nil :type boolean)
(underline nil :type boolean)
(link-url nil))
#+END_SRC
;;; ─── Framebuffer — 2D array of cells ────────────────────────────────────────
** Framebuffer — 2D array of cells
*** make-framebuffer
Create a two-dimensional array of ~cell~ structs with HEIGHT rows and WIDTH
columns. Using ~:initial-element (make-cell)~ ensures every cell is a fresh
struct instance (not shared). The ~:element-type~ declaration is a hint for
potential optimizations.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun make-framebuffer (width height)
"Create a 2D array of CELL with dimensions HEIGHT x WIDTH."
(make-array (list height width)
:initial-element (make-cell)
:element-type 'cell))
#+END_SRC
*** framebuffer-width, framebuffer-height
Accessors that return the dimensions of a framebuffer array. These guard
against non-array values (returning 0) so that callers don't crash on nil or
uninitialized framebuffer slots.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun framebuffer-width (fb)
"Return the width (columns) of framebuffer FB."
(if (arrayp fb) (array-dimension fb 1) 0))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun framebuffer-height (fb)
"Return the height (rows) of framebuffer FB."
(if (arrayp fb) (array-dimension fb 0) 0))
#+END_SRC
;;; ─── Framebuffer Backend — implements backend protocol ─────────────────────
** Framebuffer Backend — implements backend protocol
*** framebuffer-backend class
The ~framebuffer-backend~ class subclasses ~backend~ and stores a 2D cell array
plus scissor-clipping state. All drawing methods on this backend write to the
cell array instead of emitting escape sequences. The scissor coordinates are
used by ~%in-scissor-p~ to clip drawing during component rendering.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defclass framebuffer-backend (backend)
((framebuffer :initform nil :accessor fb-framebuffer)
(scissor-x :initform 0 :accessor fb-scissor-x)
(scissor-y :initform 0 :accessor fb-scissor-y)
(scissor-w :initform nil :accessor fb-scissor-w)
(scissor-h :initform nil :accessor fb-scissor-h)))
#+END_SRC
*** make-framebuffer-backend
Constructor that creates a ~framebuffer-backend~ instance and initializes its
framebuffer array to the given dimensions (defaulting to 80x24, a common
terminal size).
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun make-framebuffer-backend (&key (width 80) (height 24))
"Create a framebuffer-backend with a fresh framebuffer."
(let ((fb (make-instance 'framebuffer-backend)))
@@ -178,18 +297,33 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
fb))
#+END_SRC
** Drawing methods
** Drawing helpers
*** %in-scissor-p
Predicate that checks whether a cell at (CX, CY) falls within the active
scissor rectangle. If either scissor dimension is nil (meaning no scissor is
set), the corresponding axis check is skipped, effectively treating the entire
framebuffer as the drawable area.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
;;; ─── Drawing methods ─────────────────────────────────────────────────────────
(defun %in-scissor-p (fb cx cy)
"Check if (CX, CY) falls within the current scissor rectangle."
(let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb))
(sw (fb-scissor-w fb)) (sh (fb-scissor-h fb)))
(and (or (null sw) (and (>= cx sx) (< cx (+ sx sw))))
(or (null sh) (and (>= cy sy) (< cy (+ sy sh)))))))
#+END_SRC
*** %set-cell
Low-level cell-writer that performs bounds checking and scissor clipping before
assigning a new cell. This is the single choke-point where all drawing
ultimately lands, ensuring consistent clipping behavior across all drawing
operations. Only cells within both the framebuffer dimensions and the active
scissor rectangle are written.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun %set-cell (fb x y char &key fg bg bold italic underline link-url)
"Set cell (X, Y) if within bounds and scissor."
(let ((cells (fb-framebuffer fb)))
@@ -200,7 +334,19 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(make-cell :char char :fg fg :bg bg
:bold bold :italic italic :underline underline
:link-url link-url)))))
#+END_SRC
** Drawing methods
*** draw-text
Render a string of characters starting at position (X, Y), one cell per
character. Each cell is set via ~%set-cell~ so bounds checking and scissor
clipping apply automatically. The ~&allow-other-keys~ permits passing
style-related keyword arguments that other backends may use but the framebuffer
does not need (e.g., reverse, dim, blink).
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defmethod draw-text ((fb framebuffer-backend) x y string fg bg
&key bold italic underline reverse dim blink
(link-url nil link-url-p)
@@ -211,12 +357,30 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
:fg fg :bg bg
:bold bold :italic italic :underline underline
:link-url link-url)))
#+END_SRC
*** draw-rect
Fill a rectangular region with space characters and an optional background
color. This is used for clearing areas and rendering background fills for
panels and widgets. Iterates row by row, column by column, using ~%set-cell~ so
scissor clipping is respected.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg)
(dotimes (row h)
(dotimes (col w)
(%set-cell fb (+ x col) (+ y row) #\space :fg nil :bg bg))))
#+END_SRC
*** draw-border
Draws a border around a rectangular region, optionally rendering a title
string at the top edge. Supports three border styles: :single, :double, and
:rounded, each using different corner and line characters. The title is drawn
starting two cells from the left edge, overwriting top-edge characters.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg)
(let* ((chars (case style
(:single '(#\+ #\- #\|))
@@ -240,7 +404,15 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(when title
(loop for i from 0 below (length title)
do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg)))))
#+END_SRC
*** backend-clear
Clears every cell in the framebuffer to a fresh default cell (space, no style).
This is the ~backend-clear~ protocol method specialized on ~framebuffer-backend~,
providing a full-frame reset used between render passes.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defmethod backend-clear ((fb framebuffer-backend))
(let ((cells (fb-framebuffer fb)))
(dotimes (y (framebuffer-height cells))
@@ -248,19 +420,42 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(setf (aref cells y x) (make-cell))))))
#+END_SRC
** Diff and flush
** Link and ellipsis methods
*** draw-link
Draws text with an associated OSC-8 hyperlink URL. The framebuffer backend
stores the URL in the cell's ~link-url~ slot for later retrieval (e.g., on
mouse click). The actual OSC-8 escape sequence rendering is deferred to the
real backend during flush.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg)
;; OSC 8 links are not rendered in framebuffer — store as text
(draw-text fb x y string fg bg :link-url url))
#+END_SRC
*** draw-ellipsis
Renders a horizontal ellipsis (up to 3 periods) starting at position (X, Y).
Width is capped at 3 characters to prevent overflow into adjacent cells.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg)
(dotimes (i (min 3 width))
(%set-cell fb (+ x i) y #\. :fg fg :bg bg)))
#+END_SRC
;;; ─── Diff ────────────────────────────────────────────────────────────────────
** Diff engine
*** cells-equal-p
Compares two ~cell~ structs field by field to determine if they represent the
same visual output. Uses ~eql~ for characters, symbols, and booleans, and
~equal~ for string comparison of ~link-url~. This predicate drives the diff
algorithm — only cells that differ are flushed.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun cells-equal-p (a b)
"Return T if two cells have identical content and style."
(and (eql (cell-char a) (cell-char b))
@@ -270,7 +465,16 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(eql (cell-italic a) (cell-italic b))
(eql (cell-underline a) (cell-underline b))
(equal (cell-link-url a) (cell-link-url b))))
#+END_SRC
*** diff-framebuffers
The core difference algorithm: iterate over the overlapping region of two
framebuffers and collect a list of (X Y CELL) triples for every cell that
changed. Using ~nreverse~ at the end ensures stable ordering (top-to-bottom,
left-to-right) without consing during accumulation.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun diff-framebuffers (prev curr)
"Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes."
(let ((changes nil)
@@ -282,9 +486,19 @@ See =docs/plans/2026-05-11-rendering-pipeline.md= for full implementation plan.
(unless (cells-equal-p a b)
(push (list x y b) changes)))))
(nreverse changes)))
#+END_SRC
;;; ─── Flush ───────────────────────────────────────────────────────────────────
** Flush
*** flush-framebuffer
Orchestrates the full diff-and-flush cycle. Computes the difference between
previous and current framebuffers, then replays changes to a real backend using
minimal cursor movement (tracking the current row to avoid redundant cursor
positioning). Returns the count of changed cells so callers can monitor
rendering overhead.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun flush-framebuffer (prev-fb curr-fb backend)
"Diff PREV-FB and CURR-FB and flush changes to BACKEND.
Returns the number of changed cells."
@@ -309,16 +523,29 @@ Returns the number of changed cells."
** Frame inspection (for mouse selection / link clicking)
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
;;; --- Frame inspection ---------------------------------------------------
*** fb-cell-link-url
Retrieves the hyperlink URL stored at cell position (X, Y) in a framebuffer
array. Returns nil if the cell is out of bounds or has no link. This enables
click-to-open-link functionality in the TUI.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun fb-cell-link-url (fb x y)
"Return the link URL at (X Y) in framebuffer FB, or nil."
(when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0))
(>= x 0) (< x (array-dimension fb 1)))
(let ((c (aref fb y x)))
(cell-link-url c))))
#+END_SRC
*** extract-text
Extracts visible text from a rectangular region of the framebuffer, useful for
mouse selection and clipboard operations. Normalizes coordinate order (so the
user can drag in any direction) and appends newlines between rows for natural
multi-line text.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defun extract-text (fb x1 y1 x2 y2)
"Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)."
(let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2)))
@@ -335,9 +562,14 @@ Returns the number of changed cells."
** Scissor clipping
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
;;; ─── Scissor clipping ────────────────────────────────────────────────────────
*** with-scissor
A macro that temporarily sets the scissor rectangle on a framebuffer backend
for the duration of BODY. Saves and restores previous scissor state via
~unwind-protect~ for proper cleanup even on non-local exits. Using gensyms for
the state variables ensures no variable capture issues.
#+BEGIN_SRC lisp :tangle ../src/rendering/framebuffer.lisp
(defmacro with-scissor ((fb x y w h) &body body)
"Clip all drawing on FB to rectangle (X Y W H)."
(let ((old-x (gensym)) (old-y (gensym))
@@ -357,7 +589,13 @@ Returns the number of changed cells."
(fb-scissor-h ,fb) ,old-h)))))
#+END_SRC
** Tests
* Tests
** Test package and suite setup
Setting up the test package with FiveAM, importing the rendering and backend
packages for use in all subsequent tests. This block tangles to the test file
that is loaded by the test runner.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(defpackage :cl-tty-framebuffer-test
@@ -366,18 +604,41 @@ Returns the number of changed cells."
(def-suite framebuffer-suite :description "Framebuffer rendering pipeline tests")
(in-suite framebuffer-suite)
#+END_SRC
** Test: make-framebuffer creates correct size
Verify that the framebuffer constructor produces an array with the expected
dimensions. Height should match the first dimension (rows), width the second
dimension (columns).
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test make-framebuffer-creates-correct-size
(let ((fb (make-framebuffer 80 24)))
(is (= 24 (framebuffer-height fb)))
(is (= 80 (framebuffer-width fb)))))
#+END_SRC
** Test: cell defaults are space
Cells created via MAKE-CELL with no arguments should default to a space
character with nil foreground and background — a blank, unstyled cell.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test cell-defaults-are-space
(let ((cell (aref (make-framebuffer 10 10) 0 0)))
(is (eql #\space (cell-char cell)))
(is (null (cell-fg cell)))
(is (null (cell-bg cell)))))
#+END_SRC
** Test: draw-text on framebuffer sets cells
Drawing a string into the framebuffer backend should set the character and
foreground color at each cell position. Characters should appear at the expected
(x, y) offsets.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test draw-text-on-fb-sets-cells
(let ((fb (make-framebuffer-backend)))
(draw-text fb 2 3 "abc" :red nil)
@@ -386,7 +647,15 @@ Returns the number of changed cells."
(is (eql #\b (cell-char (aref cells 3 3))))
(is (eql #\c (cell-char (aref cells 3 4))))
(is (eql :red (cell-fg (aref cells 3 2)))))))
#+END_SRC
** Test: draw-text clips at bounds
When drawing text that extends past the right edge of the framebuffer, cells
beyond the width should remain unchanged (space characters). This prevents
buffer overflow and undefined memory access.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test draw-text-clips-at-bounds
(let ((fb (make-framebuffer-backend :width 10 :height 5)))
(draw-text fb 8 2 "hello" nil nil)
@@ -394,12 +663,26 @@ Returns the number of changed cells."
(is (eql #\h (cell-char (aref cells 2 8))))
(is (eql #\e (cell-char (aref cells 2 9))))
(is (eql #\space (cell-char (aref cells 2 0))) "out of bounds text is ignored"))))
#+END_SRC
** Test: diff of identical framebuffers returns empty
Two framebuffers with identical cells should produce no changes. The diff
engine must short-circuit when no cells differ.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test diff-identical-fbs-returns-empty
(let ((fb1 (make-framebuffer 80 24))
(fb2 (make-framebuffer 80 24)))
(is (null (diff-framebuffers fb1 fb2)))))
#+END_SRC
** Test: diff of changed framebuffer returns changes
After modifying a single cell in one framebuffer, the diff engine should return
exactly one change with the correct coordinates and cell data.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test diff-changed-fb-returns-changes
(let* ((fb1 (make-framebuffer 10 10))
(fb2 (make-framebuffer 10 10)))
@@ -410,7 +693,14 @@ Returns the number of changed cells."
(is (= 5 x))
(is (= 5 y))
(is (eql #\X (cell-char cell)))))))
#+END_SRC
** Test: with-scissor clips drawing
When a scissor rectangle is active, drawing operations outside the rectangle
should be clipped away. Operations inside the rectangle should proceed normally.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test with-scissor-clips-drawing
(let ((fb (make-framebuffer-backend :width 20 :height 10)))
(with-scissor (fb 5 5 3 3)
@@ -419,7 +709,16 @@ Returns the number of changed cells."
(let ((cells (fb-framebuffer fb)))
(is (eql #\A (cell-char (aref cells 6 6))) "inside scissor draws")
(is (eql #\space (cell-char (aref cells 1 1))) "outside scissor is clipped"))))
#+END_SRC
** Test: flush handles different-sized framebuffers
When comparing framebuffers of different sizes, only the overlapping region
should be diffed. This test verifies correct behavior at both the smaller and
larger end of the size mismatch — ensuring edge cells in the non-overlapping
region are ignored.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test flush-different-sized-fbs-handles-edge-cells
(let* ((small-fb (make-framebuffer 5 5))
(large-fb (make-framebuffer 10 10))
@@ -434,34 +733,80 @@ Returns the number of changed cells."
(is (= 1 (length changes2)) "only overlapping region diffed"))
(let ((changed2 (flush-framebuffer large-fb small-fb be)))
(is (= 1 changed2) "flush with shrunk fb reports 1 changed cell"))))
#+END_SRC
** Test: flush-fb copies to backend
After drawing on a framebuffer backend and flushing to a real backend, at least
one cell change should be detected and forwarded to the output backend.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test flush-fb-copies-to-backend
(let* ((real-be (make-simple-backend :output-stream (make-string-output-stream)))
(fb (make-framebuffer-backend)))
(draw-text fb 0 0 "X" :red nil)
(let ((changed (flush-framebuffer (make-framebuffer 80 24) (fb-framebuffer fb) real-be)))
(is (>= changed 1)))))
#+END_SRC
** Test: fb-cell-link-url returns nil for blank cell
A cell without a hyperlink should return nil from ~fb-cell-link-url~, ensuring
the default state is correct and no spurious URL is reported.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test fb-cell-link-url-returns-nil-for-blank-cell
(let ((fb (make-framebuffer 10 10)))
(is (null (fb-cell-link-url fb 5 5)))))
#+END_SRC
** Test: fb-cell-link-url finds link-url
After drawing text with a link-url, the corresponding cell should return that
URL. Cells at other positions should still return nil. This validates that
link metadata is stored per-cell and correctly retrievable.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test fb-cell-link-url-finds-link-url
(let ((fb (make-framebuffer-backend)))
(draw-text fb 0 0 "click" nil nil :link-url "https://example.com")
(is (equal "https://example.com" (fb-cell-link-url (fb-framebuffer fb) 0 0)))
(is (null (fb-cell-link-url (fb-framebuffer fb) 5 5)))))
#+END_SRC
** Test: fb-cell-link-url out of bounds returns nil
Querying a cell position outside the framebuffer dimensions should gracefully
return nil rather than erroring, which prevents crashes during mouse event
processing at the edges of the terminal.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test fb-cell-link-url-out-of-bounds-returns-nil
(let ((fb (make-framebuffer 5 5)))
(is (null (fb-cell-link-url fb 10 10)))))
#+END_SRC
** Test: extract-text single row
Extracting text from a single row of the framebuffer should return the
characters in that row as a contiguous string, preserving order and including
only visible characters.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test extract-text-single-row
(let ((fb (make-framebuffer-backend)))
(draw-text fb 0 0 "hello" nil nil)
(let ((cells (fb-framebuffer fb)))
(is (equal "hello" (extract-text cells 0 0 4 0))))))
#+END_SRC
** Test: extract-text multi-row
Extracting text from a rectangle spanning multiple rows should concatenate
rows with newline separators. This matches the expected behavior for clipboard
copy of rectangular selections in the TUI.
#+BEGIN_SRC lisp :tangle ../tests/framebuffer-tests.lisp
(test extract-text-multi-row
(let ((fb (make-framebuffer-backend)))
(draw-text fb 0 0 "abc" nil nil)

247
org/layout-engine.org
View File

@@ -42,42 +42,96 @@ unnecessary — ~200 lines of CL math suffices.
* Tests
** Test package definition
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
(defpackage :cl-tty-layout-test
(:use :cl :fiveam :cl-tty.layout)
(:export #:run-tests))
(in-package :cl-tty-layout-test)
#+END_SRC
** Test suite
~fiveam~ suites collect related tests under a descriptive name for
batch execution.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(def-suite layout-suite :description "Layout engine tests")
(in-suite layout-suite)
#+END_SRC
** Test runner
~run-tests~ provides a convenient entry point that prints results and
exits cleanly for CI or batch runs.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(defun run-tests ()
(let ((result (run 'layout-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
** Test: make-layout-node defaults
Verify that a node created with no arguments has the correct default
direction ~:column~ and is of type ~layout-node~.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test make-layout-node-defaults
(let ((n (make-layout-node)))
(is (typep n 'layout-node))
(is (eql (layout-node-direction n) :column))))
#+END_SRC
** Test: make-layout-node with ~:row~
Verify that passing ~:direction :row~ produces a node whose direction
slot reflects that choice.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test make-layout-node-row
(let ((n (make-layout-node :direction :row)))
(is (eql (layout-node-direction n) :row))))
#+END_SRC
** Test: add-child sets parent
Children must have their ~parent~ back-pointer set when added, and
the parent's ~children~ list must contain the child.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test add-child-sets-parent
(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))))
#+END_SRC
** Test: remove-child clears parent
Removing a child should clear its parent reference and remove it
from the parent's ~children~ list.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test remove-child-clears-parent
(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))))
#+END_SRC
** Test: column lays out two children vertically
In a column layout, children stack top-to-bottom. The first child
starts at y=0; the second starts below the first.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test column-two-children-vertical
(let* ((root (make-layout-node :direction :column))
(c1 (make-layout-node :height 3))
@@ -86,7 +140,14 @@ unnecessary — ~200 lines of CL math suffices.
(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))))
#+END_SRC
** Test: row lays out two children horizontally
In a row layout, children stack left-to-right. The first child starts
at x=0; the second starts to the right of the first.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test row-two-children-horizontal
(let* ((root (make-layout-node :direction :row))
(c1 (make-layout-node :width 10))
@@ -95,7 +156,15 @@ unnecessary — ~200 lines of CL math suffices.
(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))))
#+END_SRC
** Test: flex-grow distributes remaining space proportionally
When children have different ~grow~ values, remaining space is
divided in proportion to those values. A child with grow=2 gets
twice as much extra space as a child with grow=1.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test flex-grow-distributes-space
(let* ((root (make-layout-node :direction :row :width 20))
(c1 (make-layout-node :width 4 :grow 1))
@@ -103,14 +172,28 @@ unnecessary — ~200 lines of CL math suffices.
(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))))
#+END_SRC
** Test: flex-grow single child fills container
A single flexible child with ~grow~ set should expand to fill all
available space in the container.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test flex-grow-single-child
(let* ((root (make-layout-node :direction :row :width 20))
(c (make-layout-node :width 5 :grow 1)))
(layout-node-add-child root c)
(compute-layout root 20 10)
(is (= (layout-node-width c) 20))))
#+END_SRC
** Test: flex-shrink reduces overflow proportionally
When children exceed the container size, each child shrinks in
proportion to its ~shrink~ value.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test flex-shrink-reduces-overflow
(let* ((root (make-layout-node :direction :row :width 10))
(c1 (make-layout-node :width 8 :shrink 1))
@@ -118,7 +201,14 @@ unnecessary — ~200 lines of CL math suffices.
(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))))
#+END_SRC
** Test: padding reduces content area
Padding insets the child rendering area. Children are offset by the
padding values and sized to the remaining space.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test padding-reduces-content-area
(let* ((root (make-layout-node :direction :column :padding '(:top 1 :left 1 :bottom 1 :right 1)))
(c (make-layout-node :height 3)))
@@ -126,7 +216,14 @@ unnecessary — ~200 lines of CL math suffices.
(compute-layout root 20 10)
(is (= (layout-node-x c) 1)) (is (= (layout-node-y c) 1))
(is (= (layout-node-height c) 3))))
#+END_SRC
** Test: gap between children
The ~gap~ property inserts spacing between consecutive children
without adding space before the first or after the last.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test gap-between-children
(let* ((root (make-layout-node :direction :column :gap 2))
(c1 (make-layout-node :height 3))
@@ -134,25 +231,55 @@ unnecessary — ~200 lines of CL math suffices.
(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))))
#+END_SRC
** Test: vbox macro
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
(test vbox-macro
(let ((r (vbox () (make-layout-node :height 3) (make-layout-node :height 5))))
(compute-layout r 20 20)
(is (= (length (layout-node-children r)) 2))
(is (= (layout-node-y (elt (layout-node-children r) 1)) 3))))
#+END_SRC
** Test: hbox macro
The ~hbox~ macro creates a row-direction container. The second
child's x-offset should equal the first child's width.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test hbox-macro
(let ((r (hbox () (make-layout-node :width 5) (make-layout-node :width 3))))
(compute-layout r 20 10)
(is (= (length (layout-node-children r)) 2))
(is (= (layout-node-x (elt (layout-node-children r) 1)) 5))))
#+END_SRC
** Test: spacer takes grow
The ~spacer~ macro creates a flexible node that pushes siblings
apart. With two fixed-width children and a spacer between them, the
spacer absorbs all remaining width.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test spacer-takes-grow
(let ((r (hbox (:width 20) (make-layout-node :width 5) (spacer :grow 1) (make-layout-node :width 5))))
(compute-layout r 20 10)
(let ((c (layout-node-children r)))
(is (= (layout-node-x (elt c 2)) 15)) (is (= (layout-node-width (elt c 1)) 10)))))
#+END_SRC
** Test: nested vbox in hbox
Nesting a column layout inside a row layout exercises the recursive
solver. Sidebar gets fixed width; main content stretches.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test nested-vbox-in-hbox
(let* ((sidebar (vbox (:width 5 :height 10) (make-layout-node :height 3) (make-layout-node :height 7)))
(main (vbox (:grow 1 :height 10) (make-layout-node :height 2) (make-layout-node :grow 1)))
@@ -163,15 +290,27 @@ unnecessary — ~200 lines of CL math suffices.
(let ((sc (layout-node-children sidebar)))
(is (= (layout-node-y (elt sc 0)) 0))
(is (= (layout-node-y (elt sc 1)) 3)))))
#+END_SRC
;; ── Edge Cases ────────────────────────────────────────────────
** Test: empty container does not crash
Layout must gracefully handle containers with no children, returning
valid integer dimensions.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test empty-container-does-not-crash
(let ((r (make-layout-node)))
(compute-layout r 20 20)
(is (integerp (layout-node-width r)))
(is (integerp (layout-node-height r)))))
#+END_SRC
** Test: single child in column
A column with one child positions it at the origin and sizes it to
its requested height. Width is inherited from the container.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test single-child-in-column
(let* ((r (make-layout-node :direction :column :width 10 :height 20))
(c (make-layout-node :height 5)))
@@ -179,7 +318,14 @@ unnecessary — ~200 lines of CL math suffices.
(compute-layout r 10 20)
(is (= (layout-node-y c) 0))
(is (= (layout-node-height c) 5))))
#+END_SRC
** Test: zero-size container
When available space is zero, the solver must still produce valid
integer coordinates without crashing or producing NaN/infinite values.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test zero-size-container
(let* ((r (make-layout-node :direction :column))
(c (make-layout-node :height 5)))
@@ -187,7 +333,14 @@ unnecessary — ~200 lines of CL math suffices.
(compute-layout r 0 0)
(is (integerp (layout-node-x c)))
(is (integerp (layout-node-y c)))))
#+END_SRC
** Test: deep nesting three levels
Three levels of nested vboxes ensure that layout is computed
correctly for deeply nested subtrees.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test deep-nesting-three-levels
(let* ((out (vbox ()
(vbox (:grow 1)
@@ -196,7 +349,14 @@ unnecessary — ~200 lines of CL math suffices.
(elt (layout-node-children out) 0)) 0)))
(compute-layout out 20 20)
(is (= (layout-node-y leaf) 0))))
#+END_SRC
** Test: large padding leaves room
Substantial padding on all sides should offset children inward by the
full padding amount.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test large-padding-leaves-room
(let* ((r (make-layout-node :direction :column
:padding '(:top 5 :left 5 :bottom 5 :right 5)))
@@ -205,7 +365,14 @@ unnecessary — ~200 lines of CL math suffices.
(compute-layout r 20 20)
(is (= (layout-node-x c) 5))
(is (= (layout-node-y c) 5))))
#+END_SRC
** Test: negative grow is clamped
A negative ~grow~ value should not cause layout errors. The solver
treats it as zero for distribution purposes and produces valid output.
#+BEGIN_SRC lisp :tangle ../src/layout/tests.lisp
(test negative-grow-is-clamped
(let* ((r (make-layout-node :direction :row :width 10))
(c (make-layout-node :width 5 :grow -1)))
@@ -218,6 +385,11 @@ unnecessary — ~200 lines of CL math suffices.
** Package
The ~cl-tty.layout~ package exports all public symbols for creating
and manipulating layout trees. Internal accessors like
~layout-node-parent~ and helpers like ~normalize-box~ are also
exported for testing.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defpackage :cl-tty.layout
(:use :cl)
@@ -239,8 +411,11 @@ unnecessary — ~200 lines of CL math suffices.
** Box model utilities
*** normalize-box
~normalize-box~ converts nil, number, or plist inputs to a canonical
plist. ~box-edge~ extracts the value for a specific edge.
plist. This normalisation layer means users can pass ~:padding 2~ or
~:padding '(:top 1 :left 2)~ interchangeably throughout the API.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defun normalize-box (spec)
@@ -250,13 +425,27 @@ plist. ~box-edge~ extracts the value for a specific edge.
for (key val) on spec by #'cddr
do (setf (getf result key) val)
finally (return result)))))
#+END_SRC
*** box-edge
~box-edge~ extracts the value for a specific edge keyword from a
canonical box plist, defaulting to zero if the key is not present.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defun box-edge (box edge)
(or (getf box edge) 0))
#+END_SRC
** Layout node class
The ~layout-node~ class holds all properties needed by the flexbox
layout algorithm. Slots are split between tree structure (~parent~,
~children~), computed layout results (~x~, ~y~, ~width~, ~height~),
and input constraints (~direction~, ~grow~, ~shrink~, ~padding~,
~margin~, ~gap~, ~position-type~, ~position-offset~, ~fixed-width~,
~fixed-height~).
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defclass layout-node ()
((parent :initform nil :accessor layout-node-parent)
@@ -279,6 +468,10 @@ plist. ~box-edge~ extracts the value for a specific edge.
** Constructor
~make-layout-node~ is the primary constructor. It normalises all
keyword arguments through ~normalize-box~ for padding/margin, fills
defaults for missing values, and delegates to ~make-instance~.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defun make-layout-node (&key direction grow shrink padding margin gap
position-type position-offset width height)
@@ -294,13 +487,27 @@ plist. ~box-edge~ extracts the value for a specific edge.
** Tree manipulation
*** layout-node-add-child
~layout-node-add-child~ attaches a child to a parent by setting the
child's parent back-pointer and appending to the parent's children
list. Returns the child for convenience in chaining or ~let~ forms.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defun layout-node-add-child (parent child)
(setf (layout-node-parent child) parent)
(setf (layout-node-children parent)
(nconc (layout-node-children parent) (list child)))
child)
#+END_SRC
*** layout-node-remove-child
~layout-node-remove-child~ detaches a child by clearing its parent
back-pointer and removing it from the parent's children list.
Returns the child.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defun layout-node-remove-child (parent child)
(setf (layout-node-parent child) nil)
(setf (layout-node-children parent)
@@ -310,10 +517,12 @@ plist. ~box-edge~ extracts the value for a specific edge.
** Constraint solver
~distribute-sizes~ computes child sizes given available space and gap.
Each child starts from its fixed size. Remaining space is distributed
by grow ratio; overflow is reduced by shrink ratio. Rounding errors
are amortized across the first N children.
*** distribute-sizes
~distribute-sizes~ computes child sizes given available space and
gap. Each child starts from its fixed size. Remaining space is
distributed by grow ratio; overflow is reduced by shrink ratio.
Rounding errors are amortized across the first N children.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defun distribute-sizes (children avail gap horizontal)
@@ -346,9 +555,13 @@ are amortized across the first N children.
sizes)))
#+END_SRC
*** compute-layout
~compute-layout~ recursively lays out all children of the root node
within given dimensions. It positions each child at the correct
(x, y) coordinate and sizes it to fill the available space.
(x, y) coordinate and sizes it to fill the available space. The
inner ~labels~ form ~place-children~ handles the recursive descent,
adjusting for padding and direction at each level.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defun compute-layout (root available-width available-height)
@@ -409,6 +622,12 @@ within given dimensions. It positions each child at the correct
** Composable macros
*** vbox
~vbox~ creates a column-direction container with optional layout
properties and adds all children via ~layout-node-add-child~. The
~gensym~ ensures no variable capture in the expansion.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defmacro vbox ((&key grow shrink padding margin gap width height) &body children)
(let ((n (gensym)))
@@ -422,7 +641,14 @@ within given dimensions. It positions each child at the correct
,@(when height `(:height ,height)))))
,@(loop for c in children collect `(layout-node-add-child ,n ,c))
,n)))
#+END_SRC
*** hbox
~hbox~ creates a row-direction container, structurally identical to
~vbox~ except the ~:direction~ is ~:row~.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defmacro hbox ((&key grow shrink padding margin gap width height) &body children)
(let ((n (gensym)))
`(let ((,n (make-layout-node :direction :row
@@ -435,7 +661,14 @@ within given dimensions. It positions each child at the correct
,@(when height `(:height ,height)))))
,@(loop for c in children collect `(layout-node-add-child ,n ,c))
,n)))
#+END_SRC
*** spacer
~spacer~ creates a minimal flex-grow node that fills remaining space,
defaulting to ~grow 1~ when no keyword is given.
#+BEGIN_SRC lisp :tangle ../src/layout/layout.lisp
(defmacro spacer (&key grow)
`(make-layout-node :grow ,(or grow 1)))
#+END_SRC

346
org/markdown-renderer.org
View File

@@ -25,13 +25,33 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
** Main module
The main module file header includes the package declaration and a
comment indicating the file's purpose. This block is the first to
target ~markdown.lisp~ and thus overwrites any previous content;
all subsequent blocks append.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
;;; markdown.lisp — Markdown + Code + Diff rendering for cl-tty
(in-package :cl-tty.markdown)
#+END_SRC
;; ─── Node constructors ────────────────────────────────────────────────────────
*** Node constructors
Node constructors provide a uniform way to build the AST for parsed
Markdown. Using plists (property lists) with a ~:type~ key gives us
flexibility — we can attach arbitrary metadata without a rigid class
hierarchy, which keeps the parser simple and the data easy to
introspect from the REPL.
**** make-md-node
~make-md-node~ is the primary constructor. It accepts a required ~type~
symbol and optional keyword arguments for ~children~, ~properties~,
~content~, and ~url~. Only non-nil slots are stored, keeping the
plist compact.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun make-md-node (type &key children properties content url)
(let ((node (list :type type)))
(when children (setf (getf node :children) children))
@@ -39,10 +59,28 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(when content (setf (getf node :content) content))
(when url (setf (getf node :url) url))
node))
#+END_SRC
**** md-node-p
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
(defun md-node-p (thing)
(and (listp thing) (getf thing :type)))
#+END_SRC
**** md-node-text
~md-node-text~ recursively extracts the plain-text representation of a
node tree. The ~:link~ type formats as ~text (url)~; ~:text~ and
~:inline-code~ return their content directly; other container types
concatenate their children's text. This is useful for summarisation
and testing.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun md-node-text (node)
(let ((type (getf node :type)))
(cond ((eql type :text) (or (getf node :content) ""))
@@ -55,9 +93,21 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(apply #'concatenate 'string
(mapcar #'md-node-text (getf node :children))))
(t ""))))
#+END_SRC
;; ─── Block-level parser ───────────────────────────────────────────────────────
*** Block-level parser
The block parser splits raw text into lines and classifies each line
to determine what kind of block structure it begins. Helper functions
keep the main ~parse-blocks~ dispatch manageable.
**** split-string-into-lines
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
(defun split-string-into-lines (string)
(unless string (return-from split-string-into-lines (coerce nil 'vector)))
(let ((result nil) (start 0))
@@ -72,6 +122,14 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(coerce (nreverse result) 'vector))))
#+END_SRC
**** classify-line
The core line classification function. It checks line prefixes in
priority order — blank lines, thematic breaks, ATX headings, blockquote
markers, unordered/ordered list items, diff headers, diff lines, and
fenced code-block starts — and returns a ~(cons type data)~ pair.
Everything else is treated as a paragraph continuation line.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun classify-line (line)
(cond
@@ -122,7 +180,15 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(subseq line fence-len))))
(cons :code-start rest))))))
(t (cons :paragraph line))))
#+END_SRC
**** find-closing-marker
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
(defun find-closing-marker (text start marker)
(let ((marker-len (length marker)) (len (length text)))
(loop for j from start to (- len marker-len)
@@ -133,6 +199,13 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
finally (return nil))))
#+END_SRC
**** parse-paragraph
Collects consecutive paragraph lines (lines classified as ~:paragraph~)
into a single ~:paragraph~ node. Stops at a blank line or any
non-paragraph classification. Lines are joined with spaces before
inline parsing.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-paragraph (lines start)
(let ((text-parts nil) (i start))
@@ -152,7 +225,15 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
do (unless first (write-char #\Space s))
(princ part s)))))
i)))
#+END_SRC
**** parse-blockquote
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
(defun parse-blockquote (lines start)
(let ((text-parts nil) (i start))
(loop while (< i (length lines))
@@ -173,6 +254,14 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
i)))
#+END_SRC
**** parse-list
Handles both unordered (~:list-item~) and ordered (~:ordered-item~)
list items. Adjacent blank lines between items are allowed (creating
loose lists), but a blank line followed by a non-list line terminates
the list. Returns multiple nodes because each top-level list item
becomes its own ~:list-item~ or ~:ordered-item~ node.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-list (lines start)
(let ((items nil) (i start))
@@ -200,6 +289,14 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(values (nreverse nodes) i))))
#+END_SRC
**** parse-code-block
Parses a fenced code block starting at ~start~. The fence character
and length are detected from the opening line; the closing fence must
match in character and be at least as long. The language (if any) is
taken from the info string on the opening fence. Produces a single
~:code-block~ node.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-code-block (lines start lang)
(let ((code-lines nil)
@@ -227,7 +324,16 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
for first = t then nil
do (unless first (terpri s)) (princ cl s))))
i)))
#+END_SRC
**** parse-diff-block
Collects consecutive diff lines (~:diff-header~, ~:diff-line~) into a
single ~:diff-block~ node. The raw lines are preserved in a ~:lines~
property for coloured rendering later. Diff blocks are delimited by
blank lines.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-diff-block (lines start)
(let ((diff-lines nil) (i start))
(loop while (< i (length lines))
@@ -249,6 +355,14 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
i))))
#+END_SRC
**** parse-blocks
Top-level block parser. Dispatches on the ~classify-line~ result to
call the appropriate sub-parser, accumulating nodes into a list.
Handles blank lines, thematic breaks, headings, paragraphs,
blockquotes, lists, code blocks, and diff blocks. Returns ~nil~ for
~nil~ input.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-blocks (text)
(unless text (return-from parse-blocks nil))
@@ -289,9 +403,20 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(nreverse nodes)))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
;; ─── Inline parser ────────────────────────────────────────────────────────────
*** Inline parser
The inline parser handles character-level formatting inside block
content: emphasis, code spans, and links.
**** parse-inline
Main inline dispatcher. Walks the text character by character.
~*~ triggers star emphasis; ~_~ triggers underscore emphasis; ~`~
triggers inline code; ~[~ triggers links; everything else is
accumulated as plain ~:text~ nodes. Consecutive plain text is merged
into single nodes for efficiency.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-inline (text)
(unless (and text (> (length text) 0)) (return-from parse-inline nil))
(let ((nodes nil) (i 0) (len (length text)))
@@ -327,7 +452,17 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(incf i)))))
(push (make-md-node :text :content (subseq text start i)) nodes))))))
(nreverse nodes)))
#+END_SRC
**** parse-star-emphasis
Handles ~*italic*~ and ~**bold**~ using star markers. A double star
is tried first; if the closing ~**~ is found it produces a ~:bold~
node, otherwise it falls back to single-star ~:italic~. If neither
closes, returns ~nil~ to let the caller treat the character as literal
text.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-star-emphasis (text i len)
(when (>= i len) (return-from parse-star-emphasis (values nil i)))
(if (and (< (1+ i) len) (char= (char text (1+ i)) #\*))
@@ -341,7 +476,17 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close)))
(1+ close))
(values nil i)))))
#+END_SRC
**** parse-underscore-emphasis
Handles ~_italic_~ and ~__bold__~ using underscore markers.
Underscore emphasis is more restrictive than star emphasis: it only
opens after whitespace or at the start of text, and single-underscore
italic only closes before whitespace or punctuation. This avoids false
positives in identifiers like ~foo_bar~.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-underscore-emphasis (text i len)
(when (>= i len) (return-from parse-underscore-emphasis (values nil i)))
(when (and (> i 0) (not (find (char text (1- i)) " \t\n\r")))
@@ -359,7 +504,15 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(values (make-md-node :italic :children (parse-inline (subseq text (1+ i) close)))
(1+ close))
(values nil i)))))
#+END_SRC
**** parse-inline-code
Parses backtick-delimited inline code spans. Supports up to three
backticks as delimiters (so single backticks inside double-backtick
spans work). The matched pair's backtick count must be equal.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-inline-code (text i len)
(when (or (>= i len) (not (char= (char text i) #\`)))
(return-from parse-inline-code (values nil i)))
@@ -372,7 +525,16 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
:content (subseq text (+ i bt-count) close))
(+ close bt-count))
(values nil i)))))
#+END_SRC
**** parse-link
Parses Markdown links in the form ~[text](url)~. Uses nested bracket
matching via ~find-closing-marker~. The text portion is inline-parsed
to support formatting inside link text. Returns ~nil~ if the syntax
is incomplete, letting the caller render the ~[~ as literal text.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun parse-link (text i len)
(when (or (>= i len) (not (char= (char text i) #\[)))
(return-from parse-link (values nil i)))
@@ -389,9 +551,24 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(1+ close-paren)))))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
;; ─── Syntax highlighting ──────────────────────────────────────────────────────
*** Syntax highlighting
Syntax highlighting tokenises source code into (token . category) pairs
that the renderer colours with ANSI escape codes. Each supported
language has a definition of comment, string, keyword, and builtin
patterns.
**** get-highlighter
Returns a plist of highlighting rules for a given language name.
The rules define ~:comment~, ~:string~, ~:keyword~, and ~:builtin~
patterns. Supported languages: lisp, common-lisp, python,
javascript, bash, shell. Unknown languages return ~nil~, which tells
the caller to fall back to plain rendering. The assoc list uses
~string=~ for matching on the language tag, and each entry uses a
dotted-pair format ~(\"language\" . plist)~.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun get-highlighter (lang)
(cdr (assoc lang
'(("lisp" . (:comment (";" "#|" ";;") :string ("\"")
@@ -479,6 +656,15 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
:test #'string=)))
#+END_SRC
**** tokenize-line
Tokenises a single line of source code into ~(token . category)~
pairs. Categories are ~:plain~, ~:comment~, ~:string~, ~:number~,
~:keyword~, ~:builtin~, and ~:function~. The highlighter plist
provides the patterns for comment delimiters, string delimiters,
keywords, and builtins. Words immediately followed by ~(~ are
classified as ~:function~ calls.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun tokenize-line (line highlighter)
(let ((tokens nil) (i 0) (len (length line))
@@ -546,7 +732,17 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(push (cons token :plain) tokens)))))))
(t (push (cons (string c) :plain) tokens) (incf i)))))
(nreverse tokens)))
#+END_SRC
**** highlight-code
Applies syntax highlighting to a whole code string. Splits the code
into lines, tokenises each line with the language's highlighter, and
returns a flat list of ~(token . category)~ pairs with newline
separators between lines. Returns ~nil~ for empty input or a single
~:plain~ pair if no highlighter is found for the language.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun highlight-code (code language)
(unless code (return-from highlight-code nil))
(let ((highlighter (get-highlighter (and language (string-downcase language)))))
@@ -558,25 +754,59 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(when tokens (push (cons (string #\Newline) :plain) tokens))
(setf tokens (nconc (nreverse line-tokens) tokens)))))
(nreverse tokens))))
#+END_SRC
**** apply-highlight-token
Wraps a single token in an ANSI escape code based on its highlight
category. Keywords get colour 33 (yellow), builtins 36 (cyan),
functions 34 (blue), comments 2 (dim), strings 32 (green), numbers
35 (magenta). Unrecognised categories render as plain text.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun apply-highlight-token (token category)
(let ((code (case category
(:keyword "33") (:builtin "36")
(:function "34") (:comment "2") (:string "32") (:number "35")
(t nil))))
(if code (format nil "~c[~am~a~c[0m" #\Esc code token #\Esc) token)))
#+END_SRC
**** apply-highlight-style
Coerces an adjustable character vector (accumulated during line
rendering) back into a string. This is a thin wrapper that exists
for potential future customisation of style application.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun apply-highlight-style (char-vector)
(coerce char-vector 'string))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
;; ─── Diff rendering ───────────────────────────────────────────────────────────
*** Diff rendering
The diff rendering utilities classify diff lines and produce
colourised output.
**** string-prefix-p
Utility predicate that checks whether ~string~ starts with ~prefix~.
Avoids reimplementing this inline in multiple diff classifiers.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun string-prefix-p (prefix string)
(and (>= (length string) (length prefix))
(string= prefix (subseq string 0 (length prefix)))))
#+END_SRC
**** classify-diff-line
Classifies a single diff line into a semantic category: ~:file-header~
(for ~+++~ and ~---~ lines), ~:hunk-header~ (for ~@@~ lines), ~:added~
(for ~+~ lines), ~:removed~ (for ~-~ lines), or ~:context~ (for
everything else). This powers colourised diff rendering.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun classify-diff-line (line)
(cond ((string-prefix-p "+++ " line) :file-header)
((string-prefix-p "--- " line) :file-header)
@@ -584,9 +814,23 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
((string-prefix-p "+" line) :added)
((string-prefix-p "-" line) :removed)
(t :context)))
#+END_SRC
;; ─── Rendering ────────────────────────────────────────────────────────────────
*** Rendering
The rendering layer converts parsed AST nodes into styled terminal
output strings. Each node type has its own renderer, and
~render-md-node~ dispatches to the correct one.
**** apply-style
Wraps ~text~ in ANSI escape codes for a given ~style~ keyword or
string. Supports both keyword (e.g. ~:bold~) and string (e.g.
~\"bold\"~) style designators for flexibility. Common styles include
bold, italic, dim, code, link, underline, and the full set of 16
terminal colours. Unrecognised styles return the text unchanged.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun apply-style (style text)
(let ((code (cond
((eql style :bold) "1") ((eql style :italic) "3")
@@ -619,6 +863,13 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(if code (format nil "~c[~am~a~c[0m" #\Esc code text #\Esc) text)))
#+END_SRC
**** render-inline
Renders a list of inline child nodes into a single string. Handles
~:text~ (plain), ~:bold~, ~:italic~, ~:inline-code~, and ~:link~
types. Links render the text styled as link followed by the URL in
parentheses styled as url.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-inline (children)
(if (null children) ""
@@ -637,7 +888,16 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(princ " " s)
(princ (apply-style :url (format nil "(~a)" url)) s))))
(t (princ (or (getf child :content) "") s))))))))
#+END_SRC
**** render-heading
Renders a heading node as a coloured ~# Title~ line. The heading
level determines the number of ~#~ characters (capped at 6) and the
colour: level 1 uses bright-cyan, level 2 uses bright-yellow, and
deeper levels use bright-white.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-heading (node)
(let* ((level (or (getf (getf node :properties) :level) 1))
(prefix (make-string (min level 6) :initial-element #\#))
@@ -645,15 +905,36 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(color (cond ((= level 1) :bright-cyan) ((= level 2) :bright-yellow)
(t :bright-white))))
(list (apply-style color (concatenate 'string prefix " " text)))))
#+END_SRC
**** render-paragraph
Renders a paragraph node by inline-rendering its children. The
result is a single-element list containing the rendered text.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-paragraph (node)
(list (render-inline (getf node :children))))
#+END_SRC
**** render-blockquote
Renders a blockquote node with a dimmed ~> ~ prefix before the
inline-rendered content.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-blockquote (node)
(list (apply-style :dim (concatenate 'string "> " (render-inline (getf node :children))))))
#+END_SRC
**** render-code-block
Renders a fenced code block. If the block has a language tag and the
highlighter supports it, the code is syntax-highlighted with ANSI
colours. Otherwise it is rendered in plain ~:code~ style. A dimmed
language header line is shown when a language is present.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-code-block (node)
(let* ((language (or (getf (getf node :properties) :language) ""))
(content (or (getf node :content) ""))
@@ -681,7 +962,16 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(loop for line = (read-line s nil nil) while line
do (push (apply-style :code line) lines))))
(nreverse lines)))
#+END_SRC
**** render-diff-block
Renders a diff block by classifying each line and applying
colour: added lines in green (32), removed in red (31), hunk headers
in cyan (36), file headers in bold-cyan (1;36), and context lines
unstyled.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-diff-block (node)
(let* ((lines (getf (getf node :properties) :lines)) (result nil))
(dolist (line (or lines
@@ -696,16 +986,38 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(push (format nil "~c[~am~a~c[0m" #\Esc color line #\Esc) result)
(push line result))))
(nreverse result)))
#+END_SRC
**** render-thematic-break
Renders a thematic break as a dimmed horizontal rule using
Unicode box-drawing characters.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-thematic-break (node)
(declare (ignore node))
(list (apply-style :dim "──────────────────────────────────────────────")))
#+END_SRC
**** render-list-item
Renders a list item node. Ordered items get ~ 1.~ prefix,
unordered items get ~ * ~ prefix. The content is inline-rendered.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-list-item (node)
(list (concatenate 'string
(if (eql (getf node :type) :ordered-item) " 1." " * ")
(render-inline (getf node :children)))))
#+END_SRC
**** render-md-node
Dispatcher function that routes a single AST node to the correct
renderer based on its ~:type~. Each type-specific renderer returns a
list of strings (multiple lines), which ~render-md~ concatenates.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-md-node (node)
(let ((type (getf node :type)))
(case type
@@ -718,12 +1030,28 @@ and diff rendering. Self-contained in ~cl-tty.markdown~ package.
(:list-item (render-list-item node))
(:ordered-item (render-list-item node))
(t (list "")))))
#+END_SRC
**** render-md
Renders a list of AST nodes (the output of ~parse-blocks~) into a
flat list of output lines by calling ~render-md-node~ on each node
and concatenating the results.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-md (nodes)
(let ((lines nil))
(dolist (node nodes) (setf lines (nconc lines (render-md-node node))))
lines))
#+END_SRC
**** render-markdown
Top-level convenience function that parses a Markdown string and
renders it to a single output string with newline-separated lines.
Returns an empty string for ~nil~ input.
#+BEGIN_SRC lisp :tangle ../src/components/markdown.lisp
(defun render-markdown (text)
(unless text (return-from render-markdown ""))
(let ((nodes (parse-blocks text)) (parts nil))

400
org/modern-backend.org
View File

@@ -9,7 +9,7 @@ escape sequences. It supports truecolor 24-bit color, OSC 8 hyperlinks,
DECICM synchronized updates, SGR mouse tracking, kitty keyboard protocol,
and Unicode box-drawing characters (single, double, rounded).
All rendering functions produce CSI/OSC escape sequences directly — no
All rendering functions produce CSI/OSC escape sequences directly --- no
ncurses, no terminfo, no FFI. Color resolution handles named colors
(~:red~, ~:blue~, etc.), hex strings (~"#FFD700"~), and semantic theme
roles (~:accent~, ~:error~) via the ~*theme-colors*~ hash table.
@@ -18,166 +18,281 @@ roles (~:accent~, ~:error~) via the ~*theme-colors*~ hash table.
** Color and attribute helpers
- ~(hex-to-rgb hex)~ → (values r g b) — parse "#RRGGBB" or "#RGB"
- ~(sgr-fg color)~ → escape string — foreground color escape
- ~(sgr-bg color)~ → escape string — background color escape
- ~(sgr-attr attr)~ → escape string — attribute escape (bold, italic, etc.)
- ~(hex-to-rgb hex)~ (r g b) --- parse "#RRGGBB" or "#RGB"
- ~(sgr-fg color)~ escape string --- foreground color escape
- ~(sgr-bg color)~ escape string --- background color escape
- ~(sgr-attr attr)~ escape string --- attribute escape (bold, italic, etc.)
** Cursor helpers
- ~(cursor-move-escape x y)~ → escape string — CSI cursor position
- ~(cursor-style-escape shape blink)~ → escape string — DECSTR cursor shape
- ~(cursor-move-escape x y)~ escape string --- CSI cursor position
- ~(cursor-style-escape shape blink)~ escape string --- DECSTR cursor shape
** Sync and link helpers
- ~(decicm-begin)~ → escape string — enable synchronized updates
- ~(decicm-end)~ → escape string — disable synchronized updates
- ~(osc8-link url text)~ → escape string — OSC 8 hyperlink wrapper
- ~(decicm-begin)~ escape string --- enable synchronized updates
- ~(decicm-end)~ escape string --- disable synchronized updates
- ~(osc8-link url text)~ escape string --- OSC 8 hyperlink wrapper
** Border helpers
- ~(border-char style pos)~ → string — Unicode box-drawing character
- ~(border-char style pos)~ string --- Unicode box-drawing character
** Modern backend class
- ~(make-modern-backend &key output-stream)~ → modern-backend
- ~(make-modern-backend &key output-stream)~ modern-backend
- Implements all ~backend~ protocol methods with escape sequences
* Tests
The test suite lives in =modern-tests.lisp= and uses FiveAM. Each test
covers one logical behavior.
** Package and setup
The test package uses =cl-tty.backend= to access internal symbols for
white-box testing of escape generation.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(defpackage :cl-tty-modern-backend-test
(:use :cl :fiveam :cl-tty.backend)
(:export #:run-tests))
(in-package :cl-tty-modern-backend-test)
#+END_SRC
** Suite definition
A single suite groups all modern backend tests.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(def-suite modern-backend-suite :description "Modern backend tests")
(in-suite modern-backend-suite)
#+END_SRC
** Test runner
The =run-tests= entry point is called by the CI test harness.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(defun run-tests ()
(let ((result (run 'modern-backend-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
;; ── Constructor ────────────────────────────────────────────────
** Constructor test
Verifies that =make-modern-backend= returns an instance of the correct
class. This is the most basic smoke test for the backend factory.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test make-modern-backend-creates
"make-modern-backend returns a modern-backend instance"
(let ((b (make-modern-backend)))
(is (typep b 'cl-tty.backend::modern-backend))))
#+END_SRC
;; ── Escape Generation ──────────────────────────────────────────
** SGR truecolor foreground escape
Ensures a 6-digit hex string produces the correct 24-bit foreground
escape sequence with red, green, and blue components in the right order.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test sgr-truecolor-foreground
"SGR truecolor foreground escape is correct"
(is (equal (cl-tty.backend::sgr-fg "#FFD700")
(format nil "~C[38;2;255;215;0m" #\Esc))))
#+END_SRC
** SGR truecolor background escape
Same as foreground but uses the =48= background prefix instead of =38=.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test sgr-truecolor-background
"SGR truecolor background escape is correct"
(is (equal (cl-tty.backend::sgr-bg "#1a1b26")
(format nil "~C[48;2;26;27;38m" #\Esc))))
#+END_SRC
** SGR named color resolution
Verifies that keyword symbols like =:red= and =:blue= resolve to the
standard 8-color SGR codes (=31= foreground, =44= background).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test sgr-named-colors
"SGR named colors resolve to 8-color codes"
(is (equal (cl-tty.backend::sgr-fg :red)
(format nil "~C[31m" #\Esc)))
(is (equal (cl-tty.backend::sgr-bg :blue)
(format nil "~C[44m" #\Esc))))
#+END_SRC
** SGR attribute escapes
Each attribute keyword (=:bold=, =:italic=, =:underline=, =:reset=)
should map to the correct SGR number.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test sgr-bold-italic
"SGR attribute escapes are correct"
(is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc)))
(is (equal (cl-tty.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc)))
(is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc)))
(is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc))))
#+END_SRC
;; ── Cursor ─────────────────────────────────────────────────────
** Cursor move escape
Verifies that =cursor-move-escape= produces a CSI =H= sequence with
1-indexed row and column.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test cursor-move-escape
"cursor-move generates correct CSI escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tty.backend::cursor-move-escape 5 10)
(format nil "~C[11;6H" #\Esc)))))
#+END_SRC
** Cursor style block
Verifies the DECSTR escape for a block cursor without blinking (code 2).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test cursor-style-block
"cursor-style :block generate correct escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tty.backend::cursor-style-escape :block nil)
(format nil "~C[2 q" #\Esc)))))
#+END_SRC
** Cursor style bar
Verifies the DECSTR escape for a bar cursor without blinking (code 6).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test cursor-style-bar
"cursor-style :bar generate correct escape"
(let ((b (make-modern-backend)))
(is (equal (cl-tty.backend::cursor-style-escape :bar nil)
(format nil "~C[6 q" #\Esc)))))
#+END_SRC
** Cursor style underline with blink
Verifies that =:underline= with =blink=t= produces code 5 (underline
blinking), which is base 4 + blink offset 1.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test cursor-style-underline-blink
"cursor-style :underline with blink"
(let ((b (make-modern-backend)))
(is (equal (cl-tty.backend::cursor-style-escape :underline t)
(format nil "~C[5 q" #\Esc)))))
#+END_SRC
;; ── Synchronization ────────────────────────────────────────────
** DECICM synchronized update escapes
Confirms that =decicm-begin= and =decicm-end= produce =?2026h= and
=?2026l= respectively.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test decicm-escapes
"DECICM synchronized update escapes"
(is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc)))
(is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc))))
#+END_SRC
;; ── OSC 8 Hyperlinks ──────────────────────────────────────────
** OSC 8 hyperlink escape
Verifies the full OSC 8 wrapping: opening sequence with URL, the text,
and the closing sequence. The FORMAT string uses ~~ for literal tilde
and ~\\ for literal backslash.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test osc8-escape
"OSC 8 hyperlink escape wraps text"
(is (equal (cl-tty.backend::osc8-link "http://example.com" "click here")
(format nil "~C]8;;http://example.com~C\\\\click here~C]8;;~C\\\\"
(format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\"
#\Esc #\Esc #\Esc #\Esc))))
#+END_SRC
;; ── Hex Parsing ────────────────────────────────────────────────
** Hex color parsing (gold)
Verifies that ="#FFD700"= parses to (255, 215, 0).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test hex-color-parsing
"hex-to-rgb parses valid hex colors"
(multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700")
(is (= r 255))
(is (= g 215))
(is (= b 0))))
#+END_SRC
** Hex color parsing (black)
Verifies all-zero parsing.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test hex-color-black
"hex-to-rgb parses black"
(multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#000000")
(is (= r 0))
(is (= g 0))
(is (= b 0))))
#+END_SRC
** Hex color parsing (3-digit short form)
Verifies that ="#F00"= expands to ="#FF0000"= = (255, 0, 0).
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test hex-color-short-form
"hex-to-rgb parses 3-digit hex"
(multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#F00")
(is (= r 255))
(is (= g 0))
(is (= b 0))))
#+END_SRC
;; ── Border Characters ──────────────────────────────────────────
** Border characters --- rounded style
Confirms that =:rounded= style maps to the Unicode box-drawing
characters for the four corners and edges.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test border-char-rounded
"modern-border-char returns Unicode box-drawing for rounded style"
(is (equal (cl-tty.backend::border-char :rounded :top-left) "╭"))
(is (equal (cl-tty.backend::border-char :rounded :horizontal) "─"))
(is (equal (cl-tty.backend::border-char :rounded :vertical) "│"))
(is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯")))
(is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯"))
#+END_SRC
** Border characters --- double style
Confirms that =:double= style maps to double-line box-drawing characters.
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(test border-char-double
"modern-border-char returns double-line chars"
(is (equal (cl-tty.backend::border-char :double :top-left) "╔"))
(is (equal (cl-tty.backend::border-char :double :horizontal) "═"))
(is (equal (cl-tty.backend::border-char :double :vertical) "║")))
(is (equal (cl-tty.backend::border-char :double :vertical) "║"))
#+END_SRC
* Implementation
** Color and attribute helpers
*** hex-to-rgb
~hex-to-rgb~ parses hex color strings into (r g b) triplets. Handles
both 6-digit (fully specified) and 3-digit (shorthand) formats.
both 6-digit (fully specified) and 3-digit (shorthand) formats. The
3-digit form expands each hexit by duplicating it (=#F00= => =#FF0000=).
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(in-package :cl-tty.backend)
@@ -197,21 +312,37 @@ both 6-digit (fully specified) and 3-digit (shorthand) formats.
(parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t)))))
#+END_SRC
Named color mapping and theme color store:
*** *named-colors*
Maps keyword color names to 8-color SGR index values. Used as the
primary lookup in =sgr-fg= and =sgr-bg= before falling back to the
theme colors hash table.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defparameter *named-colors*
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
#+END_SRC
*** *theme-colors*
Hash table mapping semantic theme role keywords to hex color strings.
Populated by the theme system's =load-preset=. When a keyword is not in
=*named-colors*=, =sgr-fg= and =sgr-bg= consult this table as a
fallback, enabling user themes to define custom color roles.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defvar *theme-colors* (make-hash-table :test 'eq)
"Hash table mapping theme keywords to hex color strings.
Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg
as a fallback when a keyword is not in *named-colors*.")
#+END_SRC
~sgr-fg~ and ~sgr-bg~ produce the actual escape sequences. The
resolution chain is: hex → named color → theme semantic role → empty.
*** sgr-fg
~sgr-fg~ produces the SGR foreground escape sequence. Resolution chain:
hex string => named color => semantic theme role => empty string if
unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun sgr-fg (color)
@@ -232,6 +363,11 @@ resolution chain is: hex → named color → theme semantic role → empty.
(t ""))))
#+END_SRC
*** sgr-bg
~sgr-bg~ produces the SGR background escape. Same resolution chain as
=sgr-fg= but uses =48;2;R;G;B= for truecolor and =4n= for named colors.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun sgr-bg (color)
"Return SGR background escape for COLOR."
@@ -251,13 +387,23 @@ resolution chain is: hex → named color → theme semantic role → empty.
(t ""))))
#+END_SRC
Attribute codes map keywords to SGR numbers:
*** *sgr-attr-codes*
Maps attribute keywords to SGR parameter numbers. Covers bold, dim,
italic, underline, blink, reverse video, and reset.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defparameter *sgr-attr-codes*
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
(:blink . 5) (:reverse . 7) (:reset . 0)))
#+END_SRC
*** sgr-attr
~sgr-attr~ looks up the keyword in =*sgr-attr-codes*= and produces the
matching SGR escape.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun sgr-attr (attr)
"Return SGR attribute escape for ATTR keyword."
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
@@ -268,11 +414,24 @@ Attribute codes map keywords to SGR numbers:
** Cursor escapes
*** cursor-move-escape
Produces a CSI =H= (CUP) sequence to position the cursor. Coordinates
are 1-indexed: =cursor-move-escape 0 0= moves to row 1, column 1.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun cursor-move-escape (x y)
"Return CSI escape to move cursor to (x, y), 1-indexed."
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
#+END_SRC
*** cursor-style-escape
Produces a DECSTR sequence (=CSI Ps q=) to set the cursor shape.
Base codes: block=2, underline=4, bar=6. When =blink= is true the code
is incremented by 1 (e.g. blinking block = code 3).
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape."
(let* ((base (case shape
@@ -284,23 +443,50 @@ Attribute codes map keywords to SGR numbers:
** Sync and link escapes
*** decicm-begin
Enables DEC private mode 2026 (synchronized updates). All output
between =begin= and =end= is buffered by the terminal and rendered
atomically.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun decicm-begin ()
"Return escape to enable synchronized updates."
(format nil "~C[?2026h" #\Esc))
#+END_SRC
*** decicm-end
Disables DEC private mode 2026, flushing the buffered frame to the
display.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun decicm-end ()
"Return escape to disable synchronized updates."
(format nil "~C[?2026l" #\Esc))
#+END_SRC
*** osc8-link
Wraps text in an OSC 8 hyperlink. The opening sequence carries the URL,
the closing sequence (=ESC]8;;ESC\)=) terminates the link. This
allows clickable text in terminals that support the protocol.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun osc8-link (url text)
"Wrap TEXT in an OSC 8 hyperlink to URL."
(format nil "~C]8;;~A~C\\\\~A~C]8;;~C\\\\"
(format nil "~C]8;;~A~C\\~A~C]8;;~C\\"
#\Esc url #\Esc text #\Esc #\Esc))
#+END_SRC
** Border characters
*** *border-chars*
Lookup alist mapping =(style position)= pairs to Unicode box-drawing
characters. Covers single, double, and rounded styles with all four
corners plus horizontal and vertical connectors.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defparameter *border-chars*
'(((:single :top-left) . "┌") ((:single :top-right) . "┐")
@@ -312,7 +498,16 @@ Attribute codes map keywords to SGR numbers:
((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮")
((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯")
((:rounded :horizontal) . "─") ((:rounded :vertical) . "│")))
#+END_SRC
*** border-char
Looks up a border character by style and position. Falls back to
horizontal/vertical lines (=U+2500=, =U+2502=) if the style is unknown
for edge positions, or =+= for corners --- ensuring the UI never shows
a blank gap.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun border-char (style pos)
"Return the Unicode box-drawing character for STYLE at POS."
(let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
@@ -323,13 +518,28 @@ Attribute codes map keywords to SGR numbers:
** Modern backend class
*** modern-backend (class)
Subclasses the abstract =backend= class. =output-stream= is where escape
sequences are written; =in-sync-p= tracks whether we are inside a
DECICM synchronized update block.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defclass modern-backend (backend)
((output-stream :initform *standard-output*
:initarg :output-stream
:accessor backend-output-stream)
(in-sync-p :initform nil :accessor in-sync-p)))
#+END_SRC
*** make-modern-backend
Factory function that creates a =modern-backend= instance. Accepts an
optional =output-stream=; defaults to =*standard-output*=. The
=color-palette= argument is ignored in favor of the dynamic
=*theme-colors*= hash table.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun make-modern-backend (&key color-palette output-stream)
(declare (ignore color-palette))
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
@@ -337,9 +547,12 @@ Attribute codes map keywords to SGR numbers:
** Lifecycle
~initialize-backend~ enters the alt screen, enables mouse tracking,
bracketed paste, and kitty keyboard protocol. ~shutdown-backend~
restores everything.
*** initialize-backend
Enters the alternate screen buffer, enables mouse tracking (basic +
drag + SGR), bracketed paste mode, and the Kitty keyboard protocol.
Hides the cursor and flushes the stream. Returns the backend instance
for chaining.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod initialize-backend ((b modern-backend))
@@ -352,7 +565,15 @@ restores everything.
(cursor-hide b)
(finish-output (backend-output-stream b))
b)
#+END_SRC
*** shutdown-backend
Restores the terminal: shows the cursor, disables the Kitty keyboard
protocol, bracketed paste, SGR mouse, drag, basic mouse, and finally
leaves the alternate screen. Returns =nil= (via =(values)=).
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod shutdown-backend ((b modern-backend))
(cursor-show b)
(backend-write b (format nil "~C[?u" #\Esc))
@@ -367,8 +588,11 @@ restores everything.
** Backend-size via ioctl
Uses TIOCGWINSZ to query actual terminal dimensions. The alien-sap
wrapper ensures compatibility across SBCL versions.
*** backend-size
Uses TIOCGWINSZ (=0x5413= = 21523) to query actual terminal dimensions
from the kernel via =ioctl=. The =alien-sap= wrapper ensures
compatibility across SBCL versions. Returns (values cols rows).
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod backend-size ((b modern-backend))
@@ -386,13 +610,27 @@ wrapper ensures compatibility across SBCL versions.
** Capability query and write
*** backend-write
Writes a string to the backend's output stream, flushing after each
write to ensure the terminal receives the escape sequence immediately.
Returns the string length for protocol compatibility.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod backend-write ((b modern-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(finish-output stream)
(length string)))
#+END_SRC
*** capable-p
Advertises which features this backend supports. =modern-backend=
supports truecolor, OSC 8 hyperlinks, DECICM sync, SGR mouse,
bracketed paste, cursor style control, and the Kitty keyboard protocol.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod capable-p ((b modern-backend) feature)
(member feature '(:truecolor :osc8 :sync :mouse
:bracketed-paste :cursor-style
@@ -401,9 +639,12 @@ wrapper ensures compatibility across SBCL versions.
** Drawing
~draw-text~ combines cursor positioning, SGR colors, attributes, the
text itself, and a reset into a single string. This minimizes ioctl
calls — one write per draw operation.
*** draw-text
Combines cursor positioning, SGR colors, optional attributes, the text
itself, and a reset into a single concatenated string. Minimizes output
calls --- one =backend-write= per draw operation --- by packing everything
into one buffer.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-text ((b modern-backend) x y string fg bg
@@ -421,9 +662,12 @@ calls — one write per draw operation.
(backend-write b (apply #'concatenate 'string parts))))
#+END_SRC
~draw-border~ builds the full border as three string parts (top with
optional title, mid with sides, bottom) and writes them with minimal
output calls.
*** draw-border
Builds the full border as three distinct string parts (top with optional
title, repeated mid sections, bottom) and writes them with minimal
output calls. The title can be left-aligned or centered within the top
border line. Uses the border character lookup for the chosen style.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-border ((b modern-backend) x y width height
@@ -480,6 +724,13 @@ output calls.
(backend-write b bot)))
#+END_SRC
*** draw-rect
Fills a rectangular area with a background color. For each row, moves
the cursor and writes a filled line. This is simpler than =draw-border=
because it has no border characters --- just spaces with a background
color.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
(let* ((bg-esc (sgr-bg bg))
@@ -491,7 +742,16 @@ output calls.
(loop :for row :from 0 :below height :do
(backend-write b (cursor-move-escape x (+ y row)))
(backend-write b line))))
#+END_SRC
*** draw-link
Draws a hyperlinked text at position (x, y). Combines cursor
positioning, optional fg/bg colors, the OSC 8 link wrapper around the
text, and a reset. This lets the user click the text to open the URL
in terminals that support OSC 8.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-link ((b modern-backend) x y string url
&key fg bg)
(let ((parts (list (cursor-move-escape x y)
@@ -499,7 +759,15 @@ output calls.
(osc8-link url string)
(sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts))))
#+END_SRC
*** draw-ellipsis
Draws a three-dot ellipsis at the given position. The =width= parameter
is ignored since dots have a fixed visual length; delegates to
=draw-text= for uniform rendering.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-ellipsis ((b modern-backend) x y width
&key fg bg)
(declare (ignore width))
@@ -509,33 +777,87 @@ output calls.
** Cursor and input methods
*** cursor-move
Delegates to =cursor-move-escape= and writes the resulting CSI sequence
to the output stream.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod cursor-move ((b modern-backend) x y)
(backend-write b (cursor-move-escape x y)))
#+END_SRC
*** cursor-hide
Sends the DECTCEM private mode =?25l= to hide the cursor.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod cursor-hide ((b modern-backend))
(backend-write b (format nil "~C[?25l" #\Esc)))
#+END_SRC
*** cursor-show
Sends =?25h= to restore the cursor visibility.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod cursor-show ((b modern-backend))
(backend-write b (format nil "~C[?25h" #\Esc)))
#+END_SRC
*** cursor-style
Sets the cursor shape (block/underline/bar, optionally blinking) by
delegating to =cursor-style-escape=.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod cursor-style ((b modern-backend) shape &key blink)
(backend-write b (cursor-style-escape shape blink)))
#+END_SRC
*** enable-mouse
Enables basic mouse tracking, button-event tracking (drag), and SGR
extended mouse mode. These three modes together give full mouse
support while staying compatible with modern terminal emulators.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod enable-mouse ((b modern-backend))
(backend-write b (format nil "~C[?1000h" #\Esc))
(backend-write b (format nil "~C[?1002h" #\Esc))
(backend-write b (format nil "~C[?1006h" #\Esc))
(finish-output (backend-output-stream b)))
#+END_SRC
*** enable-bracketed-paste
Enables bracketed paste mode, where the terminal wraps pasted text in
=ESC[200~= and =ESC[201~= delimiters. This allows the application to
distinguish user input from pasted content.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod enable-bracketed-paste ((b modern-backend))
(backend-write b (format nil "~C[?2004h" #\Esc))
(finish-output (backend-output-stream b)))
#+END_SRC
*** begin-sync
Begins a synchronized update frame using DECICM. Sets the =in-sync-p=
slot so other methods can check whether we are inside a sync block.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod begin-sync ((b modern-backend))
(setf (in-sync-p b) t)
(backend-write b (decicm-begin)))
#+END_SRC
*** end-sync
Ends the synchronized update frame and flushes the output, causing the
terminal to render the buffered changes atomically.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod end-sync ((b modern-backend))
(setf (in-sync-p b) nil)
(backend-write b (decicm-end))

218
org/mouse.org
View File

@@ -25,6 +25,13 @@ module adds:
** Code
*** Package definition
The package lives in its own file so it can be loaded before the
implementation. It re-exports the public API symbols that consumers
(~cl-tty.core~, user applications) rely on without pulling in
implementation details.
#+BEGIN_SRC lisp :tangle ../src/components/mouse-package.lisp :noweb no
(defpackage :cl-tty.mouse
(:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering)
@@ -40,15 +47,39 @@ module adds:
#:cell-link-at #:open-link-at))
#+END_SRC
*** Package entry form
Standard boilerplate to enter the package defined above.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(in-package :cl-tty.mouse)
#+END_SRC
*** ~mouse-mixin~ — mixin class for mouse event handler slots
Using a mixin (rather than adding slots to every component class)
keeps the mouse concern orthogonal to layout or rendering. Components
that want mouse support simply inherit from ~mouse-mixin~ alongside
their primary superclass. Each slot stores a closure invoked when the
corresponding event fires; ~nil~ means "no handler."
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defclass mouse-mixin ()
((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down)
(on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up)
(on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move)
(on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll)))
#+END_SRC
*** ~handle-mouse-event~ — dispatch mouse events to the right slot handler
Maps from the low-level ~mouse-event-type~ keyword to the
corresponding mixin slot. Using ~case~ here is simpler than a generic
function dispatch because the mapping is one-to-one and never needs
CLOS multiple-dispatch. Returns ~nil~ when no handler is bound (the
caller can decide whether to bubble the event up).
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun handle-mouse-event (component event)
(let* ((type (mouse-event-type event))
(handler (case type
@@ -57,7 +88,17 @@ module adds:
(:drag (on-mouse-move component))
(t nil))))
(when handler (funcall handler event))))
#+END_SRC
*** ~hit-test~ — find the deepest component at a given (x, y)
Recursive coordinate lookup. Children are checked first so that the
innermost matching component wins (front-most in rendering order).
~ignore-errors~ guards against components that haven't been laid out
yet (no ~layout-node~ bound). This makes hit-testing safe to call
mid-render when the tree is partially constructed.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun hit-test (root x y)
"Find the deepest component at (X, Y) by testing layout-node bounds.
Recurses into component-children to find the innermost match.
@@ -81,24 +122,50 @@ Components without a layout-node or position return nil."
(>= y ny) (< y (+ ny nh)))
node)))))))
(recurse root)))
#+END_SRC
;; Selection
*** ~*selection*~ — global variable holding the current selection
A single global makes the selection accessible from anywhere in the
process without threading it through the entire component tree. This
keeps the API simple for now; a future refactor could store the
selection on a per-frame or per-window basis if needed.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defvar *selection* nil)
#+END_SRC
*** ~selection~ struct — data representation of a highlighted region
Stores the bounding box (start and end coordinates) plus the extracted
text. The ~:conc-name sel-~ prefix keeps accessors short while
avoiding name collisions. Using a struct (vs. a class) gives inline
accessors and no CLOS overhead, which matters when the selection is
read on every render frame.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defstruct (selection (:conc-name sel-))
(start-x 0) (start-y 0) (end-x 0) (end-y 0) (text ""))
#+END_SRC
*** ~get-selection~ — read the selected text
Simple accessor that returns nil when nothing is selected (rather than
an empty string), making it easy for callers to test with ~when~.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun get-selection ()
(when *selection* (sel-text *selection*)))
#+END_SRC
*** Bug Fixes (v1.0.0): Wayland clipboard support
*** ~copy-to-clipboard~ — platform-aware clipboard writing
~copy-to-clipboard~ only called ~xclip~, which fails silently on Wayland
sessions (where ~xclip~ is often unavailable or requires XWayland).
Fix: Check the ~WAYLAND_DISPLAY~ environment variable. If set, use
~wl-copy~ instead of ~xclip~. Fall back to ~xclip~ for traditional X11
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
@@ -111,32 +178,89 @@ sessions.
(sb-ext:run-program "xclip" (list "-selection" "clipboard")
:input text :wait nil)))
#+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil))
#+END_SRC
;;; --- Selection tracking (mouse drag) ---------------------------------------
*** ~*selection-active*~ — flag indicating an in-progress drag selection
Setting this to ~T~ during a mouse drag lets the renderer know it
should draw a highlight overlay. A global flag (rather than threading
the drag state through event handlers) mirrors the simplicity of
~*selection*~ and makes it trivial to check in rendering code.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defvar *selection-active* nil
"T when a drag selection is in progress.")
#+END_SRC
*** ~*selection-start*~ — drag origin coordinates
Stored as a cons cell ~(X . Y)~ of the mouse-down position. Using a
cons (vs. a struct) keeps the imperative mutation simple — ~setf~ with
~cons~ is a single expression.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defvar *selection-start* nil
"Cons (X . Y) of mouse-down position during drag.")
#+END_SRC
*** ~*selection-end*~ — current drag extent coordinates
Updated on every mouse-move during a drag so the rendering loop can
draw the live highlight rectangle between ~*selection-start*~ and
~*selection-end*~.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defvar *selection-end* nil
"Cons (X . Y) of current mouse position during drag.")
#+END_SRC
*** ~start-selection~ — begin a drag selection
Initializes all three drag state variables in one call. Both start and
end are set to the same position so that before the first mouse-move
the "selection" is a zero-width region (which renders as nothing).
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun start-selection (x y)
"Begin a drag selection at (X Y)."
(setf *selection-start* (cons x y)
*selection-end* (cons x y)
*selection-active* t))
#+END_SRC
*** ~update-selection~ — update the drag extent during mouse-move
Called on every mouse-move event while dragging. Only updates the end
position; the start remains fixed from the original mouse-down. The
rendering loop reads both globals to draw the highlight rectangle.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun update-selection (x y)
"Update the drag selection end position to (X Y)."
(setf *selection-end* (cons x y)))
#+END_SRC
*** ~selection-active-p~ — predicate for drag state
Encapsulates the global flag behind a function so that callers don't
need to know the variable name. Returning ~*selection-active*~
directly works because it is always ~nil~ or ~T~.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun selection-active-p ()
"Return T if a drag selection is in progress."
*selection-active*)
#+END_SRC
*** ~finalize-selection~ — complete the drag and extract text
Clears the active flag, normalizes coordinates (the user may have
dragged right-to-left or bottom-to-top), extracts the text from the
framebuffer via ~cl-tty.rendering:extract-text~, stores the result in
~*selection*~, and returns the extracted string. The ~fb~ parameter
must be the current framebuffer at the time of release.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun finalize-selection (fb)
"End the drag selection and extract text from the framebuffer."
(setf *selection-active* nil)
@@ -151,13 +275,28 @@ sessions.
:text text))
(setf *selection-start* nil *selection-end* nil)
text)))
#+END_SRC
;;; --- Link clicking ---------------------------------------------------------
*** ~cell-link-at~ — read a link URL from the framebuffer at (x, y)
Delegates to the rendering layer's ~fb-cell-link-url~ to look up the
cell metadata. This indirection keeps mouse code independent of the
framebuffer's internal storage format.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun cell-link-at (fb x y)
"Return the link URL at (X Y) in framebuffer FB, or nil."
(cl-tty.rendering:fb-cell-link-url fb x y))
#+END_SRC
*** ~open-link-at~ — navigate to a URL embedded at a screen position
If ~cell-link-at~ finds a URL, open it with the OS default handler
(~xdg-open~ on Linux, ~open~ on Darwin). Returns the URL (or nil) so
the caller can log or react to the result. The ~:wait nil~ avoids
blocking the TTY UI while the browser launches.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun open-link-at (fb x y)
"If there is a link URL at (X Y) in FB, open it via xdg-open."
(let ((url (cell-link-at fb x y)))
@@ -167,29 +306,68 @@ sessions.
url))
#+END_SRC
*** Tests
**** Test package and suite definition
Isolates test symbols in their own package to avoid polluting the
production namespace. FiveAM's ~def-suite~ groups all mouse tests
under a single name for convenient batch execution.
#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no
(defpackage :cl-tty-mouse-test (:use :cl :cl-tty.mouse :fiveam))
(in-package :cl-tty-mouse-test)
(def-suite mouse-suite :description "Mouse tests")
(in-suite mouse-suite)
#+END_SRC
**** Test: ~mouse-mixin-create~
Verifies that the mixin class can be instantiated and passes a basic
typep check. This guards against missing ~:initform~ values or
superclass chain issues.
#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no
(def-test mouse-mixin-create ()
(let ((m (make-instance 'mouse-mixin)))
(is-true (typep m 'mouse-mixin))))
#+END_SRC
**** Test: ~mouse-hit-test-point~
~hit-test~ on a bare ~mouse-mixin~ (no layout-node) should return nil
for any coordinates. This tests the ~ignore-errors~ guard path in the
hit-testing logic.
#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no
(def-test mouse-hit-test-point ()
"hit-test returns nil when no component has position slots bound"
(let ((obj (make-instance 'mouse-mixin)))
(is-false (hit-test obj 0 0))
(is-false (hit-test obj 100 100))))
#+END_SRC
**** Test: ~selection-set-and-get~
Sets ~*selection*~ directly (simulating a completed drag) and checks
that ~get-selection~ returns the expected text. This validates the
~selection~ struct accessor chain end-to-end.
#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no
(def-test selection-set-and-get ()
(setf cl-tty.mouse::*selection* (make-selection :text "hello"))
(is (equal "hello" (get-selection))))
#+END_SRC
;; ── Selection tracking ──────────────────────────────────────
**** Test: ~start-selection-initializes-state~
~start-selection~ must set ~*selection-start*~, ~*selection-end*~, and
~*selection-active*~ to their expected initial values. The teardown
resets globals to avoid cross-test contamination (FiveAM does not
automatically reset special variables between tests).
#+BEGIN_SRC lisp :tangle ../tests/mouse-tests.lisp :noweb no
(def-test start-selection-initializes-state ()
(start-selection 5 10)
(is-true (selection-active-p))
@@ -198,7 +376,15 @@ sessions.
(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)
@@ -206,7 +392,16 @@ sessions.
(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)))
@@ -217,5 +412,4 @@ sessions.
(let ((text (finalize-selection fb)))
(is (equal "hello
world" text)))))
#+END_SRC
#+END_SRC

111
org/package.org
View File

@@ -38,6 +38,21 @@ etc., and ~cl-tty.layout~ for ~layout-node~, ~compute-layout~, and the
The only direct dependencies are these two packages — no other
application code is needed to define components.
** Box exports
The ~box~ class is the primary rectangular container: it renders a
bordered region with optional title and background color. The accessor
family (~box-border-style~, ~box-title~, ~box-title-align~,
~box-fg~, ~box-bg~) follows a consistent naming convention so that
users can infer slot names from the class name. ~render-box~ is the
specialized method that draws the border and fills the interior.
The ~box-layout-node~ accessor connects the box to its layout tree
node, which is essential for the render pipeline's coordinate
computation. We export it separately from the rendering symbols
because it is also needed by code that walks the component tree
without triggering a full render.
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
(defpackage :cl-tty.box
(:use :cl :cl-tty.backend :cl-tty.layout)
@@ -48,30 +63,118 @@ application code is needed to define components.
#:box-border-style #:box-title #:box-title-align
#:box-fg #:box-bg
#:render-box
#+END_SRC
** Span exports
Spans are lightweight inline-style records — not full classes with
layout. Each span stores a substring of the parent text along with
its visual attributes. The reader-named accessors (~span-text~,
~span-bold~, ~span-italic~, etc.) let rendering code inspect span
properties without pulling in the internal representation. We keep
the accessor list flat (no grouping macro) to make the package
surface easy to grep and to keep the API browser-friendly.
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
;; Span
#:span
#:span-text #:span-bold #:span-italic #:span-underline
#:span-reverse #:span-dim #:span-fg #:span-bg
#+END_SRC
** Text exports
~text~ and ~make-text~ are the construction interface for the text
renderable. The ~text-layout-node~ accessor follows the same pattern
as ~box-layout-node~, bridging the component and layout layers.
~text-content~ and ~text-spans~ expose the raw data for rendering;
~text-fg~, ~text-bg~, and ~text-wrap-mode~ control global text
appearance. ~render-text~ is the CLOS method that walks the span list
and calls ~draw-text~ from the backend.
These symbols live in the ~cl-tty.box~ package rather than a
separate ~cl-tty.text~ package to keep inter-component references
trivial — boxes can hold text children, and text can be nested inside
other components, all without cross-package imports.
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
;; Text
#:text #:make-text
#:text-layout-node #:text-content #:text-spans
#:text-fg #:text-bg #:text-wrap-mode
#:render-text
#+END_SRC
** Utility exports (for tests)
~word-wrap~ and ~split-string~ are internal text-processing utilities
used by the text renderer to break lines and tokenize input. They are
exported specifically so the test suite can unit-test them in
isolation. They are not part of the public component API and should
not be relied upon by application code outside of tests.
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
;; Utilities (for tests)
#:word-wrap #:split-string
#+END_SRC
** Dirty tracking
The dirty-mixin protocol lets any component class participate in the
change-propagation system. ~dirty-mixin~ is the mixin class, and
~dirty-p~, ~mark-clean~, ~mark-dirty~ are the three operations that
the render pipeline calls to decide whether a subtree needs
re-rendering.
Having these as generic functions (rather than a single ~(setf
dirty-p)~) makes it easy for subclasses to add side effects on dirty
transitions — for example, invalidating a cached bitmap or
recomputing string metrics.
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
;; Dirty tracking
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty
#+END_SRC
** Rendering pipeline
~render~, ~render-screen~, and ~render-node~ are the three entry
points into the rendering dispatch. ~component-layout-node~,
~component-children~, and ~component-parent~ form the tree-navigation
interface that ~render-node~ uses to walk the component hierarchy.
~available-width~ and ~available-height~ are passed down the tree to
constrain layout. ~propagate-dirty~ walks upward from a changed
component to mark ancestors as dirty, ensuring the screen is
re-drawn from the correct root.
Collecting these under a single "Rendering pipeline" group signals to
readers that they form a coherent subsystem — if you override one,
you likely need to understand all of them.
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
;; Rendering pipeline
#:render #:render-screen #:render-node
#:component-layout-node #:component-children #:component-parent
#:available-width #:available-height
#:propagate-dirty
#+END_SRC
** Theme engine
~theme~ and ~make-theme~ are the constructor and class for theme
objects. ~theme-mode~ selects the active color mode (light/dark).
~theme-color~ looks up a named color in the current theme.
~load-preset~ loads a theme from a file, and ~define-preset~ registers
a preset at compile time.
The theme engine is isolated from the rest of the component layer —
boxes and text reference theme colors by name at render time, and the
theme object is passed in from the application level. This separation
means themes can be swapped without touching component instances.
#+BEGIN_SRC lisp :tangle ../src/components/package.lisp
;; Theme engine
#:theme #:make-theme #:theme-mode
#:theme-color #:load-preset #:define-preset))
(in-package :cl-tty.box)
#+END_SRC
The ~#:word-wrap~ and ~#:split-string~ exports are for tests only —
they're utility functions used internally by ~text~ rendering but
exposed so the test suite can unit-test them directly.

231
org/render.org
View File

@@ -65,6 +65,13 @@ Mark ~component~ and every ancestor dirty. Walks up via
* Tests
** Test helper: make-capturing-backend
Before any render test can run, we need a backend that captures output
to a string stream instead of writing to the real terminal. This helper
creates a ~modern-backend~ with a ~string-output-stream~ and returns
both, so tests can inspect what was rendered.
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
@@ -73,7 +80,17 @@ Mark ~component~ and every ancestor dirty. Walks up via
(let* ((s (make-string-output-stream))
(b (make-modern-backend :output-stream s)))
(values b s)))
#+END_SRC
** Test: render dispatches to box method
Verifies that calling ~render~ on a ~box~ instance invokes the box
rendering path, which draws border characters (e.g. ┌). This confirms
generic dispatch works for the box type and that the border rendering
pipeline is intact. A regression here would mean ~render-box~ is not
being called or produces no output.
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
(test render-generic-dispatches-box
"render dispatches to render-box for box instances"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -81,7 +98,17 @@ Mark ~component~ and every ancestor dirty. Walks up via
(compute-layout (box-layout-node bx) 10 5)
(render bx b)
(is (search "┌" (get-output-stream-string s)) "box renders border"))))
#+END_SRC
** Test: render dispatches to text method
Verifies that calling ~render~ on a ~text~ instance invokes the text
rendering path, which outputs the string content. This confirms generic
dispatch works for the text type and that text content is correctly
emitted to the backend. A regression would mean ~render-text~ is not
being called.
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
(test render-generic-dispatches-text
"render dispatches to render-text for text instances"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -89,19 +116,51 @@ Mark ~component~ and every ancestor dirty. Walks up via
(compute-layout (text-layout-node tx) 10 1)
(render tx b)
(is (search "Hello" (get-output-stream-string s)) "text renders content"))))
#+END_SRC
** Test: component-layout-node returns layout-node
The ~component-layout-node~ generic is the bridge between the component
layer and the layout layer. Every renderable component must have an
associated layout node. This test confirms that both ~box~ and ~text~
return a ~layout-node~ instance from their ~component-layout-node~
method. A failure here means a component type is missing its method or
the slot accessor is wrong.
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
(test component-layout-node-works
"component-layout-node returns the right slot for each type"
(let ((bx (make-box)) (tx (make-text "")))
(is (typep (component-layout-node bx) 'layout-node))
(is (typep (component-layout-node tx) 'layout-node))))
#+END_SRC
** Test: component-children returns nil for leaves
Leaf components (~box~, ~text~) have no children by definition. The
default method on ~t~ returns ~nil~. This test ensures that neither box
nor text accidentally inherits or defines a method that returns
non-nil, which would break the tree-walk in ~render-node~ by causing
infinite recursion or rendering phantom children.
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
(test component-children-returns-nil
"Leaf components have no children"
(let ((bx (make-box)) (tx (make-text "")))
(is (null (component-children bx)))
(is (null (component-children tx)))))
#+END_SRC
** Test: propagate-dirty marks component dirty
~propagate-dirty~ is the entry point for the incremental rendering
pipeline. When a component changes (e.g. a keystroke in a text input),
it calls ~propagate-dirty~ to ensure the frame is re-rendered. This
test verifies that calling ~propagate-dirty~ on a clean component sets
it dirty. Without this, components that mutate would never trigger a
re-render and the display would become stale.
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
(test propagate-dirty-marks-component
"propagate-dirty marks the component dirty"
(let ((c (make-box)))
@@ -109,7 +168,19 @@ Mark ~component~ and every ancestor dirty. Walks up via
(is-false (dirty-p c) "should be clean after mark-clean")
(propagate-dirty c)
(is-true (dirty-p c) "should be dirty after propagate-dirty")))
#+END_SRC
** Test: available-width defaults
~available-width~ reads the computed width from the component's layout
node. When a component hasn't been laid out (no explicit width set),
the layout node's width defaults to 0. This test verifies that
~available-width~ returns 0 for a freshly created box without layout
computation. This matters because container components use
~available-width~ to position children — getting a sensible default
prevents division-by-zero or garbled layouts during initialization.
#+BEGIN_SRC lisp :tangle ../src/components/render-tests.lisp
(test available-width-defaults
"available-width returns 0 for components without explicit width"
(let ((c (make-box)))
@@ -124,22 +195,46 @@ These three generic functions form the tree navigation API. They're
separated from ~render~ because layout and dirty propagation also
need to traverse the tree.
*** component-layout-node
The ~component-layout-node~ generic returns the ~layout-node~ instance
for a given component. Every component that participates in layout and
rendering must have a layout node — it stores the computed position and
size after layout passes. The generic is defined with two specific
methods for the built-in component types.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(in-package :cl-tty.box)
;; ── Component Protocol ────────────────────────────────────────
(defgeneric component-layout-node (component)
(:documentation "Return the layout-node for COMPONENT.")
(:method ((bx box)) (box-layout-node bx))
(:method ((tx text)) (text-layout-node tx)))
(:documentation "Return the layout-node for COMPONENT."))
#+END_SRC
Each component type defines its own ~component-layout-node~ method
that returns its internal layout node. The default method (on ~t~)
would return ~nil~, but since every component in cl-tty has a layout
node, we don't provide one — new component types must add their own
method.
Each component type returns its internal layout node slot. This method
specializes on ~box~ and returns the ~box-layout-node~ slot value.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defmethod component-layout-node ((bx box))
(box-layout-node bx))
#+END_SRC
The ~text~ component stores its layout node in the ~text-layout-node~
slot. Both methods return the same type (~layout-node~), so the layout
engine can operate uniformly regardless of component type.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defmethod component-layout-node ((tx text))
(text-layout-node tx))
#+END_SRC
*** component-children
Leaf components (~box~, ~text~) have no children. Container components
(~scrollbox~, ~tabbar~) override this to return their child list. The
default method on ~t~ returns ~nil~, so new component types are
automatically treated as leaves unless they explicitly override.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defgeneric component-children (component)
@@ -147,8 +242,13 @@ method.
(:method ((c t)) nil))
#+END_SRC
Leaf components (~box~, ~text~) have no children. Container components
(~scrollbox~, ~tabbar~) override this to return their child list.
*** component-parent
Parent links are set by the container when adding children. They're
used by ~propagate-dirty~ to walk up the tree. The default method on
~t~ returns ~nil~, which acts as the termination condition for the
recursive dirty walk — when ~component-parent~ returns ~nil~, we've
reached the root.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defgeneric component-parent (component)
@@ -156,11 +256,16 @@ Leaf components (~box~, ~text~) have no children. Container components
(:method ((c t)) nil))
#+END_SRC
Parent links are set by the container when adding children. They're
used by ~propagate-dirty~ to walk up the tree.
** Render dispatch
*** render generic
The ~render~ generic is the central dispatch point for the rendering
pipeline. Every component type that can be drawn defines a method on
~render~. The default method on ~t~ is a no-op so that non-renderable
objects (or components still under development) don't cause errors
when the tree walk reaches them.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
;; ── Rendering Pipeline ────────────────────────────────────────
@@ -171,25 +276,43 @@ used by ~propagate-dirty~ to walk up the tree.
(values)))
#+END_SRC
The ~render~ generic is the central dispatch point. Every component
type that can be drawn defines a method on ~render~. The default
method is a no-op so that non-renderable objects (or components still
under development) don't cause errors.
*** render method for box
Boxes are rendered with border characters. The ~render~ method
delegates to the ~render-box~ function defined in ~box.lisp~, which
handles the actual drawing of border lines and corners.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defmethod render ((bx box) backend)
(render-box bx backend))
#+END_SRC
*** render method for text
Text components render their content string at the computed position.
The ~render~ method delegates to ~render-text~ from ~text.lisp~, which
writes the string with appropriate escape sequences for positioning.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defmethod render ((tx text) backend)
(render-text tx backend))
#+END_SRC
Box and text are the two built-in renderable types. Their ~render~
methods delegate to the specific rendering functions defined in
~box.lisp~ and ~text.lisp~.
** Screen-level orchestration
*** render-screen
~render-screen~ is the entry point for rendering a full frame. It
queries the terminal size at render time (not at startup), so the
layout adapts to window resizes automatically. The DECICM sync pair
(~begin-sync~/~end-sync~) wraps the entire frame in a synchronized
update: the terminal buffers all escape sequences and flushes them
atomically, preventing partial-frame flicker.
The pipeline is: (1) query backend pixel/dimension size, (2) begin
sync, (3) compute layout at the root, (4) walk the tree rendering each
node, (5) end sync.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defun render-screen (root backend)
"Render the component tree ROOT using BACKEND.
@@ -203,14 +326,13 @@ methods delegate to the specific rendering functions defined in
(end-sync backend)))
#+END_SRC
~render-screen~ is the entry point for rendering a full frame. It
queries the terminal size at render time (not at startup), so the
layout adapts to window resizes automatically.
*** render-node
The DECICM sync pair (~begin-sync~/~end-sync~) wraps the entire
frame in a synchronized update: the terminal buffers all escape
sequences and flushes them atomically. This prevents partial-frame
flicker.
Tree walk: render this node, then recurse into children. The layout was
already computed by ~render-screen~, so each node's position and size
are available from its ~layout-node~. The recursion is depth-first:
parents are drawn before children, which matters for z-ordering (the
parent's background is drawn first, children overlay on top).
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defun render-node (node backend)
@@ -222,34 +344,53 @@ flicker.
(render-node child backend)))
#+END_SRC
Tree walk: render this node, then recurse into children. The layout
was already computed by ~render-screen~, so each node's position and
size are available from its ~layout-node~.
** Utility accessors
*** available-width
Returns the computed width from the component's layout node. The layout
node's width is set by ~compute-layout~ during ~render-screen~, so this
reflects the actual allocated space — not the requested width. The
fallback of 80 matches the default terminal width when no layout node
exists (during initialization or testing without a backend).
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defun available-width (component)
"Return the available width for COMPONENT (or 80 as default)."
(let ((ln (component-layout-node component)))
(if ln (layout-node-width ln) 80)))
#+END_SRC
*** available-height
Returns the computed height from the component's layout node. Like
~available-width~, this reflects post-layout allocated space. The
fallback of 24 matches the default terminal height. These accessors
provide a clean API for components that need to know their allocated
space during rendering, avoiding direct access to layout nodes.
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
(defun available-height (component)
"Return the available height for COMPONENT (or 24 as default)."
(let ((ln (component-layout-node component)))
(if ln (layout-node-height ln) 24)))
#+END_SRC
These accessors provide a clean API for components that need to know
their allocated space. They return the computed dimensions from the
layout node, which was set by ~compute-layout~ during ~render-screen~.
The fallback values (80x24) match the terminal default when no layout
node exists — typically during initialization or testing without a
backenπd.
** Dirty propagation
*** propagate-dirty
Recursive walk up the parent chain. When a text input receives a
keystroke, it marks itself dirty, then its parent scrollbox, then the
containing box, then the root — triggering recomputation and
re-rendering of everything that might have changed.
This is the key to incremental rendering: only dirty branches are
re-processed. The ~render~ methods check ~dirty-p~ early and return
immediately for clean components (handled in each component's render,
not here). The recursion terminates when ~component-parent~ returns
~nil~ (the root component has no parent).
#+BEGIN_SRC lisp :tangle ../src/components/render.lisp
;; ── Dirty Propagation ─────────────────────────────────────────
@@ -260,13 +401,3 @@ backenπd.
(when parent
(propagate-dirty parent))))
#+END_SRC
Recursive walk up the parent chain. When a text input receives a
keystroke, it marks itself dirty, then its parent scrollbox, then the
containing box, then the root — triggering recomputation and
re-rendering of everything that might have changed.
This is the key to incremental rendering: only dirty branches are
re-processed. The ~render~ methods check ~dirty-p~ early and return
immediately for clean components (handled in each component's render,
not here).

258
org/scrollbox.org
View File

@@ -41,8 +41,9 @@ list of child components and two scroll offset slots (~scroll-y~ and
~scroll-x~). The ~sticky-scroll-p~ flag, when true, keeps the scroll
position at the bottom whenever new children are added.
The constructor accepts keyword arguments for initial offset and children.
~children~ defaults to an empty list.
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)
@@ -57,7 +58,18 @@ The constructor accepts keyword arguments for initial offset and children.
(sticky-scroll-p :initform t :initarg :sticky-scroll-p
:accessor sticky-scroll-p :type boolean)
(layout-node :initform (make-layout-node) :accessor scroll-box-layout-node)))
#+END_SRC
** make-scroll-box constructor
A dedicated constructor function provides keyword argument defaults and
ensures ~sticky-scroll-p~ defaults to T even when the caller omits it
(the :initform on the slot handles default-initialization, but a nil
value explicitly passed as ~:sticky-scroll-p nil~ needs to be
preserved). Using a function instead of making the user call
~make-instance~ directly keeps the API ergonomic and hides CLOS plumbing.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0)
sticky-scroll-p)
(make-instance 'scroll-box
@@ -67,29 +79,39 @@ The constructor accepts keyword arguments for initial offset and children.
:sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p)))
#+END_SRC
** ScrollBox: component protocol
** component-children method
~component-children~ returns the child list for the rendering pipeline
to traverse. ~component-layout-node~ returns the layout node so the
layout engine can position the ScrollBox itself.
~component-children~ is part of the component protocol. The rendering
pipeline calls this to discover the tree of children to render. By
delegating to the ~scroll-box-children~ accessor, we keep the protocol
implementation thin — just an indirection that makes ~scroll-box~
participate polymorphically alongside other container types.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defmethod component-children ((sb scroll-box))
(scroll-box-children sb))
#+END_SRC
** component-layout-node method
~component-layout-node~ returns the layout node that the layout engine
uses to position the ScrollBox itself within its parent. Each ScrollBox
creates its own layout node at construction time via ~make-layout-node~,
so this method simply returns that stored node.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defmethod component-layout-node ((sb scroll-box))
(scroll-box-layout-node sb))
#+END_SRC
** ScrollBox: scroll-by
** clamp-scroll helper
~scroll-by~ adjusts the scroll offset by delta rows and columns. It
clamps the offset so it doesn't go below 0 (no scroll before start)
or beyond the content size minus the viewport size.
~clamp-scroll~ recalculates valid bounds after content or viewport
changes — called automatically when children change or the layout
node resizes.
~clamp-scroll~ recalculates valid scroll bounds after content or viewport
changes — called automatically when children change or the layout node
resizes. It reads the viewport dimensions from the layout node and the
content dimensions from the content-size helpers, then clamps both
scroll offsets with ~max~/~min~ to ensure they never go below 0 or
beyond the scrollable range.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun clamp-scroll (sb)
@@ -105,7 +127,17 @@ node resizes.
(setf (scroll-box-scroll-x sb)
(max 0 (min (scroll-box-scroll-x sb)
(- content-width viewport-width))))))
#+END_SRC
** scroll-by method
~scroll-by~ adjusts the scroll offset by delta rows and columns. It
increments the current offset, clamps via ~clamp-scroll~, then marks
the component dirty so the render loop picks up the change. This is
the primary API entry point for programmatic scrolling (from keyboard
input or mouse wheel events).
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun scroll-by (sb dy dx)
"Scroll by DY rows and DX columns. Clamps to valid range."
(incf (scroll-box-scroll-y sb) dy)
@@ -114,14 +146,13 @@ node resizes.
(mark-dirty sb))
#+END_SRC
** ScrollBox: content size estimation
** scroll-box-content-height
~scroll-box-content-height~ and ~scroll-box-content-width~ calculate
the total content size by summing child layout node dimensions. This
is used by ~clamp-scroll~ and scrollbar rendering.
For height: sum of all child heights (vertical layout).
For width: max of all child widths (horizontal scroll).
~scroll-box-content-height~ calculates the total content height by
summing all child heights. Each child reports its height through its
layout node, with a minimum of 1 row (even zero-height children get a
floor so they don't collapse the layout). This is used by
~clamp-scroll~, scrollbar rendering, and sticky-scroll logic.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun scroll-box-content-height (sb)
@@ -131,7 +162,16 @@ For width: max of all child widths (horizontal scroll).
(let ((ln (component-layout-node c)))
(if ln (max 1 (layout-node-height ln)) 1)))
:initial-value 0))
#+END_SRC
** scroll-box-content-width
~scroll-box-content-width~ calculates the maximum width among children,
since horizontal scrolling follows the widest child rather than summing
widths. Like the height counterpart, it floors child widths at 1 so
empty children don't zero out the measurement.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun scroll-box-content-width (sb)
"Maximum width among children."
(reduce #'max (scroll-box-children sb)
@@ -141,7 +181,7 @@ For width: max of all child widths (horizontal scroll).
:initial-value 0))
#+END_SRC
** ScrollBox: rendering with viewport culling
** Render method with viewport culling
~render~ iterates children, computes each child's position within
the viewport (adjusted for scroll offset), and only renders children
@@ -149,9 +189,14 @@ whose visible area intersects the viewport. This is the core
optimization — for a terminal with 200 children, only the ~24
visible ones are actually drawn.
~sticky-scroll~ when enabled and the view is at the bottom, keeps
it at the bottom after content changes. The flag resets to false
when the user manually scrolls up.
The method temporarily offsets each child's layout node by the scroll
amount during rendering, then restores the original position via
~unwind-protect~. This avoids mutating the permanent layout state while
still making each child's ~render~ method draw at the correct scrolled
position.
After child rendering, it delegates to ~draw-scrollbars~ for the
scrollbar overlay.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defmethod render ((sb scroll-box) backend)
@@ -187,11 +232,14 @@ the viewport are clipped out."
(draw-scrollbars sb backend vw vh)))
#+END_SRC
** ScrollBox: sticky scroll
** update-sticky-scroll
~sticky-scroll~ checks whether the view is at the bottom. If so,
auto-scrolls to keep the bottommost content visible. The user
calling ~scroll-by~ with a negative DY resets the sticky flag.
~update-sticky-scroll~ checks whether the view is at the bottom and, if
the ~sticky-scroll-p~ flag is set, auto-scrolls to keep the bottommost
content visible. The comparison uses a 1-row tolerance (~(- content-h
viewport-h 1)~) so minor content changes don't cause jitter. The sticky
flag is reset to nil when the user manually scrolls up (handled by
callers of ~scroll-by~).
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun update-sticky-scroll (sb)
@@ -205,15 +253,14 @@ calling ~scroll-by~ with a negative DY resets the sticky flag.
(max 0 (- content-h viewport-h)))))))
#+END_SRC
** ScrollBox: scrollbar rendering
** scrollbar-thumb helper
~draw-scrollbars~ renders vertical and horizontal scrollbars as
single-character-wide bars on the right and bottom edges of the
viewport. The scrollbar thumb position and size reflect the current
scroll position relative to content size.
Vertical scrollbar: blocks (~#\\Full~ ~#\\Up~ ~#\\Mid~ ~#\\Down~).
Horizontal scrollbar: block characters along the bottom.
~scrollbar-thumb~ converts a raw scroll position (in lines) into a
normalized 0.0-to-1.0 ratio representing where the thumb should appear
on the scrollbar track. When content fits entirely within the viewport,
it returns 0.0 (no scrolling possible). This normalized value is used
by ~draw-scrollbars~ to compute the pixel/character position of the
thumb.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun scrollbar-thumb (scroll-pos viewport-size content-size)
@@ -221,7 +268,22 @@ Horizontal scrollbar: block characters along the bottom.
(if (> content-size viewport-size)
(/ (float scroll-pos) (- content-size viewport-size))
0.0))
#+END_SRC
** draw-scrollbars
~draw-scrollbars~ renders vertical and horizontal scrollbars as
single-character-wide bars on the right and bottom edges of the
viewport. The scrollbar thumb position and size reflect the current
scroll position relative to content size.
The vertical scrollbar uses a filled block (█) for the thumb and a
background fill for the track. The horizontal scrollbar is drawn along
the bottom edge. Both account for the scrollbox's own position within
the layout tree (~ox~, ~oy~) so nested scrollboxes render scrollbars at
the correct screen coordinates.
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
(defun draw-scrollbars (sb backend viewport-w viewport-h)
"Draw scrollbars if content exceeds viewport."
(let* ((content-h (scroll-box-content-height sb))
@@ -269,6 +331,17 @@ Two bugs were fixed in the ScrollBox render pipeline:
Test suite for both ScrollBox and TabBar.
** Package and test infrastructure
The tests use FiveAM, the Common Lisp testing framework. The package
setup pulls in all the systems under test (~cl-tty.backend~,
~cl-tty.box~, ~cl-tty.layout~, ~cl-tty.input~, ~cl-tty.container~)
along with the base ~:cl~ language and ~:fiveam~ itself.
~run-tests~ is exported so the test runner script can call it
unconditionally; it runs the ~scrollbox-suite~ and prints results via
~fiveam:explain!~ before exiting.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(defpackage :cl-tty-scrollbox-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container)
@@ -282,9 +355,15 @@ Test suite for both ScrollBox and TabBar.
(let ((result (run 'scrollbox-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
;; ── ScrollBox Tests ─────────────────────────────────────────────
** ScrollBox constructor test
Confirms a bare ~make-scroll-box~ returns a ~scroll-box~ instance with
default scroll offsets of 0 and no children. This establishes that the
class definition and constructor are wired up correctly.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test scrollbox-creates
"A ScrollBox can be created with defaults."
(let ((sb (make-scroll-box)))
@@ -292,24 +371,59 @@ Test suite for both ScrollBox and TabBar.
(is (= (scroll-box-scroll-y sb) 0))
(is (= (scroll-box-scroll-x sb) 0))
(is-false (scroll-box-children sb))))
#+END_SRC
** ScrollBox with children test
Verifies that the ~:children~ initarg is accepted and that
~scroll-box-children~ returns the list. A ScrollBox with one child
should report length 1.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test scrollbox-with-children
"A ScrollBox can have children."
(let ((sb (make-scroll-box :children (list (make-text "hello")))))
(is (= (length (scroll-box-children sb)) 1))))
#+END_SRC
** ScrollBox scroll-by test
Exercises ~scroll-by~ with a positive DY offset and asserts the
scroll-y is non-negative after the operation. Combined with
~scrollbox-scroll-clamp~ below, this covers both the normal and
boundary behavior of the scroll mechanic.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test scrollbox-scroll-by
"ScrollBy adjusts offset clamped to valid range."
(let ((sb (make-scroll-box :scroll-y 0)))
(scroll-by sb 5 0)
(is (>= (scroll-box-scroll-y sb) 0))))
#+END_SRC
** ScrollBox component-children test
Confirms the component protocol method ~component-children~ returns the
same child list that ~scroll-box-children~ does. This ensures the
protocol indirection works and that the rendering pipeline will see the
correct children.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test scrollbox-component-children
"Component protocol: children are accessible."
(let* ((child (make-text "hello"))
(sb (make-scroll-box :children (list child))))
(is (eql (first (component-children sb)) child))))
#+END_SRC
** ScrollBox render no-op test
Renders a ScrollBox with no children to a string-output-stream backend.
The test passes if no errors are signaled — this guards against nil
layout nodes or unbound slots causing problems during the render
pipeline's initial traversal.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test scrollbox-render-noop
"Rendering a ScrollBox with no children does not error."
(let* ((stream (make-string-output-stream))
@@ -317,16 +431,30 @@ Test suite for both ScrollBox and TabBar.
(sb (make-scroll-box)))
(render sb backend)
(is-true t)))
#+END_SRC
;; ── TabBar Tests ────────────────────────────────────────────────
** TabBar constructor test
Confirms a bare ~make-tab-bar~ returns a ~tab-bar~ instance with no
active tab and no tabs. This validates the TabBar class definition and
constructor.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test tabbar-creates
"A TabBar can be created with defaults."
(let ((tb (make-tab-bar)))
(is (typep tb 'tab-bar))
(is-false (tab-bar-active tb))
(is-false (tab-bar-tabs tb))))
#+END_SRC
** TabBar add-tab test
Tests that ~tab-bar-add~ returns the supplied ID, adds a tab to the
internal list, and stores the title correctly. Each tab is stored as a
plist, so the test checks both list length and the ~:title~ property.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test tabbar-add-tab
"Adding a tab returns the id and updates tabs."
(let ((tb (make-tab-bar)))
@@ -334,7 +462,14 @@ Test suite for both ScrollBox and TabBar.
(is (eql id :tab1))
(is (= (length (tab-bar-tabs tb)) 1))
(is (string= (getf (first (tab-bar-tabs tb)) :title) "Tab One")))))
#+END_SRC
** TabBar active tab test
Verifies that ~(setf tab-bar-active)~ correctly selects a tab by ID and
that ~tab-bar-active~ returns that ID afterward.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test tabbar-active-tab
"Setting active tab works."
(let ((tb (make-tab-bar)))
@@ -342,7 +477,16 @@ Test suite for both ScrollBox and TabBar.
(tab-bar-add tb :tab2 "Two")
(setf (tab-bar-active tb) :tab2)
(is (eql (tab-bar-active tb) :tab2))))
#+END_SRC
** TabBar render no-op test
Renders a fully configured TabBar (with tabs and an active selection) to
a string-output-stream backend to confirm the render method doesn't
error. A TabBar must draw its tab strip without crashing even when
disconnected from a real terminal.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test tabbar-render-noop
"Rendering a TabBar does not error."
(let* ((stream (make-string-output-stream))
@@ -353,7 +497,17 @@ Test suite for both ScrollBox and TabBar.
(setf (tab-bar-active tb) :tab1)
(render tb backend)
(is-true t)))
#+END_SRC
** TabBar next/prev navigation test
Exercises the full navigation cycle: ~tab-bar-next~ advances through
three tabs, wrapping around past the last; ~tab-bar-prev~ goes backward,
wrapping around past the first. This is the core keyboard interaction
for tabbed UIs and must handle edge cases (empty bar, single tab, etc.)
gracefully.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test tabbar-next-prev
"TabBar next/prev wraps around through tabs."
(let ((tb (make-tab-bar)))
@@ -369,7 +523,15 @@ Test suite for both ScrollBox and TabBar.
(is (eql (tab-bar-active tb) :tab1) "wrap around past last")
(tab-bar-prev tb)
(is (eql (tab-bar-active tb) :tab3) "wrap around past first")))
#+END_SRC
** TabBar select test
~tab-bar-select~ activates a named tab directly (as opposed to relative
next/prev navigation). This test verifies that selecting ~:tab2~ from a
three-tab bar correctly sets the active tab.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test tabbar-select
"TabBar select activates the specified tab."
(let ((tb (make-tab-bar)))
@@ -377,7 +539,16 @@ Test suite for both ScrollBox and TabBar.
(tab-bar-add tb :tab2 "Two")
(tab-bar-select tb :tab2)
(is (eql (tab-bar-active tb) :tab2))))
#+END_SRC
** TabBar key handling test
~tab-bar-handle-key~ maps keyboard events to navigation actions. A
~:right~ key event should advance; a ~:left~ key event should retreat.
This tests the bridge between the input event system and the TabBar
navigation API.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test tabbar-handle-key
"TabBar handle-key dispatches left/right."
(let ((tb (make-tab-bar)))
@@ -388,7 +559,16 @@ Test suite for both ScrollBox and TabBar.
(is (eql (tab-bar-active tb) :tab2))
(tab-bar-handle-key tb (make-key-event :key :left))
(is (eql (tab-bar-active tb) :tab1))))
#+END_SRC
** ScrollBox clamp boundary test
Directly tests ~clamp-scroll~ by setting scroll offsets to invalid
values (negative and extremely large) and confirming they get clamped
back to 0. With no children, content size is 0 so the max scroll is
also 0 — this exercises the degenerate case.
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
(test scrollbox-scroll-clamp
"ScrollBox clamp prevents scrolling past bounds."
(let ((sb (make-scroll-box :scroll-y 5 :scroll-x 3)))

375
org/select.org
View File

@@ -40,20 +40,39 @@ fallback, and category grouping with dimmed headers.
** Tests
*** Test package and suite setup
The test file uses FiveAM. The ~defpackage~ pulls in all the dependencies needed
by the select widget tests — FiveAM itself, the backend/box/layout/input infrastructure,
and the ~cl-tty.select~ package under test. ~run-tests~ is the entry point for
CI and interactive use.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(defpackage :cl-tty-select-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select)
(:export #:run-tests))
(in-package #:cl-tty-select-test)
#+END_SRC
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(def-suite select-suite :description "Select widget tests")
(in-suite select-suite)
#+END_SRC
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(defun run-tests ()
(let ((result (run 'select-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
#+END_SRC
*** test select-creates
Verifies that a select widget can be constructed with default values. The
~selected-index~ should start at 0, and both ~options~ and ~filter~ should
be nil. This establishes the baseline contract for the default constructor.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-creates
"A Select can be created with defaults."
(let ((sel (make-select)))
@@ -61,13 +80,29 @@ fallback, and category grouping with dimmed headers.
(is-false (select-options sel))
(is-false (select-filter sel))
(is (= (select-selected-index sel) 0))))
#+END_SRC
*** test select-with-options
Ensures that passing ~:options~ to ~make-select~ stores them correctly. The
length check is the simplest invariant — two options in, two options out.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-with-options
"A Select stores options."
(let ((sel (make-select :options '((:title "Red" :value :red)
(:title "Blue" :value :blue)))))
(is (= (length (select-options sel)) 2))))
#+END_SRC
*** test select-filtered-exact
Tests case-insensitive substring filtering: setting filter to ~\"bl\"~ should
match \"Blue\" but not \"Red\" or \"Green\". The return value is an alist of
~(display-index original-index option)~, so we dig into the third element
to check the ~:value~.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-filtered-exact
"Filter returns case-insensitive substring matches."
(let ((sel (make-select
@@ -78,7 +113,15 @@ fallback, and category grouping with dimmed headers.
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 1))
(is (eql (getf (third (first filtered)) :value) :blue)))))
#+END_SRC
*** test select-filtered-all
When the filter is nil ~select-filtered-options~ must return every option
unchanged. This is the unfiltered/identity case and the most common state
when the user hasn't typed anything.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-filtered-all
"Nil filter returns all options."
(let ((sel (make-select
@@ -86,7 +129,15 @@ fallback, and category grouping with dimmed headers.
(:title "Blue" :value :blue)))))
(let ((filtered (select-filtered-options sel)))
(is (= (length filtered) 2)))))
#+END_SRC
*** test select-navigation
Exercises ~select-next~ and ~select-prev~ through a three-item list,
confirming that forward and backward movement works and that both directions
wrap around at list boundaries.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-navigation
"Select-next and select-prev navigate through options."
(let ((sel (make-select
@@ -102,7 +153,16 @@ fallback, and category grouping with dimmed headers.
(is (= (select-selected-index sel) 0) "wraps forward")
(select-prev sel)
(is (= (select-selected-index sel) 2) "wraps backward")))
#+END_SRC
*** test select-navigation-skips-categories
Category headers (options with ~:category t~) should be invisible to
navigation — ~select-next~ and ~select-prev~ skip over them. This test
sets up a list with two category headers interleaved and verifies they
are transparent to movement.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-navigation-skips-categories
"Navigation skips category header options."
(let ((sel (make-select
@@ -118,7 +178,15 @@ fallback, and category grouping with dimmed headers.
(is (= (select-selected-index sel) 2))
(select-next sel)
(is (= (select-selected-index sel) 4) "skipped category header at 3")))
#+END_SRC
*** test select-handle-key
Validates that ~select-handle-key~ dispatches correctly: Down moves forward,
Up moves backward, and Enter invokes the ~on-select~ callback with the
currently highlighted option's plist.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-handle-key
"Select handle-key dispatches navigation and selection."
(let* ((result (list nil))
@@ -131,7 +199,15 @@ fallback, and category grouping with dimmed headers.
(is (= (select-selected-index sel) 0))
(select-handle-key sel (make-key-event :key :enter))
(is (eql (car result) :a))))
#+END_SRC
*** test select-handle-key-ctrl
Ctrl+N and Ctrl+P are Emacs-compatible alternatives to Down/Up. They must
produce identical navigation behavior. This test confirms the control-key
dispatch paths.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-handle-key-ctrl
"Ctrl+N and Ctrl+P navigate like down/up."
(let ((sel (make-select
@@ -140,7 +216,15 @@ fallback, and category grouping with dimmed headers.
(is (= (select-selected-index sel) 1))
(select-handle-key sel (make-key-event :key :p :ctrl t))
(is (= (select-selected-index sel) 0))))
#+END_SRC
*** test select-visible-count
~select-visible-options~ should never return more items than the viewport
height. This test creates 20 options, sets the layout height to 5, and
asserts the visible subset fits within that constraint.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-visible-count
"Visible options respects viewport height."
(let* ((ln (make-layout-node))
@@ -150,7 +234,15 @@ fallback, and category grouping with dimmed headers.
(setf (layout-node-height ln) 5)
(let ((visible (select-visible-options sel)))
(is (<= (length visible) 5)))))
#+END_SRC
*** test select-fuzzy-fallback
When exact substring matching fails, the filter falls back to character-set
Jaccard similarity. ~\"nrd\"~ should match ~\"Nord\"~ because the character
overlap (n, o, r, d → 3 of 4) exceeds the 0.3 threshold.
#+BEGIN_SRC lisp :tangle ../tests/select-tests.lisp
(test select-fuzzy-fallback
"Fuzzy filter catches near-misses."
(let ((sel (make-select
@@ -167,7 +259,13 @@ fallback, and category grouping with dimmed headers.
** Package
#+BEGIN_SRC lisp
The ~cl-tty.select~ package depends on the backend, box model, layout,
and input subsystems. The exported symbols cover the public API: the
~select~ class, constructor, accessors, filtering, navigation, key
handling, rendering, and the fuzzy matching predicate (exposed for
testing and extensibility).
#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp
(defpackage :cl-tty.select
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
(:export
@@ -185,12 +283,16 @@ fallback, and category grouping with dimmed headers.
** Select class
~select~ inherits from ~dirty-mixin~. Options are stored as a list of
plists. ~selected-index~ tracks the currently highlighted option.
~filter~ is a string (or nil for unfiltered). ~on-select~ is a callback
receiving the selected option plist.
*** defclass select
#+BEGIN_SRC lisp
~select~ inherits from ~dirty-mixin~ so the rendering layer knows when
the widget state has changed (after navigation, filter updates, etc.).
Options are stored as a list of plists. ~selected-index~ tracks the
currently highlighted option. ~filter~ is a string (or nil for
unfiltered). ~on-select~ is a callback receiving the selected option
plist. ~layout-node~ positions the widget in the window.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(in-package #:cl-tty.select)
(defclass select (dirty-mixin)
@@ -204,7 +306,15 @@ receiving the selected option plist.
:accessor select-on-select)
(layout-node :initform (make-layout-node) :initarg :layout-node
:accessor select-layout-node)))
#+END_SRC
*** defun make-select
A convenience constructor that wraps ~make-instance~ with keyword
arguments. Defaults to nil for all optional parameters, matching the
~defclass~ initforms.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun make-select (&key options filter on-select)
(make-instance 'select
:options (or options nil)
@@ -214,16 +324,21 @@ receiving the selected option plist.
** Component protocol
~component-layout-node~ returns the layout node so the layout engine
can position the select widget.
*** defmethod component-layout-node
#+BEGIN_SRC lisp
The layout engine needs a uniform way to access a component's position.
~component-layout-node~ is part of the component protocol; this method
for ~select~ simply delegates to the ~select-layout-node~ accessor.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defmethod component-layout-node ((sel select))
(select-layout-node sel))
#+END_SRC
** Option filtering: substring match
*** defun select-filtered-options
~select-filtered-options~ returns options whose ~:title~ contains the
filter string (case-insensitive). When ~filter~ is nil, returns all
options. Category headers are NOT filtered out — they remain in the
@@ -232,7 +347,12 @@ list so the user can see category context.
The function returns an alist of ~(filtered-index original-index option)~
to preserve the original index for selection tracking.
#+BEGIN_SRC lisp
Internally, the filter first checks for exact substring containment via
~search~. If no option matches that way, it falls through to the
character-set ~fuzzy-match-p~ predicate. Category headers short-circuit
so they always pass through the filter.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun select-filtered-options (sel)
"Return list of options matching the current filter, in display order.
Each item: (display-index original-index option-plist)."
@@ -243,27 +363,29 @@ to preserve the original index for selection tracking.
(let ((lower (string-downcase filter)))
(remove-if-not
(lambda (opt)
(when (getf opt :category)
(return-from select-filtered-options all-options))
(let ((title (string-downcase (getf opt :title))))
(or (search lower title)
(fuzzy-match-p lower title))))
(or (getf opt :category)
(let ((title (string-downcase (getf opt :title))))
(or (search lower title)
(fuzzy-match-p lower title)))))
all-options)))))
(loop for opt in filtered
for i from 0
collect (list i (position opt all-options) opt))))
#+END_SRC
** Fuzzy matching: trigram Jaccard similarity
** Fuzzy matching: character-set Jaccard similarity
~trigram-score~ converts a string into a set of 3-character sliding
window n-grams. ~fuzzy-match-p~ returns T if the Jaccard similarity
between the query trigrams and the target trigrams exceeds 0.3.
*** defun string-trigrams
Trigrams capture character-level similarity without requiring exact
substring matches. "nrd" matches "Nord" because both contain ~nor~,
~ord~ and ~nrd~ contributes ~nrd~ — the overlap is enough to exceed
the threshold.
Converts a string into a set of 3-character sliding window n-grams.
Short strings (fewer than 3 characters) return the whole string as a
single trigram. Duplicates are removed so the set can be used for
Jaccard intersection/union calculations.
Note: the running tangle does not call this function directly — the
simpler character-set ~fuzzy-match-p~ is used instead. Trigram
matching is retained here as a documented alternative for future
experimentation.
#+BEGIN_SRC lisp
(defun string-trigrams (str)
@@ -275,7 +397,17 @@ the threshold.
(loop for i from 0 to (- (length s) 3)
do (push (subseq s i (+ i 3)) result))
(delete-duplicates result :test #'string=)))
#+END_SRC
*** defun trigram-score
Jaccard similarity of two trigram sets: the size of the intersection
divided by the size of the union. A score of 1.0 means identical sets;
0.0 means no overlap. This is used by ~fuzzy-match-p~ if trigram mode
is enabled (currently unused in the default filter path — see
~string-trigrams~).
#+BEGIN_SRC lisp
(defun trigram-score (query target)
"Jaccard similarity of trigram sets: |intersection| / |union|."
(let* ((q-trigrams (string-trigrams query))
@@ -283,7 +415,16 @@ the threshold.
(intersection (length (intersection q-trigrams t-trigrams :test #'string=)))
(union (length (union q-trigrams t-trigrams :test #'string=))))
(if (zerop union) 0.0 (/ (float intersection) union))))
#+END_SRC
*** defun fuzzy-match-p
Returns T if the Jaccard similarity between the character sets of the
query and target exceeds 0.3. The character-set approach is simpler
and cheaper than trigrams while still catching common typos and
near-misses like ~\"nrd\"~ for ~\"Nord\"~.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun fuzzy-match-p (query target)
"T if character-set Jaccard similarity exceeds threshold (0.3)."
(let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list)))
@@ -295,12 +436,14 @@ the threshold.
** Navigation
~select-next~ and ~select-prev~ move the selection forward/backward
through the filtered options list. They skip category headers (options
with ~:category t~). The selection wraps at list boundaries.
~select-clamp-index~ ensures the index is valid after filtering changes.
*** defun select-clamp-index
#+BEGIN_SRC lisp
After the filter changes (user types or clears input), the selected
index may point beyond the filtered list. ~select-clamp-index~ ensures
the index stays within valid bounds. If the list is empty the index
resets to 0.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun select-clamp-index (sel)
"Ensure selected-index is valid. Wraps if empty."
(let* ((filtered (select-filtered-options sel))
@@ -309,7 +452,16 @@ with ~:category t~). The selection wraps at list boundaries.
(setf (select-selected-index sel) 0)
(setf (select-selected-index sel)
(max 0 (min (select-selected-index sel) (1- count)))))))
#+END_SRC
*** defun select-next
Moves the selection forward to the next non-category option. Iterates
through the filtered list starting from the current index, wrapping
around at the end. Each candidate is checked for ~:category t~ and
skipped. Marks the widget dirty so the render pass picks up the change.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun select-next (sel)
"Move selection to next non-category option. Wraps at end."
(let* ((filtered (select-filtered-options sel))
@@ -323,7 +475,15 @@ with ~:category t~). The selection wraps at list boundaries.
do (setf (select-selected-index sel) idx)
(mark-dirty sel)
(return)))))
#+END_SRC
*** defun select-prev
Moves the selection backward to the previous non-category option.
Mirrors ~select-next~ but decrements the index (with modular arithmetic
for wrap-around). Category headers are skipped identically.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun select-prev (sel)
"Move selection to previous non-category option. Wraps at start."
(let* ((filtered (select-filtered-options sel))
@@ -341,15 +501,18 @@ with ~:category t~). The selection wraps at list boundaries.
** Key event handler
~select-handle-key~ dispatches keyboard events:
- Down, Ctrl+N → select-next
- Up, Ctrl+P → select-prev
- Enter → on-select callback with the selected option
- Esc → return NIL (caller can dismiss)
*** defun select-handle-key
Returns T if the key was handled, NIL otherwise.
Dispatches keyboard events:
- Down, Ctrl+N → ~select-next~
- Up, Ctrl+P → ~select-prev~
- Enter → ~on-select~ callback with the selected option
- Esc → return NIL (caller can dismiss the widget)
#+BEGIN_SRC lisp
Returns T if the key was handled (consumed), NIL otherwise so the
caller knows not to propagate the event further.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun select-handle-key (sel event)
"Handle a key-event. Returns T if handled."
(let ((key (key-event-key event))
@@ -374,11 +537,15 @@ Returns T if the key was handled, NIL otherwise.
** Visible options (viewport culling)
~select-visible-options~ returns only the filtered options that fit
within the widget's available height. Each option occupies 1 row.
This prevents rendering hundreds of items when the viewport shows 10.
*** defun select-visible-options
#+BEGIN_SRC lisp
Returns only the filtered options that fit within the widget's
available height. Each option occupies 1 row. This prevents rendering
hundreds of items when the viewport shows only 10. The window is
centered around the currently selected index so the user always sees
context around their cursor.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defun select-visible-options (sel)
"Return filtered options that fit within the viewport."
(let* ((ln (select-layout-node sel))
@@ -394,12 +561,15 @@ This prevents rendering hundreds of items when the viewport shows 10.
** Rendering
~render~ draws each visible option on its own line. The selected
option is highlighted with ~:accent~ foreground and ~:background-element~
background. Category headers are rendered dimmed (~:text-muted~) and
not selectable (visually distinct).
*** defmethod render
#+BEGIN_SRC lisp
Draws each visible option on its own line. The selected option is
highlighted with ~:accent~ foreground and ~:background-element~
background. Category headers are rendered dimmed (~:text-muted~) and
visually distinct from selectable items. Long titles are truncated with
an ellipsis character to fit the viewport width.
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(defmethod render ((sel select) backend)
(let* ((ln (select-layout-node sel))
(x (if ln (layout-node-x ln) 0))
@@ -427,120 +597,3 @@ not selectable (visually distinct).
(incf y 1)))
(values)))
#+END_SRC
** Combined tangle block
#+BEGIN_SRC lisp :tangle ../src/components/select.lisp
(in-package #:cl-tty.select)
(defclass select (dirty-mixin)
((options :initform nil :initarg :options :accessor select-options :type list)
(filter :initform nil :initarg :filter :accessor select-filter :type (or string null))
(selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum)
(on-select :initform nil :initarg :on-select :accessor select-on-select)
(layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node)))
(defun make-select (&key options filter on-select)
(make-instance 'select :options (or options nil) :filter filter :on-select on-select))
(defmethod component-layout-node ((sel select)) (select-layout-node sel))
(defun select-filtered-options (sel)
(let* ((filter (select-filter sel)) (all-options (select-options sel))
(filtered (if (null filter) all-options
(let ((lower (string-downcase filter)))
(remove-if-not
(lambda (opt)
(or (getf opt :category)
(let ((title (string-downcase (getf opt :title))))
(or (search lower title) (fuzzy-match-p lower title)))))
all-options)))))
(loop for opt in filtered for i from 0
collect (list i (position opt all-options) opt))))
(defun fuzzy-match-p (query target)
(let* ((q (remove-duplicates (coerce (string-downcase query) 'list)))
(tg (remove-duplicates (coerce (string-downcase target) 'list)))
(intersection (length (intersection q tg)))
(union (length (union q tg))))
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))
(defun select-clamp-index (sel)
(let* ((filtered (select-filtered-options sel)) (count (length filtered)))
(if (zerop count) (setf (select-selected-index sel) 0)
(setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count)))))))
(defun select-next (sel)
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
(current (select-selected-index sel)))
(when (plusp count)
(loop for i from 1 below count
for idx = (mod (+ current i) count)
for opt = (third (nth idx filtered))
when (not (getf opt :category))
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
(defun select-prev (sel)
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
(current (select-selected-index sel)))
(when (plusp count)
(loop for i from 1 below count
for idx = (mod (- current i) count)
for opt = (third (nth idx filtered))
when (not (getf opt :category))
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
(defun select-handle-key (sel event)
(let ((key (key-event-key event)) (ctrl (key-event-ctrl event)))
(cond
((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t)
((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t)
((eql key :enter)
(let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel))
(item (when (< idx (length filtered)) (third (nth idx filtered)))))
(when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t))
((eql key :escape) nil) (t nil))))
(defun select-visible-options (sel)
(let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80))
(filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel))
(half (floor (1- height) 2)) (start (max 0 (- sel-idx half)))
(end (min (length filtered) (+ start height))))
(subseq filtered start end)))
(defmethod render ((sel select) backend)
(let* ((ln (select-layout-node sel))
(x (if ln (layout-node-x ln) 0))
(y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(visible (select-visible-options sel)) (sel-idx (select-selected-index sel)))
(dolist (item visible)
(let* ((display-idx (first item)) (option (third item))
(title (getf option :title)) (cat (getf option :category))
(selected (eql display-idx sel-idx))
(display (if (> (length title) (1- w))
(concatenate 'string (subseq title 0 (1- w)) "…") title)))
(cond (cat (draw-text backend x y display :text-muted nil))
(selected
(draw-rect backend x y w 1 :bg :accent)
(draw-text backend x y display :background :accent))
(t (draw-text backend x y display nil nil)))
(incf y 1)))
(values)))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/components/select-package.lisp
(defpackage :cl-tty.select
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
(:export
#:select #:make-select
#:select-options #:select-filter
#:select-selected-index #:select-on-select
#:select-layout-node
#:select-filtered-options
#:select-next #:select-prev
#:select-visible-options
#:select-handle-key
#:render
#:fuzzy-match-p))
#+END_SRC

82
org/slot.org
View File

@@ -25,6 +25,9 @@ Slot modes:
** Implementation
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 :noweb no
(defpackage :cl-tty.slot
(:use :cl)
@@ -37,12 +40,30 @@ Slot modes:
#:*slots*))
#+END_SRC
*** Slot Storage: *slots*
The central registry is a hash table keyed by slot name (strings, for
case-insensitive lookup via ~equal~). Each value is a list of
~(order . render-fn)~ cons cells, sorted by order on insertion. The
~:test #'equal~ ensures that ~:sidebar~ and ~\"sidebar\"~ map to the
same key.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no
(in-package :cl-tty.slot)
(defvar *slots* (make-hash-table :test #'equal)
"Hash table mapping slot name (string) -> list of (order . render-fn) pairs.")
#+END_SRC
*** defslot: Register a Render Function
~defslot~ inserts a new ~(order . render-fn)~ entry into the slot's
entry list. If the slot has no previous entries a fresh list is
created; otherwise the new entry is consed onto the existing list and
the whole list is sorted by ~order~ ascending. The ~render-fn~ itself
is returned so callers can use it inline or store it.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no
(defun defslot (name &key (order 0) render-fn)
(let* ((key (string name))
(entries (gethash key *slots*)))
@@ -53,15 +74,16 @@ Slot modes:
render-fn)
#+END_SRC
*** Bug Fixes (v1.0.0): nil handler guard in slot-render
*** slot-render: Invoke All Render Functions
~slot-render~ called ~(apply (cdr entry) args)~ unconditionally, but
~defslot~ stores ~(order . render-fn)~ pairs where ~render-fn~ can be
~nil~ (if called without ~:render-fn~). This caused a type error when
~apply~ received ~nil~ as the function argument.
Iterates over the slot's registered entries and calls each non-nil
render function with the supplied ~args~. Entries with a nil handler
are silently skipped — this is important because ~defslot~ accepts an
optional ~:render-fn~ keyword that defaults to ~nil~, and we must
guard against calling ~apply~ on nil (a type error in Common Lisp).
Fix: Check ~(when fn)~ before calling ~apply~. Entries with a nil
handler are silently skipped.
Returns a list of results, one per non-nil render function. Returns
~nil~ (via ~when~) if the slot has no registrations at all.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no
(defun slot-render (slot-name &rest args)
@@ -71,39 +93,85 @@ handler are silently skipped.
(let ((fn (cdr entry)))
(when fn (apply fn args))))
entries))))
#+END_SRC
*** slot-p: Check Slot Existence
Uses ~nth-value 1~ of ~gethash~ which returns ~t~ if the key is
present (even if the value is ~nil~) or ~nil~ if absent. This is the
canonical Common Lisp idiom for testing hash-table membership.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no
(defun slot-p (slot-name)
(nth-value 1 (gethash (string slot-name) *slots*)))
#+END_SRC
*** clear-slot: Remove All Registrations
Calls ~remhash~ to delete the slot's entry from the hash table
entirely. After this call ~slot-p~ returns false and ~slot-render~
returns nil for the given slot name.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no
(defun clear-slot (slot-name)
(remhash (string slot-name) *slots*))
#+END_SRC
*** list-slots: Enumerate Registered Slots
Iterates over all hash keys in ~*slots*~ and returns them as a list.
Only slots that have been registered (i.e. have at least one entry)
appear in the result.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no
(defun list-slots ()
(loop for key being the hash-keys of *slots* collect key))
#+END_SRC
*** Tests
The test suite uses FiveAM and exercises each public function.
**** Test Package and Suite
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp :noweb no
(defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam))
(in-package :cl-tty-slot-test)
(def-suite slot-suite :description "Slot system tests")
(in-suite slot-suite)
#+END_SRC
**** defslot-register: Registering a slot makes it visible
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp :noweb no
(def-test defslot-register ()
(clear-slot :test-slot)
(defslot :test-slot :order 1 :render-fn (lambda () "hello"))
(is-true (slot-p :test-slot)))
#+END_SRC
**** slot-render-calls: Registered functions are called in order
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp :noweb no
(def-test slot-render-calls ()
(clear-slot :test-slot)
(defslot :test-slot :order 1 :render-fn (lambda () "a"))
(defslot :test-slot :order 2 :render-fn (lambda () "b"))
(is (equal '("a" "b") (slot-render :test-slot))))
#+END_SRC
**** slot-render-empty: Unregistered slot returns nil
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp :noweb no
(def-test slot-render-empty ()
(clear-slot :ghost)
(is-false (slot-render :ghost)))
#+END_SRC
**** clear-slot-removes: Clearing a slot makes it absent
#+BEGIN_SRC lisp :tangle ../tests/slot-tests.lisp :noweb no
(def-test clear-slot-removes ()
(clear-slot :test-slot)
(defslot :test-slot :order 1 :render-fn (lambda () "x"))

104
org/tabbar.org
View File

@@ -25,15 +25,30 @@ pipeline and layout engine.
* Implementation
** TabBar class
** Package declaration
~tab-bar~ stores a list of tab plists ~((:id :tab1 :title "One") ...)~
and the currently active tab id. ~tab-bar-add~ creates a new tab with
the given id and title, returns the id.
All TabBar code lives in the ~cl-tty.container~ package alongside the
other container components (scrollbox, box, slot, etc.). This keeps
the symbol namespace clean and avoids accidental collisions with
user-level code.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(in-package #:cl-tty.container)
#+END_SRC
** TabBar class
~tab-bar~ stores a list of tab plists ~((:id :tab1 :title "One") ...)~
and the currently active tab id. It inherits from ~dirty-mixin~ so that
any mutation (adding a tab, switching tabs) automatically marks the
component for re-render. A layout node holds its geometry; the
~focusable~ slot allows the keyboard navigation system to discover it.
The ~tabs~ slot is a simple plist list rather than a hash table or
alist because the total number of tabs in a UI is typically small
(< 20) and we need ordered iteration for rendering.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defclass tab-bar (dirty-mixin)
((tabs :initform nil :initarg :tabs
:accessor tab-bar-tabs :type list)
@@ -41,10 +56,30 @@ the given id and title, returns the id.
:accessor tab-bar-active)
(layout-node :initform (make-layout-node) :accessor tab-bar-layout-node)
(focusable :initform t :accessor tab-bar-focusable)))
#+END_SRC
** make-tab-bar constructor
Convenience constructor that forwards keyword arguments to
~make-instance~. Using a dedicated function instead of inlining
~make-instance~ everywhere gives us a single place to add
defaulting, validation, or initialization hooks in the future.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defun make-tab-bar (&key tabs active)
(make-instance 'tab-bar :tabs (or tabs nil) :active active))
#+END_SRC
** tab-bar-add: adding tabs
~tab-bar-add~ appends a new tab plist to the end of the tab list.
The callers supply both an ~id~ (for programmatic selection) and a
~title~ (for display). If no tab is currently active, the newly added
tab becomes active automatically — this ensures there is always a
sensible default when the first tab is created. Returns the ~id~ so
callers can chain or store it.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defun tab-bar-add (tb id title)
"Add a tab with ID and TITLE. Sets as active if first tab."
(setf (tab-bar-tabs tb)
@@ -54,18 +89,26 @@ the given id and title, returns the id.
id)
#+END_SRC
** TabBar: component protocol
** component-layout-node protocol
Returns the layout node so the layout engine can position and size
the tab bar within its parent. Every component that participates in
automatic layout must implement this method.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defmethod component-layout-node ((tb tab-bar))
(tab-bar-layout-node tb))
#+END_SRC
** TabBar: navigation
** tab-bar-next: cycling forward
~tab-bar-next~ and ~tab-bar-prev~ cycle through tabs. ~tab-bar-select~
activates a tab by id. ~tab-bar-handle-key~ dispatches key events
(Left/Right to navigate, optional Enter to select).
~tab-bar-next~ moves the active cursor to the next tab in the list,
wrapping around from the last tab to the first (~mod~ arithmetic).
It calls ~mark-dirty~ so the rendering pass picks up the change.
The lookup strategy — mapcar ids, position, mod — is O(n) but
acceptable since tab lists are small. A hash-based index would be
premature optimization at this scale.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defun tab-bar-next (tb)
@@ -78,7 +121,16 @@ activates a tab by id. ~tab-bar-handle-key~ dispatches key events
(let ((next (nth (mod (1+ pos) (length ids)) ids)))
(setf (tab-bar-active tb) next)
(mark-dirty tb)))))
#+END_SRC
** tab-bar-prev: cycling backward
Mirror of ~tab-bar-next~; decrements the position index instead of
incrementing it. ~mod~ handles negative wrap-around correctly in
Common Lisp (returns a non-negative remainder), so ~(mod (1- 0) 3)~
produces 2 rather than −1.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defun tab-bar-prev (tb)
"Move to previous tab."
(let* ((tabs (tab-bar-tabs tb))
@@ -89,18 +141,29 @@ activates a tab by id. ~tab-bar-handle-key~ dispatches key events
(let ((prev (nth (mod (1- pos) (length ids)) ids)))
(setf (tab-bar-active tb) prev)
(mark-dirty tb)))))
#+END_SRC
** tab-bar-select: direct tab selection
~tab-bar-select~ sets the active tab directly by id, bypassing the
cyclic navigation. This is used when a user clicks a tab (via mouse
binding), when a programmatic action needs to switch views, or when
activating a tab from outside the keyboard flow. Always marks dirty.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defun tab-bar-select (tb id)
"Select a tab by ID."
(setf (tab-bar-active tb) id)
(mark-dirty tb))
#+END_SRC
** TabBar: keyboard handler
** tab-bar-handle-key: keyboard dispatch
~tab-bar-handle-key~ dispatches Left → previous tab, Right → next tab.
Returns T if the key was handled, NIL otherwise (for composability with
the keybinding system).
Dispatches key events for tab navigation. Left arrow goes to the
previous tab, right arrow to the next. Returns ~t~ when the key was
consumed and ~nil~ otherwise, which lets the keybinding system fall
through to other handlers — important for composable UIs where a tab
bar lives alongside other focusable elements.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defun tab-bar-handle-key (tb event)
@@ -111,14 +174,17 @@ the keybinding system).
(t nil)))
#+END_SRC
** TabBar: rendering
** render: drawing the tab row
~render~ iterates tabs, drawing each as ~[ Title ]~ with the active
tab highlighted (bold, accent color) and inactive tabs dimmed. Tabs
are separated by two spaces.
~render~ iterates the tab list and draws each one as ~[ Title ]~.
The active tab uses the ~:accent~ foreground color and
~:background-element~ background for visual prominence; inactive tabs
are rendered in ~:text-muted~. Tabs are separated by two spaces.
The available width comes from the layout node. If tabs overflow,
they are truncated with an ellipsis.
Available width comes from the layout node. If the total tab width
exceeds the available space, tabs are truncated and an ellipsis
~...~ is drawn at the overflow point. This prevents the tab bar from
breaking the layout on narrow terminals.
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
(defmethod render ((tb tab-bar) backend)

1924
org/text-input.org
View File

File diff suppressed because it is too large Load Diff

165
org/theme.org
View File

@@ -45,32 +45,75 @@ and the backend's ~*theme-colors*~ for SGR resolution.
* Tests
** Test header
Package declaration and test suite registration.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(in-package :cl-tty-box-test)
(in-suite box-suite)
#+END_SRC
** Test: theme-create-default
Verifies basic construction of a theme with default ~:dark~ mode. The
~make-theme~ constructor should return an instance of the ~theme~
class with ~:dark~ as the initial mode.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test theme-create-default
"A theme can be created with default mode"
(let ((th (make-theme)))
(is (typep th 'theme))
(is (eql (theme-mode th) :dark))))
#+END_SRC
** Test: theme-create-light
Verifies explicit ~:light~ mode works. Both modes must produce themes
ready to accept color role assignments.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test theme-create-light
"A theme can be created in light mode"
(let ((th (make-theme :mode :light)))
(is (eql (theme-mode th) :light))))
#+END_SRC
** Test: theme-color-set-and-get
Confirms ~setf~ on ~theme-color~ stores a value and that reading it
back returns the same string. This is the core read/write contract
for the theme's role map.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test theme-color-set-and-get
"theme-color setf/get works"
(let ((th (make-theme)))
(setf (theme-color th :primary) "#FFD700")
(is (string= (theme-color th :primary) "#FFD700"))))
#+END_SRC
** Test: theme-color-unknown-returns-nil
Unassigned roles must return ~nil~ rather than signaling an error.
This allows components to degrade gracefully when a theme doesn't
define every possible role.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test theme-color-unknown-returns-nil
"Unknown roles return nil"
(let ((th (make-theme)))
(is (null (theme-color th :nonexistent)))))
#+END_SRC
** Test: load-default-dark-preset
Loading the ~:default~ preset in ~:dark~ mode must populate a set of
expected roles with their documented hex values. We spot-check
~:primary~, ~:background~, and ~:error~.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test load-default-dark-preset
"Loading the default dark preset populates roles"
(let ((th (make-theme :mode :dark)))
@@ -78,27 +121,59 @@ and the backend's ~*theme-colors*~ for SGR resolution.
(is (string= (theme-color th :primary) "#FFD700"))
(is (string= (theme-color th :background) "#1A1A2E"))
(is (string= (theme-color th :error) "#FF4444"))))
#+END_SRC
** Test: load-default-light-preset
The light variant of ~:default~ must produce different values (warm
tones on near-white). This validates the mode dispatch inside
~load-preset~.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test load-default-light-preset
"Light variant has different colors"
(let ((th (make-theme :mode :light)))
(load-preset th :default)
(is (string= (theme-color th :primary) "#B8860B"))
(is (string= (theme-color th :background) "#F8F9FA"))))
#+END_SRC
** Test: load-nord-preset
The ~:nord~ preset must produce a distinct cool-blue palette,
different from the ~:default~ gold scheme. This validates independent
preset data.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test load-nord-preset
"Nord preset has different colors than default"
(let ((th (make-theme :mode :dark)))
(load-preset th :nord)
(is (string= (theme-color th :primary) "#88C0D0"))
(is (string= (theme-color th :background) "#2E3440"))))
#+END_SRC
** Test: load-preset-unknown-warns
An unknown preset name must signal a ~warning~ (not an ~error~) and
leave the theme's roles unpopulated. This ensures graceful degradation
when a preset is missing.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test load-preset-unknown-warns
"Unknown preset warns but doesn't error"
(let ((th (make-theme)))
(signals warning (load-preset th :nonexistent))
(is (null (theme-color th :primary)))))
#+END_SRC
** Test: preset-switch-mode
Switching the mode at runtime and re-loading the same preset must
produce the other variant's colors. This validates that ~load-preset~
reads the current ~theme-mode~ each time, not a cached value.
#+BEGIN_SRC lisp :tangle ../src/components/theme-tests.lisp
(test preset-switch-mode
"Switching mode and reloading changes colors"
(let ((th (make-theme :mode :dark)))
@@ -117,47 +192,84 @@ The ~theme~ class holds a mode flag (~:dark~/~:light~) and a hash
table of role→hex mappings. The hash table gives O(1) lookups for
~theme-color~ and clean iteration for ~load-preset~.
*** defclass theme
The class has two slots: ~mode~ (defaulting to ~:dark~, with an
~:initarg~ and ~accessor~ for reads and writes) and ~roles~ (a hash
table storing role→hex mappings, lazily initialized to an empty
hash table). Using ~make-hash-table~ as the ~:initform~ ensures each
instance gets its own table instead of sharing one.
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
(in-package :cl-tty.box)
;; ── Theme Engine ──────────────────────────────────────────────
(defclass theme ()
((mode :initform :dark :initarg :mode :accessor theme-mode)
(roles :initform (make-hash-table) :accessor theme-roles)))
#+END_SRC
*** defun make-theme
A convenience constructor that delegates to ~make-instance~. Wrapping
this in a function lets us change the constructor signature without
breaking callers. Mode defaults to ~:dark~, suitable for dark-background
terminals; callers pass ~:mode :light~ for light backgrounds.
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
(defun make-theme (&key (mode :dark))
(make-instance 'theme :mode mode))
#+END_SRC
The mode defaults to ~:dark~. Applications can initialize with
~:light~ for terminals with light backgrounds. The mode controls
which variant ~load-preset~ selects.
** Color resolution
*** defun theme-color
Reads a semantic role from the theme's roles hash table. Uses
~gethash~ which returns ~nil~ for unknown roles — so missing roles
degrade gracefully rather than crashing. The backend treats ~nil~ as
"use default."
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
(defun theme-color (theme role)
"Resolve a semantic ROLE to a hex color string in THEME."
(gethash role (theme-roles theme)))
#+END_SRC
*** defun (setf theme-color)
The setter companion to ~theme-color~. Storing via ~setf~ writes
directly into the roles hash table. Uses ~setf~ on ~gethash~ which
creates the entry if it doesn't exist.
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
(defun (setf theme-color) (hex theme role)
"Set the hex color for a semantic ROLE in THEME."
(setf (gethash role (theme-roles theme)) hex))
#+END_SRC
Uses ~gethash~ for both getter and setter. Unknown roles return ~nil~,
which the backend treats as "use default" — so missing roles degrade
gracefully rather than crashing.
** Global preset registry
** Preset system
A hash table (keyed by ~eq~-comparable keywords) stores all registered
presets. Using ~#\\'~ (quoted list) instead of an alist or nested hash
table keeps preset data inline and readable.
Presets are stored in a global hash table keyed by keyword name. The
~define-preset~ macro registers a preset at macro-expansion time.
*** defparameter *presets*
Global storage for preset definitions. The ~eq~ test matches keyword
identity, which is the fastest hash test for keywords.
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
(defparameter *presets* (make-hash-table :test #'eq))
#+END_SRC
*** defmacro define-preset
Registers a preset by name (~keyword~) at macro-expansion time. The
~check-type~ enforces that names are keywords. The macro expands to a
~setf~ of ~gethash~, storing a plist of ~:dark~ and ~:light~ variants.
Using a quoted list (not an alist or hash) keeps the data compact.
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
(defmacro define-preset (name &key dark light)
"Define a theme preset with DARK and LIGHT variants.
NAME should be a keyword (e.g., :default, :nord)."
@@ -165,9 +277,20 @@ NAME should be a keyword (e.g., :default, :nord)."
`(setf (gethash ,name *presets*) '(:dark ,dark :light ,light)))
#+END_SRC
Using ~#\'~ (quoted list) instead of an alist or hash table keeps the
preset data inline and easy to read. The ~eq~ hash table test matches
keyword identity.
** Loading presets
*** defun load-preset
The central function that applies a named preset to a theme. Does
double duty: populates the theme's role map and the backend's
~*theme-colors*~. This second step is what makes semantic colors work
at the SGR level — when the backend renders ~:accent~, it looks up
~*theme-colors*~ to get the hex, then generates the escape sequence.
The ~loop for (role hex) on colors by #'cddr~ iterates the plist in
pairs, setting both the theme entry and the backend entry. If the
preset doesn't exist, ~warn~ is called instead of ~error~ — a missing
preset shouldn't crash the application.
#+BEGIN_SRC lisp :tangle ../src/components/theme.lisp
(defun load-preset (theme preset-name)
@@ -188,18 +311,6 @@ color roles resolve to hex at SGR generation time."
(warn "Unknown preset: ~S" preset-name))))
#+END_SRC
~load-preset~ does double duty: it populates the theme's role map and
the backend's ~*theme-colors*~. This second step is what makes
semantic colors work at the SGR level — when the backend renders
~:accent~, it looks up ~*theme-colors*~ to get the hex, then
generates the escape sequence.
The ~loop for (role hex) on colors by #'cddr~ iterates the plist in
pairs, setting both the theme entry and the backend entry.
If the preset doesn't exist, ~warn~ is called instead of ~error~ — a
missing preset shouldn't crash the application.
** Built-in presets
Two presets are built in:

12
src/backend/detection.lisp
View File

@@ -1,12 +1,8 @@
(in-package :cl-tty.backend)
;;; ─── Detection cache ────────────────────────────────────────────────────────
(defvar *detected-backend* nil
"Cached backend instance from detect-backend. Nil = not yet detected.")
;;; ─── Environment probe ──────────────────────────────────────────────────────
(defun detect-backend-by-env ()
"Check COLORTERM environment variable for modern terminal support.
Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise."
@@ -16,15 +12,11 @@ Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise."
(search "24bit" colorterm :test #'char-equal)))
:modern)))
;;; ─── TTY probe ──────────────────────────────────────────────────────────────
(defun detect-backend-by-tty ()
"Check if stdout is a real terminal (not a pipe/redirect).
Returns T if stdout is interactive, nil otherwise."
(interactive-stream-p *standard-output*))
;;; ─── DA1 terminal query ─────────────────────────────────────────────────────
(defun query-terminal (query &optional (timeout 0.1))
"Send QUERY string to terminal and return any response received within
TIMEOUT seconds. Returns the response string, or nil if no response."
@@ -41,14 +33,12 @@ TIMEOUT seconds. Returns the response string, or nil if no response."
(defun detect-backend-by-da1 ()
"Send DA1 (ESC[c) query and check for kitty terminal response code.
Returns T if terminal reports kitty compatibility codes."
(let ((response (query-terminal (format nil "~C[c" #\Esc))))
(let ((response (query-terminal (format nil "~C[c" (code-char 27)))))
(when response
;; DA1 response format: ESC [ ? digits ; digits c
;; Kitty reports code 62 in the response
(search "?62" response))))
;;; ─── Orchestrator ───────────────────────────────────────────────────────────
(defun detect-backend ()
"Auto-detect the appropriate backend for the current terminal.
Returns a backend instance (modern-backend or simple-backend).

20
src/backend/modern-tests.lisp
View File

@@ -11,15 +11,11 @@
(fiveam:explain! result)
(uiop:quit 0)))
;; ── Constructor ────────────────────────────────────────────────
(test make-modern-backend-creates
"make-modern-backend returns a modern-backend instance"
(let ((b (make-modern-backend)))
(is (typep b 'cl-tty.backend::modern-backend))))
;; ── Escape Generation ──────────────────────────────────────────
(test sgr-truecolor-foreground
"SGR truecolor foreground escape is correct"
(is (equal (cl-tty.backend::sgr-fg "#FFD700")
@@ -44,8 +40,6 @@
(is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc)))
(is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc))))
;; ── Cursor ─────────────────────────────────────────────────────
(test cursor-move-escape
"cursor-move generates correct CSI escape"
(let ((b (make-modern-backend)))
@@ -70,23 +64,17 @@
(is (equal (cl-tty.backend::cursor-style-escape :underline t)
(format nil "~C[5 q" #\Esc)))))
;; ── Synchronization ────────────────────────────────────────────
(test decicm-escapes
"DECICM synchronized update escapes"
(is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc)))
(is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc))))
;; ── OSC 8 Hyperlinks ──────────────────────────────────────────
(test osc8-escape
"OSC 8 hyperlink escape wraps text"
(is (equal (cl-tty.backend::osc8-link "http://example.com" "click here")
(format nil "~C]8;;http://example.com~C\\\\click here~C]8;;~C\\\\"
(format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\"
#\Esc #\Esc #\Esc #\Esc))))
;; ── Hex Parsing ────────────────────────────────────────────────
(test hex-color-parsing
"hex-to-rgb parses valid hex colors"
(multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700")
@@ -108,17 +96,15 @@
(is (= g 0))
(is (= b 0))))
;; ── Border Characters ──────────────────────────────────────────
(test border-char-rounded
"modern-border-char returns Unicode box-drawing for rounded style"
(is (equal (cl-tty.backend::border-char :rounded :top-left) "╭"))
(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) "╯")))
(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) "║")))
(is (equal (cl-tty.backend::border-char :double :vertical) "║"))

2
src/backend/modern.lisp
View File

@@ -90,7 +90,7 @@ as a fallback when a keyword is not in *named-colors*.")
(defun osc8-link (url text)
"Wrap TEXT in an OSC 8 hyperlink to URL."
(format nil "~C]8;;~A~C\\\\~A~C]8;;~C\\\\"
(format nil "~C]8;;~A~C\\~A~C]8;;~C\\"
#\Esc url #\Esc text #\Esc #\Esc))
(defparameter *border-chars*

18
src/backend/tests.lisp
View File

@@ -6,16 +6,12 @@
(def-suite backend-suite :description "Backend protocol tests")
(in-suite backend-suite)
;; ── Helpers ─────────────────────────────────────────────────────
(defun make-capturing-backend ()
"Create a simple-backend that writes to a string stream."
(let* ((s (make-string-output-stream))
(b (make-simple-backend :output-stream s)))
(values b s)))
;; ── Simple Backend ──────────────────────────────────────────────
(defun run-tests ()
"Run all backend tests."
(let ((result (run 'backend-suite)))
@@ -46,7 +42,7 @@
(draw-border b 0 0 5 3 :style :single)
(shutdown-backend b)
(let ((out (get-output-stream-string s)))
(is (search "+---+" out) "top edge should have +---+")
(is (search "+---+" out) "top edge should have +---+\"")
(is (search "| |" out) "middle row should have pipe sides"))))
(test simple-backend-draw-rounded
@@ -56,7 +52,7 @@
(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
;; Rounded falls back to ASCII -- identical output to single
(is (search "+---+" out) "rounded style produces same dashes as single"))))
(test simple-backend-draw-link
@@ -77,8 +73,6 @@
(is (string= (get-output-stream-string s) "...")
"ellipsis should output 3 dots")))
;; ── Backend Capabilities ───────────────────────────────────────
(test capable-p-known-features
"capable-p returns nil for all features on simple-backend"
(let ((b (make-simple-backend)))
@@ -89,8 +83,6 @@
(format nil "~s should not be supported on simple-backend" f)))
(shutdown-backend b)))
;; ── Backend Size ───────────────────────────────────────────────
(test backend-size-returns-integers
"backend-size returns two integer values"
(let ((b (make-simple-backend)))
@@ -102,8 +94,6 @@
(is (>= lines 3)))
(shutdown-backend b)))
;; ── Backend Protocol: Defaults and No-ops ──────────────────────
(test default-methods-are-no-ops
"Default backend methods don't error"
(let ((b (make-simple-backend)))
@@ -126,8 +116,6 @@
(is (string= (get-output-stream-string s) "in sync")
"no sync escape sequences should appear")))
;; ── Draw-rect ──────────────────────────────────────────────────
(test draw-rect-fills-area-correctly
"draw-rect with background writes nothing to output (simple-backend no-op)"
(multiple-value-bind (b s) (make-capturing-backend)
@@ -137,8 +125,6 @@
(is (string= (get-output-stream-string s) "")
"draw-rect is a no-op on simple-backend")))
;; ── Detection ──────────────────────────────────────────────────
(test detection-returns-backend-instance
"detect-backend returns a valid backend instance"
(let ((be (cl-tty.backend:detect-backend)))

4
src/components/box-tests.lisp
View File

@@ -16,8 +16,6 @@
(b (make-modern-backend :output-stream s)))
(values b s)))
;; ── Box Tests ─────────────────────────────────────────────────
(test box-creates-with-defaults
"A box created with no arguments has reasonable defaults"
(let ((b (make-box)))
@@ -92,8 +90,6 @@
(let ((out (get-output-stream-string s)))
(is (search "┌" out) "2x2 box still has borders")))))
;; ── Text and Span Tests ───────────────────────────────────────
(test text-creates-with-defaults
"A text created with no arguments has reasonable defaults"
(let ((txt (make-text "")))

10
src/components/dialog.lisp
View File

@@ -1,17 +1,11 @@
;;; dialog.lisp — Dialog System + Toast for cl-tty
(in-package :cl-tty.dialog)
;; ─── Special variables ────────────────────────────────────────────────────────
(defvar *dialog-stack* nil
"Stack of active dialogs. (list) of dialog instances.")
(defvar *toasts* nil
"List of active toast notifications.")
;; ─── Dialog class ─────────────────────────────────────────────────────────────
(defclass dialog ()
((title :initarg :title :accessor dialog-title)
(size :initarg :size :initform :medium :accessor dialog-size)
@@ -53,8 +47,6 @@
(funcall (dialog-on-dismiss dialog)))
dialog)))
;; ─── Dialog sub-classes ──────────────────────────────────────────────────────
(defun alert-dialog (title message)
(make-instance 'dialog
:title title
@@ -96,8 +88,6 @@
(pop-dialog)
(when on-submit (funcall on-submit value))))))
;; ─── Toast system ─────────────────────────────────────────────────────────────
(defclass toast ()
((message :initarg :message :accessor toast-message)
(variant :initarg :variant :initform :info :accessor toast-variant)))

7
src/components/dirty-tests.lisp
View File

@@ -1,4 +1,3 @@
;; Dirty tracking tests are in box-tests.lisp (same test suite)
(in-package :cl-tty-box-test)
(in-suite box-suite)
@@ -7,12 +6,18 @@
(let ((c (make-instance 'dirty-mixin)))
(is-true (dirty-p c) "new component should be dirty")))
(in-package :cl-tty-box-test)
(in-suite box-suite)
(test mark-clean-clears-dirty
"mark-clean sets dirty to nil"
(let ((c (make-instance 'dirty-mixin)))
(mark-clean c)
(is-false (dirty-p c) "after mark-clean, should not be dirty")))
(in-package :cl-tty-box-test)
(in-suite box-suite)
(test mark-dirty-sets-dirty
"mark-dirty sets dirty to t"
(let ((c (make-instance 'dirty-mixin)))

3
src/components/input-tests.lisp
View File

@@ -1,5 +1,8 @@
;; This file is deprecated. Tests moved to tests/input-tests.lisp.
;; Kept as placeholder to prevent confusion with stale copies.
(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)
(defun run-tests ()

7
src/components/input.lisp
View File

@@ -1,12 +1,19 @@
(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)

33
src/components/keybindings.lisp
View File

@@ -1,22 +1,14 @@
(in-package #:cl-tty.input)
;;; ---------------------------------------------------------------------------
;;; Key map struct
;;; ---------------------------------------------------------------------------
(defstruct keymap
(name nil :type (or keyword null))
(bindings nil :type list)
(parent nil :type (or keymap null)))
;;; ---------------------------------------------------------------------------
;;; Global keymap registry
;;; ---------------------------------------------------------------------------
(defparameter *keymaps* (make-hash-table :test #'equal))
(defparameter *chord-timeout* 0.5)
;;; ---------------------------------------------------------------------------
;;; Key spec matching
;;; ---------------------------------------------------------------------------
(defun key-match-p (spec event)
"T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword)
or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords."
@@ -26,7 +18,7 @@
(let* ((name (string spec))
(plus (position #\+ name)))
(if plus
;; Modified key: :ctrl+p → mod-str="CTRL", key-str="P"
;; Modified key: :ctrl+p -> mod-str="CTRL", key-str="P"
(let ((mod-str (subseq name 0 plus))
(key-str (subseq name (1+ plus))))
(and (eql (intern key-str :keyword)
@@ -43,24 +35,6 @@
(when spec
(key-match-p (first spec) event)))))
;;; ---------------------------------------------------------------------------
;;; Dispatch
;;; ---------------------------------------------------------------------------
;;; dispatch-key-event — main entry point for keymap-based dispatch.
;;;
;;; IMPORTANT: This function is NOT called by the demo's event loop
;;; or by any built-in widget event handlers. Users who want to use
;;; the keymap system MUST call dispatch-key-event explicitly in their
;;; own event loops, e.g.:
;;;
;;; (defun handle-event (event)
;;; (or (dispatch-key-event event)
;;; (handle-text-input my-input event)
;;; ...))
;;;
;;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single
;;; key specs work. The *chord-timeout* and list-of-lists syntax
;;; are reserved for future implementation.
(defun dispatch-key-event (event &key component)
(labels ((try-keymap (km)
(when km
@@ -76,9 +50,6 @@
(try-keymap (find-keymap :local))
(try-keymap (find-keymap :global)))))
;;; ---------------------------------------------------------------------------
;;; defkeymap macro
;;; ---------------------------------------------------------------------------
(defmacro defkeymap (name &body bindings)
`(setf (gethash ',name *keymaps*)
(make-keymap :name ',name

12
src/components/markdown.lisp
View File

@@ -2,8 +2,6 @@
(in-package :cl-tty.markdown)
;; ─── Node constructors ────────────────────────────────────────────────────────
(defun make-md-node (type &key children properties content url)
(let ((node (list :type type)))
(when children (setf (getf node :children) children))
@@ -28,8 +26,6 @@
(mapcar #'md-node-text (getf node :children))))
(t ""))))
;; ─── Block-level parser ───────────────────────────────────────────────────────
(defun split-string-into-lines (string)
(unless string (return-from split-string-into-lines (coerce nil 'vector)))
(let ((result nil) (start 0))
@@ -250,8 +246,6 @@
(t (incf i)))))
(nreverse nodes)))
;; ─── Inline parser ────────────────────────────────────────────────────────────
(defun parse-inline (text)
(unless (and text (> (length text) 0)) (return-from parse-inline nil))
(let ((nodes nil) (i 0) (len (length text)))
@@ -348,8 +342,6 @@
:url (subseq text (+ close-bracket 2) close-paren))
(1+ close-paren)))))
;; ─── Syntax highlighting ──────────────────────────────────────────────────────
(defun get-highlighter (lang)
(cdr (assoc lang
'(("lisp" . (:comment (";" "#|" ";;") :string ("\"")
@@ -525,8 +517,6 @@
(defun apply-highlight-style (char-vector)
(coerce char-vector 'string))
;; ─── Diff rendering ───────────────────────────────────────────────────────────
(defun string-prefix-p (prefix string)
(and (>= (length string) (length prefix))
(string= prefix (subseq string 0 (length prefix)))))
@@ -539,8 +529,6 @@
((string-prefix-p "-" line) :removed)
(t :context)))
;; ─── Rendering ────────────────────────────────────────────────────────────────
(defun apply-style (style text)
(let ((code (cond
((eql style :bold) "1") ((eql style :italic) "3")

5
src/components/mouse.lisp
View File

@@ -39,7 +39,6 @@ Components without a layout-node or position return nil."
node)))))))
(recurse root)))
;; Selection
(defvar *selection* nil)
(defstruct (selection (:conc-name sel-))
@@ -58,8 +57,6 @@ Components without a layout-node or position return nil."
:input text :wait nil)))
#+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil))
;;; --- Selection tracking (mouse drag) ---------------------------------------
(defvar *selection-active* nil
"T when a drag selection is in progress.")
@@ -98,8 +95,6 @@ Components without a layout-node or position return nil."
(setf *selection-start* nil *selection-end* nil)
text)))
;;; --- Link clicking ---------------------------------------------------------
(defun cell-link-at (fb x y)
"Return the link URL at (X Y) in framebuffer FB, or nil."
(cl-tty.rendering:fb-cell-link-url fb x y))

6
src/components/package.lisp
View File

@@ -7,24 +7,30 @@
#:box-border-style #:box-title #:box-title-align
#:box-fg #:box-bg
#:render-box
;; Span
#:span
#:span-text #:span-bold #:span-italic #:span-underline
#:span-reverse #:span-dim #:span-fg #:span-bg
;; Text
#:text #:make-text
#:text-layout-node #:text-content #:text-spans
#:text-fg #:text-bg #:text-wrap-mode
#:render-text
;; Utilities (for tests)
#:word-wrap #:split-string
;; Dirty tracking
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty
;; Rendering pipeline
#:render #:render-screen #:render-node
#:component-layout-node #:component-children #:component-parent
#:available-width #:available-height
#:propagate-dirty
;; Theme engine
#:theme #:make-theme #:theme-mode
#:theme-color #:load-preset #:define-preset))

10
src/components/render.lisp
View File

@@ -3,9 +3,13 @@
;; ── Component Protocol ────────────────────────────────────────
(defgeneric component-layout-node (component)
(:documentation "Return the layout-node for COMPONENT.")
(:method ((bx box)) (box-layout-node bx))
(:method ((tx text)) (text-layout-node tx)))
(:documentation "Return the layout-node for COMPONENT."))
(defmethod component-layout-node ((bx box))
(box-layout-node bx))
(defmethod component-layout-node ((tx text))
(text-layout-node tx))
(defgeneric component-children (component)
(:documentation "Return the children of COMPONENT, or nil.")

134
src/components/select.lisp
View File

@@ -1,77 +1,120 @@
(in-package #:cl-tty.select)
(defclass select (dirty-mixin)
((options :initform nil :initarg :options :accessor select-options :type list)
(filter :initform nil :initarg :filter :accessor select-filter :type (or string null))
(selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum)
(on-select :initform nil :initarg :on-select :accessor select-on-select)
(layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node)))
((options :initform nil :initarg :options
:accessor select-options :type list)
(filter :initform nil :initarg :filter
:accessor select-filter :type (or string null))
(selected-index :initform 0 :initarg :selected-index
:accessor select-selected-index :type fixnum)
(on-select :initform nil :initarg :on-select
:accessor select-on-select)
(layout-node :initform (make-layout-node) :initarg :layout-node
:accessor select-layout-node)))
(defun make-select (&key options filter on-select)
(make-instance 'select :options (or options nil) :filter filter :on-select on-select))
(make-instance 'select
:options (or options nil)
:filter filter
:on-select on-select))
(defmethod component-layout-node ((sel select)) (select-layout-node sel))
(defmethod component-layout-node ((sel select))
(select-layout-node sel))
(defun select-filtered-options (sel)
(let* ((filter (select-filter sel)) (all-options (select-options sel))
(filtered (if (null filter) all-options
"Return list of options matching the current filter, in display order.
Each item: (display-index original-index option-plist)."
(let* ((filter (select-filter sel))
(all-options (select-options sel))
(filtered (if (null filter)
all-options
(let ((lower (string-downcase filter)))
(remove-if-not
(lambda (opt)
(or (getf opt :category)
(let ((title (string-downcase (getf opt :title))))
(or (search lower title) (fuzzy-match-p lower title)))))
(or (search lower title)
(fuzzy-match-p lower title)))))
all-options)))))
(loop for opt in filtered for i from 0
(loop for opt in filtered
for i from 0
collect (list i (position opt all-options) opt))))
(defun fuzzy-match-p (query target)
(let* ((q (remove-duplicates (coerce (string-downcase query) 'list)))
(tg (remove-duplicates (coerce (string-downcase target) 'list)))
(intersection (length (intersection q tg)))
(union (length (union q tg))))
"T if character-set Jaccard similarity exceeds threshold (0.3)."
(let* ((q-chars (remove-duplicates (coerce (string-downcase query) 'list)))
(t-chars (remove-duplicates (coerce (string-downcase target) 'list)))
(intersection (length (intersection q-chars t-chars)))
(union (length (union q-chars t-chars))))
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))
(defun select-clamp-index (sel)
(let* ((filtered (select-filtered-options sel)) (count (length filtered)))
(if (zerop count) (setf (select-selected-index sel) 0)
(setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count)))))))
"Ensure selected-index is valid. Wraps if empty."
(let* ((filtered (select-filtered-options sel))
(count (length filtered)))
(if (zerop count)
(setf (select-selected-index sel) 0)
(setf (select-selected-index sel)
(max 0 (min (select-selected-index sel) (1- count)))))))
(defun select-next (sel)
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
"Move selection to next non-category option. Wraps at end."
(let* ((filtered (select-filtered-options sel))
(count (length filtered))
(current (select-selected-index sel)))
(when (plusp count)
(loop for i from 1 below count
for idx = (mod (+ current i) count)
for opt = (third (nth idx filtered))
when (not (getf opt :category))
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
do (setf (select-selected-index sel) idx)
(mark-dirty sel)
(return)))))
(defun select-prev (sel)
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
"Move selection to previous non-category option. Wraps at start."
(let* ((filtered (select-filtered-options sel))
(count (length filtered))
(current (select-selected-index sel)))
(when (plusp count)
(loop for i from 1 below count
for idx = (mod (- current i) count)
for opt = (third (nth idx filtered))
when (not (getf opt :category))
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
do (setf (select-selected-index sel) idx)
(mark-dirty sel)
(return)))))
(defun select-handle-key (sel event)
(let ((key (key-event-key event)) (ctrl (key-event-ctrl event)))
"Handle a key-event. Returns T if handled."
(let ((key (key-event-key event))
(ctrl (key-event-ctrl event)))
(cond
((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t)
((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t)
((or (eql key :down) (and ctrl (eql key :n)))
(select-next sel) t)
((or (eql key :up) (and ctrl (eql key :p)))
(select-prev sel) t)
((eql key :enter)
(let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel))
(item (when (< idx (length filtered)) (third (nth idx filtered)))))
(when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t))
((eql key :escape) nil) (t nil))))
(let* ((filtered (select-filtered-options sel))
(idx (select-selected-index sel))
(item (when (< idx (length filtered))
(third (nth idx filtered)))))
(when item
(let ((cb (select-on-select sel)))
(when cb (funcall cb item))))
t))
((eql key :escape) nil)
(t nil))))
(defun select-visible-options (sel)
(let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80))
(filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel))
(half (floor (1- height) 2)) (start (max 0 (- sel-idx half)))
"Return filtered options that fit within the viewport."
(let* ((ln (select-layout-node sel))
(height (if ln (layout-node-height ln) 80))
(filtered (select-filtered-options sel))
(sel-idx (select-selected-index sel))
;; Show items around the selection
(half (floor (1- height) 2))
(start (max 0 (- sel-idx half)))
(end (min (length filtered) (+ start height))))
(subseq filtered start end)))
@@ -80,17 +123,24 @@
(x (if ln (layout-node-x ln) 0))
(y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(visible (select-visible-options sel)) (sel-idx (select-selected-index sel)))
(visible (select-visible-options sel))
(sel-idx (select-selected-index sel)))
(dolist (item visible)
(let* ((display-idx (first item)) (option (third item))
(title (getf option :title)) (cat (getf option :category))
(selected (eql display-idx sel-idx))
(let* ((display-idx (first item))
(option (third item))
(title (getf option :title))
(is-category (getf option :category))
(is-selected (eql display-idx sel-idx))
(display (if (> (length title) (1- w))
(concatenate 'string (subseq title 0 (1- w)) "…") title)))
(cond (cat (draw-text backend x y display :text-muted nil))
(selected
(draw-rect backend x y w 1 :bg :accent)
(draw-text backend x y display :background :accent))
(t (draw-text backend x y display nil nil)))
(concatenate 'string (subseq title 0 (1- w)) "…")
title)))
(cond
(is-category
(draw-text backend x y display :text-muted nil))
(is-selected
(draw-rect backend x y w 1 :bg :accent)
(draw-text backend x y display :background :accent))
(t
(draw-text backend x y display nil nil)))
(incf y 1)))
(values)))

2
src/components/text.lisp
View File

@@ -1,7 +1,5 @@
(in-package :cl-tty.box)
;; ── Text Renderable ────────────────────────────────────────────
(defclass span ()
((text :initarg :text :accessor span-text)
(bold :initform nil :initarg :bold :accessor span-bold)

24
src/components/textarea.lisp
View File

@@ -1,8 +1,5 @@
(in-package #:cl-tty.input)
;;; ---------------------------------------------------------------------------
;;; Textarea class
;;; ---------------------------------------------------------------------------
(defclass textarea (dirty-mixin)
((value :initform "" :initarg :value :accessor textarea-value :type string)
(cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum)
@@ -21,9 +18,6 @@
:value (or value "")
:on-submit on-submit))
;;; ---------------------------------------------------------------------------
;;; Line helpers
;;; ---------------------------------------------------------------------------
(defun textarea-lines (ta)
"Split value into lines."
(%split-string (textarea-value ta) #\Newline))
@@ -42,9 +36,6 @@
(max 0 (min (textarea-cursor-col ta) line-len)))))
(mark-dirty ta))
;;; ---------------------------------------------------------------------------
;;; Utility: join strings with newline
;;; ---------------------------------------------------------------------------
(defun %join-lines (lines)
"Join a sequence of strings with newlines."
(with-output-to-string (s)
@@ -53,9 +44,6 @@
do (unless first (write-char #\Newline s))
(write-string line s))))
;;; ---------------------------------------------------------------------------
;;; Text manipulation
;;; ---------------------------------------------------------------------------
(defun textarea-insert-char (ta char)
"Insert CHAR at the cursor position."
(textarea-push-undo ta)
@@ -141,9 +129,6 @@
(decf (textarea-cursor-col ta))
(mark-dirty ta))))))
;;; ---------------------------------------------------------------------------
;;; Cursor movement
;;; ---------------------------------------------------------------------------
(defun textarea-move-up (ta)
(decf (textarea-cursor-row ta))
(textarea-ensure-cursor ta))
@@ -152,9 +137,6 @@
(incf (textarea-cursor-row ta))
(textarea-ensure-cursor ta))
;;; ---------------------------------------------------------------------------
;;; Undo/redo
;;; ---------------------------------------------------------------------------
(defun textarea-push-undo (ta)
"Save current value on undo stack."
(let ((stack (textarea-undo-stack ta)))
@@ -183,9 +165,6 @@
(textarea-ensure-cursor ta)
(mark-dirty ta)))))
;;; ---------------------------------------------------------------------------
;;; Key event handler
;;; ---------------------------------------------------------------------------
(defun handle-textarea-input (ta event)
"Process a key-event on a textarea widget."
(cond
@@ -239,9 +218,6 @@
(when (and ch (graphic-char-p ch))
(textarea-insert-char ta ch))))))))
;;; ---------------------------------------------------------------------------
;;; Rendering
;;; ---------------------------------------------------------------------------
(defmethod render ((ta textarea) (backend t))
"Render textarea lines at layout position."
(let* ((ln (textarea-layout-node ta))

2
src/components/theme.lisp
View File

@@ -1,7 +1,5 @@
(in-package :cl-tty.box)
;; ── Theme Engine ──────────────────────────────────────────────
(defclass theme ()
((mode :initform :dark :initarg :mode :accessor theme-mode)
(roles :initform (make-hash-table) :accessor theme-roles)))

2
src/layout/tests.lisp
View File

@@ -119,8 +119,6 @@
(is (= (layout-node-y (elt sc 0)) 0))
(is (= (layout-node-y (elt sc 1)) 3)))))
;; ── Edge Cases ────────────────────────────────────────────────
(test empty-container-does-not-crash
(let ((r (make-layout-node)))
(compute-layout r 20 20)

16
src/rendering/framebuffer.lisp
View File

@@ -12,8 +12,6 @@
(in-package :cl-tty.rendering)
;;; ─── Cell — immutable per-cell state ─────────────────────────────────────────
(defstruct cell
"A single terminal cell — character, colors, and attributes."
(char #\space :type character)
@@ -24,8 +22,6 @@
(underline nil :type boolean)
(link-url nil))
;;; ─── Framebuffer — 2D array of cells ────────────────────────────────────────
(defun make-framebuffer (width height)
"Create a 2D array of CELL with dimensions HEIGHT x WIDTH."
(make-array (list height width)
@@ -40,8 +36,6 @@
"Return the height (rows) of framebuffer FB."
(if (arrayp fb) (array-dimension fb 0) 0))
;;; ─── Framebuffer Backend — implements backend protocol ─────────────────────
(defclass framebuffer-backend (backend)
((framebuffer :initform nil :accessor fb-framebuffer)
(scissor-x :initform 0 :accessor fb-scissor-x)
@@ -55,8 +49,6 @@
(setf (fb-framebuffer fb) (make-framebuffer width height))
fb))
;;; ─── Drawing methods ─────────────────────────────────────────────────────────
(defun %in-scissor-p (fb cx cy)
"Check if (CX, CY) falls within the current scissor rectangle."
(let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb))
@@ -129,8 +121,6 @@
(dotimes (i (min 3 width))
(%set-cell fb (+ x i) y #\. :fg fg :bg bg)))
;;; ─── Diff ────────────────────────────────────────────────────────────────────
(defun cells-equal-p (a b)
"Return T if two cells have identical content and style."
(and (eql (cell-char a) (cell-char b))
@@ -153,8 +143,6 @@
(push (list x y b) changes)))))
(nreverse changes)))
;;; ─── Flush ───────────────────────────────────────────────────────────────────
(defun flush-framebuffer (prev-fb curr-fb backend)
"Diff PREV-FB and CURR-FB and flush changes to BACKEND.
Returns the number of changed cells."
@@ -176,8 +164,6 @@ Returns the number of changed cells."
(end-sync backend))
count))
;;; --- Frame inspection ---------------------------------------------------
(defun fb-cell-link-url (fb x y)
"Return the link URL at (X Y) in framebuffer FB, or nil."
(when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0))
@@ -198,8 +184,6 @@ Returns the number of changed cells."
(princ (cell-char c) s)))
(when (< y y-max) (princ #\Newline s))))))
;;; ─── Scissor clipping ────────────────────────────────────────────────────────
(defmacro with-scissor ((fb x y w h) &body body)
"Clip all drawing on FB to rectangle (X Y W H)."
(let ((old-x (gensym)) (old-y (gensym))

13
tests/input-tests.lisp
View File

@@ -190,14 +190,11 @@
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
(handle-textarea-input a (make-key-event :key :enter))
(handle-textarea-input a (make-key-event :key :b :code (char-code #\b)))
(is (string= (textarea-value a) "a
b"))))
(is (string= (textarea-value a) (format nil "a~Cb" #\Newline)))))
(test textarea-cursor-up-down
"Cursor moves between lines maintaining column position."
(let ((a (make-textarea :value "abc
de
fghi")))
(let ((a (make-textarea :value (format nil "abc~Cde~Cfghi" #\Newline #\Newline))))
(setf (textarea-cursor-row a) 1)
(setf (textarea-cursor-col a) 1)
(handle-textarea-input a (make-key-event :key :up))
@@ -209,8 +206,7 @@ fghi")))
(test textarea-cursor-up-down-bounds
"Cursor cannot move past first or last line."
(let ((a (make-textarea :value "a
b")))
(let ((a (make-textarea :value (format nil "a~Cb" #\Newline))))
(handle-textarea-input a (make-key-event :key :up))
(is (= (textarea-cursor-row a) 0))
(setf (textarea-cursor-row a) 1)
@@ -219,8 +215,7 @@ b")))
(test textarea-backspace-joins-lines
"Backspace at start of a line joins with previous."
(let ((a (make-textarea :value "hello
world")))
(let ((a (make-textarea :value (format nil "hello~Cworld" #\Newline))))
(setf (textarea-cursor-row a) 1)
(setf (textarea-cursor-col a) 0)
(handle-textarea-input a (make-key-event :key :backspace))

2
tests/mouse-tests.lisp
View File

@@ -18,8 +18,6 @@
(setf cl-tty.mouse::*selection* (make-selection :text "hello"))
(is (equal "hello" (get-selection))))
;; ── Selection tracking ──────────────────────────────────────
(def-test start-selection-initializes-state ()
(start-selection 5 10)
(is-true (selection-active-p))

4
tests/scrollbox-tabbar-tests.lisp
View File

@@ -11,8 +11,6 @@
(fiveam:explain! result)
(uiop:quit 0)))
;; ── ScrollBox Tests ─────────────────────────────────────────────
(test scrollbox-creates
"A ScrollBox can be created with defaults."
(let ((sb (make-scroll-box)))
@@ -46,8 +44,6 @@
(render sb backend)
(is-true t)))
;; ── TabBar Tests ────────────────────────────────────────────────
(test tabbar-creates
"A TabBar can be created with defaults."
(let ((tb (make-tab-bar)))