{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}

module Test.Sandwich.Interpreters.StartTree (
  startTree
  , runNodesSequentially
  , markAllChildrenWithResult
  ) where


import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Trans.Reader
import Data.IORef
import qualified Data.List as L
import Data.Sequence hiding ((:>))
import qualified Data.Set as S
import Data.String.Interpolate
import qualified Data.Text as T
import Data.Time.Clock
import Data.Typeable
import GHC.Stack
import System.Directory
import System.FilePath
import System.IO
import Test.Sandwich.Formatters.Print
import Test.Sandwich.Formatters.Print.CallStacks
import Test.Sandwich.Formatters.Print.FailureReason
import Test.Sandwich.Formatters.Print.Logs
import Test.Sandwich.Formatters.Print.Printing
import Test.Sandwich.Interpreters.RunTree.Logging
import Test.Sandwich.Interpreters.RunTree.Util
import Test.Sandwich.RunTree
import Test.Sandwich.TestTimer
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Types.Spec
import Test.Sandwich.Types.TestTimer
import Test.Sandwich.Util
import UnliftIO.Exception
import UnliftIO.STM


baseContextFromCommon :: RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon :: forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon (RunNodeCommonWithStatus {s
l
t
Bool
Int
String
Maybe String
Maybe SrcLoc
Seq Int
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: t
runTreeOpen :: t
runTreeStatus :: s
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: l
runTreeLoc :: Maybe SrcLoc
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
..}) bc :: BaseContext
bc@(BaseContext {}) =
  BaseContext
bc { baseContextPath = runTreeFolder }

startTree :: (MonadIO m, HasBaseContext context) => RunNode context -> context -> m (Async Result)
startTree :: forall (m :: * -> *) context.
(MonadIO m, HasBaseContext context) =>
RunNode context -> context -> m (Async Result)
startTree node :: RunNode context
node@(RunNodeBefore {[RunNode context]
ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: [RunNode context]
runNodeBefore :: ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeChildren :: forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeBefore :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
..} = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    (IO Result -> IO (Result, UTCTime, UTCTime)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, UTCTime, UTCTime)
timed (ExampleT context IO ()
-> context -> Var (Seq LogEntry) -> Maybe String -> IO Result
forall r.
HasBaseContext r =>
ExampleM r ()
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM ExampleT context IO ()
runNodeBefore context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Exception in before '#{runTreeLabel}' handler|]))) IO (Result, UTCTime, UTCTime)
-> ((Result, UTCTime, UTCTime) -> IO (Result, ExtraTimingInfo))
-> IO (Result, ExtraTimingInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (result :: Result
result@(Failure fr :: FailureReason
fr@(Pending {})), UTCTime
_setupStartTime, UTCTime
setupFinishTime) -> do
        [RunNode context] -> context -> Result -> IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
runNodeChildren context
ctx (FailureReason -> Result
Failure FailureReason
fr)
        (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupFinishTime)
      (result :: Result
result@(Failure FailureReason
fr), UTCTime
_setupStartTime, UTCTime
setupFinishTime) -> do
        [RunNode context] -> context -> Result -> IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
runNodeChildren context
ctx (FailureReason -> Result
Failure (FailureReason -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> SomeExceptionWithEq -> FailureReason
GetContextException Maybe CallStack
forall a. Maybe a
Nothing (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq (SomeException -> SomeExceptionWithEq)
-> SomeException -> SomeExceptionWithEq
forall a b. (a -> b) -> a -> b
$ FailureReason -> SomeException
forall e. Exception e => e -> SomeException
toException FailureReason
fr))
        (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
result, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupFinishTime)
      (Result
Success, UTCTime
_setupStartTime, UTCTime
setupFinishTime) -> do
        IO [Result] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Result] -> IO ()) -> IO [Result] -> IO ()
forall a b. (a -> b) -> a -> b
$ [RunNode context] -> context -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx
        (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
Success, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupFinishTime)
      (Result
Cancelled, UTCTime
_setupStartTime, UTCTime
setupFinishTime) -> do
        (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
Cancelled, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupFinishTime)
      (Result
DryRun, UTCTime
_setupStartTime, UTCTime
setupFinishTime) -> do
        IO [Result] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Result] -> IO ()) -> IO [Result] -> IO ()
forall a b. (a -> b) -> a -> b
$ [RunNode context] -> context -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx
        (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
DryRun, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupFinishTime)
startTree node :: RunNode context
node@(RunNodeAfter {[RunNode context]
ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeChildren :: forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: [RunNode context]
runNodeAfter :: ExampleT context IO ()
runNodeAfter :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
..} = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    IORef (Result, ExtraTimingInfo)
result <- IO (IORef (Result, ExtraTimingInfo))
-> IO (IORef (Result, ExtraTimingInfo))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Result, ExtraTimingInfo))
 -> IO (IORef (Result, ExtraTimingInfo)))
-> IO (IORef (Result, ExtraTimingInfo))
-> IO (IORef (Result, ExtraTimingInfo))
forall a b. (a -> b) -> a -> b
$ (Result, ExtraTimingInfo) -> IO (IORef (Result, ExtraTimingInfo))
forall a. a -> IO (IORef a)
newIORef (Result
Success, ExtraTimingInfo
emptyExtraTimingInfo)
    IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
finally (IO [Result] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Result] -> IO ()) -> IO [Result] -> IO ()
forall a b. (a -> b) -> a -> b
$ [RunNode context] -> context -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx)
            (do
                (Result
ret, UTCTime
teardownStartTime, UTCTime
_teardownFinishTime) <- IO Result -> IO (Result, UTCTime, UTCTime)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, UTCTime, UTCTime)
timed (ExampleT context IO ()
-> context -> Var (Seq LogEntry) -> Maybe String -> IO Result
forall r.
HasBaseContext r =>
ExampleM r ()
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM ExampleT context IO ()
runNodeAfter context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Exception in after '#{runTreeLabel}' handler|]))
                IORef (Result, ExtraTimingInfo)
-> (Result, ExtraTimingInfo) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Result, ExtraTimingInfo)
result (Result
ret, UTCTime -> ExtraTimingInfo
mkTeardownTimingInfo UTCTime
teardownStartTime)
            )
    IO (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo))
-> IO (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a b. (a -> b) -> a -> b
$ IORef (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. IORef a -> IO a
readIORef IORef (Result, ExtraTimingInfo)
result
startTree node :: RunNode context
node@(RunNodeIntroduce {[RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
ExampleT context IO intro
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
intro -> ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildrenAugmented :: [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeAlloc :: ExampleT context IO intro
runNodeCleanup :: intro -> ExampleT context IO ()
runNodeChildrenAugmented :: ()
runNodeAlloc :: ()
runNodeCleanup :: ()
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
..} = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    IORef (Result, ExtraTimingInfo)
result <- IO (IORef (Result, ExtraTimingInfo))
-> IO (IORef (Result, ExtraTimingInfo))
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Result, ExtraTimingInfo))
 -> IO (IORef (Result, ExtraTimingInfo)))
-> IO (IORef (Result, ExtraTimingInfo))
-> IO (IORef (Result, ExtraTimingInfo))
forall a b. (a -> b) -> a -> b
$ (Result, ExtraTimingInfo) -> IO (IORef (Result, ExtraTimingInfo))
forall a. a -> IO (IORef a)
newIORef (Result
Success, ExtraTimingInfo
emptyExtraTimingInfo)
    IO (Either FailureReason intro, UTCTime, UTCTime)
-> ((Either FailureReason intro, UTCTime, UTCTime) -> IO ())
-> ((Either FailureReason intro, UTCTime, UTCTime) -> IO ())
-> IO ()
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (do
                let asyncExceptionResult :: SomeAsyncException -> Result
asyncExceptionResult SomeAsyncException
e = FailureReason -> Result
Failure (FailureReason -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ Maybe CallStack
-> Maybe String -> SomeAsyncExceptionWithEq -> FailureReason
GotAsyncException Maybe CallStack
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncException -> SomeAsyncExceptionWithEq
SomeAsyncExceptionWithEq SomeAsyncException
e)
                (IO (Either FailureReason intro, UTCTime, UTCTime)
 -> (SomeAsyncException -> IO ())
 -> IO (Either FailureReason intro, UTCTime, UTCTime))
-> (SomeAsyncException -> IO ())
-> IO (Either FailureReason intro, UTCTime, UTCTime)
-> IO (Either FailureReason intro, UTCTime, UTCTime)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Either FailureReason intro, UTCTime, UTCTime)
-> (SomeAsyncException -> IO ())
-> IO (Either FailureReason intro, UTCTime, UTCTime)
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\(SomeAsyncException
e :: SomeAsyncException) -> [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> context -> Result -> IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented context
ctx (SomeAsyncException -> Result
asyncExceptionResult SomeAsyncException
e)) (IO (Either FailureReason intro, UTCTime, UTCTime)
 -> IO (Either FailureReason intro, UTCTime, UTCTime))
-> IO (Either FailureReason intro, UTCTime, UTCTime)
-> IO (Either FailureReason intro, UTCTime, UTCTime)
forall a b. (a -> b) -> a -> b
$
                  IO (Either FailureReason intro)
-> IO (Either FailureReason intro, UTCTime, UTCTime)
forall (m :: * -> *) a. MonadIO m => m a -> m (a, UTCTime, UTCTime)
timed (ExampleT context IO intro
-> context
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason intro)
forall r a.
HasBaseContext r =>
ExampleM r a
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason a)
runExampleM' ExampleT context IO intro
runNodeAlloc context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])))
            (\(Either FailureReason intro
ret, UTCTime
setupStartTime, UTCTime
setupFinishTime) -> case Either FailureReason intro
ret of
                Left FailureReason
failureReason -> IORef (Result, ExtraTimingInfo)
-> (Result, ExtraTimingInfo) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Result, ExtraTimingInfo)
result (FailureReason -> Result
Failure FailureReason
failureReason, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupStartTime)
                Right intro
intro -> do
                  UTCTime
teardownStartTime <- IO UTCTime
getCurrentTime
                  Var Status -> UTCTime -> IO ()
forall (m :: * -> *). MonadIO m => Var Status -> UTCTime -> m ()
addTeardownStartTimeToStatus Var Status
runTreeStatus UTCTime
teardownStartTime
                  Result
ret' <- ExampleT context IO ()
-> context -> Var (Seq LogEntry) -> Maybe String -> IO Result
forall r.
HasBaseContext r =>
ExampleM r ()
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM (intro -> ExampleT context IO ()
runNodeCleanup intro
intro) context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])
                  IORef (Result, ExtraTimingInfo)
-> (Result, ExtraTimingInfo) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Result, ExtraTimingInfo)
result (Result
ret', Maybe UTCTime -> Maybe UTCTime -> ExtraTimingInfo
ExtraTimingInfo (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
setupFinishTime) (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
teardownStartTime))
            )
            (\(Either FailureReason intro
ret, UTCTime
_setupStartTime, UTCTime
setupFinishTime) -> do
                Var Status -> UTCTime -> IO ()
forall (m :: * -> *). MonadIO m => Var Status -> UTCTime -> m ()
addSetupFinishTimeToStatus Var Status
runTreeStatus UTCTime
setupFinishTime
                case Either FailureReason intro
ret of
                  Left failureReason :: FailureReason
failureReason@(Pending {}) -> do
                    -- TODO: add note about failure in allocation
                    [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> context -> Result -> IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented context
ctx (FailureReason -> Result
Failure FailureReason
failureReason)
                  Left FailureReason
failureReason -> do
                    -- TODO: add note about failure in allocation
                    [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> context -> Result -> IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented context
ctx (FailureReason -> Result
Failure (FailureReason -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> SomeExceptionWithEq -> FailureReason
GetContextException Maybe CallStack
forall a. Maybe a
Nothing (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq (SomeException -> SomeExceptionWithEq)
-> SomeException -> SomeExceptionWithEq
forall a b. (a -> b) -> a -> b
$ FailureReason -> SomeException
forall e. Exception e => e -> SomeException
toException FailureReason
failureReason))
                  Right intro
intro -> do
                    -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere.
                    -- It would be better to track the profile at the type level
                    let ctxFinal :: context
ctxFinal = case intro -> Maybe TestTimerProfile
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast intro
intro of
                          Just (TestTimerProfile Text
t) -> context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx (\BaseContext
bc -> BaseContext
bc { baseContextTestTimerProfile = t })
                          Maybe TestTimerProfile
Nothing -> context
ctx

                    IO [Result] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Result] -> IO ()) -> IO [Result] -> IO ()
forall a b. (a -> b) -> a -> b
$ [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> (LabelValue lab intro :> context) -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented ((intro -> LabelValue lab intro
forall (l :: Symbol) a. a -> LabelValue l a
LabelValue intro
intro) LabelValue lab intro -> context -> LabelValue lab intro :> context
forall a b. a -> b -> a :> b
:> context
ctxFinal)
            )
    IORef (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. IORef a -> IO a
readIORef IORef (Result, ExtraTimingInfo)
result
startTree node :: RunNode context
node@(RunNodeIntroduceWith {[RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
(intro -> ExampleT context IO [Result]) -> ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeChildrenAugmented :: ()
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildrenAugmented :: [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeIntroduceAction :: (intro -> ExampleT context IO [Result]) -> ExampleT context IO ()
runNodeIntroduceAction :: ()
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
..} = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  IORef (Either () [Result], ExtraTimingInfo)
didRunWrappedAction <- IO (IORef (Either () [Result], ExtraTimingInfo))
-> m (IORef (Either () [Result], ExtraTimingInfo))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Either () [Result], ExtraTimingInfo))
 -> m (IORef (Either () [Result], ExtraTimingInfo)))
-> IO (IORef (Either () [Result], ExtraTimingInfo))
-> m (IORef (Either () [Result], ExtraTimingInfo))
forall a b. (a -> b) -> a -> b
$ (Either () [Result], ExtraTimingInfo)
-> IO (IORef (Either () [Result], ExtraTimingInfo))
forall a. a -> IO (IORef a)
newIORef (() -> Either () [Result]
forall a b. a -> Either a b
Left (), ExtraTimingInfo
emptyExtraTimingInfo)
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    let wrappedAction :: ExampleT context IO (Result, ExtraTimingInfo)
wrappedAction = do
          let failureResult :: SomeException -> Result
failureResult SomeException
e = case SomeException -> Maybe FailureReason
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                Just fr :: FailureReason
fr@(Pending {}) -> FailureReason -> Result
Failure FailureReason
fr
                Maybe FailureReason
_ -> FailureReason -> Result
Failure (FailureReason -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason Maybe CallStack
forall a. Maybe a
Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|]
          (ExampleT context IO ()
 -> (SomeException -> ExampleT context IO ())
 -> ExampleT context IO ())
-> (SomeException -> ExampleT context IO ())
-> ExampleT context IO ()
-> ExampleT context IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExampleT context IO ()
-> (SomeException -> ExampleT context IO ())
-> ExampleT context IO ()
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\SomeException
e -> Var Status -> SomeException -> ExampleT context IO ()
forall (m :: * -> *).
MonadIO m =>
Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
runTreeStatus SomeException
e ExampleT context IO ()
-> ExampleT context IO () -> ExampleT context IO ()
forall a b.
ExampleT context IO a
-> ExampleT context IO b -> ExampleT context IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> context -> Result -> ExampleT context IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented context
ctx (SomeException -> Result
failureResult SomeException
e)) (ExampleT context IO () -> ExampleT context IO ())
-> ExampleT context IO () -> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ do
            IORef (Maybe UTCTime)
beginningCleanupVar <- IO (IORef (Maybe UTCTime))
-> ExampleT context IO (IORef (Maybe UTCTime))
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Maybe UTCTime))
 -> ExampleT context IO (IORef (Maybe UTCTime)))
-> IO (IORef (Maybe UTCTime))
-> ExampleT context IO (IORef (Maybe UTCTime))
forall a b. (a -> b) -> a -> b
$ Maybe UTCTime -> IO (IORef (Maybe UTCTime))
forall a. a -> IO (IORef a)
newIORef Maybe UTCTime
forall a. Maybe a
Nothing
            ()
results <- (intro -> ExampleT context IO [Result]) -> ExampleT context IO ()
runNodeIntroduceAction ((intro -> ExampleT context IO [Result]) -> ExampleT context IO ())
-> (intro -> ExampleT context IO [Result])
-> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ \intro
intro -> do
              UTCTime
setupFinishTime <- IO UTCTime -> ExampleT context IO UTCTime
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              Var Status -> UTCTime -> ExampleT context IO ()
forall (m :: * -> *). MonadIO m => Var Status -> UTCTime -> m ()
addSetupFinishTimeToStatus Var Status
runTreeStatus UTCTime
setupFinishTime

              [Result]
results <- IO [Result] -> ExampleT context IO [Result]
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Result] -> ExampleT context IO [Result])
-> IO [Result] -> ExampleT context IO [Result]
forall a b. (a -> b) -> a -> b
$ [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
-> (LabelValue lab intro :> context) -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented ((intro -> LabelValue lab intro
forall (l :: Symbol) a. a -> LabelValue l a
LabelValue intro
intro) LabelValue lab intro -> context -> LabelValue lab intro :> context
forall a b. a -> b -> a :> b
:> context
ctx)

              UTCTime
teardownStartTime <- IO UTCTime -> ExampleT context IO UTCTime
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              Var Status -> UTCTime -> ExampleT context IO ()
forall (m :: * -> *). MonadIO m => Var Status -> UTCTime -> m ()
addTeardownStartTimeToStatus Var Status
runTreeStatus UTCTime
teardownStartTime
              IO () -> ExampleT context IO ()
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT context IO ())
-> IO () -> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Maybe UTCTime) -> Maybe UTCTime -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe UTCTime)
beginningCleanupVar (UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
teardownStartTime)

              IO () -> ExampleT context IO ()
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT context IO ())
-> IO () -> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Either () [Result], ExtraTimingInfo)
-> (Either () [Result], ExtraTimingInfo) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either () [Result], ExtraTimingInfo)
didRunWrappedAction ([Result] -> Either () [Result]
forall a b. b -> Either a b
Right [Result]
results, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupFinishTime)
              [Result] -> ExampleT context IO [Result]
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
results

            IO (Maybe UTCTime) -> ExampleT context IO (Maybe UTCTime)
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Maybe UTCTime) -> IO (Maybe UTCTime)
forall a. IORef a -> IO a
readIORef IORef (Maybe UTCTime)
beginningCleanupVar) ExampleT context IO (Maybe UTCTime)
-> (Maybe UTCTime -> ExampleT context IO ())
-> ExampleT context IO ()
forall a b.
ExampleT context IO a
-> (a -> ExampleT context IO b) -> ExampleT context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Maybe UTCTime
Nothing -> () -> ExampleT context IO ()
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              Just UTCTime
teardownStartTime ->
                IO () -> ExampleT context IO ()
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT context IO ())
-> IO () -> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Either () [Result], ExtraTimingInfo)
-> ((Either () [Result], ExtraTimingInfo)
    -> (Either () [Result], ExtraTimingInfo))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef (Either () [Result], ExtraTimingInfo)
didRunWrappedAction (((Either () [Result], ExtraTimingInfo)
  -> (Either () [Result], ExtraTimingInfo))
 -> IO ())
-> ((Either () [Result], ExtraTimingInfo)
    -> (Either () [Result], ExtraTimingInfo))
-> IO ()
forall a b. (a -> b) -> a -> b
$
                  \(Either () [Result]
ret, ExtraTimingInfo
timingInfo) -> (Either () [Result]
ret, ExtraTimingInfo
timingInfo { teardownStartTime = Just teardownStartTime })

            () -> ExampleT context IO ()
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
results

          IO (Either () [Result], ExtraTimingInfo)
-> ExampleT context IO (Either () [Result], ExtraTimingInfo)
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef (Either () [Result], ExtraTimingInfo)
-> IO (Either () [Result], ExtraTimingInfo)
forall a. IORef a -> IO a
readIORef IORef (Either () [Result], ExtraTimingInfo)
didRunWrappedAction) ExampleT context IO (Either () [Result], ExtraTimingInfo)
-> ((Either () [Result], ExtraTimingInfo)
    -> ExampleT context IO (Result, ExtraTimingInfo))
-> ExampleT context IO (Result, ExtraTimingInfo)
forall a b.
ExampleT context IO a
-> (a -> ExampleT context IO b) -> ExampleT context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            (Left (), ExtraTimingInfo
timingInfo) -> (Result, ExtraTimingInfo)
-> ExampleT context IO (Result, ExtraTimingInfo)
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailureReason -> Result
Failure (FailureReason -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason Maybe CallStack
forall a. Maybe a
Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|], ExtraTimingInfo
timingInfo)
            (Right [Result]
_, ExtraTimingInfo
timingInfo) -> (Result, ExtraTimingInfo)
-> ExampleT context IO (Result, ExtraTimingInfo)
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
Success, ExtraTimingInfo
timingInfo)
    ExampleT context IO (Result, ExtraTimingInfo)
-> context
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason (Result, ExtraTimingInfo))
forall r a.
HasBaseContext r =>
ExampleM r a
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason a)
runExampleM' ExampleT context IO (Result, ExtraTimingInfo)
wrappedAction context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) IO (Either FailureReason (Result, ExtraTimingInfo))
-> (Either FailureReason (Result, ExtraTimingInfo)
    -> IO (Result, ExtraTimingInfo))
-> IO (Result, ExtraTimingInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left FailureReason
err -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailureReason -> Result
Failure FailureReason
err, ExtraTimingInfo
emptyExtraTimingInfo)
      Right (Result, ExtraTimingInfo)
x -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result, ExtraTimingInfo)
x
startTree node :: RunNode context
node@(RunNodeAround {[RunNode context]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
ExampleT context IO [Result] -> ExampleT context IO ()
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeChildren :: forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: [RunNode context]
runNodeActionWith :: ExampleT context IO [Result] -> ExampleT context IO ()
runNodeActionWith :: forall s l t context.
RunNodeWithStatus context s l t
-> ExampleT context IO [Result] -> ExampleT context IO ()
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
..} = RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  IORef (Either () [Result], ExtraTimingInfo)
didRunWrappedAction <- IO (IORef (Either () [Result], ExtraTimingInfo))
-> m (IORef (Either () [Result], ExtraTimingInfo))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Either () [Result], ExtraTimingInfo))
 -> m (IORef (Either () [Result], ExtraTimingInfo)))
-> IO (IORef (Either () [Result], ExtraTimingInfo))
-> m (IORef (Either () [Result], ExtraTimingInfo))
forall a b. (a -> b) -> a -> b
$ (Either () [Result], ExtraTimingInfo)
-> IO (IORef (Either () [Result], ExtraTimingInfo))
forall a. a -> IO (IORef a)
newIORef (() -> Either () [Result]
forall a b. a -> Either a b
Left (), ExtraTimingInfo
emptyExtraTimingInfo)
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    let wrappedAction :: ExampleT context IO (Result, ExtraTimingInfo)
wrappedAction = do
          let failureResult :: SomeException -> Result
failureResult SomeException
e = case SomeException -> Maybe FailureReason
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                Just fr :: FailureReason
fr@(Pending {}) -> FailureReason -> Result
Failure FailureReason
fr
                Maybe FailureReason
_ -> FailureReason -> Result
Failure (FailureReason -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason Maybe CallStack
forall a. Maybe a
Nothing [i|around '#{runTreeLabel}' handler threw exception|]
          (ExampleT context IO ()
 -> (SomeException -> ExampleT context IO ())
 -> ExampleT context IO ())
-> (SomeException -> ExampleT context IO ())
-> ExampleT context IO ()
-> ExampleT context IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ExampleT context IO ()
-> (SomeException -> ExampleT context IO ())
-> ExampleT context IO ()
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\SomeException
e -> Var Status -> SomeException -> ExampleT context IO ()
forall (m :: * -> *).
MonadIO m =>
Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
runTreeStatus SomeException
e ExampleT context IO ()
-> ExampleT context IO () -> ExampleT context IO ()
forall a b.
ExampleT context IO a
-> ExampleT context IO b -> ExampleT context IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [RunNode context] -> context -> Result -> ExampleT context IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
runNodeChildren context
ctx (SomeException -> Result
failureResult SomeException
e)) (ExampleT context IO () -> ExampleT context IO ())
-> ExampleT context IO () -> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ do
            ExampleT context IO [Result] -> ExampleT context IO ()
runNodeActionWith (ExampleT context IO [Result] -> ExampleT context IO ())
-> ExampleT context IO [Result] -> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ do
              UTCTime
setupFinishTime <- IO UTCTime -> ExampleT context IO UTCTime
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
              Var Status -> UTCTime -> ExampleT context IO ()
forall (m :: * -> *). MonadIO m => Var Status -> UTCTime -> m ()
addSetupFinishTimeToStatus Var Status
runTreeStatus UTCTime
setupFinishTime
              [Result]
results <- IO [Result] -> ExampleT context IO [Result]
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Result] -> ExampleT context IO [Result])
-> IO [Result] -> ExampleT context IO [Result]
forall a b. (a -> b) -> a -> b
$ [RunNode context] -> context -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx
              IO () -> ExampleT context IO ()
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT context IO ())
-> IO () -> ExampleT context IO ()
forall a b. (a -> b) -> a -> b
$ IORef (Either () [Result], ExtraTimingInfo)
-> (Either () [Result], ExtraTimingInfo) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either () [Result], ExtraTimingInfo)
didRunWrappedAction ([Result] -> Either () [Result]
forall a b. b -> Either a b
Right [Result]
results, UTCTime -> ExtraTimingInfo
mkSetupTimingInfo UTCTime
setupFinishTime)
              [Result] -> ExampleT context IO [Result]
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
results

          (IO (Either () [Result], ExtraTimingInfo)
-> ExampleT context IO (Either () [Result], ExtraTimingInfo)
forall a. IO a -> ExampleT context IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () [Result], ExtraTimingInfo)
 -> ExampleT context IO (Either () [Result], ExtraTimingInfo))
-> IO (Either () [Result], ExtraTimingInfo)
-> ExampleT context IO (Either () [Result], ExtraTimingInfo)
forall a b. (a -> b) -> a -> b
$ IORef (Either () [Result], ExtraTimingInfo)
-> IO (Either () [Result], ExtraTimingInfo)
forall a. IORef a -> IO a
readIORef IORef (Either () [Result], ExtraTimingInfo)
didRunWrappedAction) ExampleT context IO (Either () [Result], ExtraTimingInfo)
-> ((Either () [Result], ExtraTimingInfo)
    -> ExampleT context IO (Result, ExtraTimingInfo))
-> ExampleT context IO (Result, ExtraTimingInfo)
forall a b.
ExampleT context IO a
-> (a -> ExampleT context IO b) -> ExampleT context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            (Left (), ExtraTimingInfo
timingInfo) -> (Result, ExtraTimingInfo)
-> ExampleT context IO (Result, ExtraTimingInfo)
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailureReason -> Result
Failure (FailureReason -> Result) -> FailureReason -> Result
forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason Maybe CallStack
forall a. Maybe a
Nothing [i|around '#{runTreeLabel}' handler didn't call action|], ExtraTimingInfo
timingInfo)
            (Right [Result]
_, ExtraTimingInfo
timingInfo) -> (Result, ExtraTimingInfo)
-> ExampleT context IO (Result, ExtraTimingInfo)
forall a. a -> ExampleT context IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
Success, ExtraTimingInfo
timingInfo)
    ExampleT context IO (Result, ExtraTimingInfo)
-> context
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason (Result, ExtraTimingInfo))
forall r a.
HasBaseContext r =>
ExampleM r a
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason a)
runExampleM' ExampleT context IO (Result, ExtraTimingInfo)
wrappedAction context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) IO (Either FailureReason (Result, ExtraTimingInfo))
-> (Either FailureReason (Result, ExtraTimingInfo)
    -> IO (Result, ExtraTimingInfo))
-> IO (Result, ExtraTimingInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left FailureReason
err -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailureReason -> Result
Failure FailureReason
err, ExtraTimingInfo
emptyExtraTimingInfo)
      Right (Result, ExtraTimingInfo)
x -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result, ExtraTimingInfo)
x
startTree node :: RunNode context
node@(RunNodeDescribe {[RunNode context]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeChildren :: forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: [RunNode context]
..}) context
ctx' = do
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    (([Result] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([Result] -> Int) -> ([Result] -> [Result]) -> [Result] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result -> Bool) -> [Result] -> [Result]
forall a. (a -> Bool) -> [a] -> [a]
L.filter Result -> Bool
isFailure) ([Result] -> Int) -> IO [Result] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RunNode context] -> context -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx) IO Int
-> (Int -> IO (Result, ExtraTimingInfo))
-> IO (Result, ExtraTimingInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Int
0 -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
Success, ExtraTimingInfo
emptyExtraTimingInfo)
      Int
n -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailureReason -> Result
Failure (Maybe CallStack -> Int -> FailureReason
ChildrenFailed Maybe CallStack
forall a. Maybe a
Nothing Int
n), ExtraTimingInfo
emptyExtraTimingInfo)
startTree node :: RunNode context
node@(RunNodeParallel {[RunNode context]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeChildren :: forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: [RunNode context]
..}) context
ctx' = do
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    (([Result] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([Result] -> Int) -> ([Result] -> [Result]) -> [Result] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result -> Bool) -> [Result] -> [Result]
forall a. (a -> Bool) -> [a] -> [a]
L.filter Result -> Bool
isFailure) ([Result] -> Int) -> IO [Result] -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RunNode context] -> context -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesConcurrently [RunNode context]
runNodeChildren context
ctx) IO Int
-> (Int -> IO (Result, ExtraTimingInfo))
-> IO (Result, ExtraTimingInfo)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Int
0 -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result
Success, ExtraTimingInfo
emptyExtraTimingInfo)
      Int
n -> (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FailureReason -> Result
Failure (Maybe CallStack -> Int -> FailureReason
ChildrenFailed Maybe CallStack
forall a. Maybe a
Nothing Int
n), ExtraTimingInfo
emptyExtraTimingInfo)
startTree node :: RunNode context
node@(RunNodeIt {ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeExample :: ExampleT context IO ()
runNodeExample :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
..}) context
ctx' = do
  let ctx :: context
ctx = context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' ((BaseContext -> BaseContext) -> context)
-> (BaseContext -> BaseContext) -> context
forall a b. (a -> b) -> a -> b
$ RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> BaseContext -> BaseContext
forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO (Result, ExtraTimingInfo) -> m (Async Result))
-> IO (Result, ExtraTimingInfo) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    (, ExtraTimingInfo
emptyExtraTimingInfo) (Result -> (Result, ExtraTimingInfo))
-> IO Result -> IO (Result, ExtraTimingInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExampleT context IO ()
-> context -> Var (Seq LogEntry) -> Maybe String -> IO Result
forall r.
HasBaseContext r =>
ExampleM r ()
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM ExampleT context IO ()
runNodeExample context
ctx (RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Var (Seq LogEntry)
forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLogs RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon) Maybe String
forall a. Maybe a
Nothing

-- * Util

runInAsync :: (HasBaseContext context, MonadIO m) => RunNode context -> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync :: forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context
-> context -> IO (Result, ExtraTimingInfo) -> m (Async Result)
runInAsync RunNode context
node context
ctx IO (Result, ExtraTimingInfo)
action = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLabel :: String
runTreeId :: Int
runTreeAncestors :: Seq Int
runTreeToggled :: Var Bool
runTreeOpen :: Var Bool
runTreeStatus :: Var Status
runTreeVisible :: Bool
runTreeFolder :: Maybe String
runTreeVisibilityLevel :: Int
runTreeRecordTime :: Bool
runTreeLogs :: Var (Seq LogEntry)
runTreeLoc :: Maybe SrcLoc
..} = RunNode context
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node
  let bc :: BaseContext
bc@(BaseContext {Maybe String
Maybe (Set Int)
Text
TestTimer
Options
baseContextPath :: BaseContext -> Maybe String
baseContextTestTimerProfile :: BaseContext -> Text
baseContextPath :: Maybe String
baseContextRunRoot :: Maybe String
baseContextErrorSymlinksDir :: Maybe String
baseContextOptions :: Options
baseContextOnlyRunIds :: Maybe (Set Int)
baseContextTestTimerProfile :: Text
baseContextTestTimer :: TestTimer
baseContextRunRoot :: BaseContext -> Maybe String
baseContextErrorSymlinksDir :: BaseContext -> Maybe String
baseContextOptions :: BaseContext -> Options
baseContextOnlyRunIds :: BaseContext -> Maybe (Set Int)
baseContextTestTimer :: BaseContext -> TestTimer
..}) = context -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext context
ctx
  let timerFn :: IO a -> IO a
timerFn = case Bool
runTreeRecordTime of
        Bool
True -> TestTimer -> Text -> Text -> IO a -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
TestTimer -> Text -> Text -> m a -> m a
timeAction' (BaseContext -> TestTimer
forall context. HasTestTimer context => context -> TestTimer
getTestTimer BaseContext
bc) Text
baseContextTestTimerProfile (String -> Text
T.pack String
runTreeLabel)
        Bool
_ -> IO a -> IO a
forall a. a -> a
id
  UTCTime
startTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  MVar ()
mvar <- IO (MVar ()) -> m (MVar ())
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  Async Result
myAsync <- IO (Async Result) -> m (Async Result)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Async Result) -> m (Async Result))
-> IO (Async Result) -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO Result) -> IO (Async Result)
forall a. ((forall a. IO a -> IO a) -> IO a) -> IO (Async a)
asyncWithUnmask (((forall a. IO a -> IO a) -> IO Result) -> IO (Async Result))
-> ((forall a. IO a -> IO a) -> IO Result) -> IO (Async Result)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
unmask -> do
    (IO Result -> (SomeException -> IO ()) -> IO Result)
-> (SomeException -> IO ()) -> IO Result -> IO Result
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO Result -> (SomeException -> IO ()) -> IO Result
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException (Var Status -> SomeException -> IO ()
forall (m :: * -> *).
MonadIO m =>
Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
runTreeStatus) (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ IO Result -> IO Result
forall a. IO a -> IO a
unmask (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ do
      MVar () -> IO ()
forall a. MVar a -> IO a
readMVar MVar ()
mvar
      (Result
result, ExtraTimingInfo
extraTimingInfo) <- IO (Result, ExtraTimingInfo) -> IO (Result, ExtraTimingInfo)
forall a. IO a -> IO a
timerFn IO (Result, ExtraTimingInfo)
action
      UTCTime
endTime <- IO UTCTime -> IO UTCTime
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Var Status
runTreeStatus (Status -> STM ()) -> Status -> STM ()
forall a b. (a -> b) -> a -> b
$ UTCTime
-> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Result -> Status
Done UTCTime
startTime (ExtraTimingInfo -> Maybe UTCTime
setupFinishTime ExtraTimingInfo
extraTimingInfo) (ExtraTimingInfo -> Maybe UTCTime
teardownStartTime ExtraTimingInfo
extraTimingInfo) UTCTime
endTime Result
result

      Result -> (FailureReason -> IO ()) -> IO ()
forall (m :: * -> *).
Monad m =>
Result -> (FailureReason -> m ()) -> m ()
whenFailure Result
result ((FailureReason -> IO ()) -> IO ())
-> (FailureReason -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FailureReason
reason -> do
        -- Make sure the folder exists, if configured
        Maybe String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextPath ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True

        -- Create error symlink when configured to
        case RunNode context
node of
          RunNodeDescribe {} -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- These are just noisy so don't create them
          RunNodeParallel {} -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- These are just noisy so don't create them
          RunNode context
_ -> do
            Maybe String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextErrorSymlinksDir ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
errorsDir ->
              Maybe String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextPath ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
                Maybe String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextRunRoot ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
runRoot -> do
                  let symlinkBaseName :: String
symlinkBaseName = case Maybe SrcLoc
runTreeLoc of
                        Maybe SrcLoc
Nothing -> String -> String
takeFileName String
dir
                        Just SrcLoc
loc -> [i|#{srcLocFile loc}_line#{srcLocStartLine loc}_#{takeFileName dir}|]
                  let symlinkPath :: String
symlinkPath = String
errorsDir String -> String -> String
</> (String -> Int -> Int -> String
nodeToFolderName String
symlinkBaseName Int
9999999 Int
runTreeId)

                  -- Delete the symlink if it's already present. This can happen when re-running
                  -- a previously failed test
                  Bool
exists <- String -> IO Bool
doesPathExist String
symlinkPath
                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
symlinkPath

#ifndef mingw32_HOST_OS
                  -- Get a relative path from the error dir to the results dir. System.FilePath doesn't want to
                  -- introduce ".." components, so we have to do it ourselves
                  let errorDirDepth :: Int
errorDirDepth = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([String] -> Int) -> [String] -> Int
forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String
makeRelative String
runRoot String
errorsDir

                  -- Don't do createDirectoryLink on Windows, as creating symlinks is generally not allowed for users.
                  -- See https://security.stackexchange.com/questions/10194/why-do-you-have-to-be-an-admin-to-create-a-symlink-in-windows
                  -- TODO: could we detect if this permission is available?
                  let relativePath :: String
relativePath = [String] -> String
joinPath (Int -> String -> [String]
forall a. Int -> a -> [a]
L.replicate Int
errorDirDepth String
"..") String -> String -> String
</> (String -> String -> String
makeRelative String
runRoot String
dir)
                  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
createDirectoryLink String
relativePath String
symlinkPath
#endif

        -- Write failure info
        Maybe String -> (String -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextPath ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
dir -> do
          String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (String
dir String -> String -> String
</> String
"failure.txt") IOMode
AppendMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
            -- Use the PrintFormatter to format failure.txt nicely
            let pf :: PrintFormatter
pf = PrintFormatter
defaultPrintFormatter {
                  printFormatterUseColor = False
                  , printFormatterLogLevel = Just LevelDebug
                  , printFormatterIncludeCallStacks = True
                  }
            (ReaderT (PrintFormatter, Int, Handle) IO ()
 -> (PrintFormatter, Int, Handle) -> IO ())
-> (PrintFormatter, Int, Handle)
-> ReaderT (PrintFormatter, Int, Handle) IO ()
-> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT (PrintFormatter, Int, Handle) IO ()
-> (PrintFormatter, Int, Handle) -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (PrintFormatter
pf, Int
0, Handle
h) (ReaderT (PrintFormatter, Int, Handle) IO () -> IO ())
-> ReaderT (PrintFormatter, Int, Handle) IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO ()
printFailureReason FailureReason
reason
              Maybe CallStack
-> (CallStack -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust (FailureReason -> Maybe CallStack
failureCallStack FailureReason
reason) ((CallStack -> ReaderT (PrintFormatter, Int, Handle) IO ())
 -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> (CallStack -> ReaderT (PrintFormatter, Int, Handle) IO ())
-> ReaderT (PrintFormatter, Int, Handle) IO ()
forall a b. (a -> b) -> a -> b
$ \CallStack
cs -> do
                String -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall {b} {m :: * -> *}.
(MonadReader (PrintFormatter, b, Handle) m, MonadIO m) =>
String -> m ()
p String
"\n"
                CallStack -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (m :: * -> *).
(MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) =>
CallStack -> m ()
printCallStack CallStack
cs
              String -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall {b} {m :: * -> *}.
(MonadReader (PrintFormatter, b, Handle) m, MonadIO m) =>
String -> m ()
p String
"\n"
              Var (Seq LogEntry) -> ReaderT (PrintFormatter, Int, Handle) IO ()
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, MonadReader (PrintFormatter, Int, Handle) m,
 Foldable t) =>
TVar (t LogEntry) -> m ()
printLogs Var (Seq LogEntry)
runTreeLogs

      Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Var Status
runTreeStatus (Status -> STM ()) -> Status -> STM ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> Maybe UTCTime -> Maybe UTCTime -> Async Result -> Status
Running UTCTime
startTime Maybe UTCTime
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing Async Result
myAsync
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
  Async Result -> m (Async Result)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Async Result
myAsync  -- TODO: fix race condition with writing to runTreeStatus (here and above)

-- | Run a list of children sequentially, cancelling everything on async exception TODO
runNodesSequentially :: HasBaseContext context => [RunNode context] -> context -> IO [Result]
runNodesSequentially :: forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
children context
ctx =
  (IO [Result] -> (SomeAsyncException -> IO ()) -> IO [Result])
-> (SomeAsyncException -> IO ()) -> IO [Result] -> IO [Result]
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO [Result] -> (SomeAsyncException -> IO ()) -> IO [Result]
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\(SomeAsyncException
e :: SomeAsyncException) -> [RunNode context] -> SomeAsyncException -> IO ()
forall context. [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith [RunNode context]
children SomeAsyncException
e) (IO [Result] -> IO [Result]) -> IO [Result] -> IO [Result]
forall a b. (a -> b) -> a -> b
$
    [RunNode context] -> (RunNode context -> IO Result) -> IO [Result]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((RunNode context -> Bool) -> [RunNode context] -> [RunNode context]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (context -> RunNode context -> Bool
forall ctx context s l t.
HasBaseContext ctx =>
ctx -> RunNodeWithStatus context s l t -> Bool
shouldRunChild context
ctx) [RunNode context]
children) ((RunNode context -> IO Result) -> IO [Result])
-> (RunNode context -> IO Result) -> IO [Result]
forall a b. (a -> b) -> a -> b
$ \RunNode context
child ->
      RunNode context -> context -> IO (Async Result)
forall (m :: * -> *) context.
(MonadIO m, HasBaseContext context) =>
RunNode context -> context -> m (Async Result)
startTree RunNode context
child context
ctx IO (Async Result) -> (Async Result -> IO Result) -> IO Result
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Async Result -> IO Result
forall a. Async a -> IO a
wait

-- | Run a list of children sequentially, cancelling everything on async exception TODO
runNodesConcurrently :: HasBaseContext context => [RunNode context] -> context -> IO [Result]
runNodesConcurrently :: forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesConcurrently [RunNode context]
children context
ctx =
  (IO [Result] -> (SomeAsyncException -> IO ()) -> IO [Result])
-> (SomeAsyncException -> IO ()) -> IO [Result] -> IO [Result]
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO [Result] -> (SomeAsyncException -> IO ()) -> IO [Result]
forall (m :: * -> *) e a b.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\(SomeAsyncException
e :: SomeAsyncException) -> [RunNode context] -> SomeAsyncException -> IO ()
forall context. [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith [RunNode context]
children SomeAsyncException
e) (IO [Result] -> IO [Result]) -> IO [Result] -> IO [Result]
forall a b. (a -> b) -> a -> b
$
    (Async Result -> IO Result) -> [Async Result] -> IO [Result]
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 Async Result -> IO Result
forall a. Async a -> IO a
wait ([Async Result] -> IO [Result]) -> IO [Async Result] -> IO [Result]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [IO (Async Result)] -> IO [Async Result]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [RunNode context -> context -> IO (Async Result)
forall (m :: * -> *) context.
(MonadIO m, HasBaseContext context) =>
RunNode context -> context -> m (Async Result)
startTree RunNode context
child context
ctx
                           | RunNode context
child <- (RunNode context -> Bool) -> [RunNode context] -> [RunNode context]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (context -> RunNode context -> Bool
forall ctx context s l t.
HasBaseContext ctx =>
ctx -> RunNodeWithStatus context s l t -> Bool
shouldRunChild context
ctx) [RunNode context]
children]

markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult :: forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
children context'
baseContext Result
status = do
  UTCTime
now <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  [RunNodeCommonWithStatus
   (Var Status) (Var (Seq LogEntry)) (Var Bool)]
-> (RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)
    -> m ())
-> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ((RunNodeCommonWithStatus
   (Var Status) (Var (Seq LogEntry)) (Var Bool)
 -> Bool)
-> [RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)]
-> [RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)]
forall a. (a -> Bool) -> [a] -> [a]
L.filter (context'
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Bool
forall ctx s l t.
HasBaseContext ctx =>
ctx -> RunNodeCommonWithStatus s l t -> Bool
shouldRunChild' context'
baseContext) ([RunNodeCommonWithStatus
    (Var Status) (Var (Seq LogEntry)) (Var Bool)]
 -> [RunNodeCommonWithStatus
       (Var Status) (Var (Seq LogEntry)) (Var Bool)])
-> [RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)]
-> [RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)]
forall a b. (a -> b) -> a -> b
$ (RunNode context
 -> [RunNodeCommonWithStatus
       (Var Status) (Var (Seq LogEntry)) (Var Bool)])
-> [RunNode context]
-> [RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap RunNode context
-> [RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)]
forall context s l t.
RunNodeWithStatus context s l t -> [RunNodeCommonWithStatus s l t]
getCommons [RunNode context]
children) ((RunNodeCommonWithStatus
    (Var Status) (Var (Seq LogEntry)) (Var Bool)
  -> m ())
 -> m ())
-> (RunNodeCommonWithStatus
      (Var Status) (Var (Seq LogEntry)) (Var Bool)
    -> m ())
-> m ()
forall a b. (a -> b) -> a -> b
$ \RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
child ->
    IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Status -> (Status -> Status) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar (RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Var Status
forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
child) ((Status -> Status) -> STM ()) -> (Status -> Status) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
      Running {Maybe UTCTime
UTCTime
Async Result
statusStartTime :: UTCTime
statusSetupFinishTime :: Maybe UTCTime
statusTeardownStartTime :: Maybe UTCTime
statusAsync :: Async Result
statusStartTime :: Status -> UTCTime
statusSetupFinishTime :: Status -> Maybe UTCTime
statusTeardownStartTime :: Status -> Maybe UTCTime
statusAsync :: Status -> Async Result
..} -> UTCTime
-> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Result -> Status
Done UTCTime
now Maybe UTCTime
statusSetupFinishTime Maybe UTCTime
statusTeardownStartTime UTCTime
now Result
status
      done :: Status
done@(Done {}) -> Status
done { statusResult = status }
      Status
_ -> UTCTime
-> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Result -> Status
Done UTCTime
now Maybe UTCTime
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing UTCTime
now Result
status

cancelAllChildrenWith :: [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith :: forall context. [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith [RunNode context]
children SomeAsyncException
e = do
  [RunNode context] -> (RunNode context -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RunNode context]
children ((RunNode context -> IO ()) -> IO ())
-> (RunNode context -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \RunNode context
node ->
    Var Status -> IO Status
forall (m :: * -> *) a. MonadIO m => TVar a -> m a
readTVarIO (RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Var Status
forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus (RunNodeCommonWithStatus
   (Var Status) (Var (Seq LogEntry)) (Var Bool)
 -> Var Status)
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Var Status
forall a b. (a -> b) -> a -> b
$ RunNode context
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) IO Status -> (Status -> 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
>>= \case
      Running {Maybe UTCTime
UTCTime
Async Result
statusStartTime :: Status -> UTCTime
statusSetupFinishTime :: Status -> Maybe UTCTime
statusTeardownStartTime :: Status -> Maybe UTCTime
statusAsync :: Status -> Async Result
statusStartTime :: UTCTime
statusSetupFinishTime :: Maybe UTCTime
statusTeardownStartTime :: Maybe UTCTime
statusAsync :: Async Result
..} -> Async Result -> SomeAsyncException -> IO ()
forall e a. Exception e => Async a -> e -> IO ()
cancelWith Async Result
statusAsync SomeAsyncException
e
      Status
NotStarted -> do
        UTCTime
now <- IO UTCTime
getCurrentTime
        let reason :: FailureReason
reason = Maybe CallStack
-> Maybe String -> SomeAsyncExceptionWithEq -> FailureReason
GotAsyncException Maybe CallStack
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing (SomeAsyncException -> SomeAsyncExceptionWithEq
SomeAsyncExceptionWithEq SomeAsyncException
e)
        STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Var Status
forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus (RunNodeCommonWithStatus
   (Var Status) (Var (Seq LogEntry)) (Var Bool)
 -> Var Status)
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
-> Var Status
forall a b. (a -> b) -> a -> b
$ RunNode context
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) (UTCTime
-> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Result -> Status
Done UTCTime
now Maybe UTCTime
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing UTCTime
now (FailureReason -> Result
Failure FailureReason
reason))
      Status
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

shouldRunChild :: (HasBaseContext ctx) => ctx -> RunNodeWithStatus context s l t -> Bool
shouldRunChild :: forall ctx context s l t.
HasBaseContext ctx =>
ctx -> RunNodeWithStatus context s l t -> Bool
shouldRunChild ctx
ctx RunNodeWithStatus context s l t
node = ctx -> RunNodeCommonWithStatus s l t -> Bool
forall ctx s l t.
HasBaseContext ctx =>
ctx -> RunNodeCommonWithStatus s l t -> Bool
shouldRunChild' ctx
ctx (RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNodeWithStatus context s l t
node)

shouldRunChild' :: (HasBaseContext ctx) => ctx -> RunNodeCommonWithStatus s l t -> Bool
shouldRunChild' :: forall ctx s l t.
HasBaseContext ctx =>
ctx -> RunNodeCommonWithStatus s l t -> Bool
shouldRunChild' ctx
ctx RunNodeCommonWithStatus s l t
common = case BaseContext -> Maybe (Set Int)
baseContextOnlyRunIds (BaseContext -> Maybe (Set Int)) -> BaseContext -> Maybe (Set Int)
forall a b. (a -> b) -> a -> b
$ ctx -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext ctx
ctx of
  Maybe (Set Int)
Nothing -> Bool
True
  Just Set Int
ids -> (RunNodeCommonWithStatus s l t -> Int
forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeId RunNodeCommonWithStatus s l t
common) Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Int
ids

-- * Running examples

runExampleM :: HasBaseContext r => ExampleM r () -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result
runExampleM :: forall r.
HasBaseContext r =>
ExampleM r ()
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM ExampleM r ()
ex r
ctx Var (Seq LogEntry)
logs Maybe String
exceptionMessage = ExampleM r ()
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason ())
forall r a.
HasBaseContext r =>
ExampleM r a
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason a)
runExampleM' ExampleM r ()
ex r
ctx Var (Seq LogEntry)
logs Maybe String
exceptionMessage IO (Either FailureReason ())
-> (Either FailureReason () -> IO Result) -> IO Result
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left FailureReason
err -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ FailureReason -> Result
Failure FailureReason
err
  Right () -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success

runExampleM' :: HasBaseContext r => ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a)
runExampleM' :: forall r a.
HasBaseContext r =>
ExampleM r a
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason a)
runExampleM' ExampleM r a
ex r
ctx Var (Seq LogEntry)
logs Maybe String
exceptionMessage = do
  Maybe String
maybeTestDirectory <- r -> IO (Maybe String)
forall a. HasBaseContext a => a -> IO (Maybe String)
getTestDirectory r
ctx
  let options :: Options
options = BaseContext -> Options
baseContextOptions (BaseContext -> Options) -> BaseContext -> Options
forall a b. (a -> b) -> a -> b
$ r -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext r
ctx

  -- We want our handleAny call to be *inside* the withLogFn call, because
  -- withFile will catch IOException and fill in its own information, making the
  -- resulting error confusing
  Maybe String
-> Options
-> (LogFn -> IO (Either FailureReason a))
-> IO (Either FailureReason a)
forall a. Maybe String -> Options -> (LogFn -> IO a) -> IO a
withLogFn Maybe String
maybeTestDirectory Options
options ((LogFn -> IO (Either FailureReason a))
 -> IO (Either FailureReason a))
-> (LogFn -> IO (Either FailureReason a))
-> IO (Either FailureReason a)
forall a b. (a -> b) -> a -> b
$ \LogFn
logFn ->
    (SomeException -> IO (Either FailureReason a))
-> IO (Either FailureReason a) -> IO (Either FailureReason a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
(SomeException -> m a) -> m a -> m a
handleAny (Maybe String -> SomeException -> IO (Either FailureReason a)
forall a.
Maybe String -> SomeException -> IO (Either FailureReason a)
wrapInFailureReasonIfNecessary Maybe String
exceptionMessage)
      (a -> Either FailureReason a
forall a b. b -> Either a b
Right (a -> Either FailureReason a)
-> IO a -> IO (Either FailureReason a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LoggingT IO a -> LogFn -> IO a
forall (m :: * -> *) a. LoggingT m a -> LogFn -> m a
runLoggingT (ReaderT r (LoggingT IO) a -> r -> LoggingT IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExampleM r a -> ReaderT r (LoggingT IO) a
forall context (m :: * -> *) a.
ExampleT context m a -> ReaderT context (LoggingT m) a
unExampleT ExampleM r a
ex) r
ctx) LogFn
logFn))

  where
    withLogFn :: Maybe FilePath -> Options -> (LogFn -> IO a) -> IO a
    withLogFn :: forall a. Maybe String -> Options -> (LogFn -> IO a) -> IO a
withLogFn Maybe String
Nothing (Options {Bool
[SomeFormatter]
Maybe String
Maybe LogLevel
Maybe TreeFilter
TestTimerType
TestArtifactsDirectory
LogEntryFormatter
optionsTestArtifactsDirectory :: TestArtifactsDirectory
optionsSavedLogLevel :: Maybe LogLevel
optionsMemoryLogLevel :: Maybe LogLevel
optionsLogFormatter :: LogEntryFormatter
optionsPruneTree :: Maybe TreeFilter
optionsFilterTree :: Maybe TreeFilter
optionsDryRun :: Bool
optionsFormatters :: [SomeFormatter]
optionsProjectRoot :: Maybe String
optionsTestTimerType :: TestTimerType
optionsTestArtifactsDirectory :: Options -> TestArtifactsDirectory
optionsSavedLogLevel :: Options -> Maybe LogLevel
optionsMemoryLogLevel :: Options -> Maybe LogLevel
optionsLogFormatter :: Options -> LogEntryFormatter
optionsPruneTree :: Options -> Maybe TreeFilter
optionsFilterTree :: Options -> Maybe TreeFilter
optionsDryRun :: Options -> Bool
optionsFormatters :: Options -> [SomeFormatter]
optionsProjectRoot :: Options -> Maybe String
optionsTestTimerType :: Options -> TestTimerType
..}) LogFn -> IO a
action = LogFn -> IO a
action (Maybe LogLevel -> Var (Seq LogEntry) -> LogFn
logToMemory Maybe LogLevel
optionsSavedLogLevel Var (Seq LogEntry)
logs)
    withLogFn (Just String
logPath) (Options {Bool
[SomeFormatter]
Maybe String
Maybe LogLevel
Maybe TreeFilter
TestTimerType
TestArtifactsDirectory
LogEntryFormatter
optionsTestArtifactsDirectory :: Options -> TestArtifactsDirectory
optionsSavedLogLevel :: Options -> Maybe LogLevel
optionsMemoryLogLevel :: Options -> Maybe LogLevel
optionsLogFormatter :: Options -> LogEntryFormatter
optionsPruneTree :: Options -> Maybe TreeFilter
optionsFilterTree :: Options -> Maybe TreeFilter
optionsDryRun :: Options -> Bool
optionsFormatters :: Options -> [SomeFormatter]
optionsProjectRoot :: Options -> Maybe String
optionsTestTimerType :: Options -> TestTimerType
optionsTestArtifactsDirectory :: TestArtifactsDirectory
optionsSavedLogLevel :: Maybe LogLevel
optionsMemoryLogLevel :: Maybe LogLevel
optionsLogFormatter :: LogEntryFormatter
optionsPruneTree :: Maybe TreeFilter
optionsFilterTree :: Maybe TreeFilter
optionsDryRun :: Bool
optionsFormatters :: [SomeFormatter]
optionsProjectRoot :: Maybe String
optionsTestTimerType :: TestTimerType
..}) LogFn -> IO a
action = String -> IOMode -> (Handle -> IO a) -> IO a
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (String
logPath String -> String -> String
</> String
"test_logs.txt") IOMode
AppendMode ((Handle -> IO a) -> IO a) -> (Handle -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
      LogFn -> IO a
action (Maybe LogLevel
-> Maybe LogLevel
-> LogEntryFormatter
-> Var (Seq LogEntry)
-> Handle
-> LogFn
logToMemoryAndFile Maybe LogLevel
optionsMemoryLogLevel Maybe LogLevel
optionsSavedLogLevel LogEntryFormatter
optionsLogFormatter Var (Seq LogEntry)
logs Handle
h)

    getTestDirectory :: (HasBaseContext a) => a -> IO (Maybe FilePath)
    getTestDirectory :: forall a. HasBaseContext a => a -> IO (Maybe String)
getTestDirectory (a -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext -> (BaseContext {Maybe String
Maybe (Set Int)
Text
TestTimer
Options
baseContextPath :: BaseContext -> Maybe String
baseContextTestTimerProfile :: BaseContext -> Text
baseContextRunRoot :: BaseContext -> Maybe String
baseContextErrorSymlinksDir :: BaseContext -> Maybe String
baseContextOptions :: BaseContext -> Options
baseContextOnlyRunIds :: BaseContext -> Maybe (Set Int)
baseContextTestTimer :: BaseContext -> TestTimer
baseContextPath :: Maybe String
baseContextRunRoot :: Maybe String
baseContextErrorSymlinksDir :: Maybe String
baseContextOptions :: Options
baseContextOnlyRunIds :: Maybe (Set Int)
baseContextTestTimerProfile :: Text
baseContextTestTimer :: TestTimer
..})) = case Maybe String
baseContextPath of
      Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
      Just String
dir -> do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
        Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
dir

    wrapInFailureReasonIfNecessary :: Maybe String -> SomeException -> IO (Either FailureReason a)
    wrapInFailureReasonIfNecessary :: forall a.
Maybe String -> SomeException -> IO (Either FailureReason a)
wrapInFailureReasonIfNecessary Maybe String
msg SomeException
e = Either FailureReason a -> IO (Either FailureReason a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either FailureReason a -> IO (Either FailureReason a))
-> Either FailureReason a -> IO (Either FailureReason a)
forall a b. (a -> b) -> a -> b
$ FailureReason -> Either FailureReason a
forall a b. a -> Either a b
Left (FailureReason -> Either FailureReason a)
-> FailureReason -> Either FailureReason a
forall a b. (a -> b) -> a -> b
$ case SomeException -> Maybe FailureReason
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (FailureReason
x :: FailureReason) -> FailureReason
x
      Maybe FailureReason
_ -> case SomeException -> Maybe SomeExceptionWithCallStack
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just (SomeExceptionWithCallStack e
e' CallStack
cs) -> Maybe CallStack
-> Maybe String -> SomeExceptionWithEq -> FailureReason
GotException (CallStack -> Maybe CallStack
forall a. a -> Maybe a
Just CallStack
cs) Maybe String
msg (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq (e -> SomeException
forall e. Exception e => e -> SomeException
SomeException e
e'))
        Maybe SomeExceptionWithCallStack
_ -> Maybe CallStack
-> Maybe String -> SomeExceptionWithEq -> FailureReason
GotException Maybe CallStack
forall a. Maybe a
Nothing Maybe String
msg (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq SomeException
e)

addSetupFinishTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()
addSetupFinishTimeToStatus :: forall (m :: * -> *). MonadIO m => Var Status -> UTCTime -> m ()
addSetupFinishTimeToStatus Var Status
statusVar UTCTime
setupFinishTime = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ Var Status -> (Status -> Status) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Var Status
statusVar ((Status -> Status) -> STM ()) -> (Status -> Status) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
  status :: Status
status@(Running {}) -> Status
status { statusSetupFinishTime = Just setupFinishTime }
  status :: Status
status@(Done {}) -> Status
status { statusSetupFinishTime = Just setupFinishTime }
  Status
x -> Status
x

addTeardownStartTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()
addTeardownStartTimeToStatus :: forall (m :: * -> *). MonadIO m => Var Status -> UTCTime -> m ()
addTeardownStartTimeToStatus Var Status
statusVar UTCTime
t = STM () -> m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> m ()) -> STM () -> m ()
forall a b. (a -> b) -> a -> b
$ Var Status -> (Status -> Status) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Var Status
statusVar ((Status -> Status) -> STM ()) -> (Status -> Status) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
  status :: Status
status@(Running {}) -> Status
status { statusTeardownStartTime = Just t }
  status :: Status
status@(Done {}) -> Status
status { statusTeardownStartTime = Just t }
  Status
x -> Status
x

recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m ()
recordExceptionInStatus :: forall (m :: * -> *).
MonadIO m =>
Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
status SomeException
e = do
  UTCTime
endTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let ret :: Result
ret = case SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just (SomeAsyncException
e' :: SomeAsyncException) -> FailureReason -> Result
Failure (Maybe CallStack
-> Maybe String -> SomeAsyncExceptionWithEq -> FailureReason
GotAsyncException Maybe CallStack
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing (SomeAsyncException -> SomeAsyncExceptionWithEq
SomeAsyncExceptionWithEq SomeAsyncException
e'))
        Maybe SomeAsyncException
_ -> case SomeException -> Maybe FailureReason
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
          Just (FailureReason
e' :: FailureReason) -> FailureReason -> Result
Failure FailureReason
e'
          Maybe FailureReason
_ -> FailureReason -> Result
Failure (Maybe CallStack
-> Maybe String -> SomeExceptionWithEq -> FailureReason
GotException Maybe CallStack
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq SomeException
e))
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Var Status -> (Status -> Status) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Var Status
status ((Status -> Status) -> STM ()) -> (Status -> Status) -> STM ()
forall a b. (a -> b) -> a -> b
$ \case
    Running {Maybe UTCTime
UTCTime
Async Result
statusStartTime :: Status -> UTCTime
statusSetupFinishTime :: Status -> Maybe UTCTime
statusTeardownStartTime :: Status -> Maybe UTCTime
statusAsync :: Status -> Async Result
statusStartTime :: UTCTime
statusSetupFinishTime :: Maybe UTCTime
statusTeardownStartTime :: Maybe UTCTime
statusAsync :: Async Result
..} -> UTCTime
-> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Result -> Status
Done UTCTime
statusStartTime Maybe UTCTime
statusSetupFinishTime Maybe UTCTime
statusTeardownStartTime UTCTime
endTime Result
ret
    Status
_ -> UTCTime
-> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Result -> Status
Done UTCTime
endTime Maybe UTCTime
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing UTCTime
endTime Result
ret

timed :: (MonadIO m) => m a -> m (a, UTCTime, UTCTime)
timed :: forall (m :: * -> *) a. MonadIO m => m a -> m (a, UTCTime, UTCTime)
timed m a
action = do
  UTCTime
startTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  a
ret <- m a
action
  UTCTime
endTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  (a, UTCTime, UTCTime) -> m (a, UTCTime, UTCTime)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
ret, UTCTime
startTime, UTCTime
endTime)