diff --git a/backend/detection.lisp b/backend/detection.lisp index 7197913..d5dfe11 100644 --- a/backend/detection.lisp +++ b/backend/detection.lisp @@ -123,3 +123,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/src/components/container-package.lisp b/src/components/container-package.lisp index 1ff58f7..174cf8b 100644 --- a/src/components/container-package.lisp +++ b/src/components/container-package.lisp @@ -23,3 +23,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 33f044e..41e31a1 100644 --- a/src/components/dialog-package.lisp +++ b/src/components/dialog-package.lisp @@ -49,3 +49,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 0a8cc05..6f6b846 100644 --- a/src/components/dialog.lisp +++ b/src/components/dialog.lisp @@ -251,3 +251,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 5b7a363..ab8da02 100644 --- a/src/components/input-package.lisp +++ b/src/components/input-package.lisp @@ -74,3 +74,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 a524015..7b65d06 100644 --- a/src/components/keybindings.lisp +++ b/src/components/keybindings.lisp @@ -183,3 +183,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 83072b8..2c86353 100644 --- a/src/components/mouse-package.lisp +++ b/src/components/mouse-package.lisp @@ -23,3 +23,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 84bdd15..d44cac3 100644 --- a/src/components/mouse.lisp +++ b/src/components/mouse.lisp @@ -225,3 +225,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 3561b0d..98d6e0a 100644 --- a/src/components/scrollbox.lisp +++ b/src/components/scrollbox.lisp @@ -193,3 +193,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 b1b89a8..f26d9be 100644 --- a/src/components/select-package.lisp +++ b/src/components/select-package.lisp @@ -25,3 +25,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 8f540ca..f3bb4f3 100644 --- a/src/components/select.lisp +++ b/src/components/select.lisp @@ -191,3 +191,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 03ff7ea..5f21530 100644 --- a/src/components/slot-package.lisp +++ b/src/components/slot-package.lisp @@ -17,3 +17,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 b032761..138fa3b 100644 --- a/src/components/slot.lisp +++ b/src/components/slot.lisp @@ -59,3 +59,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 324b9f6..b510a44 100644 --- a/src/components/tabbar.lisp +++ b/src/components/tabbar.lisp @@ -105,3 +105,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 83740d4..1366bd5 100644 --- a/src/components/textarea.lisp +++ b/src/components/textarea.lisp @@ -515,3 +515,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 3987120..4aa36f6 100644 --- a/src/rendering/framebuffer.lisp +++ b/src/rendering/framebuffer.lisp @@ -438,3 +438,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 062937c..df04987 100644 --- a/tests/dialog-tests.lisp +++ b/tests/dialog-tests.lisp @@ -85,3 +85,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 40cc4df..86d6b17 100644 --- a/tests/input-tests.lisp +++ b/tests/input-tests.lisp @@ -775,3 +775,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 12bedc6..3298777 100644 --- a/tests/mouse-tests.lisp +++ b/tests/mouse-tests.lisp @@ -97,3 +97,53 @@ world" text))))) (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 427d0c2..d84cd5b 100644 --- a/tests/scrollbox-tabbar-tests.lisp +++ b/tests/scrollbox-tabbar-tests.lisp @@ -255,3 +255,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 ac37e73..3ec25c7 100644 --- a/tests/select-tests.lisp +++ b/tests/select-tests.lisp @@ -239,3 +239,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 8c48b52..522211a 100644 --- a/tests/slot-tests.lisp +++ b/tests/slot-tests.lisp @@ -79,3 +79,30 @@ (defslot :test-slot :order 1 :render-fn (lambda () "x")) (clear-slot :test-slot) (is-false (slot-p :test-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)))