{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -O2 #-}
{- Building this module with -O0 causes streams not to fuse and too much
 - memory to be used. -}

-- | 
-- Copyright: 2015 Joey Hess <id@joeyh.name>
-- License: BSD-2-clause
-- 
-- Concurrent output handling, internals.
--
-- May change at any time.

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

-- | A shared global variable for the OutputHandle.
{-# 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

-- | Holds a lock while performing an action. This allows the action to
-- perform its own output to the console, without using functions from this
-- module.
--
-- While this is running, other threads that try to lockOutput will block.
-- Any calls to `outputConcurrent` and `createProcessConcurrent` will not
-- block, but the output will be buffered and displayed only once the
-- action is done.
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)

-- | Blocks until we have the output lock.
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

-- | Tries to take the output lock, without blocking.
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
					-- Restore value we took.
					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

-- | Only safe to call after taking the output lock.
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

-- | Use this around any actions that use `outputConcurrent`
-- or `createProcessConcurrent`
--
-- This is necessary to ensure that buffered concurrent output actually
-- gets displayed before the program exits.
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

-- | Blocks until any processes started by `createProcessConcurrent` have
-- finished, and any buffered output is displayed. Also blocks while
-- `lockOutput` is is use.
--
-- `withConcurrentOutput` calls this at the end, so you do not normally
-- need to use this.
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
	-- Take output lock to wait for anything else that might be
	-- currently generating output.
	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 ()

-- | Values that can be output.
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

-- | Displays a value to stdout.
--
-- No newline is appended to the value, so if you want a newline, be sure
-- to include it yourself.
--
-- Uses locking to ensure that the whole output occurs atomically
-- even when other threads are concurrently generating output.
--
-- When something else is writing to the console at the same time, this does
-- not block. It buffers the value, so it will be displayed once the other
-- writer is done.
outputConcurrent :: Outputable v => v -> IO ()
outputConcurrent :: v -> IO ()
outputConcurrent = StdHandle -> v -> IO ()
forall v. Outputable v => StdHandle -> v -> IO ()
outputConcurrent' StdHandle
StdOut

-- | Like `outputConcurrent`, but displays to stderr.
--
-- (Does not throw an exception.)
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)

-- | Use this to wait for processes started with 
-- `createProcessConcurrent` and `createProcessForeground`, and get their
-- exit status.
--
-- Note that such processes are actually automatically waited for
-- internally, so not calling this explicitly will not result
-- in zombie processes. This behavior differs from `P.waitForProcess`
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
			-- Avoid waitAny [] which blocks forever
			then ProcessHandle -> IO ExitCode
P.waitForProcess ProcessHandle
h
			else do
				-- Wait for any of the running
				-- processes to exit. It may or may not
				-- be the one corresponding to the
				-- ProcessHandle. If it is,
				-- getProcessExitCode will succeed.
				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
		-- Another thread took the lck first. Wait for that thread to
		-- wait for one of the running processes to exit.
		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

-- Registers an action that waits for a process to exit,
-- adding it to the processWaiters list, and removing it once the action
-- completes.
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)

-- | Wrapper around `System.Process.createProcess` that prevents 
-- multiple processes that are running concurrently from writing
-- to stdout/stderr at the same time.
--
-- If the process does not output to stdout or stderr, it's run
-- by createProcess entirely as usual. Only processes that can generate
-- output are handled specially:
--
-- A process is allowed to write to stdout and stderr in the usual
-- way, assuming it can successfully take the output lock.
--
-- When the output lock is held (ie, by another concurrent process,
-- or because `outputConcurrent` is being called at the same time),
-- the process is instead run with its stdout and stderr
-- redirected to a buffer. The buffered output will be displayed as soon
-- as the output lock becomes free.
--
-- Currently only available on Unix systems, not Windows.
#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

-- | Wrapper around `System.Process.createProcess` that makes sure a process
-- is run in the foreground, with direct access to stdout and stderr.
-- Useful when eg, running an interactive process.
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
	-- Wait for the process to exit and drop the lock.
	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

-- | Buffered output.
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)

-- Drain output from the handle, and buffer it.
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

-- Wait to lock output, and once we can, display everything 
-- that's put into the buffers, until the end.
--
-- If end is reached before lock is taken, instead add the command's
-- buffers to the global outputBuffer and errorBuffer.
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 -- buffers already moved to global
			)
	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
			-- signal we're going to handle it
			-- (returns false if the displaybuf already did)
			Bool
ok <- TMVar () -> () -> STM Bool
forall a. TMVar a -> a -> STM Bool
tryPutTMVar TMVar ()
activitysig ()
			-- wait for end of all buffers
			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
			-- add all of the command's buffered output to the
			-- global output buffer, atomically
			[(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
			-- worker1 might be blocked waiting for the output
			-- lock, and we've already done its job, so cancel it
			Async a -> IO ()
forall a. Async a -> IO ()
cancel Async a
worker1

-- Adds a value to the OutputBuffer. When adding Output to a Handle,
-- it's cheaper to combine it with any already buffered Output to that
-- same Handle.
--
-- When the total buffered Output exceeds 1 mb in size, it's moved out of
-- memory, to a temp file. This should only happen rarely, but is done to
-- avoid some verbose process unexpectedly causing excessive memory use.
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)

-- | Adds a value to the output buffer for later display.
--
-- Note that buffering large quantities of data this way will keep it
-- resident in memory until it can be displayed. While `outputConcurrent`
-- uses temp files if the buffer gets too big, this STM function cannot do
-- so.
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

-- | A STM action that waits for some buffered output to become
-- available, and returns it.
--
-- The function can select a subset of output when only some is desired;
-- the fst part is returned and the snd is left in the buffer.
--
-- This will prevent it from being displayed in the usual way, so you'll
-- need to use `emitOutputBuffer` to display it yourself.
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 [])

-- | Use with `outputBufferWaiterSTM` to make it only return buffered
-- output that ends with a newline. Anything buffered without a newline
-- is left in the buffer.
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'

-- | Emits the content of the OutputBuffer to the Handle
--
-- If you use this, you should use `lockOutput` to ensure you're the only
-- thread writing to the console.
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