From c2bc2dbc61a5df9c3a5dfb19cefd83dae93266db Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Juan=20Manuel=20Tom=C3=A1s?= <jtomas1815@gmail.com>
Date: Sun, 25 Oct 2026 01:40:48 -0300
Subject: Refine the testing suite

---
 test.lisp | 375 ++++++++++++++++++++++++++++----------------------------------
 1 file changed, 172 insertions(+), 203 deletions(-)

diff --git a/test.lisp b/test.lisp
index 1d98702..ea50ca8 100644
--- a/test.lisp
+++ b/test.lisp
@@ -1,212 +1,181 @@
 (in-package #:monparser)
 
-(defvar *test-passed* 0)
-(defvar *test-failed* 0)
-
-(defun print-result (result)
-  (if (failure-p result)
-    (format nil "~a" result)
-    (format nil "~a" (parsing-tree result))))
-
-(defun check-result (actual expected)
-  (cond ((eq expected :failure)
-         (or (failure-p actual)
-             (progn
-               (format t "~tFAIL: expected failure but got ~a~&" (print-result actual))
-               (incf *test-failed*)
-               nil)))
-        ((functionp expected)
-         (or (funcall expected actual)
-             (progn
-               (format t "~tFAIL: custom check failed~&")
-               (format t "~t~tInput: ~a~&" (result-place actual))
-               (format t "~t~tResult: ~a~&" actual)
-               (incf *test-failed*)
-               nil)))
-        ((characterp expected)
-         (or (and (parsing-p actual)
-                  (char= expected (parsing-tree actual)))
-             (progn
-               (format t "~tFAIL: expected ~a but got ~a~&" expected (print-result actual))
-               (incf *test-failed*)
-               nil)))
-        ((stringp expected)
-         (or (and (parsing-p actual)
-                  (string= expected (parsing-tree actual)))
-             (progn
-               (format t "~tFAIL: expected ~a but got ~a~&" expected (print-result actual))
-               (incf *test-failed*)
-               nil)))
-        ((null expected)
-         (or (and (parsing-p actual)
-                  (null (parsing-tree actual)))
-             (progn
-               (format t "~tFAIL: expected empty list but got ~a~&" (print-result actual))
-               (incf *test-failed*)
-               nil)))
-        ((typep expected 'cons)
-         (or (and (parsing-p actual)
-                  (equal expected (parsing-tree actual)))
-             (progn
-               (format t "~tFAIL: expected ~a but got ~a~&" expected (print-result actual))
-               (incf *test-failed*)
-               nil)))
-        (t (format t "~tWARN: unsupported expected type ~a~&" expected)
-           t)))
-
-(defmacro deftest (title &body tests)
+(defmacro define-tests (&body tests)
   (let ((test-forms))
     (dolist (test tests)
       (let ((parser (first test))
             (input (second test))
             (expected (third test)))
-        (push `(let ((actual (parse ,parser ,input)))
-                 (if (check-result actual ,expected)
-                   (incf *test-passed*)
-                   (incf *test-failed*)))
+        (push `(let* ((actual (parse ,parser ,input))
+                      (passed? (if (eq ,expected :failure)
+                                 (failure-p actual)
+                                 (and (parsing-p actual)
+                                      (equalp ,expected (parsing-tree actual))))))
+                 (if passed?
+                   (incf test-passed)
+                   (progn
+                     (format t "FAIL: ~a ~a ~&~tExpected: ~a~&~tActual: ~a~&~%"
+                             ',parser
+                             ,input
+                             ,expected
+                             (if (parsing-p actual)
+                               (parsing-tree actual)
+                               actual))
+                     (incf test-failed))))
               test-forms)))
-    (setf test-forms (nreverse test-forms))
-    `(progn
-       (let ((had-failures *test-failed*))
-         ,@test-forms
-         (unless (eq *test-failed* had-failures)
-           (format t "~a:~&" ,title)
-           (format t "~%"))))))
+    `(defun run-tests ()
+       (let ((test-passed 0)
+             (test-failed 0))
+         ,@(reverse test-forms)
+         (format t "PASSED: ~a~&" test-passed)
+         (format t "FAILED: ~a~&" test-failed)))))
+
+(defparser whitespace ()
+  (optional (many (unit #'whitespace?))))
+
+(defparser lazy-test ()
+  (within whitespace
+          (one-of (unit #\h)
+                  (comp ((_ (unit #\{))
+                         (body (optional (many (lazy lazy-test))))
+                         (_ (unit #\})))
+                    body)
+                  (comp ((_ (unit #\())
+                         (body (optional (many (lazy lazy-test))))
+                         (_ (unit #\))))
+                    body)
+                  (unit))))
 
-(defun test ()
-  (deftest "unit"
-           ((unit) "hello" #\h)
-           ((unit #\h) "hello" #\h)
-           ((unit #\x) "hello" :failure)
-           ((unit #'alpha-char-p) "hello" #\h)
-           ((unit #'digit-char-p) "1abc" #\1)
-           ((unit #\@) "hello" :failure)
-           ((unit #\x) "" :failure))
-  (deftest "many"
-           ((many (unit #\h)) "hello" (list #\h))
-           ((many (unit #\h)) "hhhhhhhello" (list #\h #\h #\h #\h #\h #\h #\h))
-           ((many (unit #\h)) "ello" :failure)
-           ((many (unit #\x)) "hello" :failure)
-           ((many (unit #\h)) "" :failure)
-           ((many (unit #'alpha-char-p)) "abc123xyz" (list #\a #\b #\c)))
-  (deftest "optional many"
-           ((optional (many (unit #\h))) "hello" (list #\h))
-           ((optional (many (unit #\h))) "hhhhhhhello" (list #\h #\h #\h #\h #\h #\h #\h))
-           ((optional (many (unit #\h))) "ello" nil)
-           ((optional (many (unit #\h))) "" nil))
-  (deftest "many optional"
-           ((many (optional (unit #\h))) "hello" (list #\h))
-           ((many (optional (unit #\h))) "hhhhhhhello" (list #\h #\h #\h #\h #\h #\h #\h))
-           ((many (optional (unit #\h))) "ello" :failure)
-           ((many (optional (unit #\h))) "" :failure))
-  (deftest "until literal"
-           ((comp ((prefix (optional (literal "zy")))
-                   (match (if prefix
-                            (fail "Reached prefix")
-                            (unit))))
-              match)
-            "zy" :failure)
-           ((comp ((prefix (optional (literal "zy")))
-                   (match (if prefix
-                            (fail "Reached prefix")
-                            (unit))))
-              match)
-            "ezy" #\e)
-           ((many (comp ((prefix (optional (literal "zy")))
-                         (match (if prefix
-                                  (fail "Reached prefix")
-                                  (unit))))
-                    match))
-            "the quick brown fox jumps over the lazy dog."
-            (coerce "the quick brown fox jumps over the la" 'list))
-           ((optional
-              (many
-                (comp ((prefix (optional (literal "zy")))
-                       (match (if prefix
-                                (fail "Reached prefix")
-                                (unit))))
-                  match)))
-            "the quick brown fox jumps over the lazy dog."
-            (coerce "the quick brown fox jumps over the la" 'list)))
-  (deftest "literal"
-           ((literal "hello") "hello world" (list #\h #\e #\l #\l #\o))
-           ((literal "hello") "hello" (list #\h #\e #\l #\l #\o))
-           ((literal "hello") "help" :failure)
-           ((literal "hello") "world" :failure)
-           ((literal "") "hello" (list))
-           ((literal "ab") "abc" (list #\a #\b)))
-  (deftest "one-of"
-           ((one-of (unit #\a) (unit #\b)) "abc" #\a)
-           ((one-of (unit #\b) (unit #\a)) "abc" #\a)
-           ((one-of (unit #\c) (unit #\d)) "abc" :failure))
-  (deftest "whitespace?"
-           ((many (unit #'whitespace?)) "  abc" (list #\Space #\Space))
-           ((many (unit #'whitespace?)) (format nil "~a~aabc" #\Tab #\Newline) (list #\Tab #\Newline))
-           ((many (unit #'whitespace?)) "abc" :failure)
-           ((many (unit #'whitespace?)) "" :failure))
-  (deftest "repeat"
-           ((repeat (unit #\h) 3) "hhhello" (list #\h #\h #\h))
-           ((repeat (unit #\h) 3) "hh" :failure)
-           ((repeat (unit #\x) 3) "hello" :failure))
-  (deftest "within"
-           ((within (literal "(") (many (unit #\a)) (literal ")")) "(aaa)bc" (list #\a #\a #\a))
-           ((within (literal "[") (many (unit #\x)) (literal "]")) "[xxxx]bc" (list #\x #\x #\x #\x))
-           ((within (literal "(") (many (unit #\a)) (literal ")")) "((aaa)bc" :failure)
-           ((within (literal "(") (many (unit #\a)) (literal ")")) "(aaabc" :failure))
-  (deftest "comp"
-           ((comp ((a (unit #\a))
-                   (b (unit #\b)))
-              (format nil "~a~a" a b))
-            "abc" "ab")
-           ((comp ((a (many (unit #\a)))
-                   (b (many (unit #\b))))
-              (format nil "~a ~a" a b))
-            "aaabbbccc" "(a a a) (b b b)")
-           ((comp ((a (unit #\1))
-                   (b (unit #\2))
-                   (c (unit #\3)))
-              (list a b c))
-            "12345" (list #\1 #\2 #\3)))
-  (deftest "failure chaining"
-           ((comp ((a (literal "hello"))
-                   (b (literal "world")))
-              (format nil "~a ~a" a b))
-            "helloworld" "(h e l l o) (w o r l d)")
-           ((comp ((a (literal "hello"))
-                   (b (literal "world")))
-              (format nil "~a ~a" a b))
-            "hello there" :failure)
-           ((comp ((a (literal "foo"))
-                   (b (literal "bar"))
-                   (c (literal "baz")))
-              (list a b c))
-            "foobarbaz" (list (list #\f #\o #\o) (list #\b #\a #\r) (list #\b #\a #\z)))
-           ((comp ((a (literal "foo"))
-                   (b (literal "bar"))
-                   (c (literal "baz")))
-              (list a b c))
-            "fooquxbaz" :failure))
-  (deftest "custom predicates"
-           ((many (unit (lambda (c) (char= c #\0)))) "000123" (list #\0 #\0 #\0 #\1 #\2 #\3))
-           ((many (unit (lambda (c) (oddp (digit-char-p c))))) "13579abc" (list #\1 #\3 #\5 #\7 #\9 #\a #\b #\c))
-           ((many (unit (lambda (c) (char= c #\x)))) "xxx" (list #\x #\x #\x))
-           ((many (unit (lambda (c) (char= c #\x)))) "xxxyyy" (list #\x #\x #\x #\y #\y #\y)))
-  (deftest "nested parsers"
-           ((many (within (literal "(") (unit #\a) (literal ")"))) "(a)(a)(a)bc" (list #\a #\a #\a))
-           ((many (comp ((a (unit #\a))
-                         (b (unit #\b)))
-                    (list a b)))
-            "abababc" (list (list #\a #\b) (list #\a #\b) (list #\a #\b)))
-           ((many (comp ((a (unit #\1))
-                         (b (unit #\2)))
-                    (concatenate 'string (list a b))))
-            "121212xyz" (list "12" "12" "12")))
-  (deftest "edge cases"
-           ((unit #\x) "" :failure)
-           ((many (unit #\x)) "" :failure)
-           ((optional (unit #\x)) "" nil)
-           ((literal "xyz") "" :failure)
-           ((many (literal "ab")) "ababab" (list (list #\a #\b) (list #\a #\b) (list #\a #\b)))
-           ((many (literal "ab")) "ababxab" (list (list #\a #\b) (list #\a #\b))))
-  (format t "PASSED: ~a~&" *test-passed*)
-  (format t "FAILED: ~a~&" *test-failed*))
+(define-tests
+  ((unit) "hello" #\h)
+  ((unit #\h) "hello" #\h)
+  ((unit #\x) "hello" :failure)
+  ((unit #'alpha-char-p) "hello" #\h)
+  ((unit #'digit-char-p) "1abc" #\1)
+  ((unit #\@) "hello" :failure)
+  ((unit #\x) "" :failure)
+  ((many (unit #\h)) "hello" (list #\h))
+  ((many (unit #\h)) "hhhhhhhello" (list #\h #\h #\h #\h #\h #\h #\h))
+  ((many (unit #\h)) "ello" :failure)
+  ((many (unit #\x)) "hello" :failure)
+  ((many (unit #\h)) "" :failure)
+  ((many (unit #'alpha-char-p)) "abc123xyz" (list #\a #\b #\c))
+  ((optional (many (unit #\h))) "hello" (list #\h))
+  ((optional (many (unit #\h))) "hhhhhhhello" (list #\h #\h #\h #\h #\h #\h #\h))
+  ((optional (many (unit #\h))) "ello" nil)
+  ((optional (many (unit #\h))) "" nil)
+  ((many (optional (unit #\h))) "hello" (list #\h))
+  ((many (optional (unit #\h))) "hhhhhhhello" (list #\h #\h #\h #\h #\h #\h #\h))
+  ((many (optional (unit #\h))) "ello" :failure)
+  ((many (optional (unit #\h))) "" :failure)
+  ((comp ((prefix (optional (literal "zy")))
+          (match (if prefix
+                   (fail "Reached prefix")
+                   (unit))))
+     match)
+   "zy" :failure)
+  ((comp ((prefix (optional (literal "zy")))
+          (match (if prefix
+                   (fail "Reached prefix")
+                   (unit))))
+     match)
+   "ezy" #\e)
+  ((many (comp ((prefix (optional (literal "zy")))
+                (match (if prefix
+                         (fail "Reached prefix")
+                         (unit))))
+           match))
+   "the quick brown fox jumps over the lazy dog."
+   (coerce "the quick brown fox jumps over the la" 'list))
+  ((optional
+     (many
+       (comp ((prefix (optional (literal "zy")))
+              (match (if prefix
+                       (fail "Reached prefix")
+                       (unit))))
+         match)))
+   "the quick brown fox jumps over the lazy dog."
+   (coerce "the quick brown fox jumps over the la" 'list))
+  ((literal "hello") "hello world" (list #\h #\e #\l #\l #\o))
+  ((literal "hello") "hello" (list #\h #\e #\l #\l #\o))
+  ((literal "hello") "help" :failure)
+  ((literal "hello") "world" :failure)
+  ((literal "") "hello" (list))
+  ((literal "ab") "abc" (list #\a #\b))
+  ((one-of (unit #\a) (unit #\b)) "abc" #\a)
+  ((one-of (unit #\b) (unit #\a)) "abc" #\a)
+  ((one-of (unit #\c) (unit #\d)) "abc" :failure)
+  ((one-of (unit #\h)
+           (comp ((_ (unit #\())
+                  (body (optional (many (unit #\h))))
+                  (_ (unit #\))))
+             body)
+           (unit))
+   "(hhh)ello" (list #\h #\h #\h))
+  ((many (unit #'whitespace?)) "  abc" (list #\Space #\Space))
+  ((many (unit #'whitespace?)) (format nil "~a~aabc" #\Tab #\Newline) (list #\Tab #\Newline))
+  ((many (unit #'whitespace?)) "abc" :failure)
+  ((many (unit #'whitespace?)) "" :failure)
+  ((repeat (unit #\h) 3) "hhhello" (list #\h #\h #\h))
+  ((repeat (unit #\h) 3) "hh" :failure)
+  ((repeat (unit #\x) 3) "hello" :failure)
+  ((within (literal "(") (many (unit #\a)) (literal ")")) "(aaa)bc" (list #\a #\a #\a))
+  ((within (literal "[") (many (unit #\x)) (literal "]")) "[xxxx]bc" (list #\x #\x #\x #\x))
+  ((within (literal "(") (many (unit #\a)) (literal ")")) "((aaa)bc" :failure)
+  ((within (literal "(") (many (unit #\a)) (literal ")")) "(aaabc" :failure)
+  ((comp ((a (unit #\a))
+          (b (unit #\b)))
+     (format nil "~a~a" a b))
+   "abc" "ab")
+  ((comp ((a (many (unit #\a)))
+          (b (many (unit #\b))))
+     (format nil "~a ~a" a b))
+   "aaabbbccc" "(a a a) (b b b)")
+  ((comp ((a (unit #\1))
+          (b (unit #\2))
+          (c (unit #\3)))
+     (list a b c))
+   "12345" (list #\1 #\2 #\3))
+  ((comp ((_ (unit #\{))
+          (body (optional (many (unit #\h))))
+          (_ (unit #\})))
+     body)
+   "{hhh}" (list #\h #\h #\h))
+  (lazy-test "(hhh)ello" (list #\h #\h #\h))
+  ((comp ((a (literal "hello"))
+          (b (literal "world")))
+     (format nil "~a ~a" a b))
+   "helloworld" "(h e l l o) (w o r l d)")
+  ((comp ((a (literal "hello"))
+          (b (literal "world")))
+     (format nil "~a ~a" a b))
+   "hello there" :failure)
+  ((comp ((a (literal "foo"))
+          (b (literal "bar"))
+          (c (literal "baz")))
+     (list a b c))
+   "foobarbaz" (list (list #\f #\o #\o) (list #\b #\a #\r) (list #\b #\a #\z)))
+  ((comp ((a (literal "foo"))
+          (b (literal "bar"))
+          (c (literal "baz")))
+     (list a b c))
+   "fooquxbaz" :failure)
+  ((many (unit (lambda (c) (char= c #\0)))) "000123" (list #\0 #\0 #\0 #\1 #\2 #\3))
+  ((many (unit (lambda (c) (oddp (digit-char-p c))))) "13579abc" (list #\1 #\3 #\5 #\7 #\9 #\a #\b #\c))
+  ((many (unit (lambda (c) (char= c #\x)))) "xxx" (list #\x #\x #\x))
+  ((many (unit (lambda (c) (char= c #\x)))) "xxxyyy" (list #\x #\x #\x #\y #\y #\y))
+  ((many (within (literal "(") (unit #\a) (literal ")"))) "(a)(a)(a)bc" (list #\a #\a #\a))
+  ((many (comp ((a (unit #\a))
+                (b (unit #\b)))
+           (list a b)))
+   "abababc" (list (list #\a #\b) (list #\a #\b) (list #\a #\b)))
+  ((many (comp ((a (unit #\1))
+                (b (unit #\2)))
+           (concatenate 'string (list a b))))
+   "121212xyz" (list "12" "12" "12"))
+  ((unit #\x) "" :failure)
+  ((many (unit #\x)) "" :failure)
+  ((optional (unit #\x)) "" nil)
+  ((literal "xyz") "" :failure)
+  ((many (literal "ab")) "ababab" (list (list #\a #\b) (list #\a #\b) (list #\a #\b)))
+  ((many (literal "ab")) "ababxab" (list (list #\a #\b) (list #\a #\b))))
-- 
cgit v1.2.3