{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
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           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, exceptionToResult)

import qualified Data.List.NonEmpty as NonEmpty
import           Data.List.NonEmpty (NonEmpty(..))

import           DList (DList(..))
import qualified DList

import           Test.Hspec.Core.Runner.JobQueue (JobQueue, Open, Concurrency(..), AbortEarly(..), Report(..))
import qualified Test.Hspec.Core.Runner.JobQueue as 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 c m. Monoid m => Tree c m -> m
forall m a. Monoid m => (a -> m) -> Tree c a -> 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 [(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

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]
:)

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

formatResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
formatResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
formatResult 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

data EvalItem = EvalItem {
  EvalItem -> String
evalItemDescription :: String
, EvalItem -> Maybe Location
evalItemLocation :: Maybe Location
, EvalItem -> Concurrency
evalItemConcurrency :: Concurrency
, 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
  JobQueue Open Progress Result
queue <- IO (JobQueue Open Progress Result)
forall progress a. IO (JobQueue Open progress a)
JobQueue.new
  [Tree (IO ()) Item]
enqueuedSpecs <- JobQueue Open Progress Result
-> [EvalTree] -> IO [Tree (IO ()) Item]
forall c.
JobQueue Open Progress Result
-> [Tree c EvalItem] -> IO [Tree c Item]
enqueueItems JobQueue Open Progress Result
queue [EvalTree]
specs
  JobQueue Final Progress Result
jobs <- JobQueue Open Progress Result
-> IO (JobQueue Final Progress Result)
forall progress a.
JobQueue Open progress a -> IO (JobQueue Final progress a)
JobQueue.finalize JobQueue Open Progress Result
queue
  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
    let
      applyReportResult :: Item -> WithReportResult () Item
      applyReportResult :: Item -> WithReportResult () Item
applyReportResult =  (Path -> Maybe Location -> (Seconds, Result) -> EvalM ())
-> Item -> WithReportResult () Item
forall abort a. ReportResult abort -> a -> WithReportResult abort a
WithReportResult Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
formatResult

      runningSpecs :: [Tree () (WithReportResult_ Item)]
      runningSpecs :: [Tree () (WithReportResult_ Item)]
runningSpecs = (Result -> Bool)
-> [Tree (IO ()) (WithReportResult () Item)]
-> [Tree () (WithReportResult_ Item)]
forall a.
(Result -> Bool)
-> [Tree (IO ()) (WithReportResult () a)]
-> [Tree () (WithReportResult_ a)]
applyCleanup Result -> Bool
abortEarly ([Tree (IO ()) (WithReportResult () Item)]
 -> [Tree () (WithReportResult_ Item)])
-> [Tree (IO ()) (WithReportResult () Item)]
-> [Tree () (WithReportResult_ Item)]
forall a b. (a -> b) -> a -> b
$ (Tree (IO ()) Item -> Tree (IO ()) (WithReportResult () Item))
-> [Tree (IO ()) Item] -> [Tree (IO ()) (WithReportResult () Item)]
forall a b. (a -> b) -> [a] -> [b]
map ((Item -> WithReportResult () Item)
-> Tree (IO ()) Item -> Tree (IO ()) (WithReportResult () Item)
forall a b. (a -> b) -> Tree (IO ()) a -> Tree (IO ()) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Item -> WithReportResult () Item
applyReportResult) [Tree (IO ()) Item]
enqueuedSpecs

      runEvalM :: EvalM a -> IO a
      runEvalM :: forall a. EvalM a -> IO a
runEvalM = (EvalM a -> Env -> IO a) -> Env -> EvalM a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip EvalM a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Env
env

      eval :: forall item progress a. ([String] -> item -> DList (Report progress a)) -> [(Tree () item)] -> [Report progress a]
      eval :: forall item progress a.
([String] -> item -> DList (Report progress a))
-> [Tree () item] -> [Report progress a]
eval [String] -> item -> DList (Report progress a)
evalItem = DList (Report progress a) -> [Report progress a]
forall a. DList a -> [a]
DList.toList (DList (Report progress a) -> [Report progress a])
-> ([Tree () item] -> DList (Report progress a))
-> [Tree () item]
-> [Report progress a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree () item -> DList (Report progress a))
-> [Tree () item] -> DList (Report progress a)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Tree () item -> DList (Report progress a)
foldSpec
        where
          foldSpec :: Tree () item -> DList (Report progress a)
          foldSpec :: Tree () item -> DList (Report progress a)
foldSpec = FoldTree () item (DList (Report progress a))
-> Tree () item -> DList (Report progress a)
forall r c a. Monoid r => FoldTree c a r -> Tree c a -> r
foldTree FoldTree {
            onGroupStarted :: Path -> DList (Report progress a)
onGroupStarted = Report progress a -> DList (Report progress a)
forall a. a -> DList a
DList.singleton (Report progress a -> DList (Report progress a))
-> (Path -> Report progress a) -> Path -> DList (Report progress a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Report progress a
forall progress a. IO () -> Report progress a
Report (IO () -> Report progress a)
-> (Path -> IO ()) -> Path -> Report progress a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> IO ()
groupStarted
          , onGroupDone :: Path -> DList (Report progress a)
onGroupDone = Report progress a -> DList (Report progress a)
forall a. a -> DList a
DList.singleton (Report progress a -> DList (Report progress a))
-> (Path -> Report progress a) -> Path -> DList (Report progress a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> Report progress a
forall progress a. IO () -> Report progress a
Report (IO () -> Report progress a)
-> (Path -> IO ()) -> Path -> Report progress a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> IO ()
groupDone
          , Maybe (String, Location)
-> [String] -> () -> DList (Report progress a)
onCleanup :: Maybe (String, Location)
-> [String] -> () -> DList (Report progress a)
onCleanup :: Maybe (String, Location)
-> [String] -> () -> DList (Report progress a)
onCleanup
          , onLeaf :: [String] -> item -> DList (Report progress a)
onLeaf = [String] -> item -> DList (Report progress a)
evalItem
          }

          groupStarted :: Path -> IO ()
          groupStarted :: Path -> IO ()
groupStarted = Format
format Format -> (Path -> Event) -> Path -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Event
Format.GroupStarted

          groupDone :: Path -> IO ()
          groupDone :: Path -> IO ()
groupDone = Format
format Format -> (Path -> Event) -> Path -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Event
Format.GroupDone

          onCleanup :: Maybe (String, Location) -> [String] -> () -> DList (Report progress a)
          onCleanup :: Maybe (String, Location)
-> [String] -> () -> DList (Report progress a)
onCleanup Maybe (String, Location)
_loc [String]
_groups () = DList (Report progress a)
forall a. Monoid a => a
mempty

      items :: [Report Progress Result]
      items :: [Report Progress Result]
items = ([String]
 -> WithReportResult_ Item -> DList (Report Progress Result))
-> [Tree () (WithReportResult_ Item)] -> [Report Progress Result]
forall item progress a.
([String] -> item -> DList (Report progress a))
-> [Tree () item] -> [Report progress a]
eval [String]
-> WithReportResult_ Item -> DList (Report Progress Result)
evalItem [Tree () (WithReportResult_ Item)]
runningSpecs
        where
          evalItem :: [String] -> WithReportResult_ Item -> DList (Report Progress Result)
          evalItem :: [String]
-> WithReportResult_ Item -> DList (Report Progress Result)
evalItem [String]
groups (WithReportResult ReportResult AbortEarly
reportResult (Item String
requirement Maybe Location
loc Result Progress Result
action)) = ([Report Progress Result] -> [Report Progress Result])
-> DList (Report Progress Result)
forall a. ([a] -> [a]) -> DList a
DList (([Report Progress Result] -> [Report Progress Result])
 -> DList (Report Progress Result))
-> ([Report Progress Result] -> [Report Progress Result])
-> DList (Report Progress Result)
forall a b. (a -> b) -> a -> b
$
              (IO () -> Report Progress Result
forall progress a. IO () -> Report progress a
Report (Path -> IO ()
reportItemStarted Path
path) Report Progress Result
-> [Report Progress Result] -> [Report Progress Result]
forall a. a -> [a] -> [a]
:)
            ([Report Progress Result] -> [Report Progress Result])
-> ([Report Progress Result] -> [Report Progress Result])
-> [Report Progress Result]
-> [Report Progress Result]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result Progress Result
-> ProgressCallback
-> ((Seconds, Either SomeException Result) -> IO AbortEarly)
-> Report Progress Result
forall progress a.
Result progress a
-> (progress -> IO ())
-> ((Seconds, Either SomeException a) -> IO AbortEarly)
-> Report progress a
ReportResult Result Progress Result
action ProgressCallback
progress (Seconds, Either SomeException Result) -> IO AbortEarly
result Report Progress Result
-> [Report Progress Result] -> [Report Progress Result]
forall a. a -> [a] -> [a]
:)
            where
              path :: Path
              path :: Path
path = ([String]
groups, String
requirement)

              progress :: ProgressCallback
              progress :: ProgressCallback
progress = IO Bool -> Path -> ProgressCallback
reportProgress IO Bool
timer Path
path

              result :: (Seconds, Either SomeException Result) -> IO AbortEarly
              result :: (Seconds, Either SomeException Result) -> IO AbortEarly
result = (Either SomeException Result -> IO Result)
-> (Seconds, Either SomeException Result) -> IO (Seconds, Result)
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) -> (Seconds, a) -> f (Seconds, b)
traverse ((SomeException -> IO Result)
-> (Result -> IO Result)
-> Either SomeException Result
-> IO Result
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO Result
exceptionToResult Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return) ((Seconds, Either SomeException Result) -> IO (Seconds, Result))
-> ((Seconds, Result) -> IO AbortEarly)
-> (Seconds, Either SomeException Result)
-> IO AbortEarly
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> EvalM AbortEarly -> IO AbortEarly
forall a. EvalM a -> IO a
runEvalM (EvalM AbortEarly -> IO AbortEarly)
-> ((Seconds, Result) -> EvalM AbortEarly)
-> (Seconds, Result)
-> IO AbortEarly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReportResult AbortEarly
reportResult Path
path Maybe Location
loc

          reportItemStarted :: Path -> IO ()
          reportItemStarted :: Path -> IO ()
reportItemStarted = Format
format Format -> (Path -> Event) -> Path -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> Event
Format.ItemStarted

      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 = Int
-> JobQueue Final Progress Result
-> [Report Progress Result]
-> IO ()
forall progress a.
Int -> JobQueue Final progress a -> [Report progress a] -> IO ()
JobQueue.run (EvalConfig -> Int
evalConfigConcurrentJobs EvalConfig
config) JobQueue Final Progress Result
jobs [Report Progress Result]
items

      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 [(Path, Item)] -> Env
Env EvalConfig
config (IORef [(Path, Item)] -> Env)
-> IO (IORef [(Path, Item)]) -> IO Env
forall (f :: * -> *) a b. Functor 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)

type ReportResult abort = Path -> Maybe Location -> (Seconds, Result) -> EvalM abort

data WithReportResult abort a = WithReportResult {
  forall abort a. WithReportResult abort a -> ReportResult abort
_reportResult :: ReportResult abort
, forall abort a. WithReportResult abort a -> a
_item :: a
}

type WithReportResult_ = WithReportResult AbortEarly

data Item = Item {
  Item -> String
itemDescription :: String
, Item -> Maybe Location
itemLocation :: Maybe Location
, Item -> Result Progress Result
itemAction :: JobQueue.Result Progress Result
}

applyFailFast :: (Result -> Bool) -> Tree c (WithReportResult () a) -> Tree c (WithReportResult_ a)
applyFailFast :: forall c a.
(Result -> Bool)
-> Tree c (WithReportResult () a) -> Tree c (WithReportResult_ a)
applyFailFast Result -> Bool
abortEarly = (WithReportResult () a -> WithReportResult_ a)
-> Tree c (WithReportResult () a) -> Tree c (WithReportResult_ a)
forall a b. (a -> b) -> Tree c a -> Tree c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithReportResult () a -> WithReportResult_ a
forall a. WithReportResult () a -> WithReportResult_ a
applyToWithReportResult
  where
    applyToWithReportResult :: WithReportResult () a -> WithReportResult_ a
    applyToWithReportResult :: forall a. WithReportResult () a -> WithReportResult_ a
applyToWithReportResult (WithReportResult Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
report a
a) = ReportResult AbortEarly -> a -> WithReportResult AbortEarly a
forall abort a. ReportResult abort -> a -> WithReportResult abort a
WithReportResult ((Path -> Maybe Location -> (Seconds, Result) -> EvalM ())
-> ReportResult AbortEarly
applyToReportResult Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
report) a
a

    applyToReportResult :: ReportResult () -> ReportResult AbortEarly
    applyToReportResult :: (Path -> Maybe Location -> (Seconds, Result) -> EvalM ())
-> ReportResult AbortEarly
applyToReportResult Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
report Path
path Maybe Location
loc result :: (Seconds, Result)
result@(Seconds
_, Result
r) = do
      Path -> Maybe Location -> (Seconds, Result) -> EvalM ()
report Path
path Maybe Location
loc (Seconds, Result)
result
      AbortEarly -> EvalM AbortEarly
forall a. a -> ReaderT Env IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AbortEarly -> EvalM AbortEarly) -> AbortEarly -> EvalM AbortEarly
forall a b. (a -> b) -> a -> b
$ if Result -> Bool
abortEarly Result
r then AbortEarly
AbortEarly else AbortEarly
NoAbortEarly

type Children c a = NonEmpty (Tree c (WithReportResult_ a))

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

    apply :: Maybe (String, Location) -> IO () -> Children c a -> Children c a
    apply :: forall c a.
Maybe (String, Location) -> IO () -> Children c a -> Children c a
apply Maybe (String, Location)
loc IO ()
cleanup = (WithReportResult AbortEarly a -> WithReportResult AbortEarly a)
-> NonEmpty (Tree c (WithReportResult AbortEarly a))
-> NonEmpty (Tree c (WithReportResult AbortEarly a))
forall a b c.
(a -> b) -> NonEmpty (Tree c a) -> NonEmpty (Tree c b)
forEachLeaf ((Result -> Bool)
-> WithReportResult AbortEarly a -> WithReportResult AbortEarly a
forall abort a.
(Result -> Bool)
-> WithReportResult abort a -> WithReportResult abort a
addCleanupOn Result -> Bool
abortEarly) (NonEmpty (Tree c (WithReportResult AbortEarly a))
 -> NonEmpty (Tree c (WithReportResult AbortEarly a)))
-> (NonEmpty (Tree c (WithReportResult AbortEarly a))
    -> NonEmpty (Tree c (WithReportResult AbortEarly a)))
-> NonEmpty (Tree c (WithReportResult AbortEarly a))
-> NonEmpty (Tree c (WithReportResult AbortEarly a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithReportResult AbortEarly a -> WithReportResult AbortEarly a)
-> NonEmpty (Tree c (WithReportResult AbortEarly a))
-> NonEmpty (Tree c (WithReportResult AbortEarly a))
forall a c. (a -> a) -> NonEmpty (Tree c a) -> NonEmpty (Tree c a)
forLastLeaf ((Result -> Bool)
-> WithReportResult AbortEarly a -> WithReportResult AbortEarly a
forall abort a.
(Result -> Bool)
-> WithReportResult abort a -> WithReportResult abort a
addCleanupOn (Bool -> Bool
not (Bool -> Bool) -> (Result -> Bool) -> Result -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> Bool
abortEarly))
      where
        addCleanupOn :: (Result -> Bool) -> WithReportResult abort a -> WithReportResult abort a
        addCleanupOn :: forall abort a.
(Result -> Bool)
-> WithReportResult abort a -> WithReportResult abort a
addCleanupOn Result -> Bool
p (WithReportResult ReportResult abort
report a
item) = ReportResult abort -> a -> WithReportResult abort a
forall abort a. ReportResult abort -> a -> WithReportResult abort a
WithReportResult ((Result -> Bool)
-> Maybe (String, Location)
-> IO ()
-> ReportResult abort
-> ReportResult abort
forall abort.
(Result -> Bool)
-> Maybe (String, Location)
-> IO ()
-> ReportResult abort
-> ReportResult abort
addCleanup Result -> Bool
p Maybe (String, Location)
loc IO ()
cleanup ReportResult abort
report) a
item

forEachLeaf :: (a -> b) -> NonEmpty (Tree c a) -> NonEmpty (Tree c b)
forEachLeaf :: forall a b c.
(a -> b) -> NonEmpty (Tree c a) -> NonEmpty (Tree c b)
forEachLeaf a -> b
f = (Tree c a -> Tree c b)
-> NonEmpty (Tree c a) -> NonEmpty (Tree c 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 c a -> Tree c b
forall a b. (a -> b) -> Tree c a -> Tree c b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f)

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

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

addCleanup :: (Result -> Bool) -> Maybe (String, Location) -> IO () -> ReportResult abort -> ReportResult abort
addCleanup :: forall abort.
(Result -> Bool)
-> Maybe (String, Location)
-> IO ()
-> ReportResult abort
-> ReportResult abort
addCleanup Result -> Bool
shouldRunCleanup Maybe (String, Location)
loc IO ()
cleanup ReportResult abort
reportProgress Path
path Maybe Location
l result :: (Seconds, Result)
result@(Seconds
t1, Result
r1) = do
  if Result -> Bool
shouldRunCleanup Result
r1 then do
    (Seconds
t2, ResultStatus
r2) <- IO (Seconds, ResultStatus)
-> ReaderT Env IO (Seconds, ResultStatus)
forall a. IO a -> ReaderT Env IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Seconds, ResultStatus)
 -> ReaderT Env IO (Seconds, ResultStatus))
-> IO (Seconds, ResultStatus)
-> ReaderT Env IO (Seconds, ResultStatus)
forall a b. (a -> b) -> a -> b
$ 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
    ReportResult abort
reportProgress Path
path Maybe Location
l ((Seconds, Result) -> EvalM abort)
-> (Seconds, Result) -> EvalM abort
forall a b. (a -> b) -> a -> b
$ (Seconds
t, Maybe (String, Location) -> Result -> ResultStatus -> Result
mergeResults Maybe (String, Location)
loc Result
r1 ResultStatus
r2)
  else do
    ReportResult abort
reportProgress Path
path Maybe Location
l (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 :: JobQueue Open Progress Result -> [Tree c EvalItem] -> IO [Tree c Item]
enqueueItems :: forall c.
JobQueue Open Progress Result
-> [Tree c EvalItem] -> IO [Tree c Item]
enqueueItems JobQueue Open Progress Result
queue = (Tree c EvalItem -> IO (Tree c Item))
-> [Tree c EvalItem] -> IO [Tree c Item]
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 Item) -> Tree c EvalItem -> IO (Tree c Item)
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 c a -> f (Tree c b)
traverse ((EvalItem -> IO Item) -> Tree c EvalItem -> IO (Tree c Item))
-> (EvalItem -> IO Item) -> Tree c EvalItem -> IO (Tree c Item)
forall a b. (a -> b) -> a -> b
$ JobQueue Open Progress Result -> EvalItem -> IO Item
enqueueItem JobQueue Open Progress Result
queue)

enqueueItem :: JobQueue Open Progress Result -> EvalItem -> IO Item
enqueueItem :: JobQueue Open Progress Result -> EvalItem -> IO Item
enqueueItem JobQueue Open Progress Result
queue EvalItem{String
Maybe Location
Concurrency
ProgressCallback -> IO Result
evalItemDescription :: EvalItem -> String
evalItemLocation :: EvalItem -> Maybe Location
evalItemConcurrency :: EvalItem -> Concurrency
evalItemAction :: EvalItem -> ProgressCallback -> IO Result
evalItemDescription :: String
evalItemLocation :: Maybe Location
evalItemConcurrency :: Concurrency
evalItemAction :: ProgressCallback -> IO Result
..} = do
  Result Progress Result
job <- JobQueue Open Progress Result
-> Concurrency
-> (ProgressCallback -> IO Result)
-> IO (Result Progress Result)
forall progress a.
JobQueue Open progress a
-> Concurrency -> Job progress a -> IO (Result progress a)
JobQueue.enqueue JobQueue Open Progress Result
queue Concurrency
evalItemConcurrency ProgressCallback -> IO Result
evalItemAction
  Item -> IO Item
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 :: Result Progress Result
itemAction = Result Progress Result
job
  }

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
onLeaf :: [String] -> a -> r
}

foldTree :: Monoid r => FoldTree c a r -> Tree c a -> r
foldTree :: forall r c a. Monoid 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
onLeaf :: forall c a r. FoldTree c a r -> [String] -> a -> r
onGroupStarted :: Path -> r
onGroupDone :: Path -> r
onCleanup :: Maybe (String, Location) -> [String] -> c -> r
onLeaf :: [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. Semigroup a => a -> a -> a
<> r
children r -> r -> r
forall a. Semigroup 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 m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([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. Semigroup a => a -> a -> a
<> r
cleanup
      where
        children :: r
children = (Tree c a -> r) -> NonEmpty (Tree c a) -> r
forall m a. Monoid m => (a -> m) -> NonEmpty a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([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
onLeaf ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
rGroups) a
a