module Test.Sandwich.Interpreters.StartTree (
  startTree
  , runNodesSequentially
  , markAllChildrenWithResult
  ) 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 :: forall s l t.
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 :: 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)
runNodeBefore :: forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeChildren :: forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall s l t context.
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 = forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' forall a b. (a -> b) -> a -> b
$ forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx forall a b. (a -> b) -> a -> b
$ do
    (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 (forall a. a -> Maybe a
Just [i|Exception in before '#{runTreeLabel}' handler|])) 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
        forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
runNodeChildren context
ctx (FailureReason -> Result
Failure FailureReason
fr)
        forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
      result :: Result
result@(Failure FailureReason
fr) -> do
        forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
runNodeChildren context
ctx (FailureReason -> Result
Failure forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> SomeExceptionWithEq -> FailureReason
GetContextException forall a. Maybe a
Nothing (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
toException FailureReason
fr))
        forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
      Result
Success -> do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx
        forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success
      Result
Cancelled -> do
        forall (m :: * -> *) a. Monad m => a -> m a
return Result
Cancelled
      Result
DryRun -> do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx
        forall (m :: * -> *) a. Monad m => a -> m a
return Result
DryRun
startTree node :: RunNode context
node@(RunNodeAfter {[RunNode context]
ExampleT context IO ()
RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeAfter :: forall s l t context.
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 s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall s l t context.
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 = forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' forall a b. (a -> b) -> a -> b
$ forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx forall a b. (a -> b) -> a -> b
$ do
    IORef Result
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Result
Success
    forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx)
            ((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 (forall a. a -> Maybe a
Just [i|Exception in after '#{runTreeLabel}' handler|])) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. IORef a -> a -> IO ()
writeIORef IORef Result
result)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 s l t context.
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 = forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' forall a b. (a -> b) -> a -> b
$ forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx forall a b. (a -> b) -> a -> b
$ do
    IORef Result
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Result
Success
    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 forall a b. (a -> b) -> a -> b
$ Maybe CallStack
-> Maybe String -> SomeAsyncExceptionWithEq -> FailureReason
GotAsyncException forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncException -> SomeAsyncExceptionWithEq
SomeAsyncExceptionWithEq SomeAsyncException
e)
                forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\(SomeAsyncException
e :: SomeAsyncException) -> 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)) forall a b. (a -> b) -> a -> b
$
                  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 (forall a. a -> Maybe a
Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]))
            (\case
                Left FailureReason
failureReason -> forall a. IORef a -> a -> IO ()
writeIORef IORef Result
result (FailureReason -> Result
Failure FailureReason
failureReason)
                Right intro
intro ->
                  (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 (forall a. a -> Maybe a
Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. IORef a -> a -> IO ()
writeIORef IORef Result
result
            )
            (\case
                Left failureReason :: FailureReason
failureReason@(Pending {}) -> do
                  -- TODO: add note about failure in allocation
                  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
                  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 forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> SomeExceptionWithEq -> FailureReason
GetContextException forall a. Maybe a
Nothing (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq forall a b. (a -> b) -> a -> b
$ 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 forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast intro
intro of
                        Just (TestTimerProfile Text
t) -> 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

                  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented ((forall (l :: Symbol) a. a -> LabelValue l a
LabelValue intro
intro) forall a b. a -> b -> a :> b
:> context
ctxFinal)
            )
    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 s l t context.
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 = forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' forall a b. (a -> b) -> a -> b
$ forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  IORef (Either () [Result])
didRunWrappedAction <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (forall a b. a -> Either a b
Left ())
  forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx forall a b. (a -> b) -> a -> b
$ do
    let wrappedAction :: ExampleT context IO Result
wrappedAction = do
          let failureResult :: SomeException -> Result
failureResult SomeException
e = case 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 forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason forall a. Maybe a
Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|]
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\SomeException
e -> forall (m :: * -> *).
MonadIO m =>
Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
runTreeStatus SomeException
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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)) forall a b. (a -> b) -> a -> b
$ do
            (intro -> ExampleT context IO [Result]) -> ExampleT context IO ()
runNodeIntroduceAction forall a b. (a -> b) -> a -> b
$ \intro
intro -> do
              [Result]
results <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNodeWithStatus
   (LabelValue lab intro :> context)
   (Var Status)
   (Var (Seq LogEntry))
   (Var Bool)]
runNodeChildrenAugmented ((forall (l :: Symbol) a. a -> LabelValue l a
LabelValue intro
intro) forall a b. a -> b -> a :> b
:> context
ctx)
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Either () [Result])
didRunWrappedAction (forall a b. b -> Either a b
Right [Result]
results)
              forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
results

          (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (Either () [Result])
didRunWrappedAction) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left () -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FailureReason -> Result
Failure forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason forall a. Maybe a
Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|]
            Right [Result]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
Success
    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 (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 s l t context.
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 s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeCommon :: forall s l t context.
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 = forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx' forall a b. (a -> b) -> a -> b
$ forall s l t.
RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext
baseContextFromCommon RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
runNodeCommon
  IORef (Either () [Result])
didRunWrappedAction <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (forall a b. a -> Either a b
Left ())
  forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
RunNode context -> context -> IO Result -> m (Async Result)
runInAsync RunNode context
node context
ctx forall a b. (a -> b) -> a -> b
$ do
    let wrappedAction :: ExampleT context IO Result
wrappedAction = do
          let failureResult :: SomeException -> Result
failureResult SomeException
e = case 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 forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> String -> FailureReason
Reason forall a. Maybe a
Nothing [i|around '#{runTreeLabel}' handler threw exception|]
          forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\SomeException
e -> forall (m :: * -> *).
MonadIO m =>
Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
runTreeStatus SomeException
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode context]
runNodeChildren context
ctx (SomeException -> Result
failureResult SomeException
e)) forall a b. (a -> b) -> a -> b
$ do
            ExampleT context IO [Result] -> ExampleT context IO ()
runNodeActionWith forall a b. (a -> b) -> a -> b
$ do
              [Result]
results <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode context]
runNodeChildren context
ctx
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (Either () [Result])
didRunWrappedAction (forall a b. b -> Either a b
Right [Result]
results)
              forall (m :: * -> *) a. Monad m => a -> m a
return [Result]
results

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

-- * Util

runInAsync :: (HasBaseContext context, MonadIO m) => RunNode context -> context -> IO Result -> m (Async Result)
runInAsync :: forall context (m :: * -> *).
(HasBaseContext context, MonadIO m) =>
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
..} = 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
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
..}) = forall a. HasBaseContext a => a -> BaseContext
getBaseContext context
ctx
  let timerFn :: IO a -> IO a
timerFn = case Bool
runTreeRecordTime of
        Bool
True -> forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
TestTimer -> Text -> Text -> m a -> m a
timeAction' (forall context. HasTestTimer context => context -> TestTimer
getTestTimer BaseContext
bc) Text
baseContextTestTimerProfile (String -> Text
T.pack String
runTreeLabel)
        Bool
_ -> forall a. a -> a
id
  UTCTime
startTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  MVar ()
mvar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a. IO (MVar a)
newEmptyMVar
  Async Result
myAsync <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. ((forall b. IO b -> IO b) -> IO a) -> IO (Async a)
asyncWithUnmask forall a b. (a -> b) -> a -> b
$ \forall b. IO b -> IO b
unmask -> do
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (forall (m :: * -> *).
MonadIO m =>
Var Status -> SomeException -> m ()
recordExceptionInStatus Var Status
runTreeStatus) forall a b. (a -> b) -> a -> b
$ forall b. IO b -> IO b
unmask forall a b. (a -> b) -> a -> b
$ do
      forall a. MVar a -> IO a
readMVar MVar ()
mvar
      Result
result <- forall b. IO b -> IO b
timerFn IO Result
action
      UTCTime
endTime <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar Var Status
runTreeStatus forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> Result -> Status
Done UTCTime
startTime UTCTime
endTime Result
result

      forall (m :: * -> *).
Monad m =>
Result -> (FailureReason -> m ()) -> m ()
whenFailure Result
result forall a b. (a -> b) -> a -> b
$ \FailureReason
reason -> do
        -- Make sure the folder exists, if configured
        forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextPath 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 {} -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- These are just noisy so don't create them
          RunNodeParallel {} -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- These are just noisy so don't create them
          RunNode context
_ -> do
            forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextErrorSymlinksDir forall a b. (a -> b) -> a -> b
$ \String
errorsDir ->
              forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextPath forall a b. (a -> b) -> a -> b
$ \String
dir -> do
                forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe String
baseContextRunRoot 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 = forall (t :: * -> *) a. Foldable t => t a -> Int
L.length forall a b. (a -> b) -> a -> b
$ String -> [String]
splitPath forall a b. (a -> b) -> a -> b
$ String -> String -> String
makeRelative String
runRoot String
errorsDir
                  let relativePath :: String
relativePath = [String] -> String
joinPath (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
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly String
symlinkPath

                  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
createDirectoryLink String
relativePath String
symlinkPath

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

      forall (m :: * -> *) a. Monad m => a -> m a
return Result
result
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar Var Status
runTreeStatus forall a b. (a -> b) -> a -> b
$ UTCTime -> Async Result -> Status
Running UTCTime
startTime Async Result
myAsync
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
  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 =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\(SomeAsyncException
e :: SomeAsyncException) -> forall context. [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith [RunNode context]
children SomeAsyncException
e) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. (a -> Bool) -> [a] -> [a]
L.filter (forall ctx context s l t.
HasBaseContext ctx =>
ctx -> RunNodeWithStatus context s l t -> Bool
shouldRunChild context
ctx) [RunNode context]
children) forall a b. (a -> b) -> a -> b
$ \RunNode context
child ->
      forall (m :: * -> *) context.
(MonadIO m, HasBaseContext context) =>
RunNode context -> context -> m (Async Result)
startTree RunNode context
child context
ctx forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 =
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (\(SomeAsyncException
e :: SomeAsyncException) -> forall context. [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith [RunNode context]
children SomeAsyncException
e) forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Async a -> IO a
wait forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *) context.
(MonadIO m, HasBaseContext context) =>
RunNode context -> context -> m (Async Result)
startTree RunNode context
child context
ctx
                           | RunNode context
child <- forall a. (a -> Bool) -> [a] -> [a]
L.filter (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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. (a -> Bool) -> [a] -> [a]
L.filter (forall ctx s l t.
HasBaseContext ctx =>
ctx -> RunNodeCommonWithStatus s l t -> Bool
shouldRunChild' context'
baseContext) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall context s l t.
RunNodeWithStatus context s l t -> [RunNodeCommonWithStatus s l t]
getCommons [RunNode context]
children) forall a b. (a -> b) -> a -> b
$ \RunNodeCommonWithStatus
  (Var Status) (Var (Seq LogEntry)) (Var Bool)
child ->
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar (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 :: forall context. [RunNode context] -> SomeAsyncException -> IO ()
cancelAllChildrenWith [RunNode context]
children SomeAsyncException
e = do
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RunNode context]
children forall a b. (a -> b) -> a -> b
$ \RunNode context
node ->
    forall a. TVar a -> IO a
readTVarIO (forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus forall a b. (a -> b) -> a -> b
$ forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) 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
..} -> 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing (SomeAsyncException -> SomeAsyncExceptionWithEq
SomeAsyncExceptionWithEq SomeAsyncException
e)
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar (forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus forall a b. (a -> b) -> a -> b
$ forall s l t context.
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
_ -> 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 = forall ctx s l t.
HasBaseContext ctx =>
ctx -> RunNodeCommonWithStatus s l t -> Bool
shouldRunChild' ctx
ctx (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 forall a b. (a -> b) -> a -> b
$ forall a. HasBaseContext a => a -> BaseContext
getBaseContext ctx
ctx of
  Maybe (Set Int)
Nothing -> Bool
True
  Just Set Int
ids -> (forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeId RunNodeCommonWithStatus s l t
common) 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 = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left FailureReason
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FailureReason -> Result
Failure FailureReason
err
  Right () -> 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'' :: forall r.
HasBaseContext r =>
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 = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Left FailureReason
err -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FailureReason -> Result
Failure FailureReason
err
  Right Result
x -> 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' :: 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 <- forall a. HasBaseContext a => a -> IO (Maybe String)
getTestDirectory r
ctx
  let options :: Options
options = BaseContext -> Options
baseContextOptions forall a b. (a -> b) -> a -> b
$ forall a. HasBaseContext a => a -> BaseContext
getBaseContext r
ctx

  forall (m :: * -> *) a.
MonadCatch m =>
(SomeException -> m a) -> m a -> m a
handleAny (forall a.
Maybe String -> SomeException -> IO (Either FailureReason a)
wrapInFailureReasonIfNecessary Maybe String
exceptionMessage) forall a b. (a -> b) -> a -> b
$
    forall a. Maybe String -> Options -> (LogFn -> IO a) -> IO a
withLogFn Maybe String
maybeTestDirectory Options
options forall a b. (a -> b) -> a -> b
$ \LogFn
logFn ->
      (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (m :: * -> *) a. LoggingT m a -> LogFn -> m a
runLoggingT (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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
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 = forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile (String
logPath String -> String -> String
</> String
"test_logs.txt") IOMode
AppendMode 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 (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      Just String
dir -> do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
      Just (FailureReason
x :: FailureReason) -> FailureReason
x
      Maybe FailureReason
_ -> case forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just (SomeExceptionWithCallStack e
e CallStack
cs) -> Maybe CallStack
-> Maybe String -> SomeExceptionWithEq -> FailureReason
GotException (forall a. a -> Maybe a
Just CallStack
cs) Maybe String
msg (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq (forall e. Exception e => e -> SomeException
SomeException e
e))
        Maybe SomeExceptionWithCallStack
_ -> Maybe CallStack
-> Maybe String -> SomeExceptionWithEq -> FailureReason
GotException forall a. Maybe a
Nothing Maybe String
msg (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq SomeException
e)

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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
  let ret :: Result
ret = case 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing (SomeAsyncException -> SomeAsyncExceptionWithEq
SomeAsyncExceptionWithEq SomeAsyncException
e'))
        Maybe SomeAsyncException
_ -> case 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 forall a. Maybe a
Nothing forall a. Maybe a
Nothing (SomeException -> SomeExceptionWithEq
SomeExceptionWithEq SomeException
e))
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Var Status
status 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