[commit: packages/process] master: GH77: Fixed compilation (8080309)

[git at git.haskell.org]

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

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

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

commit 80803096e76ee580bd255b5e9acc11ede2ed2690
Author: Tamar Christina <tamar at zhox.com>
Date:   Sun Dec 4 08:15:39 2016 +0000

    GH77: Fixed compilation


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

80803096e76ee580bd255b5e9acc11ede2ed2690
 System/Process/Windows.hsc | 26 ++++++++++++++------------
 cbits/runProcess.c         | 12 +++++++++---
 changelog.md               |  1 +
 3 files changed, 24 insertions(+), 15 deletions(-)

diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc
index 6347dad..c1294fa 100644
--- a/System/Process/Windows.hsc
+++ b/System/Process/Windows.hsc
@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+{-# LANGUAGE InterruptibleFFI #-}
 module System.Process.Windows
     ( mkProcessHandle
     , translateInternal
@@ -57,7 +58,7 @@ mkProcessHandle h = do
 mkProcessHandle' :: PHANDLE -> IO (Maybe ProcessHandle)
 mkProcessHandle' h = do
   if h /= nullPtr
-     then return $ Just $ mkProcessHandle h
+     then Just <$> mkProcessHandle h
      else return $ Nothing
 
 processHandleFinaliser :: MVar ProcessHandle__ -> IO ()
@@ -90,8 +91,8 @@ createProcess_Internal
   -> IO (Maybe Handle, Maybe Handle,
          Maybe Handle, ProcessHandle)
 createProcess_Internal fun cp
- = let (hndStdInput, hndStdOutput, hndStdError, ph, _, _) = createProcess_Internal_ext fun cp
-   in return (hndStdInput, hndStdOutput, hndStdError, ph)
+ = do (hndStdInput, hndStdOutput, hndStdError, ph, _, _) <- createProcess_Internal_ext fun False cp
+      return (hndStdInput, hndStdOutput, hndStdError, ph)
 
 createProcess_Internal_ext
   :: String                     -- ^ function name (for error messages)
@@ -101,7 +102,7 @@ createProcess_Internal_ext
          Maybe Handle, ProcessHandle,
          Maybe ProcessHandle, Maybe ProcessHandle)
 
-createProcess_Internal fun useJob CreateProcess{ cmdspec = cmdsp,
+createProcess_Internal_ext fun useJob CreateProcess{ cmdspec = cmdsp,
                                     cwd = mb_cwd,
                                     env = mb_env,
                                     std_in = mb_stdin,
@@ -114,13 +115,14 @@ createProcess_Internal fun useJob CreateProcess{ cmdspec = cmdsp,
                                     create_new_console = mb_create_new_console,
                                     new_session = mb_new_session }
  = do
+  let lenPtr = sizeOf (undefined :: WordPtr)
   (cmd, cmdline) <- commandToProcess cmdsp
   withFilePathException cmd $
-   alloca $ \ pfdStdInput  ->
-   alloca $ \ pfdStdOutput ->
-   alloca $ \ pfdStdError  ->
-   alloca $ \ hJob         ->
-   alloca $ \ hIOcpPort    ->
+   alloca $ \ pfdStdInput           ->
+   alloca $ \ pfdStdOutput          ->
+   alloca $ \ pfdStdError           ->
+   allocaBytes lenPtr $ \ hJob      ->
+   allocaBytes lenPtr $ \ hIOcpPort ->
    maybeWith withCEnvironment mb_env $ \pEnv ->
    maybeWith withCWString mb_cwd $ \pWorkDir -> do
    withCWString cmdline $ \pcmdline -> do
@@ -160,7 +162,7 @@ createProcess_Internal fun useJob CreateProcess{ cmdspec = cmdsp,
      ph     <- mkProcessHandle proc_handle
      phJob  <- mkProcessHandle' hJob
      phIOCP <- mkProcessHandle' hIOcpPort
-     return (hndStdInput, hndStdOutput, hndStdError, ph)
+     return (hndStdInput, hndStdOutput, hndStdError, ph, phJob, phIOCP)
 
 {-# NOINLINE runInteractiveProcess_lock #-}
 runInteractiveProcess_lock :: MVar ()
@@ -192,7 +194,7 @@ foreign import ccall unsafe "terminateJob"
 foreign import ccall interruptible "waitForJobCompletion" -- NB. safe - can block
   c_waitForJobCompletion
         :: PHANDLE
-        :: PHANDLE
+        -> PHANDLE
         -> CInt
         -> Ptr CInt
         -> IO CInt
diff --git a/cbits/runProcess.c b/cbits/runProcess.c
index b8feecf..b60bf07 100644
--- a/cbits/runProcess.c
+++ b/cbits/runProcess.c
@@ -520,8 +520,14 @@ createJob ()
     // Last process in the job terminates. This prevent half dead processes.
     jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE;
 
-    return SetInformationJobObject(hJob, JobObjectExtendedLimitInformation,
-        &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION));
+    if (SetInformationJobObject (hJob, JobObjectExtendedLimitInformation,
+                                 &jeli, sizeof(JOBOBJECT_EXTENDED_LIMIT_INFORMATION)))
+    {
+        return hJob;
+    }
+
+    maperrno();
+    return NULL;
 }
 
 static HANDLE
@@ -782,7 +788,7 @@ waitForProcess (ProcHandle handle, int *pret)
     return -1;
 }
 
-static int
+int
 waitForJobCompletion (HANDLE hJob, HANDLE ioPort, DWORD timeout, int *pExitCode)
 {
     DWORD CompletionCode;
diff --git a/changelog.md b/changelog.md
index 73c1814..a8e7738 100644
--- a/changelog.md
+++ b/changelog.md
@@ -10,6 +10,7 @@
 
 * New exposed `withCreateProcess`
 * Derive `Show` and `Eq` for `CreateProcess`, `CmdSpec`, and `StdStream`
+* Add support for monitoring process tree for termination with `...`
 
 ## 1.4.2.0 *January 2016*