A dumber approach to reverting #7995 on 3.8 branch

Cabal/src/Distribution/Compat/Process.hs

@@ -1,12 +1,17 @@
 {-# LANGUAGE CPP #-}
 module Distribution.Compat.Process (
     -- * Redefined functions
-    proc,
+    createProcess,
+    runInteractiveProcess,
+    rawSystem,
     -- * Additions
     enableProcessJobs,
     ) where
 
-import           System.Process (CreateProcess)
+import System.Exit (ExitCode (..))
+import System.IO   (Handle)
+
+import           System.Process (CreateProcess, ProcessHandle, waitForProcess)
 import qualified System.Process as Process
 
 #if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
@@ -55,7 +60,35 @@ enableProcessJobs cp = cp
 -- process redefinitions
 -------------------------------------------------------------------------------
 
--- | 'System.Process.proc' with process jobs enabled when appropriate,
--- and defaulting 'delegate_ctlc' to 'True'.
-proc :: FilePath -> [String] -> CreateProcess
-proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True }
+-- | '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)
+  where
+    fromJust = maybe (error "runInteractiveProcess: fromJust") id

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

@@ -41,8 +41,7 @@ import System.Directory
     , setCurrentDirectory )
 import System.FilePath ( (</>), (<.>) )
 import System.IO ( hClose, hPutStr )
-import Distribution.Compat.Process (proc)
-import qualified System.Process as Process
+import System.Process (StdStream(..), createPipe, waitForProcess)
 
 runTest :: PD.PackageDescription
         -> LBI.LocalBuildInfo
@@ -79,48 +78,49 @@ runTest pkg_descr lbi clbi flags suite = do
 
     suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
 
-        -- Run test executable
-        let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
-            dataDirPath = pwd </> PD.dataDir pkg_descr
-            tixFile = pwd </> tixFilePath distPref way testName'
-            pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
-                       : existingEnv
-            shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
-                     ++ pkgPathEnv
-        -- Add (DY)LD_LIBRARY_PATH if needed
-        shellEnv' <-
-          if LBI.withDynExe lbi
-          then do
-            let (Platform _ os) = LBI.hostPlatform lbi
-            paths <- LBI.depLibraryPaths True False lbi clbi
-            cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
-            return (addLibraryPath os (cpath : paths) shellEnv)
-          else return shellEnv
-        let (cmd', opts') = case testWrapper flags of
-                              Flag path -> (path, cmd:opts)
-                              NoFlag -> (cmd, opts)
-
         -- TODO: this setup is broken,
         -- if the test output is too big, we will deadlock.
-        (rOut, wOut) <- Process.createPipe
-        (exitcode, logText) <- rawSystemProcAction verbosity
-            (proc cmd' opts') { Process.env           = Just shellEnv'
-                              , Process.std_in        = Process.CreatePipe
-                              , Process.std_out       = Process.UseHandle wOut
-                              , Process.std_err       = Process.UseHandle wOut
-                              } $ \mIn _ _ -> do
-          let wIn = fromCreatePipe mIn
-          hPutStr wIn $ show (tempLog, PD.testName suite)
-          hClose wIn
-
-          -- Append contents of temporary log file to the final human-
-          -- readable log file
-          logText <- LBS.hGetContents rOut
-          -- Force the IO manager to drain the test output pipe
-          _ <- evaluate (force logText)
-          return logText
-        unless (exitcode == ExitSuccess) $
-          debug verbosity $ cmd ++ " returned " ++ show exitcode
+        (rOut, wOut) <- createPipe
+
+        -- Run test executable
+        (Just wIn, _, _, process) <- do
+                let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
+                    dataDirPath = pwd </> PD.dataDir pkg_descr
+                    tixFile = pwd </> tixFilePath distPref way testName'
+                    pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
+                               : existingEnv
+                    shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
+                             ++ pkgPathEnv
+                -- Add (DY)LD_LIBRARY_PATH if needed
+                shellEnv' <-
+                  if LBI.withDynExe lbi
+                  then do
+                    let (Platform _ os) = LBI.hostPlatform lbi
+                    paths <- LBI.depLibraryPaths True False lbi clbi
+                    cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
+                    return (addLibraryPath os (cpath : paths) shellEnv)
+                  else return shellEnv
+                case testWrapper flags of
+                  Flag path -> createProcessWithEnv verbosity path (cmd:opts) Nothing (Just shellEnv')
+                               -- these handles are closed automatically
+                               CreatePipe (UseHandle wOut) (UseHandle wOut)
+
+                  NoFlag -> createProcessWithEnv verbosity cmd opts Nothing (Just shellEnv')
+                            -- these handles are closed automatically
+                            CreatePipe (UseHandle wOut) (UseHandle wOut)
+
+        hPutStr wIn $ show (tempLog, PD.testName suite)
+        hClose wIn
+
+        -- Append contents of temporary log file to the final human-
+        -- readable log file
+        logText <- LBS.hGetContents rOut
+        -- Force the IO manager to drain the test output pipe
+        _ <- evaluate (force logText)
+
+        exitcode <- waitForProcess process
+        unless (exitcode == ExitSuccess) $ do
+            debug verbosity $ cmd ++ " returned " ++ show exitcode
 
         -- Generate final log file name
         let finalLogName l = testLogDir