module Test.Tasty.Run
( Status(..)
, StatusMap
, launchTestTree
) where
import qualified Data.IntMap as IntMap
import qualified Data.Sequence as Seq
import qualified Data.Foldable as F
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Reader
import Control.Monad.Trans.Either
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)
data Resource r
= NotCreated
| FailedToCreate SomeException
| Created r
data Initializer
= forall res . Initializer
(IO res)
(MVar (Resource res))
data Finalizer
= forall res . Finalizer
(res -> IO ())
(MVar (Resource res))
(MVar Int)
executeTest
:: ((Progress -> IO ()) -> IO Result)
-> TVar Status
-> Seq.Seq Initializer
-> Seq.Seq Finalizer
-> IO ()
executeTest action statusVar inits fins =
handle (atomically . writeTVar statusVar . Exception) $ do
resultOrExcn <- runEitherT $ do
F.forM_ inits $ \(Initializer doInit initVar) -> EitherT $
modifyMVar initVar $ \resStatus ->
case resStatus of
NotCreated -> do
mbRes <- try doInit
case mbRes of
Right res -> return (Created res, Right ())
Left ex -> return (FailedToCreate ex, Left ex)
Created {} -> return (resStatus, Right ())
FailedToCreate ex -> return (resStatus, Left ex)
EitherT . try $
action yieldProgress
mbExcn <- liftM getFirst . execWriterT . getApp $
flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) ->
AppMonoid $ do
mbExcn <-
liftIO $ modifyMVar finishVar $ \nUsers -> do
let nUsers' = nUsers 1
mbExcn <-
if nUsers' == 0
then do
resStatus <- readMVar initVar
case resStatus of
Created res ->
either
(\ex -> Just ex)
(\_ -> Nothing)
<$> try (doRelease res)
_ -> return Nothing
else return Nothing
return (nUsers', mbExcn)
tell $ First mbExcn
atomically . writeTVar statusVar $
case resultOrExcn <* maybe (return ()) Left mbExcn of
Left ex -> Exception ex
Right r -> Done r
where
yieldProgress progress =
atomically $ writeTVar statusVar $ Executing progress
type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer)
createTestActions :: OptionSet -> TestTree -> IO [(IO (), TVar Status)]
createTestActions opts tree =
liftM (map (first ($ (Seq.empty, Seq.empty)))) $
execWriterT $ getApp $
(foldTestTree
runSingleTest
(const id)
addInitAndRelease
opts
tree
:: AppMonoid (WriterT [(InitFinPair -> IO (), TVar Status)] IO))
where
runSingleTest opts _ test = AppMonoid $ do
statusVar <- liftIO $ atomically $ newTVar NotStarted
let
act (inits, fins) =
executeTest (run opts test) statusVar inits fins
tell [(act, statusVar)]
addInitAndRelease (ResourceSpec doInit doRelease) a =
AppMonoid . WriterT . fmap ((,) ()) $ do
tests <- execWriterT $ getApp a
let ntests = length tests
initVar <- newMVar NotCreated
finishVar <- newMVar ntests
let
ini = Initializer doInit initVar
fin = Finalizer doRelease initVar finishVar
return $ map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) 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)