From 7566cf663fa42e3d2f78aef032d625c3e03cf566 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Fri, 3 Dec 2021 23:23:48 +0100 Subject: [PATCH 1/4] 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 --- .../PackageTests/FileDescriptors/M.hs | 1 + .../PackageTests/FileDescriptors/Setup.hs | 2 + .../PackageTests/FileDescriptors/cabal.out | 8 +++ .../FileDescriptors/cabal.project | 1 + .../PackageTests/FileDescriptors/cabal.stderr | 7 ++ .../PackageTests/FileDescriptors/cabal.stdout | 0 .../FileDescriptors/cabal.test.hs | 4 ++ .../PackageTests/FileDescriptors/my.cabal | 9 +++ .../LibV09/setup-deadlock.cabal.err | 13 ++++ .../TestSuiteTests/LibV09/setup-deadlock.err | 14 ++++ .../TestSuiteTests/LibV09/setup.cabal.err | 7 ++ .../TestSuiteTests/LibV09/setup.err | 7 ++ .../TestSuiteTests/LibV09/tests/Deadlock.hs | 2 +- .../src/Test/Cabal/DecodeShowBuildInfo.hs | 9 ++- cabal-testsuite/src/Test/Cabal/Monad.hs | 72 +++++++++++-------- cabal-testsuite/src/Test/Cabal/Prelude.hs | 44 +++++++----- cabal-testsuite/src/Test/Cabal/Run.hs | 46 ++++++++---- changelog.d/issue-7790 | 3 + 18 files changed, 188 insertions(+), 61 deletions(-) create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/M.hs create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/Setup.hs create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/cabal.out create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/cabal.project create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/cabal.stderr create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/cabal.stdout create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/FileDescriptors/my.cabal create mode 100644 cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.err create mode 100644 cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.err create mode 100644 cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.err create mode 100644 cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.err create mode 100644 changelog.d/issue-7790 diff --git a/cabal-testsuite/PackageTests/FileDescriptors/M.hs b/cabal-testsuite/PackageTests/FileDescriptors/M.hs new file mode 100644 index 00000000000..ef2ad8bb3fc --- /dev/null +++ b/cabal-testsuite/PackageTests/FileDescriptors/M.hs @@ -0,0 +1 @@ +module M where diff --git a/cabal-testsuite/PackageTests/FileDescriptors/Setup.hs b/cabal-testsuite/PackageTests/FileDescriptors/Setup.hs new file mode 100644 index 00000000000..2ee479d6a5c --- /dev/null +++ b/cabal-testsuite/PackageTests/FileDescriptors/Setup.hs @@ -0,0 +1,2 @@ +main :: IO () +main = fail "Setup called despite `build-type:Simple`" diff --git a/cabal-testsuite/PackageTests/FileDescriptors/cabal.out b/cabal-testsuite/PackageTests/FileDescriptors/cabal.out new file mode 100644 index 00000000000..bf4d7ed26b1 --- /dev/null +++ b/cabal-testsuite/PackageTests/FileDescriptors/cabal.out @@ -0,0 +1,8 @@ +# cabal build +Resolving dependencies... +Build profile: -w ghc- -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.. diff --git a/cabal-testsuite/PackageTests/FileDescriptors/cabal.project b/cabal-testsuite/PackageTests/FileDescriptors/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/FileDescriptors/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/FileDescriptors/cabal.stderr b/cabal-testsuite/PackageTests/FileDescriptors/cabal.stderr new file mode 100644 index 00000000000..43108d9cdfc --- /dev/null +++ b/cabal-testsuite/PackageTests/FileDescriptors/cabal.stderr @@ -0,0 +1,7 @@ +Resolving dependencies... +Build profile: -w ghc- -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.. diff --git a/cabal-testsuite/PackageTests/FileDescriptors/cabal.stdout b/cabal-testsuite/PackageTests/FileDescriptors/cabal.stdout new file mode 100644 index 00000000000..e69de29bb2d diff --git a/cabal-testsuite/PackageTests/FileDescriptors/cabal.test.hs b/cabal-testsuite/PackageTests/FileDescriptors/cabal.test.hs new file mode 100644 index 00000000000..4cfc6f553ed --- /dev/null +++ b/cabal-testsuite/PackageTests/FileDescriptors/cabal.test.hs @@ -0,0 +1,4 @@ +import Test.Cabal.Prelude + +main :: IO () +main = cabalTest $ cabal "build" ["all"] diff --git a/cabal-testsuite/PackageTests/FileDescriptors/my.cabal b/cabal-testsuite/PackageTests/FileDescriptors/my.cabal new file mode 100644 index 00000000000..8ac82470a80 --- /dev/null +++ b/cabal-testsuite/PackageTests/FileDescriptors/my.cabal @@ -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 diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.err b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.err new file mode 100644 index 00000000000..df53409394d --- /dev/null +++ b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.cabal.err @@ -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. diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.err b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.err new file mode 100644 index 00000000000..d0a529f49df --- /dev/null +++ b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup-deadlock.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. diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.err b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.cabal.err new file mode 100644 index 00000000000..1765b626f96 --- /dev/null +++ b/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.. diff --git a/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.err b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.err new file mode 100644 index 00000000000..1765b626f96 --- /dev/null +++ b/cabal-testsuite/PackageTests/TestSuiteTests/LibV09/setup.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.. 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..cb963be06b7 100644 --- a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs +++ b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.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'. -- diff --git a/cabal-testsuite/src/Test/Cabal/Monad.hs b/cabal-testsuite/src/Test/Cabal/Monad.hs index 376d144e606..25c493b1158 100644 --- a/cabal-testsuite/src/Test/Cabal/Monad.hs +++ b/cabal-testsuite/src/Test/Cabal/Monad.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 #-} diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index baab736e852..b7432150090 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,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) diff --git a/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal-testsuite/src/Test/Cabal/Run.hs index 141be2575fa..0f828ef3d70 100644 --- a/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/cabal-testsuite/src/Test/Cabal/Run.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 diff --git a/changelog.d/issue-7790 b/changelog.d/issue-7790 new file mode 100644 index 00000000000..4bb3927c816 --- /dev/null +++ b/changelog.d/issue-7790 @@ -0,0 +1,3 @@ +synopsis: Test where Cabal writes output to +packages: Cabal +issues: #7790 From e0a70e18da89805df319d2576b5eba36846677f4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 25 Nov 2021 22:09:30 +0100 Subject: [PATCH 2/4] Write debug output to stderr --- Cabal/src/Distribution/Simple/Utils.hs | 48 ++++++++++++-------------- Cabal/src/Distribution/Verbosity.hs | 1 + 2 files changed, 23 insertions(+), 26 deletions(-) diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs index 15514b7abec..05614efe4fc 100644 --- a/Cabal/src/Distribution/Simple/Utils.hs +++ b/Cabal/src/Distribution/Simple/Utils.hs @@ -423,7 +423,7 @@ topHandlerWith cont prog = do handle se = do hFlush stdout pname <- getProgName - hPutStr stderr (message pname se) + putErr (message pname se) cont se message :: String -> Exception.SomeException -> String @@ -457,11 +457,6 @@ displaySomeException se = topHandler :: IO a -> IO a topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog -verbosityHandle :: Verbosity -> Handle -verbosityHandle verbosity - | isVerboseStderr verbosity = stderr - | otherwise = stdout - -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level. @@ -471,9 +466,10 @@ warn verbosity msg = withFrozenCallStack $ do when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do ts <- getPOSIXTime hFlush stdout - hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity - . wrapTextVerbosity verbosity - $ "Warning: " ++ msg + putErr + . withMetadata ts NormalMark FlagTrace verbosity + . wrapTextVerbosity verbosity + $ "Warning: " ++ msg -- | Useful status messages. -- @@ -485,9 +481,8 @@ warn verbosity msg = withFrozenCallStack $ do notice :: Verbosity -> String -> IO () notice verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h + putErr $ withMetadata ts NormalMark FlagTrace verbosity $ wrapTextVerbosity verbosity $ msg @@ -498,9 +493,8 @@ notice verbosity msg = withFrozenCallStack $ do noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h . withMetadata ts NormalMark FlagTrace verbosity $ msg + putErr . withMetadata ts NormalMark FlagTrace verbosity $ msg -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity -- level. Use this if you need fancy formatting. @@ -508,9 +502,8 @@ noticeNoWrap verbosity msg = withFrozenCallStack $ do noticeDoc :: Verbosity -> Disp.Doc -> IO () noticeDoc verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do - let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h + putErr $ withMetadata ts NormalMark FlagTrace verbosity $ Disp.renderStyle defaultStyle $ msg @@ -529,9 +522,8 @@ setupMessage verbosity msg pkgid = withFrozenCallStack $ do info :: Verbosity -> String -> IO () info verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h + putErr $ withMetadata ts NeverMark FlagTrace verbosity $ wrapTextVerbosity verbosity $ msg @@ -539,12 +531,17 @@ info verbosity msg = withFrozenCallStack $ infoNoWrap :: Verbosity -> String -> IO () infoNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do - let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h + putErr $ withMetadata ts NeverMark FlagTrace verbosity $ msg +putErr :: String -> IO () +putErr = hPutStr stderr + +putErrLn :: String -> IO () +putErrLn = hPutStrLn stderr + -- | Detailed internal debugging information -- -- We display these messages when the verbosity level is 'deafening' @@ -552,11 +549,11 @@ infoNoWrap verbosity msg = withFrozenCallStack $ debug :: Verbosity -> String -> IO () debug verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity - $ wrapTextVerbosity verbosity - $ msg + putErr + $ withMetadata ts NeverMark FlagTrace verbosity + $ wrapTextVerbosity verbosity + $ msg -- ensure that we don't lose output if we segfault/infinite loop hFlush stdout @@ -565,9 +562,8 @@ debug verbosity msg = withFrozenCallStack $ debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do - let h = verbosityHandle verbosity ts <- getPOSIXTime - hPutStr h + putErr $ withMetadata ts NeverMark FlagTrace verbosity $ msg -- ensure that we don't lose output if we segfault/infinite loop @@ -580,7 +576,7 @@ chattyTry :: String -- ^ a description of the action we were attempting -> IO () chattyTry desc action = catchIO action $ \exception -> - hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception + putErrLn $ "Error while " ++ desc ++ ": " ++ show exception -- | Run an IO computation, returning @e@ if it raises a "file -- does not exist" error. diff --git a/Cabal/src/Distribution/Verbosity.hs b/Cabal/src/Distribution/Verbosity.hs index d73cbd8031d..7c36d945571 100644 --- a/Cabal/src/Distribution/Verbosity.hs +++ b/Cabal/src/Distribution/Verbosity.hs @@ -343,6 +343,7 @@ isVerboseTimestamp = isVerboseFlag VTimestamp -- @since 3.4.0.0 isVerboseStderr :: Verbosity -> Bool isVerboseStderr = isVerboseFlag VStderr +{-# DEPRECATED isVerboseStderr "Cabal output should generally not go to stdout." #-} -- | Test if we should output warnings when we log. isVerboseNoWarn :: Verbosity -> Bool From 98988cab8644ccf789a5018c747f2340c591bfdb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 9 Dec 2021 22:29:12 +0100 Subject: [PATCH 3/4] Undo renaming of `resultOutput` --- .../src/Test/Cabal/DecodeShowBuildInfo.hs | 2 +- cabal-testsuite/src/Test/Cabal/Prelude.hs | 20 +++++++++++-------- cabal-testsuite/src/Test/Cabal/Run.hs | 4 ++-- 3 files changed, 15 insertions(+), 11 deletions(-) diff --git a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs index cb963be06b7..488b4c3c4ec 100644 --- a/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs +++ b/cabal-testsuite/src/Test/Cabal/DecodeShowBuildInfo.hs @@ -37,7 +37,7 @@ recordBuildInfo pkgName cname = do { resultExitCode = ExitSuccess , resultCommand = "build --enable-build-info" -- TODO: Consider if these three fields are instantiated correctly. - , resultOut = buildInfo + , resultOutput = buildInfo , resultStdout = buildInfo , resultStderr = mempty } diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index b7432150090..70b6ec38ca4 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -601,16 +601,20 @@ recordHeader args = do liftIO $ C.appendFile (testActualFile Out env) header recordLog :: Result -> TestM () -recordLog Result{resultOut, resultStdout, resultStderr, resultCommand} = do +recordLog Result{resultOutput, resultStdout, resultStderr, resultCommand} = do env <- getTestEnv let mode = testRecordMode env initWorkDir - liftIO $ C.appendFile (testWorkDir env "test.log") - (C.pack $ "+ " ++ resultCommand ++ "\n" - ++ "OUT\n" <> resultOut ++ "\n" - ++ "STDOUT\n" <> resultStdout ++ "\n" - ++ "STDERR\n" <> resultStderr ++ "\n" - ++ "\n") + liftIO + $ C.appendFile (testWorkDir env "test.log") + $ C.pack $ unlines + [ "+ " <> resultCommand, "OUT" + , resultOutput + , "STDOUT" + , resultStdout + , "STDERR" + , resultStderr + ] let report f txt = liftIO . C.appendFile f @@ -619,7 +623,7 @@ recordLog Result{resultOut, resultStdout, resultStderr, resultCommand} = do RecordAll -> unlines (lines txt) RecordMarked -> getMarkedOutput txt DoNotRecord -> "" - report (testActualFile Out env) resultOut + report (testActualFile Out env) resultOutput report (testActualFile Stdout env) resultStdout report (testActualFile Stderr env) resultStderr diff --git a/cabal-testsuite/src/Test/Cabal/Run.hs b/cabal-testsuite/src/Test/Cabal/Run.hs index 0f828ef3d70..3ddccc94921 100644 --- a/cabal-testsuite/src/Test/Cabal/Run.hs +++ b/cabal-testsuite/src/Test/Cabal/Run.hs @@ -22,7 +22,7 @@ data Result = Result { resultExitCode :: ExitCode , resultCommand :: String -- | Output sent to any file descriptor. - , resultOut :: String + , resultOutput :: String -- | Output sent to stdout. , resultStdout :: String -- | Output sent to stderr. @@ -90,7 +90,7 @@ run _verbosity mb_cwd env_overrides path0 args input = do return Result { resultExitCode = exitcode, resultCommand = showCommandForUser path args, - resultOut = rAll, + resultOutput = rAll, resultStdout = rStdout, resultStderr = rStderr } From 2bfbad70a19cba78ba6b804afd024cd21628e141 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Frederik=20Hangh=C3=B8j=20Iversen?= Date: Thu, 9 Dec 2021 22:34:44 +0100 Subject: [PATCH 4/4] Undo changes where tests inspect only stdout --- cabal-testsuite/src/Test/Cabal/Prelude.hs | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/cabal-testsuite/src/Test/Cabal/Prelude.hs b/cabal-testsuite/src/Test/Cabal/Prelude.hs index 70b6ec38ca4..cdf79f3d505 100644 --- a/cabal-testsuite/src/Test/Cabal/Prelude.hs +++ b/cabal-testsuite/src/Test/Cabal/Prelude.hs @@ -683,11 +683,10 @@ shouldNotExist path = liftIO $ doesFileExist path >>= assertBool (path ++ " should exist") . not assertRegex :: MonadIO m => String -> String -> Result -> m () -assertRegex msg regex r = - withFrozenCallStack $ - let out = resultStdout r - in assertBool (msg ++ ",\nactual output:\n" ++ out) - (out =~ regex) +assertRegex msg regex Result{ resultOutput } + = withFrozenCallStack + $ assertBool (msg ++ ",\nactual output:\n" ++ resultOutput) + $ resultOutput =~ regex fails :: TestM a -> TestM a fails = withReaderT (\env -> env { testShouldFail = not (testShouldFail env) }) @@ -707,18 +706,16 @@ recordNormalizer f = withReaderT (\env -> env { testRecordNormalizer = testRecordNormalizer env . f }) assertOutputContains :: MonadIO m => WithCallStack (String -> Result -> m ()) -assertOutputContains needle result = +assertOutputContains needle Result{resultOutput} = withFrozenCallStack $ - unless (needle `isInfixOf` (concatOutput output)) $ + unless (needle `isInfixOf` (concatOutput resultOutput)) $ assertFailure $ " expected: " ++ needle - where output = resultStdout result assertOutputDoesNotContain :: MonadIO m => WithCallStack (String -> Result -> m ()) -assertOutputDoesNotContain needle result = +assertOutputDoesNotContain needle Result{resultOutput} = withFrozenCallStack $ - when (needle `isInfixOf` (concatOutput output)) $ + when (needle `isInfixOf` (concatOutput resultOutput)) $ assertFailure $ "unexpected: " ++ needle - where output = resultStdout result assertFindInFile :: MonadIO m => WithCallStack (String -> FilePath -> m ()) assertFindInFile needle path = @@ -913,7 +910,7 @@ withSourceCopy m = do let cwd = testCurrentDir env dest = testSourceCopyDir env r <- git' "ls-files" ["--cached", "--modified"] - forM_ (lines (resultStdout r)) $ \f -> do + forM_ (lines (resultOutput r)) $ \f -> do unless (isTestFile f) $ do liftIO $ createDirectoryIfMissing True (takeDirectory (dest f)) liftIO $ copyFile (cwd f) (dest f) @@ -939,7 +936,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 (resultStdout r)) of + case mapMaybe (stripPrefix "id: ") (lines (resultOutput 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)