{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_HADDOCK show-extensions #-}
module ToySolver.Internal.ProcessUtil
( runProcessWithOutputCallback
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception (SomeException, try, mask, throwIO)
import qualified Control.Exception as C
import Control.Monad
import Foreign.C
import System.Exit
import System.IO
import System.IO.Error
import System.Process
#ifdef __GLASGOW_HASKELL__
import GHC.IO.Exception ( IOErrorType(..), IOException(..) )
#endif
runProcessWithOutputCallback
:: FilePath
-> [String]
-> String
-> (String -> IO ())
-> (String -> IO ())
-> IO ExitCode
runProcessWithOutputCallback :: FilePath
-> [FilePath]
-> FilePath
-> (FilePath -> IO ())
-> (FilePath -> IO ())
-> IO ExitCode
runProcessWithOutputCallback FilePath
cmd [FilePath]
args FilePath
input FilePath -> IO ()
putMsg FilePath -> IO ()
putErr = do
(Just Handle
inh, Just Handle
outh, Just Handle
errh, ProcessHandle
processh) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess
(FilePath -> [FilePath] -> CreateProcess
proc FilePath
cmd [FilePath]
args)
{ std_in :: StdStream
std_in = StdStream
CreatePipe
, std_out :: StdStream
std_out = StdStream
CreatePipe
, std_err :: StdStream
std_err = StdStream
CreatePipe
}
TMVar (IO ())
req <- forall a. IO (TMVar a)
newEmptyTMVarIO
let f :: IO () -> IO ()
f IO ()
act = forall a. STM a -> IO a
atomically (forall a. TMVar a -> a -> STM ()
putTMVar TMVar (IO ())
req IO ()
act)
m1 :: IO ()
m1 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Handle -> IO FilePath
hGetLine Handle
outh forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
s -> IO () -> IO ()
f (FilePath -> IO ()
putMsg FilePath
s))
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIOError` (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall a. IOException -> IO a
ioError IOException
e)
m2 :: IO ()
m2 = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (Handle -> IO FilePath
hGetLine Handle
errh forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \FilePath
s -> IO () -> IO ()
f (FilePath -> IO ()
putErr FilePath
s))
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIOError` (\IOException
e -> if IOException -> Bool
isEOFError IOException
e then forall (m :: * -> *) a. Monad m => a -> m a
return () else forall a. IOException -> IO a
ioError IOException
e)
forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
m1 forall a b. (a -> b) -> a -> b
$ \STM ()
waitOut -> do
forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
m2 forall a b. (a -> b) -> a -> b
$ \STM ()
waitErr -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
input) forall a b. (a -> b) -> a -> b
$
IO () -> IO ()
ignoreSigPipe forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStr Handle
inh FilePath
input
IO () -> IO ()
ignoreSigPipe forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
inh
Handle -> BufferMode -> IO ()
hSetBuffering Handle
outh BufferMode
LineBuffering
Handle -> BufferMode -> IO ()
hSetBuffering Handle
errh BufferMode
LineBuffering
let loop :: IO ()
loop = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$
[ do IO ()
act <- forall a. TMVar a -> STM a
takeTMVar TMVar (IO ())
req
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IO ()
act forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
, do forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. TMVar a -> STM Bool
isEmptyTMVar TMVar (IO ())
req
STM ()
waitOut
STM ()
waitErr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
]
IO ()
loop
Handle -> IO ()
hClose Handle
outh
Handle -> IO ()
hClose Handle
errh
ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processh
withForkWait :: IO () -> (STM () -> IO a) -> IO a
withForkWait :: forall a. IO () -> (STM () -> IO a) -> IO a
withForkWait IO ()
async STM () -> IO a
body = do
TMVar (Either SomeException ())
waitVar <- forall a. IO (TMVar a)
newEmptyTMVarIO :: IO (TMVar (Either SomeException ()))
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
ThreadId
tid <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. IO a -> IO a
restore IO ()
async) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either SomeException ()
v -> forall a. STM a -> IO a
atomically (forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Either SomeException ())
waitVar Either SomeException ()
v)
let wait :: STM ()
wait = forall a. TMVar a -> STM a
takeTMVar TMVar (Either SomeException ())
waitVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> STM a
throwSTM forall (m :: * -> *) a. Monad m => a -> m a
return
forall a. IO a -> IO a
restore (STM () -> IO a
body STM ()
wait) forall a b. IO a -> IO b -> IO a
`C.onException` ThreadId -> IO ()
killThread ThreadId
tid
ignoreSigPipe :: IO () -> IO ()
#if defined(__GLASGOW_HASKELL__)
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
C.handle forall a b. (a -> b) -> a -> b
$ \IOException
e -> case IOException
e of
IOError { ioe_type :: IOException -> IOErrorType
ioe_type = IOErrorType
ResourceVanished
, ioe_errno :: IOException -> Maybe CInt
ioe_errno = Just CInt
ioe }
| CInt -> Errno
Errno CInt
ioe forall a. Eq a => a -> a -> Bool
== Errno
ePIPE -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
IOException
_ -> forall e a. Exception e => e -> IO a
throwIO IOException
e
#else
ignoreSigPipe = id
#endif