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

literate: convert org/modern-backend.org from doc-only to tangle source

Browse Source 
Now tangles to modern.lisp + modern-tests.lisp.
Deleted hand-written originals and regenerated from org — GREEN.
This commit is contained in:
Hermes Agent
2026-05-12 17:14:37 +00:00
parent dfd828c914
commit c77c6b9d02
3 changed files with 218 additions and 133 deletions
Download Patch File Download Diff File Expand all files Collapse all files

293
org/modern-backend.org
View File

@@ -1,45 +1,51 @@
#+TITLE: cl-tty Modern Backend — v0.0.2 #+TITLE: Modern Backend
#+STARTUP: content #+STARTUP: content
#+FILETAGS: :cl-tty:backend:v0.0.2: #+FILETAGS: :cl-tty:backend:
#+OPTIONS: ^:nil
* Modern Backend * Overview
The =modern-backend= renders through raw ANSI/XTerm escape sequences. The modern backend provides full-featured terminal rendering using raw
No ncurses, no CFFI, no external dependencies — pure CL string escape sequences. It supports truecolor 24-bit color, OSC 8 hyperlinks,
construction. Supports truecolor, Unicode box-drawing, OSC 8 hyperlinks, DECICM synchronized updates, SGR mouse tracking, kitty keyboard protocol,
DECICM synchronized updates, SGR mouse, and the kitty keyboard protocol. and Unicode box-drawing characters (single, double, rounded).
** Contract All rendering functions produce CSI/OSC escape sequences directly — no
ncurses, no terminfo, no FFI. Color resolution handles named colors
(~:red~, ~:blue~, etc.), hex strings (~"#FFD700"~), and semantic theme
roles (~:accent~, ~:error~) via the ~*theme-colors*~ hash table.
*** Constructor * Contract
- =(make-modern-backend &key color-palette)= → modern-backend ** Color and attribute helpers
Create a modern backend. color-palette modifies theme color mappings.
*** Escape Sequence Generation - ~(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.)
All escape sequences follow ECMA-48 / ANSI X3.64 conventions: ** Cursor helpers
| Escape | Meaning | - ~(cursor-move-escape x y)~ → escape string — CSI cursor position
|--------+--------------------------| - ~(cursor-style-escape shape blink)~ → escape string — DECSTR cursor shape
| ~ESC[~ | Control Sequence Introducer (CSI) |
| ~ESC]~ | Operating System Command (OSC) |
| ~ESC ~ | Single-character sequence |
*** Style Resolution ** Sync and link helpers
Colors are resolved through a palette before emission: - ~(decicm-begin)~ → escape string — enable synchronized updates
- ~(decicm-end)~ → escape string — disable synchronized updates
- ~(osc8-link url text)~ → escape string — OSC 8 hyperlink wrapper
- =(resolve-color backend hex-or-name)= → color-index ** Border helpers
Convert hex string or semantic name to an SGR color code.
Hex ("#FFD700") → 48;2;R;G;B or 38;2;R;G;B.
Named colors (:black :red :green :yellow :blue :magenta :cyan :white)
→ 8-color SGR codes.
** Test Suite - ~(border-char style pos)~ → string — Unicode box-drawing character
#+BEGIN_SRC lisp ** Modern backend class
- ~(make-modern-backend &key output-stream)~ → modern-backend
- Implements all ~backend~ protocol methods with escape sequences
* Tests
#+BEGIN_SRC lisp :tangle ../src/backend/modern-tests.lisp
(defpackage :cl-tty-modern-backend-test (defpackage :cl-tty-modern-backend-test
(:use :cl :fiveam :cl-tty.backend) (:use :cl :fiveam :cl-tty.backend)
(:export #:run-tests)) (:export #:run-tests))
@@ -92,7 +98,7 @@ Colors are resolved through a palette before emission:
"cursor-move generates correct CSI escape" "cursor-move generates correct CSI escape"
(let ((b (make-modern-backend))) (let ((b (make-modern-backend)))
(is (equal (cl-tty.backend::cursor-move-escape 5 10) (is (equal (cl-tty.backend::cursor-move-escape 5 10)
(format nil "~C[6;11H" #\Esc))))) (format nil "~C[11;6H" #\Esc)))))
(test cursor-style-block (test cursor-style-block
"cursor-style :block generate correct escape" "cursor-style :block generate correct escape"
@@ -124,7 +130,7 @@ Colors are resolved through a palette before emission:
(test osc8-escape (test osc8-escape
"OSC 8 hyperlink escape wraps text" "OSC 8 hyperlink escape wraps text"
(is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") (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)))) #\Esc #\Esc #\Esc #\Esc))))
;; ── Hex Parsing ──────────────────────────────────────────────── ;; ── Hex Parsing ────────────────────────────────────────────────
@@ -166,44 +172,50 @@ Colors are resolved through a palette before emission:
(is (equal (cl-tty.backend::border-char :double :vertical) "║"))) (is (equal (cl-tty.backend::border-char :double :vertical) "║")))
#+END_SRC #+END_SRC
** Implementation * Implementation
*** Package ** Color and attribute helpers
Add to =cl-tty.backend= package: ~hex-to-rgb~ parses hex color strings into (r g b) triplets. Handles
both 6-digit (fully specified) and 3-digit (shorthand) formats.
#+BEGIN_SRC lisp
;; In package.lisp, add to :export:
;; #:modern-backend #:make-modern-backend
;; Internal symbols (not exported, used by tests):
;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape
;; decicm-begin decicm-end osc8-link hex-to-rgb border-char
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(in-package :cl-tty.backend) (in-package :cl-tty.backend)
#+END_SRC
*** Color Resolution
#+BEGIN_SRC lisp
(defun hex-to-rgb (hex) (defun hex-to-rgb (hex)
"Parse a hex color string like \"#FFD700\" into (values r g b). "Parse a hex color string like \"#FFD700\" into (values r g b).
Also handles 3-digit hex like \"#F00\"." Also handles 3-digit hex like \"#F00\" (expands to \"#FF0000\")."
(let ((clean (string-trim '(#\# #\Space) hex))) (let ((clean (string-trim '(#\# #\Space) hex)))
(if (= (length clean) 3) (if (= (length clean) 3)
(values (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t) ;; Expand 3-digit: #F00 -> #FF0000
(parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t) (let* ((r (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t))
(parse-integer (subseq clean 2 3) :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) (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 2 4) :radix 16 :junk-allowed t)
(parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t))))) (parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t)))))
#+END_SRC
Named color mapping and theme color store:
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defparameter *named-colors* (defparameter *named-colors*
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3) '((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7))) (:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
(defvar *theme-colors* (make-hash-table :test 'eq)
"Hash table mapping theme keywords to hex color strings.
Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg
as a fallback when a keyword is not in *named-colors*.")
#+END_SRC
~sgr-fg~ and ~sgr-bg~ produce the actual escape sequences. The
resolution chain is: hex → named color → theme semantic role → empty.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun sgr-fg (color) (defun sgr-fg (color)
"Return SGR foreground escape for COLOR. "Return SGR foreground escape for COLOR."
Color can be a hex string, a keyword name, or nil."
(if (null color) "" (if (null color) ""
(cond ((and (stringp color) (char= (char color 0) #\#)) (cond ((and (stringp color) (char= (char color 0) #\#))
(multiple-value-bind (r g b) (hex-to-rgb color) (multiple-value-bind (r g b) (hex-to-rgb color)
@@ -212,9 +224,15 @@ Add to =cl-tty.backend= package:
(let ((index (cdr (assoc color *named-colors*)))) (let ((index (cdr (assoc color *named-colors*))))
(if index (if index
(format nil "~C[~dm" #\Esc (+ 30 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 "")))) (t ""))))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun sgr-bg (color) (defun sgr-bg (color)
"Return SGR background escape for COLOR." "Return SGR background escape for COLOR."
(if (null color) "" (if (null color) ""
@@ -225,9 +243,17 @@ Add to =cl-tty.backend= package:
(let ((index (cdr (assoc color *named-colors*)))) (let ((index (cdr (assoc color *named-colors*))))
(if index (if index
(format nil "~C[~dm" #\Esc (+ 40 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 "")))) (t ""))))
#+END_SRC
Attribute codes map keywords to SGR numbers:
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defparameter *sgr-attr-codes* (defparameter *sgr-attr-codes*
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4) '((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
(:blink . 5) (:reverse . 7) (:reset . 0))) (:blink . 5) (:reverse . 7) (:reset . 0)))
@@ -240,17 +266,15 @@ Add to =cl-tty.backend= package:
""))) "")))
#+END_SRC #+END_SRC
*** Cursor Escapes ** Cursor escapes
#+BEGIN_SRC lisp #+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun cursor-move-escape (x y) (defun cursor-move-escape (x y)
"Return CSI escape to move cursor to (x, y), 1-indexed." "Return CSI escape to move cursor to (x, y), 1-indexed."
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x))) (format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
(defun cursor-style-escape (shape blink) (defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape. "Return DECSTR escape for cursor shape."
:block = 2, :underline = 4, :bar = 6.
Add 1 for blink variants."
(let* ((base (case shape (let* ((base (case shape
(:block 2) (:underline 4) (:bar 6) (:block 2) (:underline 4) (:bar 6)
(t 2))) (t 2)))
@@ -258,9 +282,9 @@ Add to =cl-tty.backend= package:
(format nil "~C[~d q" #\Esc code))) (format nil "~C[~d q" #\Esc code)))
#+END_SRC #+END_SRC
*** Synchronization (DECICM) ** Sync and link escapes
#+BEGIN_SRC lisp #+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defun decicm-begin () (defun decicm-begin ()
"Return escape to enable synchronized updates." "Return escape to enable synchronized updates."
(format nil "~C[?2026h" #\Esc)) (format nil "~C[?2026h" #\Esc))
@@ -268,86 +292,120 @@ Add to =cl-tty.backend= package:
(defun decicm-end () (defun decicm-end ()
"Return escape to disable synchronized updates." "Return escape to disable synchronized updates."
(format nil "~C[?2026l" #\Esc)) (format nil "~C[?2026l" #\Esc))
#+END_SRC
*** OSC 8 Hyperlinks
#+BEGIN_SRC lisp
(defun osc8-link (url text) (defun osc8-link (url text)
"Wrap TEXT in an OSC 8 hyperlink to URL." "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)) #\Esc url #\Esc text #\Esc #\Esc))
#+END_SRC #+END_SRC
*** Border Characters ** Border characters
#+BEGIN_SRC lisp #+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defparameter *border-chars* (defparameter *border-chars*
'((:single :top-left . "┌") (:single :top-right . "┐") '(((:single :top-left) . "┌") ((:single :top-right) . "┐")
(:single :bottom-left . "└") (:single :bottom-right . "┘") ((:single :bottom-left) . "└") ((:single :bottom-right) . "┘")
(:single :horizontal . "─") (:single :vertical . "│") ((:single :horizontal) . "─") ((:single :vertical) . "│")
(:double :top-left . "╔") (:double :top-right . "╗") ((:double :top-left) . "╔") ((:double :top-right) . "╗")
(:double :bottom-left . "╚") (:double :bottom-right . "╝") ((:double :bottom-left) . "╚") ((:double :bottom-right) . "╝")
(:double :horizontal . "═") (:double :vertical . "║") ((:double :horizontal) . "═") ((:double :vertical) . "║")
(:rounded :top-left . "╭") (:rounded :top-right . "╮") ((:rounded :top-left) . "╭") ((:rounded :top-right) . "╮")
(:rounded :bottom-left . "╰") (:rounded :bottom-right . "╯") ((:rounded :bottom-left) . "╰") ((:rounded :bottom-right) . "╯")
(:rounded :horizontal . "─") (:rounded :vertical . "│"))) ((:rounded :horizontal) . "─") ((:rounded :vertical) . "│")))
(defun border-char (style pos) (defun border-char (style pos)
"Return the Unicode box-drawing character for STYLE at POS." "Return the Unicode box-drawing character for STYLE at POS."
(let ((char (cdr (assoc (cons style pos) *border-chars* :test #'equal)))) (let ((char (cdr (assoc (list style pos) *border-chars* :test #'equal))))
(or char (if (member pos '(:horizontal :vertical)) (or char (if (member pos '(:horizontal :vertical))
(case pos (:horizontal "─") (:vertical "│")) (case pos (:horizontal "─") (:vertical "│"))
"+")))) "+"))))
#+END_SRC #+END_SRC
*** Modern Backend Class ** Modern backend class
#+BEGIN_SRC lisp #+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defclass modern-backend (backend) (defclass modern-backend (backend)
((output-stream :initform *standard-output* ((output-stream :initform *standard-output*
:initarg :output-stream
:accessor backend-output-stream) :accessor backend-output-stream)
(in-sync-p :initform nil :accessor in-sync-p))) (in-sync-p :initform nil :accessor in-sync-p)))
(defun make-modern-backend (&key color-palette) (defun make-modern-backend (&key color-palette output-stream)
(declare (ignore color-palette)) (declare (ignore color-palette))
(make-instance 'modern-backend)) (make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
#+END_SRC
** Lifecycle
~initialize-backend~ enters the alt screen, enables mouse tracking,
bracketed paste, and kitty keyboard protocol. ~shutdown-backend~
restores everything.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod initialize-backend ((b modern-backend)) (defmethod initialize-backend ((b modern-backend))
;; Enter raw mode, enable mouse, bracketed paste
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen (backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen
(backend-write b (format nil "~C[?1000h" #\Esc)) ; mouse basic (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[?1002h" #\Esc)) ; mouse drag
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR mouse (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[?2004h" #\Esc)) ; bracketed paste
(backend-write b (format nil "~C[?u" #\Esc)) ; kitty keyboard
(cursor-hide b) (cursor-hide b)
(finish-output (backend-output-stream b)) (finish-output (backend-output-stream b))
b) b)
(defmethod shutdown-backend ((b modern-backend)) (defmethod shutdown-backend ((b modern-backend))
(cursor-show b) (cursor-show b)
(backend-write b (format nil "~C[?2004l" #\Esc)) ; disable bracketed paste (backend-write b (format nil "~C[?u" #\Esc))
(backend-write b (format nil "~C[?1006l" #\Esc)) ; disable SGR mouse (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[?1002l" #\Esc))
(backend-write b (format nil "~C[?1000l" #\Esc)) (backend-write b (format nil "~C[?1000l" #\Esc))
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
(finish-output (backend-output-stream b)) (finish-output (backend-output-stream b))
(values)) (values))
#+END_SRC
** Backend-size via ioctl
Uses TIOCGWINSZ to query actual terminal dimensions. The alien-sap
wrapper ensures compatibility across SBCL versions.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod backend-size ((b modern-backend)) (defmethod backend-size ((b modern-backend))
;; Default fallback — real implementation queries terminal (let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
(values 80 24)) (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
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod backend-write ((b modern-backend) string) (defmethod backend-write ((b modern-backend) string)
(let ((stream (backend-output-stream b))) (let ((stream (backend-output-stream b)))
(write-string string stream) (write-string string stream)
(finish-output stream)
(length string))) (length string)))
(defmethod capable-p ((b modern-backend) feature) (defmethod capable-p ((b modern-backend) feature)
(member feature '(:truecolor :osc8 :sync :mouse (member feature '(:truecolor :osc8 :sync :mouse
:bracketed-paste :cursor-style :bracketed-paste :cursor-style
:kitty-keyboard))) :kitty-keyboard)))
#+END_SRC
** 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.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-text ((b modern-backend) x y string fg bg (defmethod draw-text ((b modern-backend) x y string fg bg
&key bold italic underline reverse dim blink) &key bold italic underline reverse dim blink)
(let ((parts (list (cursor-move-escape x y) (let ((parts (list (cursor-move-escape x y)
@@ -361,10 +419,15 @@ Add to =cl-tty.backend= package:
string string
(sgr-attr :reset)))) (sgr-attr :reset))))
(backend-write b (apply #'concatenate 'string parts)))) (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.
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-border ((b modern-backend) x y width height (defmethod draw-border ((b modern-backend) x y width height
&key style fg bg title title-align) &key style fg bg title title-align)
(declare (ignore title title-align))
(let* ((s (or style :single)) (let* ((s (or style :single))
(tl (border-char s :top-left)) (tl (border-char s :top-left))
(tr (border-char s :top-right)) (tr (border-char s :top-right))
@@ -375,31 +438,58 @@ Add to =cl-tty.backend= package:
(fg-esc (sgr-fg fg)) (fg-esc (sgr-fg fg))
(bg-esc (sgr-bg bg)) (bg-esc (sgr-bg bg))
(reset (sgr-attr :reset)) (reset (sgr-attr :reset))
(top (concatenate 'string (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 fg-esc bg-esc tl
(make-string (- width 2) :initial-element (char h 0)) (make-string left-pad :initial-element hc)
tr reset (string #\Newline))) 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 (mid (concatenate 'string
fg-esc bg-esc v fg-esc bg-esc v
(make-string (- width 2) :initial-element #\Space) (make-string inner-width :initial-element #\Space)
v reset (string #\Newline))) v reset (string #\Newline)))
(bot (concatenate 'string (bot (concatenate 'string
fg-esc bg-esc bl fg-esc bg-esc bl
(make-string (- width 2) :initial-element (char h 0)) (make-string inner-width :initial-element hc)
br reset))) br reset)))
(backend-write b top) (backend-write b top)
(loop repeat (- height 2) do (backend-write b mid)) (loop repeat (- height 2) do (backend-write b mid))
(backend-write b bot))) (backend-write b bot)))
#+END_SRC
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod draw-rect ((b modern-backend) x y width height &key bg) (defmethod draw-rect ((b modern-backend) x y width height &key bg)
(let ((bg-esc (sgr-bg bg)) (let* ((bg-esc (sgr-bg bg))
(reset (sgr-attr :reset)) (reset (sgr-attr :reset))
(line (concatenate 'string (line (concatenate 'string
bg-esc bg-esc
(make-string width :initial-element #\Space) (make-string width :initial-element #\Space)
reset (string #\Newline)))) reset (string #\Newline))))
(loop repeat height do (loop :for row :from 0 :below height :do
(backend-write b (cursor-move-escape x y)) (backend-write b (cursor-move-escape x (+ y row)))
(backend-write b line)))) (backend-write b line))))
(defmethod draw-link ((b modern-backend) x y string url (defmethod draw-link ((b modern-backend) x y string url
@@ -412,9 +502,14 @@ Add to =cl-tty.backend= package:
(defmethod draw-ellipsis ((b modern-backend) x y width (defmethod draw-ellipsis ((b modern-backend) x y width
&key fg bg) &key fg bg)
(declare (ignore width))
(let ((dots "...")) (let ((dots "..."))
(draw-text b x y dots fg bg))) (draw-text b x y dots fg bg)))
#+END_SRC
** Cursor and input methods
#+BEGIN_SRC lisp :tangle ../src/backend/modern.lisp
(defmethod cursor-move ((b modern-backend) x y) (defmethod cursor-move ((b modern-backend) x y)
(backend-write b (cursor-move-escape x y))) (backend-write b (cursor-move-escape x y)))
@@ -427,6 +522,16 @@ Add to =cl-tty.backend= package:
(defmethod cursor-style ((b modern-backend) shape &key blink) (defmethod cursor-style ((b modern-backend) shape &key blink)
(backend-write b (cursor-style-escape shape blink))) (backend-write b (cursor-style-escape shape blink)))
(defmethod enable-mouse ((b modern-backend))
(backend-write b (format nil "~C[?1000h" #\Esc))
(backend-write b (format nil "~C[?1002h" #\Esc))
(backend-write b (format nil "~C[?1006h" #\Esc))
(finish-output (backend-output-stream b)))
(defmethod enable-bracketed-paste ((b modern-backend))
(backend-write b (format nil "~C[?2004h" #\Esc))
(finish-output (backend-output-stream b)))
(defmethod begin-sync ((b modern-backend)) (defmethod begin-sync ((b modern-backend))
(setf (in-sync-p b) t) (setf (in-sync-p b) t)
(backend-write b (decicm-begin))) (backend-write b (decicm-begin)))

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

@@ -82,7 +82,7 @@
(test osc8-escape (test osc8-escape
"OSC 8 hyperlink escape wraps text" "OSC 8 hyperlink escape wraps text"
(is (equal (cl-tty.backend::osc8-link "http://example.com" "click here") (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)))) #\Esc #\Esc #\Esc #\Esc))))
;; ── Hex Parsing ──────────────────────────────────────────────── ;; ── Hex Parsing ────────────────────────────────────────────────

44
src/backend/modern.lisp
View File

@@ -1,13 +1,3 @@
;;; modern-backend — Raw escape sequence backend
;;; Generated from org/modern-backend.org
;;; DO NOT EDIT — edit the .org file instead
;; In package.lisp, add to :export:
;; #:modern-backend #:make-modern-backend
;; Internal symbols (not exported, used by tests):
;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape
;; decicm-begin decicm-end osc8-link hex-to-rgb border-char
(in-package :cl-tty.backend) (in-package :cl-tty.backend)
(defun hex-to-rgb (hex) (defun hex-to-rgb (hex)
@@ -34,10 +24,7 @@ Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg
as a fallback when a keyword is not in *named-colors*.") as a fallback when a keyword is not in *named-colors*.")
(defun sgr-fg (color) (defun sgr-fg (color)
"Return SGR foreground escape for COLOR. "Return SGR foreground escape for COLOR."
Color can be a hex string, a keyword name, or nil.
Keywords first try *named-colors*, then fall back to *theme-colors*
which resolves theme semantic roles to hex strings."
(if (null color) "" (if (null color) ""
(cond ((and (stringp color) (char= (char color 0) #\#)) (cond ((and (stringp color) (char= (char color 0) #\#))
(multiple-value-bind (r g b) (hex-to-rgb color) (multiple-value-bind (r g b) (hex-to-rgb color)
@@ -46,7 +33,6 @@ as a fallback when a keyword is not in *named-colors*.")
(let ((index (cdr (assoc color *named-colors*)))) (let ((index (cdr (assoc color *named-colors*))))
(if index (if index
(format nil "~C[~dm" #\Esc (+ 30 index)) (format nil "~C[~dm" #\Esc (+ 30 index))
;; Fall back to theme-colors hash
(let ((hex (gethash color *theme-colors*))) (let ((hex (gethash color *theme-colors*)))
(if hex (if hex
(multiple-value-bind (r g b) (hex-to-rgb hex) (multiple-value-bind (r g b) (hex-to-rgb hex)
@@ -55,8 +41,7 @@ as a fallback when a keyword is not in *named-colors*.")
(t "")))) (t ""))))
(defun sgr-bg (color) (defun sgr-bg (color)
"Return SGR background escape for COLOR. "Return SGR background escape for COLOR."
Keywords first try *named-colors*, then fall back to *theme-colors*."
(if (null color) "" (if (null color) ""
(cond ((and (stringp color) (char= (char color 0) #\#)) (cond ((and (stringp color) (char= (char color 0) #\#))
(multiple-value-bind (r g b) (hex-to-rgb color) (multiple-value-bind (r g b) (hex-to-rgb color)
@@ -65,7 +50,6 @@ as a fallback when a keyword is not in *named-colors*.")
(let ((index (cdr (assoc color *named-colors*)))) (let ((index (cdr (assoc color *named-colors*))))
(if index (if index
(format nil "~C[~dm" #\Esc (+ 40 index)) (format nil "~C[~dm" #\Esc (+ 40 index))
;; Fall back to theme-colors hash
(let ((hex (gethash color *theme-colors*))) (let ((hex (gethash color *theme-colors*)))
(if hex (if hex
(multiple-value-bind (r g b) (hex-to-rgb hex) (multiple-value-bind (r g b) (hex-to-rgb hex)
@@ -89,9 +73,7 @@ as a fallback when a keyword is not in *named-colors*.")
(format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x))) (format nil "~C[~d;~dH" #\Esc (1+ y) (1+ x)))
(defun cursor-style-escape (shape blink) (defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape. "Return DECSTR escape for cursor shape."
:block = 2, :underline = 4, :bar = 6.
Add 1 for blink variants."
(let* ((base (case shape (let* ((base (case shape
(:block 2) (:underline 4) (:bar 6) (:block 2) (:underline 4) (:bar 6)
(t 2))) (t 2)))
@@ -108,7 +90,7 @@ as a fallback when a keyword is not in *named-colors*.")
(defun osc8-link (url text) (defun osc8-link (url text)
"Wrap TEXT in an OSC 8 hyperlink to URL." "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)) #\Esc url #\Esc text #\Esc #\Esc))
(defparameter *border-chars* (defparameter *border-chars*
@@ -140,7 +122,6 @@ as a fallback when a keyword is not in *named-colors*.")
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*))) (make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
(defmethod initialize-backend ((b modern-backend)) (defmethod initialize-backend ((b modern-backend))
;; Enter raw mode, enable mouse, bracketed paste, kitty keyboard
(backend-write b (format nil "~C[?1049h" #\Esc)) ; alt screen (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[?1000h" #\Esc)) ; mouse basic
(backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag (backend-write b (format nil "~C[?1002h" #\Esc)) ; mouse drag
@@ -153,9 +134,9 @@ as a fallback when a keyword is not in *named-colors*.")
(defmethod shutdown-backend ((b modern-backend)) (defmethod shutdown-backend ((b modern-backend))
(cursor-show b) (cursor-show b)
(backend-write b (format nil "~C[?u" #\Esc)) ; restore default keyboard (backend-write b (format nil "~C[?u" #\Esc))
(backend-write b (format nil "~C[?2004l" #\Esc)) ; disable bracketed paste (backend-write b (format nil "~C[?2004l" #\Esc))
(backend-write b (format nil "~C[?1006l" #\Esc)) ; disable SGR mouse (backend-write b (format nil "~C[?1006l" #\Esc))
(backend-write b (format nil "~C[?1002l" #\Esc)) (backend-write b (format nil "~C[?1002l" #\Esc))
(backend-write b (format nil "~C[?1000l" #\Esc)) (backend-write b (format nil "~C[?1000l" #\Esc))
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen (backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
@@ -163,7 +144,6 @@ as a fallback when a keyword is not in *named-colors*.")
(values)) (values))
(defmethod backend-size ((b modern-backend)) (defmethod backend-size ((b modern-backend))
;; Query actual terminal dimensions via TIOCGWINSZ ioctl
(let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux (let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4))) (winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(unwind-protect (unwind-protect
@@ -274,6 +254,7 @@ as a fallback when a keyword is not in *named-colors*.")
(defmethod draw-ellipsis ((b modern-backend) x y width (defmethod draw-ellipsis ((b modern-backend) x y width
&key fg bg) &key fg bg)
(declare (ignore width))
(let ((dots "...")) (let ((dots "..."))
(draw-text b x y dots fg bg))) (draw-text b x y dots fg bg)))
@@ -290,13 +271,13 @@ as a fallback when a keyword is not in *named-colors*.")
(backend-write b (cursor-style-escape shape blink))) (backend-write b (cursor-style-escape shape blink)))
(defmethod enable-mouse ((b modern-backend)) (defmethod enable-mouse ((b modern-backend))
(backend-write b (format nil "~C[?1000h" #\Esc)) ; basic (backend-write b (format nil "~C[?1000h" #\Esc))
(backend-write b (format nil "~C[?1002h" #\Esc)) ; drag (backend-write b (format nil "~C[?1002h" #\Esc))
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR (backend-write b (format nil "~C[?1006h" #\Esc))
(finish-output (backend-output-stream b))) (finish-output (backend-output-stream b)))
(defmethod enable-bracketed-paste ((b modern-backend)) (defmethod enable-bracketed-paste ((b modern-backend))
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste (backend-write b (format nil "~C[?2004h" #\Esc))
(finish-output (backend-output-stream b))) (finish-output (backend-output-stream b)))
(defmethod begin-sync ((b modern-backend)) (defmethod begin-sync ((b modern-backend))
@@ -307,4 +288,3 @@ as a fallback when a keyword is not in *named-colors*.")
(setf (in-sync-p b) nil) (setf (in-sync-p b) nil)
(backend-write b (decicm-end)) (backend-write b (decicm-end))
(finish-output (backend-output-stream b))) (finish-output (backend-output-stream b)))