diff --git a/src/Shrun/Prelude.hs b/src/Shrun/Prelude.hs index 0e1424bc..ecc75493 100644 --- a/src/Shrun/Prelude.hs +++ b/src/Shrun/Prelude.hs @@ -404,8 +404,20 @@ setUncaughtExceptionHandlerDisplay :: IO () setUncaughtExceptionHandlerDisplay = #if MIN_VERSION_base(4, 20, 0) Ex.setUncaughtExceptionHandler (putStrLn . Ex.displayInner) + where + printExceptExitCode ex = case fromException ex of + Just (ExitSuccess _) -> pure () + -- for command failures + Just ((ExitFailure _) _) -> pure () + Nothing -> putStrLn $ displayException ex #else - Ex.setUncaughtExceptionHandler (putStrLn . Ex.displayNoCS) + Ex.setUncaughtExceptionHandler printExceptExitCode + where + printExceptExitCode ex = case fromException ex of + Just (Ex.MkExceptionCS ExitSuccess _) -> pure () + -- for command failures + Just (Ex.MkExceptionCS (ExitFailure _) _) -> pure () + Nothing -> putStrLn $ displayException ex #endif {- ORMOLU_ENABLE -} diff --git a/test/functional/Functional/Buffering.hs b/test/functional/Functional/Buffering.hs index d7ae6d7e..f4c0aa3e 100644 --- a/test/functional/Functional/Buffering.hs +++ b/test/functional/Functional/Buffering.hs @@ -4,7 +4,7 @@ module Functional.Buffering (specs) where import Data.List qualified as L import Data.Text qualified as T import Functional.Prelude -import Test.Shrun.Verifier (ExpectedText (MkExpectedText), ResultText (MkResultText)) +import Test.Shrun.Verifier (ExpectedText (MkExpectedText), ResultText) import Test.Shrun.Verifier qualified as V specs :: TestTree @@ -23,7 +23,7 @@ logsNoBuffer = assertLogsEq expectedOrdered results - V.verifyExpected (MkResultText <$> results) (MkExpectedText <$> allExpected) + V.verifyExpected results (MkExpectedText <$> allExpected) where -- NOTE: [Bash brace loop interpolation] -- @@ -74,11 +74,13 @@ logsNoBuffer = withFinishedPrefix "" ] -assertLogsEq :: List Text -> List Text -> IO () -assertLogsEq expectedOrdered results = case go expectedOrdered results of +assertLogsEq :: List Text -> List ResultText -> IO () +assertLogsEq expectedOrdered results = case go expectedOrdered results' of Nothing -> pure () Just errMsg -> assertFailure $ unpack errMsg where + results' = view #unResultText <$> results + go :: List Text -> List Text -> Maybe Text go [] [] = Nothing go (_ : _) [] = @@ -87,7 +89,7 @@ assertLogsEq expectedOrdered results = case go expectedOrdered results of [ "Num expected > results.\n\nExpected:\n", prettyList expectedOrdered, "\n\nResults:\n", - prettyList results + prettyList results' ] -- Having leftover results is fine, since the last few messages are quite -- non-deterministic, so we don't bother. @@ -102,7 +104,7 @@ assertLogsEq expectedOrdered results = case go expectedOrdered results of "\n\nAll expected:\n", prettyList expectedOrdered, "\n\nAll results:\n", - prettyList results + prettyList results' ] prettyList :: List Text -> Text diff --git a/test/functional/Functional/Examples.hs b/test/functional/Functional/Examples.hs index 2bf1c4bd..ca29bbb3 100644 --- a/test/functional/Functional/Examples.hs +++ b/test/functional/Functional/Examples.hs @@ -33,7 +33,7 @@ specs args = gif :: TestTree gif = testCase "Runs gif example" $ do - results <- fmap MkResultText <$> runExitFailure args + results <- runExitFailure args V.verifyExpected results expected where args = @@ -61,7 +61,7 @@ gif = core :: TestTree core = testCase "Runs core example" $ do - results <- fmap MkResultText <$> runExitFailure args + results <- runExitFailure args V.verifyExpected results expected where args = diff --git a/test/functional/Functional/Examples/CommandLogging.hs b/test/functional/Functional/Examples/CommandLogging.hs index 9fc590b1..db13118e 100644 --- a/test/functional/Functional/Examples/CommandLogging.hs +++ b/test/functional/Functional/Examples/CommandLogging.hs @@ -2,7 +2,6 @@ module Functional.Examples.CommandLogging (tests) where import Data.Text qualified as T import Functional.Prelude -import Test.Shrun.Verifier (ResultText (MkResultText)) import Test.Shrun.Verifier qualified as V -- NOTE: If tests in this module fail, fix then update configuration.md! @@ -18,7 +17,7 @@ tests = readSizeDefault :: TestTree readSizeDefault = testCase "Default --read-size splits 1000" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -39,7 +38,7 @@ readSizeDefault = readSize :: TestTree readSize = testCase "Runs --command-log-read-size example" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = diff --git a/test/functional/Functional/Examples/CommonLogging.hs b/test/functional/Functional/Examples/CommonLogging.hs index d90c547c..863812a7 100644 --- a/test/functional/Functional/Examples/CommonLogging.hs +++ b/test/functional/Functional/Examples/CommonLogging.hs @@ -17,7 +17,7 @@ tests = keyHideOn :: TestTree keyHideOn = testCase "Runs key hide example with --common-log-key-hide" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpectedUnexpected results expected unexpected where args = @@ -37,7 +37,7 @@ keyHideOn = keyHideOff :: TestTree keyHideOff = testCase "Runs key hide example without --common-log-key-hide" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpectedUnexpected results expected unexpected where args = diff --git a/test/functional/Functional/Examples/ConsoleLogging.hs b/test/functional/Functional/Examples/ConsoleLogging.hs index 7e50ecf7..35328015 100644 --- a/test/functional/Functional/Examples/ConsoleLogging.hs +++ b/test/functional/Functional/Examples/ConsoleLogging.hs @@ -27,7 +27,7 @@ tests = commandLogOn :: TestTree commandLogOn = testCase "Runs commandLog example with --console-log-command" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -42,7 +42,7 @@ commandLogOn = commandLogOnDefault :: TestTree commandLogOnDefault = testCase "Runs --console-log-command with no output shows default message" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -57,7 +57,7 @@ commandLogOnDefault = commandLogOff :: TestTree commandLogOff = testCase "Runs commandLog example without --console-log-command" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyUnexpected results unexpected where args = @@ -68,7 +68,7 @@ commandLogOff = commandNameTruncN :: TestTree commandNameTruncN = testCase "Runs --console-log-command-name-trunc 10 example" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -85,7 +85,7 @@ commandNameTruncN = testCase "Runs --console-log-command-name-trunc 10 example" commandLogLineTruncN :: TestTree commandLogLineTruncN = testCase "Runs --console-log-line-trunc 80 example" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -101,7 +101,7 @@ commandLogLineTruncN = testCase "Runs --console-log-line-trunc 80 example" $ do stripControlAll :: TestTree stripControlAll = testCase "Runs --console-log-strip-control all example" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -122,7 +122,7 @@ stripControlAll = testCase "Runs --console-log-strip-control all example" $ do stripControlNone :: TestTree stripControlNone = testCase "Runs --console-log-strip-control none example" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -140,7 +140,7 @@ stripControlNone = testCase "Runs --console-log-strip-control none example" $ do stripControlSmart :: TestTree stripControlSmart = testCase "Runs --console-log-strip-control smart example" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -158,7 +158,7 @@ stripControlSmart = testCase "Runs --console-log-strip-control smart example" $ timerFormatDigitalCompact :: TestTree timerFormatDigitalCompact = testCase "Runs timer format with digital_compact" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -174,7 +174,7 @@ timerFormatDigitalCompact = timerFormatDigitalFull :: TestTree timerFormatDigitalFull = testCase "Runs timer format with digital_full" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -190,7 +190,7 @@ timerFormatDigitalFull = timerFormatProseCompact :: TestTree timerFormatProseCompact = testCase "Runs timer format with prose_compact" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -206,7 +206,7 @@ timerFormatProseCompact = timerFormatProseFull :: TestTree timerFormatProseFull = testCase "Runs timer format with prose_full" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = diff --git a/test/functional/Functional/Examples/Core.hs b/test/functional/Functional/Examples/Core.hs index ef23fe4f..781533c8 100644 --- a/test/functional/Functional/Examples/Core.hs +++ b/test/functional/Functional/Examples/Core.hs @@ -2,7 +2,6 @@ module Functional.Examples.Core (tests) where import Functional.Prelude -import Test.Shrun.Verifier (ResultText (MkResultText)) import Test.Shrun.Verifier qualified as V -- NOTE: If tests in this module fail, fix then update configuration.md! @@ -19,7 +18,7 @@ tests = initOn :: TestTree initOn = testCase "Runs init successful example" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = @@ -36,7 +35,7 @@ initOn = initOff :: TestTree initOff = testCase "Runs init failure example" $ do - results <- fmap MkResultText <$> runExitFailure args + results <- runExitFailure args V.verifyExpected results expected where args = @@ -51,7 +50,7 @@ initOff = timeout :: TestTree timeout = testCase "Runs timeout example" $ do - results <- fmap MkResultText <$> runExitFailure args + results <- runExitFailure args V.verifyExpected results expected where args = diff --git a/test/functional/Functional/Examples/FileLogging.hs b/test/functional/Functional/Examples/FileLogging.hs index bf2f52ef..5bf1564b 100644 --- a/test/functional/Functional/Examples/FileLogging.hs +++ b/test/functional/Functional/Examples/FileLogging.hs @@ -38,7 +38,7 @@ fileLog testArgs = testCase "Runs file-log example" $ do "for i in 1 2 3; do echo hi; sleep 1; done" ] - resultsConsole <- fmap MkResultText <$> runExitFailure args + resultsConsole <- runExitFailure args V.verifyExpected resultsConsole expectedConsole resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile @@ -68,7 +68,7 @@ fileLogCommandNameTruncN testArgs = testCase desc $ do "for i in 1 2 3; do echo hi; sleep 1; done" ] - resultsConsole <- fmap MkResultText <$> run args + resultsConsole <- run args V.verifyExpected resultsConsole expectedConsole resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile @@ -96,7 +96,7 @@ fileLogDeleteOnSuccess testArgs = testCase desc $ do "sleep 2" ] - resultsConsole <- fmap MkResultText <$> run args + resultsConsole <- run args V.verifyExpected resultsConsole expectedConsole exists <- doesFileExist outFile @@ -122,7 +122,7 @@ fileLogDeleteOnSuccessFail testArgs = testCase desc $ do "sleep 2" ] - resultsConsole <- fmap MkResultText <$> runExitFailure args + resultsConsole <- runExitFailure args V.verifyExpected resultsConsole expectedConsole exists <- doesFileExist outFile @@ -156,7 +156,7 @@ fileLogLineTruncN testArgs = testCase "Runs --file-log-line-trunc 120 example" $ -- NOTE: We choose 120 so that we get _some_ chars rather than minimal ..., -- so the test is more precise. - _ <- fmap MkResultText <$> run args + _ <- run args resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile V.verifyExpected resultsFile expectedFile @@ -179,7 +179,7 @@ fileLogStripControlAll testArgs = testCase "Runs file-log strip-control all exam "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" ] - _ <- fmap MkResultText <$> run args + _ <- run args resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile V.verifyExpected resultsFile expectedFile @@ -201,7 +201,7 @@ fileLogStripControlNone testArgs = testCase "Runs file-log strip-control none ex "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" ] - _ <- fmap MkResultText <$> run args + _ <- run args resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile V.verifyExpected resultsFile expectedFile @@ -225,7 +225,7 @@ fileLogStripControlSmart testArgs = testCase "Runs file-log strip-control smart "printf ' foo \ESC[35m hello \ESC[3D bye '; sleep 2" ] - _ <- fmap MkResultText <$> run args + _ <- run args resultsFile <- fmap MkResultText . T.lines <$> readFileUtf8ThrowM outFile V.verifyExpected resultsFile expectedFile diff --git a/test/functional/Functional/Miscellaneous.hs b/test/functional/Functional/Miscellaneous.hs index ee5acab0..8e448e8b 100644 --- a/test/functional/Functional/Miscellaneous.hs +++ b/test/functional/Functional/Miscellaneous.hs @@ -2,7 +2,6 @@ module Functional.Miscellaneous (specs) where import Functional.Prelude -import Test.Shrun.Verifier (ResultText (MkResultText)) import Test.Shrun.Verifier qualified as V specs :: TestTree @@ -16,7 +15,7 @@ specs = splitNewlineLogs :: TestTree splitNewlineLogs = testCase "Logs with newlines are split" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpectedUnexpected results expected unexpected where args = @@ -40,7 +39,7 @@ splitNewlineLogs = testCase "Logs with newlines are split" $ do spaceStderrLogs :: TestTree spaceStderrLogs = testCase "Stderr Log with newlines is spaced" $ do - results <- fmap MkResultText <$> runExitFailure args + results <- runExitFailure args V.verifyExpectedUnexpected results expected unexpected where args = @@ -64,7 +63,7 @@ spaceStderrLogs = testCase "Stderr Log with newlines is spaced" $ do -- markdown file as easy as possible. Thus we move it here. stripControlAlwaysCmdNames :: TestTree stripControlAlwaysCmdNames = testCase "Always strips command names" $ do - results <- fmap MkResultText <$> run args + results <- run args V.verifyExpected results expected where args = diff --git a/test/functional/Functional/Prelude.hs b/test/functional/Functional/Prelude.hs index c783cce1..1608fdc2 100644 --- a/test/functional/Functional/Prelude.hs +++ b/test/functional/Functional/Prelude.hs @@ -12,6 +12,14 @@ -- -- 2. Once we only support GHC 9.8+, add it unconditionally to -- default-extensions. +-- +-- 3. It would be nice if we could test that we do not receive any "extra" +-- output e.g. "ExitFailure 1". To do this, though, we'd have to test +-- with the exception logic, since the exception stuff happens _outside_ +-- of these tests i.e. exceptions are caught and the unwanted output will +-- occur from the handler (set in Main.hs). +-- +-- 4. Consider testing --help (would require some refactoring like 3 above). #if __GLASGOW_HASKELL__ >= 908 {-# LANGUAGE TypeAbstractions #-} @@ -82,6 +90,7 @@ import Shrun.Logging.MonadRegionLogger import Shrun.Notify.MonadNotify (MonadNotify (notify), ShrunNote) import Shrun.Prelude as X import Shrun.ShellT (ShellT) +import Test.Shrun.Verifier (ResultText (MkResultText)) import Test.Tasty as X (TestTree, defaultMain, testGroup, withResource) import Test.Tasty.HUnit as X ( Assertion, @@ -196,7 +205,7 @@ instance MonadNotify (ShellT FuncEnv IO) where pure Nothing -- | Runs the args and retrieves the logs. -run :: List String -> IO (List Text) +run :: List String -> IO (List ResultText) run = fmap fst . runMaybeException ExNothing -- | Runs the args and retrieves the sent notifications. @@ -206,7 +215,7 @@ runNotes = fmap snd . runMaybeException ExNothing {- ORMOLU_DISABLE -} -- | 'runException' specialized to ExitFailure. -runExitFailure :: List String -> IO (List Text) +runExitFailure :: List String -> IO (List ResultText) runExitFailure = #if MIN_VERSION_base(4, 20, 0) fmap fst . runMaybeException (ExJust $ Proxy @ExitCode) @@ -221,7 +230,7 @@ runException :: forall e. (Exception e) => List String -> - IO (List Text) + IO (List ResultText) runException = fmap fst . runMaybeException (ExJust (Proxy @e)) -- | So we can hide the exception type and make it so run does not @@ -234,7 +243,7 @@ data MaybeException where runMaybeException :: MaybeException -> List String -> - IO (List Text, List ShrunNote) + IO (List ResultText, List ShrunNote) runMaybeException mException argList = do ls <- newIORef [] shrunNotes <- newIORef [] @@ -288,8 +297,8 @@ runMaybeException mException argList = do readRefs :: IORef (List Text) -> IORef (List ShrunNote) -> - IO (List Text, List ShrunNote) - readRefs ls ns = (,) <$> readIORef ls <*> readIORef ns + IO (List ResultText, List ShrunNote) + readRefs ls ns = ((,) . fmap MkResultText <$> readIORef ls) <*> readIORef ns printLogsReThrow :: (Exception e) => e -> IORef (List Text) -> IO void printLogsReThrow ex ls = do