{-# 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ TMVar Lock
-> TMVar OutputBuffer
-> TMVar OutputBuffer
-> TMVar Integer
-> TMVar [Async ()]
-> TMVar ()
-> OutputHandle
OutputHandle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO (TMVar a)
newEmptyTMVarIO
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TMVar a)
newTMVarIO ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TMVar a)
newTMVarIO ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TMVar a)
newTMVarIO Integer
0
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (TMVar a)
newTMVarIO []
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IO (TMVar a)
newEmptyTMVarIO
lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
lockOutput :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput = forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
bracket_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
takeOutputLock) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
dropOutputLock)
takeOutputLock :: IO ()
takeOutputLock :: IO ()
takeOutputLock = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 :: forall a. (TMVar Lock -> STM a) -> IO a
withLock TMVar Lock -> STM a
a = forall a. STM a -> IO a
atomically 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 <- forall a. (TMVar Lock -> STM a) -> IO a
withLock forall a b. (a -> b) -> a -> b
$ \TMVar Lock
l -> do
Maybe Lock
v <- forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar Lock
l
case Maybe Lock
v of
Just Lock
Locked
| Bool
block -> forall a. STM a
retry
| Bool
otherwise -> do
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Lock
l Lock
Locked
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe Lock
Nothing -> do
forall a. TMVar a -> a -> STM ()
putTMVar TMVar Lock
l Lock
Locked
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
locked forall a b. (a -> b) -> a -> b
$ do
(OutputBuffer
outbuf, OutputBuffer
errbuf) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ (,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TMVar a -> a -> STM a
swapTMVar (OutputHandle -> TMVar OutputBuffer
outputBuffer OutputHandle
globalOutputHandle) ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
locked
dropOutputLock :: IO ()
dropOutputLock :: IO ()
dropOutputLock = forall a. (TMVar Lock -> STM a) -> IO a
withLock forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TMVar a -> STM a
takeTMVar
withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a
withConcurrentOutput :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withConcurrentOutput m a
a = m a
a forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
flushConcurrentOutput
flushConcurrentOutput :: IO ()
flushConcurrentOutput :: IO ()
flushConcurrentOutput = do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Integer
r <- forall a. TMVar a -> STM a
takeTMVar (OutputHandle -> TMVar Integer
outputThreads OutputHandle
globalOutputHandle)
if Integer
r forall a. Ord a => a -> a -> Bool
<= Integer
0
then forall a. TMVar a -> a -> STM ()
putTMVar (OutputHandle -> TMVar Integer
outputThreads OutputHandle
globalOutputHandle) Integer
r
else forall a. STM a
retry
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> a
id
instance Outputable String where
toOutput :: String -> Text
toOutput = forall v. Outputable v => v -> Text
toOutput forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
outputConcurrent :: Outputable v => v -> IO ()
outputConcurrent :: forall v. Outputable v => v -> IO ()
outputConcurrent = forall v. Outputable v => StdHandle -> v -> IO ()
outputConcurrent' StdHandle
StdOut
errorConcurrent :: Outputable v => v -> IO ()
errorConcurrent :: forall v. Outputable v => v -> IO ()
errorConcurrent = forall v. Outputable v => StdHandle -> v -> IO ()
outputConcurrent' StdHandle
StdErr
outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()
outputConcurrent' :: forall v. Outputable v => StdHandle -> v -> IO ()
outputConcurrent' StdHandle
stdh v
v = 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 = 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 (forall v. Outputable v => v -> Text
toOutput v
v)
Handle -> IO ()
hFlush Handle
h
go Bool
False = do
OutputBuffer
oldbuf <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar OutputBuffer
bv
OutputBuffer
newbuf <- OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer
addOutputBuffer (Text -> OutputBufferedActivity
Output (forall v. Outputable v => v -> Text
toOutput v
v)) OutputBuffer
oldbuf
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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) =
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 = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
lck ()
unlock :: Bool -> IO ()
unlock Bool
True = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
takeTMVar TMVar ()
lck
unlock Bool
False = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkexit :: Bool -> IO ExitCode
checkexit Bool
locked = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> IO ExitCode
waitsome Bool
locked) forall (m :: * -> *) a. Monad m => a -> m a
return
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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM a
readTMVar TMVar [Async ()]
v
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Async ()]
l
then ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
else do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ forall a. [Async a] -> IO (Async a, a)
waitAny [Async ()]
l
Bool -> IO ExitCode
checkexit Bool
True
waitsome Bool
False = do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
lck ()
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 <- forall a. IO (TMVar a)
newEmptyTMVarIO
Async ()
waiter <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ do
Async ()
self <- forall a. STM a -> IO a
atomically (forall a. TMVar a -> STM a
takeTMVar TMVar (Async ())
regdone)
IO ()
waitaction 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 = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
[Async ()]
l <- forall a. TMVar a -> STM a
takeTMVar TMVar [Async ()]
v
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [Async ()]
v (Async ()
waiterforall a. a -> [a] -> [a]
:[Async ()]
l)
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Async ())
regdone Async ()
waiter
unregister :: Async () -> IO ()
unregister Async ()
waiter = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
[Async ()]
l <- forall a. TMVar a -> STM a
takeTMVar TMVar [Async ()]
v
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [Async ()]
v (forall a. (a -> Bool) -> [a] -> [a]
filter (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) =
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 forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
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
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` IO ()
dropOutputLock
IO ()
registerOutputThread
IO () -> IO ()
asyncProcessWaiter forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
IO ()
unregisterOutputThread
IO ()
dropOutputLock
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'
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` IO ()
unregisterOutputThread
IO () -> IO ()
asyncProcessWaiter forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO 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
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
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]
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
(,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fd -> IO Handle
fdToHandle Fd
to 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
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
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
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 <- forall a. a -> IO (MVar a)
newMVar ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
TMVar BufSig
bufsig <- forall a. STM a -> IO a
atomically forall a. STM (TMVar a)
newEmptyTMVar
TMVar AtEnd
bufend <- forall a. STM a -> IO a
atomically forall a. STM (TMVar a)
newEmptyTMVar
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
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
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
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar OutputBuffer
buf 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
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar AtEnd
bufend AtEnd
AtEnd
Handle -> IO ()
hClose Handle
fromh
changed :: IO ()
changed = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar BufSig
bufsig
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
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar Integer
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
succ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM ()
putTMVar TMVar Integer
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> a
pred forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 <- forall a. STM a -> IO a
atomically forall a. STM (TMVar a)
newEmptyTMVar
Async ()
worker1 <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
activitysig ())
( forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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
, forall (m :: * -> *). Monad m => m ()
noop
)
Async ()
worker2 <- forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall {a}. TMVar () -> Async a -> IO ()
globalbuf TMVar ()
activitysig Async ()
worker1
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. Async a -> IO (Either SomeException a)
waitCatch Async ()
worker1
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
(forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TMVar a -> STM a
takeTMVar TMVar BufSig
bufsig)
forall a. STM a -> STM a -> STM a
`orElse`
(forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TMVar a -> STM a
takeTMVar TMVar AtEnd
bufend)
OutputBuffer
l <- forall a. MVar a -> IO a
takeMVar MVar OutputBuffer
buf
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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
globalbuf :: TMVar () -> Async a -> IO ()
globalbuf TMVar ()
activitysig Async a
worker1 = do
Bool
ok <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
Bool
ok <- forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
activitysig ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok forall a b. (a -> b) -> a -> b
$
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) -> forall a. TMVar a -> STM a
takeTMVar TMVar AtEnd
bufend) [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)]
ts
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
ok
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok forall a b. (a -> b) -> a -> b
$ do
[(StdHandle, OutputBuffer)]
bs <- 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 forall a b. (a -> b) -> a -> b
$ \(StdHandle
outh, MVar OutputBuffer
buf, TMVar BufSig
_bufsig, TMVar AtEnd
_bufend) ->
(StdHandle
outh,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. MVar a -> IO a
takeMVar MVar OutputBuffer
buf
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(StdHandle, OutputBuffer)]
bs forall a b. (a -> b) -> a -> b
$ \(StdHandle
outh, OutputBuffer
b) ->
StdHandle -> OutputBuffer -> STM ()
bufferOutputSTM' StdHandle
outh OutputBuffer
b
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' forall a. Ord a => a -> a -> Bool
<= Int
1048576 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [OutputBufferedActivity] -> OutputBuffer
OutputBuffer (Text -> OutputBufferedActivity
Output Text
t' 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
{ tempFile :: String
tempFile = String
tmp
, endsInNewLine :: Bool
endsInNewLine = Bool
endnl
}
Handle -> Text -> IO ()
T.hPutStr Handle
h Text
t'
Handle -> IO ()
hClose Handle
h
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [OutputBufferedActivity] -> OutputBuffer
OutputBuffer (OutputBufferedActivity
i forall a. a -> [a] -> [a]
: [OutputBufferedActivity]
other)
where
!t' :: Text
t' = [Text] -> Text
T.concat (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OutputBufferedActivity -> Maybe Text
getOutput [OutputBufferedActivity]
this) forall a. Semigroup a => a -> a -> a
<> Text
t
!([OutputBufferedActivity]
this, [OutputBufferedActivity]
other) = 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'' -> forall a. a -> Maybe a
Just Text
t''
OutputBufferedActivity
_ -> forall a. Maybe a
Nothing
addOutputBuffer OutputBufferedActivity
v (OutputBuffer [OutputBufferedActivity]
buf) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [OutputBufferedActivity] -> OutputBuffer
OutputBuffer (OutputBufferedActivity
vforall a. a -> [a] -> [a]
:[OutputBufferedActivity]
buf)
bufferOutputSTM :: Outputable v => StdHandle -> v -> STM ()
bufferOutputSTM :: forall v. Outputable v => StdHandle -> v -> STM ()
bufferOutputSTM StdHandle
h v
v = StdHandle -> OutputBuffer -> STM ()
bufferOutputSTM' StdHandle
h ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [Text -> OutputBufferedActivity
Output (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) <- forall a. TMVar a -> STM a
takeTMVar TMVar OutputBuffer
bv
forall a. TMVar a -> a -> STM ()
putTMVar TMVar OutputBuffer
bv ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer ([OutputBufferedActivity]
newbuf 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 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TMVar a -> STM a
takeTMVar TMVar OutputBuffer
bv
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (OutputBuffer
selected forall a. Eq a => a -> a -> Bool
== [OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
forall a. STM a
retry
forall a. TMVar a -> a -> STM ()
putTMVar TMVar OutputBuffer
bv OutputBuffer
rest
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) = 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 forall a. Eq a => a -> a -> Bool
== Char
'\n'
emitOutputBuffer :: StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer :: StdHandle -> OutputBuffer -> IO ()
emitOutputBuffer StdHandle
stdh (OutputBuffer [OutputBufferedActivity]
l) =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [OutputBufferedActivity]
l) 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 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO Text
T.readFile String
tmp
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
tryWhenExists 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 = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either IOException a)
tryIO forall a b. (a -> b) -> a -> b
$ do
Handle -> Text -> IO ()
T.hPutStr Handle
outh Text
t
Handle -> IO ()
hFlush Handle
outh