diff --git a/Cabal/Distribution/Simple/Utils.hs b/Cabal/Distribution/Simple/Utils.hs index 96c8406b7d2b420d6297ef415696e1d2ddeddf97..05e5fb71c101296bfa41326729a21afdb744ec12 100644 --- a/Cabal/Distribution/Simple/Utils.hs +++ b/Cabal/Distribution/Simple/Utils.hs @@ -230,13 +230,14 @@ import System.IO.Unsafe import qualified Control.Exception as Exception import Foreign.C.Error (Errno (..), ePIPE) +import Data.Maybe (fromJust) import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime) import Control.Exception (IOException, evaluate, throwIO, fromException) import Numeric (showFFloat) import qualified System.Process as Process - ( CreateProcess(..), StdStream(..), proc) + ( CreateProcess(..), StdStream(..), proc, createProcess ) import System.Process - ( ProcessHandle, createProcess, rawSystem, runInteractiveProcess + ( CreateProcess, ProcessHandle , showCommandForUser, waitForProcess) import qualified GHC.IO.Exception as GHC @@ -680,6 +681,54 @@ maybeExit cmd = do res <- cmd unless (res == ExitSuccess) $ exitWith res +-- | Enable process jobs to ensure accurate determination of process completion +-- in the presence of @exec(3)@ on Windows. +-- +-- Unfortunately the process job support is badly broken in @process@ releases +-- prior to 1.6.8, so we disable it in these versions, despite the fact that +-- this means we may see sporatic build failures without jobs. +enableProcessJobs :: CreateProcess -> CreateProcess +#ifdef MIN_VERSION_process +#if MIN_VERSION_process(1,6,8) +enableProcessJobs cp = cp {Process.use_process_jobs = True} +#else +enableProcessJobs cp = cp +#endif +#else +enableProcessJobs cp = cp +#endif + +-- | 'System.Process.createProcess' with process jobs enabled when appropriate. +-- See 'enableProcessJobs'. +createProcess :: CreateProcess + -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) +createProcess = Process.createProcess . enableProcessJobs + +-- | 'System.Process.rawSystem' with process jobs enabled when appropriate. +-- See 'enableProcessJobs'. +rawSystem :: String -> [String] -> IO ExitCode +rawSystem cmd args = do + (_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True } + waitForProcess p + +-- | 'System.Process.runInteractiveProcess' with process jobs enabled when +-- appropriate. See 'enableProcessJobs'. +runInteractiveProcess + :: FilePath -- ^ Filename of the executable (see 'RawCommand' for details) + -> [String] -- ^ Arguments to pass to the executable + -> Maybe FilePath -- ^ Optional path to the working directory + -> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit) + -> IO (Handle,Handle,Handle,ProcessHandle) +runInteractiveProcess cmd args mb_cwd mb_env = do + (mb_in, mb_out, mb_err, p) <- + createProcess (Process.proc cmd args) + { Process.std_in = Process.CreatePipe, + Process.std_out = Process.CreatePipe, + Process.std_err = Process.CreatePipe, + Process.env = mb_env, + Process.cwd = mb_cwd } + return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p) + printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args = withFrozenCallStack $ printRawCommandAndArgsAndEnv verbosity path args Nothing Nothing