From a2ac4dc50830e0df60954d2b4ef409b5d444047d Mon Sep 17 00:00:00 2001 From: Phil Ruffwind Date: Fri, 22 Sep 2017 20:57:06 -0400 Subject: [PATCH] Use stderr for Cabal's diagnostic messages instead of stdout Send all diagnostic messages (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/Cabal.cabal | 2 +- Cabal/Distribution/Simple/Program/GHC.hs | 3 +- Cabal/Distribution/Simple/Program/Run.hs | 21 ++++--- Cabal/Distribution/Simple/Utils.hs | 79 ++++++++++++++++++------ Cabal/Distribution/Utils/LogProgress.hs | 3 +- 5 files changed, 78 insertions(+), 30 deletions(-) diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index f924753edba..9b5d559bbfa 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -85,7 +85,7 @@ library deepseq >= 1.3 && < 1.5, filepath >= 1.3 && < 1.5, pretty >= 1.1 && < 1.2, - process >= 1.1.0.1 && < 1.7, + process >= 1.2.1.0 && < 1.7, time >= 1.4 && < 1.9 if flag(old-directory) diff --git a/Cabal/Distribution/Simple/Program/GHC.hs b/Cabal/Distribution/Simple/Program/GHC.hs index d13de0ca536..f7e6a679481 100644 --- a/Cabal/Distribution/Simple/Program/GHC.hs +++ b/Cabal/Distribution/Simple/Program/GHC.hs @@ -281,7 +281,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 6b1d7d02e69..8e4330a474f 100644 --- a/Cabal/Distribution/Simple/Program/Run.hs +++ b/Cabal/Distribution/Simple/Program/Run.hs @@ -37,6 +37,7 @@ import Distribution.Compat.Environment import qualified Data.Map as Map import System.FilePath +import System.IO ( stderr ) import System.Exit ( ExitCode(..), exitWith ) @@ -56,7 +57,8 @@ data ProgramInvocation = ProgramInvocation { progInvokeCwd :: Maybe FilePath, progInvokeInput :: Maybe String, progInvokeInputEncoding :: IOEncoding, - progInvokeOutputEncoding :: IOEncoding + progInvokeOutputEncoding :: IOEncoding, + progInvokeOutAsErr :: Bool } data IOEncoding = IOEncodingText -- locale mode text @@ -76,7 +78,8 @@ emptyProgramInvocation = progInvokeCwd = Nothing, progInvokeInput = Nothing, progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText + progInvokeOutputEncoding = IOEncodingText, + progInvokeOutAsErr = False } simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation @@ -116,16 +119,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 + exitCode <- rawSystemIOWithEnv_ False verbosity + path args + mcwd menv + 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 c344e5e0b1f..9714736d46a 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -51,7 +51,9 @@ module Distribution.Simple.Utils ( rawSystemStdout, rawSystemStdInOut, rawSystemIOWithEnv, + rawSystemIOWithEnv_, createProcessWithEnv, + createProcessWithEnv_, maybeExit, xargs, findProgramLocation, @@ -222,8 +224,8 @@ import System.FilePath , splitExtension, splitExtensions, 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 ) @@ -236,8 +238,8 @@ import Numeric (showFFloat) import qualified System.Process as Process ( CreateProcess(..), StdStream(..), proc) import System.Process - ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess - , showCommandForUser, waitForProcess) + ( ProcessHandle, createProcess, createProcess_, rawSystem + , runInteractiveProcess, showCommandForUser, waitForProcess) import qualified Text.PrettyPrint as Disp @@ -466,7 +468,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 @@ -477,7 +480,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. @@ -486,7 +490,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' @@ -504,7 +509,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 @@ -512,7 +518,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 @@ -523,11 +530,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. @@ -535,10 +543,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. @@ -546,8 +555,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. @@ -764,9 +774,21 @@ rawSystemIOWithEnv :: Verbosity -> Maybe Handle -- ^ stdout -> Maybe Handle -- ^ stderr -> IO ExitCode -rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do - (_,_,_,ph) <- createProcessWithEnv verbosity path args mcwd menv - (mbToStd inp) (mbToStd out) (mbToStd err) +rawSystemIOWithEnv = rawSystemIOWithEnv_ True + +rawSystemIOWithEnv_ :: Bool -- ^ whether to close the provided handles + -> Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Maybe Handle -- ^ stdin + -> Maybe Handle -- ^ stdout + -> Maybe Handle -- ^ stderr + -> IO ExitCode +rawSystemIOWithEnv_ close verbosity path args mcwd menv inp out err = withFrozenCallStack $ do + (_,_,_,ph) <- createProcessWithEnv_ close verbosity path args mcwd menv + (mbToStd inp) (mbToStd out) (mbToStd err) exitcode <- waitForProcess ph unless (exitcode == ExitSuccess) $ do debug verbosity $ path ++ " returned " ++ show exitcode @@ -787,10 +809,27 @@ createProcessWithEnv :: -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle) -- ^ Any handles created for stdin, stdout, or stderr -- with 'CreateProcess', and a handle to the process. -createProcessWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do +createProcessWithEnv = createProcessWithEnv_ True + +createProcessWithEnv_ :: + Bool -- ^ whether to close the provided handles + -> Verbosity + -> FilePath + -> [String] + -> Maybe FilePath -- ^ New working dir or inherit + -> Maybe [(String, String)] -- ^ New environment or inherit + -> Process.StdStream -- ^ stdin + -> Process.StdStream -- ^ stdout + -> Process.StdStream -- ^ stderr + -> IO (Maybe Handle, Maybe Handle, Maybe Handle,ProcessHandle) + -- ^ Any handles created for stdin, stdout, or stderr + -- with 'CreateProcess', and a handle to the process. +createProcessWithEnv_ close verbosity path args mcwd menv inp out err = withFrozenCallStack $ do printRawCommandAndArgsAndEnv verbosity path args mcwd menv hFlush stdout - (inp', out', err', ph) <- createProcess $ + (inp', out', err', ph) <- (if close + then createProcess + else createProcess_ "createProcess_") (Process.proc path args) { Process.cwd = mcwd , Process.env = menv diff --git a/Cabal/Distribution/Utils/LogProgress.hs b/Cabal/Distribution/Utils/LogProgress.hs index 5ee2de833a0..d974c20f557 100644 --- a/Cabal/Distribution/Utils/LogProgress.hs +++ b/Cabal/Distribution/Utils/LogProgress.hs @@ -16,6 +16,7 @@ import Distribution.Compat.Prelude import Distribution.Utils.Progress import Distribution.Verbosity import Distribution.Simple.Utils +import System.IO ( stderr, hPutStrLn ) import Text.PrettyPrint type CtxMsg = 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