Test/HUnit/Base.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}

#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE ConstraintKinds #-}
#define HasCallStack_ HasCallStack =>
#else
#define HasCallStack_
#endif

-- | Basic definitions for the HUnit library.
--
--   This module contains what you need to create assertions and test cases and
--   combine them into test suites.
--
--   This module also provides infrastructure for
--   implementing test controllers (which are used to execute tests).
--   See "Test.HUnit.Text" for a great example of how to implement a test
--   controller.

module Test.HUnit.Base
(
  -- ** Declaring tests
  Test(..),
  (~=?), (~?=), (~:), (~?),

  -- ** Making assertions
  assertFailure, {- from Test.HUnit.Lang: -}
  assertBool, assertEqual, assertString,
  Assertion, {- from Test.HUnit.Lang: -}
  (@=?), (@?=), (@?),

  -- ** Extending the assertion functionality
  Assertable(..), ListAssertable(..),
  AssertionPredicate, AssertionPredicable(..),
  Testable(..),

  -- ** Test execution
  -- $testExecutionNote
  State(..), Counts(..),
  Path, Node(..),
  testCasePaths,
  testCaseCount,
  ReportStart, ReportProblem,
  performTest
) where

import Control.Monad (unless, foldM)
import Data.CallStack


-- Assertion Definition
-- ====================

import Test.HUnit.Lang


-- Conditional Assertion Functions
-- -------------------------------

-- | Asserts that the specified condition holds.
assertBool :: HasCallStack_
              String    -- ^ The message that is displayed if the assertion fails
           -> Bool      -- ^ The condition
           -> Assertion
assertBool msg b = unless b (assertFailure msg)

-- | Signals an assertion failure if a non-empty message (i.e., a message
-- other than @\"\"@) is passed.
assertString :: HasCallStack_
                String    -- ^ The message that is displayed with the assertion failure
             -> Assertion
assertString s = unless (null s) (assertFailure s)

-- Overloaded `assert` Function
-- ----------------------------

-- | Allows the extension of the assertion mechanism.
--
-- Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions,
-- there is a fair amount of flexibility of what can be achieved.  As a rule,
-- the resulting @Assertion@ should be the body of a 'TestCase' or part of
-- a @TestCase@; it should not be used to assert multiple, independent
-- conditions.
--
-- If more complex arrangements of assertions are needed, 'Test's and
-- 'Testable' should be used.
class Assertable t
 where assert :: HasCallStack_ t -> Assertion

instance Assertable ()
 where assert = return

instance Assertable Bool
 where assert = assertBool ""

instance (ListAssertable t) => Assertable [t]
 where assert = listAssert

instance (Assertable t) => Assertable (IO t)
 where assert = (>>= assert)

-- | A specialized form of 'Assertable' to handle lists.
class ListAssertable t
 where listAssert :: HasCallStack_ [t] -> Assertion

instance ListAssertable Char
 where listAssert = assertString


-- Overloaded `assertionPredicate` Function
-- ----------------------------------------

-- | The result of an assertion that hasn't been evaluated yet.
--
-- Most test cases follow the following steps:
--
-- 1. Do some processing or an action.
--
-- 2. Assert certain conditions.
--
-- However, this flow is not always suitable.  @AssertionPredicate@ allows for
-- additional steps to be inserted without the initial action to be affected
-- by side effects.  Additionally, clean-up can be done before the test case
-- has a chance to end.  A potential work flow is:
--
-- 1. Write data to a file.
--
-- 2. Read data from a file, evaluate conditions.
--
-- 3. Clean up the file.
--
-- 4. Assert that the side effects of the read operation meet certain conditions.
--
-- 5. Assert that the conditions evaluated in step 2 are met.
type AssertionPredicate = IO Bool

-- | Used to signify that a data type can be converted to an assertion
-- predicate.
class AssertionPredicable t
 where assertionPredicate :: t -> AssertionPredicate

instance AssertionPredicable Bool
 where assertionPredicate = return

instance (AssertionPredicable t) => AssertionPredicable (IO t)
 where assertionPredicate = (>>= assertionPredicate)


-- Assertion Construction Operators
-- --------------------------------

infix  1 @?, @=?, @?=

-- | Asserts that the condition obtained from the specified
--   'AssertionPredicable' holds.
(@?) :: HasCallStack_ AssertionPredicable t
                                => t          -- ^ A value of which the asserted condition is predicated
                                -> String     -- ^ A message that is displayed if the assertion fails
                                -> Assertion
predi @? msg = assertionPredicate predi >>= assertBool msg

-- | Asserts that the specified actual value is equal to the expected value
--   (with the expected value on the left-hand side).
(@=?) :: HasCallStack_ (Eq a, Show a)
                        => a -- ^ The expected value
                        -> a -- ^ The actual value
                        -> Assertion
expected @=? actual = assertEqual "" expected actual

-- | Asserts that the specified actual value is equal to the expected value
--   (with the actual value on the left-hand side).
(@?=) :: HasCallStack_ (Eq a, Show a)
                        => a -- ^ The actual value
                        -> a -- ^ The expected value
                        -> Assertion
actual @?= expected = assertEqual "" expected actual


-- Test Definition
-- ===============

-- | The basic structure used to create an annotated tree of test cases.
data Test
    -- | A single, independent test case composed.
    = TestCase Assertion
    -- | A set of @Test@s sharing the same level in the hierarchy.
    | TestList [Test]
    -- | A name or description for a subtree of the @Test@s.
    | TestLabel String Test

instance Show Test where
  showsPrec _ (TestCase _)    = showString "TestCase _"
  showsPrec _ (TestList ts)   = showString "TestList " . showList ts
  showsPrec p (TestLabel l t) = showString "TestLabel " . showString l
                                . showChar ' ' . showsPrec p t

-- Overloaded `test` Function
-- --------------------------

-- | Provides a way to convert data into a @Test@ or set of @Test@.
class Testable t
 where test :: HasCallStack_ t -> Test

instance Testable Test
 where test = id

instance (Assertable t) => Testable (IO t)
 where test = TestCase . assert

instance (Testable t) => Testable [t]
 where test = TestList . map test


-- Test Construction Operators
-- ---------------------------

infix  1 ~?, ~=?, ~?=
infixr 0 ~:

-- | Creates a test case resulting from asserting the condition obtained
--   from the specified 'AssertionPredicable'.
(~?) :: HasCallStack_ AssertionPredicable t
                                => t       -- ^ A value of which the asserted condition is predicated
                                -> String  -- ^ A message that is displayed on test failure
                                -> Test
predi ~? msg = TestCase (predi @? msg)

-- | Shorthand for a test case that asserts equality (with the expected
--   value on the left-hand side, and the actual value on the right-hand
--   side).
(~=?) :: HasCallStack_ (Eq a, Show a)
                        => a     -- ^ The expected value
                        -> a     -- ^ The actual value
                        -> Test
expected ~=? actual = TestCase (expected @=? actual)

-- | Shorthand for a test case that asserts equality (with the actual
--   value on the left-hand side, and the expected value on the right-hand
--   side).
(~?=) :: HasCallStack_ (Eq a, Show a)
                        => a     -- ^ The actual value
                        -> a     -- ^ The expected value
                        -> Test
actual ~?= expected = TestCase (actual @?= expected)

-- | Creates a test from the specified 'Testable', with the specified
--   label attached to it.
--
-- Since 'Test' is @Testable@, this can be used as a shorthand way of attaching
-- a 'TestLabel' to one or more tests.
(~:) :: HasCallStack_ Testable t => String -> t -> Test
label ~: t = TestLabel label (test t)


-- Test Execution
-- ==============

-- $testExecutionNote
-- Note: the rest of the functionality in this module is intended for
-- implementors of test controllers. If you just want to run your tests cases,
-- simply use a test controller, such as the text-based controller in
-- "Test.HUnit.Text".

-- | A data structure that hold the results of tests that have been performed
-- up until this point.
data Counts = Counts { cases, tried, errors, failures :: Int }
  deriving (Eq, Show, Read)

-- | Keeps track of the remaining tests and the results of the performed tests.
-- As each test is performed, the path is removed and the counts are
-- updated as appropriate.
data State = State { path :: Path, counts :: Counts }
  deriving (Eq, Show, Read)

-- | Report generator for reporting the start of a test run.
type ReportStart us = State -> us -> IO us

-- | Report generator for reporting problems that have occurred during
--   a test run. Problems may be errors or assertion failures.
type ReportProblem us = Maybe SrcLoc -> String -> State -> us -> IO us

-- | Uniquely describes the location of a test within a test hierarchy.
-- Node order is from test case to root.
type Path = [Node]

-- | Composed into 'Path's.
data Node  = ListItem Int | Label String
  deriving (Eq, Show, Read)

-- | Determines the paths for all 'TestCase's in a tree of @Test@s.
testCasePaths :: Test -> [Path]
testCasePaths t0 = tcp t0 []
 where tcp (TestCase _) p = [p]
       tcp (TestList ts) p =
         concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ]
       tcp (TestLabel l t) p = tcp t (Label l : p)

-- | Counts the number of 'TestCase's in a tree of @Test@s.
testCaseCount :: Test -> Int
testCaseCount (TestCase _)    = 1
testCaseCount (TestList ts)   = sum (map testCaseCount ts)
testCaseCount (TestLabel _ t) = testCaseCount t

-- | Performs a test run with the specified report generators.
--
-- This handles the actual running of the tests.  Most developers will want
-- to use @HUnit.Text.runTestTT@ instead.  A developer could use this function
-- to execute tests via another IO system, such as a GUI, or to output the
-- results in a different manner (e.g., upload XML-formatted results to a
-- webservice).
--
-- Note that the counts in a start report do not include the test case
-- being started, whereas the counts in a problem report do include the
-- test case just finished.  The principle is that the counts are sampled
-- only between test case executions.  As a result, the number of test
-- case successes always equals the difference of test cases tried and
-- the sum of test case errors and failures.
performTest :: ReportStart us   -- ^ report generator for the test run start
            -> ReportProblem us -- ^ report generator for errors during the test run
            -> ReportProblem us -- ^ report generator for assertion failures during the test run
            -> us
            -> Test             -- ^ the test to be executed
            -> IO (Counts, us)
performTest reportStart reportError reportFailure initialUs initialT = do
  (ss', us') <- pt initState initialUs initialT
  unless (null (path ss')) $ error "performTest: Final path is nonnull"
  return (counts ss', us')
 where
  initState  = State{ path = [], counts = initCounts }
  initCounts = Counts{ cases = testCaseCount initialT, tried = 0,
                       errors = 0, failures = 0}

  pt ss us (TestCase a) = do
    us' <- reportStart ss us
    r <- performTestCase a
    case r of
      Success -> do
        return (ss', us')
      Failure loc m -> do
        usF <- reportFailure loc m ssF us'
        return (ssF, usF)
      Error loc m -> do
        usE <- reportError loc m ssE us'
        return (ssE, usE)
   where c@Counts{ tried = n } = counts ss
         ss' = ss{ counts = c{ tried = n + 1 } }
         ssF = ss{ counts = c{ tried = n + 1, failures = failures c + 1 } }
         ssE = ss{ counts = c{ tried = n + 1, errors   = errors   c + 1 } }

  pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..])
   where f (ss', us') (t, n) = withNode (ListItem n) ss' us' t

  pt ss us (TestLabel label t) = withNode (Label label) ss us t

  withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t
                               return (ss2{ path = path0 }, us1)
   where path0 = path ss0
         ss1 = ss0{ path = node : path0 }