concurrent-output 1.1.0 → 1.2.0

raw patch · 11 files changed

+938/−627 lines, 11 filesdep −bytestringdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: bytestring

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG +15/−0
• System/Console/Concurrent.hs +4/−450
• System/Console/Concurrent/Internal.hs +522/−0
• System/Console/Regions.hs +330/−157
• System/Process/Concurrent.hs +34/−0
• TODO +4/−5
• aptdemo.hs +18/−7
• concurrent-output.cabal +4/−3
• demo.hs +1/−1
• demo2.hs +1/−1
• demo3.hs +5/−3

@@ -1,3 +1,18 @@+concurrent-output (1.2.0) unstable; urgency=medium++  * Avoid crash when not all of a program's output is consumed, as+    happens when eg, piping to head(1).+  * Use text, and not bytestring internally.+  * Added createProcessForeground, useful for running commands like vim.+  * Fix race that sometimes caused processes to run in background mode+    even though no other foreground process was still running.+  * Concurrent process functions now use ConcurrentProcessHandle+    instead of ProcessHandle.+  * Multi-line regions now supported.+  * Optimize region update, avoiding outputting characters already on-screen.++ -- Joey Hess <id@joeyh.name>  Mon, 02 Nov 2015 23:25:40 -0400+ concurrent-output (1.1.0) unstable; urgency=medium    * Renamed module.

@@ -1,7 +1,5 @@-{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}- -- | --- Copyright: 2013 Joey Hess <id@joeyh.name>+-- Copyright: 2015 Joey Hess <id@joeyh.name> -- License: BSD-2-clause --  -- Concurrent output handling.@@ -21,8 +19,10 @@ 	withConcurrentOutput, 	Outputable(..), 	outputConcurrent,+	ConcurrentProcessHandle, 	createProcessConcurrent, 	waitForProcessConcurrent,+	createProcessForeground, 	flushConcurrentOutput, 	lockOutput, 	-- * Low level access to the output buffer@@ -35,451 +35,5 @@ 	emitOutputBuffer, ) where -import System.IO-import System.Posix.IO-import System.Directory-import System.Exit-import Control.Monad-import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Applicative-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 Data.Char-import qualified System.Process as P-import qualified Data.ByteString as B-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8)--import Utility.Monad-import Utility.Exception--data OutputHandle = OutputHandle-	{ outputLock :: TMVar Lock-	, outputBuffer :: TMVar OutputBuffer-	, errorBuffer :: TMVar OutputBuffer-	, outputThreads :: TMVar Integer-	}--data Lock = Locked---- | A shared global variable for the OutputHandle.-{-# NOINLINE globalOutputHandle #-}-globalOutputHandle :: OutputHandle-globalOutputHandle = unsafePerformIO $ OutputHandle-	<$> newEmptyTMVarIO-	<*> newTMVarIO (OutputBuffer [])-	<*> newTMVarIO (OutputBuffer [])-	<*> newTMVarIO 0---- | 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 = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock)---- | Blocks until we have the output lock.-takeOutputLock :: IO ()-takeOutputLock = void $ takeOutputLock' True---- | Tries to take the output lock, without blocking.-tryTakeOutputLock :: IO Bool-tryTakeOutputLock = takeOutputLock' False--withLock :: (TMVar Lock -> STM a) -> IO a-withLock a = atomically $ a (outputLock globalOutputHandle)--takeOutputLock' :: Bool -> IO Bool-takeOutputLock' block = do-	locked <- withLock $ \l -> do-		v <- tryTakeTMVar l-		case v of-			Just Locked-				| block -> retry-				| otherwise -> do-					-- Restore value we took.-					putTMVar l Locked-					return False-			Nothing -> do-				putTMVar l Locked-				return True-	when locked $ do-		(outbuf, errbuf) <- atomically $ (,)-			<$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer [])-			<*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer [])-		emitOutputBuffer StdOut outbuf-		emitOutputBuffer StdErr errbuf-	return locked---- | Only safe to call after taking the output lock.-dropOutputLock :: IO ()-dropOutputLock = withLock $ void . 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 a = a `finally` liftIO flushConcurrentOutput---- | Blocks until any processes started by `createProcessConcurrent` have--- finished, and any buffered output is displayed. ------ `withConcurrentOutput` calls this at the end; you can call it anytime--- you want to flush output.-flushConcurrentOutput :: IO ()-flushConcurrentOutput = do-	-- Wait for all outputThreads to finish.-	let v = outputThreads globalOutputHandle-	atomically $ do-		r <- takeTMVar v-		if r <= 0-			then putTMVar v r-			else retry-	-- Take output lock to ensure that nothing else is currently-	-- generating output, and flush any buffered output.-	lockOutput $ return ()---- | Values that can be output.-class Outputable v where-	toOutput :: v -> B.ByteString--instance Outputable B.ByteString where-	toOutput = id--instance Outputable T.Text where-	toOutput = encodeUtf8--instance Outputable String where-	toOutput = toOutput . 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 = bracket setup cleanup go-  where-	setup = tryTakeOutputLock-	cleanup False = return ()-	cleanup True = dropOutputLock-	go True = do-		B.hPut stdout (toOutput v)-		hFlush stdout-	go False = do-		let bv = outputBuffer globalOutputHandle-		oldbuf <- atomically $ takeTMVar bv-		newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf-		atomically $ putTMVar bv newbuf---- | This must be used to wait for processes started with --- `createProcessConcurrent`.------ This is necessary because `System.Process.waitForProcess` has a--- race condition when two threads check the same process. If the race--- is triggered, one thread will successfully wait, but the other--- throws a DoesNotExist exception.-waitForProcessConcurrent :: P.ProcessHandle -> IO ExitCode-waitForProcessConcurrent h = do-	v <- tryWhenExists (P.waitForProcess h)-	case v of-		Just r -> return r-		Nothing -> maybe (waitForProcessConcurrent h) return =<< P.getProcessExitCode h---- | 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, or after the command has finished.-createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -createProcessConcurrent p-	| willOutput (P.std_out p) || willOutput (P.std_err p) =-		ifM tryTakeOutputLock-			( firstprocess-			, concurrentprocess-			)-	| otherwise = P.createProcess p-  where-	rediroutput ss h-		| willOutput ss = P.UseHandle h-		| otherwise = ss--	firstprocess = do-		r@(_, _, _, h) <- P.createProcess p-			`onException` dropOutputLock-		-- Wait for the process to exit and drop the lock.-		void $ async $ do-			void $ tryIO $ waitForProcessConcurrent h-			dropOutputLock-		return r-	-	concurrentprocess = do-		(toouth, fromouth) <- pipe-		(toerrh, fromerrh) <- pipe-		let p' = p-			{ P.std_out = rediroutput (P.std_out p) toouth-			, P.std_err = rediroutput (P.std_err p) toerrh-			}-		registerOutputThread-		r <- P.createProcess p'-			`onException` unregisterOutputThread-		outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth-		errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh-		void $ async $ bufferWriter [outbuf, errbuf]-		return r--	pipe = do-		(from, to) <- createPipe-		(,) <$> fdToHandle to <*> fdToHandle from--willOutput :: P.StdStream -> Bool-willOutput P.Inherit = True-willOutput _ = False---- | Buffered output.-data OutputBuffer = OutputBuffer [OutputBufferedActivity]-	deriving (Eq)--data StdHandle = StdOut | StdErr--toHandle :: StdHandle -> Handle-toHandle StdOut = stdout-toHandle StdErr = stderr--bufferFor :: StdHandle -> TMVar OutputBuffer-bufferFor StdOut = outputBuffer globalOutputHandle-bufferFor StdErr = errorBuffer globalOutputHandle--data OutputBufferedActivity-	= Output B.ByteString-	| InTempFile-		{ tempFile :: FilePath-		, endsInNewLine :: Bool-		}-	deriving (Eq)--data AtEnd = AtEnd-	deriving Eq--data BufSig = BufSig--setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)-setupOutputBuffer h toh ss fromh = do-	hClose toh-	buf <- newMVar (OutputBuffer [])-	bufsig <- atomically newEmptyTMVar-	bufend <- atomically newEmptyTMVar-	void $ async $ outputDrainer ss fromh buf bufsig bufend-	return (h, buf, bufsig, bufend)---- Drain output from the handle, and buffer it.-outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()-outputDrainer ss fromh buf bufsig bufend-	| willOutput ss = go-	| otherwise = atend-  where-	go = do-		v <- tryIO $ B.hGetSome fromh 1048576-		case v of-			Right b | not (B.null b) -> do-				modifyMVar_ buf $ addOutputBuffer (Output b)-				changed-				go-			_ -> atend-	atend = do-		atomically $ putTMVar bufend AtEnd-		hClose fromh-	changed = atomically $ do-		void $ tryTakeTMVar bufsig-		putTMVar bufsig BufSig--registerOutputThread :: IO ()-registerOutputThread = do-	hFlush stdout-	let v = outputThreads globalOutputHandle-	atomically $ putTMVar v . succ =<< takeTMVar v-	-unregisterOutputThread :: IO ()-unregisterOutputThread = do-	hFlush stdout-	let v = outputThreads globalOutputHandle-	atomically $ putTMVar v . pred =<< takeTMVar 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 ts = do-	activitysig <- atomically newEmptyTMVar-	worker1 <- async $ lockOutput $-		ifM (atomically $ tryPutTMVar activitysig ())-			( void $ mapConcurrently displaybuf ts-			, noop -- buffers already moved to global-			)-	worker2 <- async $ void $ globalbuf activitysig-	void $ async $ do-		void $ waitCatch worker1-		void $ waitCatch worker2-		unregisterOutputThread-  where-	displaybuf v@(outh, buf, bufsig, bufend) = do-		change <- atomically $-			(Right <$> takeTMVar bufsig)-				`orElse`-			(Left <$> takeTMVar bufend)-		l <- takeMVar buf-		putMVar buf (OutputBuffer [])-		emitOutputBuffer outh l-		case change of-			Right BufSig -> displaybuf v-			Left AtEnd -> return ()-	globalbuf activitysig = do-		ok <- atomically $ do-			-- signal we're going to handle it-			-- (returns false if the displaybuf already did)-			ok <- tryPutTMVar activitysig ()-			-- wait for end of all buffers-			when ok $-				mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts-			return ok-		when ok $ do-			-- add all of the command's buffered output to the-			-- global output buffer, atomically-			bs <- forM ts $ \(outh, buf, _bufsig, _bufend) ->-				(outh,) <$> takeMVar buf-			atomically $-				forM_ bs $ \(outh, b) -> -					bufferOutputSTM' outh b---- 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 (Output b) (OutputBuffer buf)-	| B.length b' <= 1048576 = return $ OutputBuffer (Output b' : other)-	| otherwise = do-		tmpdir <- getTemporaryDirectory-		(tmp, h) <- openTempFile tmpdir "output.tmp"-		let !endnl = endsNewLine b'-		let i = InTempFile-			{ tempFile = tmp-			, endsInNewLine = endnl-			}-		B.hPut h b'-		hClose h-		return $ OutputBuffer (i : other)-  where-	!b' = B.concat (mapMaybe getOutput this) <> b-	!(this, other) = partition isOutput buf-	isOutput v = case v of-		Output _ -> True-		_ -> False-	getOutput v = case v of-		Output b'' -> Just b''-		_ -> Nothing-addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v: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 h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)])--bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM ()-bufferOutputSTM' h (OutputBuffer newbuf) = do-	(OutputBuffer buf) <- takeTMVar bv-	putTMVar bv (OutputBuffer (newbuf ++ buf))-  where-	bv = bufferFor 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 selector = do-	bs <- forM hs $ \h -> do-		let bv = bufferFor h-		(selected, rest) <- selector <$> takeTMVar bv-		putTMVar bv rest-		return selected-	if all (== OutputBuffer []) bs-		then retry-		else do-			return (zip hs bs)-  where-	hs = [StdOut, StdErr]--waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)-waitAnyBuffer b = (b, 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 l) = -	let (selected, rest) = span completeline l-	in (OutputBuffer selected, OutputBuffer rest)-  where-	completeline (v@(InTempFile {})) = endsInNewLine v-	completeline (Output b) = endsNewLine b--endsNewLine :: B.ByteString -> Bool-endsNewLine b = not (B.null b) && B.last b == fromIntegral (ord '\n')+import System.Console.Concurrent.Internal --- | 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 stdh (OutputBuffer l) = -	forM_ (reverse l) $ \ba -> case ba of-		Output b -> do-			B.hPut outh b-			hFlush outh-		InTempFile tmp _ -> do-			B.hPut outh =<< B.readFile tmp-			void $ tryWhenExists $ removeFile tmp-  where-	outh = toHandle stdh

@@ -0,0 +1,522 @@+{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}++-- | +-- 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+import System.Posix.IO+import System.Directory+import System.Exit+import Control.Monad+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Applicative+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 Utility.Monad+import Utility.Exception++data OutputHandle = OutputHandle+	{ outputLock :: TMVar Lock+	, outputBuffer :: TMVar OutputBuffer+	, errorBuffer :: TMVar OutputBuffer+	, outputThreads :: TMVar Integer+	, processWaiters :: TMVar [Async ()]+	, waitForProcessLock :: TMVar ()+	}++data Lock = Locked++-- | A shared global variable for the OutputHandle.+{-# NOINLINE globalOutputHandle #-}+globalOutputHandle :: OutputHandle+globalOutputHandle = unsafePerformIO $ OutputHandle+	<$> newEmptyTMVarIO+	<*> newTMVarIO (OutputBuffer [])+	<*> newTMVarIO (OutputBuffer [])+	<*> newTMVarIO 0+	<*> newTMVarIO []+	<*> 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 = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock)++-- | Blocks until we have the output lock.+takeOutputLock :: IO ()+takeOutputLock = void $ takeOutputLock' True++-- | Tries to take the output lock, without blocking.+tryTakeOutputLock :: IO Bool+tryTakeOutputLock = takeOutputLock' False++withLock :: (TMVar Lock -> STM a) -> IO a+withLock a = atomically $ a (outputLock globalOutputHandle)++takeOutputLock' :: Bool -> IO Bool+takeOutputLock' block = do+	locked <- withLock $ \l -> do+		v <- tryTakeTMVar l+		case v of+			Just Locked+				| block -> retry+				| otherwise -> do+					-- Restore value we took.+					putTMVar l Locked+					return False+			Nothing -> do+				putTMVar l Locked+				return True+	when locked $ do+		(outbuf, errbuf) <- atomically $ (,)+			<$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer [])+			<*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer [])+		emitOutputBuffer StdOut outbuf+		emitOutputBuffer StdErr errbuf+	return locked++-- | Only safe to call after taking the output lock.+dropOutputLock :: IO ()+dropOutputLock = withLock $ void . 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 a = a `finally` liftIO flushConcurrentOutput++-- | Blocks until any processes started by `createProcessConcurrent` have+-- finished, and any buffered output is displayed. +--+-- `withConcurrentOutput` calls this at the end; you can call it anytime+-- you want to flush output.+flushConcurrentOutput :: IO ()+flushConcurrentOutput = do+	-- Wait for all outputThreads to finish.+	let v = outputThreads globalOutputHandle+	atomically $ do+		r <- takeTMVar v+		if r <= 0+			then putTMVar v r+			else retry+	-- Take output lock to ensure that nothing else is currently+	-- generating output, and flush any buffered output.+	lockOutput $ return ()++-- | Values that can be output.+class Outputable v where+	toOutput :: v -> T.Text++instance Outputable T.Text where+	toOutput = id++instance Outputable String where+	toOutput = toOutput . 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 = bracket setup cleanup go+  where+	setup = tryTakeOutputLock+	cleanup False = return ()+	cleanup True = dropOutputLock+	go True = do+		T.hPutStr stdout (toOutput v)+		hFlush stdout+	go False = do+		let bv = outputBuffer globalOutputHandle+		oldbuf <- atomically $ takeTMVar bv+		newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf+		atomically $ putTMVar bv newbuf++newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle++toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle 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 h) = +	bracket lock unlock checkexit+  where+	lck = waitForProcessLock globalOutputHandle+	lock = atomically $ tryPutTMVar lck ()+	unlock True = atomically $ takeTMVar lck+	unlock False = return ()+	checkexit locked = maybe (waitsome locked) return+		=<< P.getProcessExitCode h+	waitsome True = do+		let v = processWaiters globalOutputHandle+		l <- atomically $ readTMVar v+		if null l+			-- Avoid waitAny [] which blocks forever+			then P.waitForProcess 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.+				void $ tryIO $ waitAny l+				checkexit True+	waitsome False = do+		-- Another thread took the lck first. Wait for that thread to+		-- wait for one of the running processes to exit.+		atomically $ do+			putTMVar lck ()+			takeTMVar lck+		checkexit 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 waitaction = do+	regdone <- newEmptyTMVarIO+	waiter <- async $ do+		self <- atomically (takeTMVar regdone)+		waitaction `finally` unregister self+	register waiter regdone+  where+	v = processWaiters globalOutputHandle+  	register waiter regdone = atomically $ do+		l <- takeTMVar v+		putTMVar v (waiter:l)+		putTMVar regdone waiter+	unregister waiter = atomically $ do+		l <- takeTMVar v+		putTMVar v (filter (/= waiter) 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.+createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) +createProcessConcurrent p+	| willOutput (P.std_out p) || willOutput (P.std_err p) =+		ifM tryTakeOutputLock+			( fgProcess p+			, bgProcess p+			)+	| otherwise = do+		r@(_, _, _, h) <- P.createProcess p+		asyncProcessWaiter $+			void $ tryIO $ P.waitForProcess h+		return (toConcurrentProcessHandle r)++-- | 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 p = do+	takeOutputLock+	fgProcess p++fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+fgProcess p = do+	r@(_, _, _, h) <- P.createProcess p+		`onException` dropOutputLock+	-- Wait for the process to exit and drop the lock.+	asyncProcessWaiter $ do+		void $ tryIO $ P.waitForProcess h+		dropOutputLock+	return (toConcurrentProcessHandle r)++bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+bgProcess p = do+	(toouth, fromouth) <- pipe+	(toerrh, fromerrh) <- pipe+	let p' = p+		{ P.std_out = rediroutput (P.std_out p) toouth+		, P.std_err = rediroutput (P.std_err p) toerrh+		}+	registerOutputThread+	r@(_, _, _, h) <- P.createProcess p'+		`onException` unregisterOutputThread+	asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h+	outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth+	errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh+	void $ async $ bufferWriter [outbuf, errbuf]+	return (toConcurrentProcessHandle r)+  where+	pipe = do+		(from, to) <- createPipe+		(,) <$> fdToHandle to <*> fdToHandle from+	rediroutput ss h+		| willOutput ss = P.UseHandle h+		| otherwise = ss++willOutput :: P.StdStream -> Bool+willOutput P.Inherit = True+willOutput _ = False++-- | Buffered output.+data OutputBuffer = OutputBuffer [OutputBufferedActivity]+	deriving (Eq)++data StdHandle = StdOut | StdErr++toHandle :: StdHandle -> Handle+toHandle StdOut = stdout+toHandle StdErr = stderr++bufferFor :: StdHandle -> TMVar OutputBuffer+bufferFor StdOut = outputBuffer globalOutputHandle+bufferFor StdErr = errorBuffer globalOutputHandle++data OutputBufferedActivity+	= Output T.Text+	| InTempFile+		{ tempFile :: FilePath+		, endsInNewLine :: Bool+		}+	deriving (Eq)++data AtEnd = AtEnd+	deriving Eq++data BufSig = BufSig++setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)+setupOutputBuffer h toh ss fromh = do+	hClose toh+	buf <- newMVar (OutputBuffer [])+	bufsig <- atomically newEmptyTMVar+	bufend <- atomically newEmptyTMVar+	void $ async $ outputDrainer ss fromh buf bufsig bufend+	return (h, buf, bufsig, bufend)++-- Drain output from the handle, and buffer it.+outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO ()+outputDrainer ss fromh buf bufsig bufend+	| willOutput ss = go+	| otherwise = atend+  where+	go = do+		t <- T.hGetChunk fromh+		if T.null t+			then atend+			else do+				modifyMVar_ buf $ addOutputBuffer (Output t)+				changed+				go+	atend = do+		atomically $ putTMVar bufend AtEnd+		hClose fromh+	changed = atomically $ do+		void $ tryTakeTMVar bufsig+		putTMVar bufsig BufSig++registerOutputThread :: IO ()+registerOutputThread = do+	let v = outputThreads globalOutputHandle+	atomically $ putTMVar v . succ =<< takeTMVar v+	+unregisterOutputThread :: IO ()+unregisterOutputThread = do+	let v = outputThreads globalOutputHandle+	atomically $ putTMVar v . pred =<< takeTMVar 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 ts = do+	activitysig <- atomically newEmptyTMVar+	worker1 <- async $ lockOutput $+		ifM (atomically $ tryPutTMVar activitysig ())+			( void $ mapConcurrently displaybuf ts+			, noop -- buffers already moved to global+			)+	worker2 <- async $ void $ globalbuf activitysig+	void $ async $ do+		void $ waitCatch worker1+		void $ waitCatch worker2+		unregisterOutputThread+  where+	displaybuf v@(outh, buf, bufsig, bufend) = do+		change <- atomically $+			(Right <$> takeTMVar bufsig)+				`orElse`+			(Left <$> takeTMVar bufend)+		l <- takeMVar buf+		putMVar buf (OutputBuffer [])+		emitOutputBuffer outh l+		case change of+			Right BufSig -> displaybuf v+			Left AtEnd -> return ()+	globalbuf activitysig = do+		ok <- atomically $ do+			-- signal we're going to handle it+			-- (returns false if the displaybuf already did)+			ok <- tryPutTMVar activitysig ()+			-- wait for end of all buffers+			when ok $+				mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts+			return ok+		when ok $ do+			-- add all of the command's buffered output to the+			-- global output buffer, atomically+			bs <- forM ts $ \(outh, buf, _bufsig, _bufend) ->+				(outh,) <$> takeMVar buf+			atomically $+				forM_ bs $ \(outh, b) -> +					bufferOutputSTM' outh b++-- 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 (Output t) (OutputBuffer buf)+	| T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other)+	| otherwise = do+		tmpdir <- getTemporaryDirectory+		(tmp, h) <- openTempFile tmpdir "output.tmp"+		let !endnl = endsNewLine t'+		let i = InTempFile+			{ tempFile = tmp+			, endsInNewLine = endnl+			}+		T.hPutStr h t'+		hClose h+		return $ OutputBuffer (i : other)+  where+	!t' = T.concat (mapMaybe getOutput this) <> t+	!(this, other) = partition isOutput buf+	isOutput v = case v of+		Output _ -> True+		_ -> False+	getOutput v = case v of+		Output t'' -> Just t''+		_ -> Nothing+addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v: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 h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)])++bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM ()+bufferOutputSTM' h (OutputBuffer newbuf) = do+	(OutputBuffer buf) <- takeTMVar bv+	putTMVar bv (OutputBuffer (newbuf ++ buf))+  where+	bv = bufferFor 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 selector = do+	bs <- forM hs $ \h -> do+		let bv = bufferFor h+		(selected, rest) <- selector <$> takeTMVar bv+		putTMVar bv rest+		return selected+	if all (== OutputBuffer []) bs+		then retry+		else do+			return (zip hs bs)+  where+	hs = [StdOut, StdErr]++waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer)+waitAnyBuffer b = (b, 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 l) = +	let (selected, rest) = span completeline l+	in (OutputBuffer selected, OutputBuffer rest)+  where+	completeline (v@(InTempFile {})) = endsInNewLine v+	completeline (Output b) = endsNewLine b++endsNewLine :: T.Text -> Bool+endsNewLine t = not (T.null t) && T.last t == '\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 stdh (OutputBuffer l) = +	forM_ (reverse l) $ \ba -> case ba of+		Output t -> emit t+		InTempFile tmp _ -> do+			emit =<< T.readFile tmp+			void $ tryWhenExists $ removeFile tmp+  where+	outh = toHandle stdh+	emit t = void $ tryIO $ do+		T.hPutStr outh t+		hFlush outh

@@ -1,7 +1,7 @@ {-# LANGUAGE BangPatterns, TupleSections #-}  -- | --- Copyright: 2013 Joey Hess <id@joeyh.name>+-- Copyright: 2015 Joey Hess <id@joeyh.name> -- License: BSD-2-clause --  -- Console regions are displayed near the bottom of the console, and can be@@ -15,9 +15,12 @@ -- > import Control.Concurrent -- > import System.Console.Concurrent -- > import System.Console.Regions+-- > import System.Process -- >  -- > main = displayConsoleRegions $ do--- > 	mapConcurrently download [1..5] `concurrently` mapM_ message [1..10]+-- > 	mapConcurrently download [1..5]+-- >		`concurrently` mapM_ message [1..10]+-- >		`concurrently` createProcessConcurrent (proc "echo" ["hello world"]) -- >  -- > message :: Int -> IO () -- > message n = do@@ -40,6 +43,7 @@ -- Will display like this: -- -- > Message 1+-- > hello world -- > Message 2 -- > Download 1 ... -- > Download 2 ...@@ -49,6 +53,7 @@ -- the console will update like this: -- -- > Message 1+-- > hello world -- > Message 2 -- > Download 1 done! -- > Message 3@@ -83,7 +88,8 @@ import Data.Maybe import Data.String import Data.Char-import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.IO as T import Control.Monad import Control.Applicative import Control.Monad.IO.Class (liftIO, MonadIO)@@ -96,6 +102,8 @@ import System.IO.Unsafe (unsafePerformIO) import System.Posix.Signals import System.Posix.Signals.Exts+import Text.Read+import Data.List  import System.Console.Concurrent import Utility.Monad@@ -121,13 +129,9 @@ newtype ConsoleRegionHandle = ConsoleRegionHandle (TVar Region) 	deriving (Eq) -type Width = Int-type Height = Int- data Region = Region-	{ regionContent :: B.ByteString-	, regionHeight :: (Width -> Height)-	-- ^ Function from console width to the height of this region+	{ regionContent :: T.Text+	, regionLines :: [T.Text] -- cache 	, regionLayout :: RegionLayout 	, regionChildren :: Maybe [ConsoleRegionHandle] 	}@@ -143,6 +147,13 @@ regionList :: RegionList regionList = unsafePerformIO newEmptyTMVarIO +type Width = Int++-- | A shared global console width.+{-# NOINLINE consoleWidth #-}+consoleWidth :: TVar Width+consoleWidth = unsafePerformIO (newTVarIO 80)+ -- | Updates the list of regions. The list is ordered from the bottom of -- the screen up. Reordering it will change the order in which regions are -- displayed. It's also fine to remove, duplicate, or add new regions to the@@ -157,25 +168,24 @@ regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList  -- | Sets the value to display within a console region.-{- TODO--- It's fine for the value to be longer than the terminal is wide.--- Regions are laid out according to the size of their contents,--- and expand to multiple lines if necessary. ----- The value of a `Linear` region can contain newlines ('\n').--- And it's ok to include ANSI escape sequences for changing colors,--- or setting the terminal title. However, ANSI cursor movement sequences--- will mess up the  layouts of regions, '\r' is not handled, and--- other control characters or ANSI codes may confuse the region--- display. Caveat emptor.--}+-- It's fine for the value to be longer than the terminal is wide,+-- or to include newlines ('\n'). Regions expand to multiple lines as+-- necessary.+--+-- The value can include ANSI SGR escape sequences for changing+-- the colors etc of all or part of a region.+-- +-- Other ANSI escape sequences, especially those doing cursor+-- movement, will mess up the layouts of regions. Caveat emptor. setConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO () setConsoleRegion h = atomically . setConsoleRegionSTM h  setConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () setConsoleRegionSTM (ConsoleRegionHandle tv) v = do 	r <- readTVar tv-	writeTVar tv (modifyRegion r (const (toOutput v)))+	width <- readTVar consoleWidth+	writeTVar tv (modifyRegion r width (const (toOutput v))) 	case regionLayout r of 		Linear -> return () 		InLine p -> refreshParent p@@ -188,16 +198,24 @@ appendConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () appendConsoleRegionSTM (ConsoleRegionHandle tv) v = do 	r <- readTVar tv-	writeTVar tv (modifyRegion r (<> toOutput v))+	width <- readTVar consoleWidth+	writeTVar tv (modifyRegion r width (<> toOutput v)) 	case regionLayout r of 		Linear -> return () 		InLine p -> refreshParent p -modifyRegion :: Region -> (B.ByteString -> B.ByteString) -> Region-modifyRegion r f = r { regionContent = c, regionHeight = calcRegionHeight c }+modifyRegion :: Region -> Width -> (T.Text -> T.Text) -> Region+modifyRegion r width f = r { regionContent = c, regionLines = calcRegionLines c width }   where 	!c = f (regionContent r) +resizeRegion :: Width -> ConsoleRegionHandle -> STM Region+resizeRegion width (ConsoleRegionHandle tv) = do+	r <- readTVar tv+	let !r' = modifyRegion r width id+	writeTVar tv r'+	return r'+ -- | Runs the action with a new console region, closing the region when -- the action finishes or on exception. withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegionHandle -> m a) -> m a@@ -214,9 +232,10 @@ -- >	replicateM 3 (openConsoleRegionSTM Linear) openConsoleRegionSTM :: RegionLayout -> STM ConsoleRegionHandle openConsoleRegionSTM ly = do+	width <- readTVar consoleWidth 	let r = Region 		{ regionContent = mempty-		, regionHeight = calcRegionHeight mempty+		, regionLines = calcRegionLines mempty width 		, regionLayout = ly 		, regionChildren = Nothing 		}@@ -275,15 +294,20 @@ 	refreshParent parent  refreshParent :: ConsoleRegionHandle -> STM ()-refreshParent parent@(ConsoleRegionHandle pv) = do+refreshParent (ConsoleRegionHandle pv) = do 	p <- readTVar pv+	width <- readTVar consoleWidth 	case regionChildren p of 		Nothing -> return () 		Just l -> do 			cs <- forM l $ \child@(ConsoleRegionHandle cv) -> do 				refreshParent child 				regionContent <$> readTVar cv-			let p' = p { regionContent = mconcat cs }+			let !c = mconcat cs+			let p' = p+				{ regionContent = c+				, regionLines = calcRegionLines c width+				} 			writeTVar pv p'  -- | Handles all display for the other functions in this module.@@ -308,10 +332,8 @@ 			waitTSem s 			return s 		isterm <- liftIO $ hSupportsANSI stdout-		cwidth <- atomically newEmptyTMVar-		when isterm $-			trackConsoleWidth cwidth-		da <- async $ displayThread isterm cwidth endsignal+		when isterm trackConsoleWidth+		da <- async $ displayThread isterm endsignal 		return (isterm, da, endsignal) 	cleanup (isterm, da, endsignal) = liftIO $ do 		atomically $ signalTSem endsignal@@ -320,36 +342,35 @@ 		when isterm $ 			installResizeHandler Nothing -trackConsoleWidth :: TMVar Width -> IO ()-trackConsoleWidth cwidth = do+trackConsoleWidth :: IO ()+trackConsoleWidth = do 	let getwidth = do 		v <- Console.size 		case v of 			Nothing -> return () 			Just (Console.Window _height width) ->-				atomically $ void $ do-					void $ tryTakeTMVar cwidth-					putTMVar cwidth width+				atomically $ void $+					swapTVar consoleWidth width 	getwidth-	installResizeHandler $ Just getwidth+	installResizeHandler (Just getwidth)  data DisplayChange 	= BufferChange [(StdHandle, OutputBuffer)] 	| RegionChange RegionSnapshot-	| TerminalResize (Maybe Width)+	| TerminalResize Width 	| EndSignal () -type RegionSnapshot = ([ConsoleRegionHandle], [Region], Maybe Width)+type RegionSnapshot = ([ConsoleRegionHandle], [Region]) -displayThread :: Bool -> TMVar Width -> TSem -> IO ()-displayThread isterm cwidth endsignal = do-	origwidth <- atomically $ tryReadTMVar cwidth-	go ([], [], origwidth)+displayThread :: Bool -> TSem -> IO ()+displayThread isterm endsignal = do+	origwidth <- atomically $ readTVar consoleWidth+	go ([], []) origwidth   where-	go origsnapshot@(orighandles, origregions, origwidth) = do+	go origsnapshot@(orighandles, origregions) origwidth = do 		let waitwidthchange = do-			v <- tryReadTMVar cwidth-			if v == origwidth then retry else return v+			w <- readTVar consoleWidth+			if w == origwidth then retry else return w 		change <- atomically $ 			(RegionChange <$> regionWaiter origsnapshot) 				`orElse`@@ -361,180 +382,332 @@ 				`orElse` 			(EndSignal <$> waitTSem endsignal) 		case change of-			RegionChange snapshot@(_, regions, _) -> do+			RegionChange snapshot@(_, newregions) -> do 				when isterm $-					changedRegions origregions regions-				go snapshot+					changedLines+						(getlines origregions)+						(getlines newregions)+				go snapshot origwidth 			BufferChange buffers -> do-				inAreaAbove isterm origregions $+				inAreaAbove isterm (length $ getlines origregions) (getlines origregions) $ 					mapM_ (uncurry emitOutputBuffer) buffers-				go origsnapshot-			TerminalResize width -> do-				when isterm $-					-- force redraw of all regions-					inAreaAbove isterm origregions $+				go origsnapshot origwidth+			TerminalResize newwidth -> do+				newregions <- atomically $+					mapM (resizeRegion newwidth) orighandles+				when isterm $ do+					-- A resize can leave the cursor+					-- in a fairly undefined location,+					-- if it occurred while a screen+					-- draw was in progress. Move the+					-- cursor to top of screen, clear+					-- entire screen, and redisplay.+					setCursorPosition 0 0+					inAreaAbove isterm 0 (getlines newregions) $ 						return ()-				go (orighandles, origregions, width)+				go (orighandles, newregions) newwidth 			EndSignal () -> return ()+	getlines = concatMap (reverse . regionLines)  readRegions :: [ConsoleRegionHandle] -> STM [Region] readRegions = mapM (\(ConsoleRegionHandle h) -> readTVar h)  -- Wait for any changes to the region list, eg adding or removing a handle. regionListWaiter :: RegionSnapshot -> STM RegionSnapshot-regionListWaiter (orighandles, _origregions, origwidth) = do+regionListWaiter (orighandles, _origregions) = do 	handles <- readTMVar regionList 	if handles == orighandles 		then retry-		else (handles,,origwidth) <$> readRegions handles+		else do+			rs <- readRegions handles+			return (handles, rs) 		 -- Wait for any changes to any of the regions currently in the region list. regionWaiter :: RegionSnapshot -> STM RegionSnapshot-regionWaiter (orighandles, origregions, origwidth) = do+regionWaiter (orighandles, origregions) = do 	rs <- readRegions orighandles 	if rs == origregions 		then retry-		else return (orighandles, rs, origwidth)+		else return (orighandles, rs)  -- This is not an optimal screen update like curses can do, but it's--- pretty efficient, most of the time! The only particularly--- expensive part is removing a region, which typically reorders--- the regions and so requires redrawing them all.-changedRegions :: [Region] -> [Region] -> IO ()-changedRegions origregions regions+-- pretty efficient, most of the time!+changedLines :: [T.Text] -> [T.Text] -> IO ()+changedLines origlines newlines 	| delta == 0 = do-		-- The total number of regions is unchanged, so update+		-- The total number of lines is unchanged, so update 		-- whichever ones have changed, and leave the rest as-is.-		diffUpdate origregions regions+		diffUpdate origlines newlines 	| delta > 0 = do-		-- Added more regions, so output each, with a-		-- newline, thus scrolling the old regions up+		-- Added more lines, so output each, with a+		-- newline, thus scrolling the old lines up 		-- the screen. (We can do this, because the cursor-		-- is left below the first region.)-		let newregions = reverse (take delta regions)-		displayRegions newregions-		hFlush stdout-		-- Some existing regions may have also changed..-		let scrolledregions = newregions ++ origregions-		diffUpdate scrolledregions regions+		-- is left below the first line.)+		let addedlines = reverse (take delta newlines)+		displayLines addedlines+		-- Some existing lines may have also changed..+		let scrolledlines = addedlines ++ origlines+		diffUpdate scrolledlines newlines 	| otherwise = do-		-- Some regions were removed. Move up that many lines,-		-- clearing each line, and update any changed regions.+		-- Some lines were removed. Move up that many lines,+		-- clearing each line, and update any changed lines. 		replicateM_ (abs delta) $ do 			cursorUpLine 1 			clearLine-		diffUpdate (drop (abs delta) origregions) regions+		diffUpdate (drop (abs delta) origlines) newlines   where-	delta = length regions - length origregions+	delta = length newlines - length origlines --- TODO Rather than writing the whole text of a region, find--- a more efficient update, reusing parts of the old content of the region.-diffUpdate :: [Region] -> [Region] -> IO ()-diffUpdate origregions regions = updateRegions (zip regions changed)+diffUpdate :: [T.Text] -> [T.Text] -> IO ()+diffUpdate old new = updateLines (zip (zip new changed) old)   where-	changed = map (uncurry (/=)) (zip regions origregions) ++ repeat True+	changed = map (uncurry (/=)) (zip new old) ++ repeat True --- Displays regions that are paired with True, and skips over the rest.--- Cursor is assumed to be just below the line of the first region at the+changeOffsets :: [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)]+changeOffsets [] _ c = reverse c+changeOffsets (((new, changed), old):rs) n c+	| changed = changeOffsets rs 1 (((new, n), old):c)+	| otherwise = changeOffsets rs (succ n) c++-- Displays lines that are paired with True, and skips over the rest.+-- Cursor is assumed to be just below the first line at the -- beginning, and is put back there at the end.-updateRegions :: [(Region, Bool)] -> IO ()-updateRegions l+updateLines :: [((T.Text, Bool), T.Text)] -> IO ()+updateLines l 	| null l' = noop 	| otherwise = do-		forM_ l' $ \(r, offset) -> do+		forM_ l' $ \((newt, offset), oldt) -> do 			cursorUpLine offset-			clearLine-			B.hPut stdout (regionContent r)-			hFlush stdout-		cursorDownLine (sum (map snd l'))+			T.hPutStr stdout $ +				genLineUpdate $ calcLineUpdate oldt newt+		cursorDownLine (sum (map (snd . fst) l')) 		setCursorColumn 0 		hFlush stdout   where 	l' = changeOffsets l 1 [] -changeOffsets :: [(r, Bool)] -> Int -> [(r, Int)] -> [(r, Int)]-changeOffsets [] _ c = reverse c-changeOffsets ((r, changed):rs) n c-	| changed = changeOffsets rs 1 ((r, n):c)-	| otherwise = changeOffsets rs (succ n) c---- Move cursor up before the regions, performs some output there,--- which will scroll down and overwrite the regions, so --- redraws all the regions below.-inAreaAbove :: Bool -> [Region] -> IO () -> IO ()-inAreaAbove isterm regions outputter = do+-- Move cursor up before the lines, performs some output there,+-- which will scroll down and overwrite the lines, so +-- redraws all the lines below.+inAreaAbove :: Bool -> Int -> [T.Text] -> IO () -> IO ()+inAreaAbove isterm numlines ls outputter = do 	when isterm $ do-		unless (null regions) $-			cursorUpLine (length regions)+		unless (numlines < 1) $+			cursorUpLine $ numlines 		clearFromCursorToScreenEnd 	outputter 	when isterm $ do 		setCursorColumn 0 -- just in case the output lacked a newline-		displayRegions (reverse regions)+		displayLines (reverse ls) 	hFlush stdout -displayRegions :: [Region] -> IO ()-displayRegions = mapM_ $ \r -> do-	B.hPut stdout (regionContent r)+displayLines :: [T.Text] -> IO ()+displayLines = mapM_ $ \l -> do+	T.hPutStr stdout l 	putChar '\n'  installResizeHandler :: Maybe (IO ()) -> IO () installResizeHandler h = void $ 	installHandler windowChange (maybe Default Catch h) Nothing -calcRegionHeight :: B.ByteString -> Width -> Height-calcRegionHeight b width = sum $ map (calcLineHeight width) (B.split wnl b)+-- | Splits a Text into the lines it would display using when output onto+-- a console with a given width, starting from the first column.+--+-- ANSI SGR sequences are handled specially, so that color, etc settings+-- work despite the lines being split up, and the lines can be output+-- indepedently. For example, "foooREDbar bazRESET" when split into lines+-- becomes ["fooREDbarRESET", "RED bazRESET"]+calcRegionLines :: T.Text -> Width -> [T.Text]+calcRegionLines t width+	| width < 1 || T.null t = [t] -- even an empty text is 1 line high+	| otherwise = calcRegionLines' width [] [] 0 1 (T.length t) t++calcRegionLines' :: Int -> [T.Text] -> [T.Text] -> Int -> Int -> Int -> T.Text -> [T.Text]+calcRegionLines' width collectedlines collectedSGR i displaysize len t+	| i >= len = if i > 0+		then reverse (finishline t)+		else reverse collectedlines+	| t1 == '\n' = calcRegionLines' width (finishline $ T.init currline)+		[] 0 1 (T.length rest) (contSGR rest)+	-- ANSI escape sequences do not take up space on screen.+	| t1 == '\ESC' && i+1 < len = case T.index t (i+1) of+		'[' -> skipansi endCSI True+		']' -> skipansi endOSC False+		_ -> calcRegionLines' width collectedlines collectedSGR (i+1) displaysize len t+	-- Control characters do not take up space on screen.+	| isControl t1 = calcRegionLines' width collectedlines collectedSGR (i+1) displaysize len t+	| displaysize >= width = calcRegionLines' width (finishline currline)+		[] 0 1 (T.length rest) (contSGR rest)+	| otherwise = calcRegionLines' width collectedlines collectedSGR (i+1) (displaysize+1) len t   where-	wnl = fromIntegral (ord '\n')+	t1 = T.index t i+	(currline, rest) = T.splitAt (i+1) t --- Calculate the height a line would occupy if output onto a console--- with a given width, starting from the first column.+	skipansi toend isCSI = case T.findIndex toend (T.drop (i+2) t) of+		Just csiend -> calcRegionLines' width collectedlines +			(addSGR (csiend+2)) (i+2+csiend) (displaysize-1) len t+		Nothing -> reverse (finishline t)+	  where+		addSGR csiend+			| not isCSI = collectedSGR+			| ansicode == resetSGR = []+			| not (T.null ansicode) && T.last ansicode == endSGR =+				ansicode : collectedSGR+			| otherwise = collectedSGR+		  where+			ansicode = T.take (csiend + 1) (T.drop i t)+	finishline l = closeSGR l : collectedlines+	-- Close any open SGR codes at end of line+	closeSGR l+		| null collectedSGR = l+		| otherwise = l <> resetSGR+	-- Continue any open SGR codes from previous line+	contSGR l = mconcat (reverse collectedSGR) <> l++resetSGR :: T.Text+resetSGR = T.pack (setSGRCode [Reset])++endCSI :: Char -> Bool+endCSI c = let o = ord c in o >= 64 && o < 127++endOSC :: Char -> Bool+endOSC c = c == '\BEL'++endSGR :: Char+endSGR = 'm'++-- | Finds the least expensive output to make a console that was displaying+-- the old line display the new line. Cursor starts at far left. ----- Note that this counts each byte, is not aware of multibyte characters,--- so will over-estimate a bit for those.+-- Basically, loop through and find spans where the old and new line are+-- the same. Generate cursorForwardCode ANSI sequences to skip over those+-- spans, unless such a sequence would be longer than the span it's skipping. ----- Also an issue are ANSI escape sequences for eg, setting colors or the--- title. This is handled by stripping out common ANSI escape sequences--- and control characters.-calcLineHeight :: Width -> B.ByteString -> Height-calcLineHeight width b-	| width < 1 || B.null b = 1 -- even an empty line is 1 line high-	| otherwise =-		let (q,r) = (B.length b - countInvisibleBytes b) `quotRem` width-		in q + if r > 0 then 1 else 0+-- Since ANSI sequences can be present in the line, need to take them+-- into account. Generally, each of the sequences in new has to be included,+-- even if old contained the same sequence:+--+-- > old: GREENfoofoofooREDbarbarbarRESETbaz+-- > new: GREENfoofoofooREDxarbarbaxRESETbaz+-- > ret: GREEN-------->REDx------>yRESET+--+-- (The first GREEN does not effect any output text, so it can be elided.)+-- +-- Also, despite old having the same second span as new, in the same+-- location, that span has to be re-emitted because its color changed:+-- +-- > old: GREENfoofooREDbarbarbarbarbar+-- > new: GREENfoofoofooTANbarbarbar+-- > ret: GREEN----->fooTANbarbarbarCLEARREST+--+-- Also note above that the sequence has to clear the rest of the line,+-- since the new line is shorter than the old.+calcLineUpdate :: T.Text -> T.Text -> [LineUpdate]+calcLineUpdate old new = +	reverse $ go+		(advanceLine old [] [])+		(advanceLine new [] [])+  where+	go (Just _, _, _, _) (Nothing, _, past, _) = ClearToEnd : past+	go (Nothing, _, _, _) (Nothing, _, past, _) = past+	go (Nothing, _, _, _) (Just n, ns, past, _) =+		Display ns : Display (T.singleton n) : past+	go (Just o, os, _, oinvis) (Just n, ns, past, ninvis)+		| o == n && oinvis == ninvis = go+			(advanceLine os [] oinvis)+			(advanceLine ns (Skip [o] : past) ninvis)+		| otherwise = go+			(advanceLine os [] oinvis)+			(advanceLine ns (Display (T.singleton n) : past) ninvis) --- ANSI sequences and control characters.-countInvisibleBytes :: B.ByteString -> Int-countInvisibleBytes = go 0 . breakesc+type Past = [LineUpdate]+type Invis = [LineUpdate]++-- Find next character of t that is not a ANSI escape sequence+-- or control char. Any such passed on the way to the character+-- are prepended to past, and added to invis.+--+-- resetSGR is handled specially; it causes all SGRs to be removed from+-- invis, It's still prepended to past.+advanceLine :: T.Text -> Past -> Invis -> (Maybe Char, T.Text, Past, Invis)+advanceLine t past invis+	| T.null t = (Nothing, T.empty, past, invis)+	| otherwise = case T.head t of+		'\ESC' -> case T.drop 1 t of+			t' | T.null t' -> advanceLine (T.drop 1 t)+				(Skip "\ESC":past) (Skip "\ESC":invis)+			   | otherwise -> case T.head t' of+			   	'[' -> skipansi endCSI+				']' -> skipansi endOSC+				c -> (Just c, T.drop 2 t, Skip "\ESC":past, Skip "\ESC":invis)+		c | isControl c -> advanceLine (T.drop 1 t) (Skip [c]:past) (Skip [c]:invis)+		  | otherwise -> (Just c, T.drop 1 t, past, invis)   where-	go c (beforeesc, b)-		| B.length b <= 1 = B.length b + c'-		| headis csi (B.drop 1 b) = countseq breakcsi-		| headis osc (B.drop 1 b) = countseq breakosc-		-- found an ESC but apparently not in an ANSI sequence;-		-- count it as 1 invisible control character-		| otherwise = go (c'+1) (breakesc (B.drop 1 b))+	skipansi toend = case T.findIndex toend (T.drop 2 t) of+		Just csiend -> +			let sgr = SGR (T.take (csiend+3) t)+			in advanceLine (T.drop (csiend+3) t)+				(sgr:past) (addsgr sgr invis)+		Nothing -> (Nothing, T.empty, past, invis)+	addsgr (SGR sgrt) l+		| sgrt == resetSGR = filter (not . isSGR) l+	addsgr s l = s:l++data LineUpdate = Display T.Text | Skip [Char] | SGR T.Text | ClearToEnd+	deriving (Eq, Show)++isSGR :: LineUpdate -> Bool+isSGR (SGR _) = True+isSGR _ = False++genLineUpdate :: [LineUpdate] -> T.Text+genLineUpdate l = T.concat $ map tot (optimiseLineUpdate l)+  where+	tot (Display t) = t+	tot (Skip s)+		-- length (cursorForwardCode 1) == 4 so there's no point+		-- generating that for a skip of less than 5.+		| len < 5 = T.pack s+		| otherwise = T.pack (cursorForwardCode len) 	  where-		c' = c + countControlChars beforeesc-		countseq breaker =-			let (inseq, b') = breaker (B.drop 2 b)-			-- add 1 for the ESC and one for the head char-			-- that introduced the sequence, plus the length-			-- of the rest of the sequence, plus 1 for -			-- the end char of the sequence.-			in go (c'+1+1+B.length inseq+1) (breakesc (B.drop 1 b'))+		len = length s+	tot (SGR t) = t+	tot ClearToEnd = T.pack clearFromCursorToLineEndCode -	esc = fromIntegral (ord '\ESC')-	bel = fromIntegral (ord '\BEL')-	breakesc = B.break (== esc)-	headis c b = B.head b ==c-	csi = fromIntegral (ord '[') -- Control Sequence Introducer-	csiend c = c >= 64 && c < 127-	breakcsi = B.break csiend-	osc = fromIntegral (ord ']') -- Operating system command-	breakosc = B.break (== bel)+optimiseLineUpdate :: [LineUpdate] -> [LineUpdate]+optimiseLineUpdate = go []+  where+	-- elide trailing Skips+	go (Skip _:rest) [] = go rest []+	-- elide SGRs at the end of the line, except for the reset SGR+	go (SGR t:rest) [] | t /= resetSGR = go rest []+	go c [] = reverse c+	-- combine adjacent SGRs and Skips+	go c (SGR t1:Skip s:SGR t2:rest) = tryharder c (SGR (combineSGR t1 t2):Skip s:rest)+	go c (Skip s:Skip s':rest) = tryharder c (Skip (s++s'):rest)+	go c (SGR t1:SGR t2:rest) = tryharder c (SGR (combineSGR t1 t2):rest)+	go c (v:rest) = go (v:c) rest+	tryharder c l = go [] (reverse c ++ l) -countControlChars :: B.ByteString -> Int-countControlChars = length . filter iscontrol8 . B.unpack+-- Parse and combine 2 ANSI SGR sequences into one.+combineSGR :: T.Text -> T.Text -> T.Text+combineSGR a b = case combineSGRCodes (codes a) (codes b) of+	Nothing -> a <> b+	Just cs -> T.pack $ "\ESC[" ++ intercalate ";" (map show cs) ++ "m"   where-	iscontrol8 c = c < 32 || c == 127 -- del+	codes = map (readMaybe . T.unpack) .+		T.split (== ';') . T.drop 2 . T.init++-- Prefers values from the second sequence when there's a conflict with+-- values from the first sequence.+combineSGRCodes :: [Maybe Int] -> [Maybe Int] -> Maybe [Int]+combineSGRCodes as bs =+	map snd . nubBy (\a b -> fst a == fst b) <$> mapM range (reverse bs ++ reverse as)+  where+	range Nothing = Nothing+	range (Just x)+		| x >= 30 && x <= 37 = Just (Foreground, x)+		| x >= 40 && x <= 47 = Just (Background, x)+		| x >= 90 && x <= 97 = Just (Foreground, x)+		| x >= 100 && x <= 107 = Just (Background, x)+		| otherwise = Nothing

@@ -0,0 +1,34 @@+-- | +-- Copyright: 2015 Joey Hess <id@joeyh.name>+-- License: BSD-2-clause+-- +-- The functions exported by this module are intended to be drop-in+-- replacements for those from System.Process, when converting a whole+-- program to use System.Console.Concurrent.++module System.Process.Concurrent where++import System.Console.Concurrent+import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..))+import System.Process hiding (createProcess, waitForProcess)+import System.IO+import System.Exit++-- | Calls `createProcessConcurrent`+--+-- You should use the waitForProcess in this module on the resulting+-- ProcessHandle. Using System.Process.waitForProcess instead can have+-- mildly unexpected results.+createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)+createProcess p = do+	(i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p+	return (i, o, e, h)++-- | Calls `waitForProcessConcurrent`+--+-- You should only use this on a ProcessHandle obtained by calling+-- createProcess from this module. Using this with a ProcessHandle+-- obtained from System.Process.createProcess etc will have extremely+-- unexpected results; it can wait a very long time before returning.+waitForProcess :: ProcessHandle -> IO ExitCode+waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle

@@ -1,5 +1,4 @@-Optimize line update, avoiding outputting characters already on-screen (aka-what curses does, but this is portable to even windows, so no curses. Anway,-should be under 20 line function.)--Make layout take region width into account.+It would be nice to have regions whose content was determined by running a+STM Text action. Such regions should update whenever the values that action+accessed change. Could be used for such things as spreadsheets.+I have this mostly done in the stmregions git branch, but not quite working.

@@ -4,11 +4,12 @@ import Control.Concurrent import System.Console.Concurrent import System.Console.Regions+import System.Console.ANSI  main = displayConsoleRegions $ do 	mapConcurrently downline-		[ ["foo", "bar", "baz"]-		, ["pony", "mango", "very_large"]+		[ [dl "pony", growingdots, dl "mango"]+		, [dl "foo", dl "bar", dl "very large"] 		] 		`concurrently` mapM_ message [1..20] @@ -17,14 +18,24 @@ 	outputConcurrent ("Updated blah blah #" ++ show n ++ "\n")  downline cs = withConsoleRegion Linear $ \r -> -	mapConcurrently (kid r) (reverse cs)+	mapConcurrently (\a -> a r) (reverse cs)++dl c parent = withConsoleRegion (InLine parent) (go 0)   where-	kid parent c = withConsoleRegion (InLine parent) (go c 0)-	go c n r+	go n r 		| n <= 100 = do 			setConsoleRegion r $-				"[" ++ c ++ " " ++ show n ++ "%] "+				"[" ++ setSGRCode [SetColor Foreground Vivid Green] ++ c ++ setSGRCode [Reset] ++ " " ++ show n ++ "%] " 			threadDelay (25000 * length c)-			go c (n+1) r+			go (n+1) r 		| otherwise = finishConsoleRegion r $ 			"Downloaded " ++ c ++ ".deb"++growingdots parent = withConsoleRegion (InLine parent) (go 0)+  where+	go n r+		| n <= 250 = do+			setConsoleRegion r ("[" ++ setSGRCode [SetColor Foreground Vivid Blue] ++ replicate n '.' ++ setSGRCode [Reset] ++ "] ")+			threadDelay (100000)+			go (n+1) r+		| otherwise = return ()

@@ -1,5 +1,5 @@ Name: concurrent-output-Version: 1.1.0+Version: 1.2.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -31,8 +31,7 @@  Library   GHC-Options: -Wall -fno-warn-tabs -O2-  Build-Depends: base (>= 4.5), base < 5-    , bytestring (>= 0.10.0 && < 0.11)+  Build-Depends: base (>= 4.6), base < 5     , text (>= 1.2.0 && < 1.3.0)     , async (>= 2.0 && < 2.1)     , stm (>= 2.0 && < 2.5)@@ -45,7 +44,9 @@     , terminal-size (>= 0.3.0 && < 0.4.0)   Exposed-Modules:     System.Console.Concurrent+    System.Console.Concurrent.Internal     System.Console.Regions+    System.Process.Concurrent   Other-Modules:     Utility.Monad     Utility.Data

@@ -34,7 +34,7 @@ 	threadDelay 1000000 	(Nothing, Nothing, Nothing, p) <- createProcessConcurrent (proc "ls" ["-C"]) 	outputConcurrent "started running ls >>>"-	_ <- waitForProcess p+	_ <- waitForProcessConcurrent p 	outputConcurrent "<<< ls is done!\n" 	return () 	

@@ -6,7 +6,7 @@ main = displayConsoleRegions $ mapConcurrently id 	[ spinner 100 1 "Pinwheels!!" setConsoleRegion "/-\\|" (withtitle 1) 	, spinner 100 1 "Bubbles!!!!" setConsoleRegion ".oOo." (withtitle 1)-	, spinner  40 2 "Dots......!" appendConsoleRegion "."  (const (take 1))+	, spinner 100 1 "Dots......!" appendConsoleRegion "."  (const (take 1)) 	, spinner  30 2 "KleisiFish?" setConsoleRegion "  <=<   <=<  " (withtitle 10) 	, spinner  10 9 "Countdowns!" setConsoleRegion 		(reverse [1..10])

@@ -3,10 +3,12 @@ import System.Process  main = withConcurrentOutput $-	outputConcurrent "washed the car\n"+	outputConcurrent "hello world\n" 		`concurrently` 	createProcessConcurrent (proc "ls" []) 		`concurrently`-	createProcessConcurrent (proc "sh" ["-c", "echo \"hi from echo!\" >&2"])+	createProcessConcurrent (proc "who" []) 		`concurrently`-	outputConcurrent "walked the dog\n"+	createProcessForeground (proc "vim" [])+		`concurrently`+	outputConcurrent "hello world again\n"