module Test.Tasty.Run
( Status(..)
, StatusMap
, launchTestTree
) where
import qualified Data.IntMap as IntMap
import Control.Monad.State
import Control.Monad.Writer
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Applicative
import Control.Arrow
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
type StatusMap = IntMap.IntMap (TVar Status)
executeTest
:: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> IO ()
-> IO ()
executeTest action statusVar fin = do
result <- handleExceptions $
action yieldProgress
fin `finally`
(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
createTestActions :: OptionSet -> TestTree -> IO [(IO (), TVar Status)]
createTestActions opts tree =
liftM (map $ first $ ($ return ())) $
execWriterT $ getApp $
foldTestTree
runSingleTest
(const id)
addInitAndRelease
opts
tree
where
runSingleTest opts _ test = AppMonoid $ do
statusVar <- liftIO $ atomically $ newTVar NotStarted
let
act =
executeTest (run opts test) statusVar
tell [(act, statusVar)]
addInitAndRelease (ResourceSpec doInit doRelease) a =
AppMonoid . WriterT . fmap ((,) ()) $ do
tests <- execWriterT $ getApp a
let ntests = length tests
initVar <- newMVar Nothing
finishVar <- newMVar ntests
let
init = do
modifyMVar initVar $ \mbRes ->
case mbRes of
Nothing -> do
res <- doInit
return (Just res, res)
Just res -> return (mbRes, res)
release x = do
modifyMVar_ finishVar $ \nUsers -> do
let nUsers' = nUsers 1
when (nUsers' == 0) $
doRelease x
return nUsers'
return $ map (first $ \t fin' -> init >>= \r -> t (release r >> fin')) tests
launchTestTree :: OptionSet -> TestTree -> IO StatusMap
launchTestTree opts tree = do
testActions <- createTestActions opts tree
let NumThreads numTheads = lookupOption opts
runInParallel numTheads (fst <$> testActions)
return $ IntMap.fromList $ zip [0..] (snd <$> testActions)