WIP

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

@@ -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/src/Test/Cabal/DecodeShowBuildInfo.hs

@@ -33,7 +33,7 @@ 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 ExitSuccess "build --enable-build-info" buildInfo mempty
 
 -- | Decode the given filepath into a 'BuildInfo'.
 --

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

@@ -35,7 +35,8 @@ module Test.Cabal.Monad (
     testSourceCopyDir,
     testCabalDir,
     testUserCabalConfigFile,
-    testActualFile,
+    testActualFileStdout,
+    testActualFileStderr,
     -- * Skipping tests
     skip,
     skipIf,
@@ -351,22 +352,23 @@ 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)
+        -- TODO: Compare stderr
+        actual_raw <- liftIO $ readFileOrEmpty (testActualFileStdout env)
+        expect <- liftIO $ readFileOrEmpty (testExpectFileStdout 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
+            let actual_fp = testNormalizedActualFileStdout env
+                expect_fp = testNormalizedExpectFileStdout 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
+                        liftIO $ writeFileNoCR (testExpectFileStdout env) actual
                 else liftIO $ exitWith (ExitFailure 1)
 
 readFileOrEmpty :: FilePath -> IO String
@@ -597,17 +599,25 @@ 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"
+testExpectFileStdout :: TestEnv -> FilePath
+testExpectFileStdout env = testSourceDir env </> testName env <.> "stdout"
 
 -- | Where we store the actual output
-testActualFile :: TestEnv -> FilePath
-testActualFile env = testWorkDir env </> testName env <.> "comp.out"
+testActualFileStdout :: TestEnv -> FilePath
+testActualFileStdout env = testWorkDir env </> testName env <.> "comp.stdout"
+
+-- | The file where the expected output of the test lives
+testExpectFileStderr :: TestEnv -> FilePath
+testExpectFileStderr env = testSourceDir env </> testName env <.> "stderr"
+
+-- | Where we store the actual errput
+testActualFileStderr :: TestEnv -> FilePath
+testActualFileStderr env = testWorkDir env </> testName env <.> "comp.stderr"
 
 -- | Where we will write the normalized actual file (for diffing)
-testNormalizedActualFile :: TestEnv -> FilePath
-testNormalizedActualFile env = testActualFile env <.> "normalized"
+testNormalizedActualFileStdout :: TestEnv -> FilePath
+testNormalizedActualFileStdout env = testActualFileStdout env <.> "normalized"
 
 -- | Where we will write the normalized expected file (for diffing)
-testNormalizedExpectFile :: TestEnv -> FilePath
-testNormalizedExpectFile env = testWorkDir env </> testName env <.> "out.normalized"
+testNormalizedExpectFileStdout :: TestEnv -> FilePath
+testNormalizedExpectFileStdout env = testWorkDir env </> testName env <.> "stdout.normalized"

cabal-testsuite/src/Test/Cabal/Prelude.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,28 @@ 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 (testActualFileStdout env) header
 
 recordLog :: Result -> TestM ()
-recordLog res = do
+recordLog Result{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"
+                            ++ "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 (testActualFileStdout env) resultStdout
+    report (testActualFileStderr env) resultStderr
 
 getMarkedOutput :: String -> String -- trailing newline
 getMarkedOutput out = unlines (go (lines out) False)
@@ -669,7 +679,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 +705,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 +907,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 +933,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/Run.hs

@@ -15,12 +15,15 @@ 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
+    , result            :: String
+    , resultStdout      :: String
+    , resultStderr      :: String
     } deriving Show
 
 -- | Run a command, streaming its output to stdout, and return a 'Result'
@@ -46,22 +49,29 @@ 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) [ readstdout, writestdout, readstderr, writestderr, readall, writeall ]
+    let mkDrain h = do
+            r <- hGetContents h
+            length r `seq` hClose h
+            hPutStr writeall r
             return r
-    withAsync drain $ \sync -> do
+    let mkDrain' h = do
+            r <- hGetContents h
+            length r `seq` hClose h
+            return r
+    withAsync (mkDrain readstdout) $ \syncstdout -> do
+    withAsync (mkDrain readstderr) $ \syncstderr -> do
+    withAsync (mkDrain' readall)   $ \syncall -> 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 +84,15 @@ 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 <- wait syncall
 
     return Result {
             resultExitCode = exitcode,
             resultCommand = showCommandForUser path args,
-            resultOutput = out
+            result = rAll,
+            resultStdout = rStdout,
+            resultStderr = rStderr
         }