811d51a4f2
Rename: cl-tty avoids naming collision with Quicklisp's cl-tui (naryl/cl-tui, a cl-charms-based ncurses library). Our project is pure escape-sequence CL. v0.9.0 adds: - Dialog base class: modal overlay with backdrop, centered panel, size variants (:small/:medium/:large), stack-based management - Dialog subclasses: alert, confirm, select-dialog, prompt-dialog - Toast notifications: transient, top-right corner, auto-dismiss, colored variants (info/success/warning/error) - 78 tests total, 100% passing ASDF: read-time package references (+fiveam:+) replaced with find-symbol so .asd loads without FiveAM pre-loaded
439 lines
16 KiB
Org Mode
439 lines
16 KiB
Org Mode
#+TITLE: cl-tty Modern Backend — v0.0.2
|
|
#+STARTUP: content
|
|
#+FILETAGS: :cl-tty:backend:v0.0.2:
|
|
#+OPTIONS: ^:nil
|
|
|
|
* Modern Backend
|
|
|
|
The =modern-backend= renders through raw ANSI/XTerm escape sequences.
|
|
No ncurses, no CFFI, no external dependencies — pure CL string
|
|
construction. Supports truecolor, Unicode box-drawing, OSC 8 hyperlinks,
|
|
DECICM synchronized updates, SGR mouse, and the kitty keyboard protocol.
|
|
|
|
** Contract
|
|
|
|
*** Constructor
|
|
|
|
- =(make-modern-backend &key color-palette)= → modern-backend
|
|
Create a modern backend. color-palette modifies theme color mappings.
|
|
|
|
*** Escape Sequence Generation
|
|
|
|
All escape sequences follow ECMA-48 / ANSI X3.64 conventions:
|
|
|
|
| Escape | Meaning |
|
|
|--------+--------------------------|
|
|
| ~ESC[~ | Control Sequence Introducer (CSI) |
|
|
| ~ESC]~ | Operating System Command (OSC) |
|
|
| ~ESC ~ | Single-character sequence |
|
|
|
|
*** Style Resolution
|
|
|
|
Colors are resolved through a palette before emission:
|
|
|
|
- =(resolve-color backend hex-or-name)= → color-index
|
|
Convert hex string or semantic name to an SGR color code.
|
|
Hex ("#FFD700") → 48;2;R;G;B or 38;2;R;G;B.
|
|
Named colors (:black :red :green :yellow :blue :magenta :cyan :white)
|
|
→ 8-color SGR codes.
|
|
|
|
** Test Suite
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defpackage :cl-tty-modern-backend-test
|
|
(:use :cl :fiveam :cl-tty.backend)
|
|
(:export #:run-tests))
|
|
(in-package :cl-tty-modern-backend-test)
|
|
|
|
(def-suite modern-backend-suite :description "Modern backend tests")
|
|
(in-suite modern-backend-suite)
|
|
|
|
(defun run-tests ()
|
|
(let ((result (run 'modern-backend-suite)))
|
|
(fiveam:explain! result)
|
|
(uiop:quit 0)))
|
|
|
|
;; ── 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")
|
|
(format nil "~C[38;2;255;215;0m" #\Esc))))
|
|
|
|
(test sgr-truecolor-background
|
|
"SGR truecolor background escape is correct"
|
|
(is (equal (cl-tty.backend::sgr-bg "#1a1b26")
|
|
(format nil "~C[48;2;26;27;38m" #\Esc))))
|
|
|
|
(test sgr-named-colors
|
|
"SGR named colors resolve to 8-color codes"
|
|
(is (equal (cl-tty.backend::sgr-fg :red)
|
|
(format nil "~C[31m" #\Esc)))
|
|
(is (equal (cl-tty.backend::sgr-bg :blue)
|
|
(format nil "~C[44m" #\Esc))))
|
|
|
|
(test sgr-bold-italic
|
|
"SGR attribute escapes are correct"
|
|
(is (equal (cl-tty.backend::sgr-attr :bold) (format nil "~C[1m" #\Esc)))
|
|
(is (equal (cl-tty.backend::sgr-attr :italic) (format nil "~C[3m" #\Esc)))
|
|
(is (equal (cl-tty.backend::sgr-attr :underline) (format nil "~C[4m" #\Esc)))
|
|
(is (equal (cl-tty.backend::sgr-attr :reset) (format nil "~C[0m" #\Esc))))
|
|
|
|
;; ── Cursor ─────────────────────────────────────────────────────
|
|
|
|
(test cursor-move-escape
|
|
"cursor-move generates correct CSI escape"
|
|
(let ((b (make-modern-backend)))
|
|
(is (equal (cl-tty.backend::cursor-move-escape 5 10)
|
|
(format nil "~C[6;11H" #\Esc)))))
|
|
|
|
(test cursor-style-block
|
|
"cursor-style :block generate correct escape"
|
|
(let ((b (make-modern-backend)))
|
|
(is (equal (cl-tty.backend::cursor-style-escape :block nil)
|
|
(format nil "~C[2 q" #\Esc)))))
|
|
|
|
(test cursor-style-bar
|
|
"cursor-style :bar generate correct escape"
|
|
(let ((b (make-modern-backend)))
|
|
(is (equal (cl-tty.backend::cursor-style-escape :bar nil)
|
|
(format nil "~C[6 q" #\Esc)))))
|
|
|
|
(test cursor-style-underline-blink
|
|
"cursor-style :underline with blink"
|
|
(let ((b (make-modern-backend)))
|
|
(is (equal (cl-tty.backend::cursor-style-escape :underline t)
|
|
(format nil "~C[5 q" #\Esc)))))
|
|
|
|
;; ── Synchronization ────────────────────────────────────────────
|
|
|
|
(test decicm-escapes
|
|
"DECICM synchronized update escapes"
|
|
(is (equal (cl-tty.backend::decicm-begin) (format nil "~C[?2026h" #\Esc)))
|
|
(is (equal (cl-tty.backend::decicm-end) (format nil "~C[?2026l" #\Esc))))
|
|
|
|
;; ── OSC 8 Hyperlinks ──────────────────────────────────────────
|
|
|
|
(test osc8-escape
|
|
"OSC 8 hyperlink escape wraps text"
|
|
(is (equal (cl-tty.backend::osc8-link "http://example.com" "click here")
|
|
(format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\"
|
|
#\Esc #\Esc #\Esc #\Esc))))
|
|
|
|
;; ── Hex Parsing ────────────────────────────────────────────────
|
|
|
|
(test hex-color-parsing
|
|
"hex-to-rgb parses valid hex colors"
|
|
(multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#FFD700")
|
|
(is (= r 255))
|
|
(is (= g 215))
|
|
(is (= b 0))))
|
|
|
|
(test hex-color-black
|
|
"hex-to-rgb parses black"
|
|
(multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#000000")
|
|
(is (= r 0))
|
|
(is (= g 0))
|
|
(is (= b 0))))
|
|
|
|
(test hex-color-short-form
|
|
"hex-to-rgb parses 3-digit hex"
|
|
(multiple-value-bind (r g b) (cl-tty.backend::hex-to-rgb "#F00")
|
|
(is (= r 255))
|
|
(is (= g 0))
|
|
(is (= b 0))))
|
|
|
|
;; ── 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) "╯")))
|
|
|
|
(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
|
|
|
|
*** Package
|
|
|
|
Add to =cl-tty.backend= package:
|
|
|
|
#+BEGIN_SRC lisp
|
|
;; In package.lisp, add to :export:
|
|
;; #:modern-backend #:make-modern-backend
|
|
;; Internal symbols (not exported, used by tests):
|
|
;; sgr-fg sgr-bg sgr-attr cursor-move-escape cursor-style-escape
|
|
;; decicm-begin decicm-end osc8-link hex-to-rgb border-char
|
|
|
|
(in-package :cl-tty.backend)
|
|
#+END_SRC
|
|
|
|
*** Color Resolution
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun hex-to-rgb (hex)
|
|
"Parse a hex color string like \"#FFD700\" into (values r g b).
|
|
Also handles 3-digit hex like \"#F00\"."
|
|
(let ((clean (string-trim '(#\# #\Space) hex)))
|
|
(if (= (length clean) 3)
|
|
(values (parse-integer (subseq clean 0 1) :radix 16 :junk-allowed t)
|
|
(parse-integer (subseq clean 1 2) :radix 16 :junk-allowed t)
|
|
(parse-integer (subseq clean 2 3) :radix 16 :junk-allowed t))
|
|
(values (parse-integer (subseq clean 0 2) :radix 16 :junk-allowed t)
|
|
(parse-integer (subseq clean 2 4) :radix 16 :junk-allowed t)
|
|
(parse-integer (subseq clean 4 6) :radix 16 :junk-allowed t)))))
|
|
|
|
(defparameter *named-colors*
|
|
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
|
|
(:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7)))
|
|
|
|
(defun sgr-fg (color)
|
|
"Return SGR foreground escape for COLOR.
|
|
Color can be a hex string, a keyword name, or nil."
|
|
(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))
|
|
"")))
|
|
(t ""))))
|
|
|
|
(defun sgr-bg (color)
|
|
"Return SGR background escape for COLOR."
|
|
(if (null color) ""
|
|
(cond ((and (stringp color) (char= (char color 0) #\#))
|
|
(multiple-value-bind (r g b) (hex-to-rgb color)
|
|
(format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)))
|
|
((keywordp color)
|
|
(let ((index (cdr (assoc color *named-colors*))))
|
|
(if index
|
|
(format nil "~C[~dm" #\Esc (+ 40 index))
|
|
"")))
|
|
(t ""))))
|
|
|
|
(defparameter *sgr-attr-codes*
|
|
'((:bold . 1) (:dim . 2) (:italic . 3) (:underline . 4)
|
|
(:blink . 5) (:reverse . 7) (:reset . 0)))
|
|
|
|
(defun sgr-attr (attr)
|
|
"Return SGR attribute escape for ATTR keyword."
|
|
(let ((code (cdr (assoc attr *sgr-attr-codes*))))
|
|
(if code
|
|
(format nil "~C[~dm" #\Esc code)
|
|
"")))
|
|
#+END_SRC
|
|
|
|
*** Cursor Escapes
|
|
|
|
#+BEGIN_SRC 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)))
|
|
|
|
(defun cursor-style-escape (shape blink)
|
|
"Return DECSTR escape for cursor shape.
|
|
:block = 2, :underline = 4, :bar = 6.
|
|
Add 1 for blink variants."
|
|
(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
|
|
|
|
*** Synchronization (DECICM)
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defun decicm-begin ()
|
|
"Return escape to enable synchronized updates."
|
|
(format nil "~C[?2026h" #\Esc))
|
|
|
|
(defun decicm-end ()
|
|
"Return escape to disable synchronized updates."
|
|
(format nil "~C[?2026l" #\Esc))
|
|
#+END_SRC
|
|
|
|
*** OSC 8 Hyperlinks
|
|
|
|
#+BEGIN_SRC 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
|
|
|
|
#+BEGIN_SRC 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 . "│")))
|
|
|
|
(defun border-char (style pos)
|
|
"Return the Unicode box-drawing character for STYLE at POS."
|
|
(let ((char (cdr (assoc (cons style pos) *border-chars* :test #'equal))))
|
|
(or char (if (member pos '(:horizontal :vertical))
|
|
(case pos (:horizontal "─") (:vertical "│"))
|
|
"+"))))
|
|
#+END_SRC
|
|
|
|
*** Modern Backend Class
|
|
|
|
#+BEGIN_SRC lisp
|
|
(defclass modern-backend (backend)
|
|
((output-stream :initform *standard-output*
|
|
:accessor backend-output-stream)
|
|
(in-sync-p :initform nil :accessor in-sync-p)))
|
|
|
|
(defun make-modern-backend (&key color-palette)
|
|
(declare (ignore color-palette))
|
|
(make-instance '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[?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
|
|
(cursor-hide b)
|
|
(finish-output (backend-output-stream b))
|
|
b)
|
|
|
|
(defmethod shutdown-backend ((b modern-backend))
|
|
(cursor-show b)
|
|
(backend-write b (format nil "~C[?2004l" #\Esc)) ; disable bracketed paste
|
|
(backend-write b (format nil "~C[?1006l" #\Esc)) ; disable SGR mouse
|
|
(backend-write b (format nil "~C[?1002l" #\Esc))
|
|
(backend-write b (format nil "~C[?1000l" #\Esc))
|
|
(backend-write b (format nil "~C[?1049l" #\Esc)) ; normal screen
|
|
(finish-output (backend-output-stream b))
|
|
(values))
|
|
|
|
(defmethod backend-size ((b modern-backend))
|
|
;; Default fallback — real implementation queries terminal
|
|
(values 80 24))
|
|
|
|
(defmethod backend-write ((b modern-backend) string)
|
|
(let ((stream (backend-output-stream b)))
|
|
(write-string string stream)
|
|
(length string)))
|
|
|
|
(defmethod capable-p ((b modern-backend) feature)
|
|
(member feature '(:truecolor :osc8 :sync :mouse
|
|
:bracketed-paste :cursor-style
|
|
:kitty-keyboard)))
|
|
|
|
(defmethod draw-text ((b modern-backend) x y string fg bg
|
|
&key bold italic underline reverse dim blink)
|
|
(let ((parts (list (cursor-move-escape x y)
|
|
(sgr-fg fg) (sgr-bg bg)
|
|
(when bold (sgr-attr :bold))
|
|
(when italic (sgr-attr :italic))
|
|
(when underline (sgr-attr :underline))
|
|
(when reverse (sgr-attr :reverse))
|
|
(when dim (sgr-attr :dim))
|
|
(when blink (sgr-attr :blink))
|
|
string
|
|
(sgr-attr :reset))))
|
|
(backend-write b (apply #'concatenate 'string parts))))
|
|
|
|
(defmethod draw-border ((b modern-backend) x y width height
|
|
&key style fg bg title title-align)
|
|
(declare (ignore 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))
|
|
(top (concatenate 'string
|
|
fg-esc bg-esc tl
|
|
(make-string (- width 2) :initial-element (char h 0))
|
|
tr reset (string #\Newline)))
|
|
(mid (concatenate 'string
|
|
fg-esc bg-esc v
|
|
(make-string (- width 2) :initial-element #\Space)
|
|
v reset (string #\Newline)))
|
|
(bot (concatenate 'string
|
|
fg-esc bg-esc bl
|
|
(make-string (- width 2) :initial-element (char h 0))
|
|
br reset)))
|
|
(backend-write b top)
|
|
(loop repeat (- height 2) do (backend-write b mid))
|
|
(backend-write b bot)))
|
|
|
|
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
|
|
(let ((bg-esc (sgr-bg bg))
|
|
(reset (sgr-attr :reset))
|
|
(line (concatenate 'string
|
|
bg-esc
|
|
(make-string width :initial-element #\Space)
|
|
reset (string #\Newline))))
|
|
(loop repeat height do
|
|
(backend-write b (cursor-move-escape x y))
|
|
(backend-write b line))))
|
|
|
|
(defmethod draw-link ((b modern-backend) x y string url
|
|
&key fg bg)
|
|
(let ((parts (list (cursor-move-escape x y)
|
|
(sgr-fg fg) (sgr-bg bg)
|
|
(osc8-link url string)
|
|
(sgr-attr :reset))))
|
|
(backend-write b (apply #'concatenate 'string parts))))
|
|
|
|
(defmethod draw-ellipsis ((b modern-backend) x y width
|
|
&key fg bg)
|
|
(let ((dots "..."))
|
|
(draw-text b x y dots fg bg)))
|
|
|
|
(defmethod cursor-move ((b modern-backend) x y)
|
|
(backend-write b (cursor-move-escape x y)))
|
|
|
|
(defmethod cursor-hide ((b modern-backend))
|
|
(backend-write b (format nil "~C[?25l" #\Esc)))
|
|
|
|
(defmethod cursor-show ((b modern-backend))
|
|
(backend-write b (format nil "~C[?25h" #\Esc)))
|
|
|
|
(defmethod cursor-style ((b modern-backend) shape &key blink)
|
|
(backend-write b (cursor-style-escape shape blink)))
|
|
|
|
(defmethod begin-sync ((b modern-backend))
|
|
(setf (in-sync-p b) t)
|
|
(backend-write b (decicm-begin)))
|
|
|
|
(defmethod end-sync ((b modern-backend))
|
|
(setf (in-sync-p b) nil)
|
|
(backend-write b (decicm-end))
|
|
(finish-output (backend-output-stream b)))
|
|
#+END_SRC
|