{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Test.Tasty.Lua
(
pushModule
, testLuaFile
, translateResultsFromFile
, pathFailure
, registerArbitrary
)
where
import Control.Exception (SomeException, try)
import Data.Bifunctor (first)
import Data.List (intercalate)
import HsLua.Core (LuaE, LuaError)
import Test.Tasty (TestName, TestTree)
import Test.Tasty.Providers (IsTest (..), singleTest, testFailed, testPassed)
import Test.Tasty.Lua.Arbitrary (registerArbitrary)
import Test.Tasty.Lua.Module (pushModule)
import Test.Tasty.Lua.Core (Outcome (..), ResultTree (..), UnnamedTree (..),
runTastyFile)
import Test.Tasty.Lua.Translate (pathFailure, translateResultsFromFile)
#if !MIN_VERSION_base(4,12,0)
import Data.Semigroup (Semigroup ((<>)))
#endif
testLuaFile :: forall e. LuaError e
=> (forall a. LuaE e a -> IO a)
-> TestName
-> FilePath
-> TestTree
testLuaFile :: (forall a. LuaE e a -> IO a) -> TestName -> TestName -> TestTree
testLuaFile runLua :: forall a. LuaE e a -> IO a
runLua name :: TestName
name fp :: TestName
fp =
let testAction :: TestCase
testAction = IO ResultSummary -> TestCase
TestCase (IO ResultSummary -> TestCase) -> IO ResultSummary -> TestCase
forall a b. (a -> b) -> a -> b
$ do
Either TestName [ResultTree]
eitherResult <- LuaE e (Either TestName [ResultTree])
-> IO (Either TestName [ResultTree])
forall a. LuaE e a -> IO a
runLua (TestName -> LuaE e (Either TestName [ResultTree])
forall e.
LuaError e =>
TestName -> LuaE e (Either TestName [ResultTree])
runTastyFile @e TestName
fp)
ResultSummary -> IO ResultSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ResultSummary -> IO ResultSummary)
-> ResultSummary -> IO ResultSummary
forall a b. (a -> b) -> a -> b
$ case Either TestName [ResultTree]
eitherResult of
Left errMsg :: TestName
errMsg -> [FailureInfo] -> ResultSummary
FailureSummary [([TestName
name], TestName
errMsg)]
Right result :: [ResultTree]
result -> [ResultTree] -> ResultSummary
summarize [ResultTree]
result
in TestName -> TestCase -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
singleTest TestName
name TestCase
testAction
newtype TestCase = TestCase (IO ResultSummary)
instance IsTest TestCase where
run :: OptionSet -> TestCase -> (Progress -> IO ()) -> IO Result
run _ (TestCase action :: IO ResultSummary
action) _ = do
Either SomeException ResultSummary
result <- IO ResultSummary -> IO (Either SomeException ResultSummary)
forall e a. Exception e => IO a -> IO (Either e a)
try IO ResultSummary
action
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
$ case Either SomeException ResultSummary
result of
Left e :: SomeException
e -> TestName -> Result
testFailed (SomeException -> TestName
forall a. Show a => a -> TestName
show (SomeException
e :: SomeException))
Right summary :: ResultSummary
summary -> case ResultSummary
summary of
SuccessSummary n :: Int
n ->
TestName -> Result
testPassed (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ "+++ Success: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ Int -> TestName
forall a. Show a => a -> TestName
show Int
n TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ " Lua tests passed"
FailureSummary fails :: [FailureInfo]
fails ->
TestName -> Result
testFailed (TestName -> Result) -> TestName -> Result
forall a b. (a -> b) -> a -> b
$ (FailureInfo -> TestName) -> [FailureInfo] -> TestName
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FailureInfo -> TestName
stringifyFailureGist [FailureInfo]
fails
testOptions :: Tagged TestCase [OptionDescription]
testOptions = [OptionDescription] -> Tagged TestCase [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return []
summarize :: [ResultTree] -> ResultSummary
summarize :: [ResultTree] -> ResultSummary
summarize = (ResultTree -> ResultSummary -> ResultSummary)
-> ResultSummary -> [ResultTree] -> ResultSummary
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ResultSummary -> ResultSummary -> ResultSummary
forall a. Semigroup a => a -> a -> a
(<>) (ResultSummary -> ResultSummary -> ResultSummary)
-> (ResultTree -> ResultSummary)
-> ResultTree
-> ResultSummary
-> ResultSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultTree -> ResultSummary
collectSummary) (Int -> ResultSummary
SuccessSummary 0)
type LuaErrorMessage = String
type FailureInfo = ([TestName], LuaErrorMessage)
data ResultSummary
= SuccessSummary Int
| FailureSummary [FailureInfo]
stringifyFailureGist :: FailureInfo -> String
stringifyFailureGist :: FailureInfo -> TestName
stringifyFailureGist (names :: [TestName]
names, msg :: TestName
msg) =
TestName -> [TestName] -> TestName
forall a. [a] -> [[a]] -> [a]
intercalate " // " [TestName]
names TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ ":\n" TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
msg TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ "\n\n"
collectSummary :: ResultTree -> ResultSummary
collectSummary :: ResultTree -> ResultSummary
collectSummary (ResultTree name :: TestName
name tree :: UnnamedTree
tree) =
case UnnamedTree
tree of
SingleTest Success -> Int -> ResultSummary
SuccessSummary 1
SingleTest (Failure msg :: TestName
msg) -> [FailureInfo] -> ResultSummary
FailureSummary [([TestName
name], TestName
msg)]
TestGroup subtree :: [ResultTree]
subtree -> (ResultTree -> ResultSummary) -> [ResultTree] -> ResultSummary
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TestName -> ResultSummary -> ResultSummary
addGroup TestName
name (ResultSummary -> ResultSummary)
-> (ResultTree -> ResultSummary) -> ResultTree -> ResultSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultTree -> ResultSummary
collectSummary)
[ResultTree]
subtree
addGroup :: TestName -> ResultSummary -> ResultSummary
addGroup :: TestName -> ResultSummary -> ResultSummary
addGroup name :: TestName
name (FailureSummary fs :: [FailureInfo]
fs) = [FailureInfo] -> ResultSummary
FailureSummary ((FailureInfo -> FailureInfo) -> [FailureInfo] -> [FailureInfo]
forall a b. (a -> b) -> [a] -> [b]
map (([TestName] -> [TestName]) -> FailureInfo -> FailureInfo
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TestName
nameTestName -> [TestName] -> [TestName]
forall a. a -> [a] -> [a]
:)) [FailureInfo]
fs)
addGroup _name :: TestName
_name summary :: ResultSummary
summary = ResultSummary
summary
instance Semigroup ResultSummary where
(SuccessSummary n :: Int
n) <> :: ResultSummary -> ResultSummary -> ResultSummary
<> (SuccessSummary m :: Int
m) = Int -> ResultSummary
SuccessSummary (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
m)
(SuccessSummary _) <> (FailureSummary fs :: [FailureInfo]
fs) = [FailureInfo] -> ResultSummary
FailureSummary [FailureInfo]
fs
(FailureSummary fs :: [FailureInfo]
fs) <> (SuccessSummary _) = [FailureInfo] -> ResultSummary
FailureSummary [FailureInfo]
fs
(FailureSummary fs :: [FailureInfo]
fs) <> (FailureSummary gs :: [FailureInfo]
gs) = [FailureInfo] -> ResultSummary
FailureSummary ([FailureInfo]
fs [FailureInfo] -> [FailureInfo] -> [FailureInfo]
forall a. [a] -> [a] -> [a]
++ [FailureInfo]
gs)
instance Monoid ResultSummary where
mempty :: ResultSummary
mempty = Int -> ResultSummary
SuccessSummary 0
mappend :: ResultSummary -> ResultSummary -> ResultSummary
mappend = ResultSummary -> ResultSummary -> ResultSummary
forall a. Semigroup a => a -> a -> a
(<>)