Merge pull request 'v0.6.0: ScrollBox + TabBar' (#6) from feature/v0.6.0-scrollbox-tabbar into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/6
This commit was merged in pull request #6.
This commit is contained in:
14
cl-tui.asd
14
cl-tui.asd
@@ -2,7 +2,7 @@
|
|||||||
(asdf:defsystem :cl-tui
|
(asdf:defsystem :cl-tui
|
||||||
:description "Reusable Common Lisp Terminal UI Framework"
|
:description "Reusable Common Lisp Terminal UI Framework"
|
||||||
:author "Amr Gharbeia"
|
:author "Amr Gharbeia"
|
||||||
:version "0.5.0"
|
:version "0.6.0"
|
||||||
:license "TBD"
|
:license "TBD"
|
||||||
:depends-on (:fiveam :sb-posix)
|
:depends-on (:fiveam :sb-posix)
|
||||||
:components
|
:components
|
||||||
@@ -28,7 +28,11 @@
|
|||||||
(:file "input" :depends-on ("input-package" "dirty" "box"))
|
(:file "input" :depends-on ("input-package" "dirty" "box"))
|
||||||
(:file "text-input" :depends-on ("input-package" "input" "box"))
|
(:file "text-input" :depends-on ("input-package" "input" "box"))
|
||||||
(:file "textarea" :depends-on ("input-package" "input" "box"))
|
(:file "textarea" :depends-on ("input-package" "input" "box"))
|
||||||
(:file "keybindings" :depends-on ("input-package" "input")))))
|
(:file "keybindings" :depends-on ("input-package" "input"))
|
||||||
|
;; Container components (v0.6.0)
|
||||||
|
(:file "container-package" :depends-on ("package" "input-package"))
|
||||||
|
(:file "scrollbox" :depends-on ("container-package" "dirty" "box"))
|
||||||
|
(:file "tabbar" :depends-on ("container-package" "dirty" "box"))))
|
||||||
:in-order-to ((test-op (test-op :cl-tui-tests))))
|
:in-order-to ((test-op (test-op :cl-tui-tests))))
|
||||||
|
|
||||||
(asdf:defsystem :cl-tui-tests
|
(asdf:defsystem :cl-tui-tests
|
||||||
@@ -47,11 +51,13 @@
|
|||||||
(:file "dirty-tests")
|
(:file "dirty-tests")
|
||||||
(:file "render-tests")
|
(:file "render-tests")
|
||||||
(:file "theme-tests")
|
(:file "theme-tests")
|
||||||
(:file "input-tests"))))
|
(:file "input-tests")
|
||||||
|
(:file "scrollbox-tabbar-tests" :pathname "../../tests/scrollbox-tabbar-tests.lisp"))))
|
||||||
:perform (test-op (o c)
|
:perform (test-op (o c)
|
||||||
(dolist (suite '((:cl-tui-backend-test "BACKEND-SUITE")
|
(dolist (suite '((:cl-tui-backend-test "BACKEND-SUITE")
|
||||||
(:cl-tui-box-test "BOX-SUITE")
|
(:cl-tui-box-test "BOX-SUITE")
|
||||||
(:cl-tui-input-test "INPUT-SUITE")))
|
(:cl-tui-input-test "INPUT-SUITE")
|
||||||
|
(:cl-tui-scrollbox-test "SCROLLBOX-SUITE")))
|
||||||
(let* ((pkg (find-package (first suite)))
|
(let* ((pkg (find-package (first suite)))
|
||||||
(s (and pkg (find-symbol (second suite) pkg))))
|
(s (and pkg (find-symbol (second suite) pkg))))
|
||||||
(when s
|
(when s
|
||||||
|
|||||||
686
org/scrollbox-tabbar.org
Normal file
686
org/scrollbox-tabbar.org
Normal file
@@ -0,0 +1,686 @@
|
|||||||
|
#+TITLE: cl-tui v0.6.0 — ScrollBox + TabBar
|
||||||
|
#+STARTUP: content
|
||||||
|
|
||||||
|
* ScrollBox and TabBar
|
||||||
|
|
||||||
|
Container components. ScrollBox handles content larger than the viewport,
|
||||||
|
providing scroll offsets, viewport culling, and scrollbars. TabBar
|
||||||
|
handles horizontal tab navigation with keyboard support.
|
||||||
|
|
||||||
|
Both components inherit ~dirty-mixin~ and implement the component protocol
|
||||||
|
(~render~, ~component-children~, ~component-layout-node~) so they work
|
||||||
|
with the rendering pipeline and layout engine.
|
||||||
|
|
||||||
|
** Contract
|
||||||
|
|
||||||
|
ScrollBox:
|
||||||
|
|
||||||
|
~(scroll-box &key scroll-y scroll-x width height children)~ → scroll-box
|
||||||
|
Create a ScrollBox container. CHILDREN is a list of components.
|
||||||
|
~scroll-y~ and ~scroll-x~ are the scroll offsets in lines.
|
||||||
|
|
||||||
|
~(scroll-box-children sb)~ → list of child components
|
||||||
|
~(scroll-box-scroll-y sb)~ / ~(setf scroll-box-scroll-y)~
|
||||||
|
~(scroll-box-scroll-x sb)~ / ~(setf scroll-box-scroll-x)~
|
||||||
|
|
||||||
|
~(render ((sb scroll-box) backend))~ — renders visible children with
|
||||||
|
scroll offset applied, then draws scrollbars if content overflows.
|
||||||
|
|
||||||
|
~(scroll-by sb dy dx)~ — adjust scroll offset by DY rows, DX columns.
|
||||||
|
Clamps to valid range (0 to content-size minus viewport-size).
|
||||||
|
|
||||||
|
~(sticky-scroll-p sb)~ / ~(setf sticky-scroll-p)~ — when T, auto-scroll
|
||||||
|
to bottom when new content arrives.
|
||||||
|
|
||||||
|
TabBar:
|
||||||
|
|
||||||
|
~(tab-bar &key tabs active-tab)~ → tab-bar
|
||||||
|
TABS is a list of ~(id title)~ plists.
|
||||||
|
|
||||||
|
~(tab-bar-active sb)~ / ~(setf tab-bar-active)~ — currently active tab id.
|
||||||
|
~(tab-bar-tabs tb)~ — list of tab plists.
|
||||||
|
~(tab-bar-add tb id title)~ — add a tab. Returns the tab id.
|
||||||
|
|
||||||
|
~(render ((tb tab-bar) backend))~ — renders tab row, active tab
|
||||||
|
highlighted, inactive tabs dimmed.
|
||||||
|
|
||||||
|
** Tests
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../tests/scrollbox-tabbar-tests.lisp
|
||||||
|
(defpackage :cl-tui-scrollbox-test
|
||||||
|
(:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.container)
|
||||||
|
(:export #:run-tests))
|
||||||
|
(in-package #:cl-tui-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)")))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
* Implementation
|
||||||
|
|
||||||
|
** Package
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defpackage :cl-tui.container
|
||||||
|
(:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input)
|
||||||
|
(:export
|
||||||
|
;; ScrollBox
|
||||||
|
#:scroll-box #:make-scroll-box
|
||||||
|
#:scroll-box-scroll-y #:scroll-box-scroll-x
|
||||||
|
#:scroll-box-children
|
||||||
|
#:scroll-by #:sticky-scroll-p
|
||||||
|
;; TabBar
|
||||||
|
#:tab-bar #:make-tab-bar
|
||||||
|
#:tab-bar-active #:tab-bar-tabs
|
||||||
|
#:tab-bar-add
|
||||||
|
;; Rendering
|
||||||
|
#:render))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** ScrollBox class
|
||||||
|
|
||||||
|
~scroll-box~ inherits from ~dirty-mixin~ for dirty tracking. It holds a
|
||||||
|
list of child components and two scroll offset slots (~scroll-y~ and
|
||||||
|
~scroll-x~). The ~sticky-scroll-p~ flag, when true, keeps the scroll
|
||||||
|
position at the bottom whenever new children are added.
|
||||||
|
|
||||||
|
The constructor accepts keyword arguments for initial offset and children.
|
||||||
|
~children~ defaults to an empty list.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(in-package #:cl-tui.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)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** ScrollBox: component protocol
|
||||||
|
|
||||||
|
~component-children~ returns the child list for the rendering pipeline
|
||||||
|
to traverse. ~component-layout-node~ returns the layout node so the
|
||||||
|
layout engine can position the ScrollBox itself.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defmethod component-children ((sb scroll-box))
|
||||||
|
(scroll-box-children sb))
|
||||||
|
|
||||||
|
(defmethod component-layout-node ((sb scroll-box))
|
||||||
|
(scroll-box-layout-node sb))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** ScrollBox: scroll-by
|
||||||
|
|
||||||
|
~scroll-by~ adjusts the scroll offset by delta rows and columns. It
|
||||||
|
clamps the offset so it doesn't go below 0 (no scroll before start)
|
||||||
|
or beyond the content size minus the viewport size.
|
||||||
|
|
||||||
|
~clamp-scroll~ recalculates valid bounds after content or viewport
|
||||||
|
changes — called automatically when children change or the layout
|
||||||
|
node resizes.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defun clamp-scroll (sb)
|
||||||
|
"Clamp scroll offsets to valid range."
|
||||||
|
(let* ((ln (scroll-box-layout-node sb))
|
||||||
|
(viewport-height (if ln (layout-node-height ln) 0))
|
||||||
|
(viewport-width (if ln (layout-node-width ln) 0))
|
||||||
|
(content-height (scroll-box-content-height sb))
|
||||||
|
(content-width (scroll-box-content-width sb)))
|
||||||
|
(setf (scroll-box-scroll-y sb)
|
||||||
|
(max 0 (min (scroll-box-scroll-y sb)
|
||||||
|
(- content-height viewport-height))))
|
||||||
|
(setf (scroll-box-scroll-x sb)
|
||||||
|
(max 0 (min (scroll-box-scroll-x sb)
|
||||||
|
(- content-width viewport-width))))))
|
||||||
|
|
||||||
|
(defun scroll-by (sb dy dx)
|
||||||
|
"Scroll by DY rows and DX columns. Clamps to valid range."
|
||||||
|
(incf (scroll-box-scroll-y sb) dy)
|
||||||
|
(incf (scroll-box-scroll-x sb) dx)
|
||||||
|
(clamp-scroll sb)
|
||||||
|
(mark-dirty sb))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** ScrollBox: content size estimation
|
||||||
|
|
||||||
|
~scroll-box-content-height~ and ~scroll-box-content-width~ calculate
|
||||||
|
the total content size by summing child layout node dimensions. This
|
||||||
|
is used by ~clamp-scroll~ and scrollbar rendering.
|
||||||
|
|
||||||
|
For height: sum of all child heights (vertical layout).
|
||||||
|
For width: max of all child widths (horizontal scroll).
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defun scroll-box-content-height (sb)
|
||||||
|
"Total height of all children."
|
||||||
|
(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)
|
||||||
|
"Maximum width among children."
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** ScrollBox: rendering with viewport culling
|
||||||
|
|
||||||
|
~render~ iterates children, computes each child's position within
|
||||||
|
the viewport (adjusted for scroll offset), and only renders children
|
||||||
|
whose visible area intersects the viewport. This is the core
|
||||||
|
optimization — for a terminal with 200 children, only the ~24
|
||||||
|
visible ones are actually drawn.
|
||||||
|
|
||||||
|
~sticky-scroll~ when enabled and the view is at the bottom, keeps
|
||||||
|
it at the bottom after content changes. The flag resets to false
|
||||||
|
when the user manually scrolls up.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defmethod render ((sb scroll-box) backend)
|
||||||
|
"Render visible children with scroll offset applied."
|
||||||
|
(let* ((ln (scroll-box-layout-node sb))
|
||||||
|
(vx 0) (vy 0) ;; viewport origin (parent position)
|
||||||
|
(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
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** ScrollBox: sticky scroll
|
||||||
|
|
||||||
|
~sticky-scroll~ checks whether the view is at the bottom. If so,
|
||||||
|
auto-scrolls to keep the bottommost content visible. The user
|
||||||
|
calling ~scroll-by~ with a negative DY resets the sticky flag.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defun update-sticky-scroll (sb)
|
||||||
|
"If sticky-scroll-p is active and at bottom, keep at bottom."
|
||||||
|
(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)))))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** ScrollBox: scrollbar rendering
|
||||||
|
|
||||||
|
~draw-scrollbars~ renders vertical and horizontal scrollbars as
|
||||||
|
single-character-wide bars on the right and bottom edges of the
|
||||||
|
viewport. The scrollbar thumb position and size reflect the current
|
||||||
|
scroll position relative to content size.
|
||||||
|
|
||||||
|
Vertical scrollbar: blocks (~#\Full~ ~#\Up~ ~#\Mid~ ~#\Down~).
|
||||||
|
Horizontal scrollbar: block characters along the bottom.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defun scrollbar-thumb (scroll-pos viewport-size content-size)
|
||||||
|
"Return the thumb position for a scrollbar (0.0 to 1.0)."
|
||||||
|
(if (> content-size viewport-size)
|
||||||
|
(/ (float scroll-pos) (- content-size viewport-size))
|
||||||
|
0.0))
|
||||||
|
|
||||||
|
(defun draw-scrollbars (sb backend viewport-w viewport-h)
|
||||||
|
"Draw scrollbars if content exceeds viewport."
|
||||||
|
(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)))
|
||||||
|
;; Vertical scrollbar
|
||||||
|
(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 :scrollbar-bg)
|
||||||
|
(draw-text backend (1- viewport-w) thumb-pos "█" nil nil)))
|
||||||
|
;; Horizontal scrollbar
|
||||||
|
(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 :scrollbar-bg)
|
||||||
|
(draw-text backend thumb-pos (1- viewport-h) "█" nil nil)))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** TabBar class
|
||||||
|
|
||||||
|
~tab-bar~ stores a list of tab plists ~((:id :tab1 :title \"One\") ...)~
|
||||||
|
and the currently active tab id. ~tab-bar-add~ creates a new tab with
|
||||||
|
the given id and title, returns the id.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(in-package #:cl-tui.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)
|
||||||
|
"Add a tab with ID and TITLE. Sets as active if first tab."
|
||||||
|
(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)
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** TabBar: component protocol
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defmethod component-layout-node ((tb tab-bar))
|
||||||
|
(tab-bar-layout-node tb))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** TabBar: navigation
|
||||||
|
|
||||||
|
~tab-bar-next~ and ~tab-bar-prev~ cycle through tabs. ~tab-bar-select~
|
||||||
|
activates a tab by id. ~tab-bar-handle-key~ dispatches key events
|
||||||
|
(Left/Right to navigate, optional Enter to select).
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defun tab-bar-next (tb)
|
||||||
|
"Move to next tab."
|
||||||
|
(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)
|
||||||
|
"Move to previous tab."
|
||||||
|
(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)
|
||||||
|
"Select a tab by ID."
|
||||||
|
(setf (tab-bar-active tb) id)
|
||||||
|
(mark-dirty tb))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** TabBar: keyboard handler
|
||||||
|
|
||||||
|
~tab-bar-handle-key~ dispatches Left → previous tab, Right → next tab.
|
||||||
|
Returns T if the key was handled, NIL otherwise (for composability with
|
||||||
|
the keybinding system).
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defun tab-bar-handle-key (tb event)
|
||||||
|
"Handle a key-event on a TabBar. Returns T if handled."
|
||||||
|
(case (key-event-key event)
|
||||||
|
(:left (tab-bar-prev tb) t)
|
||||||
|
(:right (tab-bar-next tb) t)
|
||||||
|
(t nil)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** TabBar: rendering
|
||||||
|
|
||||||
|
~render~ iterates tabs, drawing each as ~[ Title ]~ with the active
|
||||||
|
tab highlighted (bold, accent color) and inactive tabs dimmed. Tabs
|
||||||
|
are separated by two spaces.
|
||||||
|
|
||||||
|
The available width comes from the layout node. If tabs overflow,
|
||||||
|
they are truncated with an ellipsis.
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defmethod render ((tb tab-bar) backend)
|
||||||
|
(let* ((ln (tab-bar-layout-node tb))
|
||||||
|
(x 0) (y 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)))
|
||||||
|
;; Check if tab fits
|
||||||
|
(when (>= (+ x-pos label-len 2) (+ x w))
|
||||||
|
(draw-text backend x-pos y "…" :text-muted nil)
|
||||||
|
(return))
|
||||||
|
;; Draw tab
|
||||||
|
(draw-text backend x-pos y label fg bg)
|
||||||
|
(incf x-pos (+ label-len 2))))
|
||||||
|
(values)))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** Combined tangle blocks
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/scrollbox.lisp
|
||||||
|
(in-package #:cl-tui.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)
|
||||||
|
(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))
|
||||||
|
(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))
|
||||||
|
(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)))
|
||||||
|
(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 :background-element)
|
||||||
|
(draw-text backend (1- viewport-w) 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 :background-element)
|
||||||
|
(draw-text backend thumb-pos (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)))))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/tabbar.lisp
|
||||||
|
(in-package #:cl-tui.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)) (y 0)
|
||||||
|
(w (if ln (layout-node-width ln) 80))
|
||||||
|
(active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos 0))
|
||||||
|
(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))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp :tangle ../src/components/container-package.lisp
|
||||||
|
(defpackage :cl-tui.container
|
||||||
|
(:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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
|
||||||
|
#:render))
|
||||||
|
#+END_SRC
|
||||||
13
src/components/container-package.lisp
Normal file
13
src/components/container-package.lisp
Normal file
@@ -0,0 +1,13 @@
|
|||||||
|
(defpackage :cl-tui.container
|
||||||
|
(:use :cl :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.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
|
||||||
|
#:render))
|
||||||
81
src/components/scrollbox.lisp
Normal file
81
src/components/scrollbox.lisp
Normal file
@@ -0,0 +1,81 @@
|
|||||||
|
(in-package #:cl-tui.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)
|
||||||
|
(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))
|
||||||
|
(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))
|
||||||
|
(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)))
|
||||||
|
(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 :background-element)
|
||||||
|
(draw-text backend (1- viewport-w) 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 :background-element)
|
||||||
|
(draw-text backend thumb-pos (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)))))))
|
||||||
51
src/components/tabbar.lisp
Normal file
51
src/components/tabbar.lisp
Normal file
@@ -0,0 +1,51 @@
|
|||||||
|
(in-package #:cl-tui.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)) (y 0)
|
||||||
|
(w (if ln (layout-node-width ln) 80))
|
||||||
|
(active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos 0))
|
||||||
|
(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))
|
||||||
269
tests/input-tests.lisp
Normal file
269
tests/input-tests.lisp
Normal file
@@ -0,0 +1,269 @@
|
|||||||
|
(defpackage :cl-tui-input-test
|
||||||
|
(:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input)
|
||||||
|
(:export #:run-tests))
|
||||||
|
(in-package :cl-tui-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)))
|
||||||
128
tests/scrollbox-tabbar-tests.lisp
Normal file
128
tests/scrollbox-tabbar-tests.lisp
Normal file
@@ -0,0 +1,128 @@
|
|||||||
|
(defpackage :cl-tui-scrollbox-test
|
||||||
|
(:use :cl :fiveam :cl-tui.backend :cl-tui.box :cl-tui.layout :cl-tui.input :cl-tui.container)
|
||||||
|
(:export #:run-tests))
|
||||||
|
(in-package #:cl-tui-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)")))
|
||||||
Reference in New Issue
Block a user