(in-package #:monparser)

(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))
                      (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)))
    `(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))))

(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))))