diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -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 . 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: diff --git a/src/Test/Sandwich.hs b/src/Test/Sandwich.hs --- a/src/Test/Sandwich.hs +++ b/src/Test/Sandwich.hs @@ -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 diff --git a/src/Test/Sandwich/ArgParsing.hs b/src/Test/Sandwich/ArgParsing.hs --- a/src/Test/Sandwich/ArgParsing.hs +++ b/src/Test/Sandwich/ArgParsing.hs @@ -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 diff --git a/src/Test/Sandwich/Expectations.hs b/src/Test/Sandwich/Expectations.hs --- a/src/Test/Sandwich/Expectations.hs +++ b/src/Test/Sandwich/Expectations.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Common/Count.hs b/src/Test/Sandwich/Formatters/Common/Count.hs --- a/src/Test/Sandwich/Formatters/Common/Count.hs +++ b/src/Test/Sandwich/Formatters/Common/Count.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI.hs b/src/Test/Sandwich/Formatters/TerminalUI.hs --- a/src/Test/Sandwich/Formatters/TerminalUI.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs @@ -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 ("] diff --git a/src/Test/Sandwich/Internal/Running.hs b/src/Test/Sandwich/Internal/Running.hs --- a/src/Test/Sandwich/Internal/Running.hs +++ b/src/Test/Sandwich/Internal/Running.hs @@ -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) diff --git a/src/Test/Sandwich/Interpreters/StartTree.hs b/src/Test/Sandwich/Interpreters/StartTree.hs --- a/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/src/Test/Sandwich/Interpreters/StartTree.hs @@ -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 diff --git a/src/Test/Sandwich/Util/Process.hs b/src/Test/Sandwich/Util/Process.hs --- a/src/Test/Sandwich/Util/Process.hs +++ b/src/Test/Sandwich/Util/Process.hs @@ -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 diff --git a/test/Around.hs b/test/Around.hs --- a/test/Around.hs +++ b/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 @@ 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/test/Before.hs b/test/Before.hs --- a/test/Before.hs +++ b/test/Before.hs @@ -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 diff --git a/test/Describe.hs b/test/Describe.hs --- a/test/Describe.hs +++ b/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/test/Introduce.hs b/test/Introduce.hs --- a/test/Introduce.hs +++ b/test/Introduce.hs @@ -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 diff --git a/test/IntroduceWith.hs b/test/IntroduceWith.hs new file mode 100644 --- /dev/null +++ b/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/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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 ()