{-# 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 :: HasCallStack => String -> Bool -> Assertion
assertBool String
msg Bool
b = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (forall a. HasCallStack => String -> IO a
assertFailure String
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 :: HasCallStack => String -> Assertion
assertString String
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (forall a. HasCallStack => String -> IO a
assertFailure String
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 :: HasCallStack => () -> Assertion
assert = forall (m :: * -> *) a. Monad m => a -> m a
return

instance Assertable Bool
 where assert :: HasCallStack => Bool -> Assertion
assert = HasCallStack => String -> Bool -> Assertion
assertBool String
""

instance (ListAssertable t) => Assertable [t]
 where assert :: HasCallStack => [t] -> Assertion
assert = forall t. (ListAssertable t, HasCallStack) => [t] -> Assertion
listAssert

instance (Assertable t) => Assertable (IO t)
 where assert :: HasCallStack => IO t -> Assertion
assert = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall t. (Assertable t, HasCallStack) => t -> Assertion
assert)

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

instance ListAssertable Char
 where listAssert :: HasCallStack => String -> Assertion
listAssert = HasCallStack => String -> Assertion
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 :: Bool -> AssertionPredicate
assertionPredicate = forall (m :: * -> *) a. Monad m => a -> m a
return

instance (AssertionPredicable t) => AssertionPredicable (IO t)
 where assertionPredicate :: IO t -> AssertionPredicate
assertionPredicate = (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall t. AssertionPredicable t => t -> 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
t
predi @? :: forall t.
(HasCallStack, AssertionPredicable t) =>
t -> String -> Assertion
@? String
msg = forall t. AssertionPredicable t => t -> AssertionPredicate
assertionPredicate t
predi forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> Assertion
assertBool String
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
a
expected @=? :: forall a. (HasCallStack, Eq a, Show a) => a -> a -> Assertion
@=? a
actual = forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
"" a
expected a
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
a
actual @?= :: forall a. (HasCallStack, Eq a, Show a) => a -> a -> Assertion
@?= a
expected = forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
"" a
expected a
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 :: Int -> Test -> ShowS
showsPrec Int
_ (TestCase Assertion
_)    = String -> ShowS
showString String
"TestCase _"
  showsPrec Int
_ (TestList [Test]
ts)   = String -> ShowS
showString String
"TestList " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => [a] -> ShowS
showList [Test]
ts
  showsPrec Int
p (TestLabel String
l Test
t) = String -> ShowS
showString String
"TestLabel " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
l
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Test
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 :: HasCallStack => Test -> Test
test = forall a. a -> a
id

instance (Assertable t) => Testable (IO t)
 where test :: HasCallStack => IO t -> Test
test = Assertion -> Test
TestCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. (Assertable t, HasCallStack) => t -> Assertion
assert

instance (Testable t) => Testable [t]
 where test :: HasCallStack => [t] -> Test
test = [Test] -> Test
TestList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall t. (Testable t, HasCallStack) => t -> Test
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
t
predi ~? :: forall t.
(HasCallStack, AssertionPredicable t) =>
t -> String -> Test
~? String
msg = Assertion -> Test
TestCase (t
predi forall t.
(HasCallStack, AssertionPredicable t) =>
t -> String -> Assertion
@? String
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
a
expected ~=? :: forall a. (HasCallStack, Eq a, Show a) => a -> a -> Test
~=? a
actual = Assertion -> Test
TestCase (a
expected forall a. (HasCallStack, Eq a, Show a) => a -> a -> Assertion
@=? a
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
a
actual ~?= :: forall a. (HasCallStack, Eq a, Show a) => a -> a -> Test
~?= a
expected = Assertion -> Test
TestCase (a
actual forall a. (HasCallStack, Eq a, Show a) => a -> a -> Assertion
@?= a
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
String
label ~: :: forall t. (HasCallStack, Testable t) => String -> t -> Test
~: t
t = String -> Test -> Test
TestLabel String
label (forall t. (Testable t, HasCallStack) => t -> Test
test t
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 { Counts -> Int
cases, Counts -> Int
tried, Counts -> Int
errors, Counts -> Int
failures :: Int }
  deriving (Counts -> Counts -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Counts -> Counts -> Bool
$c/= :: Counts -> Counts -> Bool
== :: Counts -> Counts -> Bool
$c== :: Counts -> Counts -> Bool
Eq, Int -> Counts -> ShowS
[Counts] -> ShowS
Counts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Counts] -> ShowS
$cshowList :: [Counts] -> ShowS
show :: Counts -> String
$cshow :: Counts -> String
showsPrec :: Int -> Counts -> ShowS
$cshowsPrec :: Int -> Counts -> ShowS
Show, ReadPrec [Counts]
ReadPrec Counts
Int -> ReadS Counts
ReadS [Counts]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Counts]
$creadListPrec :: ReadPrec [Counts]
readPrec :: ReadPrec Counts
$creadPrec :: ReadPrec Counts
readList :: ReadS [Counts]
$creadList :: ReadS [Counts]
readsPrec :: Int -> ReadS Counts
$creadsPrec :: Int -> ReadS Counts
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 { State -> Path
path :: Path, State -> Counts
counts :: Counts }
  deriving (State -> State -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: State -> State -> Bool
$c/= :: State -> State -> Bool
== :: State -> State -> Bool
$c== :: State -> State -> Bool
Eq, Int -> State -> ShowS
[State] -> ShowS
State -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [State] -> ShowS
$cshowList :: [State] -> ShowS
show :: State -> String
$cshow :: State -> String
showsPrec :: Int -> State -> ShowS
$cshowsPrec :: Int -> State -> ShowS
Show, ReadPrec [State]
ReadPrec State
Int -> ReadS State
ReadS [State]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [State]
$creadListPrec :: ReadPrec [State]
readPrec :: ReadPrec State
$creadPrec :: ReadPrec State
readList :: ReadS [State]
$creadList :: ReadS [State]
readsPrec :: Int -> ReadS State
$creadsPrec :: Int -> ReadS State
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 (Node -> Node -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: Node -> Node -> Bool
Eq, Int -> Node -> ShowS
Path -> ShowS
Node -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: Path -> ShowS
$cshowList :: Path -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show, ReadPrec Path
ReadPrec Node
Int -> ReadS Node
ReadS Path
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec Path
$creadListPrec :: ReadPrec Path
readPrec :: ReadPrec Node
$creadPrec :: ReadPrec Node
readList :: ReadS Path
$creadList :: ReadS Path
readsPrec :: Int -> ReadS Node
$creadsPrec :: Int -> ReadS Node
Read)

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

-- | Counts the number of 'TestCase's in a tree of @Test@s.
testCaseCount :: Test -> Int
testCaseCount :: Test -> Int
testCaseCount (TestCase Assertion
_)    = Int
1
testCaseCount (TestList [Test]
ts)   = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Test -> Int
testCaseCount [Test]
ts)
testCaseCount (TestLabel String
_ Test
t) = Test -> Int
testCaseCount Test
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 :: forall us.
ReportStart us
-> ReportProblem us
-> ReportProblem us
-> us
-> Test
-> IO (Counts, us)
performTest ReportStart us
reportStart ReportProblem us
reportError ReportProblem us
reportFailure us
initialUs Test
initialT = do
  (State
ss', us
us') <- State -> us -> Test -> IO (State, us)
pt State
initState us
initialUs Test
initialT
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (State -> Path
path State
ss')) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"performTest: Final path is nonnull"
  forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Counts
counts State
ss', us
us')
 where
  initState :: State
initState  = State{ path :: Path
path = [], counts :: Counts
counts = Counts
initCounts }
  initCounts :: Counts
initCounts = Counts{ cases :: Int
cases = Test -> Int
testCaseCount Test
initialT, tried :: Int
tried = Int
0,
                       errors :: Int
errors = Int
0, failures :: Int
failures = Int
0}

  pt :: State -> us -> Test -> IO (State, us)
pt State
ss us
us (TestCase Assertion
a) = do
    us
us' <- ReportStart us
reportStart State
ss us
us
    Result
r <- Assertion -> IO Result
performTestCase Assertion
a
    case Result
r of
      Result
Success -> do
        forall (m :: * -> *) a. Monad m => a -> m a
return (State
ss', us
us')
      Failure Maybe SrcLoc
loc String
m -> do
        us
usF <- ReportProblem us
reportFailure Maybe SrcLoc
loc String
m State
ssF us
us'
        forall (m :: * -> *) a. Monad m => a -> m a
return (State
ssF, us
usF)
      Error Maybe SrcLoc
loc String
m -> do
        us
usE <- ReportProblem us
reportError Maybe SrcLoc
loc String
m State
ssE us
us'
        forall (m :: * -> *) a. Monad m => a -> m a
return (State
ssE, us
usE)
   where c :: Counts
c@Counts{ tried :: Counts -> Int
tried = Int
n } = State -> Counts
counts State
ss
         ss' :: State
ss' = State
ss{ counts :: Counts
counts = Counts
c{ tried :: Int
tried = Int
n forall a. Num a => a -> a -> a
+ Int
1 } }
         ssF :: State
ssF = State
ss{ counts :: Counts
counts = Counts
c{ tried :: Int
tried = Int
n forall a. Num a => a -> a -> a
+ Int
1, failures :: Int
failures = Counts -> Int
failures Counts
c forall a. Num a => a -> a -> a
+ Int
1 } }
         ssE :: State
ssE = State
ss{ counts :: Counts
counts = Counts
c{ tried :: Int
tried = Int
n forall a. Num a => a -> a -> a
+ Int
1, errors :: Int
errors   = Counts -> Int
errors   Counts
c forall a. Num a => a -> a -> a
+ Int
1 } }

  pt State
ss us
us (TestList [Test]
ts) = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (State, us) -> (Test, Int) -> IO (State, us)
f (State
ss, us
us) (forall a b. [a] -> [b] -> [(a, b)]
zip [Test]
ts [Int
0..])
   where f :: (State, us) -> (Test, Int) -> IO (State, us)
f (State
ss', us
us') (Test
t, Int
n) = Node -> State -> us -> Test -> IO (State, us)
withNode (Int -> Node
ListItem Int
n) State
ss' us
us' Test
t

  pt State
ss us
us (TestLabel String
label Test
t) = Node -> State -> us -> Test -> IO (State, us)
withNode (String -> Node
Label String
label) State
ss us
us Test
t

  withNode :: Node -> State -> us -> Test -> IO (State, us)
withNode Node
node State
ss0 us
us0 Test
t = do (State
ss2, us
us1) <- State -> us -> Test -> IO (State, us)
pt State
ss1 us
us0 Test
t
                               forall (m :: * -> *) a. Monad m => a -> m a
return (State
ss2{ path :: Path
path = Path
path0 }, us
us1)
   where path0 :: Path
path0 = State -> Path
path State
ss0
         ss1 :: State
ss1 = State
ss0{ path :: Path
path = Node
node forall a. a -> [a] -> [a]
: Path
path0 }