packages feed

sandwich 0.3.0.4 → 0.3.0.5

raw patch · 19 files changed

+172/−53 lines, 19 files

Files

CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog for sandwich +## 0.3.0.5++* Preserve configured test artifacts directory (#109)+* Better handling for introduce node failures (#110)+* Make the type of `xit` closer to the type of `it` (#111).+ ## 0.3.0.4  * Improve display of setup/work/teardown in TUI.
sandwich.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           sandwich-version:        0.3.0.4+version:        0.3.0.5 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -280,6 +280,7 @@       Before       Describe       Introduce+      IntroduceWith       TestUtil       Paths_sandwich   hs-source-dirs:@@ -346,6 +347,7 @@       Before       Describe       Introduce+      IntroduceWith       TestUtil       Paths_sandwich   hs-source-dirs:
src/Test/Sandwich.hs view
@@ -120,8 +120,8 @@ -- | Run the spec with the given 'Options'. runSandwich :: Options -> CoreSpec -> IO () runSandwich options spec = do-  (_exitReason, failures) <- runSandwich' Nothing options spec-  when (0 < failures) $ exitFailure+  (_exitReason, _itNodeFailures, totalFailures) <- runSandwich' Nothing options spec+  when (0 < totalFailures) $ exitFailure  -- | Run the spec, configuring the options from the command line. runSandwichWithCommandLineArgs :: Options -> TopSpecWithOptions -> IO ()@@ -181,11 +181,13 @@                baseArgs <- getArgs                withArgs (baseArgs L.\\ (fmap T.unpack individualTestFlagStrings)) $                  tryAny x >>= \case-                   Left _ -> return (NormalExit, 1)-                   Right _ -> return (NormalExit, 0)+                   Left _ -> return (NormalExit, 1, 1)+                   Right _ -> return (NormalExit, 0, 0) --- | Run the spec with optional custom 'CommandLineOptions'. When finished, return the exit reason and number of failures.-runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int)+-- | Run the spec with optional custom 'CommandLineOptions'. When finished, return the exit reason,+-- the number of "it" nodes which failed, and the total failed nodes (which includes "it" nodes, and+-- may also include other nodes like "introduce" nodes).+runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int, Int) runSandwich' maybeCommandLineOptions options spec' = do   baseContext <- baseContextFromOptions options @@ -249,9 +251,11 @@     loggingFn $ finalizeFormatter f rts baseContext    fixedTree <- atomically $ mapM fixRunTree rts-  let failed = countWhere isFailedItBlock fixedTree+   exitReason <- readIORef exitReasonRef-  return (exitReason, failed)+  let failedItBlocks = countWhere isFailedItBlock fixedTree+  let failedBlocks = countWhere isFailedBlock fixedTree+  return (exitReason, failedItBlocks, failedBlocks)   -- | Count the it nodes
src/Test/Sandwich/ArgParsing.hs view
@@ -137,13 +137,13 @@   <*> flag False True (long "individual-videos" <> help "Record individual videos of each test (requires ffmpeg and Xvfb)" <> maybeInternal)   <*> flag False True (long "error-videos" <> help "Record videos of each test but delete them unless there was an exception" <> maybeInternal) -  <*> optional (strOption (long "selenium-jar" <> help "" <> metavar "STRING" <> maybeInternal))+  <*> optional (strOption (long "selenium-jar" <> help "Path to selenium.jar file to use" <> metavar "STRING" <> maybeInternal)) -  <*> optional (strOption (long "chrome-binary" <> help "" <> metavar "STRING" <> maybeInternal))-  <*> optional (strOption (long "chromedriver-binary" <> help "" <> metavar "STRING" <> maybeInternal))+  <*> optional (strOption (long "chrome-binary" <> help "Path to chrome binary" <> metavar "STRING" <> maybeInternal))+  <*> optional (strOption (long "chromedriver-binary" <> help "Path to chromedriver binary" <> metavar "STRING" <> maybeInternal)) -  <*> optional (strOption (long "firefox-binary" <> help "" <> metavar "STRING" <> maybeInternal))-  <*> optional (strOption (long "geckodriver-binary" <> help "" <> metavar "STRING" <> maybeInternal))+  <*> optional (strOption (long "firefox-binary" <> help "Path to firefox binary" <> metavar "STRING" <> maybeInternal))+  <*> optional (strOption (long "geckodriver-binary" <> help "Path to geckodriver binary" <> metavar "STRING" <> maybeInternal))  browserToUse :: (forall f a. Mod f a) -> Parser BrowserToUse browserToUse maybeInternal =@@ -266,7 +266,9 @@    let options = baseOptions {     optionsTestArtifactsDirectory = case optFixedRoot of-      Nothing -> TestArtifactsGeneratedDirectory "test_runs" (formatTime <$> getCurrentTime)+      Nothing -> case optionsTestArtifactsDirectory baseOptions of+        TestArtifactsNone -> TestArtifactsGeneratedDirectory "test_runs" (formatTime <$> getCurrentTime)+        existing -> existing       Just path -> TestArtifactsFixedDirectory path     , optionsPruneTree = case optTreePrune of         [] -> Nothing
src/Test/Sandwich/Expectations.hs view
@@ -29,7 +29,7 @@ pendingWith msg = throwIO $ Pending (Just callStack) (Just msg)  -- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.-xit :: (HasCallStack, MonadIO m) => String -> ExampleT context m1 () -> SpecFree context m ()+xit :: (HasCallStack, MonadIO m) => String -> ExampleT context m () -> SpecFree context m () xit name _ex = it name (throwIO $ Pending (Just callStack) Nothing)  -- * Expecting failures
src/Test/Sandwich/Formatters/Common/Count.hs view
@@ -32,6 +32,11 @@ isFailedItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure {})})})}) = True isFailedItBlock _ = False +isFailedNonItBlock (RunNodeIt {}) = False+isFailedNonItBlock (runNodeCommon -> (RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure (Pending {}))})})) = False+isFailedNonItBlock (runNodeCommon -> (RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure {})})})) = True+isFailedNonItBlock _ = False+ isFailedBlock (runNodeCommon -> (RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure (Pending {}))})})) = False isFailedBlock (runNodeCommon -> (RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure {})})})) = True isFailedBlock _ = False
src/Test/Sandwich/Formatters/TerminalUI.hs view
@@ -31,7 +31,6 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import UnliftIO.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger hiding (logError)@@ -67,6 +66,7 @@ import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Test.Sandwich.Util+import UnliftIO.Exception   instance Formatter TerminalUIFormatter where@@ -250,6 +250,13 @@     V.EvKey (V.KChar 'n') [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp 1     V.EvKey (V.KChar 'v') [V.MMeta] -> withScroll s $ \vp -> vScrollPage vp Up     V.EvKey (V.KChar 'v') [V.MCtrl] -> withScroll s $ \vp -> vScrollPage vp Down++#ifdef darwin_HOST_OS+    -- This seems okay on macOS, and is a good fallback since Meta+v doesn't seem to work+    V.EvKey (V.KPageUp) [V.MCtrl] -> withScroll s $ \vp -> vScrollPage vp Up+    V.EvKey (V.KPageDown) [V.MCtrl] -> withScroll s $ \vp -> vScrollPage vp Down+#endif+     V.EvKey V.KHome [V.MCtrl] -> withScroll s $ \vp -> vScrollToBeginning vp     V.EvKey V.KEnd [V.MCtrl] -> withScroll s $ \vp -> vScrollToEnd vp
src/Test/Sandwich/Formatters/TerminalUI/Draw.hs view
@@ -133,12 +133,14 @@       <> (if totalFailedTests > 0 then [[withAttr failureAttr $ str $ show totalFailedTests, str " failed"]] else mempty)       <> (if totalPendingTests > 0 then [[withAttr pendingAttr $ str $ show totalPendingTests, str " pending"]] else mempty)       <> (if totalRunningTests > 0 then [[withAttr runningAttr $ str $ show totalRunningTests, str " running"]] else mempty)+      <> (if totalFailedInteriorNodes > 0 then [[withAttr failureAttr $ str $ show totalFailedInteriorNodes, str (" failed non-test " <> (if totalFailedInteriorNodes == 1 then "node" else "nodes"))]] else mempty)       <> (if totalNotStartedTests > 0 then [[str $ show totalNotStartedTests, str " not started"]] else mempty)      totalNumTests = countWhere isItBlock (app ^. appRunTree)     totalSucceededTests = countWhere isSuccessItBlock (app ^. appRunTree)     totalPendingTests = countWhere isPendingItBlock (app ^. appRunTree)     totalFailedTests = countWhere isFailedItBlock (app ^. appRunTree)+    totalFailedInteriorNodes = countWhere isFailedNonItBlock (app ^. appRunTree)     totalRunningTests = countWhere isRunningItBlock (app ^. appRunTree)     totalNotStartedTests = countWhere isNotStartedItBlock (app ^. appRunTree)
src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} @@ -25,7 +26,7 @@   where     settingsColumn = keybindingBox [keyIndicator (L.intersperse '/' [unKChar nextKey, unKChar previousKey, '↑', '↓']) "Navigate"                                    , keyIndicatorHasSelected app (showKeys toggleKeys) "Open/close node"-                                   , keyIndicatorHasSelectedOpen app "Control-v/Meta-v" "Scroll node"+                                   , keyIndicatorHasSelectedOpen app scrollNodeLabel "Scroll node"                                    , keyIndicatorHasSelected app (unKChar closeNodeKey : '/' : [unKChar openNodeKey]) "Fold/unfold node"                                    , keyIndicator "Meta + [0-9]" "Unfold top # nodes"                                    , keyIndicator (unKChar nextFailureKey : '/' : [unKChar previousFailureKey]) "Next/previous failure"@@ -114,6 +115,13 @@                                               , str "Log level"]                                         , keyIndicator "q" "Exit"]++scrollNodeLabel :: String+#ifdef darwin_HOST_OS+scrollNodeLabel = "Control-PgUp/PgDown"+#else+scrollNodeLabel = "Control-v/Meta-v"+#endif  visibilityThresholdWidget app = hBox $   [withAttr hotkeyMessageAttr $ str "Visibility threshold ("]
src/Test/Sandwich/Internal/Running.hs view
@@ -58,17 +58,17 @@   return rts  -- | For 0 repeats, repeat until a failure-runWithRepeat :: Int -> Int -> IO (ExitReason, Int) -> IO ()+runWithRepeat :: Int -> Int -> IO (ExitReason, Int, Int) -> IO () runWithRepeat 0 totalTests action = do-  (_, numFailures) <- action-  if | numFailures == 0 -> runWithRepeat 0 totalTests action+  (_, _itNodeFailures, totalFailures) <- action+  if | totalFailures == 0 -> runWithRepeat 0 totalTests action      | otherwise -> exitFailure -- | For 1 repeat, run once and return runWithRepeat n totalTests action = do   (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n' -> do-    (exitReason, numFailures) <- liftIO action+    (exitReason, _itNodeFailures, totalFailures) <- liftIO action -    modify $ \(successes, total) -> (successes + (if numFailures == 0 then 1 else 0), total + 1)+    modify $ \(successes, total) -> (successes + (if totalFailures == 0 then 1 else 0), total + 1)      if | exitReason == SignalExit -> return ()        | n' > 0 -> loop (n' - 1)
src/Test/Sandwich/Interpreters/StartTree.hs view
@@ -125,10 +125,22 @@   didRunWrappedAction <- liftIO $ newIORef (Left (), emptyExtraTimingInfo)   runInAsync node ctx $ do     let wrappedAction = do-          let failureResult e = case fromException e of-                Just fr@(Pending {}) -> Failure fr-                _ -> Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|]-          flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildrenAugmented ctx (failureResult e)) $ do+          didAllocateVar <- liftIO $ newIORef False+          let handler e = do+                recordExceptionInStatus runTreeStatus e++                liftIO (readIORef didAllocateVar) >>= \case+                  False -> do+                    -- We didn't successfully allocate, so mark the children below this point as failed due to a+                    -- context issue.+                    markAllChildrenWithResult runNodeChildrenAugmented ctx $ case fromException e of+                      Just fr@(Pending {}) -> Failure fr+                      _ -> Failure $ GetContextException Nothing (SomeExceptionWithEq e)+                  True ->+                    -- Otherwise, let their existing statuses stand.+                    return ()++          flip withException handler $ do             beginningCleanupVar <- liftIO $ newIORef Nothing              -- Record a start event in the test timing, if configured@@ -146,6 +158,8 @@               setupFinishTime <- liftIO getCurrentTime               addSetupFinishTimeToStatus runTreeStatus setupFinishTime +              liftIO $ writeIORef didAllocateVar True+               (results, _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (body)") $                 liftIO $ runNodesSequentially runNodeChildrenAugmented (LabelValue intro :> ctx) @@ -181,7 +195,7 @@           let failureResult e = case fromException e of                 Just fr@(Pending {}) -> Failure fr                 _ -> Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler threw exception|]-          flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildren ctx (failureResult e)) $ do+          flip withException (\e -> recordExceptionInStatus runTreeStatus e) $ do             runNodeActionWith $ do               setupFinishTime <- liftIO getCurrentTime               addSetupFinishTimeToStatus runTreeStatus setupFinishTime@@ -192,7 +206,7 @@           (liftIO $ readIORef didRunWrappedAction) >>= \case             (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler didn't call action|], timingInfo)             (Right _, timingInfo) -> return (Success, timingInfo)-    runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) >>= \case+    runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in around '#{runTreeLabel}' handler|]) >>= \case       Left err -> return (Failure err, emptyExtraTimingInfo)       Right x -> pure x startTree node@(RunNodeDescribe {..}) ctx' = do
src/Test/Sandwich/Util/Process.hs view
@@ -48,9 +48,14 @@ gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m () gracefullyWaitForProcess p gracePeriodUs = void $ gracefullyWaitForProcess' p gracePeriodUs --- | Wait for a process to terminate. If it doesn't terminate within 'gracePeriodUs' microseconds,--- send it an interrupt signal and wait for another 'gracePeriodUs' microseconds.--- After this time elapses send a terminate signal and wait for the process to die.+-- | Wait for a process to terminate.+--+-- If it doesn't terminate within 'gracePeriodUs' microseconds, send it an+-- interrupt signal and wait for another 'gracePeriodUs' microseconds.+--+-- If it doesn't die by this time, send a terminate signal and wait again.+--+-- If it still isn't dead, send a kill signal. gracefullyWaitForProcess' :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m StopProcessResult gracefullyWaitForProcess' p gracePeriodUs = do   let waitForExit = do
test/Around.hs view
@@ -2,33 +2,32 @@  module Around where - import Control.Concurrent-import UnliftIO.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Writer import Data.String.Interpolate import GHC.Stack import Test.Sandwich- import TestUtil+import UnliftIO.Exception + tests :: MonadIO m => WriterT [SomeException] m () tests = do-  run aroundDoesNotFailureOnChildFailure+  run aroundDoesNotFailOnChildFailure   run aroundReceivesSubtreeResult +main :: IO () main = mainWith tests  -- * Tests --aroundDoesNotFailureOnChildFailure :: (HasCallStack) => IO ()-aroundDoesNotFailureOnChildFailure = do+aroundDoesNotFailOnChildFailure :: (HasCallStack) => IO ()+aroundDoesNotFailOnChildFailure = do   results <- runAndGetResults $ around "around label" void $ do-    it "does thing 1" $ 2 `shouldBe` 3-    it "does thing 1" $ 2 `shouldBe` 2+    it "does thing 1" $ 2 `shouldBe` (3 :: Int)+    it "does thing 1" $ 2 `shouldBe` (2 :: Int)    case results of     [Success, Failure {}, Success] -> return ()@@ -39,8 +38,8 @@   mvar <- newEmptyMVar    _ <- runAndGetResults $ around "around label" (>>= (liftIO . putMVar mvar)) $ do-    it "does thing 1" $ 2 `shouldBe` 3-    it "does thing 1" $ 2 `shouldBe` 2+    it "does thing 1" $ 2 `shouldBe` (3 :: Int)+    it "does thing 1" $ 2 `shouldBe` (2 :: Int)    takeMVar mvar >>= \case     [Failure {}, Success] -> return ()
test/Before.hs view
@@ -2,13 +2,13 @@  module Before where -import UnliftIO.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Writer import qualified Data.List as L import GHC.Stack import Test.Sandwich import TestUtil+import UnliftIO.Exception   tests :: MonadIO m => WriterT [SomeException] m ()@@ -16,6 +16,7 @@   run beforeExceptionSafety   run beforeExceptionSafetyNested +main :: IO () main = mainWith tests  -- * Tests
test/Describe.hs view
@@ -2,19 +2,20 @@  module Describe where -import UnliftIO.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Writer import Data.String.Interpolate import GHC.Stack import Test.Sandwich import TestUtil+import UnliftIO.Exception   tests :: MonadIO m => WriterT [SomeException] m () tests = do   run describeFailsWhenChildFails +main :: IO () main = mainWith tests  -- * Tests
test/Introduce.hs view
@@ -6,13 +6,13 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import UnliftIO.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Writer import Data.Foldable import GHC.Stack import Test.Sandwich import Test.Sandwich.Internal+import UnliftIO.Exception  import TestUtil @@ -23,6 +23,7 @@   run introduceFailsOnCleanUpException   run introduceCleansUpOnCancelDuringTest +main :: IO () main = mainWith tests  -- * Tests@@ -63,7 +64,9 @@       liftIO $ putMVar mvar ()       liftIO $ threadDelay 999999999999999 -  let [topNode@(RunNodeIntroduce {runNodeChildrenAugmented=[RunNodeIt {}]})] = rts+  topNode <- case rts of+    [x@(RunNodeIntroduce {runNodeChildrenAugmented=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"    -- Wait until we get into the actual test example, then cancel the top level async   takeMVar mvar
+ test/IntroduceWith.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE DataKinds #-}++module IntroduceWith where+++import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import GHC.Stack+import Test.Sandwich+import UnliftIO.Exception++import TestUtil++tests :: MonadIO m => WriterT [SomeException] m ()+tests = do+  run introduceWithFailsOnAllocateException+  run introduceWithFailsOnCleanUpException++main :: IO ()+main = mainWith tests++-- * Tests++introduceWithFailsOnAllocateException :: (HasCallStack) => IO ()+introduceWithFailsOnAllocateException = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduceWith "introduce with" fakeDatabaseLabel withAction $ do+    it "does thing 1" $ return ()++  msgs `mustBe` [[], []]+  results `mustBe` [Failure (GotException Nothing (Just "Exception in introduceWith 'introduce with' handler") someUserErrorWrapped)+                   , Failure (GetContextException Nothing someUserErrorWrapped)]+  where+    withAction action = do+      throwSomeUserError+      _ <- action FakeDatabase+      return ()++introduceWithFailsOnCleanUpException :: (HasCallStack) => IO ()+introduceWithFailsOnCleanUpException = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduceWith "introduce with" fakeDatabaseLabel withAction $ do+    it "does thing 1" $ return ()++  msgs `mustBe` [[], []]+  results `mustBe` [Failure (GotException Nothing (Just "Exception in introduceWith 'introduce with' handler") someUserErrorWrapped)+                   , Success]+  where+    withAction action = do+      _ <- action FakeDatabase+      throwSomeUserError
test/Main.hs view
@@ -6,11 +6,14 @@ import qualified Before import qualified Describe import qualified Introduce+import qualified IntroduceWith import TestUtil  +main :: IO () main = mainWith $ do   Around.tests   Before.tests   Describe.tests   Introduce.tests+  IntroduceWith.tests
test/TestUtil.hs view
@@ -33,14 +33,18 @@ -- * Values  data FakeDatabase = FakeDatabase deriving Show-fakeDatabaseLabel = Label :: Label "fakeDatabase" FakeDatabase+fakeDatabaseLabel :: Label "fakeDatabase" FakeDatabase+fakeDatabaseLabel = Label +someUserError :: IOError someUserError = userError "Oh no"++someUserErrorWrapped :: SomeExceptionWithEq someUserErrorWrapped = SomeExceptionWithEq $ SomeException $ userError "Oh no"  -- * Helpers -run :: MonadIO m => IO () -> WriterT [SomeException] m ()+run :: (HasCallStack, MonadIO m) => IO () -> WriterT [SomeException] m () run test = (liftIO $ tryAny test) >>= \case   Left err -> tell [err]   Right () -> return ()@@ -54,18 +58,21 @@   fixedTree <- atomically $ mapM fixRunTree finalTree   return $ fmap statusToResult $ concatMap getStatuses fixedTree -runAndGetResultsAndLogs :: CoreSpec -> IO ([Result], [[LogStr]])+runAndGetResultsAndLogs :: (HasCallStack) => CoreSpec -> IO ([Result], [[LogStr]]) runAndGetResultsAndLogs spec = do   finalTree <- runSandwichTree defaultOptions spec   getResultsAndMessages <$> fixTree finalTree +fixTree :: [RunNode context] -> IO [RunNodeFixed context] fixTree rts = atomically $ mapM fixRunTree rts +getResultsAndMessages :: (HasCallStack) => [RunNodeFixed context] -> ([Result], [[LogStr]]) getResultsAndMessages fixedTree = (results, msgs)   where     results = fmap statusToResult $ concatMap getStatuses fixedTree     msgs = getMessages fixedTree +getMessages :: (HasCallStack) => [RunNodeFixed context] -> [[LogStr]] getMessages fixedTree = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree  getStatuses :: RunNodeWithStatus context s l t -> [(String, s)]@@ -75,15 +82,16 @@ getLogs = extractValues $ \node -> runTreeLogs $ runNodeCommon node  statusToResult :: (HasCallStack) => (String, Status) -> Result-statusToResult (label, NotStarted) = error [i|Expected status to be Done but was NotStarted for label '#{label}'|]-statusToResult (label, Running {}) = error [i|Expected status to be Done but was Running for label '#{label}'|]+statusToResult (label, NotStarted) = error [i|Expected status to be Done but was NotStarted for label '#{label}' (#{callStack})|]+statusToResult (label, Running {}) = error [i|Expected status to be Done but was Running for label '#{label}' (#{callStack})|] statusToResult (_, Done _ _ _ _ result) = result  mustBe :: (HasCallStack, Eq a, Show a) => a -> a -> IO () mustBe x y   | x == y = return ()-  | otherwise = error [i|Expected #{show y} but got #{show x}|]+  | otherwise = error [i|Expected #{show y} but got #{show x} (#{callStack})|] +waitUntilRunning :: TVar Status -> IO () waitUntilRunning status = atomically $ do   readTVar status >>= \case     Running {} -> return ()