Match tests results to their expected field.HEADmain

Also add more tests.

1 files changed, 181 insertions, 30 deletions

diff --git a/test.lisp b/test.lisp
index b1e3f3e..358ceb4 100644
--- a/test.lisp
+++ b/test.lisp
@@ -1,55 +1,123 @@
 (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 input)
+  (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~&" input)
+               (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)
-  (let ((result '(progn)))
-    (push `(format t "~a:~&" ,title) result)
+  (let ((test-forms))
     (dolist (test tests)
       (let ((parser (first test))
-            (input (second test)))
-        (push `(format t "~a~&" (parse ,parser ,input)) result)))
-    (push '(format t "~%") result)
-    (reverse result)))
+            (input (second test))
+            (expected (third test)))
+        (push `(let ((actual (parse ,parser ,input)))
+                 (if (check-result actual ,expected ,input)
+                   (incf *test-passed*)
+                   (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 test ()
   (deftest "unit"
-           ((unit) "hello")
-           ((unit #\h) "hello"))
+           ((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")
-           ((many (unit #\h)) "hhhhhhhello")
-           ((many (unit #\h)) "ello"))
+           ((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")
-           ((optional (many (unit #\h))) "hhhhhhhello")
-           ((optional (many (unit #\h))) "ello"))
+           ((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")
-           ((many (optional (unit #\h))) "hhhhhhhello")
-           ((many (optional (unit #\h))) "ello"))
+           ((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")
-           ((comp (((prefix) (optional (literal "zy")))
-                   ((match) (if (parsing-tree prefix)
-                              (fail "Reached prefix")
-                              (progn
-                                (format t "prefix place ~a~&"
-                                        (result-place prefix))
-                                (unit)))))
-              (format t "match place: ~a~&"
-                      (result-place match))
+            "zy" :failure)
+           ((comp ((prefix (optional (literal "zy")))
+                   (match (if prefix
+                            (fail "Reached prefix")
+                            (unit))))
               match)
-            "ezy")
+            "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.")
+            "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")))
@@ -57,4 +125,87 @@
                                 (fail "Reached prefix")
                                 (unit))))
                   match)))
-            "the quick brown fox jumps over the lazy dog.")))
+            "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*))