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

fix: dialog draw-border arg, markdown/slot nil guards, +integration test suite

Browse Source
This commit is contained in:
Hermes Agent
2026-05-12 14:30:31 +00:00
parent 6e73c3bb19
commit 00db3c61a5
7 changed files with 423 additions and 44 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
run-all-tests.lisp
View File

@@ -17,7 +17,8 @@
"tests/dialog-tests.lisp"
"tests/mouse-tests.lisp"
"tests/slot-tests.lisp"
"tests/framebuffer-tests.lisp"))
"tests/framebuffer-tests.lisp"
"tests/integration-tests.lisp"))
(load f))
;; Run all test suites, exit non-zero if any fails
@@ -33,7 +34,8 @@
(:cl-tty-slot-test "SLOT-SUITE")
(:cl-tty-layout-test "LAYOUT-SUITE")
(:cl-tty-modern-backend-test "MODERN-BACKEND-SUITE")
(:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE")))
(:cl-tty-framebuffer-test "FRAMEBUFFER-SUITE")
(:cl-tty-integration-test "INTEGRATION-SUITE")))
(let* ((pkg (find-package (first suite)))
(suite-name (second suite))
(s (etypecase suite-name

2
src/components/dialog.lisp
View File

@@ -35,7 +35,7 @@
(dotimes (row h)
(draw-rect screen 0 row w 1 :bg :bright-black))
;; Dialog panel
(draw-border screen x y dw dh :single :title (dialog-title dialog))
(draw-border screen x y dw dh :style :single :title (dialog-title dialog))
(when (dialog-content dialog)
;; Content rendering delegated to component system
(draw-text screen (1+ x) (1+ y)

4
src/components/markdown.lisp
View File

@@ -31,6 +31,7 @@
;; ─── Block-level parser ───────────────────────────────────────────────────────
(defun split-string-into-lines (string)
(unless string (return-from split-string-into-lines (coerce nil 'vector)))
(let ((result nil) (start 0))
(flet ((add-line (end) (push (subseq string start end) result)))
(loop for i from 0 below (length string)
@@ -212,6 +213,7 @@
i))))
(defun parse-blocks (text)
(unless text (return-from parse-blocks nil))
(let ((lines (split-string-into-lines text)) (nodes nil) (i 0))
(loop while (< i (length lines))
do (let* ((line (string-trim (list #\return) (aref lines i)))
@@ -502,6 +504,7 @@
(nreverse tokens)))
(defun highlight-code (code language)
(unless code (return-from highlight-code nil))
(let ((highlighter (get-highlighter (and language (string-downcase language)))))
(unless highlighter (return-from highlight-code (list (cons code :plain))))
(let ((tokens nil))
@@ -672,6 +675,7 @@
lines))
(defun render-markdown (text)
(unless text (return-from render-markdown ""))
(let ((nodes (parse-blocks text)) (parts nil))
(dolist (line (render-md nodes)) (push line parts))
(with-output-to-string (s)

5
src/components/slot.lisp
View File

@@ -15,7 +15,10 @@
(defun slot-render (slot-name &rest args)
(let ((entries (gethash (string slot-name) *slots*)))
(when entries
(mapcar (lambda (entry) (apply (cdr entry) args)) entries))))
(mapcar (lambda (entry)
(let ((fn (cdr entry)))
(when fn (apply fn args))))
entries))))
(defun slot-p (slot-name)
(nth-value 1 (gethash (string slot-name) *slots*)))

263
tests/integration-tests.lisp Normal file
View File

@@ -0,0 +1,263 @@
;;; integration-tests.lisp — Full pipeline integration tests for cl-tty
;;;
;;; Composes all major components through the rendering pipeline onto a
;;; framebuffer backend and verifies cell-level output.
(defpackage :cl-tty-integration-test
(:use :cl :fiveam
:cl-tty.backend :cl-tty.box :cl-tty.layout
:cl-tty.input :cl-tty.select :cl-tty.container
:cl-tty.rendering :cl-tty.dialog))
(in-package :cl-tty-integration-test)
(def-suite integration-suite
:description "Full pipeline integration tests for cl-tty")
(in-suite integration-suite)
;; ─── Helper: extract cell text from a region ──────────────────────
(defun fb-string (fb x y &optional (len 1))
"Read a string of LEN characters from framebuffer FB starting at (X,Y)."
(let* ((cells (fb-framebuffer fb))
(w (framebuffer-width cells))
(h (framebuffer-height cells)))
(with-output-to-string (s)
(loop for i from 0 below len
for cx = (+ x i)
while (< cx w)
do (princ (cell-char (aref cells y cx)) s)))))
(defun fb-lines (fb &key (start-row 0) (end-row nil))
"Extract all lines from framebuffer FB as a list of strings."
(let* ((cells (fb-framebuffer fb))
(w (framebuffer-width cells))
(h (framebuffer-height cells))
(max-row (min (or end-row h) h)))
(loop for y from start-row below max-row
collect (fb-string fb 0 y w))))
(defun fb-contains (fb text)
"Return T if framebuffer FB contains TEXT anywhere."
(let ((all-text (format nil "~{~a~^~%~}" (fb-lines fb))))
(search text all-text :test #'char-equal)))
;; ─── Test: Box with title renders correctly ───────────────────────
(test box-title-renders-on-fb
"A Box with a title draws border and title text on framebuffer."
(let* ((fb (make-framebuffer-backend :width 40 :height 10))
(bx (make-box :border-style :single :title "My Box" :width 40 :height 10)))
(compute-layout (box-layout-node bx) 40 10)
(render-box bx fb)
;; Framebuffer uses ASCII border chars (+, -, |)
(is-true (fb-contains fb "My Box") "title text appears")
(is-true (fb-contains fb "+") "top-left corner appears")
(is-true (fb-contains fb "-") "horizontal border appears")
;; Check the title at row 0, col 2
(is (equal "My Box" (fb-string fb 2 0 6)) "title at correct position")))
;; ─── Test: Text component with word-wrap ──────────────────────────
(test text-component-on-fb
"Text component renders word-wrapped content on framebuffer."
(let* ((fb (make-framebuffer-backend :width 20 :height 6))
(tx (make-text "Hello brave new world of terminal UI"
:wrap-mode :word :width 20 :height 4)))
(compute-layout (text-layout-node tx) 20 4)
(render-text tx fb)
(is-true (fb-contains fb "Hello") "first word appears")
(is-true (fb-contains fb "brave") "second word appears")
(is-true (fb-contains fb "world") "third word wraps")))
;; ─── Test: TextInput with value ───────────────────────────────────
(test textinput-value-on-fb
"TextInput renders its value and cursor on framebuffer."
(let* ((fb (make-framebuffer-backend :width 40 :height 3))
(ti (make-text-input :value "hello world" :cursor 5)))
(setf (text-input-layout-node ti)
(make-layout-node :width 40 :height 1))
(compute-layout (text-input-layout-node ti) 40 1)
(render ti fb)
;; Verify value via direct cell inspection
(is (equal "hello world" (fb-string fb 0 0 11)) "value appears at row 0")
;; Check cursor block at position 5
(let* ((cells (fb-framebuffer fb))
(cursor-char (cell-char (aref cells 0 5))))
(is (eql #\█ cursor-char) "cursor block is drawn at position 5"))))
;; ─── Test: TextInput empty shows placeholder ──────────────────────
(test textinput-placeholder-on-fb
"TextInput with empty value shows placeholder text."
(let* ((fb (make-framebuffer-backend :width 40 :height 3))
(ti (make-text-input :value "" :placeholder "Type here...")))
(setf (text-input-layout-node ti)
(make-layout-node :width 40 :height 1))
(compute-layout (text-input-layout-node ti) 40 1)
(render ti fb)
(is (equal "Type here..." (fb-string fb 0 0 12)) "placeholder appears at row 0")))
;; ─── Test: ScrollBox with children ────────────────────────────────
(test scrollbox-children-on-fb
"ScrollBox renders visible children offset by scroll position."
(let* ((fb (make-framebuffer-backend :width 40 :height 10))
(children nil))
;; Create 8 text children, each 1 line tall
(dotimes (i 8)
(let ((tx (make-text (format nil "Line ~D" (1+ i))
:wrap-mode :none :width 40 :height 1)))
(push tx children)))
(setf children (nreverse children))
(let ((sb (make-scroll-box :children children :scroll-y 2)))
;; Set scroll-box layout to 40x8 viewport using component-layout-node
(let ((ln (component-layout-node sb)))
(setf (layout-node-width ln) 40)
(setf (layout-node-height ln) 8))
;; Layout each child too
(dolist (c children)
(compute-layout (component-layout-node c) 40 1))
(render sb fb)
;; Because scroll-y=2, Line 1 and Line 2 are scrolled out
;; Line 3 should be first visible
(is-true (fb-contains fb "Line 3") "scroll-y=2 shows Line 3 first")
(is-true (fb-contains fb "Line 4") "Line 4 is visible")
(is-true (fb-contains fb "Line 5") "Line 5 is visible")
;; Line 1 and 2 should NOT be visible (scrolled out)
(is-false (fb-contains fb "Line 1") "Line 1 scrolled out")
(is-false (fb-contains fb "Line 2") "Line 2 scrolled out"))))
;; ─── Test: Select renders options ─────────────────────────────────
(test select-options-on-fb
"Select renders option titles on framebuffer."
(let* ((fb (make-framebuffer-backend :width 40 :height 10))
(sel (make-select
:options '((:title "Red" :value :red)
(:title "Green" :value :green)
(:title "Blue" :value :blue)))))
(let ((ln (select-layout-node sel)))
(setf (layout-node-width ln) 40)
(setf (layout-node-height ln) 5))
(render sel fb)
(is-true (fb-contains fb "Red") "first option appears")
(is-true (fb-contains fb "Green") "second option appears")
(is-true (fb-contains fb "Blue") "third option appears")))
;; ─── Test: Dialog renders with backdrop ───────────────────────────
(test dialog-appears-on-fb
"Dialog renders a dimmed backdrop and dialog panel with title."
(let* ((fb (make-framebuffer-backend :width 80 :height 24))
(d (make-instance 'dialog :title "Confirm" :size :small)))
(push-dialog d)
(render-dialog d fb 80 24)
;; Dialog title appears somewhere in the output
(is-true (fb-contains fb "Confirm") "dialog title appears")
;; Dialog border (ASCII)
(is-true (fb-contains fb "+") "dialog border appears")
(is-true (fb-contains fb "|") "dialog vertical border appears")
;; Clean up
(pop-dialog)))
;; ─── Test: Dialog push/pop with render ────────────────────────────
(test dialog-push-pop-render
"Dialog push/pop cycle works with rendering."
(let* ((fb (make-framebuffer-backend :width 80 :height 24))
(d1 (make-instance 'dialog :title "Dialog One"))
(d2 (make-instance 'dialog :title "Dialog Two")))
(push-dialog d1)
(push-dialog d2)
(render-dialog (first *dialog-stack*) fb 80 24)
(is-true (fb-contains fb "Dialog Two") "top dialog renders")
(pop-dialog)
(backend-clear fb)
(render-dialog (first *dialog-stack*) fb 80 24)
(is-true (fb-contains fb "Dialog One") "second dialog renders after pop")
(pop-dialog)))
;; ─── Test: Toast renders ──────────────────────────────────────────
(test toast-appears-on-fb
"Toast notification renders with colored background."
(let* ((fb (make-framebuffer-backend :width 80 :height 24)))
(toast "Hello from toast!" :variant :info :duration 0)
(render-toast (first *toasts*) fb 80)
(is-true (fb-contains fb "Hello from toast!") "toast message appears")
(dismiss-toast (first *toasts*))))
;; ─── Test: render-screen pipeline ─────────────────────────────────
(test render-screen-pipeline
"render-screen processes a component tree through the full pipeline."
(let* ((fb (make-framebuffer-backend :width 40 :height 12))
(root (make-box :border-style :single :title "Root"
:width 40 :height 12)))
(render-screen root fb)
(is-true (fb-contains fb "Root") "title renders via render-screen")
;; Border characters (ASCII on framebuffer)
(is-true (fb-contains fb "+") "border renders")))
;; ─── Test: Full composition via framebuffer ───────────────────────
(test full-composition-via-fb
"All components compose correctly on a single framebuffer."
(let* ((fb (make-framebuffer-backend :width 60 :height 24)))
;;
;; 1. Box with title at top
;;
(let ((bx (make-box :border-style :single :title "Dashboard"
:width 60 :height 24)))
(compute-layout (box-layout-node bx) 60 24)
(render-box bx fb))
;;
;; 2. Text content inside
;;
(let ((tx (make-text "Welcome to the dashboard."
:wrap-mode :word :width 56 :height 3)))
(setf (layout-node-x (text-layout-node tx)) 2)
(setf (layout-node-y (text-layout-node tx)) 2)
(compute-layout (text-layout-node tx) 56 3)
(render-text tx fb))
;;
;; 3. TextInput
;;
(let ((ti (make-text-input :value "search query" :cursor 6)))
(setf (text-input-layout-node ti) (make-layout-node))
(setf (layout-node-x (text-input-layout-node ti)) 2)
(setf (layout-node-y (text-input-layout-node ti)) 6)
(setf (layout-node-width (text-input-layout-node ti)) 56)
(setf (layout-node-height (text-input-layout-node ti)) 1)
(render ti fb))
;;
;; 4. Select options
;;
(let ((sel (make-select
:options '((:title "Option A" :value :a)
(:title "Option B" :value :b)
(:title "Option C" :value :c)))))
(setf (select-layout-node sel) (make-layout-node))
(setf (layout-node-x (select-layout-node sel)) 2)
(setf (layout-node-y (select-layout-node sel)) 8)
(setf (layout-node-width (select-layout-node sel)) 56)
(setf (layout-node-height (select-layout-node sel)) 3)
(render sel fb))
;;
;; Verifications
;;
(is-true (fb-contains fb "Dashboard") "box title appears")
(is-true (fb-contains fb "Welcome") "text content appears")
;; Check TextInput value at its position
(is (equal "search query" (fb-string fb 2 6 12)) "TextInput value at row 6")
;; Check Select options at their positions
(is-true (fb-contains fb "Option A") "Select option A appears")
(is-true (fb-contains fb "Option B") "Select option B appears")
(is-true (fb-contains fb "Option C") "Select option C appears")))

83
tests/markdown-tests.lisp
View File

@@ -11,6 +11,83 @@
(in-suite :cl-tty-markdown-test)
;; ─── Parser edge cases ─────────────────────────────────────────
(def-test render-markdown-nil ( )
"render-markdown handles nil gracefully."
(is (string= "" (render-markdown nil))))
(def-test render-markdown-empty ( )
"render-markdown handles empty string."
(let ((result (render-markdown "")))
(is (stringp result))
(is (string= "" result))))
(def-test parse-blocks-nil ( )
"parse-blocks handles nil gracefully."
(is-false (parse-blocks nil)))
(def-test split-string-into-lines-nil ( )
"parse-blocks handles nil input (tests internal split-string-into-lines)."
(is-false (parse-blocks nil)))
(def-test nested-bold-inside-italic ( )
"Nested formatting: bold inside italic."
(let ((children (parse-inline "***hello*** world")))
(is (= 3 (length children)))
(let ((first-node (first children)))
(is-true (eql :bold (getf first-node :type))))))
(def-test nested-italic-inside-bold ( )
"Nested formatting: italic inside bold."
(let ((children (parse-inline "**bold *italic* bold**")))
(is (= 1 (length children)))
(let ((bold (first children)))
(is-true (eql :bold (getf bold :type)))
(let ((inner (getf bold :children)))
(is (= 3 (length inner)))
(is-true (eql :italic (getf (second inner) :type)))))))
(def-test inline-code-inside-bold ( )
"Code inside bold."
(let ((children (parse-inline "**bold `code` bold**")))
(is (= 1 (length children)))
(let ((bold (first children)))
(is-true (eql :bold (getf bold :type)))
(let ((inner (getf bold :children)))
(is (= 3 (length inner)))
(is-true (eql :inline-code (getf (second inner) :type)))))))
(def-test unclosed-code-block ( )
"Unclosed code block accumulates remaining lines as content."
(let* ((lines '("```lisp" "(defun foo ())" " (bar)"))
(text (format nil "~{~a~%~}" lines))
(result (parse-blocks text))
(node (first result)))
(is-true (eql :code-block (getf node :type)))
(is (equal "lisp" (getf (getf node :properties) :language)))
(is-true (search "bar" (getf node :content)))))
(def-test code-block-no-language ( )
"Code block with no language is still parsed."
(let* ((lines '("```" "plain" "```"))
(text (format nil "~{~a~%~}" lines))
(result (parse-blocks text))
(node (first result)))
(is-true (eql :code-block (getf node :type)))
(is-false (getf (getf node :properties) :language))))
(def-test markdown-very-long-line ( )
"A very long paragraph line does not cause issues."
(let* ((long-line (make-string 500 :initial-element #\x))
(result (render-markdown long-line)))
(is (stringp result))
(is-true (> (length result) 0))))
(def-test markdown-only-blank ( )
"Only blank lines produce empty output."
(is (string= "" (render-markdown (format nil "~%~%")))))
;; ─── Parser tests ─────────────────────────────────────────────────────────────
(def-test heading-parsing ( )
@@ -80,14 +157,16 @@
(is (equal "here" (getf (first link-text) :content))))))
(def-test code-block-parsing ( )
(let* ((text (format nil "```lisp~%(defun hello ())~% (print \"hi\")~%```"))
(let* ((lines '("```lisp" "(defun hello ())" " (print \"hi\")" "```"))
(text (format nil "~{~a~%~}" lines))
(result (parse-blocks text)) (node (first result)))
(is-true (eql :code-block (getf node :type)))
(is (equal "lisp" (getf (getf node :properties) :language)))
(is-true (search "(defun hello" (getf node :content)))))
(def-test code-block-unknown-language ( )
(let* ((text (format nil "```~%plain code~%```"))
(let* ((lines '("```" "plain code" "```"))
(text (format nil "~{~a~%~}" lines))
(result (parse-blocks text)) (node (first result)))
(is-true (eql :code-block (getf node :type)))
(is-false (getf (getf node :properties) :language))))

28
tests/slot-tests.lisp
View File

@@ -24,3 +24,31 @@
(defslot :test-slot :order 1 :render-fn (lambda () "x"))
(clear-slot :test-slot)
(is-false (slot-p :test-slot)))
(def-test defslot-nil-render-fn ( )
"defslot with nil (default) render-fn should not crash slot-render."
(clear-slot :nil-slot)
(defslot :nil-slot :order 1)
(is-true (slot-p :nil-slot))
(is (equal '(nil) (slot-render :nil-slot)))
(clear-slot :nil-slot))
(def-test defslot-duplicate-same-order ( )
"Multiple defslot calls with the same order should all register."
(clear-slot :dup-slot)
(defslot :dup-slot :order 5 :render-fn (lambda () "first"))
(defslot :dup-slot :order 5 :render-fn (lambda () "second"))
(let ((result (slot-render :dup-slot)))
(is (= 2 (length result)))
;; Entries with same order are prepended, so "second" comes first
(is (equal "second" (first result)))
(is (equal "first" (second result))))
(clear-slot :dup-slot))
(def-test slot-render-with-args ( )
"slot-render passes arguments to all registered render-fns."
(clear-slot :args-slot)
(defslot :args-slot :order 1 :render-fn (lambda (x y) (format nil "~a+~a" x y)))
(let ((result (slot-render :args-slot 3 4)))
(is (equal '("3+4") result)))
(clear-slot :args-slot))