concurrent-output 1.0.1 → 1.1.0

raw patch · 11 files changed

+1178/−359 lines, 11 filesdep +ansi-terminaldep +terminal-sizedep −containersPVP ok

version bump matches the API change (PVP)

Dependencies added: ansi-terminal, terminal-size

Dependencies removed: containers

API changes (from Hackage documentation)

Files

• CHANGELOG +10/−0
• Control/Concurrent/Output.hs +0/−348
• LICENSE +2/−1
• System/Console/Concurrent.hs +485/−0
• System/Console/Regions.hs +540/−0
• TODO +5/−0
• aptdemo.hs +30/−0
• concurrent-output.cabal +24/−10
• demo.hs +41/−0
• demo2.hs +29/−0
• demo3.hs +12/−0

@@ -1,3 +1,13 @@+concurrent-output (1.1.0) unstable; urgency=medium++  * Renamed module.+  * Incorporated console region support, based on Joachim Breitner's+    concurrentoutput library.+  * Fix race that sometimes prevented a concurrent processes's output from+    being displayed as program shut down.++ -- Joey Hess <id@joeyh.name>  Fri, 30 Oct 2015 21:27:41 -0400+ concurrent-output (1.0.1) unstable; urgency=medium    * Generalize what can be output.

@@ -1,348 +0,0 @@-{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-tabs #-}---- | --- Copyright: 2013 Joey Hess <id@joeyh.name>--- License: BSD-2-clause--- --- Concurrent output handling.------ > import Control.Concurrent.Async--- > import Control.Concurrent.Output--- >--- > main = withConcurrentOutput $--- > 	outputConcurrent "washed the car\n"--- > 		`concurrently`--- >	outputConcurrent "walked the dog\n"--- >		`concurrently`--- > 	createProcessConcurrent (proc "ls" [])--module Control.Concurrent.Output (-	withConcurrentOutput,-	flushConcurrentOutput,-	Outputable(..),-	outputConcurrent,-	createProcessConcurrent,-	waitForProcessConcurrent,-	lockOutput,-) 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.Set as S-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 Buffer-	, outputThreads :: TMVar (S.Set (Async ()))-	}--data Lock = Locked---- | A shared global variable for the OutputHandle.-{-# NOINLINE globalOutputHandle #-}-globalOutputHandle :: MVar OutputHandle-globalOutputHandle = unsafePerformIO $ -	newMVar =<< OutputHandle-		<$> newEmptyTMVarIO-		<*> newTMVarIO []-		<*> newTMVarIO S.empty---- | Gets the global OutputHandle.-getOutputHandle :: IO OutputHandle-getOutputHandle = readMVar globalOutputHandle---- | Holds a lock while performing an action that will display output.--- While this is running, other threads that try to lockOutput will block,--- and calls to `outputConcurrent` and `createProcessConcurrent`--- will result in that concurrent output being buffered and not--- displayed until 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 = do-	lck <- outputLock <$> getOutputHandle-	atomically (a lck)--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-		bv <- outputBuffer <$> getOutputHandle-		buf <- atomically $ swapTMVar bv []-		emitBuffer stdout buf-	return locked---- | Only safe to call after taking the output lock.-dropOutputLock :: IO ()-dropOutputLock = withLock $ void . takeTMVar---- | Use this around any IO actions that use `outputConcurrent`--- or `createProcessConcurrent`------ This is necessary to ensure that buffered concurrent output actually--- gets displayed before the program exits.-withConcurrentOutput :: IO a -> IO a-withConcurrentOutput a = a `finally` flushConcurrentOutput---- | Blocks until any processes started by `createProcessConcurrent` have--- finished, and any buffered output is displayed.-flushConcurrentOutput :: IO ()-flushConcurrentOutput = do-	-- Wait for all outputThreads to finish.-	v <- outputThreads <$> getOutputHandle-	atomically $ do-		r <- takeTMVar v-		if r == S.empty-			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, and flush output so it's displayed.------ 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-		bv <- outputBuffer <$> getOutputHandle-		oldbuf <- atomically $ takeTMVar bv-		newbuf <- addBuffer (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 (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, 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-			}-		r <- P.createProcess p'-		outbuf <- setupBuffer stdout toouth (P.std_out p) fromouth-		errbuf <- setupBuffer 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---- Built up with newest seen output first.-type Buffer = [BufferedActivity]--data BufferedActivity-	= ReachedEnd-	| Output B.ByteString-	| InTempFile FilePath-	deriving (Eq)--setupBuffer :: Handle -> Handle -> P.StdStream -> Handle -> IO (Handle, MVar Buffer, TMVar ())-setupBuffer h toh ss fromh = do-	hClose toh-	buf <- newMVar []-	bufsig <- atomically newEmptyTMVar-	void $ async $ outputDrainer ss fromh buf bufsig-	return (h, buf, bufsig)---- Drain output from the handle, and buffer it.-outputDrainer :: P.StdStream -> Handle -> MVar Buffer -> TMVar () -> IO ()-outputDrainer ss fromh buf bufsig-	| 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 $ addBuffer (Output b)-				changed-				go-			_ -> atend-	atend = do-		modifyMVar_ buf $ pure . (ReachedEnd :)-		changed-		hClose fromh-	changed = atomically $ do-		void $ tryTakeTMVar bufsig-		putTMVar bufsig ()---- Wait to lock output, and once we can, display everything --- that's put into the buffers, until the end.-bufferWriter :: [(Handle, MVar Buffer, TMVar ())] -> IO ()-bufferWriter ts = do-	worker <- async $ void $ lockOutput $ mapConcurrently go ts-	v <- outputThreads <$> getOutputHandle-	atomically $ do-		s <- takeTMVar v-		putTMVar v (S.insert worker s)-	void $ async $ do-		void $ waitCatch worker-		atomically $ do-			s <- takeTMVar v-			putTMVar v (S.delete worker s)-  where-	go v@(outh, buf, bufsig) = do-		void $ atomically $ takeTMVar bufsig-		l <- takeMVar buf-		putMVar buf []-		emitBuffer outh l-		if any (== ReachedEnd) l-			then return ()-			else go v--emitBuffer :: Handle -> Buffer -> IO ()-emitBuffer outh 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-	ReachedEnd -> return ()---- Adds a value to the Buffer. 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.-addBuffer :: BufferedActivity -> Buffer -> IO Buffer-addBuffer (Output b) buf-	| B.length b' <= 1048576 = return (Output b' : other)-	| otherwise = do-		tmpdir <- getTemporaryDirectory-		(tmp, h) <- openTempFile tmpdir "output.tmp"-		B.hPut h b'-		hClose h-		return (InTempFile tmp : 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-addBuffer v buf = return (v:buf)

@@ -1,4 +1,5 @@-Copyright 2015 Joey Hess <id@joeyh.name>.+Copyright © 2015 Joey Hess <id@joeyh.name>+Copyright © 2009 Joachim Breitner  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions

@@ -0,0 +1,485 @@+{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}++-- | +-- Copyright: 2013 Joey Hess <id@joeyh.name>+-- License: BSD-2-clause+-- +-- Concurrent output handling.+--+-- > import Control.Concurrent.Async+-- > import System.Console.Concurrent+-- >+-- > main = withConcurrentOutput $+-- > 	outputConcurrent "washed the car\n"+-- > 		`concurrently`+-- >	outputConcurrent "walked the dog\n"+-- >		`concurrently`+-- > 	createProcessConcurrent (proc "ls" [])++module System.Console.Concurrent (+	-- * Concurrent output+	withConcurrentOutput,+	Outputable(..),+	outputConcurrent,+	createProcessConcurrent,+	waitForProcessConcurrent,+	flushConcurrentOutput,+	lockOutput,+	-- * Low level access to the output buffer+	OutputBuffer,+	StdHandle(..),+	bufferOutputSTM,+	outputBufferWaiterSTM,+	waitAnyBuffer,+	waitCompleteLines,+	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')++-- | 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,540 @@+{-# LANGUAGE BangPatterns, TupleSections #-}++-- | +-- Copyright: 2013 Joey Hess <id@joeyh.name>+-- License: BSD-2-clause+-- +-- Console regions are displayed near the bottom of the console, and can be+-- updated concurrently by threads. Any other output displayed using+-- `outputConcurrent` and `createProcessConcurrent`+-- will scroll up above the open console regions.+--+-- For example, this program:+--+-- > import Control.Concurrent.Async+-- > import Control.Concurrent+-- > import System.Console.Concurrent+-- > import System.Console.Regions+-- > +-- > main = displayConsoleRegions $ do+-- > 	mapConcurrently download [1..5] `concurrently` mapM_ message [1..10]+-- > +-- > message :: Int -> IO ()+-- > message n = do+-- > 	threadDelay 500000+-- > 	outputConcurrent ("Message " ++ show n ++ "\n")+-- > +-- > download :: Int -> IO ()+-- > download n = withConsoleRegion Linear $ \r -> do+-- > 	setConsoleRegion r basemsg+-- > 	go n r+-- >   where+-- > 	basemsg = "Download " ++ show n+-- >	go c r+-- >		| c < 1 = finishConsoleRegion r (basemsg ++ " done!")+-- > 		| otherwise = do+-- > 			threadDelay 1000000+-- > 			appendConsoleRegion r " ... "+-- > 			go (c-1) r+--+-- Will display like this:+--+-- > Message 1+-- > Message 2+-- > Download 1 ...+-- > Download 2 ...+-- > Download 3 ...+--+-- Once the 1st download has finished, and another message has displayed,+-- the console will update like this:+--+-- > Message 1+-- > Message 2+-- > Download 1 done!+-- > Message 3+-- > Download 2 ... ...+-- > Download 3 ... ...++module System.Console.Regions (+	-- * Initialization+	displayConsoleRegions,+	ConsoleRegionHandle,+	RegionLayout(..),+	withConsoleRegion,+	openConsoleRegion,+	closeConsoleRegion,+	-- * Output+	setConsoleRegion,+	appendConsoleRegion,+	finishConsoleRegion,+	-- * STM interface+	--+	-- | These actions can be composed into a STM transaction; +	-- once the transaction completes the console will be updated+	-- a single time to reflect all the changes made.+	openConsoleRegionSTM,+	closeConsoleRegionSTM,+	setConsoleRegionSTM,+	appendConsoleRegionSTM,+	updateRegionListSTM,+) where++import Data.Monoid+import Data.Maybe+import Data.String+import Data.Char+import qualified Data.ByteString as B+import Control.Monad+import Control.Applicative+import Control.Monad.IO.Class (liftIO, MonadIO)+import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Concurrent.Async+import System.Console.ANSI+import qualified System.Console.Terminal.Size as Console+import System.IO+import System.IO.Unsafe (unsafePerformIO)+import System.Posix.Signals+import System.Posix.Signals.Exts++import System.Console.Concurrent+import Utility.Monad+import Utility.Exception++-- | Controls how a region is laid out in the console.+--+-- Here's an annotated example of how the console layout works.+--+-- > scrolling......+-- > scrolling......+-- > scrolling......+-- > aaaaaa......... -- Linear+-- > bbbbbbbbbbbbbbb -- Linear+-- > bbb............       (expanded to multiple lines)+-- > ccccccccc...... -- Linear+-- > ddd eee fffffff -- [InLine]+-- > ffff ggggg.....       (expanded to multiple lines)+-- > +data RegionLayout = Linear | InLine ConsoleRegionHandle+	deriving (Eq)++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+	, regionLayout :: RegionLayout+	, regionChildren :: Maybe [ConsoleRegionHandle]+	}++instance Eq Region where+	a == b = regionContent a == regionContent b+		&& regionLayout a == regionLayout b++type RegionList = TMVar [ConsoleRegionHandle]++-- | A shared global list of regions.+{-# NOINLINE regionList #-}+regionList :: RegionList+regionList = unsafePerformIO newEmptyTMVarIO++-- | 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+-- list.+updateRegionListSTM :: ([ConsoleRegionHandle] -> [ConsoleRegionHandle]) -> STM ()+updateRegionListSTM f = +	maybe noop (putTMVar regionList . f) =<< tryTakeTMVar regionList++-- | The RegionList TMVar is left empty when `displayConsoleRegions`+-- is not running.+regionDisplayEnabled :: IO Bool+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.+-}+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)))+	case regionLayout r of+		Linear -> return ()+		InLine p -> refreshParent p++-- | Appends the value to whatever was already on display within a console+-- region.+appendConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO ()+appendConsoleRegion h = atomically . appendConsoleRegionSTM h++appendConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM ()+appendConsoleRegionSTM (ConsoleRegionHandle tv) v = do+	r <- readTVar tv+	writeTVar tv (modifyRegion r (<> 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 }+  where+	!c = f (regionContent 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+withConsoleRegion l = bracketIO (openConsoleRegion l) closeConsoleRegion++-- | Opens a new console region for output.+openConsoleRegion :: RegionLayout -> IO ConsoleRegionHandle+openConsoleRegion = atomically . openConsoleRegionSTM++-- | STM version of `openConsoleRegion`. Allows atomically opening multiple+-- regions at the same time, which guarantees they are on adjacent lines.+--+-- > [r1, r2, r3] <- atomically $+-- >	replicateM 3 (openConsoleRegionSTM Linear)+openConsoleRegionSTM :: RegionLayout -> STM ConsoleRegionHandle+openConsoleRegionSTM ly = do+	let r = Region+		{ regionContent = mempty+		, regionHeight = calcRegionHeight mempty+		, regionLayout = ly+		, regionChildren = Nothing+		}+	h <- ConsoleRegionHandle <$> newTVar r+	case ly of+		Linear -> do+			v <- tryTakeTMVar regionList+			case v of+				Just l -> do putTMVar regionList (h:l)+				-- displayConsoleRegions is not active, so+				-- it's not put on any list, and won't display+				Nothing -> return ()+		InLine parent -> addChild h parent++	return h++-- | Closes a console region. Once closed, the region is removed from the+-- display.+closeConsoleRegion :: ConsoleRegionHandle -> IO ()+closeConsoleRegion = atomically . closeConsoleRegionSTM++closeConsoleRegionSTM :: ConsoleRegionHandle -> STM ()+closeConsoleRegionSTM h@(ConsoleRegionHandle tv) = do+	v <- tryTakeTMVar regionList+	case v of+		Just l ->+			let !l' = filter (/= h) l+			in putTMVar regionList l'+		_ -> return ()+	ly <- regionLayout <$> readTVar tv+	case ly of+		Linear -> return ()+		InLine parent -> removeChild h parent++-- | Closes the console region and displays the passed value in the+-- scrolling area above the active console regions.+finishConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO ()+finishConsoleRegion h = atomically . finishConsoleRegionSTM h++finishConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM ()+finishConsoleRegionSTM h v = do+	closeConsoleRegionSTM h+	bufferOutputSTM StdOut (toOutput v <> fromString "\n")++removeChild :: ConsoleRegionHandle -> ConsoleRegionHandle -> STM ()+removeChild child parent@(ConsoleRegionHandle pv) = do+	modifyTVar' pv $ \p -> case regionChildren p of+		Nothing -> p+		Just l -> p { regionChildren = Just $ filter (/= child) l }+	refreshParent parent++addChild :: ConsoleRegionHandle -> ConsoleRegionHandle -> STM ()+addChild child parent@(ConsoleRegionHandle pv) = do+	modifyTVar' pv $ \p -> p+		{ regionChildren = Just $ child : filter (/= child) (fromMaybe [] (regionChildren p)) }+	refreshParent parent++refreshParent :: ConsoleRegionHandle -> STM ()+refreshParent parent@(ConsoleRegionHandle pv) = do+	p <- readTVar pv+	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 }+			writeTVar pv p'++-- | Handles all display for the other functions in this module.+--+-- Note that this uses `lockOutput`, so it takes over all output to the+-- console while the passed IO action is running. As well as displaying+-- the console regions, this handles display of anything buffered by+-- `outputConcurrent` and `createProcessConcurrent`.+--+-- When standard output is not an ANSI capable terminal,+-- console regions are not displayed.+displayConsoleRegions :: (MonadIO m, MonadMask m) => m a -> m a+displayConsoleRegions a = ifM (liftIO regionDisplayEnabled)+	( a -- displayConsoleRegions is already running+	, lockOutput $ bracket setup cleanup (const a)+	)+  where+	setup = liftIO $ do+		atomically $ putTMVar regionList []+		endsignal <- atomically $ do+			s <- newTSem 1+			waitTSem s+			return s+		isterm <- liftIO $ hSupportsANSI stdout+		cwidth <- atomically newEmptyTMVar+		when isterm $+			trackConsoleWidth cwidth+		da <- async $ displayThread isterm cwidth endsignal+		return (isterm, da, endsignal)+	cleanup (isterm, da, endsignal) = liftIO $ do+		atomically $ signalTSem endsignal+		void $ wait da+		void $ atomically $ takeTMVar regionList+		when isterm $+			installResizeHandler Nothing++trackConsoleWidth :: TMVar Width -> IO ()+trackConsoleWidth cwidth = 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+	getwidth+	installResizeHandler $ Just getwidth++data DisplayChange+	= BufferChange [(StdHandle, OutputBuffer)]+	| RegionChange RegionSnapshot+	| TerminalResize (Maybe Width)+	| EndSignal ()++type RegionSnapshot = ([ConsoleRegionHandle], [Region], Maybe Width)++displayThread :: Bool -> TMVar Width -> TSem -> IO ()+displayThread isterm cwidth endsignal = do+	origwidth <- atomically $ tryReadTMVar cwidth+	go ([], [], origwidth)+  where+	go origsnapshot@(orighandles, origregions, origwidth) = do+		let waitwidthchange = do+			v <- tryReadTMVar cwidth+			if v == origwidth then retry else return v+		change <- atomically $+			(RegionChange <$> regionWaiter origsnapshot)+				`orElse`+			(RegionChange <$> regionListWaiter origsnapshot)+				`orElse`+			(BufferChange <$> outputBufferWaiterSTM waitCompleteLines)+				`orElse`+			(TerminalResize <$> waitwidthchange)+				`orElse`+			(EndSignal <$> waitTSem endsignal)+		case change of+			RegionChange snapshot@(_, regions, _) -> do+				when isterm $+					changedRegions origregions regions+				go snapshot+			BufferChange buffers -> do+				inAreaAbove isterm origregions $+					mapM_ (uncurry emitOutputBuffer) buffers+				go origsnapshot+			TerminalResize width -> do+				when isterm $+					-- force redraw of all regions+					inAreaAbove isterm origregions $+						return ()+				go (orighandles, origregions, width)+			EndSignal () -> return ()++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+	handles <- readTMVar regionList+	if handles == orighandles+		then retry+		else (handles,,origwidth) <$> readRegions handles+		+-- Wait for any changes to any of the regions currently in the region list.+regionWaiter :: RegionSnapshot -> STM RegionSnapshot+regionWaiter (orighandles, origregions, origwidth) = do+	rs <- readRegions orighandles+	if rs == origregions+		then retry+		else return (orighandles, rs, origwidth)++-- 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+	| delta == 0 = do+		-- The total number of regions is unchanged, so update+		-- whichever ones have changed, and leave the rest as-is.+		diffUpdate origregions regions+	| delta > 0 = do+		-- Added more regions, so output each, with a+		-- newline, thus scrolling the old regions 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+	| otherwise = do+		-- Some regions were removed. Move up that many lines,+		-- clearing each line, and update any changed regions.+		replicateM_ (abs delta) $ do+			cursorUpLine 1+			clearLine+		diffUpdate (drop (abs delta) origregions) regions+  where+	delta = length regions - length origregions++-- 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)+  where+	changed = map (uncurry (/=)) (zip regions origregions) ++ 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+-- beginning, and is put back there at the end.+updateRegions :: [(Region, Bool)] -> IO ()+updateRegions l+	| null l' = noop+	| otherwise = do+		forM_ l' $ \(r, offset) -> do+			cursorUpLine offset+			clearLine+			B.hPut stdout (regionContent r)+			hFlush stdout+		cursorDownLine (sum (map snd 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+	when isterm $ do+		unless (null regions) $+			cursorUpLine (length regions)+		clearFromCursorToScreenEnd+	outputter+	when isterm $ do+		setCursorColumn 0 -- just in case the output lacked a newline+		displayRegions (reverse regions)+	hFlush stdout++displayRegions :: [Region] -> IO ()+displayRegions = mapM_ $ \r -> do+	B.hPut stdout (regionContent r)+	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)+  where+	wnl = fromIntegral (ord '\n')++-- Calculate the height a line would occupy if output onto a console+-- with a given width, starting from the first column.+--+-- Note that this counts each byte, is not aware of multibyte characters,+-- so will over-estimate a bit for those.+--+-- 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++-- ANSI sequences and control characters.+countInvisibleBytes :: B.ByteString -> Int+countInvisibleBytes = go 0 . breakesc+  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))+	  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'))++	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)++countControlChars :: B.ByteString -> Int+countControlChars = length . filter iscontrol8 . B.unpack+  where+	iscontrol8 c = c < 32 || c == 127 -- del

@@ -0,0 +1,5 @@+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.

@@ -0,0 +1,30 @@+-- Demo similar to apt-get's download display.++import Control.Concurrent.Async+import Control.Concurrent+import System.Console.Concurrent+import System.Console.Regions++main = displayConsoleRegions $ do+	mapConcurrently downline+		[ ["foo", "bar", "baz"]+		, ["pony", "mango", "very_large"]+		]+		`concurrently` mapM_ message [1..20]++message n = do+	threadDelay 500000+	outputConcurrent ("Updated blah blah #" ++ show n ++ "\n")++downline cs = withConsoleRegion Linear $ \r -> +	mapConcurrently (kid r) (reverse cs)+  where+	kid parent c = withConsoleRegion (InLine parent) (go c 0)+	go c n r+		| n <= 100 = do+			setConsoleRegion r $+				"[" ++ c ++ " " ++ show n ++ "%] "+			threadDelay (25000 * length c)+			go c (n+1) r+		| otherwise = finishConsoleRegion r $+			"Downloaded " ++ c ++ ".deb"

@@ -1,21 +1,33 @@ Name: concurrent-output-Version: 1.0.1+Version: 1.1.0 Cabal-Version: >= 1.8-License: BSD3+License: BSD2 Maintainer: Joey Hess <id@joeyh.name>-Author: Joey Hess+Author: Joey Hess, Joachim Breitner Stability: Stable-Copyright: 2015 Joey Hess+Copyright: 2015 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple-Category: Concurrency-Synopsis: handling concurrent output+Category: User Interfaces+Synopsis: Ungarble output from several threads Description:  Provides a simple interface for writing concurrent programs that- need to output a lot of status messages to the console, and/or run- concurrent external commands that output to the console.+ need to output a lot of status messages to the console, or display+ multiple progress bars for different activities at the same time,+ or concurrently run external commands that output to the console.+ .+ Built on top of that is a way of defining multiple output regions,+ which are automatically laid out on the screen and can be individually+ updated. Can be used for progress displays etc.+ .+ <<https://joeyh.name/code/concurrent-output/demo2.gif>> Extra-Source-Files:   CHANGELOG+  TODO+  demo.hs+  demo2.hs+  demo3.hs+  aptdemo.hs  Library   GHC-Options: -Wall -fno-warn-tabs -O2@@ -27,11 +39,13 @@     , process (>= 1.2.0 && < 1.4.0)     , unix (>= 2.7.0 && < 2.8.0)     , directory (>= 1.2.0 && < 1.3.0)-    , containers (>= 0.5.0 && < 0.6.0)     , transformers (>= 0.3.0 && < 0.5.0)     , exceptions (>= 0.8.0 && < 0.9.0)+    , ansi-terminal (>= 0.6.0 && < 0.7.0)+    , terminal-size (>= 0.3.0 && < 0.4.0)   Exposed-Modules:-    Control.Concurrent.Output+    System.Console.Concurrent+    System.Console.Regions   Other-Modules:     Utility.Monad     Utility.Data

@@ -0,0 +1,41 @@+import Control.Concurrent.Async+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..15]+		`concurrently` ls++message :: Int -> IO ()+message n = do+	threadDelay 300000+	outputConcurrent ("Message " ++ show n ++ "\n")++download :: Int -> IO ()+download n = withConsoleRegion Linear $ \r -> do+	threadDelay (10000 * n)+	setConsoleRegion r basemsg+	go n r+  where+	basemsg = "Download " ++ show n+	go c r+		| c < 1 = finishConsoleRegion r+			(basemsg ++ " done!\n  Took xxx seconds.")+		| otherwise = do+			threadDelay 1000000+			appendConsoleRegion r " ... "+			go (c-1) r++ls :: IO ()+ls = do+	threadDelay 1000000+	(Nothing, Nothing, Nothing, p) <- createProcessConcurrent (proc "ls" ["-C"])+	outputConcurrent "started running ls >>>"+	_ <- waitForProcess p+	outputConcurrent "<<< ls is done!\n"+	return ()+	+	

@@ -0,0 +1,29 @@+import Control.Concurrent.Async+import Control.Concurrent+import System.Console.Concurrent+import System.Console.Regions++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  30 2 "KleisiFish?" setConsoleRegion "  <=<   <=<  " (withtitle 10)+	, spinner  10 9 "Countdowns!" setConsoleRegion+		(reverse [1..10])+		(\t n -> t ++ show (head n))+	]+  where+	withtitle n t s = t ++ take n s++spinner :: Int -> Int -> String -> (ConsoleRegionHandle -> String -> IO ()) -> [s] -> (String -> [s] -> String) -> IO ()+spinner cycles delay title updater source f =+	withConsoleRegion Linear $ \r -> do+		setConsoleRegion r title'+		mapM_ (go r) (zip [1..cycles] sourcestream)+		finishConsoleRegion r ("Enough " ++ title)+  where+	title' = title ++ "  "+	sourcestream = repeat (concat (repeat source))+	go r (n, s) = do+		updater r (f title' (drop n s))+		threadDelay (delay * 100000)

@@ -0,0 +1,12 @@+import Control.Concurrent.Async+import System.Console.Concurrent+import System.Process++main = withConcurrentOutput $+	outputConcurrent "washed the car\n"+		`concurrently`+	createProcessConcurrent (proc "ls" [])+		`concurrently`+	createProcessConcurrent (proc "sh" ["-c", "echo \"hi from echo!\" >&2"])+		`concurrently`+	outputConcurrent "walked the dog\n"