cl-tty/org/modern-backend.org

cl-tty Modern Backend — v0.0.2

• Modern Backend
  • Contract
    • Constructor
    • Escape Sequence Generation
    • Style Resolution
  • Test Suite
  • Implementation
    • Package
    • Color Resolution
    • Cursor Escapes
    • Synchronization (DECICM)
    • OSC 8 Hyperlinks
    • Border Characters
    • Modern Backend Class

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

(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) "║")))

Implementation

Package

Add to cl-tty.backend package:

;; 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)

Color Resolution

(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)
        "")))

Cursor Escapes

(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)))

Synchronization (DECICM)

(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))

OSC 8 Hyperlinks

(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))

Border Characters

(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 "│"))
                 "+"))))

Modern Backend Class

(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)))