amr/cl-tty
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

prose: split scrollbox-tabbar.org prose into per-module org files

Browse Source 
Distribute the literate prose from the old combined scrollbox-tabbar.org
into three individual module org files:

- scrollbox.org: ScrollBox class, render, scrollbars, bug fixes,
  plus the combined test suite (tangles scrollbox-tabbar-tests.lisp)
- tabbar.org: TabBar class, navigation, keyboard handler, render
- container-package.org: Package definition and exports

The old scrollbox-tabbar.org is retained as a documentation archive
with all code blocks set to :tangle no and a redirecting note.

Fixes the draw-scrollbars code block to use the post-bugfix version
(with layout-node origin offset ox/oy), matching the working code.
All 13 test suites pass at 100%.
This commit is contained in:
Hermes Agent
2026-05-12 18:06:07 +00:00
parent a061d60898
commit 668966380e
7 changed files with 687 additions and 453 deletions
Download Patch File Download Diff File Expand all files Collapse all files

367
org/scrollbox-tabbar.org
View File

@@ -1,5 +1,23 @@
#+TITLE: cl-tty v0.6.0 — ScrollBox + TabBar
#+TITLE: ScrollBox + TabBar — Archived Combined Module
#+STARTUP: content
#+FILETAGS: :cl-tty:container:
* NOTE: This file is an archive
This org file was the original combined module for ScrollBox, TabBar,
and the container package. It has been split into three separate org
files (one per tangle target):
- ~org/scrollbox.org~ — ScrollBox class, render, scrollbars (tangles
~src/components/scrollbox.lisp~ and ~tests/scrollbox-tabbar-tests.lisp~)
- ~org/tabbar.org~ — TabBar class, navigation, render (tangles
~src/components/tabbar.lisp~)
- ~org/container-package.org~ — Package definition (tangles
~src/components/container-package.lisp~)
All code blocks below are preserved for historical/documentation
reference only and have ~:tangle no~. Do not modify this file;
edit the individual org files above instead.
* ScrollBox and TabBar
@@ -44,144 +62,11 @@ TabBar:
~(render ((tb tab-bar) backend))~ — renders tab row, active tab
highlighted, inactive tabs dimmed.
** Tests
#+BEGIN_SRC lisp :tangle no
(defpackage :cl-tty-scrollbox-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container)
(:export #:run-tests))
(in-package #:cl-tty-scrollbox-test)
(def-suite scrollbox-suite :description "ScrollBox + TabBar tests")
(in-suite scrollbox-suite)
(defun run-tests ()
(let ((result (run 'scrollbox-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
;; ── ScrollBox Tests ─────────────────────────────────────────────
(test scrollbox-creates
"A ScrollBox can be created with defaults."
(let ((sb (make-scroll-box)))
(is (typep sb 'scroll-box))
(is (= (scroll-box-scroll-y sb) 0))
(is (= (scroll-box-scroll-x sb) 0))
(is-false (scroll-box-children sb))))
(test scrollbox-with-children
"A ScrollBox can have children."
(let ((sb (make-scroll-box :children (list (make-text "hello")))))
(is (= (length (scroll-box-children sb)) 1))))
(test scrollbox-scroll-by
"ScrollBy adjusts offset clamped to valid range."
(let ((sb (make-scroll-box :scroll-y 0)))
(scroll-by sb 5 0)
(is (>= (scroll-box-scroll-y sb) 0))))
(test scrollbox-component-children
"Component protocol: children are accessible."
(let* ((child (make-text "hello"))
(sb (make-scroll-box :children (list child))))
(is (eql (first (component-children sb)) child))))
(test scrollbox-render-noop
"Rendering a ScrollBox with no children does not error."
(let* ((stream (make-string-output-stream))
(backend (make-simple-backend :output-stream stream))
(sb (make-scroll-box)))
(render sb backend)
(is-true t)))
;; ── TabBar Tests ────────────────────────────────────────────────
(test tabbar-creates
"A TabBar can be created with defaults."
(let ((tb (make-tab-bar)))
(is (typep tb 'tab-bar))
(is-false (tab-bar-active tb))
(is-false (tab-bar-tabs tb))))
(test tabbar-add-tab
"Adding a tab returns the id and updates tabs."
(let ((tb (make-tab-bar)))
(let ((id (tab-bar-add tb :tab1 "Tab One")))
(is (eql id :tab1))
(is (= (length (tab-bar-tabs tb)) 1))
(is (string= (getf (first (tab-bar-tabs tb)) :title) "Tab One")))))
(test tabbar-active-tab
"Setting active tab works."
(let ((tb (make-tab-bar)))
(tab-bar-add tb :tab1 "One")
(tab-bar-add tb :tab2 "Two")
(setf (tab-bar-active tb) :tab2)
(is (eql (tab-bar-active tb) :tab2))))
(test tabbar-render-noop
"Rendering a TabBar does not error."
(let* ((stream (make-string-output-stream))
(backend (make-simple-backend :output-stream stream))
(tb (make-tab-bar)))
(tab-bar-add tb :tab1 "One")
(tab-bar-add tb :tab2 "Two")
(setf (tab-bar-active tb) :tab1)
(render tb backend)
(is-true t)))
(test tabbar-next-prev
"TabBar next/prev wraps around through tabs."
(let ((tb (make-tab-bar)))
(tab-bar-add tb :tab1 "One")
(tab-bar-add tb :tab2 "Two")
(tab-bar-add tb :tab3 "Three")
(is (eql (tab-bar-active tb) :tab1))
(tab-bar-next tb)
(is (eql (tab-bar-active tb) :tab2))
(tab-bar-next tb)
(is (eql (tab-bar-active tb) :tab3))
(tab-bar-next tb)
(is (eql (tab-bar-active tb) :tab1) "wrap around past last")
(tab-bar-prev tb)
(is (eql (tab-bar-active tb) :tab3) "wrap around past first")))
(test tabbar-select
"TabBar select activates the specified tab."
(let ((tb (make-tab-bar)))
(tab-bar-add tb :tab1 "One")
(tab-bar-add tb :tab2 "Two")
(tab-bar-select tb :tab2)
(is (eql (tab-bar-active tb) :tab2))))
(test tabbar-handle-key
"TabBar handle-key dispatches left/right."
(let ((tb (make-tab-bar)))
(tab-bar-add tb :tab1 "One")
(tab-bar-add tb :tab2 "Two")
(setf (tab-bar-active tb) :tab1)
(tab-bar-handle-key tb (make-key-event :key :right))
(is (eql (tab-bar-active tb) :tab2))
(tab-bar-handle-key tb (make-key-event :key :left))
(is (eql (tab-bar-active tb) :tab1))))
(test scrollbox-scroll-clamp
"ScrollBox clamp prevents scrolling past bounds."
(let ((sb (make-scroll-box :scroll-y 5 :scroll-x 3)))
(setf (scroll-box-scroll-y sb) -1)
(clamp-scroll sb)
(is (= (scroll-box-scroll-y sb) 0) "clamps below 0")
(setf (scroll-box-scroll-y sb) 1000000)
(clamp-scroll sb)
(is (= (scroll-box-scroll-y sb) 0) "clamps above max (no children = 0 content)")))
#+END_SRC
* Implementation
** Package
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defpackage :cl-tty.container
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
(:export
@@ -190,10 +75,12 @@ TabBar:
#:scroll-box-scroll-y #:scroll-box-scroll-x
#:scroll-box-children
#:scroll-by #:sticky-scroll-p
#:clamp-scroll
;; TabBar
#:tab-bar #:make-tab-bar
#:tab-bar-active #:tab-bar-tabs
#:tab-bar-add
#:tab-bar-add #:tab-bar-next #:tab-bar-prev
#:tab-bar-select #:tab-bar-handle-key
;; Rendering
#:render))
#+END_SRC
@@ -208,7 +95,7 @@ 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
#+BEGIN_SRC lisp :tangle no
(in-package #:cl-tty.container)
(defclass scroll-box (dirty-mixin)
@@ -237,7 +124,7 @@ The constructor accepts keyword arguments for initial offset and children.
to traverse. ~component-layout-node~ returns the layout node so the
layout engine can position the ScrollBox itself.
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defmethod component-children ((sb scroll-box))
(scroll-box-children sb))
@@ -255,7 +142,7 @@ or beyond the content size minus the viewport size.
changes — called automatically when children change or the layout
node resizes.
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defun clamp-scroll (sb)
"Clamp scroll offsets to valid range."
(let* ((ln (scroll-box-layout-node sb))
@@ -287,7 +174,7 @@ 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
#+BEGIN_SRC lisp :tangle no
(defun scroll-box-content-height (sb)
"Total height of all children."
(reduce #'+ (scroll-box-children sb)
@@ -317,7 +204,7 @@ visible ones are actually drawn.
it at the bottom after content changes. The flag resets to false
when the user manually scrolls up.
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defmethod render ((sb scroll-box) backend)
"Render visible children with scroll offset applied.
Delegates to each child's `render` method, temporarily offsetting
@@ -357,7 +244,7 @@ the viewport are clipped out."
auto-scrolls to keep the bottommost content visible. The user
calling ~scroll-by~ with a negative DY resets the sticky flag.
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defun update-sticky-scroll (sb)
"If sticky-scroll-p is active and at bottom, keep at bottom."
(when (sticky-scroll-p sb)
@@ -376,10 +263,10 @@ 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~).
Vertical scrollbar: blocks (~#\\Full~ ~#\\Up~ ~#\\Mid~ ~#\\Down~).
Horizontal scrollbar: block characters along the bottom.
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(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)
@@ -408,11 +295,11 @@ Horizontal scrollbar: block characters along the bottom.
** TabBar class
~tab-bar~ stores a list of tab plists ~((:id :tab1 :title \"One\") ...)~
~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
#+BEGIN_SRC lisp :tangle no
(in-package #:cl-tty.container)
(defclass tab-bar (dirty-mixin)
@@ -437,7 +324,7 @@ the given id and title, returns the id.
** TabBar: component protocol
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defmethod component-layout-node ((tb tab-bar))
(tab-bar-layout-node tb))
#+END_SRC
@@ -448,7 +335,7 @@ the given id and title, returns the id.
activates a tab by id. ~tab-bar-handle-key~ dispatches key events
(Left/Right to navigate, optional Enter to select).
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defun tab-bar-next (tb)
"Move to next tab."
(let* ((tabs (tab-bar-tabs tb))
@@ -483,7 +370,7 @@ activates a tab by id. ~tab-bar-handle-key~ dispatches key events
Returns T if the key was handled, NIL otherwise (for composability with
the keybinding system).
#+BEGIN_SRC lisp
#+BEGIN_SRC lisp :tangle no
(defun tab-bar-handle-key (tb event)
"Handle a key-event on a TabBar. Returns T if handled."
(case (key-event-key event)
@@ -501,7 +388,7 @@ 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
#+BEGIN_SRC lisp :tangle no
(defmethod render ((tb tab-bar) backend)
(let* ((ln (tab-bar-layout-node tb))
(x (if ln (layout-node-x ln) 0))
@@ -520,7 +407,7 @@ they are truncated with an ellipsis.
(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)
(draw-text backend x-pos y "..." :text-muted nil)
(return))
;; Draw tab
(draw-text backend x-pos y label fg bg)
@@ -548,175 +435,21 @@ Two bugs were fixed in the ScrollBox render pipeline:
Fix: Read the scrollbox's layout-node origin ~(ox, oy)~ and offset all
scrollbar drawing coordinates by those values.
** Combined tangle blocks
* Tests
#+BEGIN_SRC lisp :tangle no
(in-package #:cl-tty.container)
(defpackage :cl-tty-scrollbox-test
(:use :cl :fiveam :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input :cl-tty.container)
(:export #:run-tests))
(in-package #:cl-tty-scrollbox-test)
(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)))
(def-suite scrollbox-suite :description "ScrollBox + TabBar tests")
(in-suite scrollbox-suite)
(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)))
(defun run-tests ()
(let ((result (run 'scrollbox-suite)))
(fiveam:explain! result)
(uiop:quit 0)))
(defmethod component-children ((sb scroll-box)) (scroll-box-children sb))
(defmethod component-layout-node ((sb scroll-box)) (scroll-box-layout-node sb))
(defun clamp-scroll (sb)
(let* ((ln (scroll-box-layout-node sb))
(viewport-h (if ln (layout-node-height ln) 0))
(viewport-w (if ln (layout-node-width ln) 0))
(content-h (scroll-box-content-height sb))
(content-w (scroll-box-content-width sb)))
(setf (scroll-box-scroll-y sb) (max 0 (min (scroll-box-scroll-y sb) (- content-h viewport-h))))
(setf (scroll-box-scroll-x sb) (max 0 (min (scroll-box-scroll-x sb) (- content-w viewport-w))))))
(defun scroll-by (sb dy dx)
(incf (scroll-box-scroll-y sb) dy) (incf (scroll-box-scroll-x sb) dx)
(clamp-scroll sb) (mark-dirty sb))
(defun scroll-box-content-height (sb)
(reduce #'+ (scroll-box-children sb)
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-height ln)) 1)))
:initial-value 0))
(defun scroll-box-content-width (sb)
(reduce #'max (scroll-box-children sb)
:key (lambda (c) (let ((ln (component-layout-node c))) (if ln (max 1 (layout-node-width ln)) 1)))
:initial-value 0))
(defmethod render ((sb scroll-box) backend)
"Render ScrollBox children within the viewport, offset by scroll position.
Children outside the viewport are skipped."
(let* ((ln (scroll-box-layout-node sb))
(vx 0) (vy 0)
(vw (if ln (layout-node-width ln) 80))
(vh (if ln (layout-node-height ln) 24))
(sy (scroll-box-scroll-y sb))
(sx (scroll-box-scroll-x sb)))
(dolist (child (scroll-box-children sb))
(let* ((cln (component-layout-node child))
(ch (if cln (layout-node-height cln) 1))
(cy vy))
;; Only render children that are visible in the viewport
(when (and (< (- cy sy) vh)
(> (+ (- cy sy) ch) 0))
;; Temporarily offset child's layout-node position for rendering
(let ((orig-x (if cln (layout-node-x cln) 0))
(orig-y (if cln (layout-node-y cln) 0)))
(when cln
(setf (layout-node-x cln) (- vx sx)
(layout-node-y cln) (- vy sy)))
(unwind-protect
(render child backend)
(when cln
(setf (layout-node-x cln) orig-x
(layout-node-y cln) orig-y)))))
(incf vy ch)))
(draw-scrollbars sb backend vw vh)))
(defun scrollbar-thumb (scroll-pos viewport-size content-size)
(if (> content-size viewport-size) (/ (float scroll-pos) (- content-size viewport-size)) 0.0))
(defun draw-scrollbars (sb backend viewport-w viewport-h)
(let* ((content-h (scroll-box-content-height sb)) (content-w (scroll-box-content-width sb))
(sy (scroll-box-scroll-y sb)) (sx (scroll-box-scroll-x sb))
(ln (scroll-box-layout-node sb))
(ox (if ln (layout-node-x ln) 0))
(oy (if ln (layout-node-y ln) 0)))
(when (> content-h viewport-h)
(let* ((thumb (scrollbar-thumb sy viewport-h content-h))
(thumb-pos (round (* thumb viewport-h))))
(draw-rect backend (+ ox (1- viewport-w)) oy 1 viewport-h :bg :bright-black)
(draw-text backend (+ ox (1- viewport-w)) (+ oy thumb-pos) "█" nil nil)))
(when (> content-w viewport-w)
(let* ((thumb (scrollbar-thumb sx viewport-w content-w))
(thumb-pos (round (* thumb viewport-w))))
(draw-rect backend ox (+ oy (1- viewport-h)) viewport-w 1 :bg :bright-black)
(draw-text backend (+ ox thumb-pos) (+ oy (1- viewport-h)) "█" nil nil)))))
(defun update-sticky-scroll (sb)
(when (sticky-scroll-p sb)
(let* ((content-h (scroll-box-content-height sb))
(ln (scroll-box-layout-node sb))
(viewport-h (if ln (layout-node-height ln) 24)))
(when (>= (scroll-box-scroll-y sb) (- content-h viewport-h 1))
(setf (scroll-box-scroll-y sb) (max 0 (- content-h viewport-h)))))))
#+END_SRC
#+BEGIN_SRC lisp :tangle no
(in-package #:cl-tty.container)
(defclass tab-bar (dirty-mixin)
((tabs :initform nil :initarg :tabs :accessor tab-bar-tabs :type list)
(active :initform nil :initarg :active :accessor tab-bar-active)
(layout-node :initform (make-layout-node) :accessor tab-bar-layout-node)
(focusable :initform t :accessor tab-bar-focusable)))
(defun make-tab-bar (&key tabs active)
(make-instance 'tab-bar :tabs (or tabs nil) :active active))
(defun tab-bar-add (tb id title)
(setf (tab-bar-tabs tb) (nconc (tab-bar-tabs tb) (list (list :id id :title title))))
(unless (tab-bar-active tb) (setf (tab-bar-active tb) id)) id)
(defmethod component-layout-node ((tb tab-bar)) (tab-bar-layout-node tb))
(defun tab-bar-next (tb)
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
(pos (position current ids)))
(when pos (let ((next (nth (mod (1+ pos) (length ids)) ids)))
(setf (tab-bar-active tb) next) (mark-dirty tb)))))
(defun tab-bar-prev (tb)
(let* ((tabs (tab-bar-tabs tb)) (current (tab-bar-active tb))
(ids (mapcar (lambda (tab) (getf tab :id)) tabs))
(pos (position current ids)))
(when pos (let ((prev (nth (mod (1- pos) (length ids)) ids)))
(setf (tab-bar-active tb) prev) (mark-dirty tb)))))
(defun tab-bar-select (tb id) (setf (tab-bar-active tb) id) (mark-dirty tb))
(defun tab-bar-handle-key (tb event)
(case (key-event-key event) (:left (tab-bar-prev tb) t) (:right (tab-bar-next tb) t) (t nil)))
(defmethod render ((tb tab-bar) backend)
(let* ((ln (tab-bar-layout-node tb))
(x (if ln (layout-node-x ln) 0))
(y (if ln (layout-node-y ln) 0))
(w (if ln (layout-node-width ln) 80))
(active-id (tab-bar-active tb)) (tabs (tab-bar-tabs tb)) (x-pos x))
(dolist (tab tabs)
(let* ((id (getf tab :id)) (title (getf tab :title))
(label (format nil " ~A " title)) (label-len (length label))
(is-active (eql id active-id))
(fg (if is-active :accent :text-muted))
(bg (if is-active :background-element nil)))
(when (>= (+ x-pos label-len 2) w)
(draw-text backend x-pos y "..." :text-muted nil) (return))
(draw-text backend x-pos y label fg bg)
(incf x-pos (+ label-len 2)))))
(values))
#+END_SRC
#+BEGIN_SRC lisp :tangle no
(defpackage :cl-tty.container
(:use :cl :cl-tty.backend :cl-tty.box :cl-tty.layout :cl-tty.input)
(:export
#:scroll-box #:make-scroll-box
#:scroll-box-scroll-y #:scroll-box-scroll-x
#:scroll-box-children #:scroll-by
#:sticky-scroll-p
#:clamp-scroll
#:tab-bar #:make-tab-bar
#:tab-bar-active #:tab-bar-tabs
#:tab-bar-add #:tab-bar-next #:tab-bar-prev
#:tab-bar-select #:tab-bar-handle-key))
;; ScrollBox tests omitted here — see org/scrollbox.org
#+END_SRC