Write debug output to stderr

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,19 +493,17 @@ 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.
 --
 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,34 +522,38 @@ 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
 
 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'
 --
 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.

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

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.test.hs

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

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

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.

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.

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

@@ -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/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,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.
+      , resultOutput = buildInfo
+      , resultStdout = buildInfo
+      , resultStderr = mempty
+      }
 
 -- | Decode the given filepath into a 'BuildInfo'.
 --

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 #-}