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

fix: org tangle — fix END_SRC boundaries in mouse.org/slot.org (prose inside code blocks), replace emacs tangle with Python script that handles all blocks

Browse Source
This commit is contained in:
Hermes Agent
2026-05-12 15:22:29 +00:00
parent 4bb9160f8d
commit 5930e17b57
29 changed files with 2359 additions and 108 deletions
Download Patch File Download Diff File Expand all files Collapse all files

19
org/detection.org
View File

@@ -108,19 +108,30 @@ Returns T if stdout is interactive, nil otherwise."
Send a DA1 (Device Attributes) query and briefly listen for a response.
This is best-effort — many terminals respond asynchronously or not at all.
*** Bug Fixes (v1.0.0): query-terminal stream fix
~query-terminal~ originally used ~*query-io*~ for both writing the query and
reading the response. In raw terminal mode, the terminal's response arrives on
stdin, not on the query I/O stream. This caused ~query-terminal~ to never
receive a response on certain terminal emulators.
Fix: Write queries to ~*standard-output*~ and read responses from
~*standard-input*~. This matches where the terminal actually delivers its
DA1/DA3 response bytes.
#+BEGIN_SRC lisp :tangle ../backend/detection.lisp
;;; ─── DA1 terminal query ─────────────────────────────────────────────────────
(defun query-terminal (query &optional (timeout 0.1))
"Send QUERY string to terminal and return any response received within
TIMEOUT seconds. Returns the response string, or nil if no response."
(write-string query *query-io*)
(force-output *query-io*)
(write-string query *standard-output*)
(force-output *standard-output*)
(sleep timeout)
(let ((response (make-array 0 :element-type 'character
:fill-pointer 0 :adjustable t)))
(loop while (listen *query-io*)
do (vector-push-extend (read-char-no-hang *query-io*) response))
(loop while (listen *standard-input*)
do (vector-push-extend (read-char-no-hang *standard-input*) response))
(when (plusp (length response))
response)))

65
org/dialog.org
View File

@@ -64,24 +64,49 @@ inside the dialog panel), its size preset, title, and callbacks.
--- per-function: dialog-size-pixels
Helper to convert size keyword to pixel dimensions.
Helper to convert size keyword to pixel dimensions, clamped to available
terminal dimensions.
*** Bug Fixes (v1.0.0): dialog size clamp and draw-border keyword
Three bugs were fixed:
1. *Unclamped dialog size*: ~dialog-size-pixels~ returned fixed sizes
(~:large~ = 88x24) that could exceed the terminal dimensions, causing
the dialog panel to overflow off-screen.
Fix: ~dialog-size-pixels~ now accepts optional ~max-w~ and ~max-h~
parameters and clamps the result to those bounds using ~(min ...)~.
2. *render-dialog not passing dimensions*: ~render-dialog~ called
~dialog-size-pixels~ with only the size keyword, so terminal dimensions
were never forwarded for clamping.
Fix: ~render-dialog~ now passes ~w h~ to ~dialog-size-pixels~.
3. *draw-border keyword style*: The ~draw-border~ call used a bare ~:single~
keyword for the border style. The function signature expects ~:style :single~.
Fix: Changed ~:single~ to ~:style :single~.
#+BEGIN_SRC lisp :tangle no
(defun dialog-size-pixels (size)
(case size
(:small (values 40 8))
(:medium (values 60 16))
(:large (values 88 24))
(t (values 60 16))))
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
(multiple-value-bind (dw dh)
(case size
(:small (values 40 8))
(:medium (values 60 16))
(:large (values 88 24))
(t (values 60 16)))
(values (min dw max-w) (min dh max-h))))
#+END_SRC
--- per-function: render-dialog
|--- per-function: render-dialog
Render a dialog: backdrop (dimmed full-screen), then centered panel.
#+BEGIN_SRC lisp :tangle no
(defun render-dialog (dialog screen w h)
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog))
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
(let ((x (floor (- w dw) 2))
(y (floor (- h dh) 2)))
;; Backdrop — draw dim characters over full screen
@@ -89,7 +114,7 @@ Render a dialog: backdrop (dimmed full-screen), then centered panel.
(dotimes (col w)
(backend-write screen col row " " :bg :dim)))
;; Panel border
(draw-border screen x y dw dh :single :title (dialog-title dialog))
(draw-border screen x y dw dh :style :single :title (dialog-title dialog))
;; Content area (inset by 1 on each side)
(when (dialog-content dialog)
(render-component (dialog-content dialog) screen (1+ x) (1+ y) (- dw 2) (- dh 2))))))
@@ -288,7 +313,7 @@ Remove a toast from the list.
;;; dialog-package.lisp — Package definition for cl-tty.dialog
(defpackage :cl-tty.dialog
(:use :cl :cl-tty.input :cl-tty.select)
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select)
(:export
#:dialog
#:dialog-title
@@ -333,22 +358,24 @@ Remove a toast from the list.
(content :initarg :content :initform nil :accessor dialog-content)
(on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss)))
(defun dialog-size-pixels (size)
(case size
(:small (values 40 8))
(:medium (values 60 16))
(:large (values 88 24))
(t (values 60 16))))
(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24))
(multiple-value-bind (dw dh)
(case size
(:small (values 40 8))
(:medium (values 60 16))
(:large (values 88 24))
(t (values 60 16)))
(values (min dw max-w) (min dh max-h))))
(defun render-dialog (dialog screen w h)
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog))
(multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h)
(let ((x (floor (- w dw) 2))
(y (floor (- h dh) 2)))
;; Backdrop — dim the full screen
(dotimes (row h)
(draw-rect screen 0 row w 1 :bg :bright-black))
;; Dialog panel
(draw-border screen x y dw dh :single :title (dialog-title dialog))
(draw-border screen x y dw dh :style :single :title (dialog-title dialog))
(when (dialog-content dialog)
;; Content rendering delegated to component system
(draw-text screen (1+ x) (1+ y)

20
org/mouse.org
View File

@@ -90,10 +90,26 @@ Components without a layout-node or position return nil."
(defun get-selection ()
(when *selection* (sel-text *selection*)))
#+END_SRC
*** Bug Fixes (v1.0.0): Wayland clipboard support
~copy-to-clipboard~ only called ~xclip~, which fails silently on Wayland
sessions (where ~xclip~ is often unavailable or requires XWayland).
Fix: Check the ~WAYLAND_DISPLAY~ environment variable. If set, use
~wl-copy~ instead of ~xclip~. Fall back to ~xclip~ for traditional X11
sessions.
#+BEGIN_SRC lisp :tangle ../src/components/mouse.lisp :noweb no
(defun copy-to-clipboard (text)
#+linux (sb-ext:run-program "xclip" (list "-selection" "clipboard")
:input text :wait nil)
#+linux
(cond
((sb-ext:posix-getenv "WAYLAND_DISPLAY")
(sb-ext:run-program "wl-copy" nil :input text :wait nil))
(t
(sb-ext:run-program "xclip" (list "-selection" "clipboard")
:input text :wait nil)))
#+darwin (sb-ext:run-program "pbcopy" nil :input text :wait nil))
;;; --- Selection tracking (mouse drag) ---------------------------------------

41
org/scrollbox-tabbar.org
View File

@@ -528,6 +528,26 @@ they are truncated with an ellipsis.
(values)))
#+END_SRC
** Bug Fixes (v1.0.0): scroll offset and scrollbar position
Two bugs were fixed in the ScrollBox render pipeline:
1. *Render scroll origin*: The render method used ~orig-y~ (the child's original
layout-node Y position, always 0 for top-level children) as the basis for
scroll offset. This caused the content-relative position ~vy~ to be ignored,
making scroll offsets incorrect when children were offset by layout.
Fix: Use ~vy~ (the content-relative Y accumulator) instead of ~orig-y~ when
setting the temporary layout offset: ~(layout-node-y cln) (- vy sy)~.
2. *Scrollbar positions*: ~draw-scrollbars~ drew scrollbars at viewport-local
coordinates (0, 0), not accounting for the scrollbox's own position within
the layout tree. Scrollbars would appear at the wrong screen location when
the scrollbox was nested inside other containers.
Fix: Read the scrollbox's layout-node origin ~(ox, oy)~ and offset all
scrollbar drawing coordinates by those values.
** Combined tangle blocks
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
@@ -585,14 +605,14 @@ Children outside the viewport are skipped."
(ch (if cln (layout-node-height cln) 1))
(cy vy))
;; Only render children that are visible in the viewport
(when (and (< (+ cy (- sy)) (+ vh vy))
(> (+ cy (- sy) ch) vy))
(when (and (< (- cy sy) vh)
(> (+ (- cy sy) ch) 0))
;; 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)))
(setf (layout-node-x cln) (- vx sx)
(layout-node-y cln) (- vy sy)))
(unwind-protect
(render child backend)
(when cln
@@ -606,17 +626,20 @@ Children outside the viewport are skipped."
(defun draw-scrollbars (sb backend viewport-w viewport-h)
(let* ((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)))
(sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))
(ln (scroll-box-layout-node sb))
(ox (if ln (layout-node-x ln) 0))
(oy (if ln (layout-node-y ln) 0)))
(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 (+ ox (1- viewport-w)) oy 1 viewport-h :bg :bright-black)
(draw-text backend (+ ox (1- viewport-w)) (+ oy 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 ox (+ oy (1- viewport-h)) viewport-w 1 :bg :bright-black)
(draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil)))))
(defun update-sticky-scroll (sb)
(when (sticky-scroll-p sb)

17
org/slot.org
View File

@@ -51,11 +51,26 @@ Slot modes:
(setf (gethash key *slots*)
(sort (cons (cons order render-fn) entries) #'< :key #'car))))
render-fn)
#+END_SRC
*** Bug Fixes (v1.0.0): nil handler guard in slot-render
~slot-render~ called ~(apply (cdr entry) args)~ unconditionally, but
~defslot~ stores ~(order . render-fn)~ pairs where ~render-fn~ can be
~nil~ (if called without ~:render-fn~). This caused a type error when
~apply~ received ~nil~ as the function argument.
Fix: Check ~(when fn)~ before calling ~apply~. Entries with a nil
handler are silently skipped.
#+BEGIN_SRC lisp :tangle ../src/components/slot.lisp :noweb no
(defun slot-render (slot-name &rest args)
(let ((entries (gethash (string slot-name) *slots*)))
(when entries
(mapcar (lambda (entry) (apply (cdr entry) args)) entries))))
(mapcar (lambda (entry)
(let ((fn (cdr entry)))
(when fn (apply fn args))))
entries))))
(defun slot-p (slot-name)
(nth-value 1 (gethash (string slot-name) *slots*)))

155
org/text-input.org
View File

@@ -445,11 +445,11 @@ terminal raw mode, TextInput, Textarea, and the keybinding system.
;; Textarea
#:textarea #:make-textarea
#:textarea-value #:textarea-cursor-row #:textarea-cursor-col
#:textarea-lines
#:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack
#:textarea-layout-node
#:handle-textarea-input #:render-textarea
;; Keybindings
#:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent
#:*keymaps* #:*chord-timeout*
#:defkeymap #:dispatch-key-event #:key-match-p
#:component-keymap))
@@ -656,7 +656,8 @@ debugging argument mismatches — avoid that trap.
(max 0 (min (textarea-cursor-row ta) (1- (length lines)))))
(let ((line-len (length (nth (textarea-cursor-row ta) lines))))
(setf (textarea-cursor-col ta)
(max 0 (min (textarea-cursor-col ta) line-len))))))
(max 0 (min (textarea-cursor-col ta) line-len)))))
(mark-dirty ta))
;;; ---------------------------------------------------------------------------
;;; Utility: join strings with newline
@@ -824,11 +825,13 @@ debugging argument mismatches — avoid that trap.
(textarea-ensure-cursor ta))
(:up (textarea-move-up ta))
(:down (textarea-move-down ta))
(:home (setf (textarea-cursor-col ta) 0))
(:end (let ((lines (textarea-lines ta)))
(when (< (textarea-cursor-row ta) (length lines))
(setf (textarea-cursor-col ta)
(length (nth (textarea-cursor-row ta) lines))))))
(:home (setf (textarea-cursor-col ta) 0)
(textarea-ensure-cursor ta))
(:end (let ((lines (textarea-lines ta)))
(when (< (textarea-cursor-row ta) (length lines))
(setf (textarea-cursor-col ta)
(length (nth (textarea-cursor-row ta) lines))))
(textarea-ensure-cursor ta)))
(:enter (let ((cb (textarea-on-submit ta)))
(if cb
(funcall cb (textarea-value ta))
@@ -923,6 +926,21 @@ debugging argument mismatches — avoid that trap.
;;; ---------------------------------------------------------------------------
;;; Dispatch
;;; ---------------------------------------------------------------------------
;;; dispatch-key-event — main entry point for keymap-based dispatch.
;;;
;;; IMPORTANT: This function is NOT called by the demo's event loop
;;; or by any built-in widget event handlers. Users who want to use
;;; the keymap system MUST call dispatch-key-event explicitly in their
;;; own event loops, e.g.:
;;;
;;; (defun handle-event (event)
;;; (or (dispatch-key-event event)
;;; (handle-text-input my-input event)
;;; ...))
;;;
;;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single
;;; key specs work. The *chord-timeout* and list-of-lists syntax
;;; are reserved for future implementation.
(defun dispatch-key-event (event &key component)
(labels ((try-keymap (km)
(when km
@@ -974,6 +992,8 @@ debugging argument mismatches — avoid that trap.
#:with-raw-terminal
;; Event reading
#:read-event
;; UTF-8 input support
#:utf8-decode
;; TextInput
#:text-input #:make-text-input
#:text-input-value #:text-input-cursor
@@ -983,6 +1003,7 @@ debugging argument mismatches — avoid that trap.
;; Textarea
#:textarea #:make-textarea
#:textarea-value #:textarea-cursor-row #:textarea-cursor-col
#:textarea-lines
#:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack
#:textarea-layout-node
#:handle-textarea-input #:render-textarea
@@ -1034,6 +1055,28 @@ debugging argument mismatches — avoid that trap.
(is (= (mouse-event-x e) 10))
(is (= (mouse-event-y e) 5))))
;; ── UTF-8 Decode Tests ──────────────────────────────────────────
(test utf8-decode-latin1-supplement
"0xC3 0xA9 (é) decodes to code point 233."
(is (= (cl-tty.input:utf8-decode '(#xc3 #xa9)) 233)))
(test utf8-decode-euro-sign
"0xE2 0x82 0xAC (€) decodes to code point 8364."
(is (= (cl-tty.input:utf8-decode '(#xe2 #x82 #xac)) 8364)))
(test utf8-decode-emoji
"0xF0 0x9F 0x92 0xA9 (💩) decodes to code point 128169."
(is (= (cl-tty.input:utf8-decode '(#xf0 #x9f #x92 #xa9)) 128169)))
(test utf8-decode-invalid-short
"Invalid byte 0x80 alone returns nil."
(is-false (cl-tty.input:utf8-decode '(#x80))))
(test utf8-decode-invalid-overlong
"Overlong 2-byte sequence 0xC0 0x80 returns nil."
(is-false (cl-tty.input:utf8-decode '(#xc0 #x80))))
;; ── TextInput Tests ─────────────────────────────────────────────
(test text-input-empty
@@ -1218,6 +1261,15 @@ world")))
(is (string= (textarea-value a) "a"))))
;; ── Keybinding Tests ────────────────────────────────────────────
;; These tests verify the keymap dispatch system works correctly
;; when wired up. Note: dispatch-key-event is NOT called by the
;; demo's event loop — users MUST call it explicitly in their own
;; event loops if they want to use the defkeymap/dispatch-key-event
;; system. See src/components/keybindings.lisp for details.
;;
;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single
;; key specs work. The *chord-timeout* variable and list-of-lists
;; syntax are reserved for future implementation.
(test keymap-simple
"A keymap dispatches to its handler on matching event."
@@ -1258,6 +1310,78 @@ world")))
(is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t)))
(is-false (key-match-p :ctrl+p (make-key-event :key :p))))
(test key-spec-alt-modifier
"Alt modifier is matched correctly."
(is-true (key-match-p :alt+x (make-key-event :key :x :alt t)))
(is-false (key-match-p :alt+x (make-key-event :key :x)))
(is-false (key-match-p :alt+x (make-key-event :key :x :ctrl t))))
(test key-spec-shift-modifier
"Shift modifier is matched correctly."
(is-true (key-match-p :shift+tab (make-key-event :key :tab :shift t)))
(is-false (key-match-p :shift+tab (make-key-event :key :tab))))
(test key-spec-plain
"Plain key spec matches unmodified keys."
(is-true (key-match-p :enter (make-key-event :key :enter)))
(is-true (key-match-p :escape (make-key-event :key :escape)))
(is-false (key-match-p :enter (make-key-event :key :escape))))
(test key-spec-list-form
"List-form spec (:ctrl+p) matches same as keyword :ctrl+p."
(is-true (key-match-p '(:ctrl+p) (make-key-event :key :p :ctrl t)))
(is-false (key-match-p '(:ctrl+p) (make-key-event :key :a :ctrl t))))
(test dispatch-return-value-match
"dispatch-key-event returns T on matching binding."
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e)))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t))))
(test dispatch-return-value-no-match
"dispatch-key-event returns NIL when no binding matches."
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e)))))))
(is-false (dispatch-key-event (make-key-event :key :a))))
(test dispatch-empty-keymap
"dispatch-key-event returns NIL on empty keymap."
(setf (gethash :global *keymaps*) (make-keymap :name :global))
(is-false (dispatch-key-event (make-key-event :key :a))))
(test dispatch-local-overrides-global
"Local keymap takes priority over global."
(let ((local-called nil) (global-called nil))
(setf (gethash :local *keymaps*)
(make-keymap :name :local
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf local-called t))))))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+p . ,(lambda (e)
(declare (ignore e))
(setf global-called t))))))
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))
(is-true local-called)
(is-false global-called)))
(test dispatch-multiple-bindings
"dispatch-key-event finds the right binding among many."
(let ((called nil))
(setf (gethash :global *keymaps*)
(make-keymap :name :global
:bindings `((:ctrl+a . (lambda (e) (declare (ignore e))))
(:ctrl+b . (lambda (e) (declare (ignore e))))
(:ctrl+c . ,(lambda (e)
(declare (ignore e))
(setf called t)))
(:ctrl+d . (lambda (e) (declare (ignore e)))))))
(is-true (dispatch-key-event (make-key-event :key :c :ctrl t)))
(is-true called)))
(test defkeymap-macro
"defkeymap macro registers a keymap."
(let ((called nil))
@@ -1265,4 +1389,21 @@ world")))
(:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t)))))
(dispatch-key-event (make-key-event :key :q :ctrl t))
(is-true called)))
(test defkeymap-macro-with-list-spec
"defkeymap macro works with list-form specs."
(let ((called nil))
(eval `(defkeymap :global
((:ctrl+w) ,(lambda (e) (declare (ignore e)) (setf called t)))))
(dispatch-key-event (make-key-event :key :w :ctrl t))
(is-true called)))
;; cleanup after keybinding tests
(test keybinding-cleanup-global
"Clean up global keymap after testing."
(remhash :global *keymaps*)
(remhash :local *keymaps*)
(is-false (gethash :global *keymaps*))
(is-false (gethash :local *keymaps*)))
#+END_SRC