diff --git a/backend/detection.lisp b/backend/detection.lisp index 2ece52a..7197913 100644 --- a/backend/detection.lisp +++ b/backend/detection.lisp @@ -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))))) diff --git a/org/detection.org b/org/detection.org index e5ffc97..3c0bbb9 100644 --- a/org/detection.org +++ b/org/detection.org @@ -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))) diff --git a/org/dialog.org b/org/dialog.org index 688b85d..47882a8 100644 --- a/org/dialog.org +++ b/org/dialog.org @@ -64,24 +64,49 @@ inside the dialog panel), its size preset, title, and callbacks. --- per-function: dialog-size-pixels -Helper to convert size keyword to pixel dimensions. +Helper to convert size keyword to pixel dimensions, clamped to available +terminal dimensions. + +*** Bug Fixes (v1.0.0): dialog size clamp and draw-border keyword + +Three bugs were fixed: + +1. *Unclamped dialog size*: ~dialog-size-pixels~ returned fixed sizes + (~:large~ = 88x24) that could exceed the terminal dimensions, causing + the dialog panel to overflow off-screen. + + Fix: ~dialog-size-pixels~ now accepts optional ~max-w~ and ~max-h~ + parameters and clamps the result to those bounds using ~(min ...)~. + +2. *render-dialog not passing dimensions*: ~render-dialog~ called + ~dialog-size-pixels~ with only the size keyword, so terminal dimensions + were never forwarded for clamping. + + Fix: ~render-dialog~ now passes ~w h~ to ~dialog-size-pixels~. + +3. *draw-border keyword style*: The ~draw-border~ call used a bare ~:single~ + keyword for the border style. The function signature expects ~:style :single~. + + Fix: Changed ~:single~ to ~:style :single~. #+BEGIN_SRC lisp :tangle no -(defun dialog-size-pixels (size) - (case size - (:small (values 40 8)) - (:medium (values 60 16)) - (:large (values 88 24)) - (t (values 60 16)))) +(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24)) + (multiple-value-bind (dw dh) + (case size + (:small (values 40 8)) + (:medium (values 60 16)) + (:large (values 88 24)) + (t (values 60 16))) + (values (min dw max-w) (min dh max-h)))) #+END_SRC ---- per-function: render-dialog +|--- per-function: render-dialog Render a dialog: backdrop (dimmed full-screen), then centered panel. #+BEGIN_SRC lisp :tangle no (defun render-dialog (dialog screen w h) - (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) + (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h) (let ((x (floor (- w dw) 2)) (y (floor (- h dh) 2))) ;; Backdrop — draw dim characters over full screen @@ -89,7 +114,7 @@ Render a dialog: backdrop (dimmed full-screen), then centered panel. (dotimes (col w) (backend-write screen col row " " :bg :dim))) ;; Panel border - (draw-border screen x y dw dh :single :title (dialog-title dialog)) + (draw-border screen x y dw dh :style :single :title (dialog-title dialog)) ;; Content area (inset by 1 on each side) (when (dialog-content dialog) (render-component (dialog-content dialog) screen (1+ x) (1+ y) (- dw 2) (- dh 2)))))) @@ -288,7 +313,7 @@ Remove a toast from the list. ;;; dialog-package.lisp — Package definition for cl-tty.dialog (defpackage :cl-tty.dialog - (:use :cl :cl-tty.input :cl-tty.select) + (:use :cl :cl-tty.backend :cl-tty.input :cl-tty.select) (:export #:dialog #:dialog-title @@ -333,22 +358,24 @@ Remove a toast from the list. (content :initarg :content :initform nil :accessor dialog-content) (on-dismiss :initarg :on-dismiss :initform nil :accessor dialog-on-dismiss))) -(defun dialog-size-pixels (size) - (case size - (:small (values 40 8)) - (:medium (values 60 16)) - (:large (values 88 24)) - (t (values 60 16)))) +(defun dialog-size-pixels (size &optional (max-w 80) (max-h 24)) + (multiple-value-bind (dw dh) + (case size + (:small (values 40 8)) + (:medium (values 60 16)) + (:large (values 88 24)) + (t (values 60 16))) + (values (min dw max-w) (min dh max-h)))) (defun render-dialog (dialog screen w h) - (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog)) + (multiple-value-bind (dw dh) (dialog-size-pixels (dialog-size dialog) w h) (let ((x (floor (- w dw) 2)) (y (floor (- h dh) 2))) ;; Backdrop — dim the full screen (dotimes (row h) (draw-rect screen 0 row w 1 :bg :bright-black)) ;; Dialog panel - (draw-border screen x y dw dh :single :title (dialog-title dialog)) + (draw-border screen x y dw dh :style :single :title (dialog-title dialog)) (when (dialog-content dialog) ;; Content rendering delegated to component system (draw-text screen (1+ x) (1+ y) diff --git a/org/mouse.org b/org/mouse.org index 90e2545..cbd169c 100644 --- a/org/mouse.org +++ b/org/mouse.org @@ -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) --------------------------------------- diff --git a/org/scrollbox-tabbar.org b/org/scrollbox-tabbar.org index 9a1de21..df867fd 100644 --- a/org/scrollbox-tabbar.org +++ b/org/scrollbox-tabbar.org @@ -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) diff --git a/org/slot.org b/org/slot.org index d3e28d7..3e01865 100644 --- a/org/slot.org +++ b/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*))) diff --git a/org/text-input.org b/org/text-input.org index b2fbfe0..72cfc29 100644 --- a/org/text-input.org +++ b/org/text-input.org @@ -445,11 +445,11 @@ terminal raw mode, TextInput, Textarea, and the keybinding system. ;; Textarea #:textarea #:make-textarea #:textarea-value #:textarea-cursor-row #:textarea-cursor-col + #:textarea-lines #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack #:textarea-layout-node #:handle-textarea-input #:render-textarea ;; Keybindings - #:keymap #:make-keymap #:keymap-name #:keymap-bindings #:keymap-parent #:*keymaps* #:*chord-timeout* #:defkeymap #:dispatch-key-event #:key-match-p #:component-keymap)) @@ -656,7 +656,8 @@ debugging argument mismatches — avoid that trap. (max 0 (min (textarea-cursor-row ta) (1- (length lines))))) (let ((line-len (length (nth (textarea-cursor-row ta) lines)))) (setf (textarea-cursor-col ta) - (max 0 (min (textarea-cursor-col ta) line-len)))))) + (max 0 (min (textarea-cursor-col ta) line-len))))) + (mark-dirty ta)) ;;; --------------------------------------------------------------------------- ;;; Utility: join strings with newline @@ -824,11 +825,13 @@ debugging argument mismatches — avoid that trap. (textarea-ensure-cursor ta)) (:up (textarea-move-up ta)) (:down (textarea-move-down ta)) - (:home (setf (textarea-cursor-col ta) 0)) - (:end (let ((lines (textarea-lines ta))) - (when (< (textarea-cursor-row ta) (length lines)) - (setf (textarea-cursor-col ta) - (length (nth (textarea-cursor-row ta) lines)))))) + (:home (setf (textarea-cursor-col ta) 0) + (textarea-ensure-cursor ta)) + (:end (let ((lines (textarea-lines ta))) + (when (< (textarea-cursor-row ta) (length lines)) + (setf (textarea-cursor-col ta) + (length (nth (textarea-cursor-row ta) lines)))) + (textarea-ensure-cursor ta))) (:enter (let ((cb (textarea-on-submit ta))) (if cb (funcall cb (textarea-value ta)) @@ -923,6 +926,21 @@ debugging argument mismatches — avoid that trap. ;;; --------------------------------------------------------------------------- ;;; Dispatch ;;; --------------------------------------------------------------------------- +;;; dispatch-key-event — main entry point for keymap-based dispatch. +;;; +;;; IMPORTANT: This function is NOT called by the demo's event loop +;;; or by any built-in widget event handlers. Users who want to use +;;; the keymap system MUST call dispatch-key-event explicitly in their +;;; own event loops, e.g.: +;;; +;;; (defun handle-event (event) +;;; (or (dispatch-key-event event) +;;; (handle-text-input my-input event) +;;; ...)) +;;; +;;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single +;;; key specs work. The *chord-timeout* and list-of-lists syntax +;;; are reserved for future implementation. (defun dispatch-key-event (event &key component) (labels ((try-keymap (km) (when km @@ -974,6 +992,8 @@ debugging argument mismatches — avoid that trap. #:with-raw-terminal ;; Event reading #:read-event + ;; UTF-8 input support + #:utf8-decode ;; TextInput #:text-input #:make-text-input #:text-input-value #:text-input-cursor @@ -983,6 +1003,7 @@ debugging argument mismatches — avoid that trap. ;; Textarea #:textarea #:make-textarea #:textarea-value #:textarea-cursor-row #:textarea-cursor-col + #:textarea-lines #:textarea-on-submit #:textarea-undo-stack #:textarea-redo-stack #:textarea-layout-node #:handle-textarea-input #:render-textarea @@ -1034,6 +1055,28 @@ debugging argument mismatches — avoid that trap. (is (= (mouse-event-x e) 10)) (is (= (mouse-event-y e) 5)))) +;; ── UTF-8 Decode Tests ────────────────────────────────────────── + +(test utf8-decode-latin1-supplement + "0xC3 0xA9 (é) decodes to code point 233." + (is (= (cl-tty.input:utf8-decode '(#xc3 #xa9)) 233))) + +(test utf8-decode-euro-sign + "0xE2 0x82 0xAC (€) decodes to code point 8364." + (is (= (cl-tty.input:utf8-decode '(#xe2 #x82 #xac)) 8364))) + +(test utf8-decode-emoji + "0xF0 0x9F 0x92 0xA9 (💩) decodes to code point 128169." + (is (= (cl-tty.input:utf8-decode '(#xf0 #x9f #x92 #xa9)) 128169))) + +(test utf8-decode-invalid-short + "Invalid byte 0x80 alone returns nil." + (is-false (cl-tty.input:utf8-decode '(#x80)))) + +(test utf8-decode-invalid-overlong + "Overlong 2-byte sequence 0xC0 0x80 returns nil." + (is-false (cl-tty.input:utf8-decode '(#xc0 #x80)))) + ;; ── TextInput Tests ───────────────────────────────────────────── (test text-input-empty @@ -1218,6 +1261,15 @@ world"))) (is (string= (textarea-value a) "a")))) ;; ── Keybinding Tests ──────────────────────────────────────────── +;; These tests verify the keymap dispatch system works correctly +;; when wired up. Note: dispatch-key-event is NOT called by the +;; demo's event loop — users MUST call it explicitly in their own +;; event loops if they want to use the defkeymap/dispatch-key-event +;; system. See src/components/keybindings.lisp for details. +;; +;; Chords ((:ctrl+x :ctrl+s)) are not yet supported; only single +;; key specs work. The *chord-timeout* variable and list-of-lists +;; syntax are reserved for future implementation. (test keymap-simple "A keymap dispatches to its handler on matching event." @@ -1258,6 +1310,78 @@ world"))) (is-false (key-match-p :ctrl+p (make-key-event :key :a :ctrl t))) (is-false (key-match-p :ctrl+p (make-key-event :key :p)))) +(test key-spec-alt-modifier + "Alt modifier is matched correctly." + (is-true (key-match-p :alt+x (make-key-event :key :x :alt t))) + (is-false (key-match-p :alt+x (make-key-event :key :x))) + (is-false (key-match-p :alt+x (make-key-event :key :x :ctrl t)))) + +(test key-spec-shift-modifier + "Shift modifier is matched correctly." + (is-true (key-match-p :shift+tab (make-key-event :key :tab :shift t))) + (is-false (key-match-p :shift+tab (make-key-event :key :tab)))) + +(test key-spec-plain + "Plain key spec matches unmodified keys." + (is-true (key-match-p :enter (make-key-event :key :enter))) + (is-true (key-match-p :escape (make-key-event :key :escape))) + (is-false (key-match-p :enter (make-key-event :key :escape)))) + +(test key-spec-list-form + "List-form spec (:ctrl+p) matches same as keyword :ctrl+p." + (is-true (key-match-p '(:ctrl+p) (make-key-event :key :p :ctrl t))) + (is-false (key-match-p '(:ctrl+p) (make-key-event :key :a :ctrl t)))) + +(test dispatch-return-value-match + "dispatch-key-event returns T on matching binding." + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) + (is-true (dispatch-key-event (make-key-event :key :p :ctrl t)))) + +(test dispatch-return-value-no-match + "dispatch-key-event returns NIL when no binding matches." + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) (declare (ignore e))))))) + (is-false (dispatch-key-event (make-key-event :key :a)))) + +(test dispatch-empty-keymap + "dispatch-key-event returns NIL on empty keymap." + (setf (gethash :global *keymaps*) (make-keymap :name :global)) + (is-false (dispatch-key-event (make-key-event :key :a)))) + +(test dispatch-local-overrides-global + "Local keymap takes priority over global." + (let ((local-called nil) (global-called nil)) + (setf (gethash :local *keymaps*) + (make-keymap :name :local + :bindings `((:ctrl+p . ,(lambda (e) + (declare (ignore e)) + (setf local-called t)))))) + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+p . ,(lambda (e) + (declare (ignore e)) + (setf global-called t)))))) + (is-true (dispatch-key-event (make-key-event :key :p :ctrl t))) + (is-true local-called) + (is-false global-called))) + +(test dispatch-multiple-bindings + "dispatch-key-event finds the right binding among many." + (let ((called nil)) + (setf (gethash :global *keymaps*) + (make-keymap :name :global + :bindings `((:ctrl+a . (lambda (e) (declare (ignore e)))) + (:ctrl+b . (lambda (e) (declare (ignore e)))) + (:ctrl+c . ,(lambda (e) + (declare (ignore e)) + (setf called t))) + (:ctrl+d . (lambda (e) (declare (ignore e))))))) + (is-true (dispatch-key-event (make-key-event :key :c :ctrl t))) + (is-true called))) + (test defkeymap-macro "defkeymap macro registers a keymap." (let ((called nil)) @@ -1265,4 +1389,21 @@ world"))) (:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t))))) (dispatch-key-event (make-key-event :key :q :ctrl t)) (is-true called))) + +(test defkeymap-macro-with-list-spec + "defkeymap macro works with list-form specs." + (let ((called nil)) + (eval `(defkeymap :global + ((:ctrl+w) ,(lambda (e) (declare (ignore e)) (setf called t))))) + (dispatch-key-event (make-key-event :key :w :ctrl t)) + (is-true called))) + +;; cleanup after keybinding tests +(test keybinding-cleanup-global + "Clean up global keymap after testing." + (remhash :global *keymaps*) + (remhash :local *keymaps*) + (is-false (gethash :global *keymaps*)) + (is-false (gethash :local *keymaps*))) + #+END_SRC \ No newline at end of file diff --git a/scripts/tangle.py b/scripts/tangle.py index da6df2f..6426442 100755 --- a/scripts/tangle.py +++ b/scripts/tangle.py @@ -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 -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() - - # 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) - - if not blocks: - return 0 - - # 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()) - - 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')] - else: - org_files = [os.path.join(ORG_DIR, f) for f in os.listdir(ORG_DIR) if f.endswith('.org')] - - 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 - - if total_blocks > 0: - print(f"\nTotal: {total_blocks} code blocks tangled") - else: - print("No tangle blocks found.") + text = f.read() + + # Find all #+BEGIN_SRC blocks with :tangle + pattern = re.compile( + r'#\+BEGIN_SRC\s+(\w+)\s+(.*?)\n(.*?)\n#\+END_SRC', + re.DOTALL + ) + + count = 0 + for match in pattern.finditer(text): + lang = match.group(1) + header = match.group(2) + content = match.group(3) + + # Extract :tangle path + tangle_match = re.search(r':tangle\s+(\S+)', header) + if not tangle_match: + continue + tangle_path = tangle_match.group(1) + + # Resolve relative path + if tangle_path.startswith('../'): + target = os.path.normpath(os.path.join(os.path.dirname(org_path), tangle_path)) + else: + target = os.path.join(ORG_DIR, tangle_path) + + # Ensure directory exists + os.makedirs(os.path.dirname(target), exist_ok=True) + + # 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: + 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") diff --git a/src/components/container-package.lisp b/src/components/container-package.lisp index cc4e61a..1ff58f7 100644 --- a/src/components/container-package.lisp +++ b/src/components/container-package.lisp @@ -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)) diff --git a/src/components/dialog-package.lisp b/src/components/dialog-package.lisp index d3e5712..33f044e 100644 --- a/src/components/dialog-package.lisp +++ b/src/components/dialog-package.lisp @@ -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*)) diff --git a/src/components/dialog.lisp b/src/components/dialog.lisp index 01fd3de..0a8cc05 100644 --- a/src/components/dialog.lisp +++ b/src/components/dialog.lisp @@ -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*))) diff --git a/src/components/input-package.lisp b/src/components/input-package.lisp index 14b30a0..5b7a363 100644 --- a/src/components/input-package.lisp +++ b/src/components/input-package.lisp @@ -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)) diff --git a/src/components/keybindings.lisp b/src/components/keybindings.lisp index 54ef481..a524015 100644 --- a/src/components/keybindings.lisp +++ b/src/components/keybindings.lisp @@ -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)) diff --git a/src/components/mouse-package.lisp b/src/components/mouse-package.lisp index 6e1d27a..83072b8 100644 --- a/src/components/mouse-package.lisp +++ b/src/components/mouse-package.lisp @@ -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)) diff --git a/src/components/mouse.lisp b/src/components/mouse.lisp index facd028..84bdd15 100644 --- a/src/components/mouse.lisp +++ b/src/components/mouse.lisp @@ -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)) diff --git a/src/components/scrollbox.lisp b/src/components/scrollbox.lisp index 1a7bfcf..3561b0d 100644 --- a/src/components/scrollbox.lisp +++ b/src/components/scrollbox.lisp @@ -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))))))) diff --git a/src/components/select-package.lisp b/src/components/select-package.lisp index cd05491..b1b89a8 100644 --- a/src/components/select-package.lisp +++ b/src/components/select-package.lisp @@ -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)) diff --git a/src/components/select.lisp b/src/components/select.lisp index fb57324..8f540ca 100644 --- a/src/components/select.lisp +++ b/src/components/select.lisp @@ -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))) diff --git a/src/components/slot-package.lisp b/src/components/slot-package.lisp index 5282534..03ff7ea 100644 --- a/src/components/slot-package.lisp +++ b/src/components/slot-package.lisp @@ -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*)) diff --git a/src/components/slot.lisp b/src/components/slot.lisp index 26c9fbb..b032761 100644 --- a/src/components/slot.lisp +++ b/src/components/slot.lisp @@ -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)) diff --git a/src/components/tabbar.lisp b/src/components/tabbar.lisp index 1ec6219..324b9f6 100644 --- a/src/components/tabbar.lisp +++ b/src/components/tabbar.lisp @@ -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)) diff --git a/src/components/textarea.lisp b/src/components/textarea.lisp index 842a2df..83740d4 100644 --- a/src/components/textarea.lisp +++ b/src/components/textarea.lisp @@ -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)))) diff --git a/src/rendering/framebuffer.lisp b/src/rendering/framebuffer.lisp index a4582f2..3987120 100644 --- a/src/rendering/framebuffer.lisp +++ b/src/rendering/framebuffer.lisp @@ -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))))) diff --git a/tests/dialog-tests.lisp b/tests/dialog-tests.lisp index ee27b7c..062937c 100644 --- a/tests/dialog-tests.lisp +++ b/tests/dialog-tests.lisp @@ -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*))))) diff --git a/tests/input-tests.lisp b/tests/input-tests.lisp index 0437cb6..40cc4df 100644 --- a/tests/input-tests.lisp +++ b/tests/input-tests.lisp @@ -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*))) diff --git a/tests/mouse-tests.lisp b/tests/mouse-tests.lisp index 336163b..12bedc6 100644 --- a/tests/mouse-tests.lisp +++ b/tests/mouse-tests.lisp @@ -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))))) diff --git a/tests/scrollbox-tabbar-tests.lisp b/tests/scrollbox-tabbar-tests.lisp index 7e9400e..427d0c2 100644 --- a/tests/scrollbox-tabbar-tests.lisp +++ b/tests/scrollbox-tabbar-tests.lisp @@ -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)"))) diff --git a/tests/select-tests.lisp b/tests/select-tests.lisp index 87670c3..ac37e73 100644 --- a/tests/select-tests.lisp +++ b/tests/select-tests.lisp @@ -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))))) diff --git a/tests/slot-tests.lisp b/tests/slot-tests.lisp index ab9b63a..8c48b52 100644 --- a/tests/slot-tests.lisp +++ b/tests/slot-tests.lisp @@ -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)))