{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ConstraintKinds #-}

#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)
-- Control.Concurrent.QSem is deprecated in base-4.6.0.*
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif

module Test.Hspec.Core.Runner.Eval (
  EvalConfig(..)
, EvalTree
, EvalItem(..)
, runFormatter
#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

-- for compatibility with GHC < 7.10.1
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 -> Int
stateSuccessCount :: Int
, State m -> Int
statePendingCount :: Int
, State m -> [Path]
stateFailures :: [Path]
}

type EvalM m = StateT (State m) m

increaseSuccessCount :: Monad m => EvalM m ()
increaseSuccessCount :: EvalM m ()
increaseSuccessCount = (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 :: State m
state -> State m
state {stateSuccessCount :: Int
stateSuccessCount = State m -> Int
forall (m :: * -> *). State m -> Int
stateSuccessCount State m
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1}

increasePendingCount :: Monad m => EvalM m ()
increasePendingCount :: EvalM m ()
increasePendingCount = (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 :: State m
state -> State m
state {statePendingCount :: Int
statePendingCount = State m -> Int
forall (m :: * -> *). State m -> Int
statePendingCount State m
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1}

addFailure :: Monad m => Path -> EvalM m ()
addFailure :: Path -> EvalM m ()
addFailure path :: Path
path = (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 :: State m
state -> State m
state {stateFailures :: [Path]
stateFailures = Path
path Path -> [Path] -> [Path]
forall a. a -> [a] -> [a]
: State m -> [Path]
forall (m :: * -> *). State m -> [Path]
stateFailures State m
state}

getFormat :: Monad m => (Format m -> a) -> EvalM m a
getFormat :: (Format m -> a) -> EvalM m a
getFormat format :: 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
path item :: Item
item = do
  case Item -> Result
Format.itemResult Item
item of
    Format.Success {} -> EvalM m ()
forall (m :: * -> *). Monad m => EvalM m ()
increaseSuccessCount
    Format.Pending {} -> EvalM m ()
forall (m :: * -> *). Monad m => EvalM m ()
increasePendingCount
    Format.Failure {} -> Path -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> EvalM m ()
addFailure Path
path
  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 loc :: Maybe Location
loc duration :: Seconds
duration info :: String
info err :: 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
path loc :: Maybe Location
loc (duration :: Seconds
duration, result :: Result
result) = do
  case Result
result of
    Result info :: String
info status :: ResultStatus
status -> case ResultStatus
status of
      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 loc_ :: Maybe Location
loc_ reason :: 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 loc_ :: Maybe Location
loc_ err :: FailureReason
err@(Error _ e :: 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 loc_ :: Maybe Location
loc_ err :: 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
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
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 config :: EvalConfig m
config action :: 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 -> Int -> Int -> [Path] -> State m
forall (m :: * -> *).
EvalConfig m -> Int -> Int -> [Path] -> State m
State EvalConfig m
config 0 0 [])

-- | Evaluate all examples of a given spec and produce a report.
runFormatter :: forall m. MonadIO m => EvalConfig m -> [EvalTree] -> IO (Int, [Path])
runFormatter :: EvalConfig m -> [EvalTree] -> IO (Int, [Path])
runFormatter config :: EvalConfig m
config specs :: [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 (Int, [Path]))
-> IO (Int, [Path])
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 (Int, [Path])) -> IO (Int, [Path]))
-> ([RunningTree_ m] -> IO (Int, [Path])) -> IO (Int, [Path])
forall a b. (a -> b) -> a -> b
$ \ runningSpecs :: [RunningTree_ m]
runningSpecs -> do
    Seconds -> (IO Bool -> IO (Int, [Path])) -> IO (Int, [Path])
forall a. Seconds -> (IO Bool -> IO a) -> IO a
withTimer 0.05 ((IO Bool -> IO (Int, [Path])) -> IO (Int, [Path]))
-> (IO Bool -> IO (Int, [Path])) -> IO (Int, [Path])
forall a b. (a -> b) -> a -> b
$ \ timer :: 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
      let
        failures :: [Path]
failures = State m -> [Path]
forall (m :: * -> *). State m -> [Path]
stateFailures State m
state
        total :: Int
total = State m -> Int
forall (m :: * -> *). State m -> Int
stateSuccessCount State m
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ State m -> Int
forall (m :: * -> *). State m -> Int
statePendingCount State m
state Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Path] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Path]
failures
      (Int, [Path]) -> IO (Int, [Path])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
total, [Path] -> [Path]
forall a. [a] -> [a]
reverse [Path]
failures)
  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 timer :: IO Bool
timer path :: Path
path progress :: 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 asyncs :: [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 n :: Int
n specs :: [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 sem :: QSem
sem EvalItem{..} = do
  (asyncAction :: Async ()
asyncAction, evalAction :: 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 sem :: Semaphore
sem isParallelizable :: 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 action :: Job IO p a
action = do
  MVar ()
mvar <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  (asyncAction :: Async ()
asyncAction, evalAction :: 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, \ notifyPartial :: 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{..} action :: 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 :: 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 :: MVar (Parallel p (Seconds, a))
mvar notifyPartial :: 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
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 result :: (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 :: MVar a
mvar p :: 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 specs :: [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 groups :: [String]
groups action :: IO ()
action = do
      (dt :: Seconds
dt, r :: Either SomeException ()
r) <- IO (Seconds, Either SomeException ())
-> StateT (State m) m (Seconds, Either SomeException ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seconds, Either SomeException ())
 -> StateT (State m) m (Seconds, Either SomeException ()))
-> IO (Seconds, Either SomeException ())
-> StateT (State m) m (Seconds, Either SomeException ())
forall a b. (a -> b) -> a -> b
$ IO (Either SomeException ())
-> IO (Seconds, Either SomeException ())
forall a. IO a -> IO (Seconds, a)
measure (IO (Either SomeException ())
 -> IO (Seconds, Either SomeException ()))
-> IO (Either SomeException ())
-> IO (Seconds, Either SomeException ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall a. IO a -> IO (Either SomeException a)
safeTry IO ()
action
      (SomeException -> EvalM m ())
-> (() -> EvalM m ()) -> Either SomeException () -> EvalM m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ e :: SomeException
e -> Path -> Item -> EvalM m ()
forall (m :: * -> *). Monad m => Path -> Item -> EvalM m ()
reportItem Path
path (Item -> EvalM m ())
-> (SomeException -> Item) -> SomeException -> EvalM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Location -> Seconds -> String -> FailureReason -> Item
failureItem (SomeException -> Maybe Location
extractLocation SomeException
e) Seconds
dt "" (FailureReason -> Item)
-> (SomeException -> FailureReason) -> SomeException -> Item
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> SomeException -> FailureReason
Error Maybe String
forall a. Maybe a
Nothing (SomeException -> EvalM m ()) -> SomeException -> EvalM m ()
forall a b. (a -> b) -> a -> b
$ SomeException
e) () -> EvalM m ()
forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException ()
r
      where
        path :: Path
path = ([String]
groups, "afterAll-hook")

    evalItem :: [String] -> RunningItem m -> EvalM m ()
    evalItem :: [String] -> Item (Path -> m (Seconds, Result)) -> EvalM m ()
evalItem groups :: [String]
groups (Item requirement :: String
requirement loc :: Maybe Location
loc action :: 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] -> Tree c a -> [r]
go []
  where
    go :: [String] -> Tree c a -> [r]
go rGroups :: [String]
rGroups (Node group :: String
group xs :: [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 rGroups :: [String]
rGroups (NodeWithCleanup action :: c
action xs :: [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 rGroups :: [String]
rGroups (Leaf a :: 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 fastFail :: Bool
fastFail = [EvalM m ()] -> EvalM m ()
forall (m :: * -> *) (m :: * -> *).
Monad m =>
[StateT (State m) m ()] -> StateT (State m) m ()
go
  where
    go :: [StateT (State m) m ()] -> StateT (State m) m ()
go [] = () -> StateT (State m) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go (action :: StateT (State m) m ()
action : actions :: [StateT (State m) m ()]
actions) = do
      () <- StateT (State m) m ()
action
      Bool
hasFailures <- (Bool -> Bool
not (Bool -> Bool) -> ([Path] -> Bool) -> [Path] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([Path] -> Bool)
-> StateT (State m) m [Path] -> StateT (State m) m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State m -> [Path]) -> StateT (State m) m [Path]
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets State m -> [Path]
forall (m :: * -> *). State m -> [Path]
stateFailures
      let stopNow :: Bool
stopNow = Bool
fastFail Bool -> Bool -> Bool
&& Bool
hasFailures
      Bool -> StateT (State m) m () -> StateT (State m) m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stopNow ([StateT (State m) m ()] -> StateT (State m) m ()
go [StateT (State m) m ()]
actions)