;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-

(in-package :it.bese.fiveam)

;;;; * Tests

;;;; While executing checks and collecting the results is the core job
;;;; of a testing framework it is also important to be able to

;;;; organize checks into groups, fiveam provides two mechanisms for

;;;; organizing checks: tests and test suites. A test is a named
;;;; collection of checks which can be run and a test suite is a named
;;;; collection of tests and test suites.

(defvar *test*
  (make-hash-table :test 'eql)
  "Lookup table mapping test (and test suite)

  names to objects.")

(defun get-test (key &optional default)
  (gethash key *test* default))

(defun (setf get-test) (value key)
  (setf (gethash key *test*) value))

(defun rem-test (key)
  (remhash key *test*))

(defun test-names ()
  (loop for test being the hash-keys of *test*
        collect test))

(defmacro test (name &body body)

  "Create a test named NAME. If NAME is a list it must be of the

form:

  (name &key depends-on suite fixture compile-at profile)

NAME is the symbol which names the test.

DEPENDS-ON is a list of the form:

 (AND . test-names) - This test is run only if all of the tests
 in TEST-NAMES have passed, otherwise a single test-skipped
 result is generated.

 (OR . test-names) - If any of TEST-NAMES has passed this test is
 run, otherwise a test-skipped result is generated.

 (NOT test-name) - This is test is run only if TEST-NAME failed.

AND, OR and NOT can be combined to produce complex dependencies.

If DEPENDS-ON is a symbol it is interpreted as `(AND
,depends-on), this is accomadate the common case of one test
depending on another.

FIXTURE specifies a fixture to wrap the body in.

If PROFILE is T profiling information will be collected as well."

  (simple-style-warning "~A is OBSOLETE! Use ~A instead."
                        'test 'def-test)
  (destructuring-bind (name &rest args)
      (ensure-list name)
    `(def-test ,name (,@args) ,@body)))

(defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture
                            (compile-at :run-time) profile)
                    &body body)
  "Create a test named NAME.

NAME is the symbol which names the test.

DEPENDS-ON is a list of the form:

 (AND . test-names) - This test is run only if all of the tests
 in TEST-NAMES have passed, otherwise a single test-skipped
 result is generated.

 (OR . test-names) - If any of TEST-NAMES has passed this test is
 run, otherwise a test-skipped result is generated.

 (NOT test-name) - This is test is run only if TEST-NAME failed.

AND, OR and NOT can be combined to produce complex dependencies.

If DEPENDS-ON is a symbol it is interpreted as `(AND
,depends-on), this is accomadate the common case of one test
depending on another.

FIXTURE specifies a fixture to wrap the body in.

If PROFILE is T profiling information will be collected as well."
  (let ((suite-form
          (if suite-p
              `(get-test ',suite)
              (or suite '*suite*))))
    (check-type compile-at (member :run-time :definition-time))
    (let ((description (if (stringp (car body))
                           (pop body)
                           ""))
          (effective-body (if fixture
                              (destructuring-bind (name &rest args)
                                  (ensure-list fixture)
                                `((with-fixture ,name ,args ,@body)))
                              body))
          (lambda-name
            (format-symbol t "%~A-~A" '#:test name))
          (inner-lambda-name
            (format-symbol t "%~A-~A" '#:inner-test name)))
      `(progn
         (setf (get-test ',name)
               (make-instance 'test-case
                              :name ',name
                              :runtime-package (find-package ,(package-name *package*))
                              :test-lambda
                              (named-lambda ,lambda-name ()
                                ,@ (ecase compile-at
                                     (:run-time `((funcall
                                                   (let ((*package* (find-package ',(package-name *package*))))
                                                     (compile ',inner-lambda-name
                                                              '(lambda () ,@effective-body))))))
                                     (:definition-time effective-body)))
                              :description ,description
                              :depends-on ',depends-on
                              :collect-profiling-info ,profile))
         (setf (gethash ',name (tests ,suite-form)) ',name)
         (when *run-test-when-defined*
           (run! ',name))
         ',name))))

(defvar *run-test-when-defined* nil
  "When non-NIL tests are run as soon as they are defined.")

;; Copyright (c) 2002-2003, Edward Marco Baringer

;; All rights reserved.
;;

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:

;;

;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.

;;

;;  - Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;;
;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;    of its contributors may be used to endorse or promote products
;;    derived from this software without specific prior written permission.

;;