fix: dialog draw-border arg, markdown/slot nil guards, +integration test suite
This commit is contained in:
Hermes Agent
@@ -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
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
263
tests/integration-tests.lisp
Normal 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")))
|
||||
@@ -11,14 +11,91 @@
|
||||
|
||||
(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 ()
|
||||
(def-test heading-parsing ( )
|
||||
(let* ((result (parse-blocks "# Hello World")) (node (first result)))
|
||||
(is-true (eql :heading (getf node :type)))
|
||||
(is (= 1 (getf (getf node :properties) :level)))))
|
||||
|
||||
(def-test heading-levels ()
|
||||
(def-test heading-levels ( )
|
||||
(loop for level from 1 to 6
|
||||
do (let* ((hashes (make-string level :initial-element #\#))
|
||||
(text (format nil "~a Heading ~d" hashes level))
|
||||
@@ -27,7 +104,7 @@
|
||||
(is-true (eql :heading (getf node :type)))
|
||||
(is (= level (getf (getf node :properties) :level))))))
|
||||
|
||||
(def-test heading-with-inline-formatting ()
|
||||
(def-test heading-with-inline-formatting ( )
|
||||
(let* ((result (parse-blocks "# Hello **World**"))
|
||||
(node (first result)) (children (getf node :children)))
|
||||
(is-true (eql :heading (getf node :type)))
|
||||
@@ -35,40 +112,40 @@
|
||||
(is-true (eql :text (getf (first children) :type)))
|
||||
(is-true (eql :bold (getf (second children) :type)))))
|
||||
|
||||
(def-test paragraph-parsing ()
|
||||
(def-test paragraph-parsing ( )
|
||||
(let* ((result (parse-blocks "This is a paragraph.")) (node (first result)))
|
||||
(is-true (eql :paragraph (getf node :type)))))
|
||||
|
||||
(def-test paragraph-multi-line ()
|
||||
(def-test paragraph-multi-line ( )
|
||||
(let* ((result (parse-blocks "Line one\nLine two")) (node (first result)))
|
||||
(is-true (eql :paragraph (getf node :type)))))
|
||||
|
||||
(def-test bold-parsing ()
|
||||
(def-test bold-parsing ( )
|
||||
(let* ((children (parse-inline "hello **world** here"))
|
||||
(bold-node (second children)))
|
||||
(is (= 3 (length children)))
|
||||
(is-true (eql :bold (getf bold-node :type)))))
|
||||
|
||||
(def-test italic-parsing ()
|
||||
(def-test italic-parsing ( )
|
||||
(let* ((children (parse-inline "hello *world* here"))
|
||||
(italic-node (second children)))
|
||||
(is (= 3 (length children)))
|
||||
(is-true (eql :italic (getf italic-node :type)))))
|
||||
|
||||
(def-test bold-italic-combined ()
|
||||
(def-test bold-italic-combined ( )
|
||||
(let ((children (parse-inline "**bold** and *italic*")))
|
||||
(is (= 3 (length children)))
|
||||
(is-true (eql :bold (getf (first children) :type)))
|
||||
(is-true (eql :italic (getf (third children) :type)))))
|
||||
|
||||
(def-test inline-code-parsing ()
|
||||
(def-test inline-code-parsing ( )
|
||||
(let* ((children (parse-inline "use `foo` here"))
|
||||
(code-node (second children)))
|
||||
(is (= 3 (length children)))
|
||||
(is-true (eql :inline-code (getf code-node :type)))
|
||||
(is (equal "foo" (getf code-node :content)))))
|
||||
|
||||
(def-test link-parsing ()
|
||||
(def-test link-parsing ( )
|
||||
(let* ((children (parse-inline "click [here](https://x.com)"))
|
||||
(link-node (second children)))
|
||||
(is (= 2 (length children)))
|
||||
@@ -79,98 +156,100 @@
|
||||
(is-true (eql :text (getf (first link-text) :type)))
|
||||
(is (equal "here" (getf (first link-text) :content))))))
|
||||
|
||||
(def-test code-block-parsing ()
|
||||
(let* ((text (format nil "```lisp~%(defun hello ())~% (print \"hi\")~%```"))
|
||||
(def-test code-block-parsing ( )
|
||||
(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~%```"))
|
||||
(def-test code-block-unknown-language ( )
|
||||
(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))))
|
||||
|
||||
(def-test blockquote-parsing ()
|
||||
(def-test blockquote-parsing ( )
|
||||
(let* ((result (parse-blocks "> This is a quote")) (node (first result)))
|
||||
(is-true (eql :blockquote (getf node :type)))))
|
||||
|
||||
(def-test list-item-parsing ()
|
||||
(def-test list-item-parsing ( )
|
||||
(let* ((result (parse-blocks "- First item")) (node (first result)))
|
||||
(is-true (eql :list-item (getf node :type)))))
|
||||
|
||||
(def-test ordered-list-parsing ()
|
||||
(def-test ordered-list-parsing ( )
|
||||
(let* ((result (parse-blocks "1. First item")) (node (first result)))
|
||||
(is-true (eql :ordered-item (getf node :type)))))
|
||||
|
||||
(def-test thematic-break-parsing ()
|
||||
(def-test thematic-break-parsing ( )
|
||||
(let* ((result (parse-blocks "---")) (node (first result)))
|
||||
(is-true (eql :thematic-break (getf node :type)))))
|
||||
|
||||
;; ─── Diff tests ───────────────────────────────────────────────────────────────
|
||||
|
||||
(def-test classify-diff-added ()
|
||||
(def-test classify-diff-added ( )
|
||||
(is (eql :added (classify-diff-line "+this is added"))))
|
||||
|
||||
(def-test classify-diff-removed ()
|
||||
(def-test classify-diff-removed ( )
|
||||
(is (eql :removed (classify-diff-line "-this is removed"))))
|
||||
|
||||
(def-test classify-diff-hunk ()
|
||||
(is (eql :hunk-header (classify-diff-line "@@ -1,3 +1,4 @@"))))
|
||||
(def-test classify-diff-hunk ( )
|
||||
(is (eql :hunk-header (classify-diff-line "@@ -1,3 +1,4 @@" ))))
|
||||
|
||||
(def-test classify-diff-context ()
|
||||
(def-test classify-diff-context ( )
|
||||
(is (eql :context (classify-diff-line " normal context"))))
|
||||
|
||||
;; ─── Syntax highlighting tests ────────────────────────────────────────────────
|
||||
(def-test highlight-lisp-keyword ()
|
||||
(def-test highlight-lisp-keyword ( )
|
||||
(let ((tokens (highlight-code "(defun hello ()" "lisp")))
|
||||
(is-true (some (lambda (pair) (and (search "defun" (car pair))
|
||||
(eql :keyword (cdr pair))))
|
||||
tokens))))
|
||||
|
||||
(def-test highlight-lisp-builtin ()
|
||||
(def-test highlight-lisp-builtin ( )
|
||||
"Test that a Lisp builtin like nil is highlighted as :builtin."
|
||||
(let ((tokens (highlight-code "(if t nil)" "lisp")))
|
||||
(is-true (some (lambda (pair) (and (string= (car pair) "nil")
|
||||
(eql :builtin (cdr pair))))
|
||||
tokens))))
|
||||
|
||||
(def-test highlight-unknown-language ()
|
||||
(def-test highlight-unknown-language ( )
|
||||
(let ((tokens (highlight-code "hello world" "unknown-xyz")))
|
||||
(every (lambda (pair) (eql :plain (cdr pair))) tokens)))
|
||||
|
||||
(def-test highlight-comment ()
|
||||
(def-test highlight-comment ( )
|
||||
(let ((tokens (highlight-code "; this is a comment" "lisp")))
|
||||
(is-true (some (lambda (pair) (eql :comment (cdr pair))) tokens))))
|
||||
|
||||
;; ─── Render tests ─────────────────────────────────────────────────────────────
|
||||
|
||||
(def-test render-heading-output ()
|
||||
(def-test render-heading-output ( )
|
||||
(let* ((node (make-md-node :heading :properties (list :level 2)
|
||||
:children (list (make-md-node :text :content "Test"))))
|
||||
(lines (render-md-node node)))
|
||||
(is (= 1 (length lines)))
|
||||
(is-true (> (length (first lines)) 0))))
|
||||
|
||||
(def-test render-paragraph-output ()
|
||||
(def-test render-paragraph-output ( )
|
||||
(let* ((node (make-md-node :paragraph
|
||||
:children (list (make-md-node :text :content "Hello"))))
|
||||
(lines (render-md-node node)))
|
||||
(is (= 1 (length lines)))
|
||||
(is-true (search "Hello" (first lines)))))
|
||||
|
||||
(def-test render-thematic-break-output ()
|
||||
(def-test render-thematic-break-output ( )
|
||||
(let* ((node (make-md-node :thematic-break)) (lines (render-md-node node)))
|
||||
(is (= 1 (length lines)))))
|
||||
|
||||
(def-test render-code-block-output ()
|
||||
(def-test render-code-block-output ( )
|
||||
(let* ((node (make-md-node :code-block :content "(print \"hello\")"
|
||||
:properties (list :language "lisp")))
|
||||
(lines (render-md-node node)))
|
||||
(is-true (> (length lines) 0))))
|
||||
|
||||
(def-test render-diff-block-output ()
|
||||
(def-test render-diff-block-output ( )
|
||||
(let* ((node (make-md-node :diff-block :properties
|
||||
(list :lines
|
||||
'("--- a/file" "+++ b/file" "@@ -1 +1 @@"
|
||||
@@ -182,22 +261,22 @@
|
||||
|
||||
;; ─── Integration tests ────────────────────────────────────────────────────────
|
||||
|
||||
(def-test markdown-integration ()
|
||||
(def-test markdown-integration ( )
|
||||
(let* ((md (format nil "# Title~%~%This is **bold** and `code`.~%~%- Item 1~%- Item 2~%~%> A quote~%~%```lisp~%(defun hello ())~% (print \"hi\")~%```~%~%---"))
|
||||
(nodes (parse-blocks md)) (lines (render-md nodes)))
|
||||
(is-true (> (length lines) 5))
|
||||
(is-true (search "# Title" (first lines)))))
|
||||
|
||||
(def-test render-markdown-string ()
|
||||
(def-test render-markdown-string ( )
|
||||
(let ((result (render-markdown "**bold** text")))
|
||||
(is-true (stringp result))
|
||||
(is-true (> (length result) 0))))
|
||||
|
||||
(def-test md-node-text-simple ()
|
||||
(def-test md-node-text-simple ( )
|
||||
(let ((node (make-md-node :text :content "hello")))
|
||||
(is (equal "hello" (md-node-text node)))))
|
||||
|
||||
(def-test md-node-text-nested ()
|
||||
(def-test md-node-text-nested ( )
|
||||
(let ((node (make-md-node :paragraph :children
|
||||
(list (make-md-node :text :content "hello")
|
||||
(make-md-node :bold :children
|
||||
|
||||
@@ -4,23 +4,51 @@
|
||||
(def-suite slot-suite :description "Slot system tests")
|
||||
(in-suite slot-suite)
|
||||
|
||||
(def-test defslot-register ()
|
||||
(def-test defslot-register ( )
|
||||
(clear-slot :test-slot)
|
||||
(defslot :test-slot :order 1 :render-fn (lambda () "hello"))
|
||||
(is-true (slot-p :test-slot)))
|
||||
|
||||
(def-test slot-render-calls ()
|
||||
(def-test slot-render-calls ( )
|
||||
(clear-slot :test-slot)
|
||||
(defslot :test-slot :order 1 :render-fn (lambda () "a"))
|
||||
(defslot :test-slot :order 2 :render-fn (lambda () "b"))
|
||||
(is (equal '("a" "b") (slot-render :test-slot))))
|
||||
|
||||
(def-test slot-render-empty ()
|
||||
(def-test slot-render-empty ( )
|
||||
(clear-slot :ghost)
|
||||
(is-false (slot-render :ghost)))
|
||||
|
||||
(def-test clear-slot-removes ()
|
||||
(def-test clear-slot-removes ( )
|
||||
(clear-slot :test-slot)
|
||||
(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))
|
||||
|
||||
Reference in New Issue
Block a user