(defpackage #:lisp-test
  (:use #:common-lisp)
  (:export #:run-suite #:test-suite #:testcase #:run-all-suites
           #:clear-all-suites #:test-suites))

(in-package #:lisp-test)

(defvar *unbound-slot* (copy-seq #(unbound)))

(defun init ()
  (defparameter *test-suites* (make-hash-table :test #'eq)))

(defclass test-suite ()
  ((tests :initform '())))


(defclass test ()
  ((name :initarg :name :reader test-name)
   (form :initarg :form)
   (returns :initarg :returns :initform *unbound-slot*)
   (raises :initarg :raises :initform *unbound-slot*)
   (test :initarg :test :initform #'equal)))


(defmethod run-test ((test-case test))
  "True if TEST-CASES passes.  False otherwise."
  (with-slots (form returns raises test) test-case
    (handler-case (funcall test (eval form) returns)
      (error (e) (if (eq raises *unbound-slot*)
                     nil
                     (typep e raises))))))



(defmethod add-test ((suite test-suite) (test test))
  "Add TEST to SUITE."
  (with-slots (tests) suite
    (push test tests)))


(defmethod run-suite ((suite test-suite))
  "Run all tests in SUITE.  Returns two lists: tests that passed,
tests that failed"
  (with-slots (tests) suite
    (let ((passes '())
          (fails '()))
      (dolist (test tests)
        (if (run-test test)
            (push (test-name test) passes)
            (push (test-name test) fails)))
      (values passes fails))))


(defmethod run-suite ((suite-name symbol))
  "Run all tests in the suite named SUITE-NAME"
  (run-suite (gethash suite-name *test-suites*)))


(defmacro make-test (name form &rest keys)
  "Create a new test object"
  `(make-instance 'test
                 :name ',name
                 :form ',form
                 ,@keys))


(defmacro testcase (name form &rest keys)
  "Run a testcase."
  `(run-test (make-test ,name ,form ,@keys)))


(defmacro test-suite (name &body test-cases)
  "Define a new test suite."
  `(progn (setf (gethash ,name *test-suites*)
                (make-instance 'test-suite))
          (macrolet ((testcase (name form &rest keys)
                       `(add-test (gethash ,',name *test-suites*)
                                  (make-test ,name ,form ,@keys))))
            ,@test-cases)))


(defun run-all-suites (&optional (stream *standard-output*))
  "Run all test suites."
  (let ((passed 0)
        (failed 0))
    (maphash #'(lambda (suite-name suite)
                 (multiple-value-bind (passes fails) (run-suite suite)
                   (when fails
                     (format stream "~A:~%~{  ~A: failed~%~}~%"
                             suite-name fails))
                   (incf passed (length passes))
                   (incf failed (length fails))))
             *test-suites*)
    (list :passed passed :failed failed)))


(defun test-suites ()
  (let ((keys '()))
    (maphash #'(lambda (k v) (push k keys))
             *test-suites*)
    keys))


(defun clear-all-suites ()
  (init))


(init)