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