{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -O2 #-}
module System.Console.Concurrent.Internal where
import System.IO
#ifndef mingw32_HOST_OS
import System.Posix.IO
#endif
import System.Directory
import System.Exit
import Control.Monad
import Control.Monad.IO.Class (liftIO, MonadIO)
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.Async
import Data.Maybe
import Data.List
import Data.Monoid
import qualified System.Process as P
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Applicative
import Prelude
import Utility.Monad
import Utility.Exception
data OutputHandle = OutputHandle
{ OutputHandle -> TMVar Lock
outputLock :: TMVar Lock
, OutputHandle -> TMVar OutputBuffer
outputBuffer :: TMVar OutputBuffer
, OutputHandle -> TMVar OutputBuffer
errorBuffer :: TMVar OutputBuffer
, OutputHandle -> TMVar Integer
outputThreads :: TMVar Integer
, OutputHandle -> TMVar [Async ()]
processWaiters :: TMVar [Async ()]
, OutputHandle -> TMVar ()
waitForProcessLock :: TMVar ()
}
data Lock = Locked
{-# NOINLINE globalOutputHandle #-}
globalOutputHandle :: OutputHandle
globalOutputHandle :: OutputHandle
globalOutputHandle = IO OutputHandle -> OutputHandle
forall a. IO a -> a
unsafePerformIO (IO OutputHandle -> OutputHandle)
-> IO OutputHandle -> OutputHandle
forall a b. (a -> b) -> a -> b
$ TMVar Lock
-> TMVar OutputBuffer
-> TMVar OutputBuffer
-> TMVar Integer
-> TMVar [Async ()]
-> TMVar ()
-> OutputHandle
OutputHandle
(TMVar Lock
-> TMVar OutputBuffer
-> TMVar OutputBuffer
-> TMVar Integer
-> TMVar [Async ()]
-> TMVar ()
-> OutputHandle)
-> IO (TMVar Lock)
-> IO
(TMVar OutputBuffer
-> TMVar OutputBuffer
-> TMVar Integer
-> TMVar [Async ()]
-> TMVar ()
-> OutputHandle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TMVar Lock)
forall a. IO (TMVar a)
newEmptyTMVarIO
IO
(TMVar OutputBuffer
-> TMVar OutputBuffer
-> TMVar Integer
-> TMVar [Async ()]
-> TMVar ()
-> OutputHandle)
-> IO (TMVar OutputBuffer)
-> IO
(TMVar OutputBuffer
-> TMVar Integer -> TMVar [Async ()] -> TMVar () -> OutputHandle)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OutputBuffer -> IO (TMVar OutputBuffer)
forall a. a -> IO (TMVar a)
newTMVarIO ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
IO
(TMVar OutputBuffer
-> TMVar Integer -> TMVar [Async ()] -> TMVar () -> OutputHandle)
-> IO (TMVar OutputBuffer)
-> IO
(TMVar Integer -> TMVar [Async ()] -> TMVar () -> OutputHandle)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OutputBuffer -> IO (TMVar OutputBuffer)
forall a. a -> IO (TMVar a)
newTMVarIO ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
IO (TMVar Integer -> TMVar [Async ()] -> TMVar () -> OutputHandle)
-> IO (TMVar Integer)
-> IO (TMVar [Async ()] -> TMVar () -> OutputHandle)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Integer -> IO (TMVar Integer)
forall a. a -> IO (TMVar a)
newTMVarIO Integer
0
IO (TMVar [Async ()] -> TMVar () -> OutputHandle)
-> IO (TMVar [Async ()]) -> IO (TMVar () -> OutputHandle)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Async ()] -> IO (TMVar [Async ()])
forall a. a -> IO (TMVar a)
newTMVarIO []
IO (TMVar () -> OutputHandle) -> IO (TMVar ()) -> IO OutputHandle
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (TMVar ())
forall a. IO (TMVar a)
newEmptyTMVarIO
lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
lockOutput :: m a -> m a
lockOutput = m () -> m () -> m a -> m a
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
takeOutputLock) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
dropOutputLock)
takeOutputLock :: IO ()
takeOutputLock :: IO ()
takeOutputLock = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
takeOutputLock' Bool
True
tryTakeOutputLock :: IO Bool
tryTakeOutputLock :: IO Bool
tryTakeOutputLock = Bool -> IO Bool
takeOutputLock' Bool
False
withLock :: (TMVar Lock -> STM a) -> IO a
withLock :: (TMVar Lock -> STM a) -> IO a
withLock TMVar Lock -> STM a
a = STM a -> IO a
forall a. STM a -> IO a
atomically (STM a -> IO a) -> STM a -> IO a
forall a b. (a -> b) -> a -> b
$ TMVar Lock -> STM a
a (OutputHandle -> TMVar Lock
outputLock OutputHandle
globalOutputHandle)
takeOutputLock' :: Bool -> IO Bool
takeOutputLock' :: Bool -> IO Bool
takeOutputLock' Bool
block = do
Bool
locked <- (TMVar Lock -> STM Bool) -> IO Bool
forall a. (TMVar Lock -> STM a) -> IO a
withLock ((TMVar Lock -> STM Bool) -> IO Bool)
-> (TMVar Lock -> STM Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \TMVar Lock
l -> do
Maybe Lock
v <- TMVar Lock -> STM (Maybe Lock)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar Lock
l
case Maybe Lock
v of
Just Lock
Locked
| Bool
block -> STM Bool
forall a. STM a
retry
| Bool
otherwise -> do
TMVar Lock -> Lock -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Lock
l Lock
Locked
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe Lock
Nothing -> do
TMVar Lock -> Lock -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Lock
l Lock
Locked
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
locked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
(OutputBuffer
outbuf, OutputBuffer
errbuf) <- STM (OutputBuffer, OutputBuffer) -> IO (OutputBuffer, OutputBuffer)
forall a. STM a -> IO a
atomically (STM (OutputBuffer, OutputBuffer)
-> IO (OutputBuffer, OutputBuffer))
-> STM (OutputBuffer, OutputBuffer)
-> IO (OutputBuffer, OutputBuffer)
forall a b. (a -> b) -> a -> b
$ (,)
(OutputBuffer -> OutputBuffer -> (OutputBuffer, OutputBuffer))
-> STM OutputBuffer
-> STM (OutputBuffer -> (OutputBuffer, OutputBuffer))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar OutputBuffer -> OutputBuffer -> STM OutputBuffer
forall a. TMVar a -> a -> STM a
swapTMVar (OutputHandle -> TMVar OutputBuffer
outputBuffer OutputHandle
globalOutputHandle) ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
STM (OutputBuffer -> (OutputBuffer, OutputBuffer))
-> STM OutputBuffer -> STM (OutputBuffer, OutputBuffer)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TMVar OutputBuffer -> OutputBuffer -> STM OutputBuffer
forall a. TMVar a -> a -> STM a
swapTMVar (OutputHandle -> TMVar OutputBuffer
errorBuffer OutputHandle
globalOutputHandle) ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
StdOut OutputBuffer
outbuf
StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
StdErr OutputBuffer
errbuf
Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
locked
dropOutputLock :: IO ()
dropOutputLock :: IO ()
dropOutputLock = (TMVar Lock -> STM ()) -> IO ()
forall a. (TMVar Lock -> STM a) -> IO a
withLock ((TMVar Lock -> STM ()) -> IO ())
-> (TMVar Lock -> STM ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Lock -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM Lock -> STM ())
-> (TMVar Lock -> STM Lock) -> TMVar Lock -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar Lock -> STM Lock
forall a. TMVar a -> STM a
takeTMVar
withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a
withConcurrentOutput :: m a -> m a
withConcurrentOutput m a
a = m a
a m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
flushConcurrentOutput
flushConcurrentOutput :: IO ()
flushConcurrentOutput :: IO ()
flushConcurrentOutput = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Integer
r <- TMVar Integer -> STM Integer
forall a. TMVar a -> STM a
takeTMVar (OutputHandle -> TMVar Integer
outputThreads OutputHandle
globalOutputHandle)
if Integer
r Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
then TMVar Integer -> Integer -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (OutputHandle -> TMVar Integer
outputThreads OutputHandle
globalOutputHandle) Integer
r
else STM ()
forall a. STM a
retry
IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
class Outputable v where
toOutput :: v -> T.Text
instance Outputable T.Text where
toOutput :: Text -> Text
toOutput = Text -> Text
forall a. a -> a
id
instance Outputable String where
toOutput :: String -> Text
toOutput = Text -> Text
forall v. Outputable v => v -> Text
toOutput (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
outputConcurrent :: Outputable v => v -> IO ()
outputConcurrent :: v -> IO ()
outputConcurrent = StdHandle -> v -> IO ()
forall v. Outputable v => StdHandle -> v -> IO ()
outputConcurrent' StdHandle
StdOut
errorConcurrent :: Outputable v => v -> IO ()
errorConcurrent :: v -> IO ()
errorConcurrent = StdHandle -> v -> IO ()
forall v. Outputable v => StdHandle -> v -> IO ()
outputConcurrent' StdHandle
StdErr
outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()
outputConcurrent' :: StdHandle -> v -> IO ()
outputConcurrent' StdHandle
stdh v
v = IO Bool -> (Bool -> IO ()) -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO Bool
setup Bool -> IO ()
cleanup Bool -> IO ()
go
where
setup :: IO Bool
setup = IO Bool
tryTakeOutputLock
cleanup :: Bool -> IO ()
cleanup Bool
False = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
cleanup Bool
True = IO ()
dropOutputLock
go :: Bool -> IO ()
go Bool
True = do
Handle -> Text -> IO ()
T.hPutStr Handle
h (v -> Text
forall v. Outputable v => v -> Text
toOutput v
v)
Handle -> IO ()
hFlush Handle
h
go Bool
False = do
OutputBuffer
oldbuf <- STM OutputBuffer -> IO OutputBuffer
forall a. STM a -> IO a
atomically (STM OutputBuffer -> IO OutputBuffer)
-> STM OutputBuffer -> IO OutputBuffer
forall a b. (a -> b) -> a -> b
$ TMVar OutputBuffer -> STM OutputBuffer
forall a. TMVar a -> STM a
takeTMVar TMVar OutputBuffer
bv
OutputBuffer
newbuf <- OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer
addOutputBuffer (Text -> OutputBufferedActivity
Output (v -> Text
forall v. Outputable v => v -> Text
toOutput v
v)) OutputBuffer
oldbuf
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar OutputBuffer -> OutputBuffer -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar OutputBuffer
bv OutputBuffer
newbuf
h :: Handle
h = StdHandle -> Handle
toHandle StdHandle
stdh
bv :: TMVar OutputBuffer
bv = StdHandle -> TMVar OutputBuffer
bufferFor StdHandle
stdh
newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle
toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> (Maybe Handle, Maybe Handle, Maybe Handle,
ConcurrentProcessHandle)
toConcurrentProcessHandle (Maybe Handle
i, Maybe Handle
o, Maybe Handle
e, ProcessHandle
h) = (Maybe Handle
i, Maybe Handle
o, Maybe Handle
e, ProcessHandle -> ConcurrentProcessHandle
ConcurrentProcessHandle ProcessHandle
h)
waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode
waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode
waitForProcessConcurrent (ConcurrentProcessHandle ProcessHandle
h) =
IO Bool -> (Bool -> IO ()) -> (Bool -> IO ExitCode) -> IO ExitCode
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO Bool
lock Bool -> IO ()
unlock Bool -> IO ExitCode
checkexit
where
lck :: TMVar ()
lck = OutputHandle -> TMVar ()
waitForProcessLock OutputHandle
globalOutputHandle
lock :: IO Bool
lock = STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
lck ()
unlock :: Bool -> IO ()
unlock Bool
True = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
lck
unlock Bool
False = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkexit :: Bool -> IO ExitCode
checkexit Bool
locked = IO ExitCode
-> (ExitCode -> IO ExitCode) -> Maybe ExitCode -> IO ExitCode
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO ExitCode
waitsome Bool
locked) ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return
(Maybe ExitCode -> IO ExitCode)
-> IO (Maybe ExitCode) -> IO ExitCode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ProcessHandle -> IO (Maybe ExitCode)
P.getProcessExitCode ProcessHandle
h
waitsome :: Bool -> IO ExitCode
waitsome Bool
True = do
let v :: TMVar [Async ()]
v = OutputHandle -> TMVar [Async ()]
processWaiters OutputHandle
globalOutputHandle
[Async ()]
l <- STM [Async ()] -> IO [Async ()]
forall a. STM a -> IO a
atomically (STM [Async ()] -> IO [Async ()])
-> STM [Async ()] -> IO [Async ()]
forall a b. (a -> b) -> a -> b
$ TMVar [Async ()] -> STM [Async ()]
forall a. TMVar a -> STM a
readTMVar TMVar [Async ()]
v
if [Async ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Async ()]
l
then ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
else do
IO (Either IOException (Async (), ())) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException (Async (), ())) -> IO ())
-> IO (Either IOException (Async (), ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Async (), ()) -> IO (Either IOException (Async (), ()))
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO (Async (), ()) -> IO (Either IOException (Async (), ())))
-> IO (Async (), ()) -> IO (Either IOException (Async (), ()))
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), ())
forall a. [Async a] -> IO (Async a, a)
waitAny [Async ()]
l
Bool -> IO ExitCode
checkexit Bool
True
waitsome Bool
False = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
lck ()
TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
lck
Bool -> IO ExitCode
checkexit Bool
False
asyncProcessWaiter :: IO () -> IO ()
asyncProcessWaiter :: IO () -> IO ()
asyncProcessWaiter IO ()
waitaction = do
TMVar (Async ())
regdone <- IO (TMVar (Async ()))
forall a. IO (TMVar a)
newEmptyTMVarIO
Async ()
waiter <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
Async ()
self <- STM (Async ()) -> IO (Async ())
forall a. STM a -> IO a
atomically (TMVar (Async ()) -> STM (Async ())
forall a. TMVar a -> STM a
takeTMVar TMVar (Async ())
regdone)
IO ()
waitaction IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` Async () -> IO ()
unregister Async ()
self
Async () -> TMVar (Async ()) -> IO ()
register Async ()
waiter TMVar (Async ())
regdone
where
v :: TMVar [Async ()]
v = OutputHandle -> TMVar [Async ()]
processWaiters OutputHandle
globalOutputHandle
register :: Async () -> TMVar (Async ()) -> IO ()
register Async ()
waiter TMVar (Async ())
regdone = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Async ()]
l <- TMVar [Async ()] -> STM [Async ()]
forall a. TMVar a -> STM a
takeTMVar TMVar [Async ()]
v
TMVar [Async ()] -> [Async ()] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [Async ()]
v (Async ()
waiterAsync () -> [Async ()] -> [Async ()]
forall a. a -> [a] -> [a]
:[Async ()]
l)
TMVar (Async ()) -> Async () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Async ())
regdone Async ()
waiter
unregister :: Async () -> IO ()
unregister Async ()
waiter = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[Async ()]
l <- TMVar [Async ()] -> STM [Async ()]
forall a. TMVar a -> STM a
takeTMVar TMVar [Async ()]
v
TMVar [Async ()] -> [Async ()] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [Async ()]
v ((Async () -> Bool) -> [Async ()] -> [Async ()]
forall a. (a -> Bool) -> [a] -> [a]
filter (Async () -> Async () -> Bool
forall a. Eq a => a -> a -> Bool
/= Async ()
waiter) [Async ()]
l)
#ifndef mingw32_HOST_OS
createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
createProcessConcurrent :: CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
createProcessConcurrent CreateProcess
p
| StdStream -> Bool
willOutput (CreateProcess -> StdStream
P.std_out CreateProcess
p) Bool -> Bool -> Bool
|| StdStream -> Bool
willOutput (CreateProcess -> StdStream
P.std_err CreateProcess
p) =
IO Bool
-> (IO
(Maybe Handle, Maybe Handle, Maybe Handle,
ConcurrentProcessHandle),
IO
(Maybe Handle, Maybe Handle, Maybe Handle,
ConcurrentProcessHandle))
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM IO Bool
tryTakeOutputLock
( CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
fgProcess CreateProcess
p
, CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
bgProcess CreateProcess
p
)
| Bool
otherwise = do
r :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r@(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
h) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
P.createProcess CreateProcess
p
IO () -> IO ()
asyncProcessWaiter (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO (Either IOException ExitCode) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ExitCode) -> IO ())
-> IO (Either IOException ExitCode) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO (Either IOException ExitCode)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO ExitCode -> IO (Either IOException ExitCode))
-> IO ExitCode -> IO (Either IOException ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> (Maybe Handle, Maybe Handle, Maybe Handle,
ConcurrentProcessHandle)
toConcurrentProcessHandle (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r)
#endif
createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
createProcessForeground :: CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
createProcessForeground CreateProcess
p = do
IO ()
takeOutputLock
CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
fgProcess CreateProcess
p
fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
fgProcess :: CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
fgProcess CreateProcess
p = do
r :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r@(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
h) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
P.createProcess CreateProcess
p
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` IO ()
dropOutputLock
IO ()
registerOutputThread
IO () -> IO ()
asyncProcessWaiter (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
IO (Either IOException ExitCode) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ExitCode) -> IO ())
-> IO (Either IOException ExitCode) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO (Either IOException ExitCode)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO ExitCode -> IO (Either IOException ExitCode))
-> IO ExitCode -> IO (Either IOException ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
IO ()
unregisterOutputThread
IO ()
dropOutputLock
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> (Maybe Handle, Maybe Handle, Maybe Handle,
ConcurrentProcessHandle)
toConcurrentProcessHandle (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r)
#ifndef mingw32_HOST_OS
bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
bgProcess :: CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
bgProcess CreateProcess
p = do
(Handle
toouth, Handle
fromouth) <- IO (Handle, Handle)
pipe
(Handle
toerrh, Handle
fromerrh) <- IO (Handle, Handle)
pipe
let p' :: CreateProcess
p' = CreateProcess
p
{ std_out :: StdStream
P.std_out = StdStream -> Handle -> StdStream
rediroutput (CreateProcess -> StdStream
P.std_out CreateProcess
p) Handle
toouth
, std_err :: StdStream
P.std_err = StdStream -> Handle -> StdStream
rediroutput (CreateProcess -> StdStream
P.std_err CreateProcess
p) Handle
toerrh
}
IO ()
registerOutputThread
r :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r@(Maybe Handle
_, Maybe Handle
_, Maybe Handle
_, ProcessHandle
h) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
P.createProcess CreateProcess
p'
IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> IO ()
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` IO ()
unregisterOutputThread
IO () -> IO ()
asyncProcessWaiter (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (Either IOException ExitCode) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ExitCode) -> IO ())
-> IO (Either IOException ExitCode) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ExitCode -> IO (Either IOException ExitCode)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO ExitCode -> IO (Either IOException ExitCode))
-> IO ExitCode -> IO (Either IOException ExitCode)
forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
outbuf <- StdHandle
-> Handle
-> StdStream
-> Handle
-> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
setupOutputBuffer StdHandle
StdOut Handle
toouth (CreateProcess -> StdStream
P.std_out CreateProcess
p) Handle
fromouth
(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
errbuf <- StdHandle
-> Handle
-> StdStream
-> Handle
-> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
setupOutputBuffer StdHandle
StdErr Handle
toerrh (CreateProcess -> StdStream
P.std_err CreateProcess
p) Handle
fromerrh
IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
-> IO ()
bufferWriter [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
outbuf, (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
errbuf]
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-> (Maybe Handle, Maybe Handle, Maybe Handle,
ConcurrentProcessHandle)
toConcurrentProcessHandle (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
r)
where
pipe :: IO (Handle, Handle)
pipe = do
(Fd
from, Fd
to) <- IO (Fd, Fd)
createPipe
(,) (Handle -> Handle -> (Handle, Handle))
-> IO Handle -> IO (Handle -> (Handle, Handle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> IO Handle
fdToHandle Fd
to IO (Handle -> (Handle, Handle)) -> IO Handle -> IO (Handle, Handle)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Fd -> IO Handle
fdToHandle Fd
from
rediroutput :: StdStream -> Handle -> StdStream
rediroutput StdStream
ss Handle
h
| StdStream -> Bool
willOutput StdStream
ss = Handle -> StdStream
P.UseHandle Handle
h
| Bool
otherwise = StdStream
ss
#endif
willOutput :: P.StdStream -> Bool
willOutput :: StdStream -> Bool
willOutput StdStream
P.Inherit = Bool
True
willOutput StdStream
_ = Bool
False
data OutputBuffer = OutputBuffer [OutputBufferedActivity]
deriving (OutputBuffer -> OutputBuffer -> Bool
(OutputBuffer -> OutputBuffer -> Bool)
-> (OutputBuffer -> OutputBuffer -> Bool) -> Eq OutputBuffer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputBuffer -> OutputBuffer -> Bool
$c/= :: OutputBuffer -> OutputBuffer -> Bool
== :: OutputBuffer -> OutputBuffer -> Bool
$c== :: OutputBuffer -> OutputBuffer -> Bool
Eq)
data StdHandle = StdOut | StdErr
toHandle :: StdHandle -> Handle
toHandle :: StdHandle -> Handle
toHandle StdHandle
StdOut = Handle
stdout
toHandle StdHandle
StdErr = Handle
stderr
bufferFor :: StdHandle -> TMVar OutputBuffer
bufferFor :: StdHandle -> TMVar OutputBuffer
bufferFor StdHandle
StdOut = OutputHandle -> TMVar OutputBuffer
outputBuffer OutputHandle
globalOutputHandle
bufferFor StdHandle
StdErr = OutputHandle -> TMVar OutputBuffer
errorBuffer OutputHandle
globalOutputHandle
data OutputBufferedActivity
= Output T.Text
| InTempFile
{ OutputBufferedActivity -> String
tempFile :: FilePath
, OutputBufferedActivity -> Bool
endsInNewLine :: Bool
}
deriving (OutputBufferedActivity -> OutputBufferedActivity -> Bool
(OutputBufferedActivity -> OutputBufferedActivity -> Bool)
-> (OutputBufferedActivity -> OutputBufferedActivity -> Bool)
-> Eq OutputBufferedActivity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutputBufferedActivity -> OutputBufferedActivity -> Bool
$c/= :: OutputBufferedActivity -> OutputBufferedActivity -> Bool
== :: OutputBufferedActivity -> OutputBufferedActivity -> Bool
$c== :: OutputBufferedActivity -> OutputBufferedActivity -> Bool
Eq)
data AtEnd = AtEnd
deriving AtEnd -> AtEnd -> Bool
(AtEnd -> AtEnd -> Bool) -> (AtEnd -> AtEnd -> Bool) -> Eq AtEnd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AtEnd -> AtEnd -> Bool
$c/= :: AtEnd -> AtEnd -> Bool
== :: AtEnd -> AtEnd -> Bool
$c== :: AtEnd -> AtEnd -> Bool
Eq
data BufSig = BufSig
setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
setupOutputBuffer :: StdHandle
-> Handle
-> StdStream
-> Handle
-> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
setupOutputBuffer StdHandle
h Handle
toh StdStream
ss Handle
fromh = do
Handle -> IO ()
hClose Handle
toh
MVar OutputBuffer
buf <- OutputBuffer -> IO (MVar OutputBuffer)
forall a. a -> IO (MVar a)
newMVar ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
TMVar BufSig
bufsig <- STM (TMVar BufSig) -> IO (TMVar BufSig)
forall a. STM a -> IO a
atomically STM (TMVar BufSig)
forall a. STM (TMVar a)
newEmptyTMVar
TMVar AtEnd
bufend <- STM (TMVar AtEnd) -> IO (TMVar AtEnd)
forall a. STM a -> IO a
atomically STM (TMVar AtEnd)
forall a. STM (TMVar a)
newEmptyTMVar
IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ StdStream
-> Handle
-> MVar OutputBuffer
-> TMVar BufSig
-> TMVar AtEnd
-> IO ()
outputDrainer StdStream
ss Handle
fromh MVar OutputBuffer
buf TMVar BufSig
bufsig TMVar AtEnd
bufend
(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
forall (m :: * -> *) a. Monad m => a -> m a
return (StdHandle
h, MVar OutputBuffer
buf, TMVar BufSig
bufsig, TMVar AtEnd
bufend)
outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()
outputDrainer :: StdStream
-> Handle
-> MVar OutputBuffer
-> TMVar BufSig
-> TMVar AtEnd
-> IO ()
outputDrainer StdStream
ss Handle
fromh MVar OutputBuffer
buf TMVar BufSig
bufsig TMVar AtEnd
bufend
| StdStream -> Bool
willOutput StdStream
ss = IO ()
go
| Bool
otherwise = IO ()
atend
where
go :: IO ()
go = do
Text
t <- Handle -> IO Text
T.hGetChunk Handle
fromh
if Text -> Bool
T.null Text
t
then IO ()
atend
else do
MVar OutputBuffer -> (OutputBuffer -> IO OutputBuffer) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar OutputBuffer
buf ((OutputBuffer -> IO OutputBuffer) -> IO ())
-> (OutputBuffer -> IO OutputBuffer) -> IO ()
forall a b. (a -> b) -> a -> b
$ OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer
addOutputBuffer (Text -> OutputBufferedActivity
Output Text
t)
IO ()
changed
IO ()
go
atend :: IO ()
atend = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar AtEnd -> AtEnd -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar AtEnd
bufend AtEnd
AtEnd
Handle -> IO ()
hClose Handle
fromh
changed :: IO ()
changed = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
STM (Maybe BufSig) -> STM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (STM (Maybe BufSig) -> STM ()) -> STM (Maybe BufSig) -> STM ()
forall a b. (a -> b) -> a -> b
$ TMVar BufSig -> STM (Maybe BufSig)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar BufSig
bufsig
TMVar BufSig -> BufSig -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar BufSig
bufsig BufSig
BufSig
registerOutputThread :: IO ()
registerOutputThread :: IO ()
registerOutputThread = do
let v :: TMVar Integer
v = OutputHandle -> TMVar Integer
outputThreads OutputHandle
globalOutputHandle
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Integer -> Integer -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Integer
v (Integer -> STM ()) -> (Integer -> Integer) -> Integer -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Enum a => a -> a
succ (Integer -> STM ()) -> STM Integer -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMVar Integer -> STM Integer
forall a. TMVar a -> STM a
takeTMVar TMVar Integer
v
unregisterOutputThread :: IO ()
unregisterOutputThread :: IO ()
unregisterOutputThread = do
let v :: TMVar Integer
v = OutputHandle -> TMVar Integer
outputThreads OutputHandle
globalOutputHandle
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar Integer -> Integer -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Integer
v (Integer -> STM ()) -> (Integer -> Integer) -> Integer -> STM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer
forall a. Enum a => a -> a
pred (Integer -> STM ()) -> STM Integer -> STM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TMVar Integer -> STM Integer
forall a. TMVar a -> STM a
takeTMVar TMVar Integer
v
bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO ()
bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
-> IO ()
bufferWriter [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
ts = do
TMVar ()
activitysig <- STM (TMVar ()) -> IO (TMVar ())
forall a. STM a -> IO a
atomically STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar
Async ()
worker1 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO Bool -> (IO (), IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
activitysig ())
( IO [()] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [()] -> IO ()) -> IO [()] -> IO ()
forall a b. (a -> b) -> a -> b
$ ((StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-> IO ())
-> [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
-> IO [()]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) -> IO ()
displaybuf [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
ts
, IO ()
forall (m :: * -> *). Monad m => m ()
noop
)
Async ()
worker2 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> Async () -> IO ()
forall a. TMVar () -> Async a -> IO ()
globalbuf TMVar ()
activitysig Async ()
worker1
IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
worker1
IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either SomeException ()) -> IO ())
-> IO (Either SomeException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
worker2
IO ()
unregisterOutputThread
where
displaybuf :: (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) -> IO ()
displaybuf v :: (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
v@(StdHandle
outh, MVar OutputBuffer
buf, TMVar BufSig
bufsig, TMVar AtEnd
bufend) = do
Either AtEnd BufSig
change <- STM (Either AtEnd BufSig) -> IO (Either AtEnd BufSig)
forall a. STM a -> IO a
atomically (STM (Either AtEnd BufSig) -> IO (Either AtEnd BufSig))
-> STM (Either AtEnd BufSig) -> IO (Either AtEnd BufSig)
forall a b. (a -> b) -> a -> b
$
(BufSig -> Either AtEnd BufSig
forall a b. b -> Either a b
Right (BufSig -> Either AtEnd BufSig)
-> STM BufSig -> STM (Either AtEnd BufSig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar BufSig -> STM BufSig
forall a. TMVar a -> STM a
takeTMVar TMVar BufSig
bufsig)
STM (Either AtEnd BufSig)
-> STM (Either AtEnd BufSig) -> STM (Either AtEnd BufSig)
forall a. STM a -> STM a -> STM a
`orElse`
(AtEnd -> Either AtEnd BufSig
forall a b. a -> Either a b
Left (AtEnd -> Either AtEnd BufSig)
-> STM AtEnd -> STM (Either AtEnd BufSig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar AtEnd -> STM AtEnd
forall a. TMVar a -> STM a
takeTMVar TMVar AtEnd
bufend)
OutputBuffer
l <- MVar OutputBuffer -> IO OutputBuffer
forall a. MVar a -> IO a
takeMVar MVar OutputBuffer
buf
MVar OutputBuffer -> OutputBuffer -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar OutputBuffer
buf ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
outh OutputBuffer
l
case Either AtEnd BufSig
change of
Right BufSig
BufSig -> (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) -> IO ()
displaybuf (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
v
Left AtEnd
AtEnd -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
globalbuf :: TMVar () -> Async a -> IO ()
globalbuf TMVar ()
activitysig Async a
worker1 = do
Bool
ok <- STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
Bool
ok <- TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
activitysig ()
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (STM () -> STM ()) -> STM () -> STM ()
forall a b. (a -> b) -> a -> b
$
((StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-> STM AtEnd)
-> [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
-> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(StdHandle
_outh, MVar OutputBuffer
_buf, TMVar BufSig
_bufsig, TMVar AtEnd
bufend) -> TMVar AtEnd -> STM AtEnd
forall a. TMVar a -> STM a
takeTMVar TMVar AtEnd
bufend) [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
ts
Bool -> STM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[(StdHandle, OutputBuffer)]
bs <- [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
-> ((StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-> IO (StdHandle, OutputBuffer))
-> IO [(StdHandle, OutputBuffer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
ts (((StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-> IO (StdHandle, OutputBuffer))
-> IO [(StdHandle, OutputBuffer)])
-> ((StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
-> IO (StdHandle, OutputBuffer))
-> IO [(StdHandle, OutputBuffer)]
forall a b. (a -> b) -> a -> b
$ \(StdHandle
outh, MVar OutputBuffer
buf, TMVar BufSig
_bufsig, TMVar AtEnd
_bufend) ->
(StdHandle
outh,) (OutputBuffer -> (StdHandle, OutputBuffer))
-> IO OutputBuffer -> IO (StdHandle, OutputBuffer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar OutputBuffer -> IO OutputBuffer
forall a. MVar a -> IO a
takeMVar MVar OutputBuffer
buf
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
[(StdHandle, OutputBuffer)]
-> ((StdHandle, OutputBuffer) -> STM ()) -> STM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(StdHandle, OutputBuffer)]
bs (((StdHandle, OutputBuffer) -> STM ()) -> STM ())
-> ((StdHandle, OutputBuffer) -> STM ()) -> STM ()
forall a b. (a -> b) -> a -> b
$ \(StdHandle
outh, OutputBuffer
b) ->
StdHandle -> OutputBuffer -> STM ()
bufferOutputSTM' StdHandle
outh OutputBuffer
b
Async a -> IO ()
forall a. Async a -> IO ()
cancel Async a
worker1
addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer
addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer
addOutputBuffer (Output Text
t) (OutputBuffer [OutputBufferedActivity]
buf)
| Text -> Int
T.length Text
t' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1048576 = OutputBuffer -> IO OutputBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputBuffer -> IO OutputBuffer)
-> OutputBuffer -> IO OutputBuffer
forall a b. (a -> b) -> a -> b
$ [OutputBufferedActivity] -> OutputBuffer
OutputBuffer (Text -> OutputBufferedActivity
Output Text
t' OutputBufferedActivity
-> [OutputBufferedActivity] -> [OutputBufferedActivity]
forall a. a -> [a] -> [a]
: [OutputBufferedActivity]
other)
| Bool
otherwise = do
String
tmpdir <- IO String
getTemporaryDirectory
(String
tmp, Handle
h) <- String -> String -> IO (String, Handle)
openTempFile String
tmpdir String
"output.tmp"
let !endnl :: Bool
endnl = Text -> Bool
endsNewLine Text
t'
let i :: OutputBufferedActivity
i = InTempFile :: String -> Bool -> OutputBufferedActivity
InTempFile
{ tempFile :: String
tempFile = String
tmp
, endsInNewLine :: Bool
endsInNewLine = Bool
endnl
}
Handle -> Text -> IO ()
T.hPutStr Handle
h Text
t'
Handle -> IO ()
hClose Handle
h
OutputBuffer -> IO OutputBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputBuffer -> IO OutputBuffer)
-> OutputBuffer -> IO OutputBuffer
forall a b. (a -> b) -> a -> b
$ [OutputBufferedActivity] -> OutputBuffer
OutputBuffer (OutputBufferedActivity
i OutputBufferedActivity
-> [OutputBufferedActivity] -> [OutputBufferedActivity]
forall a. a -> [a] -> [a]
: [OutputBufferedActivity]
other)
where
!t' :: Text
t' = [Text] -> Text
T.concat ((OutputBufferedActivity -> Maybe Text)
-> [OutputBufferedActivity] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OutputBufferedActivity -> Maybe Text
getOutput [OutputBufferedActivity]
this) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
t
!([OutputBufferedActivity]
this, [OutputBufferedActivity]
other) = (OutputBufferedActivity -> Bool)
-> [OutputBufferedActivity]
-> ([OutputBufferedActivity], [OutputBufferedActivity])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition OutputBufferedActivity -> Bool
isOutput [OutputBufferedActivity]
buf
isOutput :: OutputBufferedActivity -> Bool
isOutput OutputBufferedActivity
v = case OutputBufferedActivity
v of
Output Text
_ -> Bool
True
OutputBufferedActivity
_ -> Bool
False
getOutput :: OutputBufferedActivity -> Maybe Text
getOutput OutputBufferedActivity
v = case OutputBufferedActivity
v of
Output Text
t'' -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t''
OutputBufferedActivity
_ -> Maybe Text
forall a. Maybe a
Nothing
addOutputBuffer OutputBufferedActivity
v (OutputBuffer [OutputBufferedActivity]
buf) = OutputBuffer -> IO OutputBuffer
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputBuffer -> IO OutputBuffer)
-> OutputBuffer -> IO OutputBuffer
forall a b. (a -> b) -> a -> b
$ [OutputBufferedActivity] -> OutputBuffer
OutputBuffer (OutputBufferedActivity
vOutputBufferedActivity
-> [OutputBufferedActivity] -> [OutputBufferedActivity]
forall a. a -> [a] -> [a]
:[OutputBufferedActivity]
buf)
bufferOutputSTM :: Outputable v => StdHandle -> v -> STM ()
bufferOutputSTM :: StdHandle -> v -> STM ()
bufferOutputSTM StdHandle
h v
v = StdHandle -> OutputBuffer -> STM ()
bufferOutputSTM' StdHandle
h ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [Text -> OutputBufferedActivity
Output (v -> Text
forall v. Outputable v => v -> Text
toOutput v
v)])
bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM ()
bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM ()
bufferOutputSTM' StdHandle
h (OutputBuffer [OutputBufferedActivity]
newbuf) = do
(OutputBuffer [OutputBufferedActivity]
buf) <- TMVar OutputBuffer -> STM OutputBuffer
forall a. TMVar a -> STM a
takeTMVar TMVar OutputBuffer
bv
TMVar OutputBuffer -> OutputBuffer -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar OutputBuffer
bv ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer ([OutputBufferedActivity]
newbuf [OutputBufferedActivity]
-> [OutputBufferedActivity] -> [OutputBufferedActivity]
forall a. [a] -> [a] -> [a]
++ [OutputBufferedActivity]
buf))
where
bv :: TMVar OutputBuffer
bv = StdHandle -> TMVar OutputBuffer
bufferFor StdHandle
h
outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer)
outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer))
-> STM (StdHandle, OutputBuffer)
outputBufferWaiterSTM OutputBuffer -> (OutputBuffer, OutputBuffer)
selector = StdHandle -> STM (StdHandle, OutputBuffer)
waitgetbuf StdHandle
StdOut STM (StdHandle, OutputBuffer)
-> STM (StdHandle, OutputBuffer) -> STM (StdHandle, OutputBuffer)
forall a. STM a -> STM a -> STM a
`orElse` StdHandle -> STM (StdHandle, OutputBuffer)
waitgetbuf StdHandle
StdErr
where
waitgetbuf :: StdHandle -> STM (StdHandle, OutputBuffer)
waitgetbuf StdHandle
h = do
let bv :: TMVar OutputBuffer
bv = StdHandle -> TMVar OutputBuffer
bufferFor StdHandle
h
(OutputBuffer
selected, OutputBuffer
rest) <- OutputBuffer -> (OutputBuffer, OutputBuffer)
selector (OutputBuffer -> (OutputBuffer, OutputBuffer))
-> STM OutputBuffer -> STM (OutputBuffer, OutputBuffer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TMVar OutputBuffer -> STM OutputBuffer
forall a. TMVar a -> STM a
takeTMVar TMVar OutputBuffer
bv
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OutputBuffer
selected OutputBuffer -> OutputBuffer -> Bool
forall a. Eq a => a -> a -> Bool
== [OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
STM ()
forall a. STM a
retry
TMVar OutputBuffer -> OutputBuffer -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar OutputBuffer
bv OutputBuffer
rest
(StdHandle, OutputBuffer) -> STM (StdHandle, OutputBuffer)
forall (m :: * -> *) a. Monad m => a -> m a
return (StdHandle
h, OutputBuffer
selected)
waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)
waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)
waitAnyBuffer OutputBuffer
b = (OutputBuffer
b, [OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer)
waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer)
waitCompleteLines (OutputBuffer [OutputBufferedActivity]
l) =
let ([OutputBufferedActivity]
selected, [OutputBufferedActivity]
rest) = (OutputBufferedActivity -> Bool)
-> [OutputBufferedActivity]
-> ([OutputBufferedActivity], [OutputBufferedActivity])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span OutputBufferedActivity -> Bool
completeline [OutputBufferedActivity]
l
in ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [OutputBufferedActivity]
selected, [OutputBufferedActivity] -> OutputBuffer
OutputBuffer [OutputBufferedActivity]
rest)
where
completeline :: OutputBufferedActivity -> Bool
completeline (v :: OutputBufferedActivity
v@(InTempFile {})) = OutputBufferedActivity -> Bool
endsInNewLine OutputBufferedActivity
v
completeline (Output Text
b) = Text -> Bool
endsNewLine Text
b
endsNewLine :: T.Text -> Bool
endsNewLine :: Text -> Bool
endsNewLine Text
t = Bool -> Bool
not (Text -> Bool
T.null Text
t) Bool -> Bool -> Bool
&& Text -> Char
T.last Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
emitOutputBuffer :: StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer :: StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
stdh (OutputBuffer [OutputBufferedActivity]
l) =
[OutputBufferedActivity]
-> (OutputBufferedActivity -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([OutputBufferedActivity] -> [OutputBufferedActivity]
forall a. [a] -> [a]
reverse [OutputBufferedActivity]
l) ((OutputBufferedActivity -> IO ()) -> IO ())
-> (OutputBufferedActivity -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \OutputBufferedActivity
ba -> case OutputBufferedActivity
ba of
Output Text
t -> Text -> IO ()
emit Text
t
InTempFile String
tmp Bool
_ -> do
Text -> IO ()
emit (Text -> IO ()) -> IO Text -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Text
T.readFile String
tmp
IO (Maybe ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ()) -> IO ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Maybe ())
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
tryWhenExists (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
tmp
where
outh :: Handle
outh = StdHandle -> Handle
toHandle StdHandle
stdh
emit :: Text -> IO ()
emit Text
t = IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either IOException ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ do
Handle -> Text -> IO ()
T.hPutStr Handle
outh Text
t
Handle -> IO ()
hFlush Handle
outh