{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ConstraintKinds #-}
#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif
module Test.Hspec.Core.Runner.Eval (
EvalConfig(..)
, EvalTree
, EvalItem(..)
, runFormatter
, resultItemIsFailure
#ifdef TEST
, runSequentially
#endif
) where
import Prelude ()
import Test.Hspec.Core.Compat hiding (Monad)
import qualified Test.Hspec.Core.Compat as M
import qualified Control.Exception as E
import Control.Concurrent
import Control.Concurrent.Async hiding (cancel)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.IO.Class as M
import Control.Monad.Trans.State hiding (State, state)
import Control.Monad.Trans.Class
import Test.Hspec.Core.Util
import Test.Hspec.Core.Spec (Tree(..), Progress, FailureReason(..), Result(..), ResultStatus(..), ProgressCallback)
import Test.Hspec.Core.Timer
import Test.Hspec.Core.Format (Format(..))
import qualified Test.Hspec.Core.Format as Format
import Test.Hspec.Core.Clock
import Test.Hspec.Core.Example.Location
import Test.Hspec.Core.Example (safeEvaluate)
type Monad m = (Functor m, Applicative m, M.Monad m)
type MonadIO m = (Monad m, M.MonadIO m)
data EvalConfig m = EvalConfig {
EvalConfig m -> Format m
evalConfigFormat :: Format m
, EvalConfig m -> Int
evalConfigConcurrentJobs :: Int
, EvalConfig m -> Bool
evalConfigFastFail :: Bool
}
data State m = State {
State m -> EvalConfig m
stateConfig :: EvalConfig m
, State m -> [(Path, Item)]
stateResults :: [(Path, Format.Item)]
}
type EvalM m = StateT (State m) m
addResult :: Monad m => Path -> Format.Item -> EvalM m ()
addResult :: Path -> Item -> EvalM m ()
addResult Path
path Item
item = (State m -> State m) -> EvalM m ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((State m -> State m) -> EvalM m ())
-> (State m -> State m) -> EvalM m ()
forall a b. (a -> b) -> a -> b
$ \ State m
state -> State m
state {stateResults :: [(Path, Item)]
stateResults = (Path
path, Item
item) (Path, Item) -> [(Path, Item)] -> [(Path, Item)]
forall a. a -> [a] -> [a]
: State m -> [(Path, Item)]
forall (m :: * -> *). State m -> [(Path, Item)]
stateResults State m
state}
getFormat :: Monad m => (Format m -> a) -> EvalM m a
getFormat :: (Format m -> a) -> EvalM m a
getFormat Format m -> a
format = (State m -> a) -> EvalM m a
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Format m -> a
format (Format m -> a) -> (State m -> Format m) -> State m -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalConfig m -> Format m
forall (m :: * -> *). EvalConfig m -> Format m
evalConfigFormat (EvalConfig m -> Format m)
-> (State m -> EvalConfig m) -> State m -> Format m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State m -> EvalConfig m
forall (m :: * -> *). State m -> EvalConfig m
stateConfig)
reportItem :: Monad m => Path -> Format.Item -> EvalM m ()
reportItem :: Path -> Item -> EvalM m ()
reportItem Path
path Item
item = do
Path -> Item -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> Item -> EvalM m ()
addResult Path
path Item
item
Path -> Item -> m ()
format <- (Format m -> Path -> Item -> m ())
-> EvalM m (Path -> Item -> m ())
forall (m :: * -> *) a. Monad m => (Format m -> a) -> EvalM m a
getFormat Format m -> Path -> Item -> m ()
forall (m :: * -> *). Format m -> Path -> Item -> m ()
formatItem
m () -> EvalM m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Path -> Item -> m ()
format Path
path Item
item)
failureItem :: Maybe Location -> Seconds -> String -> FailureReason -> Format.Item
failureItem :: Maybe Location -> Seconds -> String -> FailureReason -> Item
failureItem Maybe Location
loc Seconds
duration String
info FailureReason
err = Maybe Location -> Seconds -> String -> Result -> Item
Format.Item Maybe Location
loc Seconds
duration String
info (FailureReason -> Result
Format.Failure FailureReason
err)
reportResult :: Monad m => Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()
reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()
reportResult Path
path Maybe Location
loc (Seconds
duration, Result
result) = do
case Result
result of
Result String
info ResultStatus
status -> case ResultStatus
status of
ResultStatus
Success -> Path -> Item -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> Item -> EvalM m ()
reportItem Path
path (Maybe Location -> Seconds -> String -> Result -> Item
Format.Item Maybe Location
loc Seconds
duration String
info Result
Format.Success)
Pending Maybe Location
loc_ Maybe String
reason -> Path -> Item -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> Item -> EvalM m ()
reportItem Path
path (Maybe Location -> Seconds -> String -> Result -> Item
Format.Item (Maybe Location
loc_ Maybe Location -> Maybe Location -> Maybe Location
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Location
loc) Seconds
duration String
info (Result -> Item) -> Result -> Item
forall a b. (a -> b) -> a -> b
$ Maybe String -> Result
Format.Pending Maybe String
reason)
Failure Maybe Location
loc_ err :: FailureReason
err@(Error Maybe String
_ SomeException
e) -> Path -> Item -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> Item -> EvalM m ()
reportItem Path
path (Maybe Location -> Seconds -> String -> FailureReason -> Item
failureItem (Maybe Location
loc_ Maybe Location -> Maybe Location -> Maybe Location
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SomeException -> Maybe Location
extractLocation SomeException
e Maybe Location -> Maybe Location -> Maybe Location
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Location
loc) Seconds
duration String
info FailureReason
err)
Failure Maybe Location
loc_ FailureReason
err -> Path -> Item -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> Item -> EvalM m ()
reportItem Path
path (Maybe Location -> Seconds -> String -> FailureReason -> Item
failureItem (Maybe Location
loc_ Maybe Location -> Maybe Location -> Maybe Location
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Location
loc) Seconds
duration String
info FailureReason
err)
groupStarted :: Monad m => Path -> EvalM m ()
groupStarted :: Path -> EvalM m ()
groupStarted Path
path = do
Path -> m ()
format <- (Format m -> Path -> m ()) -> EvalM m (Path -> m ())
forall (m :: * -> *) a. Monad m => (Format m -> a) -> EvalM m a
getFormat Format m -> Path -> m ()
forall (m :: * -> *). Format m -> Path -> m ()
formatGroupStarted
m () -> EvalM m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> EvalM m ()) -> m () -> EvalM m ()
forall a b. (a -> b) -> a -> b
$ Path -> m ()
format Path
path
groupDone :: Monad m => Path -> EvalM m ()
groupDone :: Path -> EvalM m ()
groupDone Path
path = do
Path -> m ()
format <- (Format m -> Path -> m ()) -> EvalM m (Path -> m ())
forall (m :: * -> *) a. Monad m => (Format m -> a) -> EvalM m a
getFormat Format m -> Path -> m ()
forall (m :: * -> *). Format m -> Path -> m ()
formatGroupDone
m () -> EvalM m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> EvalM m ()) -> m () -> EvalM m ()
forall a b. (a -> b) -> a -> b
$ Path -> m ()
format Path
path
data EvalItem = EvalItem {
EvalItem -> String
evalItemDescription :: String
, EvalItem -> Maybe Location
evalItemLocation :: Maybe Location
, EvalItem -> Bool
evalItemParallelize :: Bool
, EvalItem -> ProgressCallback -> IO Result
evalItemAction :: ProgressCallback -> IO Result
}
type EvalTree = Tree (IO ()) EvalItem
runEvalM :: Monad m => EvalConfig m -> EvalM m () -> m (State m)
runEvalM :: EvalConfig m -> EvalM m () -> m (State m)
runEvalM EvalConfig m
config EvalM m ()
action = EvalM m () -> State m -> m (State m)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT EvalM m ()
action (EvalConfig m -> [(Path, Item)] -> State m
forall (m :: * -> *). EvalConfig m -> [(Path, Item)] -> State m
State EvalConfig m
config [])
runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO ([(Path, Format.Item)])
runFormatter :: EvalConfig m -> [EvalTree] -> IO [(Path, Item)]
runFormatter EvalConfig m
config [EvalTree]
specs = do
let
start :: IO [RunningTree_ m]
start = Int -> [EvalTree] -> IO [RunningTree_ m]
forall (m :: * -> *).
MonadIO m =>
Int -> [EvalTree] -> IO [RunningTree_ m]
parallelizeTree (EvalConfig m -> Int
forall (m :: * -> *). EvalConfig m -> Int
evalConfigConcurrentJobs EvalConfig m
config) [EvalTree]
specs
cancel :: [Tree (IO ()) (Async a, b)] -> IO ()
cancel = [Async a] -> IO ()
forall a. [Async a] -> IO ()
cancelMany ([Async a] -> IO ())
-> ([Tree (IO ()) (Async a, b)] -> [Async a])
-> [Tree (IO ()) (Async a, b)]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (IO ()) (Async a) -> [Async a])
-> [Tree (IO ()) (Async a)] -> [Async a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree (IO ()) (Async a) -> [Async a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ([Tree (IO ()) (Async a)] -> [Async a])
-> ([Tree (IO ()) (Async a, b)] -> [Tree (IO ()) (Async a)])
-> [Tree (IO ()) (Async a, b)]
-> [Async a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree (IO ()) (Async a, b) -> Tree (IO ()) (Async a))
-> [Tree (IO ()) (Async a, b)] -> [Tree (IO ()) (Async a)]
forall a b. (a -> b) -> [a] -> [b]
map (((Async a, b) -> Async a)
-> Tree (IO ()) (Async a, b) -> Tree (IO ()) (Async a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Async a, b) -> Async a
forall a b. (a, b) -> a
fst)
IO [RunningTree_ m]
-> ([RunningTree_ m] -> IO ())
-> ([RunningTree_ m] -> IO [(Path, Item)])
-> IO [(Path, Item)]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO [RunningTree_ m]
start [RunningTree_ m] -> IO ()
forall a b. [Tree (IO ()) (Async a, b)] -> IO ()
cancel (([RunningTree_ m] -> IO [(Path, Item)]) -> IO [(Path, Item)])
-> ([RunningTree_ m] -> IO [(Path, Item)]) -> IO [(Path, Item)]
forall a b. (a -> b) -> a -> b
$ \ [RunningTree_ m]
runningSpecs -> do
Seconds -> (IO Bool -> IO [(Path, Item)]) -> IO [(Path, Item)]
forall a. Seconds -> (IO Bool -> IO a) -> IO a
withTimer Seconds
0.05 ((IO Bool -> IO [(Path, Item)]) -> IO [(Path, Item)])
-> (IO Bool -> IO [(Path, Item)]) -> IO [(Path, Item)]
forall a b. (a -> b) -> a -> b
$ \ IO Bool
timer -> do
State m
state <- Format m -> forall a. m a -> IO a
forall (m :: * -> *). Format m -> forall a. m a -> IO a
formatRun Format m
format (m (State m) -> IO (State m)) -> m (State m) -> IO (State m)
forall a b. (a -> b) -> a -> b
$ do
EvalConfig m -> EvalM m () -> m (State m)
forall (m :: * -> *).
Monad m =>
EvalConfig m -> EvalM m () -> m (State m)
runEvalM EvalConfig m
config (EvalM m () -> m (State m)) -> EvalM m () -> m (State m)
forall a b. (a -> b) -> a -> b
$
[RunningTree m] -> EvalM m ()
forall (m :: * -> *). MonadIO m => [RunningTree m] -> EvalM m ()
run ([RunningTree m] -> EvalM m ()) -> [RunningTree m] -> EvalM m ()
forall a b. (a -> b) -> a -> b
$ (RunningTree_ m -> RunningTree m)
-> [RunningTree_ m] -> [RunningTree m]
forall a b. (a -> b) -> [a] -> [b]
map (((Async (), Item ((Progress -> m ()) -> m (Seconds, Result)))
-> Item (Path -> m (Seconds, Result)))
-> RunningTree_ m -> RunningTree m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((((Progress -> m ()) -> m (Seconds, Result))
-> Path -> m (Seconds, Result))
-> Item ((Progress -> m ()) -> m (Seconds, Result))
-> Item (Path -> m (Seconds, Result))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Progress -> m ()) -> m (Seconds, Result))
-> (Path -> Progress -> m ()) -> Path -> m (Seconds, Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> Path -> Progress -> m ()
reportProgress IO Bool
timer) (Item ((Progress -> m ()) -> m (Seconds, Result))
-> Item (Path -> m (Seconds, Result)))
-> ((Async (), Item ((Progress -> m ()) -> m (Seconds, Result)))
-> Item ((Progress -> m ()) -> m (Seconds, Result)))
-> (Async (), Item ((Progress -> m ()) -> m (Seconds, Result)))
-> Item (Path -> m (Seconds, Result))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Async (), Item ((Progress -> m ()) -> m (Seconds, Result)))
-> Item ((Progress -> m ()) -> m (Seconds, Result))
forall a b. (a, b) -> b
snd)) [RunningTree_ m]
runningSpecs
[(Path, Item)] -> IO [(Path, Item)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Path, Item)] -> [(Path, Item)]
forall a. [a] -> [a]
reverse ([(Path, Item)] -> [(Path, Item)])
-> [(Path, Item)] -> [(Path, Item)]
forall a b. (a -> b) -> a -> b
$ State m -> [(Path, Item)]
forall (m :: * -> *). State m -> [(Path, Item)]
stateResults State m
state)
where
format :: Format m
format = EvalConfig m -> Format m
forall (m :: * -> *). EvalConfig m -> Format m
evalConfigFormat EvalConfig m
config
reportProgress :: IO Bool -> Path -> Progress -> m ()
reportProgress :: IO Bool -> Path -> Progress -> m ()
reportProgress IO Bool
timer Path
path Progress
progress = do
Bool
r <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Bool
timer
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
r (Format m -> Path -> Progress -> m ()
forall (m :: * -> *). Format m -> Path -> Progress -> m ()
formatProgress Format m
format Path
path Progress
progress)
cancelMany :: [Async a] -> IO ()
cancelMany :: [Async a] -> IO ()
cancelMany [Async a]
asyncs = do
(Async a -> IO ()) -> [Async a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> IO ()
killThread (ThreadId -> IO ()) -> (Async a -> ThreadId) -> Async a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async a -> ThreadId
forall a. Async a -> ThreadId
asyncThreadId) [Async a]
asyncs
(Async a -> IO (Either SomeException a)) -> [Async a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async a -> IO (Either SomeException a)
forall a. Async a -> IO (Either SomeException a)
waitCatch [Async a]
asyncs
data Item a = Item {
Item a -> String
_itemDescription :: String
, Item a -> Maybe Location
_itemLocation :: Maybe Location
, Item a -> a
_itemAction :: a
} deriving a -> Item b -> Item a
(a -> b) -> Item a -> Item b
(forall a b. (a -> b) -> Item a -> Item b)
-> (forall a b. a -> Item b -> Item a) -> Functor Item
forall a b. a -> Item b -> Item a
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Item b -> Item a
$c<$ :: forall a b. a -> Item b -> Item a
fmap :: (a -> b) -> Item a -> Item b
$cfmap :: forall a b. (a -> b) -> Item a -> Item b
Functor
type Job m p a = (p -> m ()) -> m a
type RunningItem m = Item (Path -> m (Seconds, Result))
type RunningTree m = Tree (IO ()) (RunningItem m)
type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result)))
type RunningTree_ m = Tree (IO ()) (RunningItem_ m)
data Semaphore = Semaphore {
Semaphore -> IO ()
semaphoreWait :: IO ()
, Semaphore -> IO ()
semaphoreSignal :: IO ()
}
parallelizeTree :: MonadIO m => Int -> [EvalTree] -> IO [RunningTree_ m]
parallelizeTree :: Int -> [EvalTree] -> IO [RunningTree_ m]
parallelizeTree Int
n [EvalTree]
specs = do
QSem
sem <- Int -> IO QSem
newQSem Int
n
(EvalTree -> IO (RunningTree_ m))
-> [EvalTree] -> IO [RunningTree_ m]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((EvalItem -> IO (RunningItem_ m))
-> EvalTree -> IO (RunningTree_ m)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((EvalItem -> IO (RunningItem_ m))
-> EvalTree -> IO (RunningTree_ m))
-> (EvalItem -> IO (RunningItem_ m))
-> EvalTree
-> IO (RunningTree_ m)
forall a b. (a -> b) -> a -> b
$ QSem -> EvalItem -> IO (RunningItem_ m)
forall (m :: * -> *).
MonadIO m =>
QSem -> EvalItem -> IO (RunningItem_ m)
parallelizeItem QSem
sem) [EvalTree]
specs
parallelizeItem :: MonadIO m => QSem -> EvalItem -> IO (RunningItem_ m)
parallelizeItem :: QSem -> EvalItem -> IO (RunningItem_ m)
parallelizeItem QSem
sem EvalItem{Bool
String
Maybe Location
ProgressCallback -> IO Result
evalItemAction :: ProgressCallback -> IO Result
evalItemParallelize :: Bool
evalItemLocation :: Maybe Location
evalItemDescription :: String
evalItemAction :: EvalItem -> ProgressCallback -> IO Result
evalItemParallelize :: EvalItem -> Bool
evalItemLocation :: EvalItem -> Maybe Location
evalItemDescription :: EvalItem -> String
..} = do
(Async ()
asyncAction, Job m Progress (Seconds, Result)
evalAction) <- Semaphore
-> Bool
-> (ProgressCallback -> IO Result)
-> IO (Async (), Job m Progress (Seconds, Result))
forall (m :: * -> *) p a.
MonadIO m =>
Semaphore
-> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
parallelize (IO () -> IO () -> Semaphore
Semaphore (QSem -> IO ()
waitQSem QSem
sem) (QSem -> IO ()
signalQSem QSem
sem)) Bool
evalItemParallelize (IO Result -> IO Result
forall a. IO a -> IO a
interruptible (IO Result -> IO Result)
-> (ProgressCallback -> IO Result) -> ProgressCallback -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressCallback -> IO Result
evalItemAction)
RunningItem_ m -> IO (RunningItem_ m)
forall (m :: * -> *) a. Monad m => a -> m a
return (Async ()
asyncAction, String
-> Maybe Location
-> Job m Progress (Seconds, Result)
-> Item (Job m Progress (Seconds, Result))
forall a. String -> Maybe Location -> a -> Item a
Item String
evalItemDescription Maybe Location
evalItemLocation Job m Progress (Seconds, Result)
evalAction)
parallelize :: MonadIO m => Semaphore -> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
parallelize :: Semaphore
-> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
parallelize Semaphore
sem Bool
isParallelizable
| Bool
isParallelizable = Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
forall (m :: * -> *) p a.
MonadIO m =>
Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
runParallel Semaphore
sem
| Bool
otherwise = Job IO p a -> IO (Async (), Job m p (Seconds, a))
forall (m :: * -> *) p a.
MonadIO m =>
Job IO p a -> IO (Async (), Job m p (Seconds, a))
runSequentially
runSequentially :: MonadIO m => Job IO p a -> IO (Async (), Job m p (Seconds, a))
runSequentially :: Job IO p a -> IO (Async (), Job m p (Seconds, a))
runSequentially Job IO p a
action = do
MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
(Async ()
asyncAction, Job m p (Seconds, a)
evalAction) <- Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
forall (m :: * -> *) p a.
MonadIO m =>
Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
runParallel (IO () -> IO () -> Semaphore
Semaphore (MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
mvar) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) Job IO p a
action
(Async (), Job m p (Seconds, a))
-> IO (Async (), Job m p (Seconds, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Async ()
asyncAction, \ p -> m ()
notifyPartial -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()) m () -> m (Seconds, a) -> m (Seconds, a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Job m p (Seconds, a)
evalAction p -> m ()
notifyPartial)
data Parallel p a = Partial p | Return a
runParallel :: forall m p a. MonadIO m => Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
runParallel :: Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
runParallel Semaphore{IO ()
semaphoreSignal :: IO ()
semaphoreWait :: IO ()
semaphoreSignal :: Semaphore -> IO ()
semaphoreWait :: Semaphore -> IO ()
..} Job IO p a
action = do
MVar (Parallel p (Seconds, a))
mvar <- IO (MVar (Parallel p (Seconds, a)))
forall a. IO (MVar a)
newEmptyMVar
Async ()
asyncAction <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
E.bracket_ IO ()
semaphoreWait IO ()
semaphoreSignal (MVar (Parallel p (Seconds, a)) -> IO ()
worker MVar (Parallel p (Seconds, a))
mvar)
(Async (), Job m p (Seconds, a))
-> IO (Async (), Job m p (Seconds, a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Async ()
asyncAction, MVar (Parallel p (Seconds, a)) -> Job m p (Seconds, a)
eval MVar (Parallel p (Seconds, a))
mvar)
where
worker :: MVar (Parallel p (Seconds, a)) -> IO ()
worker MVar (Parallel p (Seconds, a))
mvar = do
let partialCallback :: p -> IO ()
partialCallback = MVar (Parallel p (Seconds, a)) -> Parallel p (Seconds, a) -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar (Parallel p (Seconds, a))
mvar (Parallel p (Seconds, a) -> IO ())
-> (p -> Parallel p (Seconds, a)) -> p -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p -> Parallel p (Seconds, a)
forall p a. p -> Parallel p a
Partial
(Seconds, a)
result <- IO a -> IO (Seconds, a)
forall a. IO a -> IO (Seconds, a)
measure (IO a -> IO (Seconds, a)) -> IO a -> IO (Seconds, a)
forall a b. (a -> b) -> a -> b
$ Job IO p a
action p -> IO ()
partialCallback
MVar (Parallel p (Seconds, a)) -> Parallel p (Seconds, a) -> IO ()
forall a. MVar a -> a -> IO ()
replaceMVar MVar (Parallel p (Seconds, a))
mvar ((Seconds, a) -> Parallel p (Seconds, a)
forall p a. a -> Parallel p a
Return (Seconds, a)
result)
eval :: MVar (Parallel p (Seconds, a)) -> (p -> m ()) -> m (Seconds, a)
eval :: MVar (Parallel p (Seconds, a)) -> Job m p (Seconds, a)
eval MVar (Parallel p (Seconds, a))
mvar p -> m ()
notifyPartial = do
Parallel p (Seconds, a)
r <- IO (Parallel p (Seconds, a)) -> m (Parallel p (Seconds, a))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MVar (Parallel p (Seconds, a)) -> IO (Parallel p (Seconds, a))
forall a. MVar a -> IO a
takeMVar MVar (Parallel p (Seconds, a))
mvar)
case Parallel p (Seconds, a)
r of
Partial p
p -> do
p -> m ()
notifyPartial p
p
MVar (Parallel p (Seconds, a)) -> Job m p (Seconds, a)
eval MVar (Parallel p (Seconds, a))
mvar p -> m ()
notifyPartial
Return (Seconds, a)
result -> (Seconds, a) -> m (Seconds, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds, a)
result
replaceMVar :: MVar a -> a -> IO ()
replaceMVar :: MVar a -> a -> IO ()
replaceMVar MVar a
mvar a
p = MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar a
mvar IO (Maybe a) -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
mvar a
p
run :: forall m. MonadIO m => [RunningTree m] -> EvalM m ()
run :: [RunningTree m] -> EvalM m ()
run [RunningTree m]
specs = do
Bool
fastFail <- (State m -> Bool) -> StateT (State m) m Bool
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (EvalConfig m -> Bool
forall (m :: * -> *). EvalConfig m -> Bool
evalConfigFastFail (EvalConfig m -> Bool)
-> (State m -> EvalConfig m) -> State m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State m -> EvalConfig m
forall (m :: * -> *). State m -> EvalConfig m
stateConfig)
Bool -> [EvalM m ()] -> EvalM m ()
forall (m :: * -> *). Monad m => Bool -> [EvalM m ()] -> EvalM m ()
sequenceActions Bool
fastFail ((RunningTree m -> [EvalM m ()]) -> [RunningTree m] -> [EvalM m ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RunningTree m -> [EvalM m ()]
foldSpec [RunningTree m]
specs)
where
foldSpec :: RunningTree m -> [EvalM m ()]
foldSpec :: RunningTree m -> [EvalM m ()]
foldSpec = FoldTree (IO ()) (Item (Path -> m (Seconds, Result))) (EvalM m ())
-> RunningTree m -> [EvalM m ()]
forall c a r. FoldTree c a r -> Tree c a -> [r]
foldTree FoldTree :: forall c a r.
(Path -> r)
-> (Path -> r)
-> ([String] -> c -> r)
-> ([String] -> a -> r)
-> FoldTree c a r
FoldTree {
onGroupStarted :: Path -> EvalM m ()
onGroupStarted = Path -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> EvalM m ()
groupStarted
, onGroupDone :: Path -> EvalM m ()
onGroupDone = Path -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> EvalM m ()
groupDone
, onCleanup :: [String] -> IO () -> EvalM m ()
onCleanup = [String] -> IO () -> EvalM m ()
runCleanup
, onLeafe :: [String] -> Item (Path -> m (Seconds, Result)) -> EvalM m ()
onLeafe = [String] -> Item (Path -> m (Seconds, Result)) -> EvalM m ()
evalItem
}
runCleanup :: [String] -> IO () -> EvalM m ()
runCleanup :: [String] -> IO () -> EvalM m ()
runCleanup [String]
groups IO ()
action = do
(Seconds, Result)
r <- IO (Seconds, Result) -> StateT (State m) m (Seconds, Result)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seconds, Result) -> StateT (State m) m (Seconds, Result))
-> IO (Seconds, Result) -> StateT (State m) m (Seconds, Result)
forall a b. (a -> b) -> a -> b
$ IO Result -> IO (Seconds, Result)
forall a. IO a -> IO (Seconds, a)
measure (IO Result -> IO (Seconds, Result))
-> IO Result -> IO (Seconds, Result)
forall a b. (a -> b) -> a -> b
$ IO Result -> IO Result
safeEvaluate (IO ()
action IO () -> IO Result -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> ResultStatus -> Result
Result String
"" ResultStatus
Success))
case (Seconds, Result)
r of
(Seconds
_, Result String
"" ResultStatus
Success) -> () -> EvalM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Seconds, Result)
_ -> Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()
forall (m :: * -> *).
Monad m =>
Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()
reportResult Path
path Maybe Location
forall a. Maybe a
Nothing (Seconds, Result)
r
where
path :: Path
path = ([String]
groups, String
"afterAll-hook")
evalItem :: [String] -> RunningItem m -> EvalM m ()
evalItem :: [String] -> Item (Path -> m (Seconds, Result)) -> EvalM m ()
evalItem [String]
groups (Item String
requirement Maybe Location
loc Path -> m (Seconds, Result)
action) = do
m (Seconds, Result) -> StateT (State m) m (Seconds, Result)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Path -> m (Seconds, Result)
action Path
path) StateT (State m) m (Seconds, Result)
-> ((Seconds, Result) -> EvalM m ()) -> EvalM m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()
forall (m :: * -> *).
Monad m =>
Path -> Maybe Location -> (Seconds, Result) -> EvalM m ()
reportResult Path
path Maybe Location
loc
where
path :: Path
path :: Path
path = ([String]
groups, String
requirement)
data FoldTree c a r = FoldTree {
FoldTree c a r -> Path -> r
onGroupStarted :: Path -> r
, FoldTree c a r -> Path -> r
onGroupDone :: Path -> r
, FoldTree c a r -> [String] -> c -> r
onCleanup :: [String] -> c -> r
, FoldTree c a r -> [String] -> a -> r
onLeafe :: [String] -> a -> r
}
foldTree :: FoldTree c a r -> Tree c a -> [r]
foldTree :: FoldTree c a r -> Tree c a -> [r]
foldTree FoldTree{[String] -> c -> r
[String] -> a -> r
Path -> r
onLeafe :: [String] -> a -> r
onCleanup :: [String] -> c -> r
onGroupDone :: Path -> r
onGroupStarted :: Path -> r
onLeafe :: forall c a r. FoldTree c a r -> [String] -> a -> r
onCleanup :: forall c a r. FoldTree c a r -> [String] -> c -> r
onGroupDone :: forall c a r. FoldTree c a r -> Path -> r
onGroupStarted :: forall c a r. FoldTree c a r -> Path -> r
..} = [String] -> Tree c a -> [r]
go []
where
go :: [String] -> Tree c a -> [r]
go [String]
rGroups (Node String
group [Tree c a]
xs) = r
start r -> [r] -> [r]
forall a. a -> [a] -> [a]
: [r]
children [r] -> [r] -> [r]
forall a. [a] -> [a] -> [a]
++ [r
done]
where
path :: Path
path = ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
rGroups, String
group)
start :: r
start = Path -> r
onGroupStarted Path
path
children :: [r]
children = (Tree c a -> [r]) -> [Tree c a] -> [r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> Tree c a -> [r]
go (String
group String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
rGroups)) [Tree c a]
xs
done :: r
done = Path -> r
onGroupDone Path
path
go [String]
rGroups (NodeWithCleanup c
action [Tree c a]
xs) = [r]
children [r] -> [r] -> [r]
forall a. [a] -> [a] -> [a]
++ [r
cleanup]
where
children :: [r]
children = (Tree c a -> [r]) -> [Tree c a] -> [r]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> Tree c a -> [r]
go [String]
rGroups) [Tree c a]
xs
cleanup :: r
cleanup = [String] -> c -> r
onCleanup ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
rGroups) c
action
go [String]
rGroups (Leaf a
a) = [[String] -> a -> r
onLeafe ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
rGroups) a
a]
sequenceActions :: Monad m => Bool -> [EvalM m ()] -> EvalM m ()
sequenceActions :: Bool -> [EvalM m ()] -> EvalM m ()
sequenceActions Bool
fastFail = [EvalM m ()] -> EvalM m ()
forall (m :: * -> *). Monad m => [EvalM m ()] -> EvalM m ()
go
where
go :: Monad m => [EvalM m ()] -> EvalM m ()
go :: [EvalM m ()] -> EvalM m ()
go [] = () -> EvalM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (EvalM m ()
action : [EvalM m ()]
actions) = do
EvalM m ()
action
Bool
hasFailures <- ((Path, Item) -> Bool) -> [(Path, Item)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Path, Item) -> Bool
resultItemIsFailure ([(Path, Item)] -> Bool)
-> StateT (State m) m [(Path, Item)] -> StateT (State m) m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State m -> [(Path, Item)]) -> StateT (State m) m [(Path, Item)]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets State m -> [(Path, Item)]
forall (m :: * -> *). State m -> [(Path, Item)]
stateResults
let stopNow :: Bool
stopNow = Bool
fastFail Bool -> Bool -> Bool
&& Bool
hasFailures
Bool -> EvalM m () -> EvalM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stopNow ([EvalM m ()] -> EvalM m ()
forall (m :: * -> *). Monad m => [EvalM m ()] -> EvalM m ()
go [EvalM m ()]
actions)
resultItemIsFailure :: (Path, Format.Item) -> Bool
resultItemIsFailure :: (Path, Item) -> Bool
resultItemIsFailure = Result -> Bool
isFailure (Result -> Bool)
-> ((Path, Item) -> Result) -> (Path, Item) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> Result
Format.itemResult (Item -> Result)
-> ((Path, Item) -> Item) -> (Path, Item) -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path, Item) -> Item
forall a b. (a, b) -> b
snd
where
isFailure :: Result -> Bool
isFailure Result
r = case Result
r of
Format.Success{} -> Bool
False
Format.Pending{} -> Bool
False
Format.Failure{} -> Bool
True