Fix bug where 'ExitFailure 1' showed up in console logs

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 -}

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

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 =

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 =

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 =

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 =

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 =

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

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 =