{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}
{-# OPTIONS_GHC -O2 #-}
module System.Console.Concurrent.Internal where
import System.IO
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 qualified Data.Text.Lazy as L
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
}
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
-> OutputHandle
OutputHandle
(TMVar Lock
-> TMVar OutputBuffer
-> TMVar OutputBuffer
-> TMVar Integer
-> OutputHandle)
-> IO (TMVar Lock)
-> IO
(TMVar OutputBuffer
-> TMVar OutputBuffer -> TMVar Integer -> 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 -> OutputHandle)
-> IO (TMVar OutputBuffer)
-> IO (TMVar OutputBuffer -> TMVar Integer -> OutputHandle)
forall a b. IO (a -> b) -> IO a -> IO b
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 -> OutputHandle)
-> IO (TMVar OutputBuffer) -> IO (TMVar Integer -> OutputHandle)
forall a b. IO (a -> b) -> IO a -> IO b
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 -> OutputHandle)
-> IO (TMVar Integer) -> IO OutputHandle
forall a b. IO (a -> b) -> IO a -> IO b
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
lockOutput :: (MonadIO m, MonadMask m) => m a -> m a
lockOutput :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
lockOutput = m () -> m () -> m a -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> m c -> m b -> m b
bracket_ (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
takeOutputLock) (IO () -> m ()
forall a. IO a -> m a
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 :: forall a. (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
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
v <- TMVar Lock -> STM (Maybe Lock)
forall a. TMVar a -> STM (Maybe a)
tryTakeTMVar TMVar Lock
l
case 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 a. a -> STM a
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 a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
when locked $ do
(outbuf, errbuf) <- atomically $ (,)
<$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer [])
<*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer [])
emitOutputBuffer StdOut outbuf
emitOutputBuffer StdErr errbuf
return 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 :: forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
withConcurrentOutput m a
a = m a
a m a -> m () -> m a
forall (m :: * -> *) a b.
(HasCallStack, MonadMask m) =>
m a -> m b -> m a
`finally` IO () -> m ()
forall a. IO a -> m a
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
r <- TMVar Integer -> STM Integer
forall a. TMVar a -> STM a
takeTMVar (OutputHandle -> TMVar Integer
outputThreads OutputHandle
globalOutputHandle)
if r <= 0
then putTMVar (outputThreads globalOutputHandle) r
else 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 a. a -> IO a
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 L.Text where
toOutput :: Text -> Text
toOutput = Text -> Text
forall v. Outputable v => v -> Text
toOutput (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
L.toStrict
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 :: forall v. Outputable v => v -> IO ()
outputConcurrent = StdHandle -> v -> IO ()
forall v. Outputable v => StdHandle -> v -> IO ()
outputConcurrent' StdHandle
StdOut
errorConcurrent :: Outputable v => v -> IO ()
errorConcurrent :: forall v. Outputable v => v -> IO ()
errorConcurrent = StdHandle -> v -> IO ()
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 = do
worker <- 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 Bool -> (Bool -> IO ()) -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket IO Bool
setup Bool -> IO ()
cleanup Bool -> IO ()
go
wait worker
where
setup :: IO Bool
setup = IO Bool
tryTakeOutputLock
cleanup :: Bool -> IO ()
cleanup Bool
False = () -> IO ()
forall a. a -> IO a
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
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
newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf
atomically $ putTMVar bv newbuf
h :: Handle
h = StdHandle -> Handle
toHandle StdHandle
stdh
bv :: TMVar OutputBuffer
bv = StdHandle -> TMVar OutputBuffer
bufferFor StdHandle
stdh
type ConcurrentProcessHandle = P.ProcessHandle
waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode
waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode
waitForProcessConcurrent = ConcurrentProcessHandle -> IO ExitCode
P.waitForProcess
createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
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@(_, _, _, h) <- CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
P.createProcess CreateProcess
p
_ <- async $ void $ tryIO $ P.waitForProcess h
return r
createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
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, P.ProcessHandle)
fgProcess :: CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
fgProcess CreateProcess
p = do
r@(_, _, _, h) <- CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
P.createProcess CreateProcess
p
IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-> IO ()
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` IO ()
dropOutputLock
registerOutputThread
_ <- async $ do
void $ tryIO $ P.waitForProcess h
unregisterOutputThread
dropOutputLock
return r
bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle)
bgProcess :: CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
bgProcess CreateProcess
p = do
let p' :: CreateProcess
p' = CreateProcess
p
{ P.std_out = rediroutput (P.std_out p)
, P.std_err = rediroutput (P.std_err p)
}
IO ()
registerOutputThread
(stdin_h, stdout_h, stderr_h, h) <- CreateProcess
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
P.createProcess CreateProcess
p'
IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
-> IO ()
-> IO
(Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)
forall (m :: * -> *) a b.
(HasCallStack, MonadCatch m) =>
m a -> m b -> m a
`onException` IO ()
unregisterOutputThread
let r =
( Maybe Handle
stdin_h
, StdStream -> Maybe Handle -> Maybe Handle
forall {a}. StdStream -> Maybe a -> Maybe a
mungeret (CreateProcess -> StdStream
P.std_out CreateProcess
p) Maybe Handle
stdout_h
, StdStream -> Maybe Handle -> Maybe Handle
forall {a}. StdStream -> Maybe a -> Maybe a
mungeret (CreateProcess -> StdStream
P.std_err CreateProcess
p) Maybe Handle
stderr_h
, ConcurrentProcessHandle
h
)
_ <- async $ void $ tryIO $ P.waitForProcess h
outbuf <- setupOutputBuffer StdOut (mungebuf (P.std_out p) stdout_h)
errbuf <- setupOutputBuffer StdErr (mungebuf (P.std_err p) stderr_h)
void $ async $ bufferWriter [outbuf, errbuf]
return r
where
rediroutput :: StdStream -> StdStream
rediroutput StdStream
ss
| StdStream -> Bool
willOutput StdStream
ss = StdStream
P.CreatePipe
| Bool
otherwise = StdStream
ss
mungebuf :: StdStream -> Maybe a -> Maybe a
mungebuf StdStream
ss Maybe a
mh
| StdStream -> Bool
willOutput StdStream
ss = Maybe a
mh
| Bool
otherwise = Maybe a
forall a. Maybe a
Nothing
mungeret :: StdStream -> Maybe a -> Maybe a
mungeret StdStream
ss Maybe a
mh
| StdStream -> Bool
willOutput StdStream
ss = Maybe a
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe a
mh
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
$c== :: OutputBuffer -> OutputBuffer -> Bool
== :: OutputBuffer -> OutputBuffer -> Bool
$c/= :: OutputBuffer -> OutputBuffer -> Bool
/= :: 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
$c== :: OutputBufferedActivity -> OutputBufferedActivity -> Bool
== :: OutputBufferedActivity -> OutputBufferedActivity -> Bool
$c/= :: OutputBufferedActivity -> OutputBufferedActivity -> Bool
/= :: 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
$c== :: AtEnd -> AtEnd -> Bool
== :: AtEnd -> AtEnd -> Bool
$c/= :: AtEnd -> AtEnd -> Bool
/= :: AtEnd -> AtEnd -> Bool
Eq
data BufSig = BufSig
setupOutputBuffer :: StdHandle -> Maybe Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
setupOutputBuffer :: StdHandle
-> Maybe Handle
-> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)
setupOutputBuffer StdHandle
h Maybe Handle
fromh = do
buf <- OutputBuffer -> IO (MVar OutputBuffer)
forall a. a -> IO (MVar a)
newMVar ([OutputBufferedActivity] -> OutputBuffer
OutputBuffer [])
bufsig <- atomically newEmptyTMVar
bufend <- atomically newEmptyTMVar
void $ async $ outputDrainer fromh buf bufsig bufend
return (h, buf, bufsig, bufend)
outputDrainer :: Maybe Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()
outputDrainer :: Maybe Handle
-> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()
outputDrainer Maybe Handle
mfromh MVar OutputBuffer
buf TMVar BufSig
bufsig TMVar AtEnd
bufend = case Maybe Handle
mfromh of
Maybe Handle
Nothing -> IO ()
atend
Just Handle
fromh -> Handle -> IO ()
go Handle
fromh
where
go :: Handle -> IO ()
go Handle
fromh = do
t <- Handle -> IO Text
T.hGetChunk Handle
fromh
if T.null t
then do
atend
hClose fromh
else do
modifyMVar_ buf $ addOutputBuffer (Output t)
changed
go fromh
atend :: IO ()
atend = 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
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
activitysig <- STM (TMVar ()) -> IO (TMVar ())
forall a. STM a -> IO a
atomically STM (TMVar ())
forall a. STM (TMVar a)
newEmptyTMVar
worker1 <- async $ lockOutput $
ifM (atomically $ tryPutTMVar activitysig ())
( void $ mapConcurrently displaybuf ts
, noop
)
worker2 <- async $ void $ globalbuf activitysig worker1
void $ async $ do
void $ waitCatch worker1
void $ waitCatch worker2
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
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)
l <- takeMVar buf
putMVar buf (OutputBuffer [])
emitOutputBuffer outh l
case 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
globalbuf :: TMVar () -> Async a -> IO ()
globalbuf TMVar ()
activitysig Async a
worker1 = do
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
ok <- TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
activitysig ()
when ok $
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) ts
return ok
when ok $ do
bs <- forM ts $ \(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
atomically $
forM_ bs $ \(StdHandle
outh, OutputBuffer
b) ->
StdHandle -> OutputBuffer -> STM ()
bufferOutputSTM' StdHandle
outh OutputBuffer
b
cancel 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 a. a -> IO a
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
tmpdir <- IO String
getTemporaryDirectory
(tmp, h) <- openTempFile tmpdir "output.tmp"
let !endnl = Text -> Bool
endsNewLine Text
t'
let i = InTempFile
{ tempFile :: String
tempFile = String
tmp
, endsInNewLine :: Bool
endsInNewLine = Bool
endnl
}
T.hPutStr h t'
hClose h
return $ OutputBuffer (i : 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 a. a -> IO a
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 :: forall v. Outputable v => 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 buf) <- TMVar OutputBuffer -> STM OutputBuffer
forall a. TMVar a -> STM a
takeTMVar TMVar OutputBuffer
bv
putTMVar bv (OutputBuffer (newbuf ++ 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
(selected, 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
when (selected == OutputBuffer [])
retry
putTMVar bv rest
return (h, 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
&& HasCallStack => Text -> Char
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