codedownio · thomasjm · Jul 5, 2025 · Jun 23, 2025 · Jun 24, 2025 · Jun 24, 2025
diff --git a/sandwich/sandwich.cabal b/sandwich/sandwich.cabal
@@ -280,6 +280,7 @@ executable sandwich-test
       Before
       Describe
       Introduce
+      IntroduceWith
       TestUtil
       Paths_sandwich
   hs-source-dirs:
@@ -346,6 +347,7 @@ test-suite sandwich-test-suite
       Before
       Describe
       Introduce
+      IntroduceWith
       TestUtil
       Paths_sandwich
   hs-source-dirs:

diff --git a/sandwich/src/Test/Sandwich.hs b/sandwich/src/Test/Sandwich.hs
@@ -120,8 +120,8 @@ import System.Win32.Console (setConsoleOutputCP)
 -- | 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 @@ runSandwichWithCommandLineArgs' baseOptions userOptionsParser spec = do
                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 @@ runSandwich' maybeCommandLineOptions options spec' = do
     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

diff --git a/sandwich/src/Test/Sandwich/Formatters/Common/Count.hs b/sandwich/src/Test/Sandwich/Formatters/Common/Count.hs
@@ -32,6 +32,11 @@ isFailedItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatu
 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

diff --git a/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/sandwich/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs
@@ -133,12 +133,14 @@ borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [
       <> (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)
 

diff --git a/sandwich/src/Test/Sandwich/Internal/Running.hs b/sandwich/src/Test/Sandwich/Internal/Running.hs
@@ -58,17 +58,17 @@ runSandwichTree options spec = do
   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)

diff --git a/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs b/sandwich/src/Test/Sandwich/Interpreters/StartTree.hs
@@ -125,10 +125,22 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do
   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 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do
               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 @@ startTree node@(RunNodeAround {..}) ctx' = do
           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 @@ startTree node@(RunNodeAround {..}) ctx' = do
           (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

diff --git a/sandwich/test/Around.hs b/sandwich/test/Around.hs
@@ -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 @@ aroundReceivesSubtreeResult = do
   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 ()

diff --git a/sandwich/test/Before.hs b/sandwich/test/Before.hs
@@ -2,20 +2,21 @@
 
 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 ()
 tests = do
   run beforeExceptionSafety
   run beforeExceptionSafetyNested
 
+main :: IO ()
 main = mainWith tests
 
 -- * Tests

diff --git a/sandwich/test/Describe.hs b/sandwich/test/Describe.hs
@@ -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

diff --git a/sandwich/test/Introduce.hs b/sandwich/test/Introduce.hs
@@ -6,13 +6,13 @@ module Introduce where
 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 @@ tests = do
   run introduceFailsOnCleanUpException
   run introduceCleansUpOnCancelDuringTest
 
+main :: IO ()
 main = mainWith tests
 
 -- * Tests
@@ -63,7 +64,9 @@ introduceCleansUpOnCancelDuringTest = do
       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

diff --git a/sandwich/test/IntroduceWith.hs b/sandwich/test/IntroduceWith.hs
@@ -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
diff --git a/sandwich/test/Main.hs b/sandwich/test/Main.hs
@@ -6,11 +6,14 @@ import qualified Around
 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