{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
#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(..)
, NonEmpty(..)
, nonEmpty
, EvalTree
, Tree(..)
, 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.Reader
import Control.Monad.Trans.Class
import Test.Hspec.Core.Util
import Test.Hspec.Core.Spec (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 (safeEvaluateResultStatus)
data NonEmpty a = a :| [a]
deriving (NonEmpty a -> NonEmpty a -> Bool
forall a. Eq a => NonEmpty a -> NonEmpty a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonEmpty a -> NonEmpty a -> Bool
$c/= :: forall a. Eq a => NonEmpty a -> NonEmpty a -> Bool
== :: NonEmpty a -> NonEmpty a -> Bool
$c== :: forall a. Eq a => NonEmpty a -> NonEmpty a -> Bool
Eq, Int -> NonEmpty a -> ShowS
forall a. Show a => Int -> NonEmpty a -> ShowS
forall a. Show a => [NonEmpty a] -> ShowS
forall a. Show a => NonEmpty a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonEmpty a] -> ShowS
$cshowList :: forall a. Show a => [NonEmpty a] -> ShowS
show :: NonEmpty a -> String
$cshow :: forall a. Show a => NonEmpty a -> String
showsPrec :: Int -> NonEmpty a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> NonEmpty a -> ShowS
Show, forall a b. a -> NonEmpty b -> NonEmpty a
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> NonEmpty b -> NonEmpty a
$c<$ :: forall a b. a -> NonEmpty b -> NonEmpty a
fmap :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
$cfmap :: forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
Functor, forall a. Eq a => a -> NonEmpty a -> Bool
forall a. Num a => NonEmpty a -> a
forall a. Ord a => NonEmpty a -> a
forall m. Monoid m => NonEmpty m -> m
forall a. NonEmpty a -> Bool
forall a. NonEmpty a -> Int
forall a. NonEmpty a -> [a]
forall a. (a -> a -> a) -> NonEmpty a -> a
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => NonEmpty a -> a
$cproduct :: forall a. Num a => NonEmpty a -> a
sum :: forall a. Num a => NonEmpty a -> a
$csum :: forall a. Num a => NonEmpty a -> a
minimum :: forall a. Ord a => NonEmpty a -> a
$cminimum :: forall a. Ord a => NonEmpty a -> a
maximum :: forall a. Ord a => NonEmpty a -> a
$cmaximum :: forall a. Ord a => NonEmpty a -> a
elem :: forall a. Eq a => a -> NonEmpty a -> Bool
$celem :: forall a. Eq a => a -> NonEmpty a -> Bool
length :: forall a. NonEmpty a -> Int
$clength :: forall a. NonEmpty a -> Int
null :: forall a. NonEmpty a -> Bool
$cnull :: forall a. NonEmpty a -> Bool
toList :: forall a. NonEmpty a -> [a]
$ctoList :: forall a. NonEmpty a -> [a]
foldl1 :: forall a. (a -> a -> a) -> NonEmpty a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NonEmpty a -> a
foldr1 :: forall a. (a -> a -> a) -> NonEmpty a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> NonEmpty a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
foldl :: forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
foldr :: forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
fold :: forall m. Monoid m => NonEmpty m -> m
$cfold :: forall m. Monoid m => NonEmpty m -> m
Foldable, Functor NonEmpty
Foldable NonEmpty
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => NonEmpty (m a) -> m (NonEmpty a)
forall (f :: * -> *) a.
Applicative f =>
NonEmpty (f a) -> f (NonEmpty a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
sequence :: forall (m :: * -> *) a. Monad m => NonEmpty (m a) -> m (NonEmpty a)
$csequence :: forall (m :: * -> *) a. Monad m => NonEmpty (m a) -> m (NonEmpty a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
NonEmpty (f a) -> f (NonEmpty a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NonEmpty (f a) -> f (NonEmpty a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
Traversable)
infixr 5 :|
nonEmpty :: [a] -> Maybe (NonEmpty a)
nonEmpty :: forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [] = forall a. Maybe a
Nothing
nonEmpty (a
a:[a]
as) = forall a. a -> Maybe a
Just (a
a forall a. a -> [a] -> NonEmpty a
:| [a]
as)
data Tree c a =
Node String (NonEmpty (Tree c a))
| NodeWithCleanup (Maybe Location) c (NonEmpty (Tree c a))
| Leaf a
deriving (Tree c a -> Tree c a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c a. (Eq c, Eq a) => Tree c a -> Tree c a -> Bool
/= :: Tree c a -> Tree c a -> Bool
$c/= :: forall c a. (Eq c, Eq a) => Tree c a -> Tree c a -> Bool
== :: Tree c a -> Tree c a -> Bool
$c== :: forall c a. (Eq c, Eq a) => Tree c a -> Tree c a -> Bool
Eq, Int -> Tree c a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall c a. (Show c, Show a) => Int -> Tree c a -> ShowS
forall c a. (Show c, Show a) => [Tree c a] -> ShowS
forall c a. (Show c, Show a) => Tree c a -> String
showList :: [Tree c a] -> ShowS
$cshowList :: forall c a. (Show c, Show a) => [Tree c a] -> ShowS
show :: Tree c a -> String
$cshow :: forall c a. (Show c, Show a) => Tree c a -> String
showsPrec :: Int -> Tree c a -> ShowS
$cshowsPrec :: forall c a. (Show c, Show a) => Int -> Tree c a -> ShowS
Show, forall a b. a -> Tree c b -> Tree c a
forall a b. (a -> b) -> Tree c a -> Tree c b
forall c a b. a -> Tree c b -> Tree c a
forall c a b. (a -> b) -> Tree c a -> Tree c b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Tree c b -> Tree c a
$c<$ :: forall c a b. a -> Tree c b -> Tree c a
fmap :: forall a b. (a -> b) -> Tree c a -> Tree c b
$cfmap :: forall c a b. (a -> b) -> Tree c a -> Tree c b
Functor, forall a. Tree c a -> Bool
forall c a. Eq a => a -> Tree c a -> Bool
forall c a. Num a => Tree c a -> a
forall c a. Ord a => Tree c a -> a
forall m a. Monoid m => (a -> m) -> Tree c a -> m
forall c m. Monoid m => Tree c m -> m
forall c a. Tree c a -> Bool
forall c a. Tree c a -> Int
forall c a. Tree c a -> [a]
forall a b. (a -> b -> b) -> b -> Tree c a -> b
forall c a. (a -> a -> a) -> Tree c a -> a
forall c m a. Monoid m => (a -> m) -> Tree c a -> m
forall c b a. (b -> a -> b) -> b -> Tree c a -> b
forall c a b. (a -> b -> b) -> b -> Tree c a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Tree c a -> a
$cproduct :: forall c a. Num a => Tree c a -> a
sum :: forall a. Num a => Tree c a -> a
$csum :: forall c a. Num a => Tree c a -> a
minimum :: forall a. Ord a => Tree c a -> a
$cminimum :: forall c a. Ord a => Tree c a -> a
maximum :: forall a. Ord a => Tree c a -> a
$cmaximum :: forall c a. Ord a => Tree c a -> a
elem :: forall a. Eq a => a -> Tree c a -> Bool
$celem :: forall c a. Eq a => a -> Tree c a -> Bool
length :: forall a. Tree c a -> Int
$clength :: forall c a. Tree c a -> Int
null :: forall a. Tree c a -> Bool
$cnull :: forall c a. Tree c a -> Bool
toList :: forall a. Tree c a -> [a]
$ctoList :: forall c a. Tree c a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Tree c a -> a
$cfoldl1 :: forall c a. (a -> a -> a) -> Tree c a -> a
foldr1 :: forall a. (a -> a -> a) -> Tree c a -> a
$cfoldr1 :: forall c a. (a -> a -> a) -> Tree c a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Tree c a -> b
$cfoldl' :: forall c b a. (b -> a -> b) -> b -> Tree c a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Tree c a -> b
$cfoldl :: forall c b a. (b -> a -> b) -> b -> Tree c a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Tree c a -> b
$cfoldr' :: forall c a b. (a -> b -> b) -> b -> Tree c a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Tree c a -> b
$cfoldr :: forall c a b. (a -> b -> b) -> b -> Tree c a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Tree c a -> m
$cfoldMap' :: forall c m a. Monoid m => (a -> m) -> Tree c a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Tree c a -> m
$cfoldMap :: forall c m a. Monoid m => (a -> m) -> Tree c a -> m
fold :: forall m. Monoid m => Tree c m -> m
$cfold :: forall c m. Monoid m => Tree c m -> m
Foldable, forall c. Functor (Tree c)
forall c. Foldable (Tree c)
forall c (m :: * -> *) a. Monad m => Tree c (m a) -> m (Tree c a)
forall c (f :: * -> *) a.
Applicative f =>
Tree c (f a) -> f (Tree c a)
forall c (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tree c a -> m (Tree c b)
forall c (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree c a -> f (Tree c b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree c a -> f (Tree c b)
sequence :: forall (m :: * -> *) a. Monad m => Tree c (m a) -> m (Tree c a)
$csequence :: forall c (m :: * -> *) a. Monad m => Tree c (m a) -> m (Tree c a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tree c a -> m (Tree c b)
$cmapM :: forall c (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tree c a -> m (Tree c b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Tree c (f a) -> f (Tree c a)
$csequenceA :: forall c (f :: * -> *) a.
Applicative f =>
Tree c (f a) -> f (Tree c a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree c a -> f (Tree c b)
$ctraverse :: forall c (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree c a -> f (Tree c b)
Traversable)
type Monad m = (Functor m, Applicative m, M.Monad m)
type MonadIO m = (Monad m, M.MonadIO m)
data EvalConfig = EvalConfig {
EvalConfig -> Format
evalConfigFormat :: Format
, EvalConfig -> Int
evalConfigConcurrentJobs :: Int
, EvalConfig -> Bool
evalConfigFailFast :: Bool
}
data Env = Env {
Env -> EvalConfig
envConfig :: EvalConfig
, Env -> IORef [(Path, Item)]
envResults :: IORef [(Path, Format.Item)]
}
formatEvent :: Format.Event -> EvalM ()
formatEvent :: Event -> EvalM ()
formatEvent Event
event = do
Format
format <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks forall a b. (a -> b) -> a -> b
$ EvalConfig -> Format
evalConfigFormat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> EvalConfig
envConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Format
format Event
event
type EvalM = ReaderT Env IO
addResult :: Path -> Format.Item -> EvalM ()
addResult :: Path -> Item -> EvalM ()
addResult Path
path Item
item = do
IORef [(Path, Item)]
ref <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Env -> IORef [(Path, Item)]
envResults
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(Path, Item)]
ref ((Path
path, Item
item) forall a. a -> [a] -> [a]
:)
getResults :: EvalM [(Path, Format.Item)]
getResults :: EvalM [(Path, Item)]
getResults = forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Env -> IORef [(Path, Item)]
envResults forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO a
readIORef)
reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM ()
reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM ()
reportItem Path
path Maybe Location
loc EvalM (Seconds, Result)
action = do
Path -> EvalM ()
reportItemStarted Path
path
EvalM (Seconds, Result)
action forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
reportResult Path
path Maybe Location
loc
reportItemStarted :: Path -> EvalM ()
reportItemStarted :: Path -> EvalM ()
reportItemStarted = Event -> EvalM ()
formatEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Event
Format.ItemStarted
reportItemDone :: Path -> Format.Item -> EvalM ()
reportItemDone :: Path -> Item -> EvalM ()
reportItemDone Path
path Item
item = do
Path -> Item -> EvalM ()
addResult Path
path Item
item
Event -> EvalM ()
formatEvent forall a b. (a -> b) -> a -> b
$ Path -> Item -> Event
Format.ItemDone Path
path Item
item
reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
reportResult Path
path Maybe Location
loc (Seconds
duration, Result
result) = do
case Result
result of
Result String
info ResultStatus
status -> Path -> Item -> EvalM ()
reportItemDone Path
path forall a b. (a -> b) -> a -> b
$ Maybe Location -> Seconds -> String -> Result -> Item
Format.Item Maybe Location
loc Seconds
duration String
info forall a b. (a -> b) -> a -> b
$ case ResultStatus
status of
ResultStatus
Success -> Result
Format.Success
Pending Maybe Location
loc_ Maybe String
reason -> Maybe Location -> Maybe String -> Result
Format.Pending Maybe Location
loc_ Maybe String
reason
Failure Maybe Location
loc_ err :: FailureReason
err@(Error Maybe String
_ SomeException
e) -> Maybe Location -> FailureReason -> Result
Format.Failure (Maybe Location
loc_ forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SomeException -> Maybe Location
extractLocation SomeException
e) FailureReason
err
Failure Maybe Location
loc_ FailureReason
err -> Maybe Location -> FailureReason -> Result
Format.Failure Maybe Location
loc_ FailureReason
err
groupStarted :: Path -> EvalM ()
groupStarted :: Path -> EvalM ()
groupStarted = Event -> EvalM ()
formatEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Event
Format.GroupStarted
groupDone :: Path -> EvalM ()
groupDone :: Path -> EvalM ()
groupDone = Event -> EvalM ()
formatEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Event
Format.GroupDone
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
runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)])
runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Item)]
runFormatter EvalConfig
config [EvalTree]
specs = do
IORef [(Path, Item)]
ref <- forall a. a -> IO (IORef a)
newIORef []
let
start :: IO [RunningTree_ IO]
start = forall (m :: * -> *).
MonadIO m =>
Int -> [EvalTree] -> IO [RunningTree_ m]
parallelizeTree (EvalConfig -> Int
evalConfigConcurrentJobs EvalConfig
config) [EvalTree]
specs
cancel :: [Tree (IO ()) (Async a, b)] -> IO ()
cancel = forall a. [Async a] -> IO ()
cancelMany forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO [RunningTree_ IO]
start forall {a} {b}. [Tree (IO ()) (Async a, b)] -> IO ()
cancel forall a b. (a -> b) -> a -> b
$ \ [RunningTree_ IO]
runningSpecs -> do
forall a. Seconds -> (IO Bool -> IO a) -> IO a
withTimer Seconds
0.05 forall a b. (a -> b) -> a -> b
$ \ IO Bool
timer -> do
Format
format Event
Format.Started
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ([RunningTree IO] -> EvalM ()
run forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> Path -> ProgressCallback
reportProgress IO Bool
timer) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd)) [RunningTree_ IO]
runningSpecs) (EvalConfig -> IORef [(Path, Item)] -> Env
Env EvalConfig
config IORef [(Path, Item)]
ref) forall a b. IO a -> IO b -> IO a
`E.finally` do
[(Path, Item)]
results <- forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [(Path, Item)]
ref
Format
format ([(Path, Item)] -> Event
Format.Done [(Path, Item)]
results)
[(Path, Item)]
results <- forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [(Path, Item)]
ref
forall (m :: * -> *) a. Monad m => a -> m a
return [(Path, Item)]
results
where
format :: Format
format = EvalConfig -> Format
evalConfigFormat EvalConfig
config
reportProgress :: IO Bool -> Path -> ProgressCallback
reportProgress IO Bool
timer Path
path Progress
progress = do
Bool
r <- IO Bool
timer
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
r forall a b. (a -> b) -> a -> b
$ do
Format
format (Path -> Progress -> Event
Format.Progress Path
path Progress
progress)
cancelMany :: [Async a] -> IO ()
cancelMany :: forall a. [Async a] -> IO ()
cancelMany [Async a]
asyncs = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ThreadId -> IO ()
killThread forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Async a -> ThreadId
asyncThreadId) [Async a]
asyncs
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Async a -> IO (Either SomeException a)
waitCatch [Async a]
asyncs
data Item a = Item {
forall a. Item a -> String
_itemDescription :: String
, forall a. Item a -> Maybe Location
_itemLocation :: Maybe Location
, forall a. Item a -> a
_itemAction :: a
} deriving 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
<$ :: forall a b. a -> Item b -> Item a
$c<$ :: forall a b. a -> Item b -> Item a
fmap :: forall a b. (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 :: forall (m :: * -> *).
MonadIO m =>
Int -> [EvalTree] -> IO [RunningTree_ m]
parallelizeTree Int
n [EvalTree]
specs = do
QSem
sem <- Int -> IO QSem
newQSem Int
n
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
QSem -> EvalItem -> IO (RunningItem_ m)
parallelizeItem QSem
sem) [EvalTree]
specs
parallelizeItem :: MonadIO m => QSem -> EvalItem -> IO (RunningItem_ m)
parallelizeItem :: forall (m :: * -> *).
MonadIO m =>
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) <- 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 (forall a. IO a -> IO a
interruptible forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgressCallback -> IO Result
evalItemAction)
forall (m :: * -> *) a. Monad m => a -> m a
return (Async ()
asyncAction, 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 :: forall (m :: * -> *) p a.
MonadIO m =>
Semaphore
-> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
parallelize Semaphore
sem Bool
isParallelizable
| Bool
isParallelizable = forall (m :: * -> *) p a.
MonadIO m =>
Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
runParallel Semaphore
sem
| Bool
otherwise = 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 :: forall (m :: * -> *) p a.
MonadIO m =>
Job IO p a -> IO (Async (), Job m p (Seconds, a))
runSequentially Job IO p a
action = do
MVar ()
mvar <- forall a. IO (MVar a)
newEmptyMVar
(Async ()
asyncAction, Job m p (Seconds, a)
evalAction) <- forall (m :: * -> *) p a.
MonadIO m =>
Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))
runParallel (IO () -> IO () -> Semaphore
Semaphore (forall a. MVar a -> IO a
takeMVar MVar ()
mvar) (forall (m :: * -> *) a. Monad m => a -> m a
return ())) Job IO p a
action
forall (m :: * -> *) a. Monad m => a -> m a
return (Async ()
asyncAction, \ p -> m ()
notifyPartial -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()) 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 :: forall (m :: * -> *) p a.
MonadIO m =>
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 <- forall a. IO (MVar a)
newEmptyMVar
Async ()
asyncAction <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ 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)
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 = forall a. MVar a -> a -> IO ()
replaceMVar MVar (Parallel p (Seconds, a))
mvar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p a. p -> Parallel p a
Partial
(Seconds, a)
result <- forall a. IO a -> IO (Seconds, a)
measure forall a b. (a -> b) -> a -> b
$ Job IO p a
action p -> IO ()
partialCallback
forall a. MVar a -> a -> IO ()
replaceMVar MVar (Parallel p (Seconds, a))
mvar (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds, a)
result
replaceMVar :: MVar a -> a -> IO ()
replaceMVar :: forall a. MVar a -> a -> IO ()
replaceMVar MVar a
mvar a
p = forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar a
mvar forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. MVar a -> a -> IO ()
putMVar MVar a
mvar a
p
run :: [RunningTree IO] -> EvalM ()
run :: [RunningTree IO] -> EvalM ()
run [RunningTree IO]
specs = do
Bool
fastFail <- forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (EvalConfig -> Bool
evalConfigFailFast forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> EvalConfig
envConfig)
Bool -> [EvalM ()] -> EvalM ()
sequenceActions Bool
fastFail (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RunningTree IO -> [EvalM ()]
foldSpec [RunningTree IO]
specs)
where
foldSpec :: RunningTree IO -> [EvalM ()]
foldSpec :: RunningTree IO -> [EvalM ()]
foldSpec = forall c a r. FoldTree c a r -> Tree c a -> [r]
foldTree FoldTree {
onGroupStarted :: Path -> EvalM ()
onGroupStarted = Path -> EvalM ()
groupStarted
, onGroupDone :: Path -> EvalM ()
onGroupDone = Path -> EvalM ()
groupDone
, onCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()
onCleanup = Maybe Location -> [String] -> IO () -> EvalM ()
runCleanup
, onLeafe :: [String] -> RunningItem IO -> EvalM ()
onLeafe = [String] -> RunningItem IO -> EvalM ()
evalItem
}
runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()
runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()
runCleanup Maybe Location
loc [String]
groups IO ()
action = do
(Seconds
t, ResultStatus
r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Seconds, a)
measure forall a b. (a -> b) -> a -> b
$ IO ResultStatus -> IO ResultStatus
safeEvaluateResultStatus (IO ()
action forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ResultStatus
Success)
case ResultStatus
r of
ResultStatus
Success -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ResultStatus
_ -> Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM ()
reportItem Path
path Maybe Location
loc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds
t, String -> ResultStatus -> Result
Result String
"" ResultStatus
r)
where
path :: Path
path = ([String]
groups, String
"afterAll-hook")
evalItem :: [String] -> RunningItem IO -> EvalM ()
evalItem :: [String] -> RunningItem IO -> EvalM ()
evalItem [String]
groups (Item String
requirement Maybe Location
loc Path -> IO (Seconds, Result)
action) = do
Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM ()
reportItem Path
path Maybe Location
loc forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Path -> IO (Seconds, Result)
action Path
path)
where
path :: Path
path :: Path
path = ([String]
groups, String
requirement)
data FoldTree c a r = FoldTree {
forall c a r. FoldTree c a r -> Path -> r
onGroupStarted :: Path -> r
, forall c a r. FoldTree c a r -> Path -> r
onGroupDone :: Path -> r
, forall c a r.
FoldTree c a r -> Maybe Location -> [String] -> c -> r
onCleanup :: Maybe Location -> [String] -> c -> r
, forall c a r. FoldTree c a r -> [String] -> a -> r
onLeafe :: [String] -> a -> r
}
foldTree :: FoldTree c a r -> Tree c a -> [r]
foldTree :: forall c a r. FoldTree c a r -> Tree c a -> [r]
foldTree FoldTree{[String] -> a -> r
Maybe Location -> [String] -> c -> r
Path -> r
onLeafe :: [String] -> a -> r
onCleanup :: Maybe Location -> [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 -> Maybe Location -> [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 NonEmpty (Tree c a)
xs) = r
start forall a. a -> [a] -> [a]
: [r]
children forall a. [a] -> [a] -> [a]
++ [r
done]
where
path :: Path
path = (forall a. [a] -> [a]
reverse [String]
rGroups, String
group)
start :: r
start = Path -> r
onGroupStarted Path
path
children :: [r]
children = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> Tree c a -> [r]
go (String
group forall a. a -> [a] -> [a]
: [String]
rGroups)) NonEmpty (Tree c a)
xs
done :: r
done = Path -> r
onGroupDone Path
path
go [String]
rGroups (NodeWithCleanup Maybe Location
loc c
action NonEmpty (Tree c a)
xs) = [r]
children forall a. [a] -> [a] -> [a]
++ [r
cleanup]
where
children :: [r]
children = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([String] -> Tree c a -> [r]
go [String]
rGroups) NonEmpty (Tree c a)
xs
cleanup :: r
cleanup = Maybe Location -> [String] -> c -> r
onCleanup Maybe Location
loc (forall a. [a] -> [a]
reverse [String]
rGroups) c
action
go [String]
rGroups (Leaf a
a) = [[String] -> a -> r
onLeafe (forall a. [a] -> [a]
reverse [String]
rGroups) a
a]
sequenceActions :: Bool -> [EvalM ()] -> EvalM ()
sequenceActions :: Bool -> [EvalM ()] -> EvalM ()
sequenceActions Bool
fastFail = [EvalM ()] -> EvalM ()
go
where
go :: [EvalM ()] -> EvalM ()
go :: [EvalM ()] -> EvalM ()
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (EvalM ()
action : [EvalM ()]
actions) = do
EvalM ()
action
Bool
hasFailures <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Path, Item) -> Bool
resultItemIsFailure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalM [(Path, Item)]
getResults
let stopNow :: Bool
stopNow = Bool
fastFail Bool -> Bool -> Bool
&& Bool
hasFailures
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stopNow ([EvalM ()] -> EvalM ()
go [EvalM ()]
actions)
resultItemIsFailure :: (Path, Format.Item) -> Bool
resultItemIsFailure :: (Path, Item) -> Bool
resultItemIsFailure = Result -> Bool
isFailure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> Result
Format.itemResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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