{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module Test.HUnit.Base
(
Test(..),
(~=?), (~?=), (~:), (~?),
assertFailure,
assertBool, assertEqual, assertString,
Assertion,
(@=?), (@?=), (@?),
Assertable(..), ListAssertable(..),
AssertionPredicate, AssertionPredicable(..),
Testable(..),
State(..), Counts(..),
Path, Node(..),
testCasePaths,
testCaseCount,
ReportStart, ReportProblem,
performTest
) where
import Control.Monad (unless, foldM)
import Data.CallStack
import Test.HUnit.Lang
assertBool :: HasCallStack
=> String
-> Bool
-> Assertion
assertBool :: String -> Bool -> Assertion
assertBool String
msg Bool
b = Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
b (String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
msg)
assertString :: HasCallStack
=> String
-> Assertion
assertString :: String -> Assertion
assertString String
s = Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (String -> Assertion
forall a. HasCallStack => String -> IO a
assertFailure String
s)
class Assertable t
where assert :: HasCallStack => t -> Assertion
instance Assertable ()
where assert :: () -> Assertion
assert = () -> Assertion
forall (m :: * -> *) a. Monad m => a -> m a
return
instance Assertable Bool
where assert :: Bool -> Assertion
assert = HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
""
instance (ListAssertable t) => Assertable [t]
where assert :: [t] -> Assertion
assert = [t] -> Assertion
forall t. (ListAssertable t, HasCallStack) => [t] -> Assertion
listAssert
instance (Assertable t) => Assertable (IO t)
where assert :: IO t -> Assertion
assert = (IO t -> (t -> Assertion) -> Assertion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> Assertion
forall t. (Assertable t, HasCallStack) => t -> Assertion
assert)
class ListAssertable t
where listAssert :: HasCallStack => [t] -> Assertion
instance ListAssertable Char
where listAssert :: String -> Assertion
listAssert = HasCallStack => String -> Assertion
String -> Assertion
assertString
type AssertionPredicate = IO Bool
class AssertionPredicable t
where assertionPredicate :: t -> AssertionPredicate
instance AssertionPredicable Bool
where assertionPredicate :: Bool -> AssertionPredicate
assertionPredicate = Bool -> AssertionPredicate
forall (m :: * -> *) a. Monad m => a -> m a
return
instance (AssertionPredicable t) => AssertionPredicable (IO t)
where assertionPredicate :: IO t -> AssertionPredicate
assertionPredicate = (IO t -> (t -> AssertionPredicate) -> AssertionPredicate
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= t -> AssertionPredicate
forall t. AssertionPredicable t => t -> AssertionPredicate
assertionPredicate)
infix 1 @?, @=?, @?=
(@?) :: (HasCallStack, AssertionPredicable t)
=> t
-> String
-> Assertion
t
predi @? :: t -> String -> Assertion
@? String
msg = t -> AssertionPredicate
forall t. AssertionPredicable t => t -> AssertionPredicate
assertionPredicate t
predi AssertionPredicate -> (Bool -> Assertion) -> Assertion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HasCallStack => String -> Bool -> Assertion
String -> Bool -> Assertion
assertBool String
msg
(@=?) :: (HasCallStack, Eq a, Show a)
=> a
-> a
-> Assertion
a
expected @=? :: a -> a -> Assertion
@=? a
actual = String -> a -> a -> Assertion
forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
"" a
expected a
actual
(@?=) :: (HasCallStack, Eq a, Show a)
=> a
-> a
-> Assertion
a
actual @?= :: a -> a -> Assertion
@?= a
expected = String -> a -> a -> Assertion
forall a.
(HasCallStack, Eq a, Show a) =>
String -> a -> a -> Assertion
assertEqual String
"" a
expected a
actual
data Test
= TestCase Assertion
| TestList [Test]
| 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 " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Test] -> ShowS
forall a. Show a => [a] -> ShowS
showList [Test]
ts
showsPrec Int
p (TestLabel String
l Test
t) = String -> ShowS
showString String
"TestLabel " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
l
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Test -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Test
t
class Testable t
where test :: HasCallStack => t -> Test
instance Testable Test
where test :: Test -> Test
test = Test -> Test
forall a. a -> a
id
instance (Assertable t) => Testable (IO t)
where test :: IO t -> Test
test = Assertion -> Test
TestCase (Assertion -> Test) -> (IO t -> Assertion) -> IO t -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO t -> Assertion
forall t. (Assertable t, HasCallStack) => t -> Assertion
assert
instance (Testable t) => Testable [t]
where test :: [t] -> Test
test = [Test] -> Test
TestList ([Test] -> Test) -> ([t] -> [Test]) -> [t] -> Test
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> Test) -> [t] -> [Test]
forall a b. (a -> b) -> [a] -> [b]
map t -> Test
forall t. (Testable t, HasCallStack) => t -> Test
test
infix 1 ~?, ~=?, ~?=
infixr 0 ~:
(~?) :: (HasCallStack, AssertionPredicable t)
=> t
-> String
-> Test
t
predi ~? :: t -> String -> Test
~? String
msg = Assertion -> Test
TestCase (t
predi t -> String -> Assertion
forall t.
(HasCallStack, AssertionPredicable t) =>
t -> String -> Assertion
@? String
msg)
(~=?) :: (HasCallStack, Eq a, Show a)
=> a
-> a
-> Test
a
expected ~=? :: a -> a -> Test
~=? a
actual = Assertion -> Test
TestCase (a
expected a -> a -> Assertion
forall a. (HasCallStack, Eq a, Show a) => a -> a -> Assertion
@=? a
actual)
(~?=) :: (HasCallStack, Eq a, Show a)
=> a
-> a
-> Test
a
actual ~?= :: a -> a -> Test
~?= a
expected = Assertion -> Test
TestCase (a
actual a -> a -> Assertion
forall a. (HasCallStack, Eq a, Show a) => a -> a -> Assertion
@?= a
expected)
(~:) :: (HasCallStack, Testable t) => String -> t -> Test
String
label ~: :: String -> t -> Test
~: t
t = String -> Test -> Test
TestLabel String
label (t -> Test
forall t. (Testable t, HasCallStack) => t -> Test
test t
t)
data Counts = Counts { Counts -> Int
cases, Counts -> Int
tried, Counts -> Int
errors, Counts -> Int
failures :: Int }
deriving (Counts -> Counts -> Bool
(Counts -> Counts -> Bool)
-> (Counts -> Counts -> Bool) -> Eq Counts
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
(Int -> Counts -> ShowS)
-> (Counts -> String) -> ([Counts] -> ShowS) -> Show Counts
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]
(Int -> ReadS Counts)
-> ReadS [Counts]
-> ReadPrec Counts
-> ReadPrec [Counts]
-> Read 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)
data State = State { State -> Path
path :: Path, State -> Counts
counts :: Counts }
deriving (State -> State -> Bool
(State -> State -> Bool) -> (State -> State -> Bool) -> Eq State
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
(Int -> State -> ShowS)
-> (State -> String) -> ([State] -> ShowS) -> Show State
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]
(Int -> ReadS State)
-> ReadS [State]
-> ReadPrec State
-> ReadPrec [State]
-> Read 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)
type ReportStart us = State -> us -> IO us
type ReportProblem us = Maybe SrcLoc -> String -> State -> us -> IO us
type Path = [Node]
data Node = ListItem Int | Label String
deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
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
(Int -> Node -> ShowS)
-> (Node -> String) -> (Path -> ShowS) -> Show Node
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
(Int -> ReadS Node)
-> ReadS Path -> ReadPrec Node -> ReadPrec Path -> Read Node
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)
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 =
[[Path]] -> [Path]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Test -> Path -> [Path]
tcp Test
t (Int -> Node
ListItem Int
n Node -> Path -> Path
forall a. a -> [a] -> [a]
: Path
p) | (Test
t,Int
n) <- [Test] -> [Int] -> [(Test, Int)]
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 Node -> Path -> Path
forall a. a -> [a] -> [a]
: Path
p)
testCaseCount :: Test -> Int
testCaseCount :: Test -> Int
testCaseCount (TestCase Assertion
_) = Int
1
testCaseCount (TestList [Test]
ts) = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Test -> Int) -> [Test] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Test -> Int
testCaseCount [Test]
ts)
testCaseCount (TestLabel String
_ Test
t) = Test -> Int
testCaseCount Test
t
performTest :: ReportStart us
-> ReportProblem us
-> ReportProblem us
-> us
-> Test
-> IO (Counts, us)
performTest :: 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
Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Path -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (State -> Path
path State
ss')) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$ String -> Assertion
forall a. HasCallStack => String -> a
error String
"performTest: Final path is nonnull"
(Counts, us) -> IO (Counts, us)
forall (m :: * -> *) a. Monad m => a -> m a
return (State -> Counts
counts State
ss', us
us')
where
initState :: State
initState = State :: Path -> Counts -> State
State{ path :: Path
path = [], counts :: Counts
counts = Counts
initCounts }
initCounts :: Counts
initCounts = Counts :: Int -> Int -> Int -> Int -> Counts
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
(State, us) -> IO (State, us)
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'
(State, us) -> IO (State, 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'
(State, us) -> IO (State, 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } }
ssF :: State
ssF = State
ss{ counts :: Counts
counts = Counts
c{ tried :: Int
tried = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, failures :: Int
failures = Counts -> Int
failures Counts
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } }
ssE :: State
ssE = State
ss{ counts :: Counts
counts = Counts
c{ tried :: Int
tried = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, errors :: Int
errors = Counts -> Int
errors Counts
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 } }
pt State
ss us
us (TestList [Test]
ts) = ((State, us) -> (Test, Int) -> IO (State, us))
-> (State, us) -> [(Test, Int)] -> IO (State, us)
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) ([Test] -> [Int] -> [(Test, Int)]
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
(State, us) -> IO (State, us)
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 Node -> Path -> Path
forall a. a -> [a] -> [a]
: Path
path0 }