(in-package "COMMON-LISP")

(defpackage "RUN-TESTS"
  (:use "COMMON-LISP" "TEST-FRAMEWORK"))

(in-package "RUN-TESTS")

(eval-when (:load-toplevel)
  (nuke-all-tests))

(defclass test-a ()
  ((slot-a :accessor slot-a :initarg :slot-a :initform 1)))

(defclass test-b ()
  ((my-a :initarg :my-a)
   (slot-b :initarg :slot-b)))

(defun frob-a (a)
  (if (<= (slot-a a) 0)
      (setf (slot-a a) 1)
    (slot-a a)))

(define-test-suite empty-test-suite)
(define-test-suite empty-tests)
(define-test-suite successful-tests)
(define-test-suite one-failure)
(define-test-suite failures)
(define-test-suite unexpected-errors)
(define-test-suite nested-tests)

(dotimes (i 10)
  (add-test 'empty-tests
	    (make-instance 'empty-test-case)))

(dotimes (i 10)
  (add-test 'empty-tests
	    (make-instance 'test-case
			   :description "Empty test"
			   :test (lambda (test)
				   (declare (ignore test))))))

(defclass a-test-case (test-case)
  ((test-a1 :reader test-a1)
   (test-a2 :reader test-a2)
   (test-a3 :reader test-a3)))

(defmethod set-up-test ((a a-test-case))
  (setf (slot-value a 'test-a1) (make-instance 'test-a)
	(slot-value a 'test-a2) (make-instance 'test-a :slot-a -1)
	(slot-value a 'test-a3) (make-instance 'test-a :slot-a 0)))

(define-test-function expect-123 (value)
  (expect value 123))

(defun test-frob-a (test-case)
  (expect (frob-a (test-a1 test-case)) 0 :test #'>)
  (expect (frob-a (test-a2 test-case)) 0 :test #'>)
  (expect (frob-a (test-a3 test-case)) 0 :test #'>))

(add-tests 'successful-tests 'a-test-case
	   "Expecting 123"
	   (expect-123 123)
	   "Test instance creation"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-a)
	     (expect-instance (test-a2 test-case) 'test-a)
	     (expect-instance (test-a3 test-case) 'test-a))
	   "Test frob-a"
	   #'test-frob-a)

(add-tests 'non-existant-tests 'a-test-case
	   "Test instance creation"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-a)
	     (expect-instance (test-a2 test-case) 'test-a)
	     (expect-instance (test-a3 test-case) 'test-a))
	   "Test frob-a"
	   #'test-frob-a)

(add-tests 'one-failure 'a-test-case
	   "Test instance creation"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-a)
	     (expect-instance (test-a2 test-case) 'test-a)
	     (expect-instance (test-a3 test-case) 'test-a))
	   "Test instance creation and fail"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-b))
	   "Test frob-a"
	   #'test-frob-a)

(defun test-frob-a-with-failure (test-case)
  (expect (frob-a (test-a1 test-case)) 0))

(add-tests 'failures 'a-test-case
	   "Test instance creation"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-a)
	     (expect-instance (test-a2 test-case) 'test-a)
	     (expect-instance (test-a3 test-case) 'test-a))
	   "Test instance creation and fail"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-b))
	   "Test initial-value and fail"
	   (lambda (test-case)
	     (expect (slot-a (test-a1 test-case)) 0))
	   "Test frob-a"
	   #'test-frob-a
	   "Test frob-a and fail"
	   #'test-frob-a-with-failure)

(defun test-frob-a-with-unexpected-error (test-case)
  (declare (ignore test-case))
  (error "Failing unexpectedly."))


(add-tests 'unexpected-errors 'a-test-case
	   "Test instance creation"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-a)
	     (expect-instance (test-a2 test-case) 'test-a)
	     (expect-instance (test-a3 test-case) 'test-a))
	   "Test instance creation and fail"
	   (lambda (test-case)
	     (expect-instance (test-a1 test-case) 'test-b))
	   "Test initial-value and fail"
	   (lambda (test-case)
	     (expect (slot-a (test-a1 test-case)) 0))
	   "Test frob-a"
	   #'test-frob-a
	   "Test frob-a with unexpected error"
	   #'test-frob-a-with-unexpected-error
	   "Test frob-a and fail"
	   #'test-frob-a-with-failure
	   "Fail the last test"
	   (lambda (test-case)
	     (declare (ignore test-case))
	     (error "Failing the last test.")))

(dotimes (i 10)
  (add-test 'nested-tests
	    (make-instance 'empty-test-case)))

(add-test 'nested-tests (test-suite 'empty-tests))
(add-test 'nested-tests (test-suite 'successful-tests))

(dotimes (i 20)
  (add-test 'nested-tests
	    (make-instance 'empty-test-case)))