{-# 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)
-- Control.Concurrent.QSem is deprecated in base-4.6.0.*
{-# OPTIONS_GHC -fno-warn-deprecations #-}
#endif

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

import qualified NonEmpty
import           NonEmpty (NonEmpty(..))

data Tree c a =
    Node String (NonEmpty (Tree c a))
  | NodeWithCleanup (Maybe (String, 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)

-- 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
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

-- | 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 <- 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 ()] -> EvalM ()
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. [RunningTree (IO ())] -> [RunningTree ()]
applyCleanup 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 = Item (Path -> IO (Seconds, Result))
type RunningTree c = Tree c RunningItem

applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()]
applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()]
applyCleanup = forall a b. (a -> b) -> [a] -> [b]
map RunningTree (IO ()) -> RunningTree ()
go
  where
    go :: RunningTree (IO ()) -> RunningTree ()
go RunningTree (IO ())
t = case RunningTree (IO ())
t of
      Leaf RunningItem
a -> forall c a. a -> Tree c a
Leaf RunningItem
a
      Node String
label NonEmpty (RunningTree (IO ()))
xs -> forall c a. String -> NonEmpty (Tree c a) -> Tree c a
Node String
label (RunningTree (IO ()) -> RunningTree ()
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (RunningTree (IO ()))
xs)
      NodeWithCleanup Maybe (String, Location)
loc IO ()
cleanup NonEmpty (RunningTree (IO ()))
xs -> forall c a.
Maybe (String, Location) -> c -> NonEmpty (Tree c a) -> Tree c a
NodeWithCleanup Maybe (String, Location)
loc () (Maybe (String, Location)
-> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())
addCleanupToLastLeaf Maybe (String, Location)
loc IO ()
cleanup forall a b. (a -> b) -> a -> b
$ RunningTree (IO ()) -> RunningTree ()
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (RunningTree (IO ()))
xs)

addCleanupToLastLeaf :: Maybe (String, Location) -> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())
addCleanupToLastLeaf :: Maybe (String, Location)
-> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())
addCleanupToLastLeaf Maybe (String, Location)
loc IO ()
cleanup = NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())
go
  where
    go :: NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())
go = forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> NonEmpty a -> NonEmpty a
mapHead RunningTree () -> RunningTree ()
goNode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse

    goNode :: RunningTree () -> RunningTree ()
goNode RunningTree ()
node = case RunningTree ()
node of
      Leaf RunningItem
item -> forall c a. a -> Tree c a
Leaf (Maybe (String, Location) -> IO () -> RunningItem -> RunningItem
addCleanupToItem Maybe (String, Location)
loc IO ()
cleanup RunningItem
item)
      NodeWithCleanup Maybe (String, Location)
loc_ () NonEmpty (RunningTree ())
zs -> forall c a.
Maybe (String, Location) -> c -> NonEmpty (Tree c a) -> Tree c a
NodeWithCleanup Maybe (String, Location)
loc_ () (NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())
go NonEmpty (RunningTree ())
zs)
      Node String
description NonEmpty (RunningTree ())
zs -> forall c a. String -> NonEmpty (Tree c a) -> Tree c a
Node String
description (NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ())
go NonEmpty (RunningTree ())
zs)

mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a
mapHead :: forall a. (a -> a) -> NonEmpty a -> NonEmpty a
mapHead a -> a
f NonEmpty a
xs = case NonEmpty a
xs of
  a
y :| [a]
ys -> a -> a
f a
y forall a. a -> [a] -> NonEmpty a
:| [a]
ys

addCleanupToItem :: Maybe (String, Location) -> IO () -> RunningItem -> RunningItem
addCleanupToItem :: Maybe (String, Location) -> IO () -> RunningItem -> RunningItem
addCleanupToItem Maybe (String, Location)
loc IO ()
cleanup RunningItem
item = RunningItem
item {
  itemAction :: Path -> IO (Seconds, Result)
itemAction = \ Path
path -> do
    (Seconds
t1, Result
r1) <- forall a. Item a -> a
itemAction RunningItem
item Path
path
    (Seconds
t2, ResultStatus
r2) <- forall a. IO a -> IO (Seconds, a)
measure forall a b. (a -> b) -> a -> b
$ IO ResultStatus -> IO ResultStatus
safeEvaluateResultStatus (IO ()
cleanup forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ResultStatus
Success)
    let t :: Seconds
t = Seconds
t1 forall a. Num a => a -> a -> a
+ Seconds
t2
    forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds
t, Maybe (String, Location) -> Result -> ResultStatus -> Result
mergeResults Maybe (String, Location)
loc Result
r1 ResultStatus
r2)
}

mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result
mergeResults :: Maybe (String, Location) -> Result -> ResultStatus -> Result
mergeResults Maybe (String, Location)
mCallSite (Result String
info ResultStatus
r1) ResultStatus
r2 = String -> ResultStatus -> Result
Result String
info forall a b. (a -> b) -> a -> b
$ case (ResultStatus
r1, ResultStatus
r2) of
  (ResultStatus
_, ResultStatus
Success) -> ResultStatus
r1
  (Failure{}, ResultStatus
_) -> ResultStatus
r1
  (Pending{}, Pending{}) -> ResultStatus
r1
  (ResultStatus
Success, Pending{}) -> ResultStatus
r2
  (ResultStatus
_, Failure Maybe Location
mLoc FailureReason
err) -> Maybe Location -> FailureReason -> ResultStatus
Failure (Maybe Location
mLoc forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Location
hookLoc) forall a b. (a -> b) -> a -> b
$ case FailureReason
err of
    Error Maybe String
message SomeException
e -> Maybe String -> SomeException -> FailureReason
Error (Maybe String
message forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
hookFailed) SomeException
e
    FailureReason
_ -> FailureReason
err
  where
    hookLoc :: Maybe Location
hookLoc = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (String, Location)
mCallSite
    hookFailed :: Maybe String
hookFailed = case Maybe (String, Location)
mCallSite of
      Just (String
name, Location
_) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"in " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"-hook:"
      Maybe (String, Location)
Nothing -> forall a. Maybe a
Nothing

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 ()] -> EvalM ()
run :: [RunningTree ()] -> EvalM ()
run [RunningTree ()]
specs = do
  Bool
failFast <- 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
failFast (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RunningTree () -> [EvalM ()]
foldSpec [RunningTree ()]
specs)
  where
    foldSpec :: RunningTree () -> [EvalM ()]
    foldSpec :: RunningTree () -> [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 (String, Location) -> [String] -> () -> EvalM ()
onCleanup = Maybe (String, Location) -> [String] -> () -> EvalM ()
runCleanup
    , onLeafe :: [String] -> RunningItem -> EvalM ()
onLeafe = [String] -> RunningItem -> EvalM ()
evalItem
    }

    runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM ()
    runCleanup :: Maybe (String, Location) -> [String] -> () -> EvalM ()
runCleanup Maybe (String, Location)
_loc [String]
_groups = forall (m :: * -> *) a. Monad m => a -> m a
return

    evalItem :: [String] -> RunningItem -> EvalM ()
    evalItem :: [String] -> RunningItem -> 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 (String, Location) -> [String] -> c -> r
onCleanup :: Maybe (String, 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 (String, Location) -> [String] -> c -> r
Path -> r
onLeafe :: [String] -> a -> r
onCleanup :: Maybe (String, 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 (String, 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 (String, 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 (String, Location) -> [String] -> c -> r
onCleanup Maybe (String, 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
failFast = [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
stopNow <- case Bool
failFast of
        Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Bool
True -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Path, Item) -> Bool
itemIsFailure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EvalM [(Path, Item)]
getResults
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
stopNow ([EvalM ()] -> EvalM ()
go [EvalM ()]
actions)

    itemIsFailure :: (Path, Format.Item) -> Bool
    itemIsFailure :: (Path, Item) -> Bool
itemIsFailure = 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