module Test.Tasty.Run
( Status(..)
, StatusMap
, Runner
, execRunner
, launchTestTree
) where
import qualified Data.IntMap as IntMap
import Data.Maybe
import Data.Typeable
import Control.Monad.State
import Control.Concurrent.STM
import Control.Exception
import Test.Tasty.Core
import Test.Tasty.Parallel
import Test.Tasty.Options
import Test.Tasty.CoreOptions
data Status
= NotStarted
| Executing Progress
| Exception SomeException
| Done Result
data TestMap = TestMap
!Int
!(IntMap.IntMap (IO (), TVar Status))
type StatusMap = IntMap.IntMap (TVar Status)
type Runner = OptionSet -> TestTree -> StatusMap -> IO Bool
executeTest
:: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> IO ()
executeTest action statusVar = do
result <- handleExceptions $
action yieldProgress
atomically $ writeTVar statusVar result
where
yieldProgress progress =
atomically $ writeTVar statusVar $ Executing progress
handleExceptions a = do
resultOrException <- try a
case resultOrException of
Left e
| Just async <- fromException e
-> throwIO (async :: AsyncException)
| otherwise
-> return $ Exception e
Right result -> return $ Done result
createTestMap :: OptionSet -> TestTree -> IO TestMap
createTestMap opts tree =
flip execStateT (TestMap 0 IntMap.empty) $ getApp $
foldTestTree
runSingleTest
(const id)
opts
tree
where
runSingleTest opts _ test = AppMonoid $ do
statusVar <- liftIO $ atomically $ newTVar NotStarted
let
act =
executeTest (run opts test) statusVar
TestMap ix tmap <- get
let
tmap' = IntMap.insert ix (act, statusVar) tmap
ix' = ix+1
put $! TestMap ix' tmap'
launchTests :: Int -> TestMap -> IO ()
launchTests threads (TestMap _ tmap) =
runInParallel threads $ map fst $ IntMap.elems tmap
launchTestTree :: OptionSet -> TestTree -> IO StatusMap
launchTestTree opts tree = do
tmap@(TestMap _ smap) <- createTestMap opts tree
let NumThreads numTheads = lookupOption opts
launchTests numTheads tmap
return $ fmap snd smap
execRunner :: Runner -> OptionSet -> TestTree -> IO Bool
execRunner runner opts testTree =
runner opts testTree =<< launchTestTree opts testTree