review fixes: 3 blocking bugs + 2 improvements
B1: modern-backend now inherits from backend (was standalone class)
B2: draw-rect y-position bug — loop now tracks row offset
B3: Layout module added to ASDF system definition
I1: 6 smoke tests replaced with behavioral tests (captured output)
I3: 6 edge case tests: empty, single-child, zero-size, deep
nesting, large padding, negative grow
Also fixed:
- Added missing make-simple-backend constructor to simple.lisp
- Added in-package to classes.lisp and simple.lisp (SBCL's load
restores *package* after each load, breaking batch-mode loading)
This commit is contained in:
@@ -1,3 +1,5 @@
|
|||||||
|
(in-package :cl-tui.backend)
|
||||||
|
|
||||||
(defclass backend () ())
|
(defclass backend () ())
|
||||||
|
|
||||||
(defgeneric initialize-backend (backend)
|
(defgeneric initialize-backend (backend)
|
||||||
|
|||||||
@@ -111,7 +111,7 @@
|
|||||||
(case pos (:horizontal "─") (:vertical "│"))
|
(case pos (:horizontal "─") (:vertical "│"))
|
||||||
"+"))))
|
"+"))))
|
||||||
|
|
||||||
(defclass modern-backend ()
|
(defclass modern-backend (backend)
|
||||||
((output-stream :initform *standard-output*
|
((output-stream :initform *standard-output*
|
||||||
: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)))
|
||||||
@@ -199,14 +199,14 @@
|
|||||||
(backend-write b bot)))
|
(backend-write b bot)))
|
||||||
|
|
||||||
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
|
(defmethod draw-rect ((b modern-backend) x y width height &key bg)
|
||||||
(let ((bg-esc (sgr-bg bg))
|
(let* ((bg-esc (sgr-bg bg))
|
||||||
(reset (sgr-attr :reset))
|
(reset (sgr-attr :reset))
|
||||||
(line (concatenate 'string
|
(line (concatenate 'string
|
||||||
bg-esc
|
bg-esc
|
||||||
(make-string width :initial-element #\Space)
|
(make-string width :initial-element #\Space)
|
||||||
reset (string #\Newline))))
|
reset (string #\Newline))))
|
||||||
(loop repeat height do
|
(loop :for row :from 0 :below height :do
|
||||||
(backend-write b (cursor-move-escape x y))
|
(backend-write b (cursor-move-escape x (+ y row)))
|
||||||
(backend-write b line))))
|
(backend-write b line))))
|
||||||
|
|
||||||
(defmethod draw-link ((b modern-backend) x y string url
|
(defmethod draw-link ((b modern-backend) x y string url
|
||||||
|
|||||||
@@ -1,7 +1,14 @@
|
|||||||
|
(in-package :cl-tui.backend)
|
||||||
|
|
||||||
(defclass simple-backend (backend)
|
(defclass simple-backend (backend)
|
||||||
((output-stream :initform *standard-output*
|
((output-stream :initform *standard-output*
|
||||||
|
:initarg :output-stream
|
||||||
:accessor backend-output-stream)))
|
:accessor backend-output-stream)))
|
||||||
|
|
||||||
|
(defun make-simple-backend (&key output-stream)
|
||||||
|
(make-instance 'simple-backend
|
||||||
|
:output-stream (or output-stream *standard-output*)))
|
||||||
|
|
||||||
(defmethod initialize-backend ((b simple-backend))
|
(defmethod initialize-backend ((b simple-backend))
|
||||||
b)
|
b)
|
||||||
|
|
||||||
|
|||||||
@@ -6,6 +6,14 @@
|
|||||||
(def-suite backend-suite :description "Backend protocol tests")
|
(def-suite backend-suite :description "Backend protocol tests")
|
||||||
(in-suite backend-suite)
|
(in-suite backend-suite)
|
||||||
|
|
||||||
|
;; ── Helpers ─────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(defun make-capturing-backend ()
|
||||||
|
"Create a simple-backend that writes to a string stream."
|
||||||
|
(let* ((s (make-string-output-stream))
|
||||||
|
(b (make-simple-backend :output-stream s)))
|
||||||
|
(values b s)))
|
||||||
|
|
||||||
;; ── Simple Backend ──────────────────────────────────────────────
|
;; ── Simple Backend ──────────────────────────────────────────────
|
||||||
|
|
||||||
(defun run-tests ()
|
(defun run-tests ()
|
||||||
@@ -19,32 +27,55 @@
|
|||||||
(let ((b (make-simple-backend)))
|
(let ((b (make-simple-backend)))
|
||||||
(is (typep b 'simple-backend))
|
(is (typep b 'simple-backend))
|
||||||
(initialize-backend b)
|
(initialize-backend b)
|
||||||
(is (capable-p b :truecolor) nil "simple backend has no truecolor")
|
(is-false (capable-p b :truecolor) "simple backend has no truecolor")
|
||||||
(shutdown-backend b)))
|
(shutdown-backend b)))
|
||||||
|
|
||||||
(test simple-backend-draw-text
|
(test simple-backend-draw-text
|
||||||
"simple-backend renders text at position, ignoring style"
|
"simple-backend renders text at position, ignoring style"
|
||||||
(let ((b (make-simple-backend)))
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
(initialize-backend b)
|
(initialize-backend b)
|
||||||
(draw-text b 0 0 "hello" nil nil)
|
(draw-text b 0 0 "hello" :red nil :bold t :italic t)
|
||||||
(shutdown-backend b)
|
(shutdown-backend b)
|
||||||
(is-t t)))
|
(is (string= (get-output-stream-string s) "hello")
|
||||||
|
"draw-text should output the string ignoring style")))
|
||||||
|
|
||||||
(test simple-backend-border-single
|
(test simple-backend-draw-border
|
||||||
"simple-backend draws ASCII single border"
|
"simple-backend draws ASCII border with +-| characters"
|
||||||
(let ((b (make-simple-backend)))
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
(initialize-backend b)
|
(initialize-backend b)
|
||||||
(draw-border b 0 0 10 5 :style :single)
|
(draw-border b 0 0 5 3 :style :single)
|
||||||
(shutdown-backend b)
|
(shutdown-backend b)
|
||||||
(is-t t)))
|
(let ((out (get-output-stream-string s)))
|
||||||
|
(is (search "-----" out) "top edge should have 5 dashes")
|
||||||
|
(is (search "| |" out) "middle row should have pipe sides"))))
|
||||||
|
|
||||||
(test simple-backend-border-rounded
|
(test simple-backend-draw-rounded
|
||||||
"simple-backend falls back to straight edges for rounded"
|
"simple-backend falls back to straight edges for rounded style"
|
||||||
(let ((b (make-simple-backend)))
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
(initialize-backend b)
|
(initialize-backend b)
|
||||||
(draw-border b 0 0 10 5 :style :rounded)
|
(draw-border b 0 0 5 3 :style :rounded)
|
||||||
(shutdown-backend b)
|
(shutdown-backend b)
|
||||||
(is-t t)))
|
(let ((out (get-output-stream-string s)))
|
||||||
|
;; Rounded falls back to ASCII — identical output to single
|
||||||
|
(is (search "-----" out) "rounded style produces same dashes as single"))))
|
||||||
|
|
||||||
|
(test simple-backend-draw-link
|
||||||
|
"simple-backend renders link as plain text"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(initialize-backend b)
|
||||||
|
(draw-link b 0 0 "click me" "http://example.com")
|
||||||
|
(shutdown-backend b)
|
||||||
|
(is (string= (get-output-stream-string s) "click me")
|
||||||
|
"simple-backend ignores URL, outputs text only")))
|
||||||
|
|
||||||
|
(test simple-backend-draw-ellipsis
|
||||||
|
"simple-backend renders ... for ellipsis"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(initialize-backend b)
|
||||||
|
(draw-ellipsis b 0 0 5)
|
||||||
|
(shutdown-backend b)
|
||||||
|
(is (string= (get-output-stream-string s) "...")
|
||||||
|
"ellipsis should output 3 dots")))
|
||||||
|
|
||||||
;; ── Backend Capabilities ───────────────────────────────────────
|
;; ── Backend Capabilities ───────────────────────────────────────
|
||||||
|
|
||||||
@@ -54,7 +85,7 @@
|
|||||||
(initialize-backend b)
|
(initialize-backend b)
|
||||||
(dolist (f '(:truecolor :osc8 :sync :mouse :bracketed-paste
|
(dolist (f '(:truecolor :osc8 :sync :mouse :bracketed-paste
|
||||||
:kitty-keyboard :sixel :cursor-style))
|
:kitty-keyboard :sixel :cursor-style))
|
||||||
(is (capable-p b f) nil
|
(is-false (capable-p b f)
|
||||||
(format nil "~s should not be supported on simple-backend" f)))
|
(format nil "~s should not be supported on simple-backend" f)))
|
||||||
(shutdown-backend b)))
|
(shutdown-backend b)))
|
||||||
|
|
||||||
@@ -71,32 +102,37 @@
|
|||||||
(is (>= lines 3)))
|
(is (>= lines 3)))
|
||||||
(shutdown-backend b)))
|
(shutdown-backend b)))
|
||||||
|
|
||||||
;; ── Drawing Primitives ─────────────────────────────────────────
|
;; ── Backend Protocol: Defaults and No-ops ──────────────────────
|
||||||
|
|
||||||
(test draw-rect-fills-area
|
(test default-methods-are-no-ops
|
||||||
"draw-rect fills a rectangular area with background"
|
"Default backend methods don't error"
|
||||||
(let ((b (make-simple-backend)))
|
(let ((b (make-simple-backend)))
|
||||||
(initialize-backend b)
|
(initialize-backend b)
|
||||||
(draw-rect b 0 0 5 3 :bg nil)
|
(is (null (multiple-value-list (cursor-hide b))))
|
||||||
(shutdown-backend b)
|
(is (null (multiple-value-list (cursor-show b))))
|
||||||
(is-t t)))
|
(is (null (multiple-value-list (cursor-style b :block))))
|
||||||
|
(is (null (multiple-value-list (begin-sync b))))
|
||||||
(test draw-text-multi-line
|
(is (null (multiple-value-list (end-sync b))))
|
||||||
"draw-text handles strings with newlines"
|
(shutdown-backend b)))
|
||||||
(let ((b (make-simple-backend)))
|
|
||||||
(initialize-backend b)
|
|
||||||
(draw-text b 0 0 "line1~%line2" nil nil)
|
|
||||||
(shutdown-backend b)
|
|
||||||
(is-t t)))
|
|
||||||
|
|
||||||
;; ── Synchronization ────────────────────────────────────────────
|
|
||||||
|
|
||||||
(test sync-is-noop-on-simple
|
(test sync-is-noop-on-simple
|
||||||
"begin-sync and end-sync are no-ops on simple-backend"
|
"begin-sync and end-sync produce no output on simple-backend"
|
||||||
(let ((b (make-simple-backend)))
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
(initialize-backend b)
|
(initialize-backend b)
|
||||||
(begin-sync b)
|
(begin-sync b)
|
||||||
(draw-text b 0 0 "in sync" nil nil)
|
(draw-text b 0 0 "in sync" nil nil)
|
||||||
(end-sync b)
|
(end-sync b)
|
||||||
(shutdown-backend b)
|
(shutdown-backend b)
|
||||||
(is-t t)))
|
(is (string= (get-output-stream-string s) "in sync")
|
||||||
|
"no sync escape sequences should appear")))
|
||||||
|
|
||||||
|
;; ── Draw-rect ──────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(test draw-rect-fills-area-correctly
|
||||||
|
"draw-rect with background writes nothing to output (simple-backend no-op)"
|
||||||
|
(multiple-value-bind (b s) (make-capturing-backend)
|
||||||
|
(initialize-backend b)
|
||||||
|
(draw-rect b 0 0 5 3 :bg :red)
|
||||||
|
(shutdown-backend b)
|
||||||
|
(is (string= (get-output-stream-string s) "")
|
||||||
|
"draw-rect is a no-op on simple-backend")))
|
||||||
|
|||||||
11
cl-tui.asd
11
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.1"
|
:version "0.0.3"
|
||||||
:license "TBD"
|
:license "TBD"
|
||||||
:depends-on (:fiveam)
|
:depends-on (:fiveam)
|
||||||
:components
|
:components
|
||||||
@@ -10,7 +10,11 @@
|
|||||||
:components
|
:components
|
||||||
((:file "package")
|
((:file "package")
|
||||||
(:file "classes" :depends-on ("package"))
|
(:file "classes" :depends-on ("package"))
|
||||||
(:file "simple" :depends-on ("package" "classes")))))
|
(:file "simple" :depends-on ("package" "classes"))
|
||||||
|
(:file "modern" :depends-on ("package" "classes"))))
|
||||||
|
(:module "layout"
|
||||||
|
:components
|
||||||
|
((:file "layout"))))
|
||||||
: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
|
||||||
@@ -18,6 +22,9 @@
|
|||||||
:depends-on (:cl-tui :fiveam)
|
:depends-on (:cl-tui :fiveam)
|
||||||
:components
|
:components
|
||||||
((:module "backend"
|
((:module "backend"
|
||||||
|
:components
|
||||||
|
((:file "tests")))
|
||||||
|
(:module "layout"
|
||||||
:components
|
:components
|
||||||
((:file "tests"))))
|
((:file "tests"))))
|
||||||
:perform (test-op (o c)
|
:perform (test-op (o c)
|
||||||
|
|||||||
@@ -118,3 +118,58 @@
|
|||||||
(let ((sc (layout-node-children sidebar)))
|
(let ((sc (layout-node-children sidebar)))
|
||||||
(is (= (layout-node-y (elt sc 0)) 0))
|
(is (= (layout-node-y (elt sc 0)) 0))
|
||||||
(is (= (layout-node-y (elt sc 1)) 3)))))
|
(is (= (layout-node-y (elt sc 1)) 3)))))
|
||||||
|
|
||||||
|
;; ── Edge Cases ────────────────────────────────────────────────
|
||||||
|
|
||||||
|
(test empty-container-does-not-crash
|
||||||
|
"compute-layout on a node with no children should not error"
|
||||||
|
(let ((r (make-layout-node)))
|
||||||
|
(compute-layout r 20 20)
|
||||||
|
(is (integerp (layout-node-width r)))
|
||||||
|
(is (integerp (layout-node-height r)))))
|
||||||
|
|
||||||
|
(test single-child-in-column
|
||||||
|
"A column with one child places it correctly"
|
||||||
|
(let* ((r (make-layout-node :direction :column :width 10 :height 20))
|
||||||
|
(c (make-layout-node :height 5)))
|
||||||
|
(layout-node-add-child r c)
|
||||||
|
(compute-layout r 10 20)
|
||||||
|
(is (= (layout-node-y c) 0))
|
||||||
|
(is (= (layout-node-height c) 5))))
|
||||||
|
|
||||||
|
(test zero-size-container
|
||||||
|
"compute-layout with zero available space should not error"
|
||||||
|
(let* ((r (make-layout-node :direction :column))
|
||||||
|
(c (make-layout-node :height 5)))
|
||||||
|
(layout-node-add-child r c)
|
||||||
|
(compute-layout r 0 0)
|
||||||
|
(is (integerp (layout-node-x c)))
|
||||||
|
(is (integerp (layout-node-y c)))))
|
||||||
|
|
||||||
|
(test deep-nesting-three-levels
|
||||||
|
"Three-level deep nesting produces correct leaf positions"
|
||||||
|
(let* ((out (vbox () ; outer box
|
||||||
|
(vbox (:grow 1) ; middle box
|
||||||
|
(make-layout-node :height 2)))) ; leaf
|
||||||
|
(leaf (elt (layout-node-children
|
||||||
|
(elt (layout-node-children out) 0)) 0)))
|
||||||
|
(compute-layout out 20 20)
|
||||||
|
(is (= (layout-node-y leaf) 0))))
|
||||||
|
|
||||||
|
(test large-padding-leaves-room
|
||||||
|
"Large padding reduces content area but doesn't crash"
|
||||||
|
(let* ((r (make-layout-node :direction :column
|
||||||
|
:padding '(:top 5 :left 5 :bottom 5 :right 5)))
|
||||||
|
(c (make-layout-node :height 3)))
|
||||||
|
(layout-node-add-child r c)
|
||||||
|
(compute-layout r 20 20)
|
||||||
|
(is (= (layout-node-x c) 5))
|
||||||
|
(is (= (layout-node-y c) 5))))
|
||||||
|
|
||||||
|
(test negative-grow-is-clamped
|
||||||
|
"Grow values are adjusted but still compute"
|
||||||
|
(let* ((r (make-layout-node :direction :row :width 10))
|
||||||
|
(c (make-layout-node :width 5 :grow -1)))
|
||||||
|
(layout-node-add-child r c)
|
||||||
|
(compute-layout r 10 10)
|
||||||
|
(is (integerp (layout-node-width c)))))
|
||||||
|
|||||||
Reference in New Issue
Block a user