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

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

@@ -82,7 +82,7 @@
(test osc8-escape
"OSC 8 hyperlink escape wraps text"
(is (equal (cl-tty.backend::osc8-link "http://example.com" "click here")
(format nil "~C]8;;http://example.com~C\\click here~C]8;;~C\\"
(format nil "~C]8;;http://example.com~C\\\\click here~C]8;;~C\\\\"
#\Esc #\Esc #\Esc #\Esc))))
;; ── Hex Parsing ────────────────────────────────────────────────

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)
(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*.")
(defun sgr-fg (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."
"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)
@@ -46,7 +33,6 @@ as a fallback when a keyword is not in *named-colors*.")
(let ((index (cdr (assoc color *named-colors*))))
(if index
(format nil "~C[~dm" #\Esc (+ 30 index))
;; Fall back to theme-colors hash
(let ((hex (gethash color *theme-colors*)))
(if 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 ""))))
(defun sgr-bg (color)
"Return SGR background escape for COLOR.
Keywords first try *named-colors*, then fall back to *theme-colors*."
"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)
@@ -65,7 +50,6 @@ as a fallback when a keyword is not in *named-colors*.")
(let ((index (cdr (assoc color *named-colors*))))
(if index
(format nil "~C[~dm" #\Esc (+ 40 index))
;; Fall back to theme-colors hash
(let ((hex (gethash color *theme-colors*)))
(if 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)))
(defun cursor-style-escape (shape blink)
"Return DECSTR escape for cursor shape.
:block = 2, :underline = 4, :bar = 6.
Add 1 for blink variants."
"Return DECSTR escape for cursor shape."
(let* ((base (case shape
(:block 2) (:underline 4) (:bar 6)
(t 2)))
@@ -108,7 +90,7 @@ as a fallback when a keyword is not in *named-colors*.")
(defun osc8-link (url text)
"Wrap TEXT in an OSC 8 hyperlink to URL."
(format nil "~C]8;;~A~C\\~A~C]8;;~C\\"
(format nil "~C]8;;~A~C\\\\~A~C]8;;~C\\\\"
#\Esc url #\Esc text #\Esc #\Esc))
(defparameter *border-chars*
@@ -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*)))
(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[?1000h" #\Esc)) ; mouse basic
(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))
(cursor-show b)
(backend-write b (format nil "~C[?u" #\Esc)) ; restore default keyboard
(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[?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
@@ -163,7 +144,6 @@ as a fallback when a keyword is not in *named-colors*.")
(values))
(defmethod backend-size ((b modern-backend))
;; Query actual terminal dimensions via TIOCGWINSZ ioctl
(let* ((+tiocgwinsz+ 21523) ; 0x5413 on Linux
(winsize (sb-alien:make-alien sb-alien:unsigned-short 4)))
(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
&key fg bg)
(declare (ignore width))
(let ((dots "..."))
(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)))
(defmethod enable-mouse ((b modern-backend))
(backend-write b (format nil "~C[?1000h" #\Esc)) ; basic
(backend-write b (format nil "~C[?1002h" #\Esc)) ; drag
(backend-write b (format nil "~C[?1006h" #\Esc)) ; SGR
(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)) ; bracketed paste
(backend-write b (format nil "~C[?2004h" #\Esc))
(finish-output (backend-output-stream b)))
(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)
(backend-write b (decicm-end))
(finish-output (backend-output-stream b)))