Merge pull request 'v0.2.0: Box and Text renderables + dirty tracking' (#3) from feature/v0.2.0-box-and-text into main
Reviewed-on: http://10.10.10.201:3001/amr/cl-tui/pulls/3
This commit was merged in pull request #3.
This commit is contained in:
@@ -113,12 +113,13 @@
|
|||||||
|
|
||||||
(defclass modern-backend (backend)
|
(defclass modern-backend (backend)
|
||||||
((output-stream :initform *standard-output*
|
((output-stream :initform *standard-output*
|
||||||
|
:initarg :output-stream
|
||||||
:accessor backend-output-stream)
|
:accessor backend-output-stream)
|
||||||
(in-sync-p :initform nil :accessor in-sync-p)))
|
(in-sync-p :initform nil :accessor in-sync-p)))
|
||||||
|
|
||||||
(defun make-modern-backend (&key color-palette)
|
(defun make-modern-backend (&key color-palette output-stream)
|
||||||
(declare (ignore color-palette))
|
(declare (ignore color-palette))
|
||||||
(make-instance 'modern-backend))
|
(make-instance 'modern-backend :output-stream (or output-stream *standard-output*)))
|
||||||
|
|
||||||
(defmethod initialize-backend ((b modern-backend))
|
(defmethod initialize-backend ((b modern-backend))
|
||||||
;; Enter raw mode, enable mouse, bracketed paste
|
;; Enter raw mode, enable mouse, bracketed paste
|
||||||
|
|||||||
18
cl-tui.asd
18
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.0.3"
|
:version "0.2.0"
|
||||||
:license "TBD"
|
:license "TBD"
|
||||||
:depends-on (:fiveam)
|
:depends-on (:fiveam)
|
||||||
:components
|
:components
|
||||||
@@ -14,7 +14,13 @@
|
|||||||
(:file "modern" :depends-on ("package" "classes"))))
|
(:file "modern" :depends-on ("package" "classes"))))
|
||||||
(:module "layout"
|
(:module "layout"
|
||||||
:components
|
:components
|
||||||
((:file "layout"))))
|
((:file "layout")))
|
||||||
|
(:module "src/components"
|
||||||
|
:components
|
||||||
|
((:file "package")
|
||||||
|
(:file "dirty")
|
||||||
|
(:file "box" :depends-on ("package"))
|
||||||
|
(:file "text" :depends-on ("package" "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
|
||||||
@@ -26,6 +32,10 @@
|
|||||||
((:file "tests")))
|
((:file "tests")))
|
||||||
(:module "layout"
|
(:module "layout"
|
||||||
:components
|
:components
|
||||||
((:file "tests"))))
|
((:file "tests")))
|
||||||
|
(:module "src/components"
|
||||||
|
:components
|
||||||
|
((:file "box-tests")
|
||||||
|
(:file "dirty-tests"))))
|
||||||
:perform (test-op (o c)
|
:perform (test-op (o c)
|
||||||
(uiop:symbol-call :cl-tui-backend-test '#:run!)))
|
(uiop:symbol-call :cl-tui-backend-test '#:run-tests)))
|
||||||
|
|||||||
@@ -157,11 +157,14 @@ The first two renderable types that every application uses. A Box draws borders
|
|||||||
and backgrounds. A Text renders strings with color and style. Together they
|
and backgrounds. A Text renders strings with color and style. Together they
|
||||||
cover 80% of terminal UI.
|
cover 80% of terminal UI.
|
||||||
|
|
||||||
*** TODO Box renderable
|
*** DONE Box renderable
|
||||||
:PROPERTIES:
|
:PROPERTIES:
|
||||||
:ID: id-v020-box
|
:ID: id-v020-box
|
||||||
:CREATED: [2026-05-10 Sat]
|
:CREATED: [2026-05-10 Sat]
|
||||||
:END:
|
:END:
|
||||||
|
:LOGBOOK:
|
||||||
|
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
|
||||||
|
:END:
|
||||||
|
|
||||||
- ~(defclass box ...)~ — renderable with background color, border, title
|
- ~(defclass box ...)~ — renderable with background color, border, title
|
||||||
- ~(render-box box window)~ — draws border (single/double/rounded), fills background, renders title
|
- ~(render-box box window)~ — draws border (single/double/rounded), fills background, renders title
|
||||||
@@ -170,11 +173,14 @@ cover 80% of terminal UI.
|
|||||||
- ~:focusable~ property — renders focused border color when focused
|
- ~:focusable~ property — renders focused border color when focused
|
||||||
- ~100 lines
|
- ~100 lines
|
||||||
|
|
||||||
*** TODO Text renderable
|
*** DONE Text renderable
|
||||||
:PROPERTIES:
|
:PROPERTIES:
|
||||||
:ID: id-v020-text
|
:ID: id-v020-text
|
||||||
:CREATED: [2026-05-10 Sat]
|
:CREATED: [2026-05-10 Sat]
|
||||||
:END:
|
:END:
|
||||||
|
:LOGBOOK:
|
||||||
|
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
|
||||||
|
:END:
|
||||||
|
|
||||||
- ~(defclass text ...)~ — renderable with content, fg/bg color, wrap mode
|
- ~(defclass text ...)~ — renderable with content, fg/bg color, wrap mode
|
||||||
- ~(render-text text window)~ — renders text at the layout position, wraps at width
|
- ~(render-text text window)~ — renders text at the layout position, wraps at width
|
||||||
@@ -182,22 +188,28 @@ cover 80% of terminal UI.
|
|||||||
- CJK/emoji character-width aware wrapping
|
- CJK/emoji character-width aware wrapping
|
||||||
- ~100 lines
|
- ~100 lines
|
||||||
|
|
||||||
*** TODO Inline text styles
|
*** DONE Inline text styles
|
||||||
:PROPERTIES:
|
:PROPERTIES:
|
||||||
:ID: id-v020-inline
|
:ID: id-v020-inline
|
||||||
:CREATED: [2026-05-10 Sat]
|
:CREATED: [2026-05-10 Sat]
|
||||||
:END:
|
:END:
|
||||||
|
:LOGBOOK:
|
||||||
|
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
|
||||||
|
:END:
|
||||||
|
|
||||||
- ~(defclass span ...)~ — inline text segment with attributes
|
- ~(defclass span ...)~ — inline text segment with attributes
|
||||||
- Text attributes: ~:bold~, ~:italic~, ~:underline~, ~:dim~, ~:reverse~
|
- Text attributes: ~:bold~, ~:italic~, ~:underline~, ~:dim~, ~:reverse~
|
||||||
- ~(make-text "hello " (bold "world") "!")~ — builds styled text from spans and strings
|
- ~(make-text "hello " (bold "world") "!")~ — builds styled text from spans and strings
|
||||||
- ~60 lines
|
- ~60 lines
|
||||||
|
|
||||||
*** TODO Dirty tracking
|
*** DONE Dirty tracking
|
||||||
:PROPERTIES:
|
:PROPERTIES:
|
||||||
:ID: id-v020-dirty
|
:ID: id-v020-dirty
|
||||||
:CREATED: [2026-05-10 Sat]
|
:CREATED: [2026-05-10 Sat]
|
||||||
:END:
|
:END:
|
||||||
|
:LOGBOOK:
|
||||||
|
- State \"DONE\" from \"TODO\" [2026-05-11 Mon]
|
||||||
|
:END:
|
||||||
|
|
||||||
- ~(mark-dirty component)~ — flags component and all ancestors
|
- ~(mark-dirty component)~ — flags component and all ancestors
|
||||||
- ~(dirty-p component)~ — returns T if the component needs re-rendering
|
- ~(dirty-p component)~ — returns T if the component needs re-rendering
|
||||||
|
|||||||
127
docs/plans/2026-05-11-v0.2.0-box-and-text.md
Normal file
127
docs/plans/2026-05-11-v0.2.0-box-and-text.md
Normal file
@@ -0,0 +1,127 @@
|
|||||||
|
# v0.2.0: Renderables — Box and Text
|
||||||
|
|
||||||
|
> Implementation plan for the first two renderable component types.
|
||||||
|
|
||||||
|
**Goal:** Create Box (border+background+title) and Text (styled wrapping text) renderables that render through the backend protocol.
|
||||||
|
|
||||||
|
**Architecture:** Each renderable is a CLOS class with a `layout-node` slot for positioning. The `render` method dispatches through the backend protocol (draw-text, draw-border, draw-rect). Tests capture backend output via string streams.
|
||||||
|
|
||||||
|
**Files created:**
|
||||||
|
- `org/box-renderable.org` — Box class, render method (literate source)
|
||||||
|
- `org/text-renderable.org` — Text class, render method, inline spans (literate source)
|
||||||
|
- `org/dirty-tracking.org` — Dirty flag system (literate source)
|
||||||
|
- `src/components/box.lisp` — tangled
|
||||||
|
- `src/components/text.lisp` — tangled
|
||||||
|
- `src/components/dirty.lisp` — tangled
|
||||||
|
|
||||||
|
**Files modified:**
|
||||||
|
- `cl-tui.asd` — add component modules
|
||||||
|
- `docs/ROADMAP.org` — mark v0.2.0 tasks DONE
|
||||||
|
|
||||||
|
## Task 1: Box renderable
|
||||||
|
|
||||||
|
**Objective:** Box class that draws borders, fills backgrounds, and renders titles.
|
||||||
|
|
||||||
|
**Files:**
|
||||||
|
- Create: `org/box-renderable.org`
|
||||||
|
- Create: `src/components/box.lisp` (extracted)
|
||||||
|
- Modify: `cl-tui.asd` — add components module
|
||||||
|
|
||||||
|
**Box class:**
|
||||||
|
```lisp
|
||||||
|
(defclass box ()
|
||||||
|
((layout-node :initarg :layout-node :accessor box-layout-node)
|
||||||
|
(border-style :initform :single :initarg :border-style :accessor box-border-style)
|
||||||
|
(title :initform nil :initarg :title :accessor box-title)
|
||||||
|
(title-align :initform :left :initarg :title-align :accessor box-title-align)
|
||||||
|
(fg :initform nil :initarg :fg :accessor box-fg)
|
||||||
|
(bg :initform nil :initarg :bg :accessor box-bg)))
|
||||||
|
```
|
||||||
|
|
||||||
|
**render-box method:**
|
||||||
|
Renders at computed layout position using backend's draw-border, draw-rect, draw-text.
|
||||||
|
Delegates to the backend — no escape sequences directly.
|
||||||
|
|
||||||
|
**Tests:**
|
||||||
|
- Create box with border, verify draw-border was called with correct params
|
||||||
|
- Create box with title, verify title positioning
|
||||||
|
- Create box with background fill
|
||||||
|
- Edge cases: box with 0 width/height, no border style, very long title
|
||||||
|
|
||||||
|
## Task 2: Text renderable
|
||||||
|
|
||||||
|
**Objective:** Text class that renders strings at layout position with word-wrap.
|
||||||
|
|
||||||
|
**Files:**
|
||||||
|
- Create: `org/text-renderable.org`
|
||||||
|
- Create: `src/components/text.lisp` (extracted)
|
||||||
|
|
||||||
|
**Text class:**
|
||||||
|
```lisp
|
||||||
|
(defclass text ()
|
||||||
|
((layout-node :initarg :layout-node :accessor text-layout-node)
|
||||||
|
(content :initarg :content :accessor text-content)
|
||||||
|
(fg :initform nil :initarg :fg :accessor text-fg)
|
||||||
|
(bg :initform nil :initarg :bg :accessor text-bg)
|
||||||
|
(wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode)
|
||||||
|
(spans :initform nil :initarg :spans :accessor text-spans)))
|
||||||
|
```
|
||||||
|
|
||||||
|
**render-text method:**
|
||||||
|
1. Get layout position (x, y, width, height)
|
||||||
|
2. If wrap-mode is :none, truncate to width
|
||||||
|
3. If wrap-mode is :word, word-wrap (break on whitespace)
|
||||||
|
4. Draw each line via backend's draw-text
|
||||||
|
5. Apply span attributes (bold, italic, etc.) per segment
|
||||||
|
|
||||||
|
**Inline spans:**
|
||||||
|
```lisp
|
||||||
|
(defclass span ()
|
||||||
|
((text :initarg :text :accessor span-text)
|
||||||
|
(bold :initform nil :initarg :bold :accessor span-bold)
|
||||||
|
(italic :initform nil :initarg :italic :accessor span-italic)
|
||||||
|
(underline :initform nil :initarg :underline :accessor span-underline)))
|
||||||
|
```
|
||||||
|
|
||||||
|
**Tests:**
|
||||||
|
- Text renders string at correct position
|
||||||
|
- Word-wrap breaks at word boundaries
|
||||||
|
- Truncation mode clips at width
|
||||||
|
- Spans apply style attributes per segment
|
||||||
|
- Empty string rendering
|
||||||
|
- Single character
|
||||||
|
- String shorter than width (no wrapping needed)
|
||||||
|
|
||||||
|
## Task 3: Dirty tracking
|
||||||
|
|
||||||
|
**Objective:** Lightweight dirty-flag system for incremental rendering.
|
||||||
|
|
||||||
|
**Files:**
|
||||||
|
- Create: `org/dirty-tracking.org`
|
||||||
|
- Create: `src/components/dirty.lisp` (extracted)
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(defgeneric mark-dirty (component))
|
||||||
|
(defgeneric dirty-p (component))
|
||||||
|
(defgeneric mark-clean (component))
|
||||||
|
```
|
||||||
|
|
||||||
|
Default methods mark/check a `dirty` slot on the component. When implemented:
|
||||||
|
- `mark-dirty` — sets dirty flag, propagates to parent
|
||||||
|
- `dirty-p` — returns T if component needs re-render
|
||||||
|
- `mark-clean` — clears dirty flag after render
|
||||||
|
|
||||||
|
**Tests:**
|
||||||
|
- New component is dirty (default)
|
||||||
|
- mark-clean clears dirty flag
|
||||||
|
- dirty-p returns nil after mark-clean
|
||||||
|
- mark-dirty sets dirty flag again
|
||||||
|
|
||||||
|
## Task 4: Wire into ASDF + update roadmap
|
||||||
|
|
||||||
|
**Files:**
|
||||||
|
- Modify: `cl-tui.asd` — add `:module "components"` to both main and test systems
|
||||||
|
- Modify: `docs/ROADMAP.org` — mark v0.2.0 tasks DONE
|
||||||
|
|
||||||
|
**Run full test suite:**
|
||||||
|
All 72 existing tests + new component tests: 100% GREEN.
|
||||||
169
org/box-renderable.org
Normal file
169
org/box-renderable.org
Normal file
@@ -0,0 +1,169 @@
|
|||||||
|
#+TITLE: cl-tui Box Renderable — v0.2.0
|
||||||
|
#+STARTUP: content
|
||||||
|
#+FILETAGS: :cl-tui:components:v0.2.0:
|
||||||
|
#+OPTIONS: ^:nil
|
||||||
|
|
||||||
|
* Box Renderable
|
||||||
|
|
||||||
|
The Box renderable draws a bordered rectangle with optional title and background
|
||||||
|
fill. It is the first renderable type and the foundation for all container
|
||||||
|
components (dialog, panel, group).
|
||||||
|
|
||||||
|
A Box has a =layout-node= slot for positioning via the layout engine. Its
|
||||||
|
=render-box= method dispatches through the backend protocol.
|
||||||
|
|
||||||
|
** Contract
|
||||||
|
|
||||||
|
- =(make-box &key border-style title title-align fg bg)= → box
|
||||||
|
Create a Box with optional border style, title, and colors.
|
||||||
|
|
||||||
|
- =(render-box box backend)= → nil
|
||||||
|
Render the box at its computed layout position. Draws background fill,
|
||||||
|
border, and title if configured.
|
||||||
|
|
||||||
|
- =(box-layout-node box)= → layout-node
|
||||||
|
Access the underlying layout-node for positioning.
|
||||||
|
|
||||||
|
** Tests
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(defpackage :cl-tui-box-test
|
||||||
|
(:use :cl :fiveam :cl-tui.backend :cl-tui.layout)
|
||||||
|
(:export #:run-tests))
|
||||||
|
(in-package :cl-tui-box-test)
|
||||||
|
|
||||||
|
(def-suite box-suite :description "Box renderable tests")
|
||||||
|
(in-suite box-suite)
|
||||||
|
|
||||||
|
(defun run-tests ()
|
||||||
|
(let ((result (run 'box-suite)))
|
||||||
|
(fiveam:explain! result)
|
||||||
|
(uiop:quit 0)))
|
||||||
|
|
||||||
|
(defun make-capturing-backend ()
|
||||||
|
(let* ((s (make-string-output-stream))
|
||||||
|
(b (make-modern-backend :output-stream s)))
|
||||||
|
(values b s)))
|
||||||
|
|
||||||
|
(test box-creates-with-defaults
|
||||||
|
"A box created with no arguments has reasonable defaults"
|
||||||
|
(let ((b (make-box)))
|
||||||
|
(is (typep b 'box))
|
||||||
|
(is (typep (box-layout-node b) 'layout-node))))
|
||||||
|
|
||||||
|
(test box-renders-border
|
||||||
|
"A box with border draws border characters"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 10 :height 5)))
|
||||||
|
(compute-layout (box-layout-node bx) 10 5)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "┌" out) "top-left corner")
|
||||||
|
(is (search "┐" out) "top-right corner")
|
||||||
|
(is (search "└" out) "bottom-left corner")
|
||||||
|
(is (search "┘" out) "bottom-right corner")))))
|
||||||
|
|
||||||
|
(test box-renders-background
|
||||||
|
"A box with background color fills interior"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :bg :red :width 5 :height 3)))
|
||||||
|
(compute-layout (box-layout-node bx) 5 3)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
;; Should contain SGR background escape for red
|
||||||
|
(is (search "48;2;255;0;0" out) "SGR background should be red")
|
||||||
|
(is (search "┌" out) "border with background")))))
|
||||||
|
|
||||||
|
(test box-renders-title
|
||||||
|
"A box with title renders the title text"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :title "Hello" :width 12 :height 3)))
|
||||||
|
(compute-layout (box-layout-node bx) 12 3)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "Hello" out) "title text should appear")))))
|
||||||
|
|
||||||
|
(test box-without-border
|
||||||
|
"A box with border-style nil draws no border"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style nil :bg :red :width 5 :height 3)))
|
||||||
|
(compute-layout (box-layout-node bx) 5 3)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "48;2;255;0;0" out) "background still renders")
|
||||||
|
;; No border chars
|
||||||
|
(is-false (search "┌" out) "no top-left corner")))))
|
||||||
|
|
||||||
|
(test box-zero-size
|
||||||
|
"A zero-size box renders nothing"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 0 :height 0)))
|
||||||
|
(compute-layout (box-layout-node bx) 0 0)
|
||||||
|
(render-box bx b)
|
||||||
|
(is (string= (get-output-stream-string s) "")
|
||||||
|
"zero-size box produces no output"))))
|
||||||
|
|
||||||
|
(test box-minimum-size
|
||||||
|
"A box with minimum non-zero size still renders"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 2 :height 2)))
|
||||||
|
(compute-layout (box-layout-node bx) 2 2)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "┌" out) "2x2 box still has borders")))))
|
||||||
|
#+END_SRC
|
||||||
|
|
||||||
|
** Implementation
|
||||||
|
|
||||||
|
#+BEGIN_SRC lisp
|
||||||
|
(in-package :cl-tui.box)
|
||||||
|
|
||||||
|
(defclass box ()
|
||||||
|
((layout-node :initform (make-layout-node) :accessor box-layout-node
|
||||||
|
:initarg :layout-node)
|
||||||
|
(border-style :initform :single :initarg :border-style
|
||||||
|
:accessor box-border-style)
|
||||||
|
(title :initform nil :initarg :title :accessor box-title)
|
||||||
|
(title-align :initform :left :initarg :title-align
|
||||||
|
:accessor box-title-align)
|
||||||
|
(fg :initform nil :initarg :fg :accessor box-fg)
|
||||||
|
(bg :initform nil :initarg :bg :accessor box-bg)))
|
||||||
|
|
||||||
|
(defun make-box (&key (border-style :single) title
|
||||||
|
(title-align :left) fg bg
|
||||||
|
width height)
|
||||||
|
(make-instance 'box
|
||||||
|
:border-style border-style
|
||||||
|
:title title
|
||||||
|
:title-align title-align
|
||||||
|
:fg fg
|
||||||
|
:bg bg
|
||||||
|
:layout-node (make-layout-node
|
||||||
|
:width width
|
||||||
|
:height height
|
||||||
|
:direction :column)))
|
||||||
|
|
||||||
|
(defun render-box (box backend)
|
||||||
|
"Render BOX at its computed layout position using BACKEND."
|
||||||
|
(let ((ln (box-layout-node box))
|
||||||
|
(bs (box-border-style box))
|
||||||
|
(title (box-title box))
|
||||||
|
(fg (box-fg box))
|
||||||
|
(bg (box-bg box)))
|
||||||
|
(let ((x (layout-node-x ln))
|
||||||
|
(y (layout-node-y ln))
|
||||||
|
(w (layout-node-width ln))
|
||||||
|
(h (layout-node-height ln)))
|
||||||
|
(when (and (zerop w) (zerop h))
|
||||||
|
(return-from render-box (values)))
|
||||||
|
(when bg
|
||||||
|
(draw-rect backend x y w h :bg bg))
|
||||||
|
(when bs
|
||||||
|
(draw-border backend x y w h
|
||||||
|
:style bs :fg fg :bg bg
|
||||||
|
:title title
|
||||||
|
:title-align (box-title-align box)))
|
||||||
|
(when (and title bs)
|
||||||
|
;; Title is rendered by draw-border — nothing extra needed
|
||||||
|
(values)))))
|
||||||
|
#+END_SRC
|
||||||
166
src/components/box-tests.lisp
Normal file
166
src/components/box-tests.lisp
Normal file
@@ -0,0 +1,166 @@
|
|||||||
|
(defpackage :cl-tui-box-test
|
||||||
|
(:use :cl :fiveam :cl-tui.backend :cl-tui.layout :cl-tui.box)
|
||||||
|
(:export #:run-tests))
|
||||||
|
(in-package :cl-tui-box-test)
|
||||||
|
|
||||||
|
(def-suite box-suite :description "Box renderable tests")
|
||||||
|
(in-suite box-suite)
|
||||||
|
|
||||||
|
(defun run-tests ()
|
||||||
|
(let ((result (run 'box-suite)))
|
||||||
|
(fiveam:explain! result)
|
||||||
|
(uiop:quit 0)))
|
||||||
|
|
||||||
|
(defun make-capturing-backend ()
|
||||||
|
(let* ((s (make-string-output-stream))
|
||||||
|
(b (make-modern-backend :output-stream s)))
|
||||||
|
(values b s)))
|
||||||
|
|
||||||
|
;; ── Box Tests ─────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(test box-creates-with-defaults
|
||||||
|
"A box created with no arguments has reasonable defaults"
|
||||||
|
(let ((b (make-box)))
|
||||||
|
(is (typep b 'box))
|
||||||
|
(is (typep (box-layout-node b) 'layout-node))))
|
||||||
|
|
||||||
|
(test box-renders-border
|
||||||
|
"A box with border draws border characters"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 10 :height 5)))
|
||||||
|
(compute-layout (box-layout-node bx) 10 5)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "┌" out) "top-left corner")
|
||||||
|
(is (search "┐" out) "top-right corner")
|
||||||
|
(is (search "└" out) "bottom-left corner")
|
||||||
|
(is (search "┘" out) "bottom-right corner")))))
|
||||||
|
|
||||||
|
(test box-renders-background
|
||||||
|
"A box with background color fills interior"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :bg :red :width 5 :height 3)))
|
||||||
|
(compute-layout (box-layout-node bx) 5 3)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "┌" out) "border with background")
|
||||||
|
(is (search "41m" out) "SGR background for red")))))
|
||||||
|
|
||||||
|
(test box-renders-title
|
||||||
|
"A box with title renders the title text"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :title "Hello" :width 12 :height 3)))
|
||||||
|
(compute-layout (box-layout-node bx) 12 3)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "Hello" out) "title text should appear")))))
|
||||||
|
|
||||||
|
(test box-without-border
|
||||||
|
"A box with border-style nil draws no border"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style nil :bg :red :width 5 :height 3)))
|
||||||
|
(compute-layout (box-layout-node bx) 5 3)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "41m" out) "background still renders")
|
||||||
|
(is-false (search "┌" out) "no top-left corner")))))
|
||||||
|
|
||||||
|
(test box-zero-size
|
||||||
|
"A box with any zero dimension renders nothing"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 0 :height 0)))
|
||||||
|
(compute-layout (box-layout-node bx) 0 0)
|
||||||
|
(render-box bx b)
|
||||||
|
(is (string= (get-output-stream-string s) "")
|
||||||
|
"zero-size box produces no output"))))
|
||||||
|
|
||||||
|
(test box-single-column
|
||||||
|
"A box with width 1 renders nothing (needs min 2 for border)"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 1 :height 5)))
|
||||||
|
(compute-layout (box-layout-node bx) 1 5)
|
||||||
|
(render-box bx b)
|
||||||
|
(is (string= (get-output-stream-string s) "")
|
||||||
|
"width=1 box renders nothing"))))
|
||||||
|
|
||||||
|
(test box-minimum-size
|
||||||
|
"A box with minimum non-zero size still renders"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((bx (make-box :border-style :single :width 2 :height 2)))
|
||||||
|
(compute-layout (box-layout-node bx) 2 2)
|
||||||
|
(render-box bx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "┌" out) "2x2 box still has borders")))))
|
||||||
|
|
||||||
|
;; ── Text and Span Tests ───────────────────────────────────────
|
||||||
|
|
||||||
|
(test text-creates-with-defaults
|
||||||
|
"A text created with no arguments has reasonable defaults"
|
||||||
|
(let ((txt (make-text "")))
|
||||||
|
(is (typep txt 'text))
|
||||||
|
(is (typep (text-layout-node txt) 'layout-node))))
|
||||||
|
|
||||||
|
(test text-renders-content
|
||||||
|
"A text renders its content at position"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((tx (make-text "Hello" :width 10 :height 1)))
|
||||||
|
(compute-layout (text-layout-node tx) 10 1)
|
||||||
|
(render-text tx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "Hello" out) "content should appear")))))
|
||||||
|
|
||||||
|
(test text-empty-string
|
||||||
|
"Empty text produces no output"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((tx (make-text "" :width 10 :height 1)))
|
||||||
|
(compute-layout (text-layout-node tx) 10 1)
|
||||||
|
(render-text tx b)
|
||||||
|
(is (string= (get-output-stream-string s) "")
|
||||||
|
"empty string produces no output"))))
|
||||||
|
|
||||||
|
(test text-truncates-when-no-wrap
|
||||||
|
"Text with wrap-mode :none truncates at width"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((tx (make-text "Hello World" :width 5 :height 1
|
||||||
|
:wrap-mode :none)))
|
||||||
|
(compute-layout (text-layout-node tx) 5 1)
|
||||||
|
(render-text tx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "Hello" out) "truncated to first 5 chars")))))
|
||||||
|
|
||||||
|
(test text-word-wraps
|
||||||
|
"Text with wrap-mode :word wraps at word boundaries"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((tx (make-text "Hello brave new world" :width 6 :height 3)))
|
||||||
|
(compute-layout (text-layout-node tx) 6 3)
|
||||||
|
(render-text tx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "Hello" out) "first line")
|
||||||
|
(is (search "brave" out) "second line")
|
||||||
|
(is (search "new" out) "third line")))))
|
||||||
|
|
||||||
|
(test text-word-wrap-single-word
|
||||||
|
"A word longer than width is hard-broken at max-width"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(let ((tx (make-text "Hello" :width 3 :height 3)))
|
||||||
|
(compute-layout (text-layout-node tx) 3 3)
|
||||||
|
(render-text tx b)
|
||||||
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "Hel" out) "first chunk is Hel")
|
||||||
|
(is (search "lo" out) "second chunk is lo")))))
|
||||||
|
|
||||||
|
(test span-creates-with-attributes
|
||||||
|
"A span has text and optional style attributes"
|
||||||
|
(let ((s (span "bold text" :bold t)))
|
||||||
|
(is (string= (span-text s) "bold text"))
|
||||||
|
(is-true (span-bold s))
|
||||||
|
(is-false (span-italic s))))
|
||||||
|
|
||||||
|
(test make-text-with-spans
|
||||||
|
"Text with spans stores span objects"
|
||||||
|
(let* ((sp (list (span "Hello" :bold t)
|
||||||
|
(span "World" :italic t)))
|
||||||
|
(tx (make-text "" :spans sp)))
|
||||||
|
(is (= (length (text-spans tx)) 2))
|
||||||
|
(is (string= (span-text (elt (text-spans tx) 0)) "Hello"))
|
||||||
|
(is-true (span-bold (elt (text-spans tx) 0)))))
|
||||||
54
src/components/box.lisp
Normal file
54
src/components/box.lisp
Normal file
@@ -0,0 +1,54 @@
|
|||||||
|
(in-package :cl-tui.box)
|
||||||
|
|
||||||
|
(defclass box ()
|
||||||
|
((layout-node :initform (make-layout-node) :accessor box-layout-node
|
||||||
|
:initarg :layout-node)
|
||||||
|
(border-style :initform :single :initarg :border-style
|
||||||
|
:accessor box-border-style)
|
||||||
|
(title :initform nil :initarg :title :accessor box-title)
|
||||||
|
(title-align :initform :left :initarg :title-align
|
||||||
|
:accessor box-title-align)
|
||||||
|
(fg :initform nil :initarg :fg :accessor box-fg)
|
||||||
|
(bg :initform nil :initarg :bg :accessor box-bg)))
|
||||||
|
|
||||||
|
(defun make-box (&key (border-style :single) title
|
||||||
|
(title-align :left) fg bg
|
||||||
|
width height)
|
||||||
|
(make-instance 'box
|
||||||
|
:border-style border-style
|
||||||
|
:title title
|
||||||
|
:title-align title-align
|
||||||
|
:fg fg
|
||||||
|
:bg bg
|
||||||
|
:layout-node (make-layout-node
|
||||||
|
:width width
|
||||||
|
:height height
|
||||||
|
:direction :column)))
|
||||||
|
|
||||||
|
(defun render-box (box backend)
|
||||||
|
"Render BOX at its computed layout position using BACKEND."
|
||||||
|
(let ((ln (box-layout-node box))
|
||||||
|
(bs (box-border-style box))
|
||||||
|
(title (box-title box))
|
||||||
|
(fg (box-fg box))
|
||||||
|
(bg (box-bg box)))
|
||||||
|
(let ((x (layout-node-x ln))
|
||||||
|
(y (layout-node-y ln))
|
||||||
|
(w (layout-node-width ln))
|
||||||
|
(h (layout-node-height ln)))
|
||||||
|
(when (or (zerop w) (zerop h) (< w 2) (< h 2))
|
||||||
|
(return-from render-box (values)))
|
||||||
|
(when bg
|
||||||
|
(draw-rect backend x y w h :bg bg))
|
||||||
|
(when bs
|
||||||
|
(draw-border backend x y w h :style bs :fg fg :bg bg))
|
||||||
|
(when title
|
||||||
|
(let* ((content-w (- w 4))
|
||||||
|
(tx (+ x 2))
|
||||||
|
(ty (+ y (if bs 1 0)))
|
||||||
|
(ta (box-title-align box))
|
||||||
|
(display (subseq title 0 (min (length title) content-w))))
|
||||||
|
(case ta
|
||||||
|
(:center (draw-text backend (+ x (ceiling (- w (length display)) 2)) ty display fg bg))
|
||||||
|
(:right (draw-text backend (+ x (- w (length display) 2)) ty display fg bg))
|
||||||
|
(t (draw-text backend tx ty display fg bg))))))))
|
||||||
20
src/components/dirty-tests.lisp
Normal file
20
src/components/dirty-tests.lisp
Normal file
@@ -0,0 +1,20 @@
|
|||||||
|
;; Dirty tracking tests are in box-tests.lisp (same test suite)
|
||||||
|
(in-package :cl-tui-box-test)
|
||||||
|
|
||||||
|
(test dirty-mixin-default-is-dirty
|
||||||
|
"A dirty-mixin starts as dirty"
|
||||||
|
(let ((c (make-instance 'dirty-mixin)))
|
||||||
|
(is-true (dirty-p c) "new component should be dirty")))
|
||||||
|
|
||||||
|
(test mark-clean-clears-dirty
|
||||||
|
"mark-clean sets dirty to nil"
|
||||||
|
(let ((c (make-instance 'dirty-mixin)))
|
||||||
|
(mark-clean c)
|
||||||
|
(is-false (dirty-p c) "after mark-clean, should not be dirty")))
|
||||||
|
|
||||||
|
(test mark-dirty-sets-dirty
|
||||||
|
"mark-dirty sets dirty to t"
|
||||||
|
(let ((c (make-instance 'dirty-mixin)))
|
||||||
|
(mark-clean c)
|
||||||
|
(mark-dirty c)
|
||||||
|
(is-true (dirty-p c) "after mark-dirty, should be dirty again")))
|
||||||
14
src/components/dirty.lisp
Normal file
14
src/components/dirty.lisp
Normal file
@@ -0,0 +1,14 @@
|
|||||||
|
(in-package :cl-tui.box)
|
||||||
|
|
||||||
|
;; ── Dirty Tracking ─────────────────────────────────────────────
|
||||||
|
|
||||||
|
(defclass dirty-mixin ()
|
||||||
|
((dirty :initform t :accessor dirty-p)))
|
||||||
|
|
||||||
|
(defgeneric mark-clean (component)
|
||||||
|
(:method ((c dirty-mixin))
|
||||||
|
(setf (dirty-p c) nil)))
|
||||||
|
|
||||||
|
(defgeneric mark-dirty (component)
|
||||||
|
(:method ((c dirty-mixin))
|
||||||
|
(setf (dirty-p c) t)))
|
||||||
23
src/components/package.lisp
Normal file
23
src/components/package.lisp
Normal file
@@ -0,0 +1,23 @@
|
|||||||
|
(defpackage :cl-tui.box
|
||||||
|
(:use :cl :cl-tui.backend :cl-tui.layout)
|
||||||
|
(:export
|
||||||
|
;; Box
|
||||||
|
#:box #:make-box
|
||||||
|
#:box-layout-node
|
||||||
|
#:box-border-style #:box-title #:box-title-align
|
||||||
|
#:box-fg #:box-bg
|
||||||
|
#:render-box
|
||||||
|
;; Span
|
||||||
|
#:span
|
||||||
|
#:span-text #:span-bold #:span-italic #:span-underline
|
||||||
|
#:span-reverse #:span-dim #:span-fg #:span-bg
|
||||||
|
;; Text
|
||||||
|
#:text #:make-text
|
||||||
|
#:text-layout-node #:text-content #:text-spans
|
||||||
|
#:text-fg #:text-bg #:text-wrap-mode
|
||||||
|
#:render-text
|
||||||
|
;; Utilities (for tests)
|
||||||
|
#:word-wrap #:split-string
|
||||||
|
;; Dirty tracking
|
||||||
|
#:dirty-mixin #:dirty-p #:mark-clean #:mark-dirty))
|
||||||
|
(in-package :cl-tui.box)
|
||||||
106
src/components/text.lisp
Normal file
106
src/components/text.lisp
Normal file
@@ -0,0 +1,106 @@
|
|||||||
|
(in-package :cl-tui.box)
|
||||||
|
|
||||||
|
;; ── Text Renderable ────────────────────────────────────────────
|
||||||
|
|
||||||
|
(defclass span ()
|
||||||
|
((text :initarg :text :accessor span-text)
|
||||||
|
(bold :initform nil :initarg :bold :accessor span-bold)
|
||||||
|
(italic :initform nil :initarg :italic :accessor span-italic)
|
||||||
|
(underline :initform nil :initarg :underline :accessor span-underline)
|
||||||
|
(reverse :initform nil :initarg :reverse :accessor span-reverse)
|
||||||
|
(dim :initform nil :initarg :dim :accessor span-dim)
|
||||||
|
(fg :initform nil :initarg :fg :accessor span-fg)
|
||||||
|
(bg :initform nil :initarg :bg :accessor span-bg)))
|
||||||
|
|
||||||
|
(defun span (text &key bold italic underline reverse dim fg bg)
|
||||||
|
(make-instance 'span
|
||||||
|
:text text :bold bold :italic italic
|
||||||
|
:underline underline :reverse reverse :dim dim
|
||||||
|
:fg fg :bg bg))
|
||||||
|
|
||||||
|
(defclass text ()
|
||||||
|
((layout-node :initform (make-layout-node) :accessor text-layout-node
|
||||||
|
:initarg :layout-node)
|
||||||
|
(content :initform "" :initarg :content :accessor text-content)
|
||||||
|
(spans :initform nil :initarg :spans :accessor text-spans)
|
||||||
|
(fg :initform nil :initarg :fg :accessor text-fg)
|
||||||
|
(bg :initform nil :initarg :bg :accessor text-bg)
|
||||||
|
(wrap-mode :initform :word :initarg :wrap-mode :accessor text-wrap-mode)))
|
||||||
|
|
||||||
|
(defun make-text (content &key fg bg wrap-mode width height spans)
|
||||||
|
(make-instance 'text
|
||||||
|
:content content
|
||||||
|
:fg fg :bg bg
|
||||||
|
:wrap-mode (or wrap-mode :word)
|
||||||
|
:spans spans
|
||||||
|
:layout-node (make-layout-node :direction :column
|
||||||
|
:width width :height height)))
|
||||||
|
|
||||||
|
(defun render-text (text-object backend)
|
||||||
|
"Render TEXT-OBJECT at its computed layout position using BACKEND."
|
||||||
|
(let ((ln (text-layout-node text-object))
|
||||||
|
(content (text-content text-object))
|
||||||
|
(fg (text-fg text-object))
|
||||||
|
(bg (text-bg text-object))
|
||||||
|
(wrap (text-wrap-mode text-object))
|
||||||
|
(spans (text-spans text-object)))
|
||||||
|
(declare (ignore spans))
|
||||||
|
(let ((x (layout-node-x ln))
|
||||||
|
(y (layout-node-y ln))
|
||||||
|
(w (layout-node-width ln))
|
||||||
|
(h (layout-node-height ln)))
|
||||||
|
(when (or (zerop (length content)) (zerop w) (zerop h))
|
||||||
|
(return-from render-text (values)))
|
||||||
|
(if (eql wrap :none)
|
||||||
|
(let ((display (subseq content 0 (min (length content) w))))
|
||||||
|
(draw-text backend x y display fg bg))
|
||||||
|
(let ((lines (word-wrap content w))
|
||||||
|
(max-lines h))
|
||||||
|
(loop for line in lines
|
||||||
|
for row from 0 below max-lines
|
||||||
|
do (draw-text backend x (+ y row) line fg bg)))))))
|
||||||
|
|
||||||
|
(defun word-wrap (text max-width)
|
||||||
|
"Split TEXT into lines, each <= MAX-WIDTH chars.
|
||||||
|
Breaks at word boundaries. Words exceeding MAX-WIDTH are hard-broken."
|
||||||
|
(if (or (zerop max-width) (zerop (length text)))
|
||||||
|
(list "")
|
||||||
|
(let ((words (split-string text)) (lines nil) (current nil) (current-len 0))
|
||||||
|
(dolist (word words)
|
||||||
|
(let ((wl (length word)))
|
||||||
|
(cond ((<= wl max-width)
|
||||||
|
(if (and current (<= (+ current-len 1 wl) max-width))
|
||||||
|
(push word current)
|
||||||
|
(progn
|
||||||
|
(when current
|
||||||
|
(push (format nil "~{~A~^ ~}" (nreverse current)) lines))
|
||||||
|
(setf current (list word))
|
||||||
|
(setf current-len wl))))
|
||||||
|
(t
|
||||||
|
(when current
|
||||||
|
(push (format nil "~{~A~^ ~}" (nreverse current)) lines)
|
||||||
|
(setf current nil)
|
||||||
|
(setf current-len 0))
|
||||||
|
(loop for i from 0 below wl by max-width
|
||||||
|
do (push (subseq word i (min (+ i max-width) wl)) lines))))))
|
||||||
|
(when current
|
||||||
|
(push (format nil "~{~A~^ ~}" (nreverse current)) lines))
|
||||||
|
(or (nreverse lines) (list "")))))
|
||||||
|
|
||||||
|
(defun split-string (string)
|
||||||
|
"Split STRING into words separated by whitespace."
|
||||||
|
(loop with words = nil
|
||||||
|
with start = 0
|
||||||
|
with len = (length string)
|
||||||
|
while (< start len)
|
||||||
|
do (let ((ws-start (position-if (lambda (c) (find c '(#\Space #\Tab #\Newline)))
|
||||||
|
string :start start)))
|
||||||
|
(if ws-start
|
||||||
|
(progn
|
||||||
|
(when (> ws-start start)
|
||||||
|
(push (subseq string start ws-start) words))
|
||||||
|
(setf start (1+ ws-start)))
|
||||||
|
(progn
|
||||||
|
(push (subseq string start) words)
|
||||||
|
(setf start len))))
|
||||||
|
finally (return (nreverse words))))
|
||||||
Reference in New Issue
Block a user