{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE LambdaCase #-}
module Test.Hspec.Core.Runner.Eval (
  EvalConfig(..)
, ColorMode(..)
, EvalTree
, Tree(..)
, EvalItem(..)
, Concurrency(..)
, runFormatter
#ifdef TEST
, mergeResults
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat hiding (Monad)

import           Control.Monad.IO.Class (liftIO)
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, exceptionToResultStatus)

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

import           Test.Hspec.Core.Runner.JobQueue

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
(Tree c a -> Tree c a -> Bool)
-> (Tree c a -> Tree c a -> Bool) -> Eq (Tree c a)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall c a. (Eq c, Eq a) => 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
/= :: Tree c a -> Tree c a -> Bool
Eq, Int -> Tree c a -> ShowS
[Tree c a] -> ShowS
Tree c a -> String
(Int -> Tree c a -> ShowS)
-> (Tree c a -> String) -> ([Tree c a] -> ShowS) -> Show (Tree c a)
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
$cshowsPrec :: forall c a. (Show c, Show a) => Int -> Tree c a -> ShowS
showsPrec :: Int -> Tree c a -> ShowS
$cshow :: forall c a. (Show c, Show a) => Tree c a -> String
show :: Tree c a -> String
$cshowList :: forall c a. (Show c, Show a) => [Tree c a] -> ShowS
showList :: [Tree c a] -> ShowS
Show, (forall a b. (a -> b) -> Tree c a -> Tree c b)
-> (forall a b. a -> Tree c b -> Tree c a) -> Functor (Tree c)
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
$cfmap :: forall c a b. (a -> b) -> Tree c a -> Tree c b
fmap :: forall a b. (a -> b) -> Tree c a -> Tree c b
$c<$ :: forall c a b. a -> Tree c b -> Tree c a
<$ :: forall a b. a -> Tree c b -> Tree c a
Functor, (forall m. Monoid m => Tree c m -> m)
-> (forall m a. Monoid m => (a -> m) -> Tree c a -> m)
-> (forall m a. Monoid m => (a -> m) -> Tree c a -> m)
-> (forall a b. (a -> b -> b) -> b -> Tree c a -> b)
-> (forall a b. (a -> b -> b) -> b -> Tree c a -> b)
-> (forall b a. (b -> a -> b) -> b -> Tree c a -> b)
-> (forall b a. (b -> a -> b) -> b -> Tree c a -> b)
-> (forall a. (a -> a -> a) -> Tree c a -> a)
-> (forall a. (a -> a -> a) -> Tree c a -> a)
-> (forall a. Tree c a -> [a])
-> (forall a. Tree c a -> Bool)
-> (forall a. Tree c a -> Int)
-> (forall a. Eq a => a -> Tree c a -> Bool)
-> (forall a. Ord a => Tree c a -> a)
-> (forall a. Ord a => Tree c a -> a)
-> (forall a. Num a => Tree c a -> a)
-> (forall a. Num a => Tree c a -> a)
-> Foldable (Tree c)
forall a. Eq a => a -> Tree c a -> Bool
forall a. Num a => Tree c a -> a
forall a. Ord a => Tree c a -> a
forall m. Monoid m => Tree c m -> m
forall a. Tree c a -> Bool
forall a. Tree c a -> Int
forall a. Tree c a -> [a]
forall a. (a -> a -> a) -> Tree c a -> a
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 b a. (b -> a -> b) -> b -> Tree c a -> b
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
$cfold :: forall c m. Monoid m => Tree c m -> m
fold :: forall m. Monoid m => Tree c m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> Tree c a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> Tree c a -> b
$cfoldr1 :: forall c a. (a -> a -> a) -> Tree c a -> a
foldr1 :: forall a. (a -> a -> a) -> Tree c a -> a
$cfoldl1 :: forall c a. (a -> a -> a) -> Tree c a -> a
foldl1 :: forall a. (a -> a -> a) -> Tree c a -> a
$ctoList :: forall c a. Tree c a -> [a]
toList :: forall a. Tree c a -> [a]
$cnull :: forall c a. Tree c a -> Bool
null :: forall a. Tree c a -> Bool
$clength :: forall c a. Tree c a -> Int
length :: forall a. Tree c a -> Int
$celem :: forall c a. Eq a => a -> Tree c a -> Bool
elem :: forall a. Eq a => a -> Tree c a -> Bool
$cmaximum :: forall c a. Ord a => Tree c a -> a
maximum :: forall a. Ord a => Tree c a -> a
$cminimum :: forall c a. Ord a => Tree c a -> a
minimum :: forall a. Ord a => Tree c a -> a
$csum :: forall c a. Num a => Tree c a -> a
sum :: forall a. Num a => Tree c a -> a
$cproduct :: forall c a. Num a => Tree c a -> a
product :: forall a. Num a => Tree c a -> a
Foldable, Functor (Tree c)
Foldable (Tree c)
(Functor (Tree c), Foldable (Tree c)) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Tree c a -> f (Tree c b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Tree c (f a) -> f (Tree c a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Tree c a -> m (Tree c b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Tree c (m a) -> m (Tree c a))
-> Traversable (Tree c)
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 (m :: * -> *) a. Monad m => Tree c (m a) -> m (Tree c a)
forall (f :: * -> *) a.
Applicative f =>
Tree c (f a) -> f (Tree c a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tree c a -> m (Tree c b)
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)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree c a -> f (Tree c b)
$csequenceA :: forall c (f :: * -> *) a.
Applicative f =>
Tree c (f a) -> f (Tree c a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Tree c (f a) -> f (Tree c a)
$cmapM :: forall c (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tree c a -> m (Tree c b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Tree c a -> m (Tree c b)
$csequence :: forall c (m :: * -> *) a. Monad m => Tree c (m a) -> m (Tree c a)
sequence :: forall (m :: * -> *) a. Monad m => Tree c (m a) -> m (Tree c a)
Traversable)

data EvalConfig = EvalConfig {
  EvalConfig -> Format
evalConfigFormat :: Format
, EvalConfig -> Int
evalConfigConcurrentJobs :: Int
, EvalConfig -> Bool
evalConfigFailFast :: Bool
, EvalConfig -> ColorMode
evalConfigColorMode :: ColorMode
}

data ColorMode = ColorDisabled | ColorEnabled

data Env = Env {
  Env -> EvalConfig
envConfig :: EvalConfig
, Env -> IORef Bool
envAbort :: IORef Bool
, 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 a. IO a -> ReaderT Env IO a
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

abort :: EvalM ()
abort :: EvalM ()
abort = do
  IORef Bool
ref <- (Env -> IORef Bool) -> ReaderT Env IO (IORef Bool)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Env -> IORef Bool
envAbort
  IO () -> EvalM ()
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EvalM ()) -> IO () -> EvalM ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ref Bool
True

shouldAbort :: EvalM Bool
shouldAbort :: EvalM Bool
shouldAbort = do
  IORef Bool
ref <- (Env -> IORef Bool) -> ReaderT Env IO (IORef Bool)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Env -> IORef Bool
envAbort
  IO Bool -> EvalM Bool
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> EvalM Bool) -> IO Bool -> EvalM Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ref

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 a. IO a -> ReaderT Env IO a
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]
:)

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 a b.
ReaderT Env IO a -> (a -> ReaderT Env IO b) -> ReaderT Env IO b
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

isFailure :: Result -> Bool
isFailure :: Result -> Bool
isFailure Result
r = case Result -> ResultStatus
resultStatus Result
r of
  Success{} -> Bool
False
  Pending{} -> Bool
False
  Failure{} -> Bool
True

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
  ColorMode
mode <- (Env -> ColorMode) -> ReaderT Env IO ColorMode
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks (EvalConfig -> ColorMode
evalConfigColorMode (EvalConfig -> ColorMode)
-> (Env -> EvalConfig) -> Env -> ColorMode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Env -> EvalConfig
envConfig)
  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 a. Maybe a -> Maybe a -> Maybe a
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 -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ case ColorMode
mode of
        ColorMode
ColorEnabled -> FailureReason
err
        ColorMode
ColorDisabled -> case FailureReason
err of
          FailureReason
NoReason -> FailureReason
err
          Reason String
_ -> FailureReason
err
          ExpectedButGot Maybe String
_ String
_ String
_ -> FailureReason
err
          ColorizedReason String
r -> String -> FailureReason
Reason (ShowS
stripAnsi String
r)
#if __GLASGOW_HASKELL__ < 900
          Error _ _ -> err
#endif

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 -> Concurrency
evalItemConcurrency :: Concurrency
, EvalItem -> ProgressCallback -> IO (Seconds, Result)
evalItemAction :: ProgressCallback -> IO (Seconds, 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
  Int -> (JobQueue -> IO [(Path, Item)]) -> IO [(Path, Item)]
forall a. Int -> (JobQueue -> IO a) -> IO a
withJobQueue (EvalConfig -> Int
evalConfigConcurrentJobs EvalConfig
config) ((JobQueue -> IO [(Path, Item)]) -> IO [(Path, Item)])
-> (JobQueue -> IO [(Path, Item)]) -> IO [(Path, Item)]
forall a b. (a -> b) -> a -> b
$ \ JobQueue
queue -> 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
      Env
env <- IO Env
mkEnv
      [RunningTree_ IO]
runningSpecs_ <- JobQueue -> [EvalTree] -> IO [RunningTree_ IO]
forall (m :: * -> *).
MonadIO m =>
JobQueue -> [EvalTree] -> IO [RunningTree_ m]
enqueueItems JobQueue
queue [EvalTree]
specs

      let
        applyReportProgress :: RunningItem_ IO -> RunningItem IO
        applyReportProgress :: RunningItem_ IO -> RunningItem IO
applyReportProgress RunningItem_ IO
item = ((ProgressCallback -> IO (Seconds, Result))
 -> Path -> IO (Seconds, Result))
-> RunningItem_ IO -> RunningItem IO
forall a b. (a -> b) -> Item a -> Item b
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) RunningItem_ IO
item

        runningSpecs :: [RunningTree () EvalM]
        runningSpecs :: [RunningTree () (ReaderT Env IO)]
runningSpecs = (Result -> Bool)
-> [RunningTree (IO ()) IO] -> [RunningTree () (ReaderT Env IO)]
applyCleanup Result -> Bool
abortEarly ([RunningTree (IO ()) IO] -> [RunningTree () (ReaderT Env IO)])
-> [RunningTree (IO ()) IO] -> [RunningTree () (ReaderT Env IO)]
forall a b. (a -> b) -> a -> b
$ (RunningTree_ IO -> RunningTree (IO ()) IO)
-> [RunningTree_ IO] -> [RunningTree (IO ()) IO]
forall a b. (a -> b) -> [a] -> [b]
map ((RunningItem_ IO -> RunningItem IO)
-> RunningTree_ IO -> RunningTree (IO ()) IO
forall a b. (a -> b) -> Tree (IO ()) a -> Tree (IO ()) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RunningItem_ IO -> RunningItem IO
applyReportProgress) [RunningTree_ IO]
runningSpecs_

        abortEarly :: Result -> Bool
        abortEarly :: Result -> Bool
abortEarly Result
result = EvalConfig -> Bool
evalConfigFailFast EvalConfig
config Bool -> Bool -> Bool
&& Result -> Bool
isFailure Result
result

        getResults :: IO [(Path, Format.Item)]
        getResults :: IO [(Path, Item)]
getResults = [(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 (Env -> IORef [(Path, Item)]
envResults Env
env)

        formatItems :: IO ()
        formatItems :: IO ()
formatItems = EvalM () -> Env -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ([RunningTree () (ReaderT Env IO)] -> EvalM ()
eval [RunningTree () (ReaderT Env IO)]
runningSpecs) Env
env

        formatDone :: IO ()
        formatDone :: IO ()
formatDone = IO [(Path, Item)]
getResults IO [(Path, Item)] -> ([(Path, Item)] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Format
format Format -> ([(Path, Item)] -> Event) -> [(Path, Item)] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Path, Item)] -> Event
Format.Done

      Format
format Event
Format.Started
      IO ()
formatItems IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
formatDone
      IO [(Path, Item)]
getResults
  where
    mkEnv :: IO Env
    mkEnv :: IO Env
mkEnv = EvalConfig -> IORef Bool -> IORef [(Path, Item)] -> Env
Env EvalConfig
config (IORef Bool -> IORef [(Path, Item)] -> Env)
-> IO (IORef Bool) -> IO (IORef [(Path, Item)] -> Env)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False IO (IORef [(Path, Item)] -> Env)
-> IO (IORef [(Path, Item)]) -> IO Env
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(Path, Item)] -> IO (IORef [(Path, Item)])
forall a. a -> IO (IORef a)
newIORef []

    format :: Format
    format :: Format
format = EvalConfig -> Format
evalConfigFormat EvalConfig
config

    reportProgress :: IO Bool -> Path -> Progress -> IO ()
    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)

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 -> 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
$cfmap :: forall a b. (a -> b) -> Item a -> Item b
fmap :: forall a b. (a -> b) -> Item a -> Item b
$c<$ :: forall a b. a -> Item b -> Item a
<$ :: forall a b. a -> Item b -> Item a
Functor

type RunningItem m = Item (Path -> m (Seconds, Result))
type RunningTree c m = Tree c (RunningItem m)

type RunningItem_ m = Item (Job m Progress (Seconds, Result))
type RunningTree_ m = Tree (IO ()) (RunningItem_ m)

applyFailFast :: (Result -> Bool) -> RunningTree () IO -> RunningTree () EvalM
applyFailFast :: (Result -> Bool)
-> RunningTree () IO -> RunningTree () (ReaderT Env IO)
applyFailFast = (RunningItem IO -> RunningItem (ReaderT Env IO))
-> RunningTree () IO -> RunningTree () (ReaderT Env IO)
forall a b. (a -> b) -> Tree () a -> Tree () b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RunningItem IO -> RunningItem (ReaderT Env IO))
 -> RunningTree () IO -> RunningTree () (ReaderT Env IO))
-> ((Result -> Bool)
    -> RunningItem IO -> RunningItem (ReaderT Env IO))
-> (Result -> Bool)
-> RunningTree () IO
-> RunningTree () (ReaderT Env IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Path -> IO (Seconds, Result)) -> Path -> EvalM (Seconds, Result))
-> RunningItem IO -> RunningItem (ReaderT Env IO)
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Path -> IO (Seconds, Result))
  -> Path -> EvalM (Seconds, Result))
 -> RunningItem IO -> RunningItem (ReaderT Env IO))
-> ((Result -> Bool)
    -> (Path -> IO (Seconds, Result))
    -> Path
    -> EvalM (Seconds, Result))
-> (Result -> Bool)
-> RunningItem IO
-> RunningItem (ReaderT Env IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IO (Seconds, Result) -> EvalM (Seconds, Result))
-> (Path -> IO (Seconds, Result))
-> Path
-> EvalM (Seconds, Result)
forall a b. (a -> b) -> (Path -> a) -> Path -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((IO (Seconds, Result) -> EvalM (Seconds, Result))
 -> (Path -> IO (Seconds, Result))
 -> Path
 -> EvalM (Seconds, Result))
-> ((Result -> Bool)
    -> IO (Seconds, Result) -> EvalM (Seconds, Result))
-> (Result -> Bool)
-> (Path -> IO (Seconds, Result))
-> Path
-> EvalM (Seconds, Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result -> Bool) -> IO (Seconds, Result) -> EvalM (Seconds, Result)
forall {t} {a}. (t -> Bool) -> IO (a, t) -> ReaderT Env IO (a, t)
applyToItem
  where
    applyToItem :: (t -> Bool) -> IO (a, t) -> ReaderT Env IO (a, t)
applyToItem t -> Bool
abortEarly IO (a, t)
action = do
      result :: (a, t)
result@(a
_, t
r) <- IO (a, t) -> ReaderT Env IO (a, t)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Env m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO (a, t)
action
      Bool -> EvalM () -> EvalM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (t -> Bool
abortEarly t
r) EvalM ()
abort
      (a, t) -> ReaderT Env IO (a, t)
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a, t)
result

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

applyCleanupAction :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO)
applyCleanupAction :: (Result -> Bool)
-> Maybe (String, Location)
-> IO ()
-> NonEmpty (RunningTree () IO)
-> NonEmpty (RunningTree () IO)
applyCleanupAction Result -> Bool
abortEarly Maybe (String, Location)
loc IO ()
cleanup = (RunningItem IO -> RunningItem IO)
-> NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO)
forall a. (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a)
forLastLeaf ((Result -> Bool) -> RunningItem IO -> RunningItem IO
addCleanupOn (Bool -> Bool
not (Bool -> Bool) -> (Result -> Bool) -> Result -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Bool
abortEarly)) (NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO))
-> (NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO))
-> NonEmpty (RunningTree () IO)
-> NonEmpty (RunningTree () IO)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RunningItem IO -> RunningItem IO)
-> NonEmpty (RunningTree () IO) -> NonEmpty (RunningTree () IO)
forall a b.
(a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b)
forEachLeaf ((Result -> Bool) -> RunningItem IO -> RunningItem IO
addCleanupOn Result -> Bool
abortEarly)
  where
    addCleanupOn :: (Result -> Bool) -> RunningItem IO -> RunningItem IO
addCleanupOn Result -> Bool
p = (Result -> Bool)
-> Maybe (String, Location)
-> IO ()
-> RunningItem IO
-> RunningItem IO
addCleanupToItem Result -> Bool
p Maybe (String, Location)
loc IO ()
cleanup

forEachLeaf :: (a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b)
forEachLeaf :: forall a b.
(a -> b) -> NonEmpty (Tree () a) -> NonEmpty (Tree () b)
forEachLeaf a -> b
f = (Tree () a -> Tree () b)
-> NonEmpty (Tree () a) -> NonEmpty (Tree () b)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> Tree () a -> Tree () b
forall a b. (a -> b) -> Tree () a -> Tree () b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)

forLastLeaf :: (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a)
forLastLeaf :: forall a. (a -> a) -> NonEmpty (Tree () a) -> NonEmpty (Tree () a)
forLastLeaf a -> a
p = NonEmpty (Tree () a) -> NonEmpty (Tree () a)
go
  where
    go :: NonEmpty (Tree () a) -> NonEmpty (Tree () a)
go = NonEmpty (Tree () a) -> NonEmpty (Tree () a)
forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse (NonEmpty (Tree () a) -> NonEmpty (Tree () a))
-> (NonEmpty (Tree () a) -> NonEmpty (Tree () a))
-> NonEmpty (Tree () a)
-> NonEmpty (Tree () a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree () a -> Tree () a)
-> NonEmpty (Tree () a) -> NonEmpty (Tree () a)
forall a. (a -> a) -> NonEmpty a -> NonEmpty a
mapHead Tree () a -> Tree () a
goNode (NonEmpty (Tree () a) -> NonEmpty (Tree () a))
-> (NonEmpty (Tree () a) -> NonEmpty (Tree () a))
-> NonEmpty (Tree () a)
-> NonEmpty (Tree () a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Tree () a) -> NonEmpty (Tree () a)
forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse

    goNode :: Tree () a -> Tree () a
goNode Tree () a
node = case Tree () a
node of
      Node String
description NonEmpty (Tree () a)
xs -> String -> NonEmpty (Tree () a) -> Tree () a
forall c a. String -> NonEmpty (Tree c a) -> Tree c a
Node String
description (NonEmpty (Tree () a) -> NonEmpty (Tree () a)
go NonEmpty (Tree () a)
xs)
      NodeWithCleanup Maybe (String, Location)
loc_ () NonEmpty (Tree () a)
xs -> Maybe (String, Location) -> () -> NonEmpty (Tree () a) -> Tree () a
forall c a.
Maybe (String, Location) -> c -> NonEmpty (Tree c a) -> Tree c a
NodeWithCleanup Maybe (String, Location)
loc_ () (NonEmpty (Tree () a) -> NonEmpty (Tree () a)
go NonEmpty (Tree () a)
xs)
      Leaf a
item -> a -> Tree () a
forall c a. a -> Tree c a
Leaf (a -> a
p a
item)

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 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
ys

addCleanupToItem :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> RunningItem IO -> RunningItem IO
addCleanupToItem :: (Result -> Bool)
-> Maybe (String, Location)
-> IO ()
-> RunningItem IO
-> RunningItem IO
addCleanupToItem Result -> Bool
shouldRunCleanup Maybe (String, Location)
loc IO ()
cleanup RunningItem IO
item = RunningItem IO
item {
  itemAction = \ Path
path -> do
    result :: (Seconds, Result)
result@(Seconds
t1, Result
r1) <- RunningItem IO -> Path -> IO (Seconds, Result)
forall a. Item a -> a
itemAction RunningItem IO
item Path
path
    if Result -> Bool
shouldRunCleanup Result
r1 then do
      (Seconds
t2, ResultStatus
r2) <- IO ResultStatus -> IO (Seconds, ResultStatus)
forall a. IO a -> IO (Seconds, a)
measure (IO ResultStatus -> IO (Seconds, ResultStatus))
-> IO ResultStatus -> IO (Seconds, ResultStatus)
forall a b. (a -> b) -> a -> b
$ IO ResultStatus -> IO ResultStatus
safeEvaluateResultStatus (IO ()
cleanup IO () -> IO ResultStatus -> IO ResultStatus
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ResultStatus -> IO ResultStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ResultStatus
Success)
      let t :: Seconds
t = Seconds
t1 Seconds -> Seconds -> Seconds
forall a. Num a => a -> a -> a
+ Seconds
t2
      (Seconds, Result) -> IO (Seconds, Result)
forall a. a -> IO a
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)
    else do
      (Seconds, Result) -> IO (Seconds, Result)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Seconds, Result)
result
}

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 (ResultStatus -> Result) -> ResultStatus -> Result
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 Maybe Location -> Maybe Location -> Maybe Location
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Location
hookLoc) (FailureReason -> ResultStatus) -> FailureReason -> ResultStatus
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 Maybe String -> Maybe String -> Maybe String
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe String
hookFailed) SomeException
e
    FailureReason
_ -> FailureReason
err
  where
    hookLoc :: Maybe Location
hookLoc = (String, Location) -> Location
forall a b. (a, b) -> b
snd ((String, Location) -> Location)
-> Maybe (String, Location) -> Maybe Location
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
_) -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-hook:"
      Maybe (String, Location)
Nothing -> Maybe String
forall a. Maybe a
Nothing

enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m]
enqueueItems :: forall (m :: * -> *).
MonadIO m =>
JobQueue -> [EvalTree] -> IO [RunningTree_ m]
enqueueItems JobQueue
queue = (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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree (IO ()) a -> f (Tree (IO ()) 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
$ JobQueue -> EvalItem -> IO (RunningItem_ m)
forall (m :: * -> *).
MonadIO m =>
JobQueue -> EvalItem -> IO (RunningItem_ m)
enqueueItem JobQueue
queue)

enqueueItem :: MonadIO m => JobQueue -> EvalItem -> IO (RunningItem_ m)
enqueueItem :: forall (m :: * -> *).
MonadIO m =>
JobQueue -> EvalItem -> IO (RunningItem_ m)
enqueueItem JobQueue
queue EvalItem{String
Maybe Location
Concurrency
ProgressCallback -> IO (Seconds, Result)
evalItemDescription :: EvalItem -> String
evalItemLocation :: EvalItem -> Maybe Location
evalItemConcurrency :: EvalItem -> Concurrency
evalItemAction :: EvalItem -> ProgressCallback -> IO (Seconds, Result)
evalItemDescription :: String
evalItemLocation :: Maybe Location
evalItemConcurrency :: Concurrency
evalItemAction :: ProgressCallback -> IO (Seconds, Result)
..} = do
  Job m Progress (Either SomeException (Seconds, Result))
job <- JobQueue
-> Concurrency
-> (ProgressCallback -> IO (Seconds, Result))
-> IO (Job m Progress (Either SomeException (Seconds, Result)))
forall (m :: * -> *) progress a.
MonadIO m =>
JobQueue
-> Concurrency
-> Job IO progress a
-> IO (Job m progress (Either SomeException a))
enqueueJob JobQueue
queue Concurrency
evalItemConcurrency ProgressCallback -> IO (Seconds, Result)
evalItemAction
  RunningItem_ m -> IO (RunningItem_ m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Item {
    itemDescription :: String
itemDescription = String
evalItemDescription
  , itemLocation :: Maybe Location
itemLocation = Maybe Location
evalItemLocation
  , itemAction :: (Progress -> m ()) -> m (Seconds, Result)
itemAction = Job m Progress (Either SomeException (Seconds, Result))
job Job m Progress (Either SomeException (Seconds, Result))
-> (Either SomeException (Seconds, Result) -> m (Seconds, Result))
-> (Progress -> m ())
-> m (Seconds, Result)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO (Seconds, Result) -> m (Seconds, Result)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seconds, Result) -> m (Seconds, Result))
-> (Either SomeException (Seconds, Result) -> IO (Seconds, Result))
-> Either SomeException (Seconds, Result)
-> m (Seconds, Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeException -> IO (Seconds, Result))
-> ((Seconds, Result) -> IO (Seconds, Result))
-> Either SomeException (Seconds, Result)
-> IO (Seconds, Result)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO (Seconds, Result)
exceptionToResult (Seconds, Result) -> IO (Seconds, Result)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
  }
  where
    exceptionToResult :: SomeException -> IO (Seconds, Result)
    exceptionToResult :: SomeException -> IO (Seconds, Result)
exceptionToResult SomeException
err = (,) Seconds
0 (Result -> (Seconds, Result))
-> (ResultStatus -> Result) -> ResultStatus -> (Seconds, Result)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ResultStatus -> Result
Result String
"" (ResultStatus -> (Seconds, Result))
-> IO ResultStatus -> IO (Seconds, Result)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeException -> IO ResultStatus
exceptionToResultStatus SomeException
err

eval :: [RunningTree () EvalM] -> EvalM ()
eval :: [RunningTree () (ReaderT Env IO)] -> EvalM ()
eval [RunningTree () (ReaderT Env IO)]
specs = do
  [EvalM ()] -> EvalM ()
sequenceActions ((RunningTree () (ReaderT Env IO) -> [EvalM ()])
-> [RunningTree () (ReaderT Env IO)] -> [EvalM ()]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RunningTree () (ReaderT Env IO) -> [EvalM ()]
foldSpec [RunningTree () (ReaderT Env IO)]
specs)
  where
    foldSpec :: RunningTree () EvalM -> [EvalM ()]
    foldSpec :: RunningTree () (ReaderT Env IO) -> [EvalM ()]
foldSpec = FoldTree () (RunningItem (ReaderT Env IO)) (EvalM ())
-> RunningTree () (ReaderT Env IO) -> [EvalM ()]
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 (ReaderT Env IO) -> EvalM ()
onLeafe = [String] -> RunningItem (ReaderT Env IO) -> EvalM ()
evalItem
    }

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

    evalItem :: [String] -> RunningItem EvalM -> EvalM ()
    evalItem :: [String] -> RunningItem (ReaderT Env IO) -> EvalM ()
evalItem [String]
groups (Item String
requirement Maybe Location
loc Path -> EvalM (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
$ Path -> EvalM (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
onGroupStarted :: forall c a r. FoldTree c a r -> Path -> r
onGroupDone :: forall c a r. FoldTree c a r -> Path -> r
onCleanup :: forall c a r.
FoldTree c a r -> Maybe (String, Location) -> [String] -> c -> r
onLeafe :: forall c a r. FoldTree c a r -> [String] -> a -> r
onGroupStarted :: Path -> r
onGroupDone :: Path -> r
onCleanup :: Maybe (String, Location) -> [String] -> c -> r
onLeafe :: [String] -> a -> 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 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]) -> NonEmpty (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)) 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 [r] -> [r] -> [r]
forall a. [a] -> [a] -> [a]
++ [r
cleanup]
      where
        children :: [r]
children = (Tree c a -> [r]) -> NonEmpty (Tree c a) -> [r]
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 ([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 :: [EvalM ()] -> EvalM ()
sequenceActions :: [EvalM ()] -> EvalM ()
sequenceActions = [EvalM ()] -> EvalM ()
go
  where
    go :: [EvalM ()] -> EvalM ()
    go :: [EvalM ()] -> EvalM ()
go [] = EvalM ()
forall (m :: * -> *). Applicative m => m ()
pass
    go (EvalM ()
action : [EvalM ()]
actions) = do
      EvalM ()
action
      EvalM Bool
shouldAbort EvalM Bool -> (Bool -> EvalM ()) -> EvalM ()
forall a b.
ReaderT Env IO a -> (a -> ReaderT Env IO b) -> ReaderT Env IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
        Bool
False -> [EvalM ()] -> EvalM ()
go [EvalM ()]
actions
        Bool
True -> EvalM ()
forall (m :: * -> *). Applicative m => m ()
pass