;;;; Copyright (c) 2007-2013 Nikodemus Siivola <nikodemus@random-state.net>
;;;; Copyright (c) 2012-2020 Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
;;;;
;;;; Permission is hereby granted, free of charge, to any person
;;;; obtaining a copy of this software and associated documentation files
;;;; (the "Software"), to deal in the Software without restriction,
;;;; including without limitation the rights to use, copy, modify, merge,
;;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;;; and to permit persons to whom the Software is furnished to do so,
;;;; subject to the following conditions:
;;;;
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
;;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(cl:in-package #:esrap-tests)

(in-suite esrap)

;;; defrule tests

(test defrule.check-expression
  "Test expression checking in DEFRULE."
  (macrolet ((is-invalid-expr (expression)
               `(signals invalid-expression-error
                  (defrule foo ,expression))))
    (is-invalid-expr (~ 1))
    (is-invalid-expr (string))
    (is-invalid-expr (character-ranges 1))
    (is-invalid-expr (character-ranges (#\a)))
    (is-invalid-expr (character-ranges (#\a #\b #\c)))
    (is-invalid-expr (and (string)))
    (is-invalid-expr (not))
    (is-invalid-expr (foo))
    (is-invalid-expr (function))
    (is-invalid-expr (function foo bar))
    (is-invalid-expr (function 1))
    (is-invalid-expr (function (lambda (x) x)))
    (is-invalid-expr (< #\a))
    (is-invalid-expr (< 0 #\a))
    (is-invalid-expr (< -1 #\a))
    (is-invalid-expr (< 1 (string)))
    (is-invalid-expr (> #\a))
    (is-invalid-expr (> 0 #\a))
    (is-invalid-expr (> -1 #\a))
    (is-invalid-expr (> 1 (string)))))

(test defrule.ignore-declarations
  "Test ignore declarations generated by DEFRULE."
  (macrolet ((does-not-warn (condition-class &body body)
               `(finishes
                 (handler-case (compile nil '(lambda () ,@body))
                   (,condition-class (condition)
                     (fail "Signaled an unexpected warning: ~A." condition))))))
    (does-not-warn style-warning
      (defrule foo (and)
        (:function second)
        (:lambda (x) (declare (ignore x)))))
    (does-not-warn style-warning
      (defrule foo (and)
        (:lambda (x &bounds start end)
          (declare (ignore start))
          (values x end))))))

(test defrule.style-warnings
  "Test signaling of style-warnings from DEFRULE."
  (macrolet ((signals-style-warning (expression)
               `(signals style-warning
                  (defrule foo ,expression))))
    ;; Function terminal.
    (signals-style-warning (function no-such-function))
    (signals-style-warning (function cond))
    ;; Semantic predicate
    (signals-style-warning (no-such-function #\a))
    (signals-style-warning (cond #\a))))

(test defrule.errors
  "Test signaling of errors for DEFRULE syntax errors."
  (flet ((test-case (form &optional expected-report)
           (signals error (macroexpand form))
           (when expected-report
             (handler-case (macroexpand form)
               (error (condition)
                 (is (search expected-report
                             (princ-to-string condition))))))))
    (test-case '(defrule multiple-guards "foo"
                  (:when foo)
                  (:when bar)))
    (test-case '(defrule multiple-expressions-in-when "foo"
                  (:when foo bar)))

    (test-case '(defrule lambda-lambda-list "foo"
                 (:lambda (a b))))
    (test-case '(defrule lambda-lambda-list "foo"
                 (:lambda (&optional a b))))
    (test-case '(defrule lambda-lambda-list "foo"
                 (:lambda (&rest a))))
    (test-case '(defrule lambda-lambda-list "foo"
                 (:lambda (&key a))))
    (test-case '(defrule lambda-lambda-list "foo"
                 (:lambda (&key &allow-other-keys))))
    (test-case '(defrule lambda-lambda-list "foo"
                 (:lambda (&bounds)))
               "Expected &BOUNDS START END")
    (test-case '(defrule lambda-lambda-list "foo"
                 (:lambda (&bounds a b c)))
               "Expected &BOUNDS START END")

    (test-case '(defrule destructure-lambda-list "foo"
                 (:destructure (&bounds)))
               "Expected &BOUNDS START END")
    (test-case '(defrule destructure-lambda-list "foo"
                 (:destructure (&bounds a b c)))
               "Expected &BOUNDS START END")

    (test-case '(defrule around-lambda-list "foo"
                 (:around (a))))
    (test-case '(defrule around-lambda-list "foo"
                 (:around (&optional a))))
    (test-case '(defrule around-lambda-list "foo"
                 (:around (&rest a))))
    (test-case '(defrule around-lambda-list "foo"
                 (:around (&key a))))
    (test-case '(defrule around-lambda-list "foo"
                 (:around (&key &allow-other-keys))))
    (test-case '(defrule around-lambda-list "foo"
                 (:around (&bounds)))
               "Expected &BOUNDS START END")
    (test-case '(defrule around-lambda-list "foo"
                 (:around (&bounds a b c)))
               "Expected &BOUNDS START END")

    (test-case '(defrule error-report.invalid "foo"
                 (:error-report "invalid")))
    (test-case '(defrule error-report.repeated "foo"
                  (:error-report nil)
                  (:error-report t)))

    (test-case '(defrule use-cache.invalid "foo"
                  (:use-cache 5)))
    (test-case '(defrule use-cache.repeated "foo"
                  (:use-cache nil)
                  (:use-cache t)))))

;;; A few semantic predicates

(defun not-doublequote (char)
  (not (eql #\" char)))

(defun not-digit (char)
  (when (find-if-not #'digit-char-p char)
    t))

(defun not-newline (char)
  (not (eql #\newline char)))

(defun not-space (char)
  (not (eql #\space char)))

(defun even-length-p (productions)
  (evenp (length productions)))

(defrule oddity
    (and #\a (or #\c (even-length-p (+ oddity))) #\b))

;;; Utility rules

(defrule beginning-of-input
    (! (< 1 character))
  (:constant :beginning-of-input))

(defrule whitespace (+ (or #\space #\tab #\newline))
  (:text t)
  (:error-report nil))

(defrule empty-line #\newline
  (:constant ""))

(defrule non-empty-line (and (+ (not-newline character)) (? #\newline))
  (:destructure (text newline)
    (declare (ignore newline))
    (text text)))

(defrule line (or empty-line non-empty-line)
  (:identity t))

(defrule trimmed-line line
  (:lambda (line)
    (string-trim '(#\space #\tab) line)))

(defrule trimmed-lines (* trimmed-line)
  (:identity t))

(defrule digits (+ (digit-char-p character))
  (:text t))

(defrule integer (and (? whitespace)
                      digits
                      (and (? whitespace) (or (& #\,) (! character))))
  (:function second)
  (:function parse-integer))

(defrule list-of-integers (+ (or (and integer #\, list-of-integers)
                                 integer))
  (:destructure (match)
    (if (integerp match)
        (list match)
        (destructuring-bind (int comma list) match
          (declare (ignore comma))
          (cons int list)))))

(defrule detail.1
    (and "d1" " " "detail" whitespace)
  (:error-report :detail))

(defrule detail.2
    (and "d2" " " "detail" whitespace)
  (:error-report nil))

(defrule context.1
    (and "context" " " (or (and "d3" " " "detail") detail.1))
  (:error-report :context))

(defrule error-report
    (or detail.1 detail.2 (and "d4" " " "detail") context.1))

(test-both-modes parse.smoke
  (macrolet
      ((test-case (expected rule text &rest args)
         `(is (equal '(,@expected)
                     (multiple-value-list (parse ,rule ,text ,@args))))))

    (test-case (("1," "2," "" "3," "4.") nil t)
               'trimmed-lines "1,
                               2,

                               3,
                               4.")
    (test-case (123 nil t) 'integer "  123")
    (test-case (123 nil t) 'integer "  123  ")
    (test-case (123 nil t) 'integer "123  ")
    (test-case ((123 45 6789 0) nil t)
               'list-of-integers "123, 45  ,   6789, 0")
    (test-case ((123 45 6789 0) nil t)
               'list-of-integers "  123 ,45,6789, 0  ")

    ;; Ensure that parsing with :junk-allowed returns the correct
    ;; position.
    (test-case (nil 1) 'list-of-integers " a"
               :start 1 :junk-allowed t)

    ;; Test successful parse that does not consume input. This case
    ;; can only be detected by examining the third return value.
    (test-case (nil 1 t) '(? list-of-integers) " a"
               :start 1 :junk-allowed t)

    ;; Handling of :raw (by the compiler-macro).
    (test-case (123 nil t) 'integer "123" :raw nil)
    (is (typep (parse 'integer "123" :raw t) 'esrap::successful-parse))
    (is (typep (parse 'integer "12a" :raw t) 'esrap::error-result))))

(defrule single-token/bounds.1 (+ (not-space character))
  (:lambda (result &bounds start end)
    (format nil "~A[~S-~S]" (text result) start end)))

(defrule single-token/bounds.2 (and (not-space character) (* (not-space character)))
  (:destructure (first &rest rest &bounds start end)
    (format nil "~C~A(~S-~S)" first (text rest) start end)))

(defrule tokens/bounds.1 (and (? whitespace)
                              (or (and single-token/bounds.1 whitespace tokens/bounds.1)
                                  single-token/bounds.1))
  (:destructure (whitespace match)
    (declare (ignore whitespace))
    (if (stringp match)
        (list match)
        (destructuring-bind (token whitespace list) match
          (declare (ignore whitespace))
          (cons token list)))))

(defrule tokens/bounds.2 (and (? whitespace)
                              (or (and single-token/bounds.2 whitespace tokens/bounds.2)
                                  single-token/bounds.2))
  (:destructure (whitespace match)
    (declare (ignore whitespace))
    (if (stringp match)
        (list match)
        (destructuring-bind (token whitespace list) match
          (declare (ignore whitespace))
          (cons token list)))))

(test-both-modes bounds.1
  (is (equal '("foo[0-3]")
             (parse 'tokens/bounds.1 "foo")))
  (is (equal '("foo[0-3]" "bar[4-7]" "quux[11-15]")
             (parse 'tokens/bounds.1 "foo bar    quux"))))

(test-both-modes bounds.2
  (is (equal '("foo(0-3)")
             (parse 'tokens/bounds.2 "foo")))
  (is (equal '("foo(0-3)" "bar(4-7)" "quux(11-15)")
             (parse 'tokens/bounds.2 "foo bar    quux"))))

;;; Look{ahead, behind}

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun make-look*-test (expression input expected-production expected-position
                          successp)
    `(is (equal '(,expected-production ,expected-position ,@(when successp '(t)))
                (multiple-value-list
                 (parse ',expression ,input :junk-allowed t))))))

(test-both-modes lookahead.smoke
  "Smoke test for lookahead expressions."
  (macrolet
      ((test-case (expression input expected-production expected-position
                   &optional (successp t))
         (make-look*-test
          expression input expected-production expected-position successp)))

    ;; End of input.
    (test-case (! (> 3 character))               "abc" nil           0)
    ;; Some simple cases.
    (test-case (> 1 #\b)                         "abc" "b"           0)
    (test-case (> 2 #\c)                         "abc" "c"           0)
    (test-case (> 3 #\d)                         "abc" nil           0 nil)
    (test-case (> 3 (! character))               "abc" nil           0)
    (test-case (> 4 (! character))               "abc" nil           0 nil)
    ;; Make sure we can parse something before and after the
    ;; lookahead.
    (test-case (and #\a (> 1 #\c) #\b)           "abc" ("a" "c" "b") 2)
    (test-case (and #\a (> 2 #\d) #\b)           "abc" nil           0 nil)
    (test-case (and #\a (> 2 (! character)) #\b) "abc" ("a" nil "b") 2)))

(test-both-modes lookbehind.smoke
  "Smoke test for lookbehind expressions."
  (macrolet
      ((test-case (expression input expected-production expected-position
                   &optional (successp t))
         (make-look*-test
          expression input expected-production expected-position successp)))

    ;; Beginning of input
    (test-case (! (< 1 character))   "abc" nil         0)
    ;; Parse some stuff, so we can go back with the lookbehind.
    (test-case (and "abc" (< 1 #\d)) "abc" nil         0 nil)
    (test-case (and "abc" (< 1 #\c)) "abc" ("abc" "c") nil)
    (test-case (and "abc" (< 2 #\b)) "abc" ("abc" "b") nil)
    (test-case (and "abc" (< 3 #\a)) "abc" ("abc" "a") nil)
    (test-case (and "abc" (< 4 #\a)) "abc" nil         0 nil)
    ;; Lookbehind at the beginning of the input.
    (test-case (< 1 #\a)             "abc" nil         0 nil)))

;;; Function terminals

(defun parse-integer1 (text position end)
  (parse-integer text :start position :end end :junk-allowed t))

(defrule function-terminals.integer #'parse-integer1)

(test-both-modes function-terminals.parse-integer
  "Test using the function PARSE-INTEGER1 as a terminal."
  (macrolet ((test-case (input expected
                         &optional
                         (expression ''function-terminals.integer))
               `(is (equal ,expected (parse ,expression ,input)))))
    (test-case "1"  1)
    (test-case " 1" 1)
    (test-case "-1" -1)
    (test-case "-1" '(-1 nil)
               '(and (? function-terminals.integer) (* character)))
    (test-case "a"  '(nil (#\a))
               '(and (? function-terminals.integer) (* character)))))

(defun parse-5-as (text position end)
  (let ((chars  '())
        (amount 0))
    (dotimes (i 5)
      (let ((char (when (< (+ position i) end)
                    (aref text (+ position i)))))
        (unless (eql char #\a)
          (return-from parse-5-as
            (values nil (+ position i) "Expected \"a\".")))
        (push char chars)
        (incf amount)))
    (values (nreverse chars) (+ position amount))))

(defrule function-terminals.parse-5-as #'parse-5-as)

(test-both-modes function-terminals.parse-5-as.smoke
  "Test using PARSE-A as a terminal."
  (macrolet ((test-case (input expected
                         &optional (expression ''function-terminals.parse-5-as))
               `(is (equal ,expected (parse ,expression ,input)))))
    (test-case "aaaaa" '(#\a #\a #\a #\a #\a))
    (test-case "b" '(nil "b") '(and (? function-terminals.parse-5-as) #\b))
    (test-case "aaaaab" '((#\a #\a #\a #\a #\a) "b")
               '(and (? function-terminals.parse-5-as) #\b))))

(test-both-modes function-terminals.parse-5-as.condition
  "Test using PARSE-A as a terminal."
  (handler-case
      (parse 'function-terminals.parse-5-as "aaaab")
    (esrap-parse-error (condition)
      (is (eql 4 (esrap-error-position condition)))
      (is (search "Expected \"a\"." (princ-to-string condition))))))

(defun function-terminals.nested-parse (text position end)
  (parse '(and #\d function-terminals.nested-parse)
         text :start position :end end :junk-allowed t))

(defrule function-terminals.nested-parse
    (or (and #'function-terminals.nested-parse #\a)
        (and #\b #'function-terminals.nested-parse)
        #\c))

(test-both-modes function-terminals.nested-parse
  "Test a function terminal which itself calls PARSE."
  (is (equal '("b" ("d" (("d" "c") "a")))
             (parse 'function-terminals.nested-parse "bddca"))))

(test-both-modes function-terminals.nested-parse.condition
  "Test propagation of failure information through function terminals."
  (signals esrap-parse-error (parse 'function-terminals.nested-parse "bddxa")))

(defun function-terminals.without-consuming (text position end)
  (declare (ignore end))
  (if (char= (aref text position) #\a)
      (values :ok position t)
      (values nil position "\"a\" expected")))

(test-both-modes function-terminals.without-consuming
  "Test that function terminals can succeed without consuming input."
  (is (equal '((:ok "a") nil t)
             (multiple-value-list
              (parse '(and #'function-terminals.without-consuming #\a) "a"))))

  (is (equal '(((:ok "a" :ok) (:ok "a" :ok)) 2 t)
             (multiple-value-list
              (parse '(+ (and #'function-terminals.without-consuming #\a
                              #'function-terminals.without-consuming))
                     "aaab" :junk-allowed t)))))

;;; Left recursion tests

(defun make-input-and-expected-result (size)
  (labels ((make-expected (size)
             (if (plusp size)
                 (list (make-expected (1- size)) "l")
                 "r")))
    (let ((expected (make-expected size)))
      (values (apply #'concatenate 'string (flatten expected)) expected))))

(defrule left-recursion.direct
    (or (and left-recursion.direct #\l) #\r))

(test-both-modes left-recursion.direct.success
  "Test parsing with one left recursive rule for different inputs."
  (dotimes (i 20)
    (multiple-value-bind (input expected)
        (make-input-and-expected-result i)
      (is (equal expected (parse 'left-recursion.direct input))))))

(test-both-modes left-recursion.direct.condition
  "Test signaling of `left-recursion' condition if requested."
  (let ((*on-left-recursion* :error))
    (signals (left-recursion)
      (parse 'left-recursion.direct "l"))
    (handler-case (parse 'left-recursion.direct "l")
      (left-recursion (condition)
        (is (string= "l" (esrap-error-text condition)))
        (is (= 0 (esrap-error-position condition)))
        (is (eq 'left-recursion.direct
                (left-recursion-nonterminal condition)))
        (is (equal '(left-recursion.direct
                     left-recursion.direct)
                   (left-recursion-path condition)))))))

(defrule left-recursion.indirect.1 left-recursion.indirect.2)

(defrule left-recursion.indirect.2 (or (and left-recursion.indirect.1 "l") "r"))

(test-both-modes left-recursion.indirect.success
  "Test parsing with mutually left recursive rules for different
   inputs."
  (dotimes (i 20)
    (multiple-value-bind (input expected)
        (make-input-and-expected-result i)
      (is (equal expected (parse 'left-recursion.indirect.1 input)))
      (is (equal expected (parse 'left-recursion.indirect.2 input))))))

(test-both-modes left-recursion.indirect.condition
  "Test signaling of `left-recursion' condition if requested."
  (let ((*on-left-recursion* :error))
    (signals (left-recursion)
      (parse 'left-recursion.indirect.1 "l"))
    (handler-case (parse 'left-recursion.indirect.1 "l")
      (left-recursion (condition)
        (is (string= "l" (esrap-error-text condition)))
        (is (= 0 (esrap-error-position condition)))
        (is (eq 'left-recursion.indirect.1
                (left-recursion-nonterminal condition)))
        (is (equal '(left-recursion.indirect.1
                     left-recursion.indirect.2
                     left-recursion.indirect.1)
                   (left-recursion-path condition)))))))

;;; Test conditions

(declaim (special *active*))

(defvar *active* nil)

(defrule condition.maybe-active "foo"
  (:when *active*))

(defrule condition.always-active "foo"
  (:when t))

(defrule condition.never-active "foo"
  (:when nil))

(test-both-modes condition.maybe-active
  "Rule not active at toplevel."
  (flet ((do-it () (parse 'condition.maybe-active "foo"))) ; TODO avoid redundancy
    (signals esrap-parse-error (do-it))
    (handler-case (do-it)
      (esrap-parse-error (condition)
        (search "Rule CONDITION.MAYBE-ACTIVE not active"
                (princ-to-string condition)))))

  (finishes (let ((*active* t))
              (parse 'condition.maybe-active "foo")))

  (finishes (parse 'condition.always-active "foo"))

  (flet ((do-it () (parse 'condition.never-active "foo")))
    (signals esrap-parse-error (do-it))
    (handler-case (do-it)
      (esrap-parse-error (condition)
        (search "Rule CONDITION.NEVER-ACTIVE not active"
                (princ-to-string condition))))))

(defrule condition.undefined-dependency
    (and "foo" no-such-rule))

(test-both-modes condition.undefined-rules
  "Test handling of undefined rules."
  (signals undefined-rule-error
    (parse 'no-such-rule "foo"))
  (signals undefined-rule-error
    (parse 'condition.undefined-dependency "foo")))

(test condition.invalid-argument-combinations
  "Test handling of invalid PARSE argument combinations."
  ;; Prevent the compiler-macro form recognizing the invalid argument
  ;; combination at compile-time.
  (locally (declare (notinline parse))
    (signals error (parse 'integer "1" :junk-allowed t :raw t)))
  ;; Compiler-macro should recognize the invalid argument combination
  ;; at compile-time. Relies on the implementation detecting invalid
  ;; keyword arguments at compile-time.
  (signals warning
    (with-silent-compilation-unit ()
      (compile nil '(lambda ()
                      (parse 'integer "1" :junk-allowed t :raw t))))))

(test-both-modes condition.misc
  "Test signaling of `esrap-parse-error' conditions for failed
   parses."
  ;; Rule does not allow empty string.
  (signals-esrap-error ("" esrap-parse-error 0
                           ("At end of input"
                            "^ (Line 1, Column 0, Position 0)"
                            "In context DIGITS:"
                            "While parsing DIGITS." "Expected"
                            "any character satisfying DIGIT-CHAR-P"))
    (parse 'integer ""))

  ;; Junk at end of input.
  (signals-esrap-error ("123foo" esrap-parse-error 3
                                 ("At" "^ (Line 1, Column 3, Position 3)"
                                  "In context INTEGER:"
                                  "While parsing INTEGER."
                                  "The production" "#\\f"
                                  "does not satisfy the predicate DIGIT-CHAR-P"
                                  "Expected"
                                  "any character satisfying DIGIT-CHAR-P"
                                  "or <end of input>"))
    (parse 'integer "123foo"))
  (signals-esrap-error ("a" esrap-parse-error 0
                            ("At" "^ (Line 1, Column 0, Position 0)"
                             "In context (STRING 0):"
                             "While parsing (STRING 0)." "Expected"
                             "<end of input>"))
    (parse '(string 0) "a"))

  ;; Whitespace not allowed.
  (signals-esrap-error ("1, " esrap-parse-error 3
                              ("At" "^ (Line 1, Column 3, Position 3)"
                               "In context DIGITS:"
                               "While parsing DIGITS." "Expected"
                               "any character satisfying DIGIT-CHAR-P"))
    (parse 'list-of-integers "1, "))

  ;; Multi-line input.
  (signals-esrap-error ("1,
2, " esrap-parse-error 6 ("At" "1," "^ (Line 2, Column 3, Position 6)"
                          "In context DIGITS:"
                          "While parsing DIGITS." "Expected"
                          "any character satisfying DIGIT-CHAR-P"))
    (parse 'list-of-integers "1,
2, "))

  ;; Rule not active at toplevel.
  (signals-esrap-error ("foo" esrap-parse-error 0
                              ("At" "^ (Line 1, Column 0, Position 0)"
                               "In context CONDITION.NEVER-ACTIVE:"
                               "While parsing CONDITION.NEVER-ACTIVE."
                               "Problem"
                               "Rule ESRAP-TESTS::CONDITION.NEVER-ACTIVE is not active"))
    (parse 'condition.never-active "foo"))

  ;; Rule not active at subexpression-level.
  (signals-esrap-error ("ffoo" esrap-parse-error 1
                               ("At" "^ (Line 1, Column 1, Position 1)"
                                "In context (AND \"f\" CONDITION.NEVER-ACTIVE):"
                                "While parsing (AND \"f\" CONDITION.NEVER-ACTIVE). Expected:"))
    (parse '(and "f" condition.never-active) "ffoo"))

  ;; Failing function terminal.
  (signals-esrap-error ("(1 2" esrap-parse-error 0
                               ("At" "^ (Line 1, Column 0, Position 0)"
                                "In context FUNCTION-TERMINALS.INTEGER:"
                                "While parsing FUNCTION-TERMINALS.INTEGER."
                                "Expected:"
                                "a string that can be parsed by the function"))
    (parse 'function-terminals.integer "(1 2"))

  ;; Failing nested semantic predicates.
  (signals-esrap-error ("aacbb" esrap-parse-error 1
                               ("At" "^ (Line 1, Column 1, Position 1)"
                                "In context ODDITY:"
                                "While parsing ODDITY."
                                "The production" "((\"a\" \"c\" \"b\"))"
                                "does not satisfy the predicate" "EVEN-LENGTH-P"
                                "Expected:"
                                "the character a"))
    (parse 'oddity "aacbb"))
  (signals-esrap-error ("aaacbbb" esrap-parse-error 2
                               ("At" "^ (Line 1, Column 2, Position 2)"
                                "In context ODDITY:"
                                "While parsing ODDITY."
                                "The production" "((\"a\" \"c\" \"b\"))"
                                "does not satisfy the predicate" "EVEN-LENGTH-P"
                                "Expected:"
                                "the character a"))
    (parse 'oddity "aaacbbb"))

  ;; Failing look{ahead,behind}.
  (signals-esrap-error ("abc" esrap-parse-error 2
                              ("At" "^ (Line 1, Column 2, Position 2)"
                               "In context (< 2 \"bbc\"):"
                               "While parsing (< 2 \"bbc\")"
                               "Expected:"
                               "the string \"bbc\""
                               "2 characters before the current position"))
    (parse '(and "ab" (< 2 "bbc") "c") "abc"))
  (signals-esrap-error ("abcd" esrap-parse-error 1
                               ("At" "^ (Line 1, Column 1, Position 1)"
                                "In context (> 1 \"bb\"):"
                                "While parsing (> 1 \"bb\")"
                                "Expected:"
                                "the string \"bb\""
                                "1 character after the current position"))
    (parse '(and "a" (> 1 "bb") "bcd") "abcd")))

(test-both-modes condition.error-report
  "Test effect of the :ERROR-REPORT option on parse error reports."
  (signals-esrap-error ("foo" esrap-parse-error 0
                        ("At" "^ (Line 1, Column 0, Position 0)"
                         "In context ERROR-REPORT"
                         "While parsing ERROR-REPORT"
                         "Expected:"
                         "the string \"d1\""
                         "or the string \"d4\""))
    (parse 'error-report "foo"))

  (signals-esrap-error ("d1" esrap-parse-error 2
                        ("At" "^ (Line 1, Column 2, Position 2)"
                         "In context ERROR-REPORT"
                         "While parsing DETAIL.1"
                         "Expected:" "the character Space"))
    (parse 'error-report "d1"))

  (signals-esrap-error ("context" esrap-parse-error 7
                        ("At" "^ (Line 1, Column 7, Position 7)"
                         "In context CONTEXT.1"
                         "While parsing CONTEXT.1"))
    (parse 'error-report "context"))

  (signals-esrap-error ("context d1 foo" esrap-parse-error 8
                        ("At" "^ (Line 1, Column 8, Position 8)"
                         "In context CONTEXT.1"
                         "While parsing CONTEXT.1"))
    (parse 'error-report "context d1 foo"))

  (signals-esrap-error ("context d3 foo" esrap-parse-error 8
                        ("At" "^ (Line 1, Column 8, Position 8)"
                         "In context CONTEXT.1"
                         "While parsing CONTEXT.1"))
    (parse 'error-report "context d3 foo")))

(test-both-modes parse.string
  "Test parsing an arbitrary string of a given length."
  (is (equal "" (parse '(string 0) "")))
  (is (equal "aa" (parse '(string 2) "aa")))
  (signals esrap-parse-error (parse '(string 0) "a"))
  (signals esrap-parse-error (parse '(string 2) "a"))
  (signals esrap-parse-error (parse '(string 2) "aaa")))

(defmacro times-2 (form)
  (destructuring-bind (first second third) form
    (let ((expr (second second)))
      `(,first '(and ,expr ,expr) ,third))))

(defmacro times-4 (form)
  (destructuring-bind (first second third) form
    (let ((expr (second second)))
      `(,first '(and ,expr ,expr ,expr ,expr) ,third))))

(test-both-modes parse.case-insensitive
  "Test parsing character and string constants in case-insensitive
   mode."
  ;; The TIMES-{2,4} macros and (and #\c) variants prevent the
  ;; ordered-choise and greedy-repetition optimizations from being
  ;; used.
  ;;
  ;; To further complicate things, TIMES-{2,4} cannot be lexical
  ;; macros as that would prevent application of the `parse'
  ;; compiler-macro.
  (dolist (input '("aabb" "AABB" "aAbB" "aaBB" "AAbb"))
    (unless (every #'lower-case-p input)
      (signals esrap-parse-error (times-4 (parse '(or #\a #\b) input)))
      (signals esrap-parse-error (times-4 (parse '(or #\a #\b (and #\c)) input)))
      (signals esrap-parse-error (times-2 (parse '(or "aa" "bb") input)))
      (signals esrap-parse-error (times-2 (parse '(or "aa" "bb" (and #\c)) input))))
    (is (equal "aabb" (text (times-2 (parse '(or (~ "aa") (~ "bb"))           input)))))
    (is (equal "aabb" (text (times-2 (parse '(or (~ "aa") (~ "bb") (and #\c)) input)))))
    (is (equal "aabb" (text (times-2 (parse '(or (~ "aa") (~ "bb"))           input)))))
    (is (equal "aabb" (text (times-2 (parse '(or (~ "aa") (~ "bb") (and #\c)) input)))))
    (is (equal "aabb" (text (times-4 (parse '(or (~ #\a) (~ #\b))             input)))))
    (is (equal "aabb" (text (times-4 (parse '(or (~ #\a) (~ #\b) (and #\c))   input)))))
    (is (equal "AABB" (text (times-4 (parse '(or (~ #\A) (~ #\B))             input)))))
    (is (equal "AABB" (text (times-4 (parse '(or (~ #\A) (~ #\B) (and #\c))   input)))))
    (is (equal "aaBB" (text (times-4 (parse '(or (~ #\a) (~ #\B))             input)))))
    (is (equal "aaBB" (text (times-4 (parse '(or (~ #\a) (~ #\B) (and #\c))   input)))))))

(test-both-modes parse.negation
  "Test negation in rules."
  (macrolet ((test-case (expected expression input)
               `(is (equal ,expected (text (parse ,expression ,input
                                                  :junk-allowed t))))))
    (test-case "F"      '(not "Baz")                "FooBazBar")
    (test-case "Foo"    '(+ (not "Baz"))            "FooBazBar")
    (test-case "FooBaz" '(+ (not "Bar"))            "FooBazBar")
    (test-case "Foo"    '(+ (not (or "Bar" "Baz"))) "FooBazBar")))

(test-both-modes parse.compiler-macro
  "Test `parse' compiler-macro."
  ;; Make sure the `parse' compiler-macro applies `constantp'
  ;; correctly.
  (macrolet ((times-2 (expr)
               `'(and ,expr ,expr)))
    (is (equal '("a" "a") (parse (times-2 #\a) "aa")))))

;;; Test around

(defvar *around.depth* nil)

(defrule around/inner
    (+ (alpha-char-p character))
  (:text t))

(defrule around.1
    (or around/inner (and #\{ around.1 #\}))
  (:lambda (thing)
    (if (stringp thing)
        (cons *around.depth* thing)
        (second thing)))
  (:around ()
    (let ((*around.depth*
           (if *around.depth*
               (cons (1+ (first *around.depth*)) *around.depth*)
               (list 0))))
      (call-transform))))

(defrule around.2
    (or around/inner (and #\{ around.2 #\}))
  (:lambda (thing)
    (if (stringp thing)
        (cons *around.depth* thing)
        (second thing)))
  (:around (&bounds start end)
    (let ((*around.depth*
           (if *around.depth*
               (cons (cons (1+ (car (first *around.depth*))) (cons start end))
                     *around.depth*)
               (list (cons 0 (cons start end))))))
      (call-transform))))

(test-both-modes around.1
  "Test executing code around the transform of a rule."
  (macrolet ((test-case (input expected)
               `(is (equal ,expected (parse 'around.1 ,input)))))
    (test-case "foo"     '((0) . "foo"))
    (test-case "{bar}"   '((1 0) . "bar"))
    (test-case "{{baz}}" '((2 1 0) . "baz"))))

(test-both-modes around.2
  "Test executing code around the transform of a rule."
  (macrolet ((test-case (input expected)
               `(is (equal ,expected (parse 'around.2 ,input)))))
    (test-case "foo"     '(((0 . (0 . 3)))
                           . "foo"))
    (test-case "{bar}"   '(((1 . (1 . 4))
                            (0 . (0 . 5)))
                           . "bar"))
    (test-case "{{baz}}" '(((2 . (2 . 5))
                            (1 . (1 . 6))
                            (0 . (0 . 7)))
                           . "baz"))))

;;; Test character ranges

(defrule character-range (character-ranges (#\a #\b) #\-))

(test-both-modes character-range
  (macrolet ((test-case (expected expression input)
               `(is (equal ,expected (parse ,expression ,input
                                            :junk-allowed t)))))
    (test-case #\a            '(character-ranges (#\a #\z) #\-)     "a")
    (test-case '(#\a #\b)     '(* (character-ranges (#\a #\z) #\-)) "ab")
    (test-case '(#\a #\b)     '(* (character-ranges (#\a #\z) #\-)) "ab1")
    (test-case '(#\a #\b #\-) '(* (character-ranges (#\a #\z) #\-)) "ab-")
    (test-case nil            '(* (character-ranges (#\a #\z) #\-)) "AB-")
    (test-case nil            '(* (character-ranges (#\a #\z) #\-)) "ZY-")
    (test-case '(#\a #\b #\-) '(* character-range)                  "ab-cd")))

;;; Test multiple transforms

(defrule multiple-transforms.1
    (and #\a #\1 #\c)
  (:function second)
  (:text t)
  (:function parse-integer))

(defrule multiple-transforms.2
    #\1
  (:text t)
  (:function parse-integer)
  (:function 1+)
  (:lambda (x &bounds start end)
    (list x start end)))

(defrule multiple-transforms.3
    #\1
  (:text t)
  (:lambda (x &bounds start)
    (list (parse-integer x) start)))

(test-both-modes multiple-transforms
  "Apply composed transforms to parse result."
  (is (eql 1 (parse 'multiple-transforms.1 "a1c")))
  (is (equal '(2 0 1) (parse 'multiple-transforms.2 "1")))
  (is (equal '(1 0) (parse 'multiple-transforms.3 "1"))))

;;; Test uncached rules

(defrule uncached.1
    #\a
  (:use-cache nil))

(defrule uncached.2
    #\b
  (:use-cache t))

(defrule uncached.3
    #\c
  (:use-cache :unless-trivial))

(defrule uncached
    (and (+ uncached.1) (+ uncached.2) (+ uncached.3)))

(test-both-modes uncached
  "Test uncached rules."
  (flet ((test-case (input expected)
           (is (equal expected (parse 'uncached input)))))
    (test-case "abc"    '(("a")     ("b")     ("c")))
    (test-case "aabc"   '(("a" "a") ("b")     ("c")))
    (test-case "abbc"   '(("a")     ("b" "b") ("c")))
    (test-case "abcc"   '(("a")     ("b")     ("c" "c")))
    (test-case "aabbcc" '(("a" "a") ("b" "b") ("c" "c")))))

;;; Test rule introspection

(defrule expression-start-terminals.1
    (or expression-start-terminals.2 #\a))

(defrule expression-start-terminals.2
    (or #\c (and (? #\b) expression-start-terminals.1)))

(test expression-start-terminals.smoke
  (macrolet
      ((test-case (expression expected)
         `(is (equal ',expected (expression-start-terminals ,expression)))))
    (test-case '(and)                              ())
    (test-case '(or)                               ())
    (test-case 'character                          (character))
    (test-case '(string 5)                         ((string 5)))
    (test-case #\A                                 (#\A))
    (test-case '(or #\B #\A)                       (#\A #\B))
    (test-case '(or character #\A)                 (#\A character))
    (test-case '(or #\A "foo")                     ("foo" #\A))
    (test-case "foo"                               ("foo"))
    (test-case '(or "foo" "bar")                   ("bar" "foo"))
    (test-case '(character-ranges (#\a #\z))       ((character-ranges (#\a #\z))))
    (test-case '(~ "foo")                          ((~ "foo")))
    (test-case '#'parse-integer                    (#'parse-integer))
    (test-case '(digit-char-p (and))               ())
    (test-case '(digit-char-p character)           ((digit-char-p (character))))
    (test-case '(or (digit-char-p character) #\a)  (#\a (digit-char-p (character))))
    (test-case 'expression-start-terminals.1       (#\a #\b #\c))
    (test-case 'expression-start-terminals.2       (#\a #\b #\c))
    (test-case 'left-recursion.direct              (#\l #\r))
    (test-case '(or #\b #\a)                       (#\a #\b))
    (test-case '(and #\a #\b)                      (#\a))
    (test-case '(and (or #\a #\b) #\c)             (#\a #\b))
    (test-case '(and (? #\a) #\b)                  (#\a #\b))
    (test-case '(and (? #\a) (? #\b) (or #\d #\c)) (#\a #\b #\c #\d))
    (test-case '(and (and) #\a)                    (#\a))
    (test-case '(not (or #\a #\b))                 ((not (#\a #\b))))
    (test-case '(not character)                    ((not (character))))
    (test-case '(! (or #\a #\b))                   ((! (#\a #\b))))
    (test-case '(! character)                      ((! (character))))
    (test-case '(& #\a)                            (#\a))
    (test-case '(* #\a)                            (#\a))
    (test-case '(+ #\a)                            (#\a))
    (test-case '(< 1 #\a)                          ((< 1 (#\a))))
    (test-case '(> 1 #\a)                          ((> 1 (#\a))))
    (test-case '(> 2 (or #\a #\b))                 ((> 2 (#\a #\b))))))

(test describe-terminal.smoke
  (flet ((describe-it (terminal)
           (with-output-to-string (stream)
             (with-standard-io-syntax
               (let ((*print-pretty* t))
                 (pprint-logical-block (stream nil)
                   (describe-terminal terminal stream)))))))
    (macrolet
        ((test-case (terminal expected)
           `(is (string= ,expected (describe-it ,terminal)))))
      (test-case 'character  "any character")
      (test-case '(string 5) "a string of length 5")
      (test-case #\a         (format nil "the character a~@[ (~A)~]"
                                     (char-name #\a)))
      (test-case #\Space     "the character Space")
      (test-case '(~ #\a)    (format nil "the character a~@[ (~A)~], disregarding case"
                                     (char-name #\a)))
      (test-case "f"         (format nil "the character f~@[ (~A)~]"
                                     (char-name #\f)))
      (test-case "foo"       "the string \"foo\"")
      (test-case '(~ "foo")  "the string \"foo\", disregarding case")
      (test-case '(character-ranges #\a)
                 "a character in [a]")
      (test-case '(character-ranges (#\a #\z))
                 "a character in [a-z]")
      (test-case '#'parse-integer
                 "a string that can be parsed by the function PARSE-INTEGER")
      (test-case '(digit-char-p (character))
                 "any character satisfying DIGIT-CHAR-P")
      (test-case '(digit-char-p ((~ "foo")))
                 "the string \"foo\", disregarding case satisfying DIGIT-CHAR-P")
      (test-case '(digit-char-p ("aa" "bb"))
                 "    the string \"aa\"
 or the string \"bb\"
satisfying DIGIT-CHAR-P")
      (test-case '(digit-char-p ("aa" "bb" "cc"))
                 "    the string \"aa\"
 or the string \"bb\"
 or the string \"cc\"
satisfying DIGIT-CHAR-P")
      (test-case '(not (#\a #\b))
                 (format nil "anything but     the character a~@[ (~A)~]
             and the character b~@[ (~A)~]"
                         (char-name #\a) (char-name #\b)))
      (test-case '(not (character)) "<end of input>")
      (test-case '(! (#\a #\b))
                 (format nil "anything but     the character a~@[ (~A)~]
             and the character b~@[ (~A)~]"
                         (char-name #\a) (char-name #\b)))
      (test-case '(! ((keyword? (#\_ (alpha-char-p (character))))))
                 (format nil "anything but     the character _~@[ (~A)~]
              or any character satisfying ALPHA-CHAR-P
             satisfying ~A"
                         (char-name #\_) 'keyword?)))))

(test describe-terminal.condition
  (signals error (describe-terminal '(and #\a #\b))))

(defrule describe-grammar.undefined-dependency
    describe-grammar.no-such-rule.1)

(test describe-grammar.smoke
  "Smoke test for DESCRIBE-GRAMMAR."
  (mapc
   (lambda (spec)
     (destructuring-bind (rule &rest expected) spec
       (let ((output (with-output-to-string (stream)
                       (describe-grammar rule stream))))
         (mapc (lambda (expected)
                 (is (search expected output)))
               (ensure-list expected)))))

   '((condition.maybe-active
      "Grammar CONDITION.MAYBE-ACTIVE"
      "MAYBE-ACTIVE" "<-" "\"foo\" : *ACTIVE*")
     (describe-grammar.undefined-dependency
      "Grammar DESCRIBE-GRAMMAR.UNDEFINED-DEPENDENCY"
      "Undefined nonterminal" "DESCRIBE-GRAMMAR.NO-SUCH-RULE.1")
     (describe-grammar.no-such-rule.1
      "Symbol DESCRIBE-GRAMMAR.NO-SUCH-RULE.1 is not a defined nonterminal.")
     (describe-grammar.no-such-rule.2
      "Symbol DESCRIBE-GRAMMAR.NO-SUCH-RULE.2 is not a defined nonterminal.")
     (around.1
      "Grammar AROUND.1"
      "AROUND.1" "<-" ": T" "AROUND/INNER" "<-" ": T")
     (around.2
      "Grammar AROUND.2"
      "AROUND.2" "<-" ": T" "AROUND/INNER" "<-" ": T")
     (character-range
      "Grammar CHARACTER-RANGE"
      "CHARACTER-RANGE" "<-" "(CHARACTER-RANGES (#\\a" ": T")
     (multiple-transforms.1
      "Grammar MULTIPLE-TRANSFORMS.1"
      "MULTIPLE-TRANSFORMS.1" "<-" "(AND #\\a #\\1" ": T")
     (beginning-of-input
      "Grammar BEGINNING-OF-INPUT"
      "BEGINNING-OF-INPUT" "<-" "(! (< 1 CHARACTER))" ": T"))))

;;; Test tracing

(defun parse-with-trace (rule text)
  (with-output-to-string (*trace-output*)
    (parse rule text)))

(test #+TODO -both-modes trace-rule.smoke
  "Smoke test for the rule (un)tracing functionality."
  (labels
      ((test-case (trace-rule trace-args parse-rule text expected)
         ;; No trace output before tracing.
         (is (emptyp (parse-with-trace parse-rule text)))
         ;; Trace output.
         (apply #'trace-rule trace-rule trace-args)
         (is (string= expected (parse-with-trace parse-rule text)))
         ;; Back to no output.
         (apply #'untrace-rule trace-rule trace-args)
         (is (emptyp (parse-with-trace parse-rule text)))))

    ;; Smoke test 1.
    (test-case 'integer '() 'integer "123"
               "1: INTEGER 0[123]?
1: INTEGER 0-3 -> 123
")

    ;; Smoke test 2.
    (test-case 'beginning-of-input '(:recursive t) 'beginning-of-input ""
               "1: BEGINNING-OF-INPUT 0[]?
1: BEGINNING-OF-INPUT 0-0 -> :BEGINNING-OF-INPUT
")

    ;; Smoke test 3.
    (test-case 'integer '(:recursive t) 'integer "12"
               "1: INTEGER 0[12]?
 2: WHITESPACE 0[12]?
 2: WHITESPACE -|
 2: DIGITS 0[12]?
 2: DIGITS 0-2 -> \"12\"
 2: WHITESPACE 2[12]?
 2: WHITESPACE -|
1: INTEGER 0-2 -> 12
")

    ;; Depth-limited recursive tracing.
    (test-case 'list-of-integers '(:recursive 1) 'list-of-integers "12, 13"
               "1: LIST-OF-INTEGERS 0[12,]?
 2: INTEGER 0[12,]?
 2: INTEGER 0-2 -> 12
 2: LIST-OF-INTEGERS 3[2, 13]?
  3: INTEGER 3[2, 13]?
  3: INTEGER 3-6 -> 13
  3: INTEGER 3[2, 13]?
  3: INTEGER 3-6 -> 13
  3: INTEGER 6[13]?
  3: INTEGER -|
  3: INTEGER 6[13]?
  3: INTEGER -|
 2: LIST-OF-INTEGERS 3-6 -> (13)
 2: INTEGER 6[13]?
 2: INTEGER -|
 2: INTEGER 6[13]?
 2: INTEGER -|
1: LIST-OF-INTEGERS 0-6 -> (12 13)
")

    ;; Left-recursive rule - non-recursive tracing.
    (test-case 'left-recursion.direct '()
               'left-recursion.direct "rl"
               "1: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT -|
 2: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT 0-1 -> \"r\"
 2: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT 0-2 -> (\"r\" \"l\")
1: LEFT-RECURSION.DIRECT 0-2 -> (\"r\" \"l\")
")

    ;; Left-recursive rule - recursive tracing.
    (test-case 'left-recursion.direct '(:recursive t)
               'left-recursion.direct "rl"
               "1: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT -|
 2: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT 0-1 -> \"r\"
 2: LEFT-RECURSION.DIRECT 0[rl]?
 2: LEFT-RECURSION.DIRECT 0-2 -> (\"r\" \"l\")
1: LEFT-RECURSION.DIRECT 0-2 -> (\"r\" \"l\")
")

    ;; Conditional tracing.
    (test-case 'digits `(:condition ,(lambda (symbol text position end)
                                       (declare (ignore symbol text end))
                                       (= position 0)))
               'list-of-integers "123, 123"
               "1: DIGITS 0[123]?
1: DIGITS 0-3 -> \"123\"
")))

(test trace-rule.condition
  "Test conditions signaled by the rule (un)tracing functionality."
  ;; It is important for this test that no rule of the given name
  ;; exists - including as undefined dependency of another rule.
  (signals error (trace-rule 'trace-rule.condition.no-such-rule.1))
  (signals error (untrace-rule 'trace-rule.condition.no-such-rule.1)))

(defrule trace-rule.condition.recursive
    (and trace-rule.condition.no-such-rule.2))

(test trace-rule.condition.recursive+undefined-rule
  "Recursively tracing a rule with undefined dependencies should not
   signal an error."
  (finishes
    (trace-rule 'trace-rule.condition.recursive :recursive t)))

(defrule trace-rule.redefinition (and))

(test trace-rule.redefinition
  "Make sure that a traced rule can be redefined. This used to signal
   an error."
  (finishes
    (trace-rule 'trace-rule.redefinition)
    (change-rule 'trace-rule.redefinition '(and))))

(test trace-rule.twice
  "Test tracing an already-traced rule."
  (trace-rule 'integer)
  (trace-rule 'integer)
  (is (string= "1: INTEGER 0[123]?
1: INTEGER 0-3 -> 123
"
               (parse-with-trace 'integer "123")))
  (untrace-rule 'integer))

(test untrace-all-rules.smoke
  "Smoke test for the UNTRACE-ALL-RULES function."
  (trace-rule 'integer)
  (untrace-all-rules)
  (is (emptyp (parse-with-trace 'integer "123"))))
