{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Tasty.KAT
(
testKatDetailed
, testKatGrouped
, testKatLoad
, Resource(..)
, katLoaderSimple
, mapTestUnits
) where
import Control.Applicative
import Control.Exception
import Data.Typeable
import Test.Tasty (testGroup)
import Test.Tasty.Providers
import Test.Tasty.KAT.FileLoader
newtype Resource a = Resource [(String, [a])]
data TestKatSingle = TestKatSingle (IO Bool)
deriving Typeable
data TestKatGroup = TestKatGroup [(Int, IO Bool)]
deriving Typeable
data KatResult = KatFailed String | KatSuccess
deriving (Int -> KatResult -> ShowS
[KatResult] -> ShowS
KatResult -> String
(Int -> KatResult -> ShowS)
-> (KatResult -> String)
-> ([KatResult] -> ShowS)
-> Show KatResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KatResult] -> ShowS
$cshowList :: [KatResult] -> ShowS
show :: KatResult -> String
$cshow :: KatResult -> String
showsPrec :: Int -> KatResult -> ShowS
$cshowsPrec :: Int -> KatResult -> ShowS
Show,KatResult -> KatResult -> Bool
(KatResult -> KatResult -> Bool)
-> (KatResult -> KatResult -> Bool) -> Eq KatResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KatResult -> KatResult -> Bool
$c/= :: KatResult -> KatResult -> Bool
== :: KatResult -> KatResult -> Bool
$c== :: KatResult -> KatResult -> Bool
Eq)
tryResult :: IO Bool -> IO KatResult
tryResult :: IO Bool -> IO KatResult
tryResult IO Bool
f = do
Either SomeException Bool
er <- IO Bool -> IO (Either SomeException Bool)
forall e a. Exception e => IO a -> IO (Either e a)
try IO Bool
f
case Either SomeException Bool
er of
Left (SomeException
e :: SomeException)
| SomeException -> String
forall a. Show a => a -> String
show SomeException
e String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"<<timeout>>" -> SomeException -> IO KatResult
forall e a. Exception e => e -> IO a
throwIO SomeException
e
| Bool
otherwise -> KatResult -> IO KatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (KatResult -> IO KatResult) -> KatResult -> IO KatResult
forall a b. (a -> b) -> a -> b
$ String -> KatResult
KatFailed (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
Right Bool
r -> KatResult -> IO KatResult
forall (m :: * -> *) a. Monad m => a -> m a
return (KatResult -> IO KatResult) -> KatResult -> IO KatResult
forall a b. (a -> b) -> a -> b
$ if Bool
r then KatResult
KatSuccess else String -> KatResult
KatFailed String
"test failed"
instance IsTest TestKatSingle where
run :: OptionSet -> TestKatSingle -> (Progress -> IO ()) -> IO Result
run OptionSet
_ (TestKatSingle IO Bool
tst) Progress -> IO ()
_ = do
KatResult
r <- IO Bool -> IO KatResult
tryResult IO Bool
tst
case KatResult
r of
KatResult
KatSuccess -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed String
""
KatFailed String
s -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed String
s
testOptions :: Tagged TestKatSingle [OptionDescription]
testOptions = [OptionDescription] -> Tagged TestKatSingle [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return []
instance IsTest TestKatGroup where
run :: OptionSet -> TestKatGroup -> (Progress -> IO ()) -> IO Result
run OptionSet
_ (TestKatGroup [(Int, IO Bool)]
groupTests) Progress -> IO ()
_ = do
(Int
success, Int
failed) <- [KatResult] -> (Int, Int)
summarize ([KatResult] -> (Int, Int)) -> IO [KatResult] -> IO (Int, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int, IO Bool) -> IO KatResult)
-> [(Int, IO Bool)] -> IO [KatResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Int, IO Bool) -> IO KatResult
runGroup [(Int, IO Bool)]
groupTests
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
(if Int
failed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then String -> Result
testPassed else String -> Result
testFailed)
(if Int
failed Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then (Int -> String
forall a. Show a => a -> String
show Int
failed) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests failed on " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
failed Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
success)
else (Int -> String
forall a. Show a => a -> String
show Int
success) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" tests succeed")
where summarize :: [KatResult] -> (Int, Int)
summarize :: [KatResult] -> (Int, Int)
summarize = ((Int, Int) -> KatResult -> (Int, Int))
-> (Int, Int) -> [KatResult] -> (Int, Int)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\(Int
s,Int
f) KatResult
k -> if KatResult
k KatResult -> KatResult -> Bool
forall a. Eq a => a -> a -> Bool
== KatResult
KatSuccess then (Int
sInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
f) else (Int
s,Int
fInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) (Int
0,Int
0)
runGroup :: (Int, IO Bool) -> IO KatResult
runGroup :: (Int, IO Bool) -> IO KatResult
runGroup (Int
_, IO Bool
tst) = IO Bool -> IO KatResult
tryResult IO Bool
tst
testOptions :: Tagged TestKatGroup [OptionDescription]
testOptions = [OptionDescription] -> Tagged TestKatGroup [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return []
testKatDetailed :: TestName
-> Resource a
-> (String -> a -> IO Bool)
-> TestTree
testKatDetailed :: String -> Resource a -> (String -> a -> IO Bool) -> TestTree
testKatDetailed String
name (Resource [(String, [a])]
groups) String -> a -> IO Bool
test =
String -> [TestTree] -> TestTree
testGroup String
name ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ ((String, [a]) -> TestTree) -> [(String, [a])] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (String, [a]) -> TestTree
groupToTests [(String, [a])]
groups
where groupToTests :: (String, [a]) -> TestTree
groupToTests (String
groupName, [a]
vectors) =
String -> [TestTree] -> TestTree
testGroup String
groupName ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> TestTree) -> [(Int, a)] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, a
v) -> String -> TestKatSingle -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest (Int -> String
forall a. Show a => a -> String
show (Int
i :: Int)) (IO Bool -> TestKatSingle
TestKatSingle (IO Bool -> TestKatSingle) -> IO Bool -> TestKatSingle
forall a b. (a -> b) -> a -> b
$ String -> a -> IO Bool
test String
groupName a
v)) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
vectors)
testKatGrouped :: TestName
-> Resource a
-> (String -> a -> IO Bool)
-> TestTree
testKatGrouped :: String -> Resource a -> (String -> a -> IO Bool) -> TestTree
testKatGrouped String
name (Resource [(String, [a])]
groups) String -> a -> IO Bool
test =
String -> [TestTree] -> TestTree
testGroup String
name ([TestTree] -> TestTree) -> [TestTree] -> TestTree
forall a b. (a -> b) -> a -> b
$ ((String, [a]) -> TestTree) -> [(String, [a])] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (String, [a]) -> TestTree
groupToTests [(String, [a])]
groups
where groupToTests :: (String, [a]) -> TestTree
groupToTests (String
groupName, [a]
vectors) =
String -> TestKatGroup -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest String
groupName (TestKatGroup -> TestTree) -> TestKatGroup -> TestTree
forall a b. (a -> b) -> a -> b
$ [(Int, IO Bool)] -> TestKatGroup
TestKatGroup ([(Int, IO Bool)] -> TestKatGroup)
-> [(Int, IO Bool)] -> TestKatGroup
forall a b. (a -> b) -> a -> b
$ ((Int, a) -> (Int, IO Bool)) -> [(Int, a)] -> [(Int, IO Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, a
v) -> (Int
i, String -> a -> IO Bool
test String
groupName a
v)) ([Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
vectors)
testKatLoad :: FilePath
-> ([String] -> [(String, [a])])
-> IO (Resource a)
testKatLoad :: String -> ([String] -> [(String, [a])]) -> IO (Resource a)
testKatLoad String
filepath [String] -> [(String, [a])]
transform = [(String, [a])] -> Resource a
forall a. [(String, [a])] -> Resource a
Resource ([(String, [a])] -> Resource a)
-> (String -> [(String, [a])]) -> String -> Resource a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [(String, [a])]
transform ([String] -> [(String, [a])])
-> (String -> [String]) -> String -> [(String, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> Resource a) -> IO String -> IO (Resource a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
readFile String
filepath