352f27e260
The osc8-link implementation and its test both had doubled backslashes (\\ -> \\) in their format strings, producing two literal backslashes at runtime instead of the single backslash needed for the OSC 8 string terminator (ST = ESC \). Fix: change \\ to \\ in both the implementation and test format strings. The tangled .lisp files now have correct escaped backslashes (\) producing one backslash in the runtime string. Additionally clean up a patch artifact that left a stray backslash before the opening quote.
866 lines
30 KiB
Org Mode
866 lines
30 KiB
Org Mode
#+TITLE: Modern Backend
|
|
#+STARTUP: content
|
|
#+FILETAGS: :cl-tty:backend:
|
|
|
|
* Overview
|
|
|
|
The modern backend provides full-featured terminal rendering using raw
|
|
escape sequences. It supports truecolor 24-bit color, OSC 8 hyperlinks,
|
|
DECICM synchronized updates, SGR mouse tracking, kitty keyboard protocol,
|
|
and Unicode box-drawing characters (single, double, rounded).
|
|
|
|
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.
|
|
|
|
* Contract
|
|
|
|
** Color and attribute helpers
|
|
|
|
- ~(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
|
|
|
|
** 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
|
|
|
|
** Border helpers
|
|
|
|
- ~(border-char style pos)~ string --- Unicode box-drawing character
|
|
|
|
** Modern backend class
|
|
|
|
- ~(make-modern-backend &key output-stream)~ modern-backend
|
|
- Implements all ~backend~ protocol methods with escape sequences
|
|
|
|
* Tests
|
|
|
|
The test suite lives in =modern-tests.lisp= and uses FiveAM. Each test
|
|
covers one logical behavior.
|
|
|
|
** Package and setup
|
|
|
|
The test package uses =cl-tty.backend= to access internal symbols for
|
|
white-box testing of escape generation.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
|
|
(defpackage :cl-tty-modern-backend-test
|
|
(:use :cl :fiveam :cl-tty.backend)
|
|
(:export #:run-tests))
|
|
(in-package :cl-tty-modern-backend-test)
|
|
#+END_SRC
|
|
|
|
** Suite definition
|
|
|
|
A single suite groups all modern backend tests.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
|
|
(def-suite modern-backend-suite :description "Modern backend tests")
|
|
(in-suite modern-backend-suite)
|
|
#+END_SRC
|
|
|
|
** Test runner
|
|
|
|
The =run-tests= entry point is called by the CI test harness.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
|
|
(defun run-tests ()
|
|
(let ((result (run 'modern-backend-suite)))
|
|
(fiveam:explain! result)
|
|
(uiop:quit 0)))
|
|
#+END_SRC
|
|
|
|
** Constructor 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
|
|
|
|
** 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 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
|
|
|
|
** 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 hyperlink escape
|
|
|
|
Verifies the full OSC 8 wrapping: opening sequence with URL, the text,
|
|
and the closing sequence. The FORMAT string uses ~~ for literal tilde
|
|
and ~\\ for literal backslash.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
|
|
(test osc8-escape
|
|
"OSC 8 hyperlink escape wraps text"
|
|
(is (equal (cl-tty.backend::osc8-link "http://example.com" "click here")
|
|
(format nil "~C]8;;http://example.com~C\click here~C]8;;~C\"
|
|
#\Esc #\Esc #\Esc #\Esc))))
|
|
#+END_SRC
|
|
|
|
** Hex 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 --- rounded style
|
|
|
|
Confirms that =:rounded= style maps to the Unicode box-drawing
|
|
characters for the four corners and edges.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
|
|
(test border-char-rounded
|
|
"modern-border-char returns Unicode box-drawing for rounded style"
|
|
(is (equal (cl-tty.backend::border-char :rounded :top-left) "╭"))
|
|
(is (equal (cl-tty.backend::border-char :rounded :horizontal) "─"))
|
|
(is (equal (cl-tty.backend::border-char :rounded :vertical) "│"))
|
|
(is (equal (cl-tty.backend::border-char :rounded :bottom-right) "╯"))
|
|
#+END_SRC
|
|
|
|
** Border characters --- double style
|
|
|
|
Confirms that =:double= style maps to double-line box-drawing characters.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
|
|
(test border-char-double
|
|
"modern-border-char returns double-line chars"
|
|
(is (equal (cl-tty.backend::border-char :double :top-left) "╔"))
|
|
(is (equal (cl-tty.backend::border-char :double :horizontal) "═"))
|
|
(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. 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)
|
|
|
|
(defun hex-to-rgb (hex)
|
|
"Parse a hex color string like \"#FFD700\" into (values r g b).
|
|
Also handles 3-digit hex like \"#F00\" (expands to \"#FF0000\")."
|
|
(let ((clean (string-trim '(#\# #\Space) hex)))
|
|
(if (= (length clean) 3)
|
|
;; Expand 3-digit: #F00 -> #FF0000
|
|
(let* ((r (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t))
|
|
(g (parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t))
|
|
(b (parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t)))
|
|
(values (+ r (* r 16)) (+ g (* g 16)) (+ b (* b 16))))
|
|
(values (parse-integer (subseq clean 0 2) :radix 16 :junk-allowed t)
|
|
(parse-integer (subseq clean 2 4) :radix 16 :junk-allowed t)
|
|
(parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t)))))
|
|
#+END_SRC
|
|
|
|
*** *named-colors*
|
|
|
|
Maps keyword color names to 8-color SGR index values. Used as the
|
|
primary lookup in =sgr-fg= and =sgr-bg= before falling back to the
|
|
theme colors hash table.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defparameter *named-colors*
|
|
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
|
|
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
|
|
#+END_SRC
|
|
|
|
*** *theme-colors*
|
|
|
|
Hash table mapping semantic theme role keywords to hex color strings.
|
|
Populated by the theme system's =load-preset=. When a keyword is not in
|
|
=*named-colors*=, =sgr-fg= and =sgr-bg= consult this table as a
|
|
fallback, enabling user themes to define custom color roles.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defvar *theme-colors* (make-hash-table :test 'eq)
|
|
"Hash table mapping theme keywords to hex color strings.
|
|
Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg
|
|
as a fallback when a keyword is not in *named-colors*.")
|
|
#+END_SRC
|
|
|
|
*** sgr-fg
|
|
|
|
~sgr-fg~ produces the SGR foreground escape sequence. Resolution chain:
|
|
hex string => named color => semantic theme role => empty string if
|
|
unresolved. Truecolor uses =38;2;R;G;B=, named colors use =3n=.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defun sgr-fg (color)
|
|
"Return SGR foreground escape for COLOR."
|
|
(if (null color) ""
|
|
(cond ((and (stringp color) (char= (char color 0) #\#))
|
|
(multiple-value-bind (r g b) (hex-to-rgb color)
|
|
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)))
|
|
((keywordp color)
|
|
(let ((index (cdr (assoc color *named-colors*))))
|
|
(if index
|
|
(format nil "~C[~dm" #\Esc (+ 30 index))
|
|
(let ((hex (gethash color *theme-colors*)))
|
|
(if hex
|
|
(multiple-value-bind (r g b) (hex-to-rgb hex)
|
|
(format nil "~C[38;2;~d;~d;~dm" #\Esc r g b))
|
|
"")))))
|
|
(t ""))))
|
|
#+END_SRC
|
|
|
|
*** sgr-bg
|
|
|
|
~sgr-bg~ produces the SGR background escape. Same resolution chain as
|
|
=sgr-fg= but uses =48;2;R;G;B= for truecolor and =4n= for named colors.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defun sgr-bg (color)
|
|
"Return SGR background escape for COLOR."
|
|
(if (null color) ""
|
|
(cond ((and (stringp color) (char= (char color 0) #\#))
|
|
(multiple-value-bind (r g b) (hex-to-rgb color)
|
|
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)))
|
|
((keywordp color)
|
|
(let ((index (cdr (assoc color *named-colors*))))
|
|
(if index
|
|
(format nil "~C[~dm" #\Esc (+ 40 index))
|
|
(let ((hex (gethash color *theme-colors*)))
|
|
(if hex
|
|
(multiple-value-bind (r g b) (hex-to-rgb hex)
|
|
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b))
|
|
"")))))
|
|
(t ""))))
|
|
#+END_SRC
|
|
|
|
*** *sgr-attr-codes*
|
|
|
|
Maps attribute keywords to SGR parameter numbers. Covers bold, dim,
|
|
italic, underline, blink, reverse video, and reset.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defparameter *sgr-attr-codes*
|
|
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
|
|
(:blink . 5) (:reverse . 7) (:reset . 0)))
|
|
#+END_SRC
|
|
|
|
*** sgr-attr
|
|
|
|
~sgr-attr~ looks up the keyword in =*sgr-attr-codes*= and produces the
|
|
matching SGR escape.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defun sgr-attr (attr)
|
|
"Return SGR attribute escape for ATTR keyword."
|
|
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
|
|
(if code
|
|
(format nil "~C[~dm" #\Esc code)
|
|
"")))
|
|
#+END_SRC
|
|
|
|
** 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
|
|
(:block 2) (:underline 4) (:bar 6)
|
|
(t 2)))
|
|
(code (if blink (1+ base) base)))
|
|
(format nil "~C[~d q" #\Esc code)))
|
|
#+END_SRC
|
|
|
|
** 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\\\"
|
|
#\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) . "┐")
|
|
((:single :bottom-left) . "└") ((:single :bottom-right) . "┘")
|
|
((:single :horizontal) . "─") ((:single :vertical) . "│")
|
|
((:double :top-left) . "╔") ((:double :top-right) . "╗")
|
|
((:double :bottom-left) . "╚") ((:double :bottom-right) . "╝")
|
|
((:double :horizontal) . "═") ((:double :vertical) . "║")
|
|
((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮")
|
|
((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯")
|
|
((:rounded :horizontal) . "─") ((:rounded :vertical) . "│")))
|
|
#+END_SRC
|
|
|
|
*** border-char
|
|
|
|
Looks up a border character by style and position. Falls back to
|
|
horizontal/vertical lines (=U+2500=, =U+2502=) if the style is unknown
|
|
for edge positions, or =+= for corners --- ensuring the UI never shows
|
|
a blank gap.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defun border-char (style pos)
|
|
"Return the Unicode box-drawing character for STYLE at POS."
|
|
(let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
|
|
(or char (if (member pos '(:horizontal :vertical))
|
|
(case pos (:horizontal "─") (:vertical "│"))
|
|
"+"))))
|
|
#+END_SRC
|
|
|
|
** Modern backend class
|
|
|
|
*** modern-backend (class)
|
|
|
|
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*)))
|
|
#+END_SRC
|
|
|
|
** Lifecycle
|
|
|
|
*** initialize-backend
|
|
|
|
Enters the alternate screen buffer, enables mouse tracking (basic +
|
|
drag + SGR), bracketed paste mode, and the Kitty keyboard protocol.
|
|
Hides the cursor and flushes the stream. Returns the backend instance
|
|
for chaining.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod initialize-backend ((b modern-backend))
|
|
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen
|
|
(backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic
|
|
(backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag
|
|
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse
|
|
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste
|
|
(backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard
|
|
(cursor-hide b)
|
|
(finish-output (backend-output-stream b))
|
|
b)
|
|
#+END_SRC
|
|
|
|
*** shutdown-backend
|
|
|
|
Restores the terminal: shows the cursor, disables the Kitty keyboard
|
|
protocol, bracketed paste, SGR mouse, drag, basic mouse, and finally
|
|
leaves the alternate screen. Returns =nil= (via =(values)=).
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod shutdown-backend ((b modern-backend))
|
|
(cursor-show b)
|
|
(backend-write b (format nil "~C[?u" #\Esc))
|
|
(backend-write b (format nil "~C[?2004l" #\Esc))
|
|
(backend-write b (format nil "~C[?1006l" #\Esc))
|
|
(backend-write b (format nil "~C[?1002l" #\Esc))
|
|
(backend-write b (format nil "~C[?1000l" #\Esc))
|
|
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
|
|
(finish-output (backend-output-stream b))
|
|
(values))
|
|
#+END_SRC
|
|
|
|
** Backend-size via ioctl
|
|
|
|
*** backend-size
|
|
|
|
Uses TIOCGWINSZ (=0x5413= = 21523) to query actual terminal dimensions
|
|
from the kernel via =ioctl=. The =alien-sap= wrapper ensures
|
|
compatibility across SBCL versions. Returns (values cols rows).
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod backend-size ((b modern-backend))
|
|
(let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
|
|
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
|
|
(unwind-protect
|
|
(progn
|
|
(sb-unix:unix-ioctl (sb-sys:fd-stream-fd (backend-output-stream b))
|
|
+tiocgwinsz+
|
|
(sb-alien:alien-sap winsize))
|
|
(values (sb-alien:deref winsize 1) ;; cols
|
|
(sb-alien:deref winsize 0))) ;; rows
|
|
(sb-alien:free-alien winsize))))
|
|
#+END_SRC
|
|
|
|
** Capability query and write
|
|
|
|
*** backend-write
|
|
|
|
Writes a string to the backend's output stream, flushing after each
|
|
write to ensure the terminal receives the escape sequence immediately.
|
|
Returns the string length for protocol compatibility.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod backend-write ((b modern-backend) string)
|
|
(let ((stream (backend-output-stream b)))
|
|
(write-string string stream)
|
|
(finish-output stream)
|
|
(length string)))
|
|
#+END_SRC
|
|
|
|
*** capable-p
|
|
|
|
Advertises which features this backend supports. =modern-backend=
|
|
supports truecolor, OSC 8 hyperlinks, DECICM sync, SGR mouse,
|
|
bracketed paste, cursor style control, and the Kitty keyboard protocol.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod capable-p ((b modern-backend) feature)
|
|
(member feature '(:truecolor :osc8 :sync :mouse
|
|
:bracketed-paste :cursor-style
|
|
:kitty-keyboard)))
|
|
#+END_SRC
|
|
|
|
** Drawing
|
|
|
|
*** draw-text
|
|
|
|
Combines cursor positioning, SGR colors, optional attributes, the text
|
|
itself, and a reset into a single concatenated string. Minimizes output
|
|
calls --- one =backend-write= per draw operation --- by packing everything
|
|
into one buffer.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod draw-text ((b modern-backend) x y string fg bg
|
|
&key bold italic underline reverse dim blink)
|
|
(let ((parts (list (cursor-move-escape x y)
|
|
(sgr-fg fg) (sgr-bg bg)
|
|
(when bold (sgr-attr :bold))
|
|
(when italic (sgr-attr :italic))
|
|
(when underline (sgr-attr :underline))
|
|
(when reverse (sgr-attr :reverse))
|
|
(when dim (sgr-attr :dim))
|
|
(when blink (sgr-attr :blink))
|
|
string
|
|
(sgr-attr :reset))))
|
|
(backend-write b (apply #'concatenate 'string parts))))
|
|
#+END_SRC
|
|
|
|
*** draw-border
|
|
|
|
Builds the full border as three distinct string parts (top with optional
|
|
title, repeated mid sections, bottom) and writes them with minimal
|
|
output calls. The title can be left-aligned or centered within the top
|
|
border line. Uses the border character lookup for the chosen style.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod draw-border ((b modern-backend) x y width height
|
|
&key style fg bg title title-align)
|
|
(let* ((s (or style :single))
|
|
(tl (border-char s :top-left))
|
|
(tr (border-char s :top-right))
|
|
(bl (border-char s :bottom-left))
|
|
(br (border-char s :bottom-right))
|
|
(h (border-char s :horizontal))
|
|
(v (border-char s :vertical))
|
|
(fg-esc (sgr-fg fg))
|
|
(bg-esc (sgr-bg bg))
|
|
(reset (sgr-attr :reset))
|
|
(inner-width (- width 2))
|
|
(hc (char h 0))
|
|
(top (if (and title (plusp (length title)))
|
|
(let* ((align (or title-align :left))
|
|
(max-tlen (- inner-width 2))
|
|
(tlen (min (length title) max-tlen))
|
|
(trunc-title (subseq title 0 tlen)))
|
|
(ecase align
|
|
(:left
|
|
(let ((right-hyphens (- inner-width tlen 2)))
|
|
(concatenate 'string
|
|
fg-esc bg-esc tl (string #\Space)
|
|
trunc-title (string #\Space)
|
|
(make-string (max 0 right-hyphens) :initial-element hc)
|
|
tr reset (string #\Newline))))
|
|
(:center
|
|
(let* ((total-pad (- inner-width tlen))
|
|
(left-pad (floor total-pad 2))
|
|
(right-pad (- total-pad left-pad)))
|
|
(concatenate 'string
|
|
fg-esc bg-esc tl
|
|
(make-string left-pad :initial-element hc)
|
|
trunc-title
|
|
(make-string right-pad :initial-element hc)
|
|
tr reset (string #\Newline))))))
|
|
(concatenate 'string
|
|
fg-esc bg-esc tl
|
|
(make-string inner-width :initial-element hc)
|
|
tr reset (string #\Newline))))
|
|
(mid (concatenate 'string
|
|
fg-esc bg-esc v
|
|
(make-string inner-width :initial-element #\Space)
|
|
v reset (string #\Newline)))
|
|
(bot (concatenate 'string
|
|
fg-esc bg-esc bl
|
|
(make-string inner-width :initial-element hc)
|
|
br reset)))
|
|
(backend-write b top)
|
|
(loop repeat (- height 2) do (backend-write b mid))
|
|
(backend-write b bot)))
|
|
#+END_SRC
|
|
|
|
*** draw-rect
|
|
|
|
Fills a rectangular area with a background color. For each row, moves
|
|
the cursor and writes a filled line. This is simpler than =draw-border=
|
|
because it has no border characters --- just spaces with a background
|
|
color.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
|
|
(let* ((bg-esc (sgr-bg bg))
|
|
(reset (sgr-attr :reset))
|
|
(line (concatenate 'string
|
|
bg-esc
|
|
(make-string width :initial-element #\Space)
|
|
reset (string #\Newline))))
|
|
(loop :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)
|
|
(sgr-fg fg) (sgr-bg bg)
|
|
(osc8-link url string)
|
|
(sgr-attr :reset))))
|
|
(backend-write b (apply #'concatenate 'string parts))))
|
|
#+END_SRC
|
|
|
|
*** draw-ellipsis
|
|
|
|
Draws a three-dot ellipsis at the given position. The =width= parameter
|
|
is ignored since dots have a fixed visual length; delegates to
|
|
=draw-text= for uniform rendering.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod draw-ellipsis ((b modern-backend) x y width
|
|
&key fg bg)
|
|
(declare (ignore width))
|
|
(let ((dots "..."))
|
|
(draw-text b x y dots fg bg)))
|
|
#+END_SRC
|
|
|
|
** Cursor and input methods
|
|
|
|
*** cursor-move
|
|
|
|
Delegates to =cursor-move-escape= and writes the resulting CSI sequence
|
|
to the output stream.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod cursor-move ((b modern-backend) x y)
|
|
(backend-write b (cursor-move-escape x y)))
|
|
#+END_SRC
|
|
|
|
*** cursor-hide
|
|
|
|
Sends the DECTCEM private mode =?25l= to hide the cursor.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod cursor-hide ((b modern-backend))
|
|
(backend-write b (format nil "~C[?25l" #\Esc)))
|
|
#+END_SRC
|
|
|
|
*** cursor-show
|
|
|
|
Sends =?25h= to restore the cursor visibility.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod cursor-show ((b modern-backend))
|
|
(backend-write b (format nil "~C[?25h" #\Esc)))
|
|
#+END_SRC
|
|
|
|
*** cursor-style
|
|
|
|
Sets the cursor shape (block/underline/bar, optionally blinking) by
|
|
delegating to =cursor-style-escape=.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod cursor-style ((b modern-backend) shape &key blink)
|
|
(backend-write b (cursor-style-escape shape blink)))
|
|
#+END_SRC
|
|
|
|
*** enable-mouse
|
|
|
|
Enables basic mouse tracking, button-event tracking (drag), and SGR
|
|
extended mouse mode. These three modes together give full mouse
|
|
support while staying compatible with modern terminal emulators.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod enable-mouse ((b modern-backend))
|
|
(backend-write b (format nil "~C[?1000h" #\Esc))
|
|
(backend-write b (format nil "~C[?1002h" #\Esc))
|
|
(backend-write b (format nil "~C[?1006h" #\Esc))
|
|
(finish-output (backend-output-stream b)))
|
|
#+END_SRC
|
|
|
|
*** enable-bracketed-paste
|
|
|
|
Enables bracketed paste mode, where the terminal wraps pasted text in
|
|
=ESC[200~= and =ESC[201~= delimiters. This allows the application to
|
|
distinguish user input from pasted content.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod enable-bracketed-paste ((b modern-backend))
|
|
(backend-write b (format nil "~C[?2004h" #\Esc))
|
|
(finish-output (backend-output-stream b)))
|
|
#+END_SRC
|
|
|
|
*** begin-sync
|
|
|
|
Begins a synchronized update frame using DECICM. Sets the =in-sync-p=
|
|
slot so other methods can check whether we are inside a sync block.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod begin-sync ((b modern-backend))
|
|
(setf (in-sync-p b) t)
|
|
(backend-write b (decicm-begin)))
|
|
#+END_SRC
|
|
|
|
*** end-sync
|
|
|
|
Ends the synchronized update frame and flushes the output, causing the
|
|
terminal to render the buffered changes atomically.
|
|
|
|
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
|
|
(defmethod end-sync ((b modern-backend))
|
|
(setf (in-sync-p b) nil)
|
|
(backend-write b (decicm-end))
|
|
(finish-output (backend-output-stream b)))
|
|
#+END_SRC
|