{-# LANGUAGE RankNTypes #-}
module System.Process.Machine where

import Data.Machine
import Data.IOData (IOData)
import System.Exit (ExitCode(..))
import System.IO.Machine
import System.Process (CreateProcess(..), ProcessHandle, createProcess, waitForProcess)

type ProcessMachines a b k = (Maybe (ProcessT IO a b), Maybe (MachineT IO k a), Maybe (MachineT IO k a))

mStdIn :: IOSource a -> ProcessMachines a a0 k0 -> IO ()
mStdIn :: IOSource a -> ProcessMachines a a0 k0 -> IO ()
mStdIn IOSource a
ms (Just ProcessT IO a a0
stdIn, Maybe (MachineT IO k0 a)
_, Maybe (MachineT IO k0 a)
_)  = MachineT IO Any a0 -> IO ()
forall (m :: * -> *) (k :: * -> *) b.
Monad m =>
MachineT m k b -> m ()
runT_ (MachineT IO Any a0 -> IO ()) -> MachineT IO Any a0 -> IO ()
forall a b. (a -> b) -> a -> b
$ ProcessT IO a a0
stdIn ProcessT IO a a0 -> MachineT IO Any a -> MachineT IO Any a0
forall (m :: * -> *) b c (k :: * -> *).
Monad m =>
ProcessT m b c -> MachineT m k b -> MachineT m k c
<~ MachineT IO Any a
IOSource a
ms
mStdIn IOSource a
_  ProcessMachines a a0 k0
_                   = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

mStdOut :: ProcessT IO a b -> ProcessMachines a a0 k0 -> IO [b]
mStdOut :: ProcessT IO a b -> ProcessMachines a a0 k0 -> IO [b]
mStdOut ProcessT IO a b
mp (Maybe (ProcessT IO a a0)
_, Just MachineT IO k0 a
stdOut, Maybe (MachineT IO k0 a)
_)  = MachineT IO k0 b -> IO [b]
forall (m :: * -> *) (k :: * -> *) b.
Monad m =>
MachineT m k b -> m [b]
runT (MachineT IO k0 b -> IO [b]) -> MachineT IO k0 b -> IO [b]
forall a b. (a -> b) -> a -> b
$ ProcessT IO a b
mp ProcessT IO a b -> MachineT IO k0 a -> MachineT IO k0 b
forall (m :: * -> *) b c (k :: * -> *).
Monad m =>
ProcessT m b c -> MachineT m k b -> MachineT m k c
<~ MachineT IO k0 a
stdOut
mStdOut ProcessT IO a b
_  ProcessMachines a a0 k0
_                    = [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []

{--
mStdOut_ :: ProcessT IO a b -> ProcessMachines a a0 k0 -> IO ()
mStdOut mp (_, Just stdOut, _)  = runT_ $ mp <~ stdOut
mStdOut _  _                    = return ()
--}

mStdErr :: ProcessT IO a b -> ProcessMachines a a0 k0 -> IO [b]
mStdErr :: ProcessT IO a b -> ProcessMachines a a0 k0 -> IO [b]
mStdErr ProcessT IO a b
mp (Maybe (ProcessT IO a a0)
_, Maybe (MachineT IO k0 a)
_, Just MachineT IO k0 a
stdErr)  = MachineT IO k0 b -> IO [b]
forall (m :: * -> *) (k :: * -> *) b.
Monad m =>
MachineT m k b -> m [b]
runT (MachineT IO k0 b -> IO [b]) -> MachineT IO k0 b -> IO [b]
forall a b. (a -> b) -> a -> b
$ ProcessT IO a b
mp ProcessT IO a b -> MachineT IO k0 a -> MachineT IO k0 b
forall (m :: * -> *) b c (k :: * -> *).
Monad m =>
ProcessT m b c -> MachineT m k b -> MachineT m k c
<~ MachineT IO k0 a
stdErr
mStdErr ProcessT IO a b
_  ProcessMachines a a0 k0
_                    = [b] -> IO [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []

callProcessMachines :: IOData a => forall b k. IODataMode a -> CreateProcess -> (ProcessMachines a b k -> IO c) -> IO (ExitCode, c)
callProcessMachines :: forall b (k :: * -> *).
IODataMode a
-> CreateProcess
-> (ProcessMachines a b k -> IO c)
-> IO (ExitCode, c)
callProcessMachines IODataMode a
m CreateProcess
cp ProcessMachines a b k -> IO c
f = do
  (ProcessMachines a b k
machines, ProcessHandle
pHandle) <- IODataMode a
-> CreateProcess -> IO (ProcessMachines a b k, ProcessHandle)
forall a b (k :: * -> *).
IOData a =>
IODataMode a
-> CreateProcess -> IO (ProcessMachines a b k, ProcessHandle)
createProcessMachines IODataMode a
m CreateProcess
cp
  c
x                   <- ProcessMachines a b k -> IO c
f ProcessMachines a b k
machines
  ExitCode
exitCode            <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
pHandle
  (ExitCode, c) -> IO (ExitCode, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
exitCode, c
x)

createProcessMachines :: IOData a => forall b k. IODataMode a -> CreateProcess -> IO (ProcessMachines a b k, ProcessHandle)
createProcessMachines :: forall b (k :: * -> *).
IODataMode a
-> CreateProcess -> IO (ProcessMachines a b k, ProcessHandle)
createProcessMachines (Handle -> IO a
r, Handle -> a -> IO ()
w) CreateProcess
cp = do
  (Maybe Handle
pIn, Maybe Handle
pOut, Maybe Handle
pErr, ProcessHandle
pHandle) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
cp
  let pInSink :: Maybe (ProcessT IO a a)
pInSink = (Handle -> ProcessT IO a a)
-> Maybe Handle -> Maybe (ProcessT IO a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Handle -> a -> IO ()) -> Handle -> SinkIO IO a
forall a (m :: * -> *).
(Handle -> a -> IO ()) -> Handle -> SinkIO m a
sinkHandleWith Handle -> a -> IO ()
w) Maybe Handle
pIn
  let pOutSource :: Maybe (MachineT IO k a)
pOutSource = (Handle -> MachineT IO k a)
-> Maybe Handle -> Maybe (MachineT IO k a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Handle -> MachineT IO k a
forall (k :: * -> *). Handle -> MachineT IO k a
sourceHandle' Maybe Handle
pOut
  let pErrSource :: Maybe (MachineT IO k a)
pErrSource = (Handle -> MachineT IO k a)
-> Maybe Handle -> Maybe (MachineT IO k a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Handle -> MachineT IO k a
forall (k :: * -> *). Handle -> MachineT IO k a
sourceHandle' Maybe Handle
pErr
  (ProcessMachines a b k, ProcessHandle)
-> IO (ProcessMachines a b k, ProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ProcessMachines a b k, ProcessHandle)
 -> IO (ProcessMachines a b k, ProcessHandle))
-> (ProcessMachines a b k, ProcessHandle)
-> IO (ProcessMachines a b k, ProcessHandle)
forall a b. (a -> b) -> a -> b
$ ((Maybe (ProcessT IO a b)
forall a. Maybe (ProcessT IO a a)
pInSink, Maybe (MachineT IO k a)
forall (k :: * -> *). Maybe (MachineT IO k a)
pOutSource, Maybe (MachineT IO k a)
forall (k :: * -> *). Maybe (MachineT IO k a)
pErrSource), ProcessHandle
pHandle) where
    sourceHandle' :: Handle -> MachineT IO k a
sourceHandle' = (Handle -> IO a) -> Handle -> SourceIO IO a
forall (m :: * -> *) a. (Handle -> m a) -> Handle -> SourceIO m a
sourceHandleWith Handle -> IO a
r