Skip to content

Commit ba8db78

Browse files
MikolajMikolaj
authored
Merge pull request #8321 from Mikolaj/revert-7995-and-7921
Temporarily revert #7995 and #7921 due to #8208
2 parents 240f1c6 + d038dc8 commit ba8db78

File tree

20 files changed

+386
-449
lines changed

20 files changed

+386
-449
lines changed

‎Cabal/src/Distribution/Compat/Process.hs

Lines changed: 39 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,17 @@
11
{-# LANGUAGE CPP #-}
22
module Distribution.Compat.Process (
33
-- * Redefined functions
4-
proc,
4+
createProcess,
5+
runInteractiveProcess,
6+
rawSystem,
57
-- * Additions
68
enableProcessJobs,
79
) where
810

9-
import System.Process (CreateProcess)
11+
import System.Exit (ExitCode (..))
12+
import System.IO (Handle)
13+
14+
import System.Process (CreateProcess, ProcessHandle, waitForProcess)
1015
import qualified System.Process as Process
1116

1217
#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
@@ -55,7 +60,35 @@ enableProcessJobs cp = cp
5560
-- process redefinitions
5661
-------------------------------------------------------------------------------
5762

58-
-- | 'System.Process.proc' with process jobs enabled when appropriate,
59-
-- and defaulting 'delegate_ctlc' to 'True'.
60-
proc :: FilePath -> [String] -> CreateProcess
61-
proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True }
63+
-- | 'System.Process.createProcess' with process jobs enabled when appropriate.
64+
-- See 'enableProcessJobs'.
65+
createProcess :: CreateProcess
66+
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
67+
createProcess = Process.createProcess . enableProcessJobs
68+
69+
-- | 'System.Process.rawSystem' with process jobs enabled when appropriate.
70+
-- See 'enableProcessJobs'.
71+
rawSystem :: String -> [String] -> IO ExitCode
72+
rawSystem cmd args = do
73+
(_,_,_,p) <- createProcess (Process.proc cmd args) { Process.delegate_ctlc = True }
74+
waitForProcess p
75+
76+
-- | 'System.Process.runInteractiveProcess' with process jobs enabled when
77+
-- appropriate. See 'enableProcessJobs'.
78+
runInteractiveProcess
79+
:: FilePath -- ^ Filename of the executable (see 'RawCommand' for details)
80+
-> [String] -- ^ Arguments to pass to the executable
81+
-> Maybe FilePath -- ^ Optional path to the working directory
82+
-> Maybe [(String,String)] -- ^ Optional environment (otherwise inherit)
83+
-> IO (Handle,Handle,Handle,ProcessHandle)
84+
runInteractiveProcess cmd args mb_cwd mb_env = do
85+
(mb_in, mb_out, mb_err, p) <-
86+
createProcess (Process.proc cmd args)
87+
{ Process.std_in = Process.CreatePipe,
88+
Process.std_out = Process.CreatePipe,
89+
Process.std_err = Process.CreatePipe,
90+
Process.env = mb_env,
91+
Process.cwd = mb_cwd }
92+
return (fromJust mb_in, fromJust mb_out, fromJust mb_err, p)
93+
where
94+
fromJust = maybe (error "runInteractiveProcess: fromJust") id

‎Cabal/src/Distribution/Simple/Program/Run.hs

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -124,10 +124,12 @@ runProgramInvocation verbosity
124124
} = do
125125
pathOverride <- getExtraPathEnv envOverrides extraPath
126126
menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
127-
maybeExit $ rawSystemIOWithEnv verbosity
127+
exitCode <- rawSystemIOWithEnv verbosity
128128
path args
129129
mcwd menv
130130
Nothing Nothing Nothing
131+
when (exitCode /= ExitSuccess) $
132+
exitWith exitCode
131133

132134
runProgramInvocation verbosity
133135
ProgramInvocation {

‎Cabal/src/Distribution/Simple/Test/LibV09.hs

Lines changed: 42 additions & 42 deletions
Original file line numberDiff line numberDiff line change
@@ -41,8 +41,7 @@ import System.Directory
4141
, setCurrentDirectory )
4242
import System.FilePath ( (</>), (<.>) )
4343
import System.IO ( hClose, hPutStr )
44-
import Distribution.Compat.Process (proc)
45-
import qualified System.Process as Process
44+
import System.Process (StdStream(..), createPipe, waitForProcess)
4645

4746
runTest :: PD.PackageDescription
4847
-> LBI.LocalBuildInfo
@@ -79,48 +78,49 @@ runTest pkg_descr lbi clbi flags suite = do
7978

8079
suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
8180

82-
-- Run test executable
83-
let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
84-
dataDirPath = pwd </> PD.dataDir pkg_descr
85-
tixFile = pwd </> tixFilePath distPref way testName'
86-
pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
87-
: existingEnv
88-
shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
89-
++ pkgPathEnv
90-
-- Add (DY)LD_LIBRARY_PATH if needed
91-
shellEnv' <-
92-
if LBI.withDynExe lbi
93-
then do
94-
let (Platform _ os) = LBI.hostPlatform lbi
95-
paths <- LBI.depLibraryPaths True False lbi clbi
96-
cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
97-
return (addLibraryPath os (cpath : paths) shellEnv)
98-
else return shellEnv
99-
let (cmd', opts') = case testWrapper flags of
100-
Flag path -> (path, cmd:opts)
101-
NoFlag -> (cmd, opts)
102-
10381
-- TODO: this setup is broken,
10482
-- if the test output is too big, we will deadlock.
105-
(rOut, wOut) <- Process.createPipe
106-
(exitcode, logText) <- rawSystemProcAction verbosity
107-
(proc cmd' opts') { Process.env = Just shellEnv'
108-
, Process.std_in = Process.CreatePipe
109-
, Process.std_out = Process.UseHandle wOut
110-
, Process.std_err = Process.UseHandle wOut
111-
} $ \mIn _ _ -> do
112-
let wIn = fromCreatePipe mIn
113-
hPutStr wIn $ show (tempLog, PD.testName suite)
114-
hClose wIn
115-
116-
-- Append contents of temporary log file to the final human-
117-
-- readable log file
118-
logText <- LBS.hGetContents rOut
119-
-- Force the IO manager to drain the test output pipe
120-
_ <- evaluate (force logText)
121-
return logText
122-
unless (exitcode == ExitSuccess) $
123-
debug verbosity $ cmd ++ " returned " ++ show exitcode
83+
(rOut, wOut) <- createPipe
84+
85+
-- Run test executable
86+
(Just wIn, _, _, process) <- do
87+
let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
88+
dataDirPath = pwd </> PD.dataDir pkg_descr
89+
tixFile = pwd </> tixFilePath distPref way testName'
90+
pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
91+
: existingEnv
92+
shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
93+
++ pkgPathEnv
94+
-- Add (DY)LD_LIBRARY_PATH if needed
95+
shellEnv' <-
96+
if LBI.withDynExe lbi
97+
then do
98+
let (Platform _ os) = LBI.hostPlatform lbi
99+
paths <- LBI.depLibraryPaths True False lbi clbi
100+
cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
101+
return (addLibraryPath os (cpath : paths) shellEnv)
102+
else return shellEnv
103+
case testWrapper flags of
104+
Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv')
105+
-- these handles are closed automatically
106+
CreatePipe (UseHandle wOut) (UseHandle wOut)
107+
108+
NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')
109+
-- these handles are closed automatically
110+
CreatePipe (UseHandle wOut) (UseHandle wOut)
111+
112+
hPutStr wIn $ show (tempLog, PD.testName suite)
113+
hClose wIn
114+
115+
-- Append contents of temporary log file to the final human-
116+
-- readable log file
117+
logText <- LBS.hGetContents rOut
118+
-- Force the IO manager to drain the test output pipe
119+
_ <- evaluate (force logText)
120+
121+
exitcode <- waitForProcess process
122+
unless (exitcode == ExitSuccess) $ do
123+
debug verbosity $ cmd ++ " returned " ++ show exitcode
124124

125125
-- Generate final log file name
126126
let finalLogName l = testLogDir

0 commit comments

Comments
 (0)