Check where Cabal writes output to

Tests can now specify files with a `.stdout` or `.stderr` suffix to
assert where Cabal writes output to. `.out` will continue to work for
testing what output Cabal generates ignoring which file descriptor
that output is sent to.

This commit also simplifies the
`test{,Normalized}{Actual,Expect}File{Out,Stdout,Stderr}` family of
functions

Author: fredefox

cabal-testsuite/PackageTests/FileDescriptors/M.hs

@@ -0,0 +1 @@
+module M where

cabal-testsuite/PackageTests/FileDescriptors/Setup.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = fail "Setup called despite `build-type:Simple`"

cabal-testsuite/PackageTests/FileDescriptors/cabal.out

@@ -0,0 +1,8 @@
+# cabal build
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - my-0 (lib) (first run)
+Configuring library for my-0..
+Preprocessing library for my-0..
+Building library for my-0..

cabal-testsuite/PackageTests/FileDescriptors/cabal.project

@@ -0,0 +1 @@
+packages: .

cabal-testsuite/PackageTests/FileDescriptors/cabal.stderr

@@ -0,0 +1,7 @@
+Resolving dependencies...
+Build profile: -w ghc-<GHCVER> -O1
+In order, the following will be built:
+ - my-0 (lib) (first run)
+Configuring library for my-0..
+Preprocessing library for my-0..
+Building library for my-0..

cabal-testsuite/PackageTests/FileDescriptors/cabal.stdout

@@ -0,0 +1,4 @@
+import Test.Cabal.Prelude
+
+main :: IO ()
+main = cabalTest $ cabal "build" ["all"]

cabal-testsuite/PackageTests/FileDescriptors/cabal.test.hs

@@ -0,0 +1,9 @@
+cabal-version:       3.0
+name:                my
+version:             0
+-- tests that output goes to the correct file descriptors
+
+library
+  exposed-modules:     M
+  build-depends:       base
+  default-language:    Haskell2010

cabal-testsuite/PackageTests/FileDescriptors/my.cabal

@@ -0,0 +1,13 @@
+# Setup configure
+Configuring LibV09-0.1...
+# Setup build
+Preprocessing library for LibV09-0.1..
+Building library for LibV09-0.1..
+Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1..
+Building test suite 'LibV09-Deadlock' for LibV09-0.1..
+# Setup test
+Running 1 test suites...
+Test suite LibV09-Deadlock: RUNNING...
+Test suite LibV09-Deadlock: FAIL
+Test suite logged to: setup-deadlock.cabal.dist/work/dist/test/LibV09-0.1-LibV09-Deadlock.log
+0 of 1 test suites (0 of 1000 test cases) passed.

cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.err

@@ -0,0 +1,14 @@
+# Setup configure
+Configuring LibV09-0.1...
+# Setup build
+Preprocessing library for LibV09-0.1..
+Building library for LibV09-0.1..
+Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1..
+Building test suite 'LibV09-Deadlock' for LibV09-0.1..
+# Setup test
+Running 1 test suites...
+Test suite LibV09-Deadlock: RUNNING...
+Test suite LibV09-Deadlock: FAIL
+Test suite logged to:
+setup-deadlock.dist/work/dist/test/LibV09-0.1-LibV09-Deadlock.log
+0 of 1 test suites (0 of 1000 test cases) passed.

cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.err

@@ -0,0 +1,7 @@
+# Setup configure
+Configuring LibV09-0.1...
+# Setup build
+Preprocessing library for LibV09-0.1..
+Building library for LibV09-0.1..
+Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1..
+Building test suite 'LibV09-Deadlock' for LibV09-0.1..

cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.err

@@ -0,0 +1,7 @@
+# Setup configure
+Configuring LibV09-0.1...
+# Setup build
+Preprocessing library for LibV09-0.1..
+Building library for LibV09-0.1..
+Preprocessing test suite 'LibV09-Deadlock' for LibV09-0.1..
+Building test suite 'LibV09-Deadlock' for LibV09-0.1..

cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.err

@@ -5,4 +5,4 @@ import Distribution.TestSuite
 import Lib
 
 tests :: IO [Test]
-tests = return  [nullt x | x <- [1 .. 1000]]
+tests = return  [nullt x | x <- [1 .. 3]]

cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs

@@ -33,7 +33,14 @@ recordBuildInfo pkgName cname = do
   recordMode RecordAll $ do
     recordHeader ["show-build-info", prettyShow pkgName, prettyShow cname]
     buildInfo <- liftIO $ readFile fp
-    recordLog $ Result ExitSuccess "build --enable-build-info" buildInfo
+    recordLog $ Result
+      { resultExitCode = ExitSuccess
+      , resultCommand = "build --enable-build-info"
+      -- TODO: Consider if these three fields are instantiated correctly.
+      , resultOut = buildInfo
+      , resultStdout = buildInfo
+      , resultStderr = mempty
+      }
 
 -- | Decode the given filepath into a 'BuildInfo'.
 --

cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs

@@ -35,6 +35,7 @@ module Test.Cabal.Monad (
     testSourceCopyDir,
     testCabalDir,
     testUserCabalConfigFile,
+    FileDescriptor(..),
     testActualFile,
     -- * Skipping tests
     skip,
@@ -351,23 +352,29 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
 
     check_expect accept = do
         env <- getTestEnv
-        actual_raw <- liftIO $ readFileOrEmpty (testActualFile env)
-        expect <- liftIO $ readFileOrEmpty (testExpectFile env)
         norm_env <- mkNormalizerEnv
-        let actual = normalizeOutput norm_env actual_raw
-        when (words actual /= words expect) $ do
-            -- First try whitespace insensitive diff
-            let actual_fp = testNormalizedActualFile env
-                expect_fp = testNormalizedExpectFile env
-            liftIO $ writeFile actual_fp actual
-            liftIO $ writeFile expect_fp expect
-            liftIO $ putStrLn "Actual output differs from expected:"
-            b <- diff ["-uw"] expect_fp actual_fp
-            unless b . void $ diff ["-u"] expect_fp actual_fp
-            if accept
-                then do liftIO $ putStrLn "Accepting new output."
-                        liftIO $ writeFileNoCR (testExpectFile env) actual
-                else liftIO $ exitWith (ExitFailure 1)
+        [Out, Stdout, Stderr] `forM_` \fd -> do
+            exists <- liftIO $ doesFileExist $ testFile NotNormalized Expect fd env
+            when exists $ do
+              actual <- normalizeOutput norm_env <$> liftIO (readFileOrEmpty (testFile NotNormalized Actual fd env))
+              expect <- liftIO $ readFileOrEmpty (testFile NotNormalized Expect fd env)
+              when (words actual /= words expect) $ do
+                -- First try whitespace insensitive diff
+                let
+                  actualFile = testFile Normalized Actual fd env
+                  expectFile = testFile Normalized Expect fd env
+                liftIO $ do
+                  writeFile expectFile  actual
+                  writeFile actualFile expect
+                  putStrLn "Actual output differs from expected:"
+                b <- diff ["-uw"] expectFile actualFile
+                unless b . void $ diff ["-u"] expectFile actualFile
+                liftIO $
+                  if accept
+                  then do
+                    putStrLn "Accepting new output."
+                    writeFileNoCR (testFile NotNormalized Expect Stdout env) actual
+                  else exitWith (ExitFailure 1)
 
 readFileOrEmpty :: FilePath -> IO String
 readFileOrEmpty f = readFile f `E.catch` \e ->
@@ -596,18 +603,23 @@ testCabalDir env = testHomeDir env </> ".cabal"
 testUserCabalConfigFile :: TestEnv -> FilePath
 testUserCabalConfigFile env = testCabalDir env </> "config"
 
--- | The file where the expected output of the test lives
-testExpectFile :: TestEnv -> FilePath
-testExpectFile env = testSourceDir env </> testName env <.> "out"
+data Expected = Expect | Actual deriving (Show, Eq, Ord, Enum, Read, Bounded)
+data Normalized = Normalized | NotNormalized deriving (Show, Eq, Ord, Enum, Read, Bounded)
+data FileDescriptor = Out | Stdout | Stderr deriving (Show, Eq, Ord, Enum, Read, Bounded)
 
--- | Where we store the actual output
-testActualFile :: TestEnv -> FilePath
-testActualFile env = testWorkDir env </> testName env <.> "comp.out"
-
--- | Where we will write the normalized actual file (for diffing)
-testNormalizedActualFile :: TestEnv -> FilePath
-testNormalizedActualFile env = testActualFile env <.> "normalized"
-
--- | Where we will write the normalized expected file (for diffing)
-testNormalizedExpectFile :: TestEnv -> FilePath
-testNormalizedExpectFile env = testWorkDir env </> testName env <.> "out.normalized"
+testFile :: Normalized -> Expected -> FileDescriptor -> TestEnv -> FilePath
+testFile n e f = \env -> sourceDir env </> testName env <.> suffix
+  where
+  suffix
+    =   case e of { Expect -> "" ; Actual -> "comp" }
+    <.> case f of { Out -> "out" ; Stdout -> "stdout" ; Stderr -> "stderr" }
+    <.> case n of { Normalized -> "normalized" ; NotNormalized -> "" }
+  sourceDir env = case (e, n) of
+    (_, Normalized) -> testWorkDir env
+    (Actual, _) -> testWorkDir env
+    _ -> testSourceDir env
+{-# INLINE testFile #-}
+
+testActualFile :: FileDescriptor -> TestEnv -> FilePath
+testActualFile fd env = testFile NotNormalized Actual fd env
+{-# INLINE testActualFile #-}

cabal-testsuite/src/Test/Cabal/Monad.hs

@@ -563,14 +563,17 @@ withRepo repo_dir m = do
 requireSuccess :: Result -> TestM Result
 requireSuccess r@Result { resultCommand = cmd
                         , resultExitCode = exitCode
-                        , resultOutput = output } = withFrozenCallStack $ do
+                        , resultStdout
+                        , resultStderr } = withFrozenCallStack $ do
     env <- getTestEnv
     when (exitCode /= ExitSuccess && not (testShouldFail env)) $
         assertFailure $ "Command " ++ cmd ++ " failed.\n" ++
-        "Output:\n" ++ output ++ "\n"
+        "Stdout:\n" ++ resultStdout ++ "\n" ++
+        "Stderr:\n" ++ resultStderr ++ "\n"
     when (exitCode == ExitSuccess && testShouldFail env) $
         assertFailure $ "Command " ++ cmd ++ " succeeded.\n" ++
-        "Output:\n" ++ output ++ "\n"
+        "Stdout:\n" ++ resultStdout ++ "\n" ++
+        "Stderr:\n" ++ resultStderr ++ "\n"
     return r
 
 initWorkDir :: TestM ()
@@ -595,21 +598,30 @@ recordHeader args = do
             initWorkDir
             liftIO $ putStr str_header
             liftIO $ C.appendFile (testWorkDir env </> "test.log") header
-            liftIO $ C.appendFile (testActualFile env) header
+            liftIO $ C.appendFile (testActualFile Out env) header
 
 recordLog :: Result -> TestM ()
-recordLog res = do
+recordLog Result{resultOut, resultStdout, resultStderr, resultCommand} = do
     env <- getTestEnv
     let mode = testRecordMode env
     initWorkDir
     liftIO $ C.appendFile (testWorkDir env </> "test.log")
-                         (C.pack $ "+ " ++ resultCommand res ++ "\n"
-                            ++ resultOutput res ++ "\n\n")
-    liftIO . C.appendFile (testActualFile env) . C.pack . testRecordNormalizer env $
-        case mode of
-            RecordAll    -> unlines (lines (resultOutput res))
-            RecordMarked -> getMarkedOutput (resultOutput res)
+                         (C.pack $ "+ " ++ resultCommand ++ "\n"
+                            ++ "OUT\n" <> resultOut ++ "\n"
+                            ++ "STDOUT\n" <> resultStdout ++ "\n"
+                            ++ "STDERR\n" <> resultStderr ++ "\n"
+                            ++ "\n")
+    let report f txt
+          = liftIO
+          . C.appendFile f
+          . C.pack
+          . testRecordNormalizer env $ case mode of
+            RecordAll    -> unlines (lines txt)
+            RecordMarked -> getMarkedOutput txt
             DoNotRecord  -> ""
+    report (testActualFile Out env) resultOut
+    report (testActualFile Stdout env) resultStdout
+    report (testActualFile Stderr env) resultStderr
 
 getMarkedOutput :: String -> String -- trailing newline
 getMarkedOutput out = unlines (go (lines out) False)
@@ -669,7 +681,7 @@ shouldNotExist path =
 assertRegex :: MonadIO m => String -> String -> Result -> m ()
 assertRegex msg regex r =
     withFrozenCallStack $
-    let out = resultOutput r
+    let out = resultStdout r
     in assertBool (msg ++ ",\nactual output:\n" ++ out)
        (out =~ regex)
 
@@ -695,14 +707,14 @@ assertOutputContains needle result =
     withFrozenCallStack $
     unless (needle `isInfixOf` (concatOutput output)) $
     assertFailure $ " expected: " ++ needle
-  where output = resultOutput result
+  where output = resultStdout result
 
 assertOutputDoesNotContain :: MonadIO m => WithCallStack (String -> Result -> m ())
 assertOutputDoesNotContain needle result =
     withFrozenCallStack $
     when (needle `isInfixOf` (concatOutput output)) $
     assertFailure $ "unexpected: " ++ needle
-  where output = resultOutput result
+  where output = resultStdout result
 
 assertFindInFile :: MonadIO m => WithCallStack (String -> FilePath -> m ())
 assertFindInFile needle path =
@@ -897,7 +909,7 @@ withSourceCopy m = do
     let cwd  = testCurrentDir env
         dest = testSourceCopyDir env
     r <- git' "ls-files" ["--cached", "--modified"]
-    forM_ (lines (resultOutput r)) $ \f -> do
+    forM_ (lines (resultStdout r)) $ \f -> do
         unless (isTestFile f) $ do
             liftIO $ createDirectoryIfMissing True (takeDirectory (dest </> f))
             liftIO $ copyFile (cwd </> f) (dest </> f)
@@ -923,7 +935,7 @@ getIPID :: String -> TestM String
 getIPID pn = do
     r <- ghcPkg' "field" ["--global", pn, "id"]
     -- Don't choke on warnings from ghc-pkg
-    case mapMaybe (stripPrefix "id: ") (lines (resultOutput r)) of
+    case mapMaybe (stripPrefix "id: ") (lines (resultStdout r)) of
         -- ~/.cabal/store may contain multiple versions of single package
         -- we pick first one. It should work
         (x:_) -> return (takeWhile (not . Char.isSpace) x)

cabal-testsuite/src/Test/Cabal/Prelude.hs

@@ -15,12 +15,18 @@ import System.IO
 import System.Exit
 import System.Directory
 import System.FilePath
+import Data.Foldable (traverse_)
 
 -- | The result of invoking the command line.
 data Result = Result
     { resultExitCode    :: ExitCode
     , resultCommand     :: String
-    , resultOutput      :: String
+    -- | Output sent to any file descriptor.
+    , resultOut         :: String
+    -- | Output sent to stdout.
+    , resultStdout      :: String
+    -- | Output sent to stderr.
+    , resultStderr      :: String
     } deriving Show
 
 -- | Run a command, streaming its output to stdout, and return a 'Result'
@@ -46,22 +52,23 @@ run _verbosity mb_cwd env_overrides path0 args input = do
 
     mb_env <- getEffectiveEnvironment env_overrides
     putStrLn $ "+ " ++ showCommandForUser path args
-    (readh, writeh) <- Compat.createPipe
-    hSetBuffering readh LineBuffering
-    hSetBuffering writeh LineBuffering
-    let drain = do
-            r <- hGetContents readh
-            putStr r -- forces the output
-            hClose readh
+    (readstdout, writestdout) <- Compat.createPipe
+    (readstderr, writestderr) <- Compat.createPipe
+    (readall, writeall) <- Compat.createPipe
+    traverse_ (`hSetBuffering` LineBuffering) [ stdout, readstdout, writestdout, readstderr, writestderr, readall, writeall ]
+    let mkDrain h = do
+            r <- hGetContents' h
+            hPutStr writeall r
             return r
-    withAsync drain $ \sync -> do
+    withAsync (mkDrain readstdout) $ \syncstdout -> do
+    withAsync (mkDrain readstderr) $ \syncstderr -> do
 
     let prc = (proc path args)
           { cwd = mb_cwd
           , env = mb_env
           , std_in = case input of { Just _ -> CreatePipe; Nothing -> Inherit }
-          , std_out = UseHandle writeh
-          , std_err = UseHandle writeh
+          , std_out = UseHandle writestdout
+          , std_err = UseHandle writestderr
           }
     (stdin_h, _, _, procHandle) <- createProcess prc
 
@@ -74,10 +81,23 @@ run _verbosity mb_cwd env_overrides path0 args input = do
 
     -- wait for the program to terminate
     exitcode <- waitForProcess procHandle
-    out <- wait sync
+    rStdout <- wait syncstdout
+    rStderr <- wait syncstderr
+    hClose writeall
+
+    rAll <- hGetContents' readall
 
     return Result {
             resultExitCode = exitcode,
             resultCommand = showCommandForUser path args,
-            resultOutput = out
+            resultOut = rAll,
+            resultStdout = rStdout,
+            resultStderr = rStderr
         }
+
+-- `hGetContents'` is in since base-4.15.0.0 -- which we don't have.
+hGetContents' :: Handle -> IO String
+hGetContents' h = do
+  v <- hGetContents h
+  length v `seq` hClose h
+  pure v

cabal-testsuite/src/Test/Cabal/Run.hs

@@ -0,0 +1,3 @@
+synopsis: Test where Cabal writes output to
+packages: Cabal
+issues: #7790