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

#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
, 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 (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)

-- 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 = EvalConfig {
  EvalConfig -> Format
evalConfigFormat :: Format
, EvalConfig -> Int
evalConfigConcurrentJobs :: Int
, EvalConfig -> Bool
evalConfigFastFail :: 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 <- (Env -> Format) -> ReaderT Env IO Format
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks ((Env -> Format) -> ReaderT Env IO Format)
-> (Env -> Format) -> ReaderT Env IO Format
forall a b. (a -> b) -> a -> b
$ EvalConfig -> Format
evalConfigFormat (EvalConfig -> Format) -> (Env -> EvalConfig) -> Env -> Format
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> EvalConfig
envConfig
  IO () -> EvalM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EvalM ()) -> IO () -> EvalM ()
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 <- (Env -> IORef [(Path, Item)])
-> ReaderT Env IO (IORef [(Path, Item)])
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Env -> IORef [(Path, Item)]
envResults
  IO () -> EvalM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EvalM ()) -> IO () -> EvalM ()
forall a b. (a -> b) -> a -> b
$ IORef [(Path, Item)] -> ([(Path, Item)] -> [(Path, Item)]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(Path, Item)]
ref ((Path
path, Item
item) (Path, Item) -> [(Path, Item)] -> [(Path, Item)]
forall a. a -> [a] -> [a]
:)

getResults :: EvalM [(Path, Format.Item)]
getResults :: EvalM [(Path, Item)]
getResults = [(Path, Item)] -> [(Path, Item)]
forall a. [a] -> [a]
reverse ([(Path, Item)] -> [(Path, Item)])
-> EvalM [(Path, Item)] -> EvalM [(Path, Item)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Env -> IORef [(Path, Item)])
-> ReaderT Env IO (IORef [(Path, Item)])
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Env -> IORef [(Path, Item)]
envResults ReaderT Env IO (IORef [(Path, Item)])
-> (IORef [(Path, Item)] -> EvalM [(Path, Item)])
-> EvalM [(Path, Item)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO [(Path, Item)] -> EvalM [(Path, Item)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Path, Item)] -> EvalM [(Path, Item)])
-> (IORef [(Path, Item)] -> IO [(Path, Item)])
-> IORef [(Path, Item)]
-> EvalM [(Path, Item)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef [(Path, Item)] -> IO [(Path, Item)]
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 EvalM (Seconds, Result)
-> ((Seconds, Result) -> EvalM ()) -> EvalM ()
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 (Event -> EvalM ()) -> (Path -> Event) -> Path -> EvalM ()
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 (Event -> EvalM ()) -> Event -> EvalM ()
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 (Item -> EvalM ()) -> Item -> EvalM ()
forall a b. (a -> b) -> a -> b
$ Maybe Location -> Seconds -> String -> Result -> Item
Format.Item Maybe Location
loc Seconds
duration String
info (Result -> Item) -> Result -> Item
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_ Maybe Location -> Maybe Location -> Maybe Location
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 (Event -> EvalM ()) -> (Path -> Event) -> Path -> EvalM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Event
Format.GroupStarted

groupDone :: Path -> EvalM ()
groupDone :: Path -> EvalM ()
groupDone = Event -> EvalM ()
formatEvent (Event -> EvalM ()) -> (Path -> Event) -> Path -> EvalM ()
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

-- | Evaluate all examples of a given spec and produce a report.
runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)])
runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Item)]
runFormatter EvalConfig
config [EvalTree]
specs = do
  IORef [(Path, Item)]
ref <- [(Path, Item)] -> IO (IORef [(Path, Item)])
forall a. a -> IO (IORef a)
newIORef []

  let
    start :: IO [RunningTree_ IO]
start = Int -> [EvalTree] -> IO [RunningTree_ IO]
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 = [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_ IO]
-> ([RunningTree_ IO] -> IO ())
-> ([RunningTree_ IO] -> IO [(Path, Item)])
-> IO [(Path, Item)]
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO [RunningTree_ IO]
start [RunningTree_ IO] -> IO ()
forall a b. [Tree (IO ()) (Async a, b)] -> IO ()
cancel (([RunningTree_ IO] -> IO [(Path, Item)]) -> IO [(Path, Item)])
-> ([RunningTree_ IO] -> IO [(Path, Item)]) -> IO [(Path, Item)]
forall a b. (a -> b) -> a -> b
$ \ [RunningTree_ IO]
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

      Format
format Event
Format.Started
      EvalM () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ([RunningTree IO] -> EvalM ()
run ([RunningTree IO] -> EvalM ()) -> [RunningTree IO] -> EvalM ()
forall a b. (a -> b) -> a -> b
$ (RunningTree_ IO -> RunningTree IO)
-> [RunningTree_ IO] -> [RunningTree IO]
forall a b. (a -> b) -> [a] -> [b]
map (((Async (), Item (ProgressCallback -> IO (Seconds, Result)))
 -> Item (Path -> IO (Seconds, Result)))
-> RunningTree_ IO -> RunningTree IO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ProgressCallback -> IO (Seconds, Result))
 -> Path -> IO (Seconds, Result))
-> Item (ProgressCallback -> IO (Seconds, Result))
-> Item (Path -> IO (Seconds, Result))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ProgressCallback -> IO (Seconds, Result))
-> (Path -> ProgressCallback) -> Path -> IO (Seconds, Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO Bool -> Path -> ProgressCallback
reportProgress IO Bool
timer) (Item (ProgressCallback -> IO (Seconds, Result))
 -> Item (Path -> IO (Seconds, Result)))
-> ((Async (), Item (ProgressCallback -> IO (Seconds, Result)))
    -> Item (ProgressCallback -> IO (Seconds, Result)))
-> (Async (), Item (ProgressCallback -> IO (Seconds, Result)))
-> Item (Path -> IO (Seconds, Result))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Async (), Item (ProgressCallback -> IO (Seconds, Result)))
-> Item (ProgressCallback -> IO (Seconds, Result))
forall a b. (a, b) -> b
snd)) [RunningTree_ IO]
runningSpecs) (EvalConfig -> IORef [(Path, Item)] -> Env
Env EvalConfig
config IORef [(Path, Item)]
ref) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`E.finally` do
        [(Path, Item)]
results <- [(Path, Item)] -> [(Path, Item)]
forall a. [a] -> [a]
reverse ([(Path, Item)] -> [(Path, Item)])
-> IO [(Path, Item)] -> IO [(Path, Item)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Path, Item)] -> IO [(Path, Item)]
forall a. IORef a -> IO a
readIORef IORef [(Path, Item)]
ref
        Format
format ([(Path, Item)] -> Event
Format.Done [(Path, Item)]
results)

      [(Path, Item)]
results <- [(Path, Item)] -> [(Path, Item)]
forall a. [a] -> [a]
reverse ([(Path, Item)] -> [(Path, Item)])
-> IO [(Path, Item)] -> IO [(Path, Item)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(Path, Item)] -> IO [(Path, Item)]
forall a. IORef a -> IO a
readIORef IORef [(Path, Item)]
ref
      [(Path, Item)] -> IO [(Path, Item)]
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
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
r (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Format
format (Path -> Progress -> Event
Format.Progress 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 :: [RunningTree IO] -> EvalM ()
run :: [RunningTree IO] -> EvalM ()
run [RunningTree IO]
specs = do
  Bool
fastFail <- (Env -> Bool) -> ReaderT Env IO Bool
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (EvalConfig -> Bool
evalConfigFastFail (EvalConfig -> Bool) -> (Env -> EvalConfig) -> Env -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> EvalConfig
envConfig)
  Bool -> [EvalM ()] -> EvalM ()
sequenceActions Bool
fastFail ((RunningTree IO -> [EvalM ()]) -> [RunningTree IO] -> [EvalM ()]
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 = FoldTree (IO ()) (Item (Path -> IO (Seconds, Result))) (EvalM ())
-> RunningTree IO -> [EvalM ()]
forall c a r. FoldTree c a r -> Tree c a -> [r]
foldTree FoldTree :: forall c a r.
(Path -> r)
-> (Path -> r)
-> (Maybe Location -> [String] -> c -> r)
-> ([String] -> a -> r)
-> FoldTree c a r
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] -> Item (Path -> IO (Seconds, Result)) -> EvalM ()
onLeafe = [String] -> Item (Path -> IO (Seconds, Result)) -> EvalM ()
evalItem
    }

    runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()
    runCleanup :: Maybe Location -> [String] -> IO () -> EvalM ()
runCleanup Maybe Location
loc [String]
groups IO ()
action = do
      (Seconds, Result)
r <- IO (Seconds, Result) -> EvalM (Seconds, Result)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seconds, Result) -> EvalM (Seconds, Result))
-> IO (Seconds, Result) -> EvalM (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 ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Seconds, Result)
_ -> Path -> Maybe Location -> EvalM (Seconds, Result) -> EvalM ()
reportItem Path
path Maybe Location
loc ((Seconds, Result) -> EvalM (Seconds, Result)
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds, Result)
r)
      where
        path :: Path
path = ([String]
groups, String
"afterAll-hook")

    evalItem :: [String] -> RunningItem IO -> EvalM ()
    evalItem :: [String] -> Item (Path -> IO (Seconds, Result)) -> 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 (EvalM (Seconds, Result) -> EvalM ())
-> EvalM (Seconds, Result) -> EvalM ()
forall a b. (a -> b) -> a -> b
$ IO (Seconds, Result) -> EvalM (Seconds, Result)
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 {
  FoldTree c a r -> Path -> r
onGroupStarted :: Path -> r
, FoldTree c a r -> Path -> r
onGroupDone :: Path -> r
, FoldTree c a r -> Maybe Location -> [String] -> c -> r
onCleanup :: Maybe Location -> [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] -> 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 [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 Maybe Location
loc 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 = Maybe Location -> [String] -> c -> r
onCleanup Maybe Location
loc ([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 :: Bool -> [EvalM ()] -> EvalM ()
sequenceActions :: Bool -> [EvalM ()] -> EvalM ()
sequenceActions Bool
fastFail = [EvalM ()] -> EvalM ()
go
  where
    go :: [EvalM ()] -> EvalM ()
    go :: [EvalM ()] -> EvalM ()
go [] = () -> EvalM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go (EvalM ()
action : [EvalM ()]
actions) = do
      EvalM ()
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)
-> EvalM [(Path, Item)] -> ReaderT Env IO Bool
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
      Bool -> EvalM () -> EvalM ()
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 (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