diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.out b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.err similarity index 100% rename from cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.out rename to cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.err diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.out b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.err similarity index 100% rename from cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.out rename to cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.err diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.out b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.err similarity index 100% rename from cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.out rename to cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.err diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.out b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.err similarity index 100% rename from cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.out rename to cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.err diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs index 5d7db101ed9..6fdf78e48ad 100644 --- a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/tests/Deadlock.hs +++ b/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]] diff --git a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs index 02c1cb7e733..8ac5e92d5a1 100644 --- a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs +++ b/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'. -- diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 376d144e606..add2fd2256e 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/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,14 +352,15 @@ 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:" @@ -366,7 +368,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do 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" diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index baab736e852..e894a56584c 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/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) diff --git a/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal-testsuite/src/Test/Cabal/Run.hs index 141be2575fa..25fe77485d6 100644 --- a/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/cabal-testsuite/src/Test/Cabal/Run.hs @@ -15,12 +15,14 @@ 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 + , resultStdout :: String + , resultStderr :: String } deriving Show -- | Run a command, streaming its output to stdout, and return a 'Result' @@ -46,22 +48,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 + (readstdout, writestdout) <- Compat.createPipe + (readstderr, writestderr) <- Compat.createPipe + traverse_ (`hSetBuffering` LineBuffering) [ readstdout, writestdout, readstderr, writestderr ] + let mkDrain h = do + r <- hGetContents h putStr r -- forces the output - hClose readh + hClose h 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 +77,12 @@ 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 return Result { resultExitCode = exitcode, resultCommand = showCommandForUser path args, - resultOutput = out + resultStdout = rStdout, + resultStderr = rStderr }