{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module      : Test.Tasty.KAT
-- License     : MIT
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : Good
--
-- Tasty support for KAT (Known Answer Tests)
--
module Test.Tasty.KAT
    (
    -- * Run tests
      testKatDetailed
    , testKatGrouped
    -- * Load KAT resources
    , 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
            --nbGroups = fromIntegral $ length groupTests
            --yieldProgress $ Progress { progressText = groupName, progressPercent = fromIntegral tstNb / nbGroups  }

    testOptions :: Tagged TestKatGroup [OptionDescription]
testOptions = [OptionDescription] -> Tagged TestKatGroup [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | run one tasty test per vectors in each groups
--
-- This is useful to have detailed output on what failed
-- and what succeeded. For a more concise output, use
-- 'testKatGrouped'
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 = -- singleTest name $ mkTestKat resource 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)

-- | run one tasty test per group
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 = -- singleTest name $ mkTestKat resource 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)

-- | Read a KAT file into values that will be used for KATs tests
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