From e752ad0550235fe3525fd11db5997eb14504fa47 Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Sun, 24 Sep 2017 22:40:39 -0400 Subject: [PATCH] Use stderr for Cabal's diagnostic messages instead of stdout Send all diagnostic messages (including debug, info, notice) to stderr instead of stdout. Likewise, redirect GHC's stdout to stderr as GHC sends progress output to stdout due to GHC Trac #3636. --- Cabal/Distribution/Simple/Program/GHC.hs | 3 +- Cabal/Distribution/Simple/Program/Run.hs | 15 +++++--- Cabal/Distribution/Simple/Utils.hs | 36 +++++++++++-------- Cabal/Distribution/Utils/LogProgress.hs | 3 +- .../Distribution/Client/GenBounds.hs | 8 ++--- cabal-install/Distribution/Client/Install.hs | 6 ++-- 6 files changed, 44 insertions(+), 27 deletions(-) diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index cdb9b014b19..c103a48b68a 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -566,7 +566,8 @@ ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> ProgramInvocation ghcInvocation prog comp platform opts = (programInvocation prog (renderGhcOptions comp platform opts)) { - progInvokePathEnv = fromNubListR (ghcOptExtraPath opts) + progInvokePathEnv = fromNubListR (ghcOptExtraPath opts), + progInvokeOutAsErr = True } renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String] diff --git a/Cabal/Distribution/Simple/Program/Run.hs b/Cabal/Distribution/Simple/Program/Run.hs index df07db0d386..2ada7794389 100644 --- a/Cabal/Distribution/Simple/Program/Run.hs +++ b/Cabal/Distribution/Simple/Program/Run.hs @@ -40,6 +40,7 @@ import Distribution.Verbosity import System.Exit (ExitCode (..), exitWith) import System.FilePath +import System.IO (stderr) import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map @@ -60,7 +61,8 @@ data ProgramInvocation = ProgramInvocation { progInvokeCwd :: Maybe FilePath, progInvokeInput :: Maybe IOData, progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'. - progInvokeOutputEncoding :: IOEncoding + progInvokeOutputEncoding :: IOEncoding, + progInvokeOutAsErr :: Bool } data IOEncoding = IOEncodingText -- locale mode text @@ -81,7 +83,8 @@ emptyProgramInvocation = progInvokeCwd = Nothing, progInvokeInput = Nothing, progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText + progInvokeOutputEncoding = IOEncodingText, + progInvokeOutAsErr = False } simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation @@ -121,16 +124,20 @@ runProgramInvocation verbosity progInvokeEnv = envOverrides, progInvokePathEnv = extraPath, progInvokeCwd = mcwd, - progInvokeInput = Nothing + progInvokeInput = Nothing, + progInvokeOutAsErr = outAsErr } = do pathOverride <- getExtraPathEnv envOverrides extraPath menv <- getEffectiveEnvironment (envOverrides ++ pathOverride) exitCode <- rawSystemIOWithEnv verbosity path args mcwd menv - Nothing Nothing Nothing + Nothing childStdout Nothing when (exitCode /= ExitSuccess) $ exitWith exitCode + where + childStdout | outAsErr = Just stderr + | otherwise = Nothing runProgramInvocation verbosity ProgramInvocation { diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index 01f81c1969e..79aa2d9be86 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -222,8 +222,8 @@ import System.FilePath as FilePath , getSearchPath, joinPath, takeDirectory, splitExtension , splitDirectories, searchPathSeparator ) import System.IO - ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush - , hClose, hSetBuffering, BufferMode(..) ) + ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hPutStrLn + , hFlush, hClose, hSetBuffering, BufferMode(..) ) import System.IO.Error import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -453,7 +453,8 @@ notice :: Verbosity -> String -> IO () notice verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do ts <- getPOSIXTime - hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity + hFlush stdout + hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity . wrapTextVerbosity verbosity $ msg @@ -464,7 +465,8 @@ noticeNoWrap :: Verbosity -> String -> IO () noticeNoWrap verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do ts <- getPOSIXTime - hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity $ msg + hFlush stdout + hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity $ msg -- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity -- level. Use this if you need fancy formatting. @@ -473,7 +475,8 @@ noticeDoc :: Verbosity -> Disp.Doc -> IO () noticeDoc verbosity msg = withFrozenCallStack $ do when (verbosity >= normal) $ do ts <- getPOSIXTime - hPutStr stdout . withMetadata ts NormalMark FlagTrace verbosity + hFlush stdout + hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity . Disp.renderStyle defaultStyle $ msg -- | Display a "setup status message". Prefer using setupMessage' @@ -491,7 +494,8 @@ info :: Verbosity -> String -> IO () info verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do ts <- getPOSIXTime - hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + hFlush stdout + hPutStr stderr . withMetadata ts NeverMark FlagTrace verbosity . wrapTextVerbosity verbosity $ msg @@ -499,7 +503,8 @@ infoNoWrap :: Verbosity -> String -> IO () infoNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= verbose) $ do ts <- getPOSIXTime - hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + hFlush stdout + hPutStr stderr . withMetadata ts NeverMark FlagTrace verbosity $ msg -- | Detailed internal debugging information @@ -510,11 +515,12 @@ debug :: Verbosity -> String -> IO () debug verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do ts <- getPOSIXTime - hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + hFlush stdout + hPutStr stderr . withMetadata ts NeverMark FlagTrace verbosity . wrapTextVerbosity verbosity $ msg -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout + hFlush stderr -- | A variant of 'debug' that doesn't perform the automatic line -- wrapping. Produces better output in some cases. @@ -522,10 +528,11 @@ debugNoWrap :: Verbosity -> String -> IO () debugNoWrap verbosity msg = withFrozenCallStack $ when (verbosity >= deafening) $ do ts <- getPOSIXTime - hPutStr stdout . withMetadata ts NeverMark FlagTrace verbosity + hFlush stdout + hPutStr stderr . withMetadata ts NeverMark FlagTrace verbosity $ msg -- ensure that we don't lose output if we segfault/infinite loop - hFlush stdout + hFlush stderr -- | Perform an IO action, catching any IO exceptions and printing an error -- if one occurs. @@ -533,8 +540,9 @@ chattyTry :: String -- ^ a description of the action we were attempting -> IO () -- ^ the action itself -> IO () chattyTry desc action = - catchIO action $ \exception -> - putStrLn $ "Error while " ++ desc ++ ": " ++ show exception + catchIO action $ \exception -> do + hFlush stdout + hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception -- | Run an IO computation, returning @e@ if it raises a "file -- does not exist" error. @@ -741,7 +749,7 @@ rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $ do debug verbosity $ path ++ " returned " ++ show exitcode exitWith exitcode --- Closes the passed in handles before returning. +-- Closes the passed in handles before returning (excluding standard handles). rawSystemIOWithEnv :: Verbosity -> FilePath -> [String] diff --git a/Cabal/Distribution/Utils/LogProgress.hs b/Cabal/Distribution/Utils/LogProgress.hs index 5ee2de833a0..2a5a03254c0 100644 --- a/Cabal/Distribution/Utils/LogProgress.hs +++ b/Cabal/Distribution/Utils/LogProgress.hs @@ -17,6 +17,7 @@ import Distribution.Utils.Progress import Distribution.Verbosity import Distribution.Simple.Utils import Text.PrettyPrint +import System.IO (hPutStrLn, stderr) type CtxMsg = Doc type LogMsg = Doc @@ -54,7 +55,7 @@ runLogProgress verbosity (LogProgress m) = } step_fn :: LogMsg -> NoCallStackIO a -> NoCallStackIO a step_fn doc go = do - putStrLn (render doc) + hPutStrLn stderr (render doc) go fail_fn :: Doc -> NoCallStackIO a fail_fn doc = do diff --git a/cabal-install/Distribution/Client/GenBounds.hs b/cabal-install/Distribution/Client/GenBounds.hs index 454a9cfad72..0cb8ac89a59 100644 --- a/cabal-install/Distribution/Client/GenBounds.hs +++ b/cabal-install/Distribution/Client/GenBounds.hs @@ -43,7 +43,7 @@ import Distribution.Simple.Compiler import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Utils - ( tryFindPackageDesc ) + ( notice, tryFindPackageDesc, warn ) import Distribution.System ( Platform ) import Distribution.Deprecated.Text @@ -120,13 +120,13 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo let epd = finalizePD mempty defaultComponentRequestedSpec (const True) platform cinfo [] gpd case epd of - Left _ -> putStrLn "finalizePD failed" + Left _ -> warn verbosity "finalizePD failed" Right (pd,_) -> do let needBounds = filter (not . hasUpperBound . depVersion) $ enabledBuildDepends pd defaultComponentRequestedSpec if (null needBounds) - then putStrLn + then notice verbosity "Congratulations, all your dependencies have upper bounds!" else go needBounds where @@ -135,7 +135,7 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags - putStrLn boundsNeededMsg + notice verbosity boundsNeededMsg let isNeeded pkg = unPackageName (packageName pkg) `elem` map depName needBounds diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 82f91e83a2d..73d7d878fa6 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -56,7 +56,7 @@ import System.Directory import System.FilePath ( (), (<.>), equalFilePath, takeDirectory ) import System.IO - ( openFile, IOMode(AppendMode), hClose ) + ( openFile, IOMode(AppendMode), hPutStr, hClose, stderr ) import System.IO.Error ( isDoesNotExistError, ioeGetFileName ) @@ -1230,11 +1230,11 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg = Nothing -> return () Just (mkLogFileName, _) -> do let logName = mkLogFileName pkgid uid - putStr $ "Build log ( " ++ logName ++ " ):\n" + hPutStr stderr $ "Build log ( " ++ logName ++ " ):\n" printFile logName printFile :: FilePath -> IO () - printFile path = readFile path >>= putStr + printFile path = readFile path >>= hPutStr stderr -- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ReadyPackage'. In particular the