[commit: packages/process] master: GH77: Replaced system and rawSystem (f6de652)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/process

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f6de6523e27c42ad8e92a375239dbfe8772e2b7e/process

>---------------------------------------------------------------

commit f6de6523e27c42ad8e92a375239dbfe8772e2b7e
Author: Tamar Christina <tamar at zhox.com>
Date:   Sun Dec 4 17:20:45 2016 +0000

    GH77: Replaced system and rawSystem


>---------------------------------------------------------------

f6de6523e27c42ad8e92a375239dbfe8772e2b7e
 System/Process.hs           | 25 ++++++++++++++++++++-----
 System/Process/Internals.hs | 33 ++++++++++++++++++++++++++++++++-
 2 files changed, 52 insertions(+), 6 deletions(-)

diff --git a/System/Process.hs b/System/Process.hs
index 0fc3445..44a4362 100644
--- a/System/Process.hs
+++ b/System/Process.hs
@@ -43,6 +43,7 @@ module System.Process (
     readCreateProcessWithExitCode,
     readProcessWithExitCode,
     withCreateProcess,
+    executeAndWait,
 
     -- ** Related utilities
     showCommandForUser,
@@ -852,9 +853,7 @@ when the process died as the result of a signal.
 -}
 system :: String -> IO ExitCode
 system "" = ioException (ioeSetErrorString (mkIOError InvalidArgument "system" Nothing Nothing) "null command")
-system str = do
-  (_,_,_,p) <- createProcess_ "system" (shell str) { delegate_ctlc = True }
-  waitForProcess p
+system str = executeAndWait "system" (shell str) { delegate_ctlc = True }
 
 
 --TODO: in a later release {-# DEPRECATED rawSystem "Use 'callProcess' (or 'spawnProcess' and 'waitForProcess') instead" #-}
@@ -868,6 +867,22 @@ It will therefore behave more portably between operating systems than 'system'.
 The return codes and possible failures are the same as for 'system'.
 -}
 rawSystem :: String -> [String] -> IO ExitCode
-rawSystem cmd args = do
-  (_,_,_,p) <- createProcess_ "rawSystem" (proc cmd args) { delegate_ctlc = True }
+rawSystem cmd args = executeAndWait "rawSystem" (proc cmd args) { delegate_ctlc = True }
+
+-- ---------------------------------------------------------------------------
+-- executeAndWait
+
+-- | Create a new process and wait for it's termination.
+--
+-- @since 1.4.?.?
+executeAndWait :: String -> CreateProcess -> IO ExitCode
+executeAndWait name proc_ = do
+#if defined(WINDOWS)
+  (_,_,_,_,Just job,Just iocp) <- createProcessExt_ name True proc_
+  maybe (ExitFailure (-1)) mkExitCode <$> waitForJobCompletion job iocp (-1)
+    where mkExitCode code | code == 0 = ExitSuccess
+                          | otherwise = ExitFailure $ fromIntegral code
+#else
+  (_,_,_,p) <- createProcess_ name proc_
   waitForProcess p
+#endif
\ No newline at end of file
diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs
index fad7c92..1ee8f5c 100644
--- a/System/Process/Internals.hs
+++ b/System/Process/Internals.hs
@@ -43,6 +43,7 @@ module System.Process.Internals (
     createPipe,
     createPipeFd,
     interruptProcessGroupOf,
+    createProcessExt_,
     ) where
 
 import Foreign.C
@@ -60,7 +61,6 @@ import System.Process.Posix
 #endif
 
 -- ----------------------------------------------------------------------------
-
 -- | This function is almost identical to
 -- 'System.Process.createProcess'. The only differences are:
 --
@@ -81,6 +81,37 @@ createProcess_
 createProcess_ = createProcess_Internal
 {-# INLINE createProcess_ #-}
 
+-- ----------------------------------------------------------------------------
+-- | This function is almost identical to
+-- 'createProcess_'. The only differences are:
+--
+-- * A boolean argument can be given in order to create an I/O cp port to monitor
+--   a process tree's progress on Windows.
+--
+-- The function also returns two new handles:
+--   * an I/O Completion Port handle on which events
+--     will be signaled.
+--   * a Job handle which can be used to kill all running
+--     processes.
+--
+--  On POSIX platforms these two new handles will always be Nothing
+--
+-- @since 1.4.?.?
+createProcessExt_
+  :: String   -- ^ function name (for error messages)
+  -> Bool     -- ^ Use I/O CP port for monitoring
+  -> CreateProcess
+  -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle,
+         Maybe ProcessHandle, Maybe ProcessHandle)
+#ifdef WINDOWS
+createProcessExt_ = createProcess_Internal_ext
+#else
+createProcessExt_ name _ proc_ 
+  = do (hndStdInput, hndStdOutput, hndStdError, ph) <- createProcess_ nme proc_
+        return ((hndStdInput, hndStdOutput, hndStdError, ph, Nothing, Nothing)
+#endif
+{-# INLINE createProcessExt_ #-}
+
 -- ------------------------------------------------------------------------
 -- Escaping commands for shells