(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 ((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 ,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" #\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*))