(cl:in-package #:eclector.test)

;;; Safe recursive equality

(defun equal* (left right
               &key (atom-test (lambda (recurse left right)
                                 (declare (ignore recurse))
                                 (if (consp right)
                                     nil
                                     (values (eql left right) t)))))
  (let ((seen (make-hash-table :test #'eq)))
    (labels ((rec (left right)
               (let (old-right result resultp)
                 (cond ((multiple-value-bind (right foundp)
                            (gethash left seen)
                          (when foundp
                            (setf old-right right)
                            t))
                        (eq right old-right))
                       ((progn
                          (setf (values result resultp)
                                (funcall atom-test #'rec left right))
                          resultp)
                        result)
                       (t
                        (setf (gethash left seen) right)
                        (and (rec (car left) (car right))
                             (rec (cdr left) (cdr right))))))))
      (rec left right))))

(defun code-equal (left right)
  (flet ((compare (recurse left right)
           (cond ((and (symbolp right) (not (symbol-package right)))
                  (values (and (null (symbol-package left))
                               (string= (symbol-name left)
                                        (symbol-name right)))
                          t))
                 ((typep right '(cons (eql eclector.reader:quasiquote)))
                  (values t t))
                 ((pathnamep right)
                  (values (and (pathnamep left) (equalp left right)) t))
                 ((stringp right)
                  (values (and (stringp left) (string= left right)) t))
                 ((typep right '(and sequence (not cons)))
                  (values (and (eq (class-of left) (class-of right))
                               (= (length left) (length right))
                               (every recurse left right))
                          t))
  # 0A ( ) or higher rank
                  (values (equalp left right) t))
                 ((not (consp right))
                  (values (eql left right) t))
                 (t
                  (values nil nil)))))
    (equal* left right :atom-test #'compare)))

;;; Processing test cases

(defun wrap-in-expect (input-var form)
  `(macrolet ((expect (label test)
                `(is ,test
                     ,(format nil "~~@<For input ~~S, expected ~A ~
                                   ~~S but got ~~S~~@:>"
                              label)
                     ,',input-var ,(second test) ,(third test))))
     ,form))

(defmacro do-input-cases ((input-and-length-vars &rest lambda-list) form cases)
  (destructuring-bind (input-var &optional length-var)
      (alexandria:ensure-list input-and-length-vars)
    (alexandria:with-unique-names (parameter)
      `(mapc (lambda (,parameter)
               (let* ((,input-var (format nil (first ,parameter)))
                      ,@(when length-var
                          `((,length-var (length ,input-var)))))
                 (destructuring-bind (,@lambda-list) (rest ,parameter)
                   ,(wrap-in-expect input-var form))))
             ,cases))))

(defmacro do-stream-input-cases (((&optional length-var) &rest lambda-list)
                                 form cases)
  (alexandria:with-unique-names (parameter input)
    `(mapc (lambda (,parameter)
             (let* ((,input (format nil (first ,parameter)))
                    ,@(when length-var
                        `((,length-var (length ,input)))))
               (destructuring-bind (,@lambda-list) (rest ,parameter)
                 (macrolet ((with-stream ((stream-var) &body body)
                              `(with-input-from-string (,stream-var ,',input)
                                 (let ((values (multiple-value-list
                                                (progn ,@body))))
                                   (multiple-value-call #'values
                                     (values-list values)
                                     (file-position ,stream-var))))))
                   ,(wrap-in-expect input form)))))
           ,cases)))

;;; Checking expected errors

(defun %expected-condition-type (condition-type)
  (case condition-type
    (eclector.reader:feature-expression-type-error
     'eclector.reader::feature-expression-type-error/reader)
    (eclector.reader:single-feature-expected
     'eclector.reader::single-feature-expected/reader)
    (t
     condition-type)))

(defun %signals-printable (condition-type position thunk)
  (handler-bind
      ((condition (lambda (condition)
                    (when (typep condition condition-type)
                      ;; The test should specify the exact expected
                      ;; condition type, not some supertype.
                      (is (type= (%expected-condition-type condition-type)
                                 (type-of condition)))
                      (when (typep condition
                                   `(and stream-error
                                         (not (or eclector.reader:unquote-splicing-in-dotted-list
                                                  eclector.reader:unquote-splicing-at-top))))
                        (is (not (null (stream-error-stream condition)))))
                      ;; Check effective stream position in CONDITION
                      ;; against expected position.
                      (unless (null position)
                        (let ((effective-position
                               (+ (eclector.base:stream-position condition)
                                  (eclector.base:position-offset condition))))
                         (is (= position effective-position))))
                      ;; Make sure CONDITION prints properly.
                      (is (not (string= "" (princ-to-string condition))))
                      (return-from %signals-printable)))))
    (funcall thunk)))

(defmacro signals-printable (condition position &body body)
  (let ((do-it (gensym "DO-IT")))
    `(flet ((,do-it () ,@body))
       (signals ,condition (,do-it))
       (%signals-printable ',condition ,position #',do-it))))

(defun handle-expected-error (expected position thunk)
  (macrolet ((cases ()
               (flet ((condition-names ()
                        (let ((result '()))
                          (do-external-symbols (symbol '#:eclector.reader)
                            (when (and (find-class symbol nil)
                                       (subtypep symbol 'condition))
                              (push symbol result)))
                          result))
                      (do-type (type)
                        `(,type
                          (signals ,type (funcall thunk))
                          (%signals-printable ',type position thunk)
                          t)))
                 `(case expected
                    ,@(map 'list #'do-type (condition-names))
                    (t nil)))))
    (cases)))

(defmacro error-case ((expression &optional position) &body clauses)
  (let* ((error-clause (find 'error clauses :key #'first))
         (error-body (rest error-clause))
         (other-clauses (remove 'error clauses :key #'first)))
    (once-only (expression)
      `(or (handle-expected-error
            ,expression ,position (lambda () ,@error-body))
           (case ,expression
             ,@other-clauses)))))

 Safe recursive equality
 Processing test cases
 Checking expected errors
 The test should specify the exact expected
 condition type, not some supertype.
 Check effective stream position in CONDITION
 against expected position.
 Make sure CONDITION prints properly.
(cl:in-package #:eclector.test)


(defun equal* (left right
               &key (atom-test (lambda (recurse left right)
                                 (declare (ignore recurse))
                                 (if (consp right)
                                     nil
                                     (values (eql left right) t)))))
  (let ((seen (make-hash-table :test #'eq)))
    (labels ((rec (left right)
               (let (old-right result resultp)
                 (cond ((multiple-value-bind (right foundp)
                            (gethash left seen)
                          (when foundp
                            (setf old-right right)
                            t))
                        (eq right old-right))
                       ((progn
                          (setf (values result resultp)
                                (funcall atom-test #'rec left right))
                          resultp)
                        result)
                       (t
                        (setf (gethash left seen) right)
                        (and (rec (car left) (car right))
                             (rec (cdr left) (cdr right))))))))
      (rec left right))))

(defun code-equal (left right)
  (flet ((compare (recurse left right)
           (cond ((and (symbolp right) (not (symbol-package right)))
                  (values (and (null (symbol-package left))
                               (string= (symbol-name left)
                                        (symbol-name right)))
                          t))
                 ((typep right '(cons (eql eclector.reader:quasiquote)))
                  (values t t))
                 ((pathnamep right)
                  (values (and (pathnamep left) (equalp left right)) t))
                 ((stringp right)
                  (values (and (stringp left) (string= left right)) t))
                 ((typep right '(and sequence (not cons)))
                  (values (and (eq (class-of left) (class-of right))
                               (= (length left) (length right))
                               (every recurse left right))
                          t))
  # 0A ( ) or higher rank
                  (values (equalp left right) t))
                 ((not (consp right))
                  (values (eql left right) t))
                 (t
                  (values nil nil)))))
    (equal* left right :atom-test #'compare)))


(defun wrap-in-expect (input-var form)
  `(macrolet ((expect (label test)
                `(is ,test
                     ,(format nil "~~@<For input ~~S, expected ~A ~
                                   ~~S but got ~~S~~@:>"
                              label)
                     ,',input-var ,(second test) ,(third test))))
     ,form))

(defmacro do-input-cases ((input-and-length-vars &rest lambda-list) form cases)
  (destructuring-bind (input-var &optional length-var)
      (alexandria:ensure-list input-and-length-vars)
    (alexandria:with-unique-names (parameter)
      `(mapc (lambda (,parameter)
               (let* ((,input-var (format nil (first ,parameter)))
                      ,@(when length-var
                          `((,length-var (length ,input-var)))))
                 (destructuring-bind (,@lambda-list) (rest ,parameter)
                   ,(wrap-in-expect input-var form))))
             ,cases))))

(defmacro do-stream-input-cases (((&optional length-var) &rest lambda-list)
                                 form cases)
  (alexandria:with-unique-names (parameter input)
    `(mapc (lambda (,parameter)
             (let* ((,input (format nil (first ,parameter)))
                    ,@(when length-var
                        `((,length-var (length ,input)))))
               (destructuring-bind (,@lambda-list) (rest ,parameter)
                 (macrolet ((with-stream ((stream-var) &body body)
                              `(with-input-from-string (,stream-var ,',input)
                                 (let ((values (multiple-value-list
                                                (progn ,@body))))
                                   (multiple-value-call #'values
                                     (values-list values)
                                     (file-position ,stream-var))))))
                   ,(wrap-in-expect input form)))))
           ,cases)))


(defun %expected-condition-type (condition-type)
  (case condition-type
    (eclector.reader:feature-expression-type-error
     'eclector.reader::feature-expression-type-error/reader)
    (eclector.reader:single-feature-expected
     'eclector.reader::single-feature-expected/reader)
    (t
     condition-type)))

(defun %signals-printable (condition-type position thunk)
  (handler-bind
      ((condition (lambda (condition)
                    (when (typep condition condition-type)
                      (is (type= (%expected-condition-type condition-type)
                                 (type-of condition)))
                      (when (typep condition
                                   `(and stream-error
                                         (not (or eclector.reader:unquote-splicing-in-dotted-list
                                                  eclector.reader:unquote-splicing-at-top))))
                        (is (not (null (stream-error-stream condition)))))
                      (unless (null position)
                        (let ((effective-position
                               (+ (eclector.base:stream-position condition)
                                  (eclector.base:position-offset condition))))
                         (is (= position effective-position))))
                      (is (not (string= "" (princ-to-string condition))))
                      (return-from %signals-printable)))))
    (funcall thunk)))

(defmacro signals-printable (condition position &body body)
  (let ((do-it (gensym "DO-IT")))
    `(flet ((,do-it () ,@body))
       (signals ,condition (,do-it))
       (%signals-printable ',condition ,position #',do-it))))

(defun handle-expected-error (expected position thunk)
  (macrolet ((cases ()
               (flet ((condition-names ()
                        (let ((result '()))
                          (do-external-symbols (symbol '#:eclector.reader)
                            (when (and (find-class symbol nil)
                                       (subtypep symbol 'condition))
                              (push symbol result)))
                          result))
                      (do-type (type)
                        `(,type
                          (signals ,type (funcall thunk))
                          (%signals-printable ',type position thunk)
                          t)))
                 `(case expected
                    ,@(map 'list #'do-type (condition-names))
                    (t nil)))))
    (cases)))

(defmacro error-case ((expression &optional position) &body clauses)
  (let* ((error-clause (find 'error clauses :key #'first))
         (error-body (rest error-clause))
         (other-clauses (remove 'error clauses :key #'first)))
    (once-only (expression)
      `(or (handle-expected-error
            ,expression ,position (lambda () ,@error-body))
           (case ,expression
             ,@other-clauses)))))
