feat: show repl stderr on exceptions in test

Author: ulidtko

tests/integration/lib/StackTest/Repl.hs

@@ -10,16 +10,19 @@ module StackTest.Repl
     , replGetLine
     ) where
 
+import Control.Exception (SomeException, catch, displayException, finally)
 import Control.Monad (unless, when)
 import Control.Monad.IO.Class (liftIO)
 import Data.Maybe (fromMaybe)
 import GHC.Stack (HasCallStack)
+import System.Directory (removeFile)
 import System.Environment (lookupEnv)
-import System.Exit (ExitCode (..))
+import System.Exit (ExitCode (..), exitFailure)
 import System.IO
-    ( BufferMode (NoBuffering, LineBuffering), Handle
-    , hClose, hGetChar, hGetLine, hPutStrLn, hSetBuffering
+    ( BufferMode (NoBuffering, LineBuffering), Handle, IOMode (ReadMode)
+    , hClose, hGetChar, hGetContents', hGetLine, hPutStrLn, hSetBuffering
     , openTempFile
+    , withFile
     )
 
 import Control.Monad.Trans (lift)
@@ -87,6 +90,18 @@ runRepl cmd args actions = do
 
   -- run the test script which is to talk to the GHCi subprocess.
   runReaderT actions (ReplConnection rStdin rStdout)
+    -- the nested actions script may fail in arbitrary ways; handle that here,
+    -- attaching the subprocess stderr as relevant context
+    `catch` \(e :: SomeException) -> do
+      putStrLn "=============================="
+      putStrLn "EXCEPTION in test: "
+      putStrLn . quote $ displayException e
+      putStrLn "------[ stderr of repl ]------"
+      withFile stderrBufPath ReadMode $ \h -> hGetContents' h >>= putStr . quote
+      putStrLn "=============================="
+    `finally` do
+      hClose stderrBufHandle
+      removeFile stderrBufPath
 
   -- once done with the test, signal EOF on stdin for clean termination of ghci
   hClose rStdin
@@ -104,5 +119,9 @@ repl :: HasCallStack => [String] -> Repl () -> IO ()
 repl args action = do
   stackExe' <- stackExe
   ec <- runRepl stackExe' ("repl" : "--ghci-options=-ignore-dot-ghci" : args) action
-  unless (ec == ExitSuccess) $
-    error $ "GHCi exited with " <> show ec
+  unless (ec == ExitSuccess) $ do
+    putStrLn $ "repl exited with " <> show ec
+    exitFailure
+
+quote :: String -> String
+quote = unlines . map ("> " <>) . lines

tests/integration/tests/3926-ghci-with-sublibraries/Main.hs

@@ -5,37 +5,30 @@ import StackTest
 import StackTest.Repl
 
 main :: IO ()
-main
-  | isWindows =
-      putStrLn "This test was disabled on Windows on 25 June 2023 (see \
-               \https://github.com/commercialhaskell/stack/issues/6170)."
-  | otherwise = do
-      stack ["clean"] -- to make sure we can load the code even after a clean
-      copy "src/Lib.v1" "src/Lib.hs"
-      copy "src-internal/Internal.v1" "src-internal/Internal.hs"
-      stack ["build"] -- need a build before ghci at the moment, see #4148
-      replThread
-
-replThread :: IO ()
-replThread = repl [] $ do
-  -- The command must be issued before searching the output for the next prompt,
-  -- otherwise, on Windows from msys2-20230526, `stack repl` encounters a EOF
-  -- and terminates gracefully.
-  replCommand ":main"
-  liftIO $ putStrLn "Awaiting prompt..."
-  nextPrompt
-  liftIO $ putStrLn "Initial prompt received"
-  line <- replGetLine
-  let expected = "hello world"
-  when (line /= expected) $
-    error $
-         "Main module didn't load correctly.\n"
-      <> "Expected: " <> expected <> "\n"
-      <> "Actual  : " <> line <> "\n"
-  liftIO $ copy "src-internal/Internal.v2" "src-internal/Internal.hs"
-  reloadAndTest "testInt" "42" "Internal library didn't reload."
-  liftIO $ copy "src/Lib.v2" "src/Lib.hs"
-  reloadAndTest "testStr" "\"OK\"" "Main library didn't reload."
+main = do
+  stack ["clean"] -- to make sure we can load the code even after a clean
+  copy "src/Lib.v1" "src/Lib.hs"
+  copy "src-internal/Internal.v1" "src-internal/Internal.hs"
+  stack ["build"] -- need a build before ghci at the moment, see #4148
+  repl [] $ do
+    -- The command must be issued before searching the output for the next prompt,
+    -- otherwise, on Windows from msys2-20230526, `stack repl` encounters a EOF
+    -- and terminates gracefully.
+    replCommand ":main"
+    liftIO $ putStrLn "Awaiting prompt..."
+    nextPrompt
+    liftIO $ putStrLn "Initial prompt received"
+    line <- replGetLine
+    let expected = "hello world"
+    when (line /= expected) $
+      error $
+          "Main module didn't load correctly.\n"
+        <> "Expected: " <> expected <> "\n"
+        <> "Actual  : " <> line <> "\n"
+    liftIO $ copy "src-internal/Internal.v2" "src-internal/Internal.hs"
+    reloadAndTest "testInt" "42" "Internal library didn't reload."
+    liftIO $ copy "src/Lib.v2" "src/Lib.hs"
+    reloadAndTest "testStr" "\"OK\"" "Main library didn't reload."
 
 reloadAndTest :: String -> String -> String -> Repl ()
 reloadAndTest cmd exp err = do