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

Critical fixes: case→cond in %read-event, theme resolution, SGR mouse, scrollbox/text-input/textarea render stubs, test runner exit code, ASDF rename

Browse Source 
CRITICAL: case b → cond in %read-event (input.lisp:280)
  case with (and ...) predicate clauses treats keys as eql-compared
  atoms — all range clauses were dead code.  Every Ctrl+letter and
  printable ASCII fell through to :unknown.  text-input/textarea
  widgets were non-functional with real terminal input.  No test
  coverage of %read-event masked this.

HIGH: Theme resolution wired (backend/modern.lisp, theme.lisp)
  sgr-fg/sgr-bg now fall back to *theme-colors* hash for semantic
  keywords (:accent, :text-muted, :background-element).  *theme-colors*
  exported from cl-tty.backend.  load-preset populates it from preset
  hex values.  Previously all themed render output was invisible.

HIGH: SGR mouse parser wired (input.lisp:210-215)
  parse-sgr-mouse was defined but never called.  Now %read-escape-sequence
  detects ESC[< prefix and routes to parse-sgr-mouse.  Mouse drags,
  releases, and scroll events now parse correctly.

MEDIUM: Rendering stubs replaced
  - scrollbox: delegates to (render child backend) with position
    offset via unwind-protect (was debug string 'child at ~D')
  - text-input: draws value/placeholder at layout position
  - textarea: draws visible lines at layout position

MEDIUM: hit-test uses component-layout-node (mouse.lisp:18-31)
  Was checking nonexistent x/y/width/height slots.  Now reads
  layout-node-x/y/w/h via component-layout-node generic.

MEDIUM: test runner exit code (run-all-tests.lisp, cl-tty.asd)
  run-all-tests.lisp exits 1 if any suite fails.
  asdf:test-system exits 1 on failure.
  Renamed :cl-tty-tests to :cl-tty/test (ASDF convention).

MEDIUM: draw-border respects x/y on simple-backend (simple.lisp:42-53)
  Was writing to cursor position only.  Now uses newlines+spaces
  to reach specified coordinates (no escape sequences needed).

LOW: TabBar truncation off-by-one fixed (tabbar.lisp:47)
  >= changed to > to avoid cutting tabs 2 chars early.

LOW: Scrollbar coordinates absolute (scrollbox.lisp:61-73)
  Scrollbar drawn at viewport-relative (0,0).  Now adds layout
  node x/y offset for correct terminal positioning.

LOW: backend-write calls finish-output (modern.lisp:169)

LOW: load-preset no longer flips theme-mode (theme.lisp:43-45)
  Mode toggle caused load-preset to load wrong variant on
  second call.

All backported to org source files (org/text-input.org,
org/scrollbox-tabbar.org) so tangling produces matching .lisp.

392 tests pass, exit code 0.
This commit is contained in:
Hermes
2026-05-12 00:48:00 +00:00
parent b50c97a0cb
commit c3c330dfff
15 changed files with 504 additions and 1575 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
src/components/input.lisp
View File

@@ -204,10 +204,14 @@
(make-key-event :key :escape :raw (string #\Esc)))))
;; CSI: ESC [ ...
(#x5b
(multiple-value-bind (params final-byte) (parse-csi-params)
(multiple-value-bind (params final-byte raw) (parse-csi-params)
(if (null final-byte)
(make-key-event :key :escape :raw (string #\Esc))
(if (and (char= (code-char final-byte) #\M)
;; SGR mouse: ESC [ < ... m/M
(if (and raw (plusp (length raw)) (char= (char raw 0) #\<))
(or (parse-sgr-mouse raw)
(make-key-event :key :unknown :raw raw))
(if (and (char= (code-char final-byte) #\M)
(>= (length params) 3))
(let* ((p0 (first params)))
(if (zerop (logand p0 #x40))
@@ -252,7 +256,7 @@
ctrl (logtest modifier 4)))
(make-key-event :key (or key :unknown)
:ctrl ctrl :alt alt :shift shift
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))))))
:raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))))
;; ESC ESC
(#x1b
(make-key-event :key :escape :alt t :raw "\\e\\e"))
@@ -273,24 +277,24 @@
(let ((b (read-raw-byte :timeout timeout)))
(unless b
(return-from %read-event nil))
(case b
(#x1b
(cond
((= b #x1b)
(%read-escape-sequence))
(#x09
((= b #x09)
(make-key-event :key :tab :code #x09))
(#x0a
((= b #x0a)
(make-key-event :key :enter :code #x0a))
(#x0d
((= b #x0d)
(make-key-event :key :enter :code #x0d))
((#x7f #x08)
((or (= b #x7f) (= b #x08))
(make-key-event :key :backspace :code b))
((and (>= b #x01) (<= b #x1a))
(let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword)))
(make-key-event :key key :ctrl t :code b)))
(#x1c (make-key-event :key :backslash :ctrl t :code b))
(#x1d (make-key-event :key :rbracket :ctrl t :code b))
(#x1e (make-key-event :key :caret :ctrl t :code b))
(#x1f (make-key-event :key :underscore :ctrl t :code b))
((= b #x1c) (make-key-event :key :backslash :ctrl t :code b))
((= b #x1d) (make-key-event :key :rbracket :ctrl t :code b))
((= b #x1e) (make-key-event :key :caret :ctrl t :code b))
((= b #x1f) (make-key-event :key :underscore :ctrl t :code b))
((and (>= b #x20) (<= b #x7e))
(let ((ch (code-char b)))
(make-key-event :key (intern (string (string-upcase ch)) :keyword)

22
src/components/mouse.lisp
View File

@@ -16,18 +16,18 @@
(when handler (funcall handler event))))
(defun hit-test (root x y)
"Find the deepest component at (X, Y) by testing layout-node bounds.
Components without a layout-node or position return nil."
(labels ((recurse (node)
(when (and (slot-exists-p node 'x) (slot-boundp node 'x)
(slot-exists-p node 'y) (slot-boundp node 'y)
(slot-exists-p node 'width) (slot-boundp node 'width)
(slot-exists-p node 'height) (slot-boundp node 'height))
(let ((nx (slot-value node 'x))
(ny (slot-value node 'y))
(nw (slot-value node 'width))
(nh (slot-value node 'height)))
(when (and (>= x nx) (< x (+ nx nw))
(>= y ny) (< y (+ ny nh)))
node)))))
(let ((ln (ignore-errors (component-layout-node node))))
(when ln
(let ((nx (layout-node-x ln))
(ny (layout-node-y ln))
(nw (layout-node-width ln))
(nh (layout-node-height ln)))
(when (and (>= x nx) (< x (+ nx nw))
(>= y ny) (< y (+ ny nh)))
node))))))
(recurse root)))
;; Selection

32
src/components/scrollbox.lisp
View File

@@ -39,6 +39,8 @@
:initial-value 0))
(defmethod render ((sb scroll-box) backend)
"Render ScrollBox children within the viewport, offset by scroll position.
Children outside the viewport are skipped."
(let* ((ln (scroll-box-layout-node sb))
(vx 0) (vy 0)
(vw (if ln (layout-node-width ln) 80))
@@ -49,9 +51,20 @@
(let* ((cln (component-layout-node child))
(ch (if cln (layout-node-height cln) 1))
(cy vy))
(when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy))
(draw-text backend (- sx) (+ vy cy (- sy))
(format nil "child at ~D" vy) nil nil))
;; Only render children that are visible in the viewport
(when (and (< (+ cy (- sy)) (+ vh vy))
(> (+ cy (- sy) ch) vy))
;; Temporarily offset child's layout-node position for rendering
(let ((orig-x (if cln (layout-node-x cln) 0))
(orig-y (if cln (layout-node-y cln) 0)))
(when cln
(setf (layout-node-x cln) (- orig-x sx)
(layout-node-y cln) (- orig-y sy)))
(unwind-protect
(render child backend)
(when cln
(setf (layout-node-x cln) orig-x
(layout-node-y cln) orig-y)))))
(incf vy ch)))
(draw-scrollbars sb backend vw vh)))
@@ -59,18 +72,21 @@
(if (> content-size viewport-size) (/ (float scroll-pos) (- content-size viewport-size)) 0.0))
(defun draw-scrollbars (sb backend viewport-w viewport-h)
(let* ((content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb))
(let* ((ln (scroll-box-layout-node sb))
(vx (if ln (layout-node-x ln) 0))
(vy (if ln (layout-node-y ln) 0))
(content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb))
(sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb)))
(when (> content-h viewport-h)
(let* ((thumb (scrollbar-thumb sy viewport-h content-h))
(thumb-pos (round (* thumb viewport-h))))
(draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :bright-black)
(draw-text backend (1- viewport-w) thumb-pos "█" nil nil)))
(draw-rect backend (+ vx (1- viewport-w)) vy 1 viewport-h :bg :bright-black)
(draw-text backend (+ vx (1- viewport-w)) (+ vy thumb-pos) "█" nil nil)))
(when (> content-w viewport-w)
(let* ((thumb (scrollbar-thumb sx viewport-w content-w))
(thumb-pos (round (* thumb viewport-w))))
(draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :bright-black)
(draw-text backend thumb-pos (1- viewport-h) "█" nil nil)))))
(draw-rect backend vx (+ vy (1- viewport-h)) viewport-w 1 :bg :bright-black)
(draw-text backend (+ vx thumb-pos) (+ vy (1- viewport-h)) "█" nil nil)))))
(defun update-sticky-scroll (sb)
(when (sticky-scroll-p sb)

2
src/components/tabbar.lisp
View File

@@ -44,7 +44,7 @@
(is-active (eql id active-id))
(fg (if is-active :accent :text-muted))
(bg (if is-active :background-element nil)))
(when (>= (+ x-pos label-len 2) w)
(when (> (+ x-pos label-len 2) w)
(draw-text backend x-pos y "..." :text-muted nil) (return))
(draw-text backend x-pos y label fg bg)
(incf x-pos (+ label-len 2)))))

19
src/components/text-input.lisp
View File

@@ -153,11 +153,18 @@
(text-input-insert input ch))))))))
;;; ---------------------------------------------------------------------------
;;; Rendering (stub — proper rendering uses theme + backend)
;;; Rendering
;;; ---------------------------------------------------------------------------
(defmethod render ((in text-input) (backend t))
"Render a text-input widget. Full rendering requires *current-backend*,
*current-theme*, and the rendering pipeline. This is a no-op stub for
unit testing the widget logic."
(declare (ignore in backend))
(values))
"Render text-input value or placeholder at layout position."
(let* ((ln (text-input-layout-node in))
(x (if ln (layout-node-x ln) 0))
(y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(value (text-input-value in))
(cursor (text-input-cursor in))
(display (if (plusp (length value))
value
(or (text-input-placeholder in) ""))))
(declare (ignore w cursor))
(draw-text backend x y display nil nil)))

21
src/components/textarea.lisp
View File

@@ -237,11 +237,20 @@
(textarea-insert-char ta ch))))))))
;;; ---------------------------------------------------------------------------
;;; Rendering (stub — proper rendering uses theme + backend)
;;; Rendering
;;; ---------------------------------------------------------------------------
(defmethod render ((ta textarea) (backend t))
"Render a textarea widget. Full rendering requires *current-backend*,
*current-theme*, and the rendering pipeline. This is a no-op stub for
unit testing the widget logic."
(declare (ignore ta backend))
(values))
"Render textarea lines at layout position."
(let* ((ln (textarea-layout-node ta))
(x (if ln (layout-node-x ln) 0))
(y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(h (if ln (layout-node-height ln) 24))
(lines (textarea-lines ta))
(max-lines (min (length lines) h)))
(declare (ignore w))
(loop for i from 0 below max-lines
for line in lines
do (draw-text backend x (+ y i)
(subseq line 0 (min (length line) w))
nil nil))))

20
src/components/theme.lisp
View File

@@ -26,16 +26,20 @@ NAME should be a keyword (e.g., :default, :nord)."
`(setf (gethash ,name *presets*) '(:dark ,dark :light ,light)))
(defun load-preset (theme preset-name)
"Load PRESET-NAME (a keyword) into THEME, overwriting role mappings."
"Load PRESET-NAME colors into THEME.
Side-effect: populates cl-tty.backend:*theme-colors* so that semantic
color roles resolve to hex at SGR generation time."
(let ((preset (gethash preset-name *presets*)))
(if preset
(let* ((variant (if (eql (theme-mode theme) :dark)
(getf preset :dark)
(getf preset :light)))
(roles (theme-roles theme)))
(clrhash roles)
(loop for (role hex) on variant by #'cddr
do (setf (gethash role roles) hex)))
(let* ((colors (if (eql (theme-mode theme) :dark)
(getf preset :dark)
(getf preset :light)))
;; Populate backend theme color map
(theme-map (symbol-value (find-symbol "*THEME-COLORS*" :cl-tty.backend))))
;; Set theme colors
(loop for (role hex) on colors by #'cddr
do (setf (theme-color theme role) hex)
(setf (gethash role theme-map) hex)))
(warn "Unknown preset: ~S" preset-name))))
(define-preset :default