{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}

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


import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Concurrent.STM
import Control.Exception.Safe
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


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

startTree :: (MonadIO m, HasBaseContext context) => RunNode context -> context -> m (Async Result)
startTree :: 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)
runNodeBefore :: forall context s l t.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeChildren :: forall context s l t.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeBefore :: ExampleT context IO ()
runNodeChildren :: [RunNode context]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = 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 -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    (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 -> (Result -> IO Result) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      result :: Result
result@(Failure fr :: FailureReason
fr@(Pending {Maybe String
Maybe CallStack
failurePendingMessage :: FailureReason -> Maybe String
failureCallStack :: FailureReason -> Maybe CallStack
failurePendingMessage :: Maybe String
failureCallStack :: Maybe CallStack
..})) -> 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 -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
      result :: Result
result@(Failure FailureReason
fr) -> 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 -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
      Result
Success -> 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 -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success
startTree node :: RunNode context
node@(RunNodeAfter {[RunNode context]
ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeAfter :: forall context s l t.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeAfter :: ExampleT context IO ()
runNodeChildren :: [RunNode context]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: forall context s l t.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = 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 -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    IORef Result
result <- IO (IORef Result) -> IO (IORef Result)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Result) -> IO (IORef Result))
-> IO (IORef Result) -> IO (IORef Result)
forall a b. (a -> b) -> a -> b
$ Result -> IO (IORef Result)
forall a. a -> IO (IORef a)
newIORef Result
Success
    IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask 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)
            ((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|])) IO Result -> (Result -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
result)
    IO Result -> IO Result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$ IORef Result -> IO Result
forall a. IORef a -> IO a
readIORef IORef Result
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 ()
runNodeCleanup :: ()
runNodeAlloc :: ()
runNodeChildrenAugmented :: ()
runNodeCleanup :: intro -> ExampleT context IO ()
runNodeAlloc :: ExampleT context IO intro
runNodeChildrenAugmented :: [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = 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 -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    IORef Result
result <- IO (IORef Result) -> IO (IORef Result)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Result) -> IO (IORef Result))
-> IO (IORef Result) -> IO (IORef Result)
forall a b. (a -> b) -> a -> b
$ Result -> IO (IORef Result)
forall a. a -> IO (IORef a)
newIORef Result
Success
    IO (Either FailureReason intro)
-> (Either FailureReason intro -> IO ())
-> (Either FailureReason intro -> IO ())
-> IO ()
forall (m :: * -> *) a b c.
MonadMask 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)
 -> (SomeAsyncException -> IO ())
 -> IO (Either FailureReason intro))
-> (SomeAsyncException -> IO ())
-> IO (Either FailureReason intro)
-> IO (Either FailureReason intro)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Either FailureReason intro)
-> (SomeAsyncException -> IO ()) -> IO (Either FailureReason intro)
forall (m :: * -> *) e a b.
(MonadMask 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)
 -> IO (Either FailureReason intro))
-> IO (Either FailureReason intro)
-> IO (Either FailureReason intro)
forall a b. (a -> b) -> a -> b
$
                  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|]))
            (\case
                Left FailureReason
failureReason -> IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
result (FailureReason -> Result
Failure FailureReason
failureReason)
                Right intro
intro ->
                  (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|])) IO Result -> (Result -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IORef Result -> Result -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Result
result
            )
            (\case
                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 :: Text
baseContextTestTimerProfile = Text
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 -> IO Result
forall a. IORef a -> IO a
readIORef IORef Result
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 ()
runNodeIntroduceAction :: ()
runNodeIntroduceAction :: (intro -> ExampleT context IO [Result]) -> ExampleT context IO ()
runNodeChildrenAugmented :: [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildrenAugmented :: ()
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = 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])
didRunWrappedAction <- IO (IORef (Either () [Result])) -> m (IORef (Either () [Result]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Either () [Result])) -> m (IORef (Either () [Result])))
-> IO (IORef (Either () [Result]))
-> m (IORef (Either () [Result]))
forall a b. (a -> b) -> a -> b
$ Either () [Result] -> IO (IORef (Either () [Result]))
forall a. a -> IO (IORef a)
newIORef (() -> Either () [Result]
forall a b. a -> Either a b
Left ())
  RunNode context -> context -> IO Result -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    let wrappedAction :: ExampleT context IO Result
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.
(MonadMask 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 (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
            (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
              [Result]
results <- IO [Result] -> ExampleT context IO [Result]
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)
              IO () -> ExampleT context IO ()
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]) -> Either () [Result] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either () [Result])
didRunWrappedAction ([Result] -> Either () [Result]
forall a b. b -> Either a b
Right [Result]
results)
              [Result] -> ExampleT context IO [Result]
forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
results

          (IO (Either () [Result]) -> ExampleT context IO (Either () [Result])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () [Result])
 -> ExampleT context IO (Either () [Result]))
-> IO (Either () [Result])
-> ExampleT context IO (Either () [Result])
forall a b. (a -> b) -> a -> b
$ IORef (Either () [Result]) -> IO (Either () [Result])
forall a. IORef a -> IO a
readIORef IORef (Either () [Result])
didRunWrappedAction) ExampleT context IO (Either () [Result])
-> (Either () [Result] -> ExampleT context IO Result)
-> ExampleT context IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left () -> Result -> ExampleT context IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> ExampleT context IO Result)
-> Result -> ExampleT context IO Result
forall a b. (a -> b) -> a -> b
$ 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|]
            Right [Result]
_ -> Result -> ExampleT context IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success
    ExampleT context IO Result
-> context -> Var (Seq LogEntry) -> Maybe String -> IO Result
forall r.
HasBaseContext r =>
ExampleM r Result
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM'' ExampleT context IO Result
wrappedAction context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Exception in introduceWith '#{runTreeLabel}' handler|])
startTree node :: RunNode context
node@(RunNodeAround {[RunNode context]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
ExampleT context IO [Result] -> ExampleT context IO ()
runNodeActionWith :: forall context s l t.
RunNodeWithStatus context s l t
-> ExampleT context IO [Result] -> ExampleT context IO ()
runNodeActionWith :: ExampleT context IO [Result] -> ExampleT context IO ()
runNodeChildren :: [RunNode context]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: forall context s l t.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..}) context
ctx' = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = 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])
didRunWrappedAction <- IO (IORef (Either () [Result])) -> m (IORef (Either () [Result]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Either () [Result])) -> m (IORef (Either () [Result])))
-> IO (IORef (Either () [Result]))
-> m (IORef (Either () [Result]))
forall a b. (a -> b) -> a -> b
$ Either () [Result] -> IO (IORef (Either () [Result]))
forall a. a -> IO (IORef a)
newIORef (() -> Either () [Result]
forall a b. a -> Either a b
Left ())
  RunNode context -> context -> IO Result -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    let wrappedAction :: ExampleT context IO Result
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.
(MonadMask 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 (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
              [Result]
results <- IO [Result] -> ExampleT context IO [Result]
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 (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]) -> Either () [Result] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Either () [Result])
didRunWrappedAction ([Result] -> Either () [Result]
forall a b. b -> Either a b
Right [Result]
results)
              [Result] -> ExampleT context IO [Result]
forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
results

          (IO (Either () [Result]) -> ExampleT context IO (Either () [Result])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either () [Result])
 -> ExampleT context IO (Either () [Result]))
-> IO (Either () [Result])
-> ExampleT context IO (Either () [Result])
forall a b. (a -> b) -> a -> b
$ IORef (Either () [Result]) -> IO (Either () [Result])
forall a. IORef a -> IO a
readIORef IORef (Either () [Result])
didRunWrappedAction) ExampleT context IO (Either () [Result])
-> (Either () [Result] -> ExampleT context IO Result)
-> ExampleT context IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left () -> Result -> ExampleT context IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return (Result -> ExampleT context IO Result)
-> Result -> ExampleT context IO Result
forall a b. (a -> b) -> a -> b
$ 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|]
            Right [Result]
_ -> Result -> ExampleT context IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success
    ExampleT context IO Result
-> context -> Var (Seq LogEntry) -> Maybe String -> IO Result
forall r.
HasBaseContext r =>
ExampleM r Result
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM'' ExampleT context IO Result
wrappedAction context
ctx Var (Seq LogEntry)
runTreeLogs (String -> Maybe String
forall a. a -> Maybe a
Just [i|Exception in introduceWith '#{runTreeLabel}' handler|])
startTree node :: RunNode context
node@(RunNodeDescribe {[RunNode context]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: [RunNode context]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: forall context s l t.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..}) 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 -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    (([Result] -> 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) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Int
0 -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success
      Int
n -> Result -> IO Result
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 (Maybe CallStack -> Int -> FailureReason
ChildrenFailed Maybe CallStack
forall a. Maybe a
Nothing Int
n)
startTree node :: RunNode context
node@(RunNodeParallel {[RunNode context]
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: [RunNode context]
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeChildren :: forall context s l t.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..}) 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 -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    (([Result] -> 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) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Int
0 -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success
      Int
n -> Result -> IO Result
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 (Maybe CallStack -> Int -> FailureReason
ChildrenFailed Maybe CallStack
forall a. Maybe a
Nothing Int
n)
startTree node :: RunNode context
node@(RunNodeIt {ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeExample :: forall context s l t.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeExample :: ExampleT context IO ()
runNodeCommon :: RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon :: forall context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
..}) 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 -> m (Async Result)
forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx (IO Result -> m (Async Result)) -> IO Result -> m (Async Result)
forall a b. (a -> b) -> a -> b
$ do
    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 -> m (Async Result)
runInAsync :: RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx IO Result
action = do
  let RunNodeCommonWithStatus {Bool
Int
String
Maybe String
Maybe SrcLoc
Var Bool
Var (Seq LogEntry)
Var Status
Seq Int
runTreeLoc :: Maybe SrcLoc
runTreeLogs :: Var (Seq LogEntry)
runTreeRecordTime :: Bool
runTreeVisibilityLevel :: Int
runTreeFolder :: Maybe String
runTreeVisible :: Bool
runTreeStatus :: Var Status
runTreeOpen :: Var Bool
runTreeToggled :: Var Bool
runTreeAncestors :: Seq Int
runTreeId :: Int
runTreeLabel :: String
runTreeLoc :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLogs :: forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeRecordTime :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisibilityLevel :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeFolder :: forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeVisible :: forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeStatus :: forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeOpen :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeAncestors :: forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeId :: forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeLabel :: forall s l t. RunNodeCommonWithStatus s l t -> String
..} = RunNode context
-> RunNodeCommonWithStatus
     (Var Status) (Var (Seq LogEntry)) (Var Bool)
forall context s l t.
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
baseContextTestTimer :: BaseContext -> TestTimer
baseContextOnlyRunIds :: BaseContext -> Maybe (Set Int)
baseContextOptions :: BaseContext -> Options
baseContextErrorSymlinksDir :: BaseContext -> Maybe String
baseContextRunRoot :: BaseContext -> Maybe String
baseContextTestTimer :: TestTimer
baseContextTestTimerProfile :: Text
baseContextOnlyRunIds :: Maybe (Set Int)
baseContextOptions :: Options
baseContextErrorSymlinksDir :: Maybe String
baseContextRunRoot :: Maybe String
baseContextPath :: Maybe String
baseContextTestTimerProfile :: BaseContext -> Text
baseContextPath :: BaseContext -> Maybe String
..}) = 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.
(MonadMask m, MonadIO 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  MVar ()
mvar <- IO (MVar ()) -> m (MVar ())
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 (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 b. IO b -> IO b) -> IO Result) -> IO (Async Result)
forall a. ((forall b. IO b -> IO b) -> IO a) -> IO (Async a)
asyncWithUnmask (((forall b. IO b -> IO b) -> IO Result) -> IO (Async Result))
-> ((forall b. IO b -> IO b) -> IO Result) -> IO (Async Result)
forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
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.
(MonadMask 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 b. IO b -> IO b
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 <- IO Result -> IO Result
forall b. IO b -> IO b
timerFn IO Result
action
      UTCTime
endTime <- IO UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO 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 -> UTCTime -> Result -> Status
Done UTCTime
startTime 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 (m :: * -> *) a. Monad m => a -> m a
return () -- These are just noisy so don't create them
          RunNodeParallel {} -> () -> IO ()
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
                  -- 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 (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
                  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)

                  let symlinkBaseName :: String
symlinkBaseName = case Maybe SrcLoc
runTreeLoc of
                        Maybe SrcLoc
Nothing -> String -> String
takeFileName String
dir
                        Just SrcLoc
loc -> [i|#{srcLocFile loc}:#{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

                  IO () -> IO ()
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

        -- 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 :: Bool
printFormatterUseColor = Bool
False
                  , printFormatterLogLevel :: Maybe LogLevel
printFormatterLogLevel = LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just LogLevel
LevelDebug
                  , printFormatterIncludeCallStacks :: Bool
printFormatterIncludeCallStacks = Bool
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 (m :: * -> *) a. Monad m => a -> m a
return Result
result
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO 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 -> Async Result -> Status
Running UTCTime
startTime Async Result
myAsync
  IO () -> m ()
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 (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 :: [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.
(MonadMask 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 (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 :: [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.
(MonadMask 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)
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)
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 :: [RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
children context'
baseContext Result
status = do
  UTCTime
now <- IO UTCTime -> m UTCTime
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO 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)
child) (UTCTime -> UTCTime -> Result -> Status
Done UTCTime
now UTCTime
now Result
status)

cancelAllChildrenWith :: [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith :: [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 a. TVar a -> IO 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 context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) IO Status -> (Status -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Running {UTCTime
Async Result
statusAsync :: Status -> Async Result
statusStartTime :: Status -> UTCTime
statusAsync :: Async Result
statusStartTime :: UTCTime
..} -> 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 a. STM a -> IO 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 context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) (UTCTime -> UTCTime -> Result -> Status
Done UTCTime
now UTCTime
now (FailureReason -> Result
Failure FailureReason
reason))
      Status
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

shouldRunChild :: (HasBaseContext ctx) => ctx -> RunNodeWithStatus context s l t -> Bool
shouldRunChild :: 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 context s l t.
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' :: 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 :: 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left FailureReason
err -> Result -> IO Result
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 (m :: * -> *) a. Monad m => a -> m a
return Result
Success

runExampleM'' :: HasBaseContext r => ExampleM r Result -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result
runExampleM'' :: ExampleM r Result
-> r -> Var (Seq LogEntry) -> Maybe String -> IO Result
runExampleM'' ExampleM r Result
ex r
ctx Var (Seq LogEntry)
logs Maybe String
exceptionMessage = ExampleM r Result
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason Result)
forall r a.
HasBaseContext r =>
ExampleM r a
-> r
-> Var (Seq LogEntry)
-> Maybe String
-> IO (Either FailureReason a)
runExampleM' ExampleM r Result
ex r
ctx Var (Seq LogEntry)
logs Maybe String
exceptionMessage IO (Either FailureReason Result)
-> (Either FailureReason Result -> IO Result) -> IO Result
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left FailureReason
err -> Result -> IO Result
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
x -> Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
x

runExampleM' :: HasBaseContext r => ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a)
runExampleM' :: 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

  (SomeException -> IO (Either FailureReason a))
-> IO (Either FailureReason a) -> IO (Either FailureReason a)
forall (m :: * -> *) a.
MonadCatch 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) (IO (Either FailureReason a) -> IO (Either FailureReason a))
-> IO (Either FailureReason a) -> IO (Either FailureReason a)
forall a b. (a -> b) -> a -> b
$
    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 ->
      (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 :: Maybe String -> Options -> (LogFn -> IO a) -> IO a
withLogFn Maybe String
Nothing (Options {Bool
[SomeFormatter]
Maybe String
Maybe LogLevel
Maybe TreeFilter
TestTimerType
TestArtifactsDirectory
LogEntryFormatter
optionsTestTimerType :: Options -> TestTimerType
optionsProjectRoot :: Options -> Maybe String
optionsFormatters :: Options -> [SomeFormatter]
optionsDryRun :: Options -> Bool
optionsFilterTree :: Options -> Maybe TreeFilter
optionsLogFormatter :: Options -> LogEntryFormatter
optionsMemoryLogLevel :: Options -> Maybe LogLevel
optionsSavedLogLevel :: Options -> Maybe LogLevel
optionsTestArtifactsDirectory :: Options -> TestArtifactsDirectory
optionsTestTimerType :: TestTimerType
optionsProjectRoot :: Maybe String
optionsFormatters :: [SomeFormatter]
optionsDryRun :: Bool
optionsFilterTree :: Maybe TreeFilter
optionsLogFormatter :: LogEntryFormatter
optionsMemoryLogLevel :: Maybe LogLevel
optionsSavedLogLevel :: Maybe LogLevel
optionsTestArtifactsDirectory :: TestArtifactsDirectory
..}) 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
optionsTestTimerType :: TestTimerType
optionsProjectRoot :: Maybe String
optionsFormatters :: [SomeFormatter]
optionsDryRun :: Bool
optionsFilterTree :: Maybe TreeFilter
optionsLogFormatter :: LogEntryFormatter
optionsMemoryLogLevel :: Maybe LogLevel
optionsSavedLogLevel :: Maybe LogLevel
optionsTestArtifactsDirectory :: TestArtifactsDirectory
optionsTestTimerType :: Options -> TestTimerType
optionsProjectRoot :: Options -> Maybe String
optionsFormatters :: Options -> [SomeFormatter]
optionsDryRun :: Options -> Bool
optionsFilterTree :: Options -> Maybe TreeFilter
optionsLogFormatter :: Options -> LogEntryFormatter
optionsMemoryLogLevel :: Options -> Maybe LogLevel
optionsSavedLogLevel :: Options -> Maybe LogLevel
optionsTestArtifactsDirectory :: Options -> TestArtifactsDirectory
..}) 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 :: a -> IO (Maybe String)
getTestDirectory (a -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext -> (BaseContext {Maybe String
Maybe (Set Int)
Text
TestTimer
Options
baseContextTestTimer :: TestTimer
baseContextTestTimerProfile :: Text
baseContextOnlyRunIds :: Maybe (Set Int)
baseContextOptions :: Options
baseContextErrorSymlinksDir :: Maybe String
baseContextRunRoot :: Maybe String
baseContextPath :: Maybe String
baseContextTestTimer :: BaseContext -> TestTimer
baseContextOnlyRunIds :: BaseContext -> Maybe (Set Int)
baseContextOptions :: BaseContext -> Options
baseContextErrorSymlinksDir :: BaseContext -> Maybe String
baseContextRunRoot :: BaseContext -> Maybe String
baseContextTestTimerProfile :: BaseContext -> Text
baseContextPath :: BaseContext -> Maybe String
..})) = case Maybe String
baseContextPath of
      Maybe String
Nothing -> Maybe String -> IO (Maybe String)
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 (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 :: Maybe String -> SomeException -> IO (Either FailureReason a)
wrapInFailureReasonIfNecessary Maybe String
msg SomeException
e = Either FailureReason a -> IO (Either FailureReason 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)

recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m ()
recordExceptionInStatus :: Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
status SomeException
e = do
  UTCTime
endTime <- IO UTCTime -> m UTCTime
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO 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 {UTCTime
statusStartTime :: UTCTime
statusStartTime :: Status -> UTCTime
statusStartTime} -> UTCTime -> UTCTime -> Result -> Status
Done UTCTime
statusStartTime UTCTime
endTime Result
ret
    Status
_ -> UTCTime -> UTCTime -> Result -> Status
Done UTCTime
endTime UTCTime
endTime Result
ret