diff --git a/backend/modern.lisp b/backend/modern.lisp index 44110f1..aabf5dd 100644 --- a/backend/modern.lisp +++ b/backend/modern.lisp @@ -28,9 +28,16 @@ '((:black . 0) (:red . 1) (:green . 2) (:yellow . 3) (:blue . 4) (:magenta . 5) (:cyan . 6) (:white . 7))) +(defvar *theme-colors* (make-hash-table :test 'eq) + "Hash table mapping theme keywords to hex color strings. +Populated by the theme system's load-preset. Checked by sgr-fg/sgr-bg +as a fallback when a keyword is not in *named-colors*.") + (defun sgr-fg (color) "Return SGR foreground escape for COLOR. - Color can be a hex string, a keyword name, or nil." + Color can be a hex string, a keyword name, or nil. + Keywords first try *named-colors*, then fall back to *theme-colors* + which resolves theme semantic roles to hex strings." (if (null color) "" (cond ((and (stringp color) (char= (char color 0) #\#)) (multiple-value-bind (r g b) (hex-to-rgb color) @@ -39,11 +46,17 @@ (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 30 index)) - ""))) + ;; Fall back to theme-colors hash + (let ((hex (gethash color *theme-colors*))) + (if hex + (multiple-value-bind (r g b) (hex-to-rgb hex) + (format nil "~C[38;2;~d;~d;~dm" #\Esc r g b)) + ""))))) (t "")))) (defun sgr-bg (color) - "Return SGR background escape for COLOR." + "Return SGR background escape for COLOR. + Keywords first try *named-colors*, then fall back to *theme-colors*." (if (null color) "" (cond ((and (stringp color) (char= (char color 0) #\#)) (multiple-value-bind (r g b) (hex-to-rgb color) @@ -52,7 +65,12 @@ (let ((index (cdr (assoc color *named-colors*)))) (if index (format nil "~C[~dm" #\Esc (+ 40 index)) - ""))) + ;; Fall back to theme-colors hash + (let ((hex (gethash color *theme-colors*))) + (if hex + (multiple-value-bind (r g b) (hex-to-rgb hex) + (format nil "~C[48;2;~d;~d;~dm" #\Esc r g b)) + ""))))) (t "")))) (defparameter *sgr-attr-codes* @@ -149,6 +167,7 @@ (defmethod backend-write ((b modern-backend) string) (let ((stream (backend-output-stream b))) (write-string string stream) + (finish-output stream) (length string))) (defmethod capable-p ((b modern-backend) feature) diff --git a/backend/package.lisp b/backend/package.lisp index 72414a3..e1eb0af 100644 --- a/backend/package.lisp +++ b/backend/package.lisp @@ -23,6 +23,8 @@ #:modern-backend #:make-modern-backend ;; Detection #:detect-backend #:*detected-backend* + ;; Theme color resolution (populated by theme system) + #:*theme-colors* ;; Internal (for testing) #:sgr-fg #:sgr-bg #:sgr-attr #:cursor-move-escape #:cursor-style-escape diff --git a/backend/simple.lisp b/backend/simple.lisp index 2044218..a7af39f 100644 --- a/backend/simple.lisp +++ b/backend/simple.lisp @@ -44,13 +44,22 @@ POS is :top-left, :top-right, :bottom-left, :bottom-right, (declare (ignore style fg bg title title-align)) (let ((h (%simple-border-char nil :horizontal)) (v (%simple-border-char nil :vertical))) + ;; Position cursor with newlines and spaces (no escape sequences) + (dotimes (row y) (backend-write b (string #\Newline))) ;; Top edge - (backend-write b (format nil "~%~v@{~a~:*~}" width h)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (make-string width :initial-element h)) ;; Sides (loop for i from 1 below (1- height) - do (backend-write b (format nil "~%|~v@{~a~:*~}|" (- width 2) #\space))) + do (backend-write b (string #\Newline)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (string v)) + (backend-write b (make-string (- width 2) :initial-element #\space)) + (backend-write b (string v))) ;; Bottom edge - (backend-write b (format nil "~%~v@{~a~:*~}" width h)))) + (backend-write b (string #\Newline)) + (backend-write b (make-string x :initial-element #\space)) + (backend-write b (make-string width :initial-element h)))) (defmethod draw-rect ((b simple-backend) x y width height &key bg) diff --git a/cl-tty.asd b/cl-tty.asd index 9e0f42e..c96cba6 100644 --- a/cl-tty.asd +++ b/cl-tty.asd @@ -52,9 +52,9 @@ ;; Slot system (v0.11.0) (:file "slot-package" :depends-on ("package")) (:file "slot" :depends-on ("slot-package"))))) - :in-order-to ((test-op (test-op :cl-tty-tests)))) + :in-order-to ((test-op (test-op :cl-tty/test)))) -(asdf:defsystem :cl-tty-tests +(asdf:defsystem :cl-tty/test :description "Test suite for cl-tty" :depends-on (:cl-tty :fiveam) :components @@ -83,7 +83,9 @@ ((:file "framebuffer-tests" :pathname "../../tests/framebuffer-tests")))) :perform (test-op (o c) (let ((run (find-symbol "RUN" :fiveam)) - (explain (find-symbol "EXPLAIN!" :fiveam))) + (explain (find-symbol "EXPLAIN!" :fiveam)) + (status (find-symbol "RESULTS-STATUS" :fiveam)) + (all-passed t)) (dolist (suite '((:cl-tty-backend-test "BACKEND-SUITE") (:cl-tty-box-test "BOX-SUITE") (:cl-tty-input-test "INPUT-SUITE") @@ -102,5 +104,8 @@ (pkg (find-symbol (string (first suite)) :keyword)) (t nil)))) (when s - (funcall explain (funcall run s)))))) - (uiop:quit 0))) + (let ((result (funcall run s))) + (funcall explain result) + (unless (funcall status result) + (setf all-passed nil)))))) + (uiop:quit (if all-passed 0 1))))) diff --git a/org/scrollbox-tabbar.org b/org/scrollbox-tabbar.org index 3085e66..c2034e7 100644 --- a/org/scrollbox-tabbar.org +++ b/org/scrollbox-tabbar.org @@ -319,38 +319,36 @@ when the user manually scrolls up. #+BEGIN_SRC lisp (defmethod render ((sb scroll-box) backend) - "Render visible children with scroll offset applied." + "Render visible children with scroll offset applied. +Delegates to each child's `render` method, temporarily offsetting +its layout-node position for the scroll offset. Children outside +the viewport are clipped out." (let* ((ln (scroll-box-layout-node sb)) - (vx 0) (vy 0) ;; viewport origin (parent position) + (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)) - (cw (if cln (layout-node-width cln) 1)) (ch (if cln (layout-node-height cln) 1)) - ;; Child's position after scroll offset - (cx vx) (cy vy)) - (declare (ignore cx)) - ;; Only render if child intersects viewport vertically + ;; Only render children that are visible in the viewport (when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy)) - (let ((old-ln (component-layout-node child))) - (when old-ln - ;; Temporarily adjust layout to account for scroll - (let ((new-ln (make-layout-node))) - (setf (layout-node-x new-ln) (- sx) - (layout-node-y new-ln) (- sy) - (layout-node-width new-ln) cw - (layout-node-height new-ln) ch) - ;; Use a captured-backend approach or just draw-text - (draw-text backend 0 (+ vy cy (- sy)) - (format nil "child at ~D" vy) - nil nil))))) - (incf vy ch)))) - (draw-scrollbars sb backend vw vh)) + ;; Temporarily offset child's layout-node position for rendering + (let ((orig-x (if cln (layout-node-x cln) 0)) + (orig-y (if cln (layout-node-y cln) 0))) + (when cln + (setf (layout-node-x cln) (- orig-x sx) + (layout-node-y cln) (- orig-y sy))) + (unwind-protect + (render child backend) + (when cln + (setf (layout-node-x cln) orig-x + (layout-node-y cln) orig-y))))) + (incf vy ch))) + (draw-scrollbars sb backend vw vh))) #+END_SRC ** ScrollBox: sticky scroll @@ -573,6 +571,8 @@ they are truncated with an ellipsis. :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)) @@ -583,9 +583,20 @@ they are truncated with an ellipsis. (let* ((cln (component-layout-node child)) (ch (if cln (layout-node-height cln) 1)) (cy vy)) - (when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy)) - (draw-text backend (- sx) (+ vy cy (- sy)) - (format nil "child at ~D" vy) nil nil)) + ;; Only render children that are visible in the viewport + (when (and (< (+ cy (- sy)) (+ vh vy)) + (> (+ cy (- sy) ch) vy)) + ;; Temporarily offset child's layout-node position for rendering + (let ((orig-x (if cln (layout-node-x cln) 0)) + (orig-y (if cln (layout-node-y cln) 0))) + (when cln + (setf (layout-node-x cln) (- orig-x sx) + (layout-node-y cln) (- orig-y sy))) + (unwind-protect + (render child backend) + (when cln + (setf (layout-node-x cln) orig-x + (layout-node-y cln) orig-y))))) (incf vy ch))) (draw-scrollbars sb backend vw vh))) diff --git a/org/text-input.org b/org/text-input.org index 605988b..0b6f1ba 100644 --- a/org/text-input.org +++ b/org/text-input.org @@ -503,1456 +503,11 @@ debugging argument mismatches — avoid that trap. (defstruct key-event (key nil :type (or keyword null)) (ctrl nil :type boolean) - (alt nil :type boolean) - (shift nil :type boolean) - (code nil :type (or fixnum null)) - (raw nil :type (or string null)) - (text nil :type (or string null))) -#+END_SRC + -** Mouse Event Struct +... [OUTPUT TRUNCATED - 58394 chars omitted out of 108394 total] ... -Separate from key-event because mouse carries coordinates and button -information that key events don't need. Parsed from SGR mouse sequences -(~ESC[= b #x30) (<= b #x3f)) - (if (char= (code-char b) #\;) - (progn (push current params) (setf current 0)) - (setf current (+ (* current 10) (- b #x30))))) - ((and (>= b #x20) (<= b #x2f)) - nil) - ((and (>= b #x40) (<= b #x7e)) - (push current params) - (return (values (nreverse params) b - (map 'string #'code-char raw)))) - (t - (return (values nil nil nil)))))))) -#+END_SRC - -** CSI Key Translation Tables - -Maps CSI final bytes and parameter values to keyword names. Two tables: -one for single-byte final keys (~A=up, ~B=down, H=home, etc.) and -one for ~ sequence codes (~1~=home, ~3~=delete, ~11~=F1, etc.). - -Using quoted alists (~'((#\A . :up) ...)~) because these are compile-time -constants. The ~assoc~ lookup is fast enough for single-key dispatch. - -#+BEGIN_SRC lisp -(defparameter *csi-key-table* - '((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left) - (#\F . :end) (#\H . :home) - (#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4) - (#\Z . :tab))) - -(defparameter *csi-tilde-table* - '((1 . :home) (2 . :insert) (3 . :delete) - (4 . :end) (5 . :page-up) (6 . :page-down) - (7 . :home) (8 . :end) - (11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4) - (15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8) - (20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12))) -#+END_SRC - -** SGR Mouse Parser - -The SGR mouse format is ~ESC[ final start)) - (let* ((nums (mapcar #'parse-integer - (%split-string (subseq raw (1+ start) final) #\;))) - (code (first nums)) - (x (or (second nums) 0)) - (y (or (third nums) 0)) - (button (logand code #x03)) - (mod (logand code #x1c)) - (motion (logand code #x20)) - (wheel (logand code #x40))) - (declare (ignore mod)) - (make-mouse-event - :type (cond (releasep :release) - (motion :drag) - (t :press)) - :button (cond (wheel (if (zerop (logand code #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y :raw raw))))) -#+END_SRC - -** Escape Sequence Reader - -After reading ESC (0x1b), we need to determine if this is a standalone -Escape or the start of a multi-byte sequence. The function dispatches -based on the next byte: - -- ~O~ (0x4f) → SS3 sequence (F1-F4 in most terminals). Reads one more - byte and looks up the mapping ~(#\P=F1, #\Q=F2, #\R=F3, #\S=F4)~. -- ~[~ (0x5b) → CSI sequence. Delegates to ~parse-csi-params~, then - maps the final byte with modifier support. CSI sequences can carry - modifier information in the first parameter: 1=Shift, 2=Alt, 4=Ctrl. -- Another ESC (0x1b) → double-escape, treated as Alt+Escape. -- Any printable → Alt+key. Reads one more ASCII byte and creates a - key-event with ~:alt t~. - -#+BEGIN_SRC lisp -(defun %read-escape-sequence () - (let ((b (read-raw-byte))) - (unless b - (return-from %read-escape-sequence - (make-key-event :key :escape :raw (string #\Esc)))) - (case b - (#x4f - (let ((b2 (read-raw-byte))) - (if b2 - (let ((key (cdr (assoc (code-char b2) - '((#\P . :f1) (#\Q . :f2) - (#\R . :f3) (#\S . :f4)))))) - (make-key-event :key (or key :unknown) - :raw (format nil "~C~C~C" #\Esc #\O (code-char b2)))) - (make-key-event :key :escape :raw (string #\Esc))))) - (#x5b - (multiple-value-bind (params final-byte) (parse-csi-params) - (if (null final-byte) - (make-key-event :key :escape :raw (string #\Esc)) - (if (and (char= (code-char final-byte) #\M) - (>= (length params) 3)) - (let* ((p0 (first params))) - (if (zerop (logand p0 #x40)) - (let* ((x (second params)) - (y (third params)) - (button (logand p0 #x03)) - (motion (logand p0 #x20)) - (wheel (logand p0 #x40))) - (make-mouse-event - :type (if motion :drag :press) - :button (cond (wheel (if (zerop (logand p0 #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y - :raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte)))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or p0 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or (first params) 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))) - (#x1b - (make-key-event :key :escape :alt t :raw "\\e\\e")) - (t - (let ((ch (code-char b))) - (if (and (>= b #x20) (<= b #x7e)) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :alt t - :raw (format nil "~C~C" #\Esc ch)) - (make-key-event :key :unknown - :raw (format nil "~C~C" #\Esc ch)))))))) -#+END_SRC - -** Top-level Event Reader - -The main input dispatcher. Reads one byte and classifies it: - -- Ctrl characters (0x01-0x1a) map to ~:A~ through ~:Z~ with ~:ctrl t~. - The mapping adds 0x60 to get the lowercase letter, then ~string-upcase~s - it so the keyword matches ~:ctrl+a~ (uppercase P from reader convention). -- Tab (0x09), Enter (0x0a and 0x0d — both mapped to ~:enter~). -- Backspace (0x7f DEL or 0x08 BS — mapped to ~:backspace~). -- Printable ASCII (0x20-0x7e) → keyword ~:A~ through ~:~. -- Escape (0x1b) → ~%read-escape-sequence~ for multi-byte sequences. -- Anything else → ~:unknown~. - -~:key~ values are always uppercase keywords. This matters because -the reader interns keyword symbols uppercase by default — if the -parser returns lowercase keywords, key matching fails silently. - -#+BEGIN_SRC lisp -(defun %read-event (&key timeout) - (let ((b (read-raw-byte :timeout timeout))) - (unless b - (return-from %read-event nil)) - (case b - (#x1b - (%read-escape-sequence)) - (#x09 - (make-key-event :key :tab :code #x09)) - (#x0a - (make-key-event :key :enter :code #x0a)) - (#x0d - (make-key-event :key :enter :code #x0d)) - ((#x7f #x08) - (make-key-event :key :backspace :code b)) - ((and (>= b #x01) (<= b #x1a)) - (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) - (make-key-event :key key :ctrl t :code b))) - (#x1c (make-key-event :key :backslash :ctrl t :code b)) - (#x1d (make-key-event :key :rbracket :ctrl t :code b)) - (#x1e (make-key-event :key :caret :ctrl t :code b)) - (#x1f (make-key-event :key :underscore :ctrl t :code b)) - ((and (>= b #x20) (<= b #x7e)) - (let ((ch (code-char b))) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :code b))) - (t - (make-key-event :key :unknown :code b :raw (string (code-char b))))))) -#+END_SRC - -** Backend Integration - -The backend protocol declares ~read-event~ as a generic function with a -default no-op. This method overrides it for all ~backend~ instances, -providing real terminal input via our parser. The ~probe-file~ guard -handles the case where stdin is not a terminal (piped input). - -#+BEGIN_SRC lisp -(defmethod read-event ((b cl-tty.backend:backend) &key timeout) - (declare (ignore b)) - (when (probe-file "/dev/stdin") - (%read-event :timeout timeout))) -#+END_SRC - -* TextInput Widget - -** Widget Class - -~text-input~ inherits from ~dirty-mixin~ for dirty tracking. The -~on-submit~ slot stores a callback function that receives the current -value when Enter is pressed. ~layout-node~ enables integration with -the layout engine. ~focusable~ is always ~t~ for input widgets. - -The ~value~ and ~cursor~ slots are directly accessible for testing -without going through the event handler. - -#+BEGIN_SRC lisp -(in-package #:cl-tty.input) - -(defclass text-input (dirty-mixin) - ((value :initform "" :initarg :value :accessor text-input-value :type string) - (cursor :initform 0 :initarg :cursor :accessor text-input-cursor :type fixnum) - (placeholder :initform "" :initarg :placeholder :accessor text-input-placeholder :type string) - (max-length :initform nil :initarg :max-length :accessor text-input-max-length) - (on-submit :initform nil :initarg :on-submit :accessor text-input-on-submit) - (layout-node :initform (make-layout-node) :accessor text-input-layout-node) - (focusable :initform t :accessor text-input-focusable))) - -(defun make-text-input (&key value cursor placeholder max-length on-submit) - (make-instance 'text-input - :value (or value "") - :cursor (or cursor 0) - :placeholder (or placeholder "") - :max-length max-length - :on-submit on-submit)) -#+END_SRC - -** Editing Operations: Insert - -~text-input-insert~ inserts a character at the cursor position by -splitting the string at the cursor and concatenating the three parts. -I use ~concatenate 'string~ rather than a data structure because -terminal input fields are typically short (< 100 chars). The ~max-length~ -check returns early if the limit is reached. - -#+BEGIN_SRC lisp -(defun text-input-insert (input char) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input)) - (max (text-input-max-length input))) - (when (and max (>= (length val) max)) - (return-from text-input-insert)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (string char) - (subseq val pos))) - (incf (text-input-cursor input)) - (mark-dirty input))) -#+END_SRC - -** Editing Operations: Backspace and Delete - -~text-input-backspace~ deletes the character before the cursor. I guard -against ~(zerop pos)~ because calling ~(subseq "abc" -1 0)~ would error. -~text-input-delete~ deletes the character AT the cursor — essentially -the same operation but at a different position. - -#+BEGIN_SRC lisp -(defun text-input-backspace (input) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (zerop pos) (return-from text-input-backspace)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 (1- pos)) - (subseq val pos))) - (decf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-delete (input) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (>= pos (length val)) - (return-from text-input-delete)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (subseq val (1+ pos)))) - (mark-dirty input))) -#+END_SRC - -** Cursor Movement - -Four cursor movement functions: left, right, home (start), end. Each -clamps to valid bounds. ~decf~ and ~incf~ naturally saturate at the -boundaries because of the guards. - -~text-input-delete-word-before~ deletes from cursor back to the previous -word boundary. This is the emacs ~Ctrl+W~ behavior — whitespace-delimited -word deletion. The logic finds the first space going backward from the -cursor, then deletes everything between that space and the cursor. - -#+BEGIN_SRC lisp -(defun text-input-move-left (input) - (when (plusp (text-input-cursor input)) - (decf (text-input-cursor input)))) - -(defun text-input-move-right (input) - (when (< (text-input-cursor input) (length (text-input-value input))) - (incf (text-input-cursor input)))) - -(defun text-input-move-home (input) - (setf (text-input-cursor input) 0)) - -(defun text-input-move-end (input) - (setf (text-input-cursor input) (length (text-input-value input)))) - -(defun text-input-delete-word-before (input) - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (zerop pos) - (return-from text-input-delete-word-before)) - (let* ((start (or (position-if (lambda (c) (not (char= c #\Space))) - val :end pos :from-end t) - 0)) - (word-start (or (and (plusp start) - (position #\Space val :end start :from-end t)) - 0)) - (delete-start (if (and (zerop word-start) - (or (char/= (char val 0) #\Space) - (zerop start))) - 0 - (if (zerop start) - (1+ word-start) - (1+ (or (position #\Space val :end start :from-end t) - 0)))))) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 delete-start) - (subseq val pos))) - (setf (text-input-cursor input) delete-start) - (mark-dirty input)))) -#+END_SRC - -** Key Event Handler - -~handle-text-input~ is the main dispatcher for a TextInput widget. -It receives a ~key-event~ and dispatches based on ~ctrl~ flag and -~key~: - -- Ctrl+key shortcuts use an inner ~case~ on ~key~ to dispatch - Ctrl+A/E/W/U/K. -- Non-ctrl keys dispatch cursor movement, editing, Enter callback, - and character insertion via the ~otherwise~ clause. - -The ~otherwise~ clause (right before Render metho), uses ~code-char~ -to convert the raw byte code into a character, and ~graphic-char-p~ -to filter out control characters. This is the fallthrough for ANY -unrecognized key — including printable characters. - -#+BEGIN_SRC lisp -(defun handle-text-input (input event) - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:a (text-input-move-home input)) - (:e (text-input-move-end input)) - (:w (text-input-delete-word-before input)) - (:u (progn - (setf (text-input-value input) - (subseq (text-input-value input) - (text-input-cursor input))) - (setf (text-input-cursor input) 0) - (mark-dirty input))) - (:k (progn - (setf (text-input-value input) - (subseq (text-input-value input) 0 - (text-input-cursor input))) - (mark-dirty input))) - (t nil))) - (t - (case (key-event-key event) - (:left (text-input-move-left input)) - (:right (text-input-move-right input)) - (:home (text-input-move-home input)) - (:end (text-input-move-end input)) - (:backspace (text-input-backspace input)) - (:delete (text-input-delete input)) - (:enter (let ((cb (text-input-on-submit input))) - (when cb (funcall cb (text-input-value input))))) - (:tab nil) - (:escape nil) - (otherwise - (let ((ch (code-char (key-event-code event)))) - (when (and ch (graphic-char-p ch)) - (text-input-insert input ch)))))))) -#+END_SRC - -** Rendering Stub - -~render~ is defined as a method on the component's ~render~ generic -to satisfy the rendering pipeline protocol. The full implementation -needs ~*current-backend*~ and ~*current-theme*~ — for unit testing, -this no-op lets us test editing logic without terminal output. - -#+BEGIN_SRC lisp -(defmethod render ((in text-input) (backend t)) - (declare (ignore in backend)) - (values)) -#+END_SRC - -* Textarea Widget - -** Widget Class - -~textarea~ is like ~text-input~ but multi-line. The cursor is a -(row, column) pair. ~undo-stack~ and ~redo-stack~ use ~make-array~ -with ~:fill-pointer 0~ to create adjustable vectors — ~vector-push~ -and ~vector-pop~ manage them as stacks with automatic bounds checking. - -The ~selection-start~ slot supports Shift+click and Shift+arrow -selection (not yet implemented in the handler). ~on-submit~ fires -on Ctrl+Enter when set. - -#+BEGIN_SRC lisp -(in-package #:cl-tty.input) - -(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)) -#+END_SRC - -** Line Helpers - -~textarea-lines~ splits the value at newlines. I coerce to vector -in editing functions for ~aref~ access (O(1) indexed access vs -~nth~'s O(n) list traversal for large documents). - -~textarea-ensure-cursor~ clamps the cursor to valid bounds after -operations like undo or up/down movement. The ~min~ with ~max~ -pattern avoids branching. - -#+BEGIN_SRC lisp -(defun textarea-lines (ta) - (%split-string (textarea-value ta) #\Newline)) - -(defun textarea-line-count (ta) - (length (textarea-lines ta))) - -(defun textarea-ensure-cursor (ta) - (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)))))) -#+END_SRC - -** Character Insertion - -~textarea-insert-char~ inserts a character at the cursor (row, col) -position within the current line. I use a vector copy of lines for -indexed access, modify the specific line via concatenation, then -rebuild the value from the modified vector. - -The ~undo~ push captures the state BEFORE the edit — this is -important for correct undo semantics (undo restores the previous -state, not the state before the undo). - -#+BEGIN_SRC lisp -(defun textarea-insert-char (ta char) - (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))))) -#+END_SRC - -** Newline Insertion - -~textarea-newline~ splits the current line at the cursor and inserts -the cursor position pushes everything after into a new line. The -~concatenate 'vector~ approach builds the new line array with the -inserted empty line. - -The special case ~(< 0 (length lines))~ catches edge cases like -inserting a newline at the very end of the last line. - -#+BEGIN_SRC lisp -(defun textarea-newline (ta) - (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))))) -#+END_SRC - -** Backspace - -~textarea-backspace~ handles two cases: - -1. ~(zerop col)~ — at the start of a line. Joins the current line - with the previous one by concatenating ~prev + curr~ and removing - the current line from the vector. Cursor moves to the join point - (end of previous line). -2. ~(> col 0)~ — inside a line. Deletes the character before the - cursor within the same line using concatenation. - -The ~(and (zerop row) (zerop col))~ case is a no-op (already at the -very beginning of the document). - -#+BEGIN_SRC lisp -(defun textarea-backspace (ta) - (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) - ((zerop col) - (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)))))) -#+END_SRC - -** Cursor Movement: Up/Down - -~textarea-move-up~ and ~textarea-move-down~ decrement/increment the -row, then call ~ensure-cursor~ to clamp the column to the new line's -length. This handles the case where the user moves from a long line -to a short one. - -#+BEGIN_SRC lisp -(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)) -#+END_SRC - -** Undo/Redo Stack - -~textarea-push-undo~ saves the current value onto the undo stack and -clears the redo stack (any new action after an undo invalidates the -redo history). The stacks are fill-pointer arrays — ~vector-push~ -adds to the end, ~vector-pop~ removes from the end (LIFO). - -~textarea-undo~ pops from the undo stack, pushes the current value -onto the redo stack, and restores the old value. ~textarea-redo~ does -the reverse. - -The ~(>= (length stack) (array-total-size stack))~ guard prevents the -stack from growing beyond 100 entries by dropping the oldest entry. - -#+BEGIN_SRC lisp -(defun textarea-push-undo (ta) - (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))))) -#+END_SRC - -** Key Event Handler - -~handle-textarea-input~ dispatches key events for the textarea widget. -It handles all the keys that ~handle-text-input~ does (cursor movement, -character insertion, backspace, delete) plus: - -- Ctrl+Z/Y for undo/redo -- Ctrl+A/E for home/end on current line -- Up/Down for line navigation -- Enter for newline insertion -- Left/Right/Home/End for cursor movement within/between lines - -Critically, this function does NOT fall through to ~handle-text-input~ -— early versions tried that but failed because ~handle-text-input~ -accesses ~text-input-*~ slots that ~textarea~ doesn't have. Instead, -textarea implements its own complete dispatching with line-aware -versions of each operation. - -#+BEGIN_SRC lisp -(defun handle-textarea-input (ta event) - (cond - ((key-event-ctrl event) - (case (key-event-key event) - (:z (textarea-undo ta)) - (:y (textarea-redo ta)) - (: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)) - (: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)))))) - (: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)))) - (otherwise - (let ((ch (code-char (key-event-code event)))) - (when (and ch (graphic-char-p ch)) - (textarea-insert-char ta ch))))))) -#+END_SRC - -** %join-lines helper - -This helper is needed because Common Lisp's ~format~ directive -~"~{~A~^~C~}"~ does NOT work as a newline-separated join — ~^C~ -inside ~{~}~ consumes list items, not format arguments. The correct -approach is ~write-char~ between items in an explicit loop. - -The function accepts both lists and vectors (the textarea code uses -vectors internally, but ~textarea-lines~ returns lists). - -#+BEGIN_SRC lisp -(defun %join-lines (lines) - (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)))) -#+END_SRC - -** Rendering Stub - -#+BEGIN_SRC lisp -(defmethod render ((ta textarea) (backend t)) - (declare (ignore ta backend)) - (values)) -#+END_SRC - -* Keybinding System - -The keybinding system provides layered keymaps — dispatch checks the -focused component's keymap first, then :local, then :global. This -allows modal applications (Vim-style) where the same key does -different things in different contexts. - -** Keymap Struct - -A keymap has a ~name~ for debugging, ~bindings~ as an alist (ordered -for priority), and an optional ~parent~ for inheritance chains. - -#+BEGIN_SRC lisp -(in-package #:cl-tty.input) - -(defstruct keymap - (name nil :type (or keyword null)) - (bindings nil :type list) - (parent nil :type (or keymap null))) -#+END_SRC - -** Global Registry - -~*keymaps*~ is a hash table mapping keyword names to keymap structs. -~equal~ test is used because keymap names are keywords (which are -~eql~-comparable, but ~equal~ is safer for edge cases). -~*chord-timeout*~ controls how long the system waits for the second -key in a two-key chord sequence. - -#+BEGIN_SRC lisp -(defparameter *keymaps* (make-hash-table :test #'equal)) -(defparameter *chord-timeout* 0.5) -#+END_SRC - -** Key Spec Matching - -~key-match-p~ determines whether a keybinding spec matches a key event. -The spec format is a keyword like ~:ctrl+p~ — the function splits the -keyword name on ~+~ to extract the modifier (~"CTRL"~, ~"ALT"~, -~"SHIFT"~) and the base key (~"P"~). - -I used ~case~ with string literals in an early version: -~(~case mod-str ("CTRL" ...))~. This does NOT work because ~case~ uses -~eql~ for comparison, and ~eql~ compares strings by object identity, -not value. Two ~"CTRL"~ literals may or may not be ~eql~ depending on -whether the compiler coalesces them. The fix is ~cond~ with ~string=?. - -#+BEGIN_SRC lisp -(defun key-match-p (spec event) - (etypecase spec - (keyword - (let* ((name (string spec)) - (plus (position #\+ name))) - (if plus - (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)))) - (eql spec (key-event-key event))))) - (list - (when spec - (key-match-p (first spec) event))))) -#+END_SRC - -** Dispatch - -~dispatch-key-event~ routes an event through the three keymap layers: - -1. Focused component's keymap (from ~component-keymap~ generic) -2. ~:local~ keymap (for the current screen/modal context) -3. ~:global~ keymap (always active — Ctrl+C, Ctrl+Q, etc.) - -Each keymap is tried in order. The first match calls the handler and -returns ~t~. If no keymap matches, the event is unhandled (~nil~). - -#+BEGIN_SRC lisp -(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))))) -#+END_SRC - -** defkeymap macro - -~defkeymap~ is a convenience macro for registering a keymap. It -expands to a ~setf~ on ~*keymaps*~. Each binding is a cons of a -key spec and a handler form, quoted and wrapped in a ~list~. - -The ~loop~ handles both ~(spec . handler)~ and ~(spec handler)~ -binding formats for flexibility. - -#+BEGIN_SRC lisp -(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)))))))) -#+END_SRC - -** Component Protocol Integration - -~component-keymap~ is a generic function that returns ~nil~ by default. -Widgets with custom keymaps override this method to return their own -~keymap~ struct. - -#+BEGIN_SRC lisp -(defgeneric component-keymap (component) - (:method ((c t)) nil)) -#+END_SRC - - -* Working Code (tangle targets) - -The code below is the working, tested implementation. Each block tangles -to its target file. The per-function blocks above are the literate reading -experience; this section is what actually generates the compilable code. - -** input.lisp -#+BEGIN_SRC lisp :tangle ../src/components/input.lisp -(in-package #:cl-tty.input) - -;;; --------------------------------------------------------------------------- -;;; Utility: split-string (avoids external dependency) -;;; --------------------------------------------------------------------------- -(defun %split-string (string separator) - "Split STRING at each occurrence of SEPARATOR. Returns list of strings." - (loop with start = 0 - for pos = (position separator string :start start) - collect (subseq string start pos) - while pos - do (setf start (1+ pos)))) - -;;; --------------------------------------------------------------------------- -;;; Global variables for rendering pipeline (set by application) -;;; --------------------------------------------------------------------------- -(defvar *current-backend* nil - "The active backend used for rendering.") -(defvar *current-theme* nil - "The active theme used for semantic color resolution.") - -;;; --------------------------------------------------------------------------- -;;; Key event struct -;;; --------------------------------------------------------------------------- -(defstruct key-event - (key nil :type (or keyword null)) - (ctrl nil :type boolean) - (alt nil :type boolean) - (shift nil :type boolean) - (code nil :type (or fixnum null)) - (raw nil :type (or string null)) - (text nil :type (or string null))) - -;;; --------------------------------------------------------------------------- -;;; Mouse event struct -;;; --------------------------------------------------------------------------- -(defstruct mouse-event - (type nil :type (or keyword null)) - (button nil :type (or keyword nil)) - (x 0 :type fixnum) - (y 0 :type fixnum) - (raw nil :type (or string null))) - -;;; --------------------------------------------------------------------------- -;;; Terminal raw mode -;;; --------------------------------------------------------------------------- -(defun save-terminal-state () - (sb-posix:tcgetattr 0)) - -(defun make-raw-termios (termios) - (flet ((clear-flag (flags mask) - (logand flags (lognot mask)))) - (setf (sb-posix:termios-iflag termios) - (clear-flag (sb-posix:termios-iflag termios) - (logior sb-posix:brkint sb-posix:ignpar - sb-posix:istrip sb-posix:inlcr - sb-posix:igncr sb-posix:icrnl - sb-posix:ixon))) - (setf (sb-posix:termios-oflag termios) - (clear-flag (sb-posix:termios-oflag termios) - sb-posix:opost)) - (setf (sb-posix:termios-lflag termios) - (clear-flag (sb-posix:termios-lflag termios) - (logior sb-posix:icanon sb-posix:echo - sb-posix:isig sb-posix:iexten))) - (setf (sb-posix:termios-cc termios sb-posix:vmin) 1) - (setf (sb-posix:termios-cc termios sb-posix:vtime) 0) - termios)) - -(defun set-raw-mode () - (let ((raw (make-raw-termios (save-terminal-state)))) - (sb-posix:tcsetattr 0 sb-posix:tcsanow raw) - raw)) - -(defun restore-terminal-state (termios) - (sb-posix:tcsetattr 0 sb-posix:tcsanow termios)) - -(defmacro with-raw-terminal (&body body) - (let ((saved (gensym "SAVED"))) - `(let ((,saved (save-terminal-state))) - (set-raw-mode) - (unwind-protect - (progn ,@body) - (restore-terminal-state ,saved))))) - -;;; --------------------------------------------------------------------------- -;;; Low-level byte reading -;;; --------------------------------------------------------------------------- -(defun read-raw-byte (&key timeout) - (if timeout - (let ((deadline (+ (get-universal-time) timeout))) - (loop while (< (get-universal-time) deadline) - do (handler-case - (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) - (let ((n (sb-posix:read 0 buf 1))) - (when (plusp n) - (return-from read-raw-byte (aref buf 0))))) - (sb-posix:syscall-error () - (return-from read-raw-byte nil))) - (sleep 0.01)) - nil) - (let ((buf (make-array 1 :element-type '(unsigned-byte 8)))) - (multiple-value-bind (n err) - (ignore-errors (sb-posix:read 0 buf 1)) - (if (and (integerp n) (plusp n)) - (aref buf 0) - (progn - (when err (format *error-output* "read error: ~A~%" err)) - nil)))))) - -;;; --------------------------------------------------------------------------- -;;; CSI parameter parser -;;; --------------------------------------------------------------------------- -(defun parse-csi-params () - (let ((params '()) - (raw (make-array 0 :element-type '(unsigned-byte 8) - :fill-pointer 0 :adjustable t)) - (current 0)) - (loop - (let ((b (read-raw-byte))) - (unless b (return (values nil nil nil))) - (vector-push-extend b raw) - (cond - ((and (>= b #x30) (<= b #x3f)) - (if (char= (code-char b) #\;) - (progn (push current params) (setf current 0)) - (setf current (+ (* current 10) (- b #x30))))) - ((and (>= b #x20) (<= b #x2f)) - nil) - ((and (>= b #x40) (<= b #x7e)) - (push current params) - (return (values (nreverse params) b - (map 'string #'code-char raw)))) - (t - (return (values nil nil nil)))))))) - -;;; --------------------------------------------------------------------------- -;;; Key event tables -;;; --------------------------------------------------------------------------- -(defparameter *csi-key-table* - '((#\A . :up) (#\B . :down) (#\C . :right) (#\D . :left) - (#\F . :end) (#\H . :home) - (#\P . :f1) (#\Q . :f2) (#\R . :f3) (#\S . :f4) - (#\Z . :tab))) - -(defparameter *csi-tilde-table* - '((1 . :home) (2 . :insert) (3 . :delete) - (4 . :end) (5 . :page-up) (6 . :page-down) - (7 . :home) (8 . :end) - (11 . :f1) (12 . :f2) (13 . :f3) (14 . :f4) - (15 . :f5) (17 . :f6) (18 . :f7) (19 . :f8) - (20 . :f9) (21 . :f10) (23 . :f11) (24 . :f12))) - -;;; --------------------------------------------------------------------------- -;;; SGR mouse parser -;;; --------------------------------------------------------------------------- -(defun parse-sgr-mouse (raw) - (let* ((start (position #\< raw)) - (end (position #\m raw :from-end t)) - (end2 (position #\M raw :from-end t)) - (final (if end end end2)) - (releasep (char= (char raw (1- (length raw))) #\m))) - (when (and start final (> final start)) - (let* ((nums (mapcar #'parse-integer - (%split-string (subseq raw (1+ start) final) #\;))) - (code (first nums)) - (x (or (second nums) 0)) - (y (or (third nums) 0)) - (button (logand code #x03)) - (mod (logand code #x1c)) - (motion (logand code #x20)) - (wheel (logand code #x40))) - (declare (ignore mod)) - (make-mouse-event - :type (cond (releasep :release) - (motion :drag) - (t :press)) - :button (cond (wheel (if (zerop (logand code #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y :raw raw))))) - -;;; --------------------------------------------------------------------------- -;;; Escape sequence reader -;;; --------------------------------------------------------------------------- -(defun %read-escape-sequence () - (let ((b (read-raw-byte))) - (unless b - (return-from %read-escape-sequence - (make-key-event :key :escape :raw (string #\Esc)))) - (case b - ;; SS3: ESC O X - (#x4f - (let ((b2 (read-raw-byte))) - (if b2 - (let ((key (cdr (assoc (code-char b2) - '((#\P . :f1) (#\Q . :f2) - (#\R . :f3) (#\S . :f4)))))) - (make-key-event :key (or key :unknown) - :raw (format nil "~C~C~C" #\Esc #\O (code-char b2)))) - (make-key-event :key :escape :raw (string #\Esc))))) - ;; CSI: ESC [ ... - (#x5b - (multiple-value-bind (params final-byte) (parse-csi-params) - (if (null final-byte) - (make-key-event :key :escape :raw (string #\Esc)) - (if (and (char= (code-char final-byte) #\M) - (>= (length params) 3)) - (let* ((p0 (first params))) - (if (zerop (logand p0 #x40)) - (let* ((x (second params)) - (y (third params)) - (button (logand p0 #x03)) - (motion (logand p0 #x20)) - (wheel (logand p0 #x40))) - (make-mouse-event - :type (if motion :drag :press) - :button (cond (wheel (if (zerop (logand p0 #x01)) - :wheel-up :wheel-down)) - ((= button 0) :left) - ((= button 1) :middle) - ((= button 2) :right) - (t :none)) - :x x :y y :raw (format nil "~C[<~d;~d;~d~C" #\Esc p0 x y (code-char final-byte)))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or p0 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))) - (let* ((tilde-p (char= (code-char final-byte) #\~)) - (param (or (first params) 0)) - (key (if tilde-p - (cdr (assoc param *csi-tilde-table*)) - (cdr (assoc (code-char final-byte) *csi-key-table*)))) - (modifier (when (> (length params) 1) (second params)))) - (let ((ctrl nil) (alt nil) (shift nil)) - (when modifier - (setf shift (logtest modifier 1) - alt (logtest modifier 2) - ctrl (logtest modifier 4))) - (make-key-event :key (or key :unknown) - :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))) - ;; ESC ESC - (#x1b - (make-key-event :key :escape :alt t :raw "\\e\\e")) - ;; ESC + printable = Alt+key - (t - (let ((ch (code-char b))) - (if (and (>= b #x20) (<= b #x7e)) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :alt t - :raw (format nil "~C~C" #\Esc ch)) - (make-key-event :key :unknown - :raw (format nil "~C~C" #\Esc ch)))))))) - -;;; --------------------------------------------------------------------------- -;;; Top-level event reader -;;; --------------------------------------------------------------------------- -(defun %read-event (&key timeout) - (let ((b (read-raw-byte :timeout timeout))) - (unless b - (return-from %read-event nil)) - (case b - (#x1b - (%read-escape-sequence)) - (#x09 - (make-key-event :key :tab :code #x09)) - (#x0a - (make-key-event :key :enter :code #x0a)) - (#x0d - (make-key-event :key :enter :code #x0d)) - ((#x7f #x08) - (make-key-event :key :backspace :code b)) - ((and (>= b #x01) (<= b #x1a)) - (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) - (make-key-event :key key :ctrl t :code b))) - (#x1c (make-key-event :key :backslash :ctrl t :code b)) - (#x1d (make-key-event :key :rbracket :ctrl t :code b)) - (#x1e (make-key-event :key :caret :ctrl t :code b)) - (#x1f (make-key-event :key :underscore :ctrl t :code b)) - ((and (>= b #x20) (<= b #x7e)) - (let ((ch (code-char b))) - (make-key-event :key (intern (string (string-upcase ch)) :keyword) - :code b))) - (t - (make-key-event :key :unknown :code b :raw (string (code-char b))))))) - -;;; --------------------------------------------------------------------------- -;;; Backend integration -;;; --------------------------------------------------------------------------- -(defmethod read-event ((b cl-tty.backend:backend) &key timeout) - (declare (ignore b)) - (when (probe-file "/dev/stdin") - (%read-event :timeout timeout))) -#+END_SRC - - -** text-input.lisp -#+BEGIN_SRC lisp :tangle ../src/components/text-input.lisp -(in-package #:cl-tty.input) - -;;; --------------------------------------------------------------------------- -;;; TextInput class -;;; --------------------------------------------------------------------------- -(defclass text-input (dirty-mixin) - ((value :initform "" :initarg :value :accessor text-input-value - :type string) - (cursor :initform 0 :initarg :cursor :accessor text-input-cursor - :type fixnum) - (placeholder :initform "" :initarg :placeholder - :accessor text-input-placeholder :type string) - (max-length :initform nil :initarg :max-length - :accessor text-input-max-length) - (on-submit :initform nil :initarg :on-submit - :accessor text-input-on-submit) - (layout-node :initform (make-layout-node) :accessor text-input-layout-node) - (focusable :initform t :accessor text-input-focusable))) - -(defun make-text-input (&key value cursor placeholder max-length on-submit) - (make-instance 'text-input - :value (or value "") - :cursor (or cursor 0) - :placeholder (or placeholder "") - :max-length max-length - :on-submit on-submit)) - -;;; --------------------------------------------------------------------------- -;;; Editing operations -;;; --------------------------------------------------------------------------- -(defun text-input-insert (input char) - "Insert CHAR at the cursor position in INPUT." - (let* ((val (text-input-value input)) - (pos (text-input-cursor input)) - (max (text-input-max-length input))) - (when (and max (>= (length val) max)) - (return-from text-input-insert)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (string char) - (subseq val pos))) - (incf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-backspace (input) - "Delete character before cursor." - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (zerop pos) (return-from text-input-backspace)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 (1- pos)) - (subseq val pos))) - (decf (text-input-cursor input)) - (mark-dirty input))) - -(defun text-input-delete (input) - "Delete character at cursor." - (let* ((val (text-input-value input)) - (pos (text-input-cursor input))) - (when (>= pos (length val)) - (return-from text-input-delete)) - (setf (text-input-value input) - (concatenate 'string - (subseq val 0 pos) - (subseq val (1+ pos)))) - (mark-dirty input))) - -;;; --------------------------------------------------------------------------- -;;; Cursor movement -;;; --------------------------------------------------------------------------- +-------------------------------------------- (defun text-input-move-left (input) (when (plusp (text-input-cursor input)) (decf (text-input-cursor input)))) @@ -2036,14 +591,21 @@ experience; this section is what actually generates the compilable code. (text-input-insert input ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((in text-input) (backend t)) - "Render a text-input widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore in backend)) - (values)) + "Render text-input value or placeholder at layout position." + (let* ((ln (text-input-layout-node in)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (value (text-input-value in)) + (cursor (text-input-cursor in)) + (display (if (plusp (length value)) + value + (or (text-input-placeholder in) "")))) + (declare (ignore w cursor)) + (draw-text backend x y display nil nil))) #+END_SRC @@ -2288,14 +850,23 @@ experience; this section is what actually generates the compilable code. (textarea-insert-char ta ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((ta textarea) (backend t)) - "Render a textarea widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore ta backend)) - (values)) + "Render textarea lines at layout position." + (let* ((ln (textarea-layout-node ta)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (h (if ln (layout-node-height ln) 24)) + (lines (textarea-lines ta)) + (max-lines (min (length lines) h))) + (declare (ignore w)) + (loop for i from 0 below max-lines + for line in lines + do (draw-text backend x (+ y i) + (subseq line 0 (min (length line) w)) + nil nil)))) #+END_SRC @@ -2691,5 +1262,4 @@ world"))) (:ctrl+q ,(lambda (e) (declare (ignore e)) (setf called t))))) (dispatch-key-event (make-key-event :key :q :ctrl t)) (is-true called))) -#+END_SRC - +#+END_SRC \ No newline at end of file diff --git a/run-all-tests.lisp b/run-all-tests.lisp index 90e7438..dc14a25 100644 --- a/run-all-tests.lisp +++ b/run-all-tests.lisp @@ -20,27 +20,31 @@ "tests/framebuffer-tests.lisp")) (load f)) -;; Run all test suites -(dolist (suite '((:cl-tty-backend-test "BACKEND-SUITE") - (:cl-tty-box-test "BOX-SUITE") - (:cl-tty-input-test "INPUT-SUITE") - (:cl-tty-scrollbox-test "SCROLLBOX-SUITE") - (:cl-tty-select-test "SELECT-SUITE") - (:cl-tty-markdown-test :cl-tty-markdown-test) - (:cl-tty-dialog-test "DIALOG-SUITE") - (:cl-tty-mouse-test "MOUSE-SUITE") - (:cl-tty-slot-test "SLOT-SUITE") - (:cl-tty-layout-test "LAYOUT-SUITE") - (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE") - (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE"))) - (let* ((pkg (find-package (first suite))) - (suite-name (second suite)) - (s (etypecase suite-name - (keyword (find-symbol (string suite-name) :keyword)) - (string (find-symbol suite-name pkg))))) - (format t "~&=== ~a ===~%" (first suite)) - (if s - (fiveam:explain! (fiveam:run s)) - (format t "Suite not found~%")))) - -(uiop:quit 0) +;; Run all test suites, exit non-zero if any fails +(let ((all-passed t)) + (dolist (suite '((:cl-tty-backend-test "BACKEND-SUITE") + (:cl-tty-box-test "BOX-SUITE") + (:cl-tty-input-test "INPUT-SUITE") + (:cl-tty-scrollbox-test "SCROLLBOX-SUITE") + (:cl-tty-select-test "SELECT-SUITE") + (:cl-tty-markdown-test :cl-tty-markdown-test) + (:cl-tty-dialog-test "DIALOG-SUITE") + (:cl-tty-mouse-test "MOUSE-SUITE") + (:cl-tty-slot-test "SLOT-SUITE") + (:cl-tty-layout-test "LAYOUT-SUITE") + (:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE") + (:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE"))) + (let* ((pkg (find-package (first suite))) + (suite-name (second suite)) + (s (etypecase suite-name + (keyword (find-symbol (string suite-name) :keyword)) + (string (find-symbol suite-name pkg))))) + (format t "~&=== ~a ===~%" (first suite)) + (if s + (let ((result (fiveam:run s))) + (fiveam:explain! result) + (unless (fiveam:results-status result) + (setf all-passed nil) + (format t "~&FAILED: ~a~%" (first suite)))) + (format t "Suite not found~%")))) + (uiop:quit (if all-passed 0 1))) diff --git a/src/components/input.lisp b/src/components/input.lisp index 9aba6d5..1996d49 100644 --- a/src/components/input.lisp +++ b/src/components/input.lisp @@ -204,10 +204,14 @@ (make-key-event :key :escape :raw (string #\Esc))))) ;; CSI: ESC [ ... (#x5b - (multiple-value-bind (params final-byte) (parse-csi-params) + (multiple-value-bind (params final-byte raw) (parse-csi-params) (if (null final-byte) (make-key-event :key :escape :raw (string #\Esc)) - (if (and (char= (code-char final-byte) #\M) + ;; SGR mouse: ESC [ < ... m/M + (if (and raw (plusp (length raw)) (char= (char raw 0) #\<)) + (or (parse-sgr-mouse raw) + (make-key-event :key :unknown :raw raw)) + (if (and (char= (code-char final-byte) #\M) (>= (length params) 3)) (let* ((p0 (first params))) (if (zerop (logand p0 #x40)) @@ -252,7 +256,7 @@ ctrl (logtest modifier 4))) (make-key-event :key (or key :unknown) :ctrl ctrl :alt alt :shift shift - :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte)))))))))) + :raw (format nil "~C[~d~C" #\Esc param (code-char final-byte))))))))))) ;; ESC ESC (#x1b (make-key-event :key :escape :alt t :raw "\\e\\e")) @@ -273,24 +277,24 @@ (let ((b (read-raw-byte :timeout timeout))) (unless b (return-from %read-event nil)) - (case b - (#x1b + (cond + ((= b #x1b) (%read-escape-sequence)) - (#x09 + ((= b #x09) (make-key-event :key :tab :code #x09)) - (#x0a + ((= b #x0a) (make-key-event :key :enter :code #x0a)) - (#x0d + ((= b #x0d) (make-key-event :key :enter :code #x0d)) - ((#x7f #x08) + ((or (= b #x7f) (= b #x08)) (make-key-event :key :backspace :code b)) ((and (>= b #x01) (<= b #x1a)) (let ((key (intern (string-upcase (string (code-char (+ b #x60)))) :keyword))) (make-key-event :key key :ctrl t :code b))) - (#x1c (make-key-event :key :backslash :ctrl t :code b)) - (#x1d (make-key-event :key :rbracket :ctrl t :code b)) - (#x1e (make-key-event :key :caret :ctrl t :code b)) - (#x1f (make-key-event :key :underscore :ctrl t :code b)) + ((= b #x1c) (make-key-event :key :backslash :ctrl t :code b)) + ((= b #x1d) (make-key-event :key :rbracket :ctrl t :code b)) + ((= b #x1e) (make-key-event :key :caret :ctrl t :code b)) + ((= b #x1f) (make-key-event :key :underscore :ctrl t :code b)) ((and (>= b #x20) (<= b #x7e)) (let ((ch (code-char b))) (make-key-event :key (intern (string (string-upcase ch)) :keyword) diff --git a/src/components/mouse.lisp b/src/components/mouse.lisp index 4361f11..60e641f 100644 --- a/src/components/mouse.lisp +++ b/src/components/mouse.lisp @@ -16,18 +16,18 @@ (when handler (funcall handler event)))) (defun hit-test (root x y) + "Find the deepest component at (X, Y) by testing layout-node bounds. +Components without a layout-node or position return nil." (labels ((recurse (node) - (when (and (slot-exists-p node 'x) (slot-boundp node 'x) - (slot-exists-p node 'y) (slot-boundp node 'y) - (slot-exists-p node 'width) (slot-boundp node 'width) - (slot-exists-p node 'height) (slot-boundp node 'height)) - (let ((nx (slot-value node 'x)) - (ny (slot-value node 'y)) - (nw (slot-value node 'width)) - (nh (slot-value node 'height))) - (when (and (>= x nx) (< x (+ nx nw)) - (>= y ny) (< y (+ ny nh))) - node))))) + (let ((ln (ignore-errors (component-layout-node node)))) + (when ln + (let ((nx (layout-node-x ln)) + (ny (layout-node-y ln)) + (nw (layout-node-width ln)) + (nh (layout-node-height ln))) + (when (and (>= x nx) (< x (+ nx nw)) + (>= y ny) (< y (+ ny nh))) + node)))))) (recurse root))) ;; Selection diff --git a/src/components/scrollbox.lisp b/src/components/scrollbox.lisp index dff0f36..6fa71ac 100644 --- a/src/components/scrollbox.lisp +++ b/src/components/scrollbox.lisp @@ -39,6 +39,8 @@ :initial-value 0)) (defmethod render ((sb scroll-box) backend) + "Render ScrollBox children within the viewport, offset by scroll position. +Children outside the viewport are skipped." (let* ((ln (scroll-box-layout-node sb)) (vx 0) (vy 0) (vw (if ln (layout-node-width ln) 80)) @@ -49,9 +51,20 @@ (let* ((cln (component-layout-node child)) (ch (if cln (layout-node-height cln) 1)) (cy vy)) - (when (and (< (+ cy (- sy)) (+ vh vy)) (> (+ cy (- sy) ch) vy)) - (draw-text backend (- sx) (+ vy cy (- sy)) - (format nil "child at ~D" vy) nil nil)) + ;; Only render children that are visible in the viewport + (when (and (< (+ cy (- sy)) (+ vh vy)) + (> (+ cy (- sy) ch) vy)) + ;; Temporarily offset child's layout-node position for rendering + (let ((orig-x (if cln (layout-node-x cln) 0)) + (orig-y (if cln (layout-node-y cln) 0))) + (when cln + (setf (layout-node-x cln) (- orig-x sx) + (layout-node-y cln) (- orig-y sy))) + (unwind-protect + (render child backend) + (when cln + (setf (layout-node-x cln) orig-x + (layout-node-y cln) orig-y))))) (incf vy ch))) (draw-scrollbars sb backend vw vh))) @@ -59,18 +72,21 @@ (if (> content-size viewport-size) (/ (float scroll-pos) (- content-size viewport-size)) 0.0)) (defun draw-scrollbars (sb backend viewport-w viewport-h) - (let* ((content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb)) + (let* ((ln (scroll-box-layout-node sb)) + (vx (if ln (layout-node-x ln) 0)) + (vy (if ln (layout-node-y ln) 0)) + (content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb)) (sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))) (when (> content-h viewport-h) (let* ((thumb (scrollbar-thumb sy viewport-h content-h)) (thumb-pos (round (* thumb viewport-h)))) - (draw-rect backend (1- viewport-w) 0 1 viewport-h :bg :bright-black) - (draw-text backend (1- viewport-w) thumb-pos "█" nil nil))) + (draw-rect backend (+ vx (1- viewport-w)) vy 1 viewport-h :bg :bright-black) + (draw-text backend (+ vx (1- viewport-w)) (+ vy thumb-pos) "█" nil nil))) (when (> content-w viewport-w) (let* ((thumb (scrollbar-thumb sx viewport-w content-w)) (thumb-pos (round (* thumb viewport-w)))) - (draw-rect backend 0 (1- viewport-h) viewport-w 1 :bg :bright-black) - (draw-text backend thumb-pos (1- viewport-h) "█" nil nil))))) + (draw-rect backend vx (+ vy (1- viewport-h)) viewport-w 1 :bg :bright-black) + (draw-text backend (+ vx thumb-pos) (+ vy (1- viewport-h)) "█" nil nil))))) (defun update-sticky-scroll (sb) (when (sticky-scroll-p sb) diff --git a/src/components/tabbar.lisp b/src/components/tabbar.lisp index eceeae9..f7b7f64 100644 --- a/src/components/tabbar.lisp +++ b/src/components/tabbar.lisp @@ -44,7 +44,7 @@ (is-active (eql id active-id)) (fg (if is-active :accent :text-muted)) (bg (if is-active :background-element nil))) - (when (>= (+ x-pos label-len 2) w) + (when (> (+ x-pos label-len 2) w) (draw-text backend x-pos y "..." :text-muted nil) (return)) (draw-text backend x-pos y label fg bg) (incf x-pos (+ label-len 2))))) diff --git a/src/components/text-input.lisp b/src/components/text-input.lisp index 78e5557..a00a659 100644 --- a/src/components/text-input.lisp +++ b/src/components/text-input.lisp @@ -153,11 +153,18 @@ (text-input-insert input ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((in text-input) (backend t)) - "Render a text-input widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore in backend)) - (values)) + "Render text-input value or placeholder at layout position." + (let* ((ln (text-input-layout-node in)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (value (text-input-value in)) + (cursor (text-input-cursor in)) + (display (if (plusp (length value)) + value + (or (text-input-placeholder in) "")))) + (declare (ignore w cursor)) + (draw-text backend x y display nil nil))) diff --git a/src/components/textarea.lisp b/src/components/textarea.lisp index efab3a8..2c9090e 100644 --- a/src/components/textarea.lisp +++ b/src/components/textarea.lisp @@ -237,11 +237,20 @@ (textarea-insert-char ta ch)))))))) ;;; --------------------------------------------------------------------------- -;;; Rendering (stub — proper rendering uses theme + backend) +;;; Rendering ;;; --------------------------------------------------------------------------- (defmethod render ((ta textarea) (backend t)) - "Render a textarea widget. Full rendering requires *current-backend*, - *current-theme*, and the rendering pipeline. This is a no-op stub for - unit testing the widget logic." - (declare (ignore ta backend)) - (values)) + "Render textarea lines at layout position." + (let* ((ln (textarea-layout-node ta)) + (x (if ln (layout-node-x ln) 0)) + (y (if ln (layout-node-y ln) 0)) + (w (if ln (layout-node-width ln) 80)) + (h (if ln (layout-node-height ln) 24)) + (lines (textarea-lines ta)) + (max-lines (min (length lines) h))) + (declare (ignore w)) + (loop for i from 0 below max-lines + for line in lines + do (draw-text backend x (+ y i) + (subseq line 0 (min (length line) w)) + nil nil)))) diff --git a/src/components/theme.lisp b/src/components/theme.lisp index de32b59..f3cc09d 100644 --- a/src/components/theme.lisp +++ b/src/components/theme.lisp @@ -26,16 +26,20 @@ NAME should be a keyword (e.g., :default, :nord)." `(setf (gethash ,name *presets*) '(:dark ,dark :light ,light))) (defun load-preset (theme preset-name) - "Load PRESET-NAME (a keyword) into THEME, overwriting role mappings." + "Load PRESET-NAME colors into THEME. +Side-effect: populates cl-tty.backend:*theme-colors* so that semantic +color roles resolve to hex at SGR generation time." (let ((preset (gethash preset-name *presets*))) (if preset - (let* ((variant (if (eql (theme-mode theme) :dark) - (getf preset :dark) - (getf preset :light))) - (roles (theme-roles theme))) - (clrhash roles) - (loop for (role hex) on variant by #'cddr - do (setf (gethash role roles) hex))) + (let* ((colors (if (eql (theme-mode theme) :dark) + (getf preset :dark) + (getf preset :light))) + ;; Populate backend theme color map + (theme-map (symbol-value (find-symbol "*THEME-COLORS*" :cl-tty.backend)))) + ;; Set theme colors + (loop for (role hex) on colors by #'cddr + do (setf (theme-color theme role) hex) + (setf (gethash role theme-map) hex))) (warn "Unknown preset: ~S" preset-name)))) (define-preset :default diff --git a/tests/input-tests.lisp b/tests/input-tests.lisp new file mode 100644 index 0000000..1f3971f --- /dev/null +++ b/tests/input-tests.lisp @@ -0,0 +1,269 @@ +(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)))) + +;; ── 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 ──────────────────────────────────────────── + +(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 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)))