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
This commit is contained in:
Hermes Agent
@@ -60,3 +60,66 @@ Result is cached in *detected-backend* for subsequent calls."
|
||||
(detect-backend-by-da1)))
|
||||
(make-modern-backend)
|
||||
(make-simple-backend)))))
|
||||
|
||||
(in-package :cl-tty.backend)
|
||||
|
||||
;;; ─── Detection cache ────────────────────────────────────────────────────────
|
||||
|
||||
(defvar *detected-backend* nil
|
||||
"Cached backend instance from detect-backend. Nil = not yet detected.")
|
||||
|
||||
;;; ─── Environment probe ──────────────────────────────────────────────────────
|
||||
|
||||
(defun detect-backend-by-env ()
|
||||
"Check COLORTERM environment variable for modern terminal support.
|
||||
Returns :modern if COLORTERM contains 'truecolor' or '24bit', nil otherwise."
|
||||
(let ((colorterm (sb-ext:posix-getenv "COLORTERM")))
|
||||
(when (and colorterm
|
||||
(or (search "truecolor" colorterm :test #'char-equal)
|
||||
(search "24bit" colorterm :test #'char-equal)))
|
||||
:modern)))
|
||||
|
||||
;;; ─── TTY probe ──────────────────────────────────────────────────────────────
|
||||
|
||||
(defun detect-backend-by-tty ()
|
||||
"Check if stdout is a real terminal (not a pipe/redirect).
|
||||
Returns T if stdout is interactive, nil otherwise."
|
||||
(interactive-stream-p *standard-output*))
|
||||
|
||||
;;; ─── 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 *standard-output*)
|
||||
(force-output *standard-output*)
|
||||
(sleep timeout)
|
||||
(let ((response (make-array 0 :element-type 'character
|
||||
:fill-pointer 0 :adjustable t)))
|
||||
(loop while (listen *standard-input*)
|
||||
do (vector-push-extend (read-char-no-hang *standard-input*) response))
|
||||
(when (plusp (length response))
|
||||
response)))
|
||||
|
||||
(defun detect-backend-by-da1 ()
|
||||
"Send DA1 (ESC[c) query and check for kitty terminal response code.
|
||||
Returns T if terminal reports kitty compatibility codes."
|
||||
(let ((response (query-terminal (format nil "~C[c" #\Esc))))
|
||||
(when response
|
||||
;; DA1 response format: ESC [ ? digits ; digits c
|
||||
;; Kitty reports code 62 in the response
|
||||
(search "?62" response))))
|
||||
|
||||
;;; ─── Orchestrator ───────────────────────────────────────────────────────────
|
||||
|
||||
(defun detect-backend ()
|
||||
"Auto-detect the appropriate backend for the current terminal.
|
||||
Returns a backend instance (modern-backend or simple-backend).
|
||||
Result is cached in *detected-backend* for subsequent calls."
|
||||
(or *detected-backend*
|
||||
(setf *detected-backend*
|
||||
(if (and (detect-backend-by-tty)
|
||||
(or (eql (detect-backend-by-env) :modern)
|
||||
(detect-backend-by-da1)))
|
||||
(make-modern-backend)
|
||||
(make-simple-backend)))))
|
||||
|
||||
@@ -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)))
|
||||
|
||||
|
||||
@@ -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)
|
||||
(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))))
|
||||
(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)
|
||||
(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))))
|
||||
(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)
|
||||
|
||||
@@ -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) ---------------------------------------
|
||||
|
||||
@@ -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
17
org/slot.org
@@ -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*)))
|
||||
|
||||
@@ -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))
|
||||
(: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))))))
|
||||
(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
|
||||
@@ -1,74 +1,62 @@
|
||||
#!/usr/bin/env python3
|
||||
"""tangle.py — Extract code blocks from .org files into .lisp files.
|
||||
|
||||
Reads all .org files in org/ directory, finds #+BEGIN_SRC lisp :tangle <path>
|
||||
blocks, and writes/concatenates them to the specified target paths.
|
||||
|
||||
Blocks with the same :tangle target are concatenated in file order.
|
||||
|
||||
Usage:
|
||||
python3 scripts/tangle.py # tangle all org/ files
|
||||
python3 scripts/tangle.py org/specific.org # tangle one file
|
||||
|
||||
Target paths are relative to the project root (../target from org/ = project/target).
|
||||
"""Simple org-babel tangle replacement.
|
||||
Extracts #+BEGIN_SRC blocks with :tangle headers and writes target files.
|
||||
"""
|
||||
import re
|
||||
import os
|
||||
import sys
|
||||
from collections import OrderedDict
|
||||
import re, os, sys
|
||||
|
||||
PROJECT_ROOT = os.path.dirname(os.path.dirname(os.path.abspath(__file__)))
|
||||
ORG_DIR = os.path.join(PROJECT_ROOT, 'org')
|
||||
ORG_DIR = os.path.dirname(os.path.dirname(os.path.abspath(__file__)))
|
||||
|
||||
def tangle_file(org_path):
|
||||
"""Extract tangle blocks from one .org file."""
|
||||
org_path = os.path.join(ORG_DIR, org_path)
|
||||
with open(org_path) as f:
|
||||
content = f.read()
|
||||
text = f.read()
|
||||
|
||||
# Find all tangle blocks with their targets
|
||||
pattern = r'#\+BEGIN_SRC lisp :tangle ([^\n]+)\n(.*?)\n#\+END_SRC'
|
||||
blocks = re.findall(pattern, content, re.DOTALL)
|
||||
# Find all #+BEGIN_SRC blocks with :tangle
|
||||
pattern = re.compile(
|
||||
r'#\+BEGIN_SRC\s+(\w+)\s+(.*?)\n(.*?)\n#\+END_SRC',
|
||||
re.DOTALL
|
||||
)
|
||||
|
||||
if not blocks:
|
||||
return 0
|
||||
count = 0
|
||||
for match in pattern.finditer(text):
|
||||
lang = match.group(1)
|
||||
header = match.group(2)
|
||||
content = match.group(3)
|
||||
|
||||
# Group by target path
|
||||
targets = OrderedDict()
|
||||
for tangle_path, code in blocks:
|
||||
# Resolve tangle path: ../src/x.lisp -> src/x.lisp
|
||||
resolved = tangle_path.replace('../', '')
|
||||
full_path = os.path.join(PROJECT_ROOT, resolved)
|
||||
if full_path not in targets:
|
||||
targets[full_path] = []
|
||||
targets[full_path].append(code.strip())
|
||||
# Extract :tangle path
|
||||
tangle_match = re.search(r':tangle\s+(\S+)', header)
|
||||
if not tangle_match:
|
||||
continue
|
||||
tangle_path = tangle_match.group(1)
|
||||
|
||||
for full_path, codes in targets.items():
|
||||
os.makedirs(os.path.dirname(full_path), exist_ok=True)
|
||||
combined = '\n\n'.join(codes) + '\n'
|
||||
with open(full_path, 'w') as f:
|
||||
f.write(combined)
|
||||
print(f" {os.path.relpath(full_path, PROJECT_ROOT)} ({len(codes)} blocks, {sum(len(c) for c in codes)} chars)")
|
||||
|
||||
return len(blocks)
|
||||
|
||||
def main():
|
||||
if len(sys.argv) > 1:
|
||||
org_files = [f for f in sys.argv[1:] if f.endswith('.org')]
|
||||
# Resolve relative path
|
||||
if tangle_path.startswith('../'):
|
||||
target = os.path.normpath(os.path.join(os.path.dirname(org_path), tangle_path))
|
||||
else:
|
||||
org_files = [os.path.join(ORG_DIR, f) for f in os.listdir(ORG_DIR) if f.endswith('.org')]
|
||||
target = os.path.join(ORG_DIR, tangle_path)
|
||||
|
||||
total_blocks = 0
|
||||
for org_file in sorted(org_files):
|
||||
name = os.path.basename(org_file)
|
||||
blocks = tangle_file(org_file)
|
||||
if blocks:
|
||||
print(f"{name}: {blocks} blocks")
|
||||
total_blocks += blocks
|
||||
# Ensure directory exists
|
||||
os.makedirs(os.path.dirname(target), exist_ok=True)
|
||||
|
||||
if total_blocks > 0:
|
||||
print(f"\nTotal: {total_blocks} code blocks tangled")
|
||||
# Don't write :tangle no blocks
|
||||
if tangle_path == 'no':
|
||||
continue
|
||||
|
||||
# Write the content (append if same file already written)
|
||||
content = content.rstrip('\n') + '\n'
|
||||
if os.path.exists(target):
|
||||
with open(target, 'a') as f:
|
||||
f.write('\n' + content)
|
||||
else:
|
||||
print("No tangle blocks found.")
|
||||
with open(target, 'w') as f:
|
||||
f.write(content)
|
||||
print(f" {target} ({len(content)} bytes)")
|
||||
count += 1
|
||||
|
||||
return count
|
||||
|
||||
if __name__ == '__main__':
|
||||
main()
|
||||
for f in sys.argv[1:] or ['org/text-input.org']:
|
||||
print(f"Tangling {f}...")
|
||||
c = tangle_file(f)
|
||||
print(f" {c} code blocks")
|
||||
|
||||
@@ -10,3 +10,16 @@
|
||||
#:tab-bar-active #:tab-bar-tabs
|
||||
#:tab-bar-add #:tab-bar-next #:tab-bar-prev
|
||||
#:tab-bar-select #:tab-bar-handle-key))
|
||||
|
||||
(defpackage :cl-tty.container
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
#:scroll-box #:make-scroll-box
|
||||
#:scroll-box-scroll-y #:scroll-box-scroll-x
|
||||
#:scroll-box-children #:scroll-by
|
||||
#:sticky-scroll-p
|
||||
#:clamp-scroll
|
||||
#:tab-bar #:make-tab-bar
|
||||
#:tab-bar-active #:tab-bar-tabs
|
||||
#:tab-bar-add #:tab-bar-next #:tab-bar-prev
|
||||
#:tab-bar-select #:tab-bar-handle-key))
|
||||
|
||||
@@ -23,3 +23,29 @@
|
||||
#:render-toast
|
||||
#:dismiss-toast
|
||||
#:*toasts*))
|
||||
|
||||
;;; dialog-package.lisp — Package definition for cl-tty.dialog
|
||||
|
||||
(defpackage :cl-tty.dialog
|
||||
(:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select)
|
||||
(:export
|
||||
#:dialog
|
||||
#:dialog-title
|
||||
#:dialog-content
|
||||
#:dialog-on-dismiss
|
||||
#:dialog-size
|
||||
#:dialog-size-pixels
|
||||
#:render-dialog
|
||||
#:push-dialog
|
||||
#:pop-dialog
|
||||
#:*dialog-stack*
|
||||
#:alert-dialog
|
||||
#:confirm-dialog
|
||||
#:select-dialog
|
||||
#:prompt-dialog
|
||||
#:toast
|
||||
#:toast-message
|
||||
#:toast-variant
|
||||
#:render-toast
|
||||
#:dismiss-toast
|
||||
#:*toasts*))
|
||||
|
||||
@@ -124,3 +124,130 @@
|
||||
|
||||
(defun dismiss-toast (toast)
|
||||
(setf *toasts* (remove toast *toasts*)))
|
||||
|
||||
;;; dialog.lisp — Dialog System + Toast for cl-tty
|
||||
|
||||
(in-package :cl-tty.dialog)
|
||||
|
||||
;; ─── Special variables ────────────────────────────────────────────────────────
|
||||
|
||||
(defvar *dialog-stack* nil
|
||||
"Stack of active dialogs. (list) of dialog instances.")
|
||||
|
||||
(defvar *toasts* nil
|
||||
"List of active toast notifications.")
|
||||
|
||||
;; ─── Dialog class ─────────────────────────────────────────────────────────────
|
||||
|
||||
(defclass dialog ()
|
||||
((title :initarg :title :accessor dialog-title)
|
||||
(size :initarg :size :initform :medium :accessor dialog-size)
|
||||
(content :initarg :content :initform nil :accessor dialog-content)
|
||||
(on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss)))
|
||||
|
||||
(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) 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 :style :single :title (dialog-title dialog))
|
||||
(when (dialog-content dialog)
|
||||
;; Content rendering delegated to component system
|
||||
(draw-text screen (1+ x) (1+ y)
|
||||
(format nil "~a" (dialog-content dialog))
|
||||
:white :default)))))
|
||||
|
||||
(defun push-dialog (dialog)
|
||||
(push dialog *dialog-stack*)
|
||||
dialog)
|
||||
|
||||
(defun pop-dialog ()
|
||||
(when *dialog-stack*
|
||||
(let ((dialog (pop *dialog-stack*)))
|
||||
(when (dialog-on-dismiss dialog)
|
||||
(funcall (dialog-on-dismiss dialog)))
|
||||
dialog)))
|
||||
|
||||
;; ─── Dialog sub-classes ──────────────────────────────────────────────────────
|
||||
|
||||
(defun alert-dialog (title message)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'select
|
||||
:options (list (list :title "OK" :value :ok))
|
||||
:on-select (lambda (opt) (declare (ignore opt)) (pop-dialog)))
|
||||
:on-dismiss (lambda () (pop-dialog))))
|
||||
|
||||
(defun confirm-dialog (title message &key on-yes on-no)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'select
|
||||
:options (list (list :title "Yes" :value :yes)
|
||||
(list :title "No" :value :no))
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(if (eql opt :yes)
|
||||
(when on-yes (funcall on-yes))
|
||||
(when on-no (funcall on-no)))))))
|
||||
|
||||
(defun select-dialog (title options &key on-select)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :medium
|
||||
:content (make-instance 'select
|
||||
:options options
|
||||
:on-select (lambda (opt)
|
||||
(pop-dialog)
|
||||
(when on-select (funcall on-select opt))))))
|
||||
|
||||
(defun prompt-dialog (title &key on-submit)
|
||||
(make-instance 'dialog
|
||||
:title title
|
||||
:size :small
|
||||
:content (make-instance 'text-input
|
||||
:on-submit (lambda (value)
|
||||
(pop-dialog)
|
||||
(when on-submit (funcall on-submit value))))))
|
||||
|
||||
;; ─── Toast system ─────────────────────────────────────────────────────────────
|
||||
|
||||
(defclass toast ()
|
||||
((message :initarg :message :accessor toast-message)
|
||||
(variant :initarg :variant :initform :info :accessor toast-variant)))
|
||||
|
||||
(defun render-toast (toast screen w)
|
||||
(let* ((msg (toast-message toast))
|
||||
(variant (toast-variant toast))
|
||||
(color (case variant
|
||||
(:info :blue) (:success :green)
|
||||
(:warning :yellow) (:error :red)))
|
||||
(max-w (min 60 (1- w)))
|
||||
(x (- w max-w 1))
|
||||
(text (if (> (length msg) (- max-w 2))
|
||||
(concatenate 'string (subseq msg 0 (- max-w 5)) "...")
|
||||
msg)))
|
||||
(draw-rect screen x 0 max-w 1 :bg color)
|
||||
(draw-text screen (1+ x) 0 text :white color :bold t)))
|
||||
|
||||
(defun toast (message &key (variant :info) (duration 0))
|
||||
(let ((toast (make-instance 'toast :message message :variant variant)))
|
||||
(push toast *toasts*)
|
||||
(when (plusp duration) (dismiss-toast toast))
|
||||
toast))
|
||||
|
||||
(defun dismiss-toast (toast)
|
||||
(setf *toasts* (remove toast *toasts*)))
|
||||
|
||||
@@ -36,3 +36,41 @@
|
||||
#:*keymaps* #:*chord-timeout*
|
||||
#:defkeymap #:dispatch-key-event #:key-match-p
|
||||
#:component-keymap))
|
||||
|
||||
(defpackage :cl-tty.input
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout)
|
||||
(:export
|
||||
;; Key events
|
||||
#:key-event #:make-key-event
|
||||
#:key-event-p #:key-event-key #:key-event-ctrl
|
||||
#:key-event-alt #:key-event-shift #:key-event-code
|
||||
#:key-event-raw #:key-event-text
|
||||
;; Mouse events
|
||||
#:mouse-event #:make-mouse-event
|
||||
#:mouse-event-p #:mouse-event-type #:mouse-event-button
|
||||
#:mouse-event-x #:mouse-event-y
|
||||
;; Terminal raw mode
|
||||
#:save-terminal-state #:set-raw-mode #:restore-terminal-state
|
||||
#: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
|
||||
#:text-input-placeholder #:text-input-max-length
|
||||
#:text-input-on-submit #:text-input-layout-node
|
||||
#:handle-text-input #:render-text-input
|
||||
;; 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))
|
||||
|
||||
@@ -90,3 +90,96 @@
|
||||
;;; --- Component protocol integration ---
|
||||
(defgeneric component-keymap (component)
|
||||
(:method ((c t)) nil))
|
||||
|
||||
(in-package #:cl-tty.input)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key map struct
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defstruct keymap
|
||||
(name nil :type (or keyword null))
|
||||
(bindings nil :type list)
|
||||
(parent nil :type (or keymap null)))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Global keymap registry
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defparameter *keymaps* (make-hash-table :test #'equal))
|
||||
(defparameter *chord-timeout* 0.5)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key spec matching
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun key-match-p (spec event)
|
||||
"T if SPEC matches EVENT. Spec is :ctrl+p (modifier+key keyword)
|
||||
or (:ctrl+p) for single-spec in a list, or (:ctrl+x :ctrl+s) for chords."
|
||||
(etypecase spec
|
||||
;; Keyword like :ctrl+p, :alt+f, :enter, :space, :f1
|
||||
(keyword
|
||||
(let* ((name (string spec))
|
||||
(plus (position #\+ name)))
|
||||
(if plus
|
||||
;; Modified key: :ctrl+p → mod-str="CTRL", key-str="P"
|
||||
(let ((mod-str (subseq name 0 plus))
|
||||
(key-str (subseq name (1+ plus))))
|
||||
(and (eql (intern key-str :keyword)
|
||||
(key-event-key event))
|
||||
(cond
|
||||
((string= mod-str "CTRL") (key-event-ctrl event))
|
||||
((string= mod-str "ALT") (key-event-alt event))
|
||||
((string= mod-str "SHIFT") (key-event-shift event))
|
||||
(t t))))
|
||||
;; Plain keyword: :enter, :escape, :f1, etc.
|
||||
(eql spec (key-event-key event)))))
|
||||
;; List: (:ctrl+p) or (:ctrl+x :ctrl+s)
|
||||
(list
|
||||
(when spec
|
||||
(key-match-p (first spec) event)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; 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
|
||||
(loop for (spec . handler) in (keymap-bindings km)
|
||||
thereis (when (key-match-p spec event)
|
||||
(funcall handler event)
|
||||
t))))
|
||||
(find-keymap (name)
|
||||
(gethash name *keymaps*)))
|
||||
(or (and component
|
||||
(let ((km (component-keymap component)))
|
||||
(when km (try-keymap km))))
|
||||
(try-keymap (find-keymap :local))
|
||||
(try-keymap (find-keymap :global)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; defkeymap macro
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defmacro defkeymap (name &body bindings)
|
||||
`(setf (gethash ',name *keymaps*)
|
||||
(make-keymap :name ',name
|
||||
:bindings (list ,@(loop for b in bindings
|
||||
collect (if (consp (cdr b))
|
||||
`(cons ',(car b) ,(cadr b))
|
||||
`(cons ',(car b) ,(cdr b))))))))
|
||||
|
||||
;;; --- Component protocol integration ---
|
||||
(defgeneric component-keymap (component)
|
||||
(:method ((c t)) nil))
|
||||
|
||||
@@ -10,3 +10,16 @@
|
||||
#:start-selection #:update-selection #:finalize-selection
|
||||
#:selection-active-p
|
||||
#:cell-link-at #:open-link-at))
|
||||
|
||||
(defpackage :cl-tty.mouse
|
||||
(:use :cl :cl-tty.layout :cl-tty.input :cl-tty.box :cl-tty.rendering)
|
||||
(:export
|
||||
#:mouse-mixin
|
||||
#:on-mouse-down #:on-mouse-up #:on-mouse-move #:on-mouse-scroll
|
||||
#:handle-mouse-event
|
||||
#:hit-test
|
||||
#:selection #:get-selection #:copy-to-clipboard
|
||||
#:make-selection #:selection-p
|
||||
#:start-selection #:update-selection #:finalize-selection
|
||||
#:selection-active-p
|
||||
#:cell-link-at #:open-link-at))
|
||||
|
||||
@@ -111,3 +111,117 @@ Components without a layout-node or position return nil."
|
||||
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
|
||||
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
|
||||
url))
|
||||
|
||||
(in-package :cl-tty.mouse)
|
||||
|
||||
(defclass mouse-mixin ()
|
||||
((on-mouse-down :initarg :on-mouse-down :initform nil :accessor on-mouse-down)
|
||||
(on-mouse-up :initarg :on-mouse-up :initform nil :accessor on-mouse-up)
|
||||
(on-mouse-move :initarg :on-mouse-move :initform nil :accessor on-mouse-move)
|
||||
(on-mouse-scroll :initarg :on-mouse-scroll :initform nil :accessor on-mouse-scroll)))
|
||||
|
||||
(defun handle-mouse-event (component event)
|
||||
(let* ((type (mouse-event-type event))
|
||||
(handler (case type
|
||||
(:press (on-mouse-down component))
|
||||
(:release (on-mouse-up component))
|
||||
(:drag (on-mouse-move component))
|
||||
(t nil))))
|
||||
(when handler (funcall handler event))))
|
||||
|
||||
(defun hit-test (root x y)
|
||||
"Find the deepest component at (X, Y) by testing layout-node bounds.
|
||||
Recurses into component-children to find the innermost match.
|
||||
Components without a layout-node or position return nil."
|
||||
(labels ((recurse (node)
|
||||
(let ((ln (ignore-errors (component-layout-node node)))
|
||||
(best nil))
|
||||
(when ln
|
||||
(let ((nx (layout-node-x ln))
|
||||
(ny (layout-node-y ln))
|
||||
(nw (layout-node-width ln))
|
||||
(nh (layout-node-height ln)))
|
||||
;; Check children first for deeper match
|
||||
(dolist (child (ignore-errors (component-children node)))
|
||||
(let ((child-hit (recurse child)))
|
||||
(when child-hit
|
||||
(setf best child-hit))))
|
||||
;; If no child matched, check self
|
||||
(or best
|
||||
(when (and (>= x nx) (< x (+ nx nw))
|
||||
(>= y ny) (< y (+ ny nh)))
|
||||
node)))))))
|
||||
(recurse root)))
|
||||
|
||||
;; Selection
|
||||
(defvar *selection* nil)
|
||||
|
||||
(defstruct (selection (:conc-name sel-))
|
||||
(start-x 0) (start-y 0) (end-x 0) (end-y 0) (text ""))
|
||||
|
||||
(defun get-selection ()
|
||||
(when *selection* (sel-text *selection*)))
|
||||
|
||||
(defun copy-to-clipboard (text)
|
||||
#+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) ---------------------------------------
|
||||
|
||||
(defvar *selection-active* nil
|
||||
"T when a drag selection is in progress.")
|
||||
|
||||
(defvar *selection-start* nil
|
||||
"Cons (X . Y) of mouse-down position during drag.")
|
||||
|
||||
(defvar *selection-end* nil
|
||||
"Cons (X . Y) of current mouse position during drag.")
|
||||
|
||||
(defun start-selection (x y)
|
||||
"Begin a drag selection at (X Y)."
|
||||
(setf *selection-start* (cons x y)
|
||||
*selection-end* (cons x y)
|
||||
*selection-active* t))
|
||||
|
||||
(defun update-selection (x y)
|
||||
"Update the drag selection end position to (X Y)."
|
||||
(setf *selection-end* (cons x y)))
|
||||
|
||||
(defun selection-active-p ()
|
||||
"Return T if a drag selection is in progress."
|
||||
*selection-active*)
|
||||
|
||||
(defun finalize-selection (fb)
|
||||
"End the drag selection and extract text from the framebuffer."
|
||||
(setf *selection-active* nil)
|
||||
(when (and *selection-start* *selection-end* fb)
|
||||
(let* ((x1 (car *selection-start*))
|
||||
(y1 (cdr *selection-start*))
|
||||
(x2 (car *selection-end*))
|
||||
(y2 (cdr *selection-end*))
|
||||
(text (cl-tty.rendering:extract-text fb x1 y1 x2 y2)))
|
||||
(setf *selection* (make-selection :start-x x1 :start-y y1
|
||||
:end-x x2 :end-y y2
|
||||
:text text))
|
||||
(setf *selection-start* nil *selection-end* nil)
|
||||
text)))
|
||||
|
||||
;;; --- Link clicking ---------------------------------------------------------
|
||||
|
||||
(defun cell-link-at (fb x y)
|
||||
"Return the link URL at (X Y) in framebuffer FB, or nil."
|
||||
(cl-tty.rendering:fb-cell-link-url fb x y))
|
||||
|
||||
(defun open-link-at (fb x y)
|
||||
"If there is a link URL at (X Y) in FB, open it via xdg-open."
|
||||
(let ((url (cell-link-at fb x y)))
|
||||
(when url
|
||||
#+linux (sb-ext:run-program "xdg-open" (list url) :wait nil)
|
||||
#+darwin (sb-ext:run-program "open" (list url) :wait nil))
|
||||
url))
|
||||
|
||||
@@ -95,3 +95,101 @@ Children outside the viewport are skipped."
|
||||
(viewport-h (if ln (layout-node-height ln) 24)))
|
||||
(when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h)))))))
|
||||
|
||||
(in-package #:cl-tty.container)
|
||||
|
||||
(defclass scroll-box (dirty-mixin)
|
||||
((children :initform nil :initarg :children :accessor scroll-box-children :type list)
|
||||
(scroll-y :initform 0 :initarg :scroll-y :accessor scroll-box-scroll-y :type fixnum)
|
||||
(scroll-x :initform 0 :initarg :scroll-x :accessor scroll-box-scroll-x :type fixnum)
|
||||
(sticky-scroll-p :initform t :initarg :sticky-scroll-p :accessor sticky-scroll-p :type boolean)
|
||||
(layout-node :initform (make-layout-node) :accessor scroll-box-layout-node)))
|
||||
|
||||
(defun make-scroll-box (&key (children nil) (scroll-y 0) (scroll-x 0) sticky-scroll-p)
|
||||
(make-instance 'scroll-box
|
||||
:children children :scroll-y scroll-y :scroll-x scroll-x
|
||||
:sticky-scroll-p (if (null sticky-scroll-p) t sticky-scroll-p)))
|
||||
|
||||
(defmethod component-children ((sb scroll-box)) (scroll-box-children sb))
|
||||
(defmethod component-layout-node ((sb scroll-box)) (scroll-box-layout-node sb))
|
||||
|
||||
(defun clamp-scroll (sb)
|
||||
(let* ((ln (scroll-box-layout-node sb))
|
||||
(viewport-h (if ln (layout-node-height ln) 0))
|
||||
(viewport-w (if ln (layout-node-width ln) 0))
|
||||
(content-h (scroll-box-content-height sb))
|
||||
(content-w (scroll-box-content-width sb)))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (min (scroll-box-scroll-y sb) (- content-h viewport-h))))
|
||||
(setf (scroll-box-scroll-x sb) (max 0 (min (scroll-box-scroll-x sb) (- content-w viewport-w))))))
|
||||
|
||||
(defun scroll-by (sb dy dx)
|
||||
(incf (scroll-box-scroll-y sb) dy) (incf (scroll-box-scroll-x sb) dx)
|
||||
(clamp-scroll sb) (mark-dirty sb))
|
||||
|
||||
(defun scroll-box-content-height (sb)
|
||||
(reduce #'+ (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-height ln)) 1)))
|
||||
:initial-value 0))
|
||||
|
||||
(defun scroll-box-content-width (sb)
|
||||
(reduce #'max (scroll-box-children sb)
|
||||
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-width ln)) 1)))
|
||||
: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))
|
||||
(vh (if ln (layout-node-height ln) 24))
|
||||
(sy (scroll-box-scroll-y sb))
|
||||
(sx (scroll-box-scroll-x sb)))
|
||||
(dolist (child (scroll-box-children sb))
|
||||
(let* ((cln (component-layout-node child))
|
||||
(ch (if cln (layout-node-height cln) 1))
|
||||
(cy vy))
|
||||
;; Only render children that are visible in the viewport
|
||||
(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) (- vx sx)
|
||||
(layout-node-y cln) (- vy 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)))
|
||||
|
||||
(defun scrollbar-thumb (scroll-pos viewport-size content-size)
|
||||
(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))
|
||||
(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 (+ 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 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)
|
||||
(let* ((content-h (scroll-box-content-height sb))
|
||||
(ln (scroll-box-layout-node sb))
|
||||
(viewport-h (if ln (layout-node-height ln) 24)))
|
||||
(when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1))
|
||||
(setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h)))))))
|
||||
|
||||
@@ -11,3 +11,17 @@
|
||||
#:select-handle-key
|
||||
#:render
|
||||
#:fuzzy-match-p))
|
||||
|
||||
(defpackage :cl-tty.select
|
||||
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export
|
||||
#:select #:make-select
|
||||
#:select-options #:select-filter
|
||||
#:select-selected-index #:select-on-select
|
||||
#:select-layout-node
|
||||
#:select-filtered-options
|
||||
#:select-next #:select-prev
|
||||
#:select-visible-options
|
||||
#:select-handle-key
|
||||
#:render
|
||||
#:fuzzy-match-p))
|
||||
|
||||
@@ -94,3 +94,100 @@
|
||||
(t (draw-text backend x y display nil nil)))
|
||||
(incf y 1)))
|
||||
(values)))
|
||||
|
||||
(in-package #:cl-tty.select)
|
||||
|
||||
(defclass select (dirty-mixin)
|
||||
((options :initform nil :initarg :options :accessor select-options :type list)
|
||||
(filter :initform nil :initarg :filter :accessor select-filter :type (or string null))
|
||||
(selected-index :initform 0 :initarg :selected-index :accessor select-selected-index :type fixnum)
|
||||
(on-select :initform nil :initarg :on-select :accessor select-on-select)
|
||||
(layout-node :initform (make-layout-node) :initarg :layout-node :accessor select-layout-node)))
|
||||
|
||||
(defun make-select (&key options filter on-select)
|
||||
(make-instance 'select :options (or options nil) :filter filter :on-select on-select))
|
||||
|
||||
(defmethod component-layout-node ((sel select)) (select-layout-node sel))
|
||||
|
||||
(defun select-filtered-options (sel)
|
||||
(let* ((filter (select-filter sel)) (all-options (select-options sel))
|
||||
(filtered (if (null filter) all-options
|
||||
(let ((lower (string-downcase filter)))
|
||||
(remove-if-not
|
||||
(lambda (opt)
|
||||
(or (getf opt :category)
|
||||
(let ((title (string-downcase (getf opt :title))))
|
||||
(or (search lower title) (fuzzy-match-p lower title)))))
|
||||
all-options)))))
|
||||
(loop for opt in filtered for i from 0
|
||||
collect (list i (position opt all-options) opt))))
|
||||
|
||||
(defun fuzzy-match-p (query target)
|
||||
(let* ((q (remove-duplicates (coerce (string-downcase query) 'list)))
|
||||
(tg (remove-duplicates (coerce (string-downcase target) 'list)))
|
||||
(intersection (length (intersection q tg)))
|
||||
(union (length (union q tg))))
|
||||
(if (zerop union) nil (> (/ (float intersection) union) 0.3))))
|
||||
|
||||
(defun select-clamp-index (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered)))
|
||||
(if (zerop count) (setf (select-selected-index sel) 0)
|
||||
(setf (select-selected-index sel) (max 0 (min (select-selected-index sel) (1- count)))))))
|
||||
|
||||
(defun select-next (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
|
||||
(current (select-selected-index sel)))
|
||||
(when (plusp count)
|
||||
(loop for i from 1 below count
|
||||
for idx = (mod (+ current i) count)
|
||||
for opt = (third (nth idx filtered))
|
||||
when (not (getf opt :category))
|
||||
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
|
||||
|
||||
(defun select-prev (sel)
|
||||
(let* ((filtered (select-filtered-options sel)) (count (length filtered))
|
||||
(current (select-selected-index sel)))
|
||||
(when (plusp count)
|
||||
(loop for i from 1 below count
|
||||
for idx = (mod (- current i) count)
|
||||
for opt = (third (nth idx filtered))
|
||||
when (not (getf opt :category))
|
||||
do (setf (select-selected-index sel) idx) (mark-dirty sel) (return)))))
|
||||
|
||||
(defun select-handle-key (sel event)
|
||||
(let ((key (key-event-key event)) (ctrl (key-event-ctrl event)))
|
||||
(cond
|
||||
((or (eql key :down) (and ctrl (eql key :n))) (select-next sel) t)
|
||||
((or (eql key :up) (and ctrl (eql key :p))) (select-prev sel) t)
|
||||
((eql key :enter)
|
||||
(let* ((filtered (select-filtered-options sel)) (idx (select-selected-index sel))
|
||||
(item (when (< idx (length filtered)) (third (nth idx filtered)))))
|
||||
(when item (let ((cb (select-on-select sel))) (when cb (funcall cb item)))) t))
|
||||
((eql key :escape) nil) (t nil))))
|
||||
|
||||
(defun select-visible-options (sel)
|
||||
(let* ((ln (select-layout-node sel)) (height (if ln (layout-node-height ln) 80))
|
||||
(filtered (select-filtered-options sel)) (sel-idx (select-selected-index sel))
|
||||
(half (floor (1- height) 2)) (start (max 0 (- sel-idx half)))
|
||||
(end (min (length filtered) (+ start height))))
|
||||
(subseq filtered start end)))
|
||||
|
||||
(defmethod render ((sel select) backend)
|
||||
(let* ((ln (select-layout-node sel))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(visible (select-visible-options sel)) (sel-idx (select-selected-index sel)))
|
||||
(dolist (item visible)
|
||||
(let* ((display-idx (first item)) (option (third item))
|
||||
(title (getf option :title)) (cat (getf option :category))
|
||||
(selected (eql display-idx sel-idx))
|
||||
(display (if (> (length title) (1- w))
|
||||
(concatenate 'string (subseq title 0 (1- w)) "…") title)))
|
||||
(cond (cat (draw-text backend x y display :text-muted nil))
|
||||
(selected
|
||||
(draw-rect backend x y w 1 :bg :accent)
|
||||
(draw-text backend x y display :background :accent))
|
||||
(t (draw-text backend x y display nil nil)))
|
||||
(incf y 1)))
|
||||
(values)))
|
||||
|
||||
@@ -7,3 +7,13 @@
|
||||
#:clear-slot
|
||||
#:list-slots
|
||||
#:*slots*))
|
||||
|
||||
(defpackage :cl-tty.slot
|
||||
(:use :cl)
|
||||
(:export
|
||||
#:defslot
|
||||
#:slot-render
|
||||
#:slot-p
|
||||
#:clear-slot
|
||||
#:list-slots
|
||||
#:*slots*))
|
||||
|
||||
@@ -28,3 +28,34 @@
|
||||
|
||||
(defun list-slots ()
|
||||
(loop for key being the hash-keys of *slots* collect key))
|
||||
|
||||
(in-package :cl-tty.slot)
|
||||
|
||||
(defvar *slots* (make-hash-table :test #'equal)
|
||||
"Hash table mapping slot name (string) -> list of (order . render-fn) pairs.")
|
||||
|
||||
(defun defslot (name &key (order 0) render-fn)
|
||||
(let* ((key (string name))
|
||||
(entries (gethash key *slots*)))
|
||||
(if (null entries)
|
||||
(setf (gethash key *slots*) (list (cons order render-fn)))
|
||||
(setf (gethash key *slots*)
|
||||
(sort (cons (cons order render-fn) entries) #'< :key #'car))))
|
||||
render-fn)
|
||||
|
||||
(defun slot-render (slot-name &rest args)
|
||||
(let ((entries (gethash (string slot-name) *slots*)))
|
||||
(when 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*)))
|
||||
|
||||
(defun clear-slot (slot-name)
|
||||
(remhash (string slot-name) *slots*))
|
||||
|
||||
(defun list-slots ()
|
||||
(loop for key being the hash-keys of *slots* collect key))
|
||||
|
||||
@@ -51,3 +51,57 @@
|
||||
(draw-text backend x-pos y label fg bg)
|
||||
(incf x-pos (+ label-len 2)))))
|
||||
(values))
|
||||
|
||||
(in-package #:cl-tty.container)
|
||||
|
||||
(defclass tab-bar (dirty-mixin)
|
||||
((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list)
|
||||
(active :initform nil :initarg :active :accessor tab-bar-active)
|
||||
(layout-node :initform (make-layout-node) :accessor tab-bar-layout-node)
|
||||
(focusable :initform t :accessor tab-bar-focusable)))
|
||||
|
||||
(defun make-tab-bar (&key tabs active)
|
||||
(make-instance 'tab-bar :tabs (or tabs nil) :active active))
|
||||
|
||||
(defun tab-bar-add (tb id title)
|
||||
(setf (tab-bar-tabs tb) (nconc (tab-bar-tabs tb) (list (list :id id :title title))))
|
||||
(unless (tab-bar-active tb) (setf (tab-bar-active tb) id)) id)
|
||||
|
||||
(defmethod component-layout-node ((tb tab-bar)) (tab-bar-layout-node tb))
|
||||
|
||||
(defun tab-bar-next (tb)
|
||||
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
|
||||
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
|
||||
(pos (position current ids)))
|
||||
(when pos (let ((next (nth (mod (1+ pos) (length ids)) ids)))
|
||||
(setf (tab-bar-active tb) next) (mark-dirty tb)))))
|
||||
|
||||
(defun tab-bar-prev (tb)
|
||||
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
|
||||
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
|
||||
(pos (position current ids)))
|
||||
(when pos (let ((prev (nth (mod (1- pos) (length ids)) ids)))
|
||||
(setf (tab-bar-active tb) prev) (mark-dirty tb)))))
|
||||
|
||||
(defun tab-bar-select (tb id) (setf (tab-bar-active tb) id) (mark-dirty tb))
|
||||
|
||||
(defun tab-bar-handle-key (tb event)
|
||||
(case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil)))
|
||||
|
||||
(defmethod render ((tb tab-bar) backend)
|
||||
(let* ((ln (tab-bar-layout-node tb))
|
||||
(x (if ln (layout-node-x ln) 0))
|
||||
(y (if ln (layout-node-y ln) 0))
|
||||
(w (if ln (layout-node-width ln) 80))
|
||||
(active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x))
|
||||
(dolist (tab tabs)
|
||||
(let* ((id (getf tab :id)) (title (getf tab :title))
|
||||
(label (format nil " ~A " title)) (label-len (length label))
|
||||
(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)
|
||||
(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)))))
|
||||
(values))
|
||||
|
||||
@@ -256,3 +256,262 @@
|
||||
do (draw-text backend x (+ y i)
|
||||
(subseq line 0 (min (length line) w))
|
||||
nil nil))))
|
||||
|
||||
(in-package #:cl-tty.input)
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Textarea class
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defclass textarea (dirty-mixin)
|
||||
((value :initform "" :initarg :value :accessor textarea-value :type string)
|
||||
(cursor-row :initform 0 :accessor textarea-cursor-row :type fixnum)
|
||||
(cursor-col :initform 0 :accessor textarea-cursor-col :type fixnum)
|
||||
(selection-start :initform nil :accessor textarea-selection-start)
|
||||
(undo-stack :initform (make-array 100 :fill-pointer 0)
|
||||
:accessor textarea-undo-stack)
|
||||
(redo-stack :initform (make-array 100 :fill-pointer 0)
|
||||
:accessor textarea-redo-stack)
|
||||
(on-submit :initform nil :initarg :on-submit :accessor textarea-on-submit)
|
||||
(layout-node :initform (make-layout-node) :accessor textarea-layout-node)
|
||||
(focusable :initform t :accessor textarea-focusable)))
|
||||
|
||||
(defun make-textarea (&key value on-submit)
|
||||
(make-instance 'textarea
|
||||
:value (or value "")
|
||||
:on-submit on-submit))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Line helpers
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-lines (ta)
|
||||
"Split value into lines."
|
||||
(%split-string (textarea-value ta) #\Newline))
|
||||
|
||||
(defun textarea-line-count (ta)
|
||||
"Number of lines in value."
|
||||
(length (textarea-lines ta)))
|
||||
|
||||
(defun textarea-ensure-cursor (ta)
|
||||
"Clamp cursor to valid range."
|
||||
(let ((lines (textarea-lines ta)))
|
||||
(setf (textarea-cursor-row ta)
|
||||
(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)))))
|
||||
(mark-dirty ta))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Utility: join strings with newline
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun %join-lines (lines)
|
||||
"Join a sequence of strings with newlines."
|
||||
(with-output-to-string (s)
|
||||
(loop for line across (if (listp lines) (coerce lines 'vector) lines)
|
||||
for first = t then nil
|
||||
do (unless first (write-char #\Newline s))
|
||||
(write-string line s))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Text manipulation
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-insert-char (ta char)
|
||||
"Insert CHAR at the cursor position."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(if (< row (length lines))
|
||||
(let* ((line (aref lines row))
|
||||
(new-line (concatenate 'string
|
||||
(subseq line 0 col)
|
||||
(string char)
|
||||
(subseq line col))))
|
||||
(setf (aref lines row) new-line)
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(incf (textarea-cursor-col ta))
|
||||
(mark-dirty ta))
|
||||
(progn
|
||||
(setf (textarea-value ta)
|
||||
(concatenate 'string (textarea-value ta) (string char)))
|
||||
(incf (textarea-cursor-col ta))
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-newline (ta)
|
||||
"Insert a newline at the cursor."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(if (< row (length lines))
|
||||
(let* ((line (aref lines row))
|
||||
(before (subseq line 0 col))
|
||||
(after (subseq line col)))
|
||||
(setf (aref lines row) before)
|
||||
(let ((new-lines (concatenate 'vector
|
||||
(subseq lines 0 (1+ row))
|
||||
(vector after)
|
||||
(subseq lines (1+ row)))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines new-lines)))
|
||||
(incf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) 0)
|
||||
(mark-dirty ta))
|
||||
(progn
|
||||
(setf (textarea-value ta)
|
||||
(concatenate 'string (textarea-value ta) (string #\Newline)))
|
||||
(incf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) 0)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-backspace (ta)
|
||||
"Delete character before cursor."
|
||||
(textarea-push-undo ta)
|
||||
(let* ((lines (coerce (textarea-lines ta) 'vector))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta)))
|
||||
(cond
|
||||
((and (zerop row) (zerop col))
|
||||
nil) ;; nothing to delete
|
||||
((zerop col)
|
||||
;; Join with previous line
|
||||
(let* ((prev (aref lines (1- row)))
|
||||
(curr (aref lines row))
|
||||
(new-pos (length prev)))
|
||||
(setf (aref lines (1- row))
|
||||
(concatenate 'string prev curr))
|
||||
(let ((new-lines (concatenate 'vector
|
||||
(subseq lines 0 row)
|
||||
(subseq lines (1+ row)))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines new-lines)))
|
||||
(decf (textarea-cursor-row ta))
|
||||
(setf (textarea-cursor-col ta) new-pos)
|
||||
(mark-dirty ta)))
|
||||
(t
|
||||
(let* ((line (aref lines row))
|
||||
(new-line (concatenate 'string
|
||||
(subseq line 0 (1- col))
|
||||
(subseq line col))))
|
||||
(setf (aref lines row) new-line)
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(decf (textarea-cursor-col ta))
|
||||
(mark-dirty ta))))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Cursor movement
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-move-up (ta)
|
||||
(decf (textarea-cursor-row ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
|
||||
(defun textarea-move-down (ta)
|
||||
(incf (textarea-cursor-row ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Undo/redo
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun textarea-push-undo (ta)
|
||||
"Save current value on undo stack."
|
||||
(let ((stack (textarea-undo-stack ta)))
|
||||
(when (>= (length stack) (array-total-size stack))
|
||||
(loop for i from 1 below (length stack)
|
||||
do (setf (aref stack (1- i)) (aref stack i)))
|
||||
(decf (fill-pointer stack)))
|
||||
(vector-push (textarea-value ta) stack)
|
||||
(setf (fill-pointer (textarea-redo-stack ta)) 0)))
|
||||
|
||||
(defun textarea-undo (ta)
|
||||
(let ((stack (textarea-undo-stack ta)))
|
||||
(when (plusp (length stack))
|
||||
(let ((prev (vector-pop stack)))
|
||||
(vector-push (textarea-value ta) (textarea-redo-stack ta))
|
||||
(setf (textarea-value ta) prev)
|
||||
(textarea-ensure-cursor ta)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
(defun textarea-redo (ta)
|
||||
(let ((stack (textarea-redo-stack ta)))
|
||||
(when (plusp (length stack))
|
||||
(let ((next (vector-pop stack)))
|
||||
(vector-push (textarea-value ta) (textarea-undo-stack ta))
|
||||
(setf (textarea-value ta) next)
|
||||
(textarea-ensure-cursor ta)
|
||||
(mark-dirty ta)))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Key event handler
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defun handle-textarea-input (ta event)
|
||||
"Process a key-event on a textarea widget."
|
||||
(cond
|
||||
((key-event-ctrl event)
|
||||
(case (key-event-key event)
|
||||
(:z (textarea-undo ta))
|
||||
(:y (textarea-redo ta))
|
||||
;; Ctrl+A/E: home/end
|
||||
(:a (setf (textarea-cursor-col ta) 0))
|
||||
(:e (let ((lines (textarea-lines ta)))
|
||||
(when (< (textarea-cursor-row ta) (length lines))
|
||||
(setf (textarea-cursor-col ta)
|
||||
(length (nth (textarea-cursor-row ta) lines))))))
|
||||
(t nil)))
|
||||
(t
|
||||
(case (key-event-key event)
|
||||
(:left (decf (textarea-cursor-col ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
(:right (incf (textarea-cursor-col ta))
|
||||
(textarea-ensure-cursor ta))
|
||||
(:up (textarea-move-up ta))
|
||||
(:down (textarea-move-down ta))
|
||||
(: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))
|
||||
(textarea-newline ta))))
|
||||
(:backspace (textarea-backspace ta))
|
||||
(:delete (let* ((lines (textarea-lines ta))
|
||||
(row (textarea-cursor-row ta))
|
||||
(col (textarea-cursor-col ta))
|
||||
(line (nth row lines)))
|
||||
(when (and line (< col (length line)))
|
||||
(textarea-push-undo ta)
|
||||
(setf (nth row lines)
|
||||
(concatenate 'string
|
||||
(subseq line 0 col)
|
||||
(subseq line (1+ col))))
|
||||
(setf (textarea-value ta)
|
||||
(%join-lines lines))
|
||||
(mark-dirty ta))))
|
||||
;; Character insertion
|
||||
(otherwise
|
||||
(let ((ch (code-char (key-event-code event))))
|
||||
(when (and ch (graphic-char-p ch))
|
||||
(textarea-insert-char ta ch))))))))
|
||||
|
||||
;;; ---------------------------------------------------------------------------
|
||||
;;; Rendering
|
||||
;;; ---------------------------------------------------------------------------
|
||||
(defmethod render ((ta textarea) (backend t))
|
||||
"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)))
|
||||
(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))))
|
||||
|
||||
@@ -218,3 +218,223 @@ Returns the number of changed cells."
|
||||
(fb-scissor-y ,fb) ,old-y
|
||||
(fb-scissor-w ,fb) ,old-w
|
||||
(fb-scissor-h ,fb) ,old-h)))))
|
||||
|
||||
(defpackage :cl-tty.rendering
|
||||
(:use :cl :cl-tty.backend)
|
||||
(:export
|
||||
#:cell #:make-cell #:cell-char #:cell-fg #:cell-bg
|
||||
#:cell-bold #:cell-italic #:cell-underline #:cell-link-url
|
||||
#:framebuffer-backend #:make-framebuffer-backend
|
||||
#:make-framebuffer #:fb-framebuffer
|
||||
#:framebuffer-width #:framebuffer-height
|
||||
#:diff-framebuffers #:flush-framebuffer
|
||||
#:with-scissor
|
||||
#:extract-text #:fb-cell-link-url))
|
||||
|
||||
(in-package :cl-tty.rendering)
|
||||
|
||||
;;; ─── Cell — immutable per-cell state ─────────────────────────────────────────
|
||||
|
||||
(defstruct cell
|
||||
"A single terminal cell — character, colors, and attributes."
|
||||
(char #\space :type character)
|
||||
(fg nil)
|
||||
(bg nil)
|
||||
(bold nil :type boolean)
|
||||
(italic nil :type boolean)
|
||||
(underline nil :type boolean)
|
||||
(link-url nil))
|
||||
|
||||
;;; ─── Framebuffer — 2D array of cells ────────────────────────────────────────
|
||||
|
||||
(defun make-framebuffer (width height)
|
||||
"Create a 2D array of CELL with dimensions HEIGHT x WIDTH."
|
||||
(make-array (list height width)
|
||||
:initial-element (make-cell)
|
||||
:element-type 'cell))
|
||||
|
||||
(defun framebuffer-width (fb)
|
||||
"Return the width (columns) of framebuffer FB."
|
||||
(if (arrayp fb) (array-dimension fb 1) 0))
|
||||
|
||||
(defun framebuffer-height (fb)
|
||||
"Return the height (rows) of framebuffer FB."
|
||||
(if (arrayp fb) (array-dimension fb 0) 0))
|
||||
|
||||
;;; ─── Framebuffer Backend — implements backend protocol ─────────────────────
|
||||
|
||||
(defclass framebuffer-backend (backend)
|
||||
((framebuffer :initform nil :accessor fb-framebuffer)
|
||||
(scissor-x :initform 0 :accessor fb-scissor-x)
|
||||
(scissor-y :initform 0 :accessor fb-scissor-y)
|
||||
(scissor-w :initform nil :accessor fb-scissor-w)
|
||||
(scissor-h :initform nil :accessor fb-scissor-h)))
|
||||
|
||||
(defun make-framebuffer-backend (&key (width 80) (height 24))
|
||||
"Create a framebuffer-backend with a fresh framebuffer."
|
||||
(let ((fb (make-instance 'framebuffer-backend)))
|
||||
(setf (fb-framebuffer fb) (make-framebuffer width height))
|
||||
fb))
|
||||
|
||||
;;; ─── Drawing methods ─────────────────────────────────────────────────────────
|
||||
|
||||
(defun %in-scissor-p (fb cx cy)
|
||||
"Check if (CX, CY) falls within the current scissor rectangle."
|
||||
(let ((sx (fb-scissor-x fb)) (sy (fb-scissor-y fb))
|
||||
(sw (fb-scissor-w fb)) (sh (fb-scissor-h fb)))
|
||||
(and (or (null sw) (and (>= cx sx) (< cx (+ sx sw))))
|
||||
(or (null sh) (and (>= cy sy) (< cy (+ sy sh)))))))
|
||||
|
||||
(defun %set-cell (fb x y char &key fg bg bold italic underline link-url)
|
||||
"Set cell (X, Y) if within bounds and scissor."
|
||||
(let ((cells (fb-framebuffer fb)))
|
||||
(when (and (>= y 0) (< y (framebuffer-height cells))
|
||||
(>= x 0) (< x (framebuffer-width cells))
|
||||
(%in-scissor-p fb x y))
|
||||
(setf (aref cells y x)
|
||||
(make-cell :char char :fg fg :bg bg
|
||||
:bold bold :italic italic :underline underline
|
||||
:link-url link-url)))))
|
||||
|
||||
(defmethod draw-text ((fb framebuffer-backend) x y string fg bg
|
||||
&key bold italic underline reverse dim blink
|
||||
(link-url nil link-url-p)
|
||||
&allow-other-keys)
|
||||
(declare (ignore reverse dim blink link-url-p))
|
||||
(loop for i from 0 below (length string)
|
||||
do (%set-cell fb (+ x i) y (char string i)
|
||||
:fg fg :bg bg
|
||||
:bold bold :italic italic :underline underline
|
||||
:link-url link-url)))
|
||||
|
||||
(defmethod draw-rect ((fb framebuffer-backend) x y w h &key bg)
|
||||
(dotimes (row h)
|
||||
(dotimes (col w)
|
||||
(%set-cell fb (+ x col) (+ y row) #\space :fg nil :bg bg))))
|
||||
|
||||
(defmethod draw-border ((fb framebuffer-backend) x y w h &key (style :single) title title-align fg bg)
|
||||
(let* ((chars (case style
|
||||
(:single '(#\+ #\- #\|))
|
||||
(:double '(#\+ #\= #\|))
|
||||
(:rounded '(#\. #\- #\|))
|
||||
(t '(#\+ #\- #\|))))
|
||||
(tc (first chars)) (hc (second chars)) (vc (third chars)))
|
||||
;; Top edge
|
||||
(%set-cell fb x y tc :fg fg :bg bg)
|
||||
(loop for i from 1 below (1- w) do (%set-cell fb (+ x i) y hc :fg fg :bg bg))
|
||||
(%set-cell fb (1- (+ x w)) y tc :fg fg :bg bg)
|
||||
;; Sides
|
||||
(dotimes (row (- h 2))
|
||||
(%set-cell fb x (+ y row 1) vc :fg fg :bg bg)
|
||||
(%set-cell fb (1- (+ x w)) (+ y row 1) vc :fg fg :bg bg))
|
||||
;; Bottom edge
|
||||
(%set-cell fb x (+ y h -1) tc :fg fg :bg bg)
|
||||
(loop for i from 1 below (1- w) do (%set-cell fb (+ x i) (+ y h -1) hc :fg fg :bg bg))
|
||||
(%set-cell fb (1- (+ x w)) (+ y h -1) tc :fg fg :bg bg)
|
||||
;; Title
|
||||
(when title
|
||||
(loop for i from 0 below (length title)
|
||||
do (%set-cell fb (+ x 2 i) y (char title i) :fg fg :bg bg)))))
|
||||
|
||||
(defmethod backend-clear ((fb framebuffer-backend))
|
||||
(let ((cells (fb-framebuffer fb)))
|
||||
(dotimes (y (framebuffer-height cells))
|
||||
(dotimes (x (framebuffer-width cells))
|
||||
(setf (aref cells y x) (make-cell))))))
|
||||
|
||||
(defmethod draw-link ((fb framebuffer-backend) x y string url &key fg bg)
|
||||
;; OSC 8 links are not rendered in framebuffer — store as text
|
||||
(draw-text fb x y string fg bg :link-url url))
|
||||
|
||||
(defmethod draw-ellipsis ((fb framebuffer-backend) x y width &key fg bg)
|
||||
(dotimes (i (min 3 width))
|
||||
(%set-cell fb (+ x i) y #\. :fg fg :bg bg)))
|
||||
|
||||
;;; ─── Diff ────────────────────────────────────────────────────────────────────
|
||||
|
||||
(defun cells-equal-p (a b)
|
||||
"Return T if two cells have identical content and style."
|
||||
(and (eql (cell-char a) (cell-char b))
|
||||
(eql (cell-fg a) (cell-fg b))
|
||||
(eql (cell-bg a) (cell-bg b))
|
||||
(eql (cell-bold a) (cell-bold b))
|
||||
(eql (cell-italic a) (cell-italic b))
|
||||
(eql (cell-underline a) (cell-underline b))
|
||||
(equal (cell-link-url a) (cell-link-url b))))
|
||||
|
||||
(defun diff-framebuffers (prev curr)
|
||||
"Compare PREV and CURR framebuffers. Return list of (X Y CELL) for changes."
|
||||
(let ((changes nil)
|
||||
(h (min (framebuffer-height prev) (framebuffer-height curr)))
|
||||
(w (min (framebuffer-width prev) (framebuffer-width curr))))
|
||||
(dotimes (y h)
|
||||
(dotimes (x w)
|
||||
(let ((a (aref prev y x)) (b (aref curr y x)))
|
||||
(unless (cells-equal-p a b)
|
||||
(push (list x y b) changes)))))
|
||||
(nreverse changes)))
|
||||
|
||||
;;; ─── Flush ───────────────────────────────────────────────────────────────────
|
||||
|
||||
(defun flush-framebuffer (prev-fb curr-fb backend)
|
||||
"Diff PREV-FB and CURR-FB and flush changes to BACKEND.
|
||||
Returns the number of changed cells."
|
||||
(let* ((changes (diff-framebuffers prev-fb curr-fb))
|
||||
(count (length changes))
|
||||
(current-row -1))
|
||||
(when (plusp count)
|
||||
(begin-sync backend)
|
||||
(dolist (change changes)
|
||||
(destructuring-bind (x y cell) change
|
||||
(unless (= y current-row)
|
||||
(cursor-move backend x y)
|
||||
(setf current-row y))
|
||||
(draw-text backend x y (string (cell-char cell))
|
||||
(cell-fg cell) (cell-bg cell)
|
||||
:bold (cell-bold cell)
|
||||
:italic (cell-italic cell)
|
||||
:underline (cell-underline cell))))
|
||||
(end-sync backend))
|
||||
count))
|
||||
|
||||
;;; --- Frame inspection ---------------------------------------------------
|
||||
|
||||
(defun fb-cell-link-url (fb x y)
|
||||
"Return the link URL at (X Y) in framebuffer FB, or nil."
|
||||
(when (and (arrayp fb) (>= y 0) (< y (array-dimension fb 0))
|
||||
(>= x 0) (< x (array-dimension fb 1)))
|
||||
(let ((c (aref fb y x)))
|
||||
(cell-link-url c))))
|
||||
|
||||
(defun extract-text (fb x1 y1 x2 y2)
|
||||
"Extract visible text from the rectangle between (X1,Y1) and (X2,Y2)."
|
||||
(let ((x-min (max 0 (min x1 x2))) (x-max (max 0 (max x1 x2)))
|
||||
(y-min (max 0 (min y1 y2))) (y-max (max 0 (max y1 y2)))
|
||||
(h (if (arrayp fb) (array-dimension fb 0) 0))
|
||||
(w (if (arrayp fb) (array-dimension fb 1) 0)))
|
||||
(with-output-to-string (s)
|
||||
(loop for y from y-min to (min y-max (1- h))
|
||||
do (loop for x from x-min to (min x-max (1- w))
|
||||
do (let ((c (aref fb y x)))
|
||||
(princ (cell-char c) s)))
|
||||
(when (< y y-max) (princ #\Newline s))))))
|
||||
|
||||
;;; ─── Scissor clipping ────────────────────────────────────────────────────────
|
||||
|
||||
(defmacro with-scissor ((fb x y w h) &body body)
|
||||
"Clip all drawing on FB to rectangle (X Y W H)."
|
||||
(let ((old-x (gensym)) (old-y (gensym))
|
||||
(old-w (gensym)) (old-h (gensym)))
|
||||
`(let ((,old-x (fb-scissor-x ,fb))
|
||||
(,old-y (fb-scissor-y ,fb))
|
||||
(,old-w (fb-scissor-w ,fb))
|
||||
(,old-h (fb-scissor-h ,fb)))
|
||||
(setf (fb-scissor-x ,fb) ,x
|
||||
(fb-scissor-y ,fb) ,y
|
||||
(fb-scissor-w ,fb) ,w
|
||||
(fb-scissor-h ,fb) ,h)
|
||||
(unwind-protect (progn ,@body)
|
||||
(setf (fb-scissor-x ,fb) ,old-x
|
||||
(fb-scissor-y ,fb) ,old-y
|
||||
(fb-scissor-w ,fb) ,old-w
|
||||
(fb-scissor-h ,fb) ,old-h)))))
|
||||
|
||||
@@ -41,3 +41,47 @@
|
||||
(let ((*toasts* (list (make-instance 'toast :message "T" :variant :info))))
|
||||
(dismiss-toast (first *toasts*))
|
||||
(is (= 0 (length *toasts*)))))
|
||||
|
||||
;;; dialog-tests.lisp — Tests for cl-tty.dialog
|
||||
|
||||
(defpackage :cl-tty-dialog-test
|
||||
(:use :cl :cl-tty.dialog :fiveam))
|
||||
|
||||
(in-package :cl-tty-dialog-test)
|
||||
|
||||
(def-suite dialog-suite :description "Dialog + Toast tests for cl-tty.dialog")
|
||||
(in-suite dialog-suite)
|
||||
|
||||
(def-test dialog-create ()
|
||||
(let ((d (make-instance 'dialog :title "Test")))
|
||||
(is-true (typep d 'dialog))
|
||||
(is (equal "Test" (dialog-title d)))))
|
||||
|
||||
(def-test dialog-size-small ()
|
||||
(multiple-value-bind (w h) (dialog-size-pixels :small)
|
||||
(is (= 40 w))
|
||||
(is (= 8 h))))
|
||||
|
||||
(def-test dialog-size-medium ()
|
||||
(multiple-value-bind (w h) (dialog-size-pixels :medium)
|
||||
(is (= 60 w))
|
||||
(is (= 16 h))))
|
||||
|
||||
(def-test dialog-push-pop ()
|
||||
(let ((*dialog-stack* nil))
|
||||
(push-dialog (make-instance 'dialog :title "D1"))
|
||||
(is (= 1 (length *dialog-stack*)))
|
||||
(push-dialog (make-instance 'dialog :title "D2"))
|
||||
(is (= 2 (length *dialog-stack*)))
|
||||
(pop-dialog)
|
||||
(is (= 1 (length *dialog-stack*)))))
|
||||
|
||||
(def-test toast-create ()
|
||||
(let ((*toasts* nil))
|
||||
(toast "Hello" :variant :info :duration 0)
|
||||
(is (= 1 (length *toasts*)))))
|
||||
|
||||
(def-test toast-dismiss ()
|
||||
(let ((*toasts* (list (make-instance 'toast :message "T" :variant :info))))
|
||||
(dismiss-toast (first *toasts*))
|
||||
(is (= 0 (length *toasts*)))))
|
||||
|
||||
@@ -386,3 +386,392 @@ world")))
|
||||
(remhash :local *keymaps*)
|
||||
(is-false (gethash :global *keymaps*))
|
||||
(is-false (gethash :local *keymaps*)))
|
||||
|
||||
(defpackage :cl-tty-input-test
|
||||
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
|
||||
(:export #:run-tests))
|
||||
(in-package :cl-tty-input-test)
|
||||
|
||||
(def-suite input-suite :description "Text input and keybinding tests")
|
||||
(in-suite input-suite)
|
||||
|
||||
(defun run-tests ()
|
||||
(let ((result (run 'input-suite)))
|
||||
(fiveam:explain! result)
|
||||
(uiop:quit 0)))
|
||||
|
||||
;; ── Key Event Tests ─────────────────────────────────────────────
|
||||
|
||||
(test key-event-construction
|
||||
"A key-event can be created and queried."
|
||||
(let ((e (make-key-event :key :a :ctrl t :alt nil)))
|
||||
(is (eql (key-event-key e) :a))
|
||||
(is-true (key-event-ctrl e))
|
||||
(is-false (key-event-alt e))))
|
||||
|
||||
(test key-event-defaults
|
||||
"Fields default to NIL/nil."
|
||||
(let ((e (make-key-event :key :space)))
|
||||
(is (eql (key-event-key e) :space))
|
||||
(is-false (key-event-ctrl e))
|
||||
(is-false (key-event-alt e))
|
||||
(is-false (key-event-shift e))))
|
||||
|
||||
(test mouse-event-construction
|
||||
"A mouse-event can be created and queried."
|
||||
(let ((e (make-mouse-event :type :press :button :left :x 10 :y 5)))
|
||||
(is (eql (mouse-event-type e) :press))
|
||||
(is (eql (mouse-event-button e) :left))
|
||||
(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
|
||||
"A newly created text-input has empty value and cursor at 0."
|
||||
(let ((in (make-text-input)))
|
||||
(is (string= (text-input-value in) ""))
|
||||
(is (= (text-input-cursor in) 0))))
|
||||
|
||||
(test text-input-insert-char
|
||||
"Inserting a character appends and moves cursor."
|
||||
(let ((in (make-text-input)))
|
||||
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
|
||||
(is (string= (text-input-value in) "a"))
|
||||
(is (= (text-input-cursor in) 1))))
|
||||
|
||||
(test text-input-insert-multiple
|
||||
"Inserting multiple characters works left to right."
|
||||
(let ((in (make-text-input)))
|
||||
(handle-text-input in (make-key-event :key :h :code (char-code #\h)))
|
||||
(handle-text-input in (make-key-event :key :e :code (char-code #\e)))
|
||||
(handle-text-input in (make-key-event :key :l :code (char-code #\l)))
|
||||
(handle-text-input in (make-key-event :key :l :code (char-code #\l)))
|
||||
(handle-text-input in (make-key-event :key :o :code (char-code #\o)))
|
||||
(is (string= (text-input-value in) "hello"))
|
||||
(is (= (text-input-cursor in) 5))))
|
||||
|
||||
(test text-input-backspace
|
||||
"Backspace removes the character before the cursor."
|
||||
(let ((in (make-text-input :value "ab" :cursor 2)))
|
||||
(handle-text-input in (make-key-event :key :backspace))
|
||||
(is (string= (text-input-value in) "a"))
|
||||
(is (= (text-input-cursor in) 1))))
|
||||
|
||||
(test text-input-backspace-at-start
|
||||
"Backspace at position 0 does nothing."
|
||||
(let ((in (make-text-input :value "ab" :cursor 0)))
|
||||
(handle-text-input in (make-key-event :key :backspace))
|
||||
(is (string= (text-input-value in) "ab"))
|
||||
(is (= (text-input-cursor in) 0))))
|
||||
|
||||
(test text-input-delete
|
||||
"Delete removes the character at the cursor."
|
||||
(let ((in (make-text-input :value "abc" :cursor 1)))
|
||||
(handle-text-input in (make-key-event :key :delete))
|
||||
(is (string= (text-input-value in) "ac"))
|
||||
(is (= (text-input-cursor in) 1))))
|
||||
|
||||
(test text-input-cursor-left-right
|
||||
"Cursor moves left and right."
|
||||
(let ((in (make-text-input :value "ab" :cursor 2)))
|
||||
(handle-text-input in (make-key-event :key :left))
|
||||
(is (= (text-input-cursor in) 1))
|
||||
(handle-text-input in (make-key-event :key :right))
|
||||
(is (= (text-input-cursor in) 2))))
|
||||
|
||||
(test text-input-cursor-bounds
|
||||
"Cursor cannot move past start or end."
|
||||
(let ((in (make-text-input :value "ab" :cursor 0)))
|
||||
(handle-text-input in (make-key-event :key :left))
|
||||
(is (= (text-input-cursor in) 0))
|
||||
(setf (text-input-cursor in) 2)
|
||||
(handle-text-input in (make-key-event :key :right))
|
||||
(is (= (text-input-cursor in) 2))))
|
||||
|
||||
(test text-input-home-end
|
||||
"Home moves to start, End moves to end."
|
||||
(let ((in (make-text-input :value "hello" :cursor 3)))
|
||||
(handle-text-input in (make-key-event :key :home))
|
||||
(is (= (text-input-cursor in) 0))
|
||||
(handle-text-input in (make-key-event :key :end))
|
||||
(is (= (text-input-cursor in) 5))))
|
||||
|
||||
(test text-input-max-length
|
||||
"Max-length prevents inserting beyond the limit."
|
||||
(let ((in (make-text-input :max-length 3)))
|
||||
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
|
||||
(handle-text-input in (make-key-event :key :b :code (char-code #\b)))
|
||||
(handle-text-input in (make-key-event :key :c :code (char-code #\c)))
|
||||
(handle-text-input in (make-key-event :key :d :code (char-code #\d)))
|
||||
(is (string= (text-input-value in) "abc"))))
|
||||
|
||||
(test text-input-placeholder
|
||||
"Placeholder is stored but does not affect value."
|
||||
(let ((in (make-text-input :placeholder "Type here...")))
|
||||
(is (string= (text-input-placeholder in) "Type here..."))
|
||||
(is (string= (text-input-value in) ""))))
|
||||
|
||||
(test text-input-on-submit
|
||||
"On-submit callback fires on Enter."
|
||||
(let ((result (list nil)))
|
||||
(let ((in (make-text-input :value "hello"
|
||||
:on-submit (lambda (v) (setf (car result) v)))))
|
||||
(handle-text-input in (make-key-event :key :enter))
|
||||
(is (string= (car result) "hello")))))
|
||||
|
||||
(test text-input-ctrl-a-e
|
||||
"Ctrl+A moves to home, Ctrl+E moves to end."
|
||||
(let ((in (make-text-input :value "abc" :cursor 2)))
|
||||
(handle-text-input in (make-key-event :key :a :ctrl t))
|
||||
(is (= (text-input-cursor in) 0))
|
||||
(handle-text-input in (make-key-event :key :e :ctrl t))
|
||||
(is (= (text-input-cursor in) 3))))
|
||||
|
||||
(test text-input-insert-in-middle
|
||||
"Inserting in the middle of text shifts rest right."
|
||||
(let ((in (make-text-input :value "ab" :cursor 1)))
|
||||
(handle-text-input in (make-key-event :key :x :code (char-code #\x)))
|
||||
(is (string= (text-input-value in) "axb"))
|
||||
(is (= (text-input-cursor in) 2))))
|
||||
|
||||
(test text-input-dirty-on-insert
|
||||
"Inserting marks the widget dirty."
|
||||
(let ((in (make-text-input)))
|
||||
(mark-clean in)
|
||||
(handle-text-input in (make-key-event :key :a :code (char-code #\a)))
|
||||
(is-true (dirty-p in))))
|
||||
|
||||
;; ── Textarea Tests ──────────────────────────────────────────────
|
||||
|
||||
(test textarea-empty
|
||||
"New textarea has empty value and cursor at (0,0)."
|
||||
(let ((a (make-textarea)))
|
||||
(is (string= (textarea-value a) ""))
|
||||
(is (= (textarea-cursor-row a) 0))
|
||||
(is (= (textarea-cursor-col a) 0))))
|
||||
|
||||
(test textarea-newline
|
||||
"Enter inserts a newline."
|
||||
(let ((a (make-textarea)))
|
||||
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
|
||||
(handle-textarea-input a (make-key-event :key :enter))
|
||||
(handle-textarea-input a (make-key-event :key :b :code (char-code #\b)))
|
||||
(is (string= (textarea-value a) "a
|
||||
b"))))
|
||||
|
||||
(test textarea-cursor-up-down
|
||||
"Cursor moves between lines maintaining column position."
|
||||
(let ((a (make-textarea :value "abc
|
||||
de
|
||||
fghi")))
|
||||
(setf (textarea-cursor-row a) 1)
|
||||
(setf (textarea-cursor-col a) 1)
|
||||
(handle-textarea-input a (make-key-event :key :up))
|
||||
(is (= (textarea-cursor-row a) 0))
|
||||
(is (= (textarea-cursor-col a) 1))
|
||||
(handle-textarea-input a (make-key-event :key :down))
|
||||
(is (= (textarea-cursor-row a) 1))
|
||||
(is (= (textarea-cursor-col a) 1))))
|
||||
|
||||
(test textarea-cursor-up-down-bounds
|
||||
"Cursor cannot move past first or last line."
|
||||
(let ((a (make-textarea :value "a
|
||||
b")))
|
||||
(handle-textarea-input a (make-key-event :key :up))
|
||||
(is (= (textarea-cursor-row a) 0))
|
||||
(setf (textarea-cursor-row a) 1)
|
||||
(handle-textarea-input a (make-key-event :key :down))
|
||||
(is (= (textarea-cursor-row a) 1))))
|
||||
|
||||
(test textarea-backspace-joins-lines
|
||||
"Backspace at start of a line joins with previous."
|
||||
(let ((a (make-textarea :value "hello
|
||||
world")))
|
||||
(setf (textarea-cursor-row a) 1)
|
||||
(setf (textarea-cursor-col a) 0)
|
||||
(handle-textarea-input a (make-key-event :key :backspace))
|
||||
(is (string= (textarea-value a) "helloworld"))))
|
||||
|
||||
(test textarea-undo
|
||||
"Ctrl+Z undoes the last edit."
|
||||
(let ((a (make-textarea)))
|
||||
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
|
||||
(handle-textarea-input a (make-key-event :key :z :ctrl t))
|
||||
(is (string= (textarea-value a) ""))))
|
||||
|
||||
(test textarea-undo-redo
|
||||
"Ctrl+Y redoes an undone edit."
|
||||
(let ((a (make-textarea)))
|
||||
(handle-textarea-input a (make-key-event :key :a :code (char-code #\a)))
|
||||
(handle-textarea-input a (make-key-event :key :z :ctrl t))
|
||||
(handle-textarea-input a (make-key-event :key :y :ctrl t))
|
||||
(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."
|
||||
(let ((called nil))
|
||||
(setf (gethash :global *keymaps*)
|
||||
(make-keymap :name :global
|
||||
:bindings `((:ctrl+p . ,(lambda (e)
|
||||
(declare (ignore e))
|
||||
(setf called t))))))
|
||||
(is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))
|
||||
(is-true called)))
|
||||
|
||||
(test keymap-no-match
|
||||
"Non-matching event returns nil."
|
||||
(let ((called nil))
|
||||
(setf (gethash :global *keymaps*)
|
||||
(make-keymap :name :global
|
||||
:bindings `((:ctrl+p . ,(lambda (e)
|
||||
(declare (ignore e))
|
||||
(setf called t))))))
|
||||
(is-false (dispatch-key-event (make-key-event :key :a)))
|
||||
(is-false called)))
|
||||
|
||||
(test keymap-fallback
|
||||
"Event not in local falls through to global."
|
||||
(let ((global-called nil))
|
||||
(setf (gethash :global *keymaps*)
|
||||
(make-keymap :name :global
|
||||
:bindings `((:ctrl+q . ,(lambda (e)
|
||||
(declare (ignore e))
|
||||
(setf global-called t))))))
|
||||
(dispatch-key-event (make-key-event :key :q :ctrl t))
|
||||
(is-true global-called)))
|
||||
|
||||
(test key-spec-simple
|
||||
"Keyword key-spec matches key+ctrl."
|
||||
(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)))
|
||||
(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))
|
||||
(eval `(defkeymap :global
|
||||
(: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*)))
|
||||
|
||||
@@ -47,3 +47,53 @@
|
||||
(let ((text (finalize-selection fb)))
|
||||
(is (equal "hello
|
||||
world" text)))))
|
||||
|
||||
(defpackage :cl-tty-mouse-test (:use :cl :cl-tty.mouse :fiveam))
|
||||
(in-package :cl-tty-mouse-test)
|
||||
|
||||
(def-suite mouse-suite :description "Mouse tests")
|
||||
(in-suite mouse-suite)
|
||||
|
||||
(def-test mouse-mixin-create ()
|
||||
(let ((m (make-instance 'mouse-mixin)))
|
||||
(is-true (typep m 'mouse-mixin))))
|
||||
|
||||
(def-test mouse-hit-test-point ()
|
||||
"hit-test returns nil when no component has position slots bound"
|
||||
(let ((obj (make-instance 'mouse-mixin)))
|
||||
(is-false (hit-test obj 0 0))
|
||||
(is-false (hit-test obj 100 100))))
|
||||
|
||||
(def-test selection-set-and-get ()
|
||||
(setf cl-tty.mouse::*selection* (make-selection :text "hello"))
|
||||
(is (equal "hello" (get-selection))))
|
||||
|
||||
;; ── Selection tracking ──────────────────────────────────────
|
||||
|
||||
(def-test start-selection-initializes-state ()
|
||||
(start-selection 5 10)
|
||||
(is-true (selection-active-p))
|
||||
(is (equal '(5 . 10) cl-tty.mouse::*selection-start*))
|
||||
(is (equal '(5 . 10) cl-tty.mouse::*selection-end*))
|
||||
(setf cl-tty.mouse::*selection-active* nil
|
||||
cl-tty.mouse::*selection-start* nil
|
||||
cl-tty.mouse::*selection-end* nil))
|
||||
|
||||
(def-test update-selection-moves-end ()
|
||||
(start-selection 0 0)
|
||||
(update-selection 3 7)
|
||||
(is (equal '(3 . 7) cl-tty.mouse::*selection-end*))
|
||||
(setf cl-tty.mouse::*selection-active* nil
|
||||
cl-tty.mouse::*selection-start* nil
|
||||
cl-tty.mouse::*selection-end* nil))
|
||||
|
||||
(def-test finalize-selection-extracts-text ()
|
||||
(let* ((fb-be (cl-tty.rendering:make-framebuffer-backend))
|
||||
(fb (cl-tty.rendering:fb-framebuffer fb-be)))
|
||||
(cl-tty.backend:draw-text fb-be 0 0 "hello" nil nil)
|
||||
(cl-tty.backend:draw-text fb-be 0 1 "world" nil nil)
|
||||
(start-selection 0 0)
|
||||
(update-selection 4 1)
|
||||
(let ((text (finalize-selection fb)))
|
||||
(is (equal "hello
|
||||
world" text)))))
|
||||
|
||||
@@ -126,3 +126,132 @@
|
||||
(setf (scroll-box-scroll-y sb) 1000000)
|
||||
(clamp-scroll sb)
|
||||
(is (= (scroll-box-scroll-y sb) 0) "clamps above max (no children = 0 content)")))
|
||||
|
||||
(defpackage :cl-tty-scrollbox-test
|
||||
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container)
|
||||
(:export #:run-tests))
|
||||
(in-package #:cl-tty-scrollbox-test)
|
||||
|
||||
(def-suite scrollbox-suite :description "ScrollBox + TabBar tests")
|
||||
(in-suite scrollbox-suite)
|
||||
|
||||
(defun run-tests ()
|
||||
(let ((result (run 'scrollbox-suite)))
|
||||
(fiveam:explain! result)
|
||||
(uiop:quit 0)))
|
||||
|
||||
;; ── ScrollBox Tests ─────────────────────────────────────────────
|
||||
|
||||
(test scrollbox-creates
|
||||
"A ScrollBox can be created with defaults."
|
||||
(let ((sb (make-scroll-box)))
|
||||
(is (typep sb 'scroll-box))
|
||||
(is (= (scroll-box-scroll-y sb) 0))
|
||||
(is (= (scroll-box-scroll-x sb) 0))
|
||||
(is-false (scroll-box-children sb))))
|
||||
|
||||
(test scrollbox-with-children
|
||||
"A ScrollBox can have children."
|
||||
(let ((sb (make-scroll-box :children (list (make-text "hello")))))
|
||||
(is (= (length (scroll-box-children sb)) 1))))
|
||||
|
||||
(test scrollbox-scroll-by
|
||||
"ScrollBy adjusts offset clamped to valid range."
|
||||
(let ((sb (make-scroll-box :scroll-y 0)))
|
||||
(scroll-by sb 5 0)
|
||||
(is (>= (scroll-box-scroll-y sb) 0))))
|
||||
|
||||
(test scrollbox-component-children
|
||||
"Component protocol: children are accessible."
|
||||
(let* ((child (make-text "hello"))
|
||||
(sb (make-scroll-box :children (list child))))
|
||||
(is (eql (first (component-children sb)) child))))
|
||||
|
||||
(test scrollbox-render-noop
|
||||
"Rendering a ScrollBox with no children does not error."
|
||||
(let* ((stream (make-string-output-stream))
|
||||
(backend (make-simple-backend :output-stream stream))
|
||||
(sb (make-scroll-box)))
|
||||
(render sb backend)
|
||||
(is-true t)))
|
||||
|
||||
;; ── TabBar Tests ────────────────────────────────────────────────
|
||||
|
||||
(test tabbar-creates
|
||||
"A TabBar can be created with defaults."
|
||||
(let ((tb (make-tab-bar)))
|
||||
(is (typep tb 'tab-bar))
|
||||
(is-false (tab-bar-active tb))
|
||||
(is-false (tab-bar-tabs tb))))
|
||||
|
||||
(test tabbar-add-tab
|
||||
"Adding a tab returns the id and updates tabs."
|
||||
(let ((tb (make-tab-bar)))
|
||||
(let ((id (tab-bar-add tb :tab1 "Tab One")))
|
||||
(is (eql id :tab1))
|
||||
(is (= (length (tab-bar-tabs tb)) 1))
|
||||
(is (string= (getf (first (tab-bar-tabs tb)) :title) "Tab One")))))
|
||||
|
||||
(test tabbar-active-tab
|
||||
"Setting active tab works."
|
||||
(let ((tb (make-tab-bar)))
|
||||
(tab-bar-add tb :tab1 "One")
|
||||
(tab-bar-add tb :tab2 "Two")
|
||||
(setf (tab-bar-active tb) :tab2)
|
||||
(is (eql (tab-bar-active tb) :tab2))))
|
||||
|
||||
(test tabbar-render-noop
|
||||
"Rendering a TabBar does not error."
|
||||
(let* ((stream (make-string-output-stream))
|
||||
(backend (make-simple-backend :output-stream stream))
|
||||
(tb (make-tab-bar)))
|
||||
(tab-bar-add tb :tab1 "One")
|
||||
(tab-bar-add tb :tab2 "Two")
|
||||
(setf (tab-bar-active tb) :tab1)
|
||||
(render tb backend)
|
||||
(is-true t)))
|
||||
|
||||
(test tabbar-next-prev
|
||||
"TabBar next/prev wraps around through tabs."
|
||||
(let ((tb (make-tab-bar)))
|
||||
(tab-bar-add tb :tab1 "One")
|
||||
(tab-bar-add tb :tab2 "Two")
|
||||
(tab-bar-add tb :tab3 "Three")
|
||||
(is (eql (tab-bar-active tb) :tab1))
|
||||
(tab-bar-next tb)
|
||||
(is (eql (tab-bar-active tb) :tab2))
|
||||
(tab-bar-next tb)
|
||||
(is (eql (tab-bar-active tb) :tab3))
|
||||
(tab-bar-next tb)
|
||||
(is (eql (tab-bar-active tb) :tab1) "wrap around past last")
|
||||
(tab-bar-prev tb)
|
||||
(is (eql (tab-bar-active tb) :tab3) "wrap around past first")))
|
||||
|
||||
(test tabbar-select
|
||||
"TabBar select activates the specified tab."
|
||||
(let ((tb (make-tab-bar)))
|
||||
(tab-bar-add tb :tab1 "One")
|
||||
(tab-bar-add tb :tab2 "Two")
|
||||
(tab-bar-select tb :tab2)
|
||||
(is (eql (tab-bar-active tb) :tab2))))
|
||||
|
||||
(test tabbar-handle-key
|
||||
"TabBar handle-key dispatches left/right."
|
||||
(let ((tb (make-tab-bar)))
|
||||
(tab-bar-add tb :tab1 "One")
|
||||
(tab-bar-add tb :tab2 "Two")
|
||||
(setf (tab-bar-active tb) :tab1)
|
||||
(tab-bar-handle-key tb (make-key-event :key :right))
|
||||
(is (eql (tab-bar-active tb) :tab2))
|
||||
(tab-bar-handle-key tb (make-key-event :key :left))
|
||||
(is (eql (tab-bar-active tb) :tab1))))
|
||||
|
||||
(test scrollbox-scroll-clamp
|
||||
"ScrollBox clamp prevents scrolling past bounds."
|
||||
(let ((sb (make-scroll-box :scroll-y 5 :scroll-x 3)))
|
||||
(setf (scroll-box-scroll-y sb) -1)
|
||||
(clamp-scroll sb)
|
||||
(is (= (scroll-box-scroll-y sb) 0) "clamps below 0")
|
||||
(setf (scroll-box-scroll-y sb) 1000000)
|
||||
(clamp-scroll sb)
|
||||
(is (= (scroll-box-scroll-y sb) 0) "clamps above max (no children = 0 content)")))
|
||||
|
||||
@@ -118,3 +118,124 @@
|
||||
(let ((filtered (select-filtered-options sel)))
|
||||
(is (= (length filtered) 1))
|
||||
(is (eql (getf (third (first filtered)) :value) :nord)))))
|
||||
|
||||
(defpackage :cl-tty-select-test
|
||||
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.select)
|
||||
(:export #:run-tests))
|
||||
(in-package #:cl-tty-select-test)
|
||||
|
||||
(def-suite select-suite :description "Select widget tests")
|
||||
(in-suite select-suite)
|
||||
|
||||
(defun run-tests ()
|
||||
(let ((result (run 'select-suite)))
|
||||
(fiveam:explain! result)
|
||||
(uiop:quit 0)))
|
||||
|
||||
(test select-creates
|
||||
"A Select can be created with defaults."
|
||||
(let ((sel (make-select)))
|
||||
(is (typep sel 'select))
|
||||
(is-false (select-options sel))
|
||||
(is-false (select-filter sel))
|
||||
(is (= (select-selected-index sel) 0))))
|
||||
|
||||
(test select-with-options
|
||||
"A Select stores options."
|
||||
(let ((sel (make-select :options '((:title "Red" :value :red)
|
||||
(:title "Blue" :value :blue)))))
|
||||
(is (= (length (select-options sel)) 2))))
|
||||
|
||||
(test select-filtered-exact
|
||||
"Filter returns case-insensitive substring matches."
|
||||
(let ((sel (make-select
|
||||
:options '((:title "Red" :value :red)
|
||||
(:title "Green" :value :green)
|
||||
(:title "Blue" :value :blue)))))
|
||||
(setf (select-filter sel) "bl")
|
||||
(let ((filtered (select-filtered-options sel)))
|
||||
(is (= (length filtered) 1))
|
||||
(is (eql (getf (third (first filtered)) :value) :blue)))))
|
||||
|
||||
(test select-filtered-all
|
||||
"Nil filter returns all options."
|
||||
(let ((sel (make-select
|
||||
:options '((:title "Red" :value :red)
|
||||
(:title "Blue" :value :blue)))))
|
||||
(let ((filtered (select-filtered-options sel)))
|
||||
(is (= (length filtered) 2)))))
|
||||
|
||||
(test select-navigation
|
||||
"Select-next and select-prev navigate through options."
|
||||
(let ((sel (make-select
|
||||
:options '((:title "A" :value :a)
|
||||
(:title "B" :value :b)
|
||||
(:title "C" :value :c)))))
|
||||
(is (= (select-selected-index sel) 0))
|
||||
(select-next sel)
|
||||
(is (= (select-selected-index sel) 1))
|
||||
(select-next sel)
|
||||
(is (= (select-selected-index sel) 2))
|
||||
(select-next sel)
|
||||
(is (= (select-selected-index sel) 0) "wraps forward")
|
||||
(select-prev sel)
|
||||
(is (= (select-selected-index sel) 2) "wraps backward")))
|
||||
|
||||
(test select-navigation-skips-categories
|
||||
"Navigation skips category header options."
|
||||
(let ((sel (make-select
|
||||
:options '((:title "Colors" :category t)
|
||||
(:title "Red" :value :red)
|
||||
(:title "Green" :value :green)
|
||||
(:title "Shapes" :category t)
|
||||
(:title "Circle" :value :circle)))))
|
||||
(is (= (select-selected-index sel) 0))
|
||||
(select-next sel)
|
||||
(is (= (select-selected-index sel) 1) "skipped category header at 0")
|
||||
(select-next sel)
|
||||
(is (= (select-selected-index sel) 2))
|
||||
(select-next sel)
|
||||
(is (= (select-selected-index sel) 4) "skipped category header at 3")))
|
||||
|
||||
(test select-handle-key
|
||||
"Select handle-key dispatches navigation and selection."
|
||||
(let* ((result (list nil))
|
||||
(sel (make-select
|
||||
:options '((:title "A" :value :a) (:title "B" :value :b))
|
||||
:on-select (lambda (opt) (setf (car result) (getf opt :value))))))
|
||||
(select-handle-key sel (make-key-event :key :down))
|
||||
(is (= (select-selected-index sel) 1))
|
||||
(select-handle-key sel (make-key-event :key :up))
|
||||
(is (= (select-selected-index sel) 0))
|
||||
(select-handle-key sel (make-key-event :key :enter))
|
||||
(is (eql (car result) :a))))
|
||||
|
||||
(test select-handle-key-ctrl
|
||||
"Ctrl+N and Ctrl+P navigate like down/up."
|
||||
(let ((sel (make-select
|
||||
:options '((:title "A" :value :a) (:title "B" :value :b) (:title "C" :value :c)))))
|
||||
(select-handle-key sel (make-key-event :key :n :ctrl t))
|
||||
(is (= (select-selected-index sel) 1))
|
||||
(select-handle-key sel (make-key-event :key :p :ctrl t))
|
||||
(is (= (select-selected-index sel) 0))))
|
||||
|
||||
(test select-visible-count
|
||||
"Visible options respects viewport height."
|
||||
(let* ((ln (make-layout-node))
|
||||
(sel (make-select
|
||||
:options (loop for i below 20 collect (list :title (format nil "Item ~D" i) :value i)))))
|
||||
(setf (select-layout-node sel) ln)
|
||||
(setf (layout-node-height ln) 5)
|
||||
(let ((visible (select-visible-options sel)))
|
||||
(is (<= (length visible) 5)))))
|
||||
|
||||
(test select-fuzzy-fallback
|
||||
"Fuzzy filter catches near-misses."
|
||||
(let ((sel (make-select
|
||||
:options '((:title "Nord" :value :nord)
|
||||
(:title "Tokyo Night" :value :tokyo)
|
||||
(:title "Catppuccin" :value :cat)))))
|
||||
(setf (select-filter sel) "nrd")
|
||||
(let ((filtered (select-filtered-options sel)))
|
||||
(is (= (length filtered) 1))
|
||||
(is (eql (getf (third (first filtered)) :value) :nord)))))
|
||||
|
||||
@@ -52,3 +52,30 @@
|
||||
(let ((result (slot-render :args-slot 3 4)))
|
||||
(is (equal '("3+4") result)))
|
||||
(clear-slot :args-slot))
|
||||
|
||||
(defpackage :cl-tty-slot-test (:use :cl :cl-tty.slot :fiveam))
|
||||
(in-package :cl-tty-slot-test)
|
||||
|
||||
(def-suite slot-suite :description "Slot system tests")
|
||||
(in-suite slot-suite)
|
||||
|
||||
(def-test defslot-register ()
|
||||
(clear-slot :test-slot)
|
||||
(defslot :test-slot :order 1 :render-fn (lambda () "hello"))
|
||||
(is-true (slot-p :test-slot)))
|
||||
|
||||
(def-test slot-render-calls ()
|
||||
(clear-slot :test-slot)
|
||||
(defslot :test-slot :order 1 :render-fn (lambda () "a"))
|
||||
(defslot :test-slot :order 2 :render-fn (lambda () "b"))
|
||||
(is (equal '("a" "b") (slot-render :test-slot))))
|
||||
|
||||
(def-test slot-render-empty ()
|
||||
(clear-slot :ghost)
|
||||
(is-false (slot-render :ghost)))
|
||||
|
||||
(def-test clear-slot-removes ()
|
||||
(clear-slot :test-slot)
|
||||
(defslot :test-slot :order 1 :render-fn (lambda () "x"))
|
||||
(clear-slot :test-slot)
|
||||
(is-false (slot-p :test-slot)))
|
||||
|
||||
Reference in New Issue
Block a user