waitForProcess bug

Main.hs

module Main where

import System.Process
import Control.Concurrent

main :: IO ()
main = do
  (_, _, _, p) <- createProcess ((shell "sleep 1") { create_group = True })
  forkIO $ waitForProcess p >>= print
  threadDelay 10
  -- interruptProcessGroupOf p
  waitForProcess p >>= print
  putStrLn "Success!"

Safe.hs

-- 'Safe' version
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import System.Process
import Control.Concurrent
import Control.Exception
import System.Exit

waitForProcessSafe :: ProcessHandle -> IO ExitCode
waitForProcessSafe p = waitForProcess p
  `catch` (\(e :: IOError) -> do
  threadDelay 1 -- give the other thread enough time to acquire the lock
  waitForProcess p)

main :: IO ()
main = do
  (_, _, _, p) <- createProcess ((shell "sleep 1") { create_group = True })
  forkIO $ waitForProcessSafe p >>= print
  threadDelay 10
  -- interruptProcessGroupOf p
  waitForProcessSafe p >>= print
  putStrLn "Success!"