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

restructure: move backend/ and layout/ into src/; convert README to org syntax; fix demo package conflict and alien-sap ioctl; update ROADMAP with v0.15.0; remove stale files

Browse Source 
- Move backend/ and layout/ directories into src/
- Update all path references in ASD, scripts, docs
- Convert README.org from Markdown syntax to proper Org-mode
- Fix demo.lisp use-package conflict (both backend and input export #:read-event)
- Fix modern-backend TIOCGWINSZ ioctl alien type (alien-sap wrapper)
- Add v0.15.0 section to ROADMAP, update line count to 5760
- Add known gaps (suspend/resume-backend, slot modes) to v1.0.0 checklist
- Remove docs/plans/, debug-layout.lisp, system-index.txt, ci-watchdog.sh
- Move tangle.py to Hermes skill (org-babel-tangle)
- Add .gitignore for fasl files
This commit is contained in:
Hermes Agent
2026-05-12 16:57:19 +00:00
parent 5f07c1fd76
commit 47094c48e5
31 changed files with 369 additions and 1390 deletions
Download Patch File Download Diff File Expand all files Collapse all files

310
src/backend/modern.lisp Normal file
View File

@@ -0,0 +1,310 @@
;;; 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)
"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)))))
(defparameter *named-colors*
'((:black . 0) (:red . 1) (:green . 2) (:yellow . 3)
(: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*.")
(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."
(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))
;; Fall back to theme-colors hash
(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 ""))))
(defun sgr-bg (color)
"Return SGR background escape for COLOR.
Keywords first try *named-colors*, then fall back to *theme-colors*."
(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))
;; Fall back to theme-colors hash
(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 ""))))
(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)
"")))
(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)))
(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))
(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))
(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 (list style pos) *border-chars* :test #'equal))))
(or char (if (member pos '(:horizontal :vertical))
(case pos (:horizontal "─") (:vertical "│"))
"+"))))
(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)))
(defun make-modern-backend (&key color-palette output-stream)
(declare (ignore color-palette))
(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
(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)
(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[?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))
;; 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
(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))))
(defmethod backend-write ((b modern-backend) string)
(let ((stream (backend-output-stream b)))
(write-string string stream)
(finish-output 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)
(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)))
(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))))
(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 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
(finish-output (backend-output-stream b)))
(defmethod enable-bracketed-paste ((b modern-backend))
(backend-write b (format nil "~C[?2004h" #\Esc)) ; bracketed paste
(finish-output (backend-output-stream b)))
(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)))