From 9e8431d5dd4d0054969a889eef54ae589ab5e1a1 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 | 9 +++-- cabal-install/Distribution/Client/Install.hs | 6 ++-- 6 files changed, 46 insertions(+), 26 deletions(-) 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..496c9fa9c92 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 + 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..805d92b19b6 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -222,8 +222,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 ) @@ -466,7 +466,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 +478,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 +488,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 +507,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 +516,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 +528,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 +541,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 +553,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. @@ -754,7 +762,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..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 diff --git a/cabal-install/Distribution/Client/GenBounds.hs b/cabal-install/Distribution/Client/GenBounds.hs index a806d4082cc..eac67ce1d1b 100644 --- a/cabal-install/Distribution/Client/GenBounds.hs +++ b/cabal-install/Distribution/Client/GenBounds.hs @@ -52,6 +52,8 @@ import Distribution.Version , orLaterVersion, earlierVersion, intersectVersionRanges ) import System.Directory ( getCurrentDirectory ) +import System.IO + ( hPutStrLn, hFlush, stderr ) -- | Does this version range have an upper bound? hasUpperBound :: VersionRange -> Bool @@ -116,13 +118,13 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo let epd = finalizePD [] defaultComponentRequestedSpec (const True) platform cinfo [] gpd case epd of - Left _ -> putStrLn "finalizePD failed" + Left _ -> hPutStrLn stderr "finalizePD failed" Right (pd,_) -> do let needBounds = filter (not . hasUpperBound . depVersion) $ buildDepends pd if (null needBounds) - then putStrLn + then hPutStrLn stderr "Congratulations, all your dependencies have upper bounds!" else go needBounds where @@ -131,7 +133,8 @@ genBounds verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo verbosity packageDBs repoCtxt comp platform progdb mSandboxPkgInfo globalFlags freezeFlags - putStrLn boundsNeededMsg + hPutStrLn stderr boundsNeededMsg + hFlush stderr 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 2832e379fa8..c100a36d2bb 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 ) @@ -1206,11 +1206,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