concurrent-output 1.5.0 → 1.6.0

raw patch · 8 files changed

+117/−43 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +15/−0
• System/Console/Concurrent.hs +4/−0
• System/Console/Concurrent/Internal.hs +16/−10
• System/Console/Regions.hs +64/−26
• System/Process/Concurrent.hs +4/−0
• aptdemo.hs +5/−0
• concurrent-output.cabal +5/−3
• stmdemo.hs +4/−4

@@ -1,3 +1,18 @@+concurrent-output (1.6.0) unstable; urgency=medium++  * Generalized newConsoleRegion. +  * Better efficiency when there are more regions than will fit on the+    screen.+  * Fixed consoleHeight (was returning width)+  * Fix outputBufferWaiterSTM which never returned any buffered stderr,+    and fix regional display of buffered error messages.+  * Ported to Windows, although createProcessConcurrent is omitted due to+    needing support for pipe(), and consoleSize is not updated by resize.+  * Stopped exporting consoleSize; use consoleWidth and consoleHeight+    instead.++ -- Joey Hess <id@joeyh.name>  Thu, 05 Nov 2015 15:35:16 -0400+ concurrent-output (1.5.0) unstable; urgency=medium    * Added errorConcurrent.

@@ -14,6 +14,8 @@ -- >		`concurrently` -- > 	createProcessConcurrent (proc "ls" []) +{-# LANGUAGE CPP #-}+ module System.Console.Concurrent ( 	-- * Concurrent output 	withConcurrentOutput,@@ -21,7 +23,9 @@ 	outputConcurrent, 	errorConcurrent, 	ConcurrentProcessHandle,+#ifndef mingw32_HOST_OS 	createProcessConcurrent,+#endif 	waitForProcessConcurrent, 	createProcessForeground, 	flushConcurrentOutput,

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-}+{-# LANGUAGE CPP #-}  -- |  -- Copyright: 2015 Joey Hess <id@joeyh.name>@@ -11,7 +12,9 @@ module System.Console.Concurrent.Internal where  import System.IO+#ifndef mingw32_HOST_OS import System.Posix.IO+#endif import System.Directory import System.Exit import Control.Monad@@ -253,6 +256,9 @@ -- the process is instead run with its stdout and stderr -- redirected to a buffer. The buffered output will be displayed as soon -- as the output lock becomes free.+--+-- Currently only available on Unix systems, not Windows.+#ifndef mingw32_HOST_OS createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)  createProcessConcurrent p 	| willOutput (P.std_out p) || willOutput (P.std_err p) =@@ -265,6 +271,7 @@ 		asyncProcessWaiter $ 			void $ tryIO $ P.waitForProcess h 		return (toConcurrentProcessHandle r)+#endif  -- | Wrapper around `System.Process.createProcess` that makes sure a process -- is run in the foreground, with direct access to stdout and stderr.@@ -284,6 +291,7 @@ 		dropOutputLock 	return (toConcurrentProcessHandle r) +#ifndef mingw32_HOST_OS bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) bgProcess p = do 	(toouth, fromouth) <- pipe@@ -307,6 +315,7 @@ 	rediroutput ss h 		| willOutput ss = P.UseHandle h 		| otherwise = ss+#endif  willOutput :: P.StdStream -> Bool willOutput P.Inherit = True@@ -483,19 +492,16 @@ -- -- 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+outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM (StdHandle, OutputBuffer)+outputBufferWaiterSTM selector = waitgetbuf StdOut `orElse` waitgetbuf StdErr+  where+	waitgetbuf h = do 		let bv = bufferFor h 		(selected, rest) <- selector <$> takeTMVar bv+		when (selected == OutputBuffer [])+			retry 		putTMVar bv rest-		return selected-	if all (== OutputBuffer []) bs-		then retry-		else do-			return (zip hs bs)-  where-	hs = [StdOut, StdErr]+		return (h, selected)  waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer) waitAnyBuffer b = (b, OutputBuffer [])

@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns, TupleSections, TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE CPP #-}  -- |  -- Copyright: 2015 Joey Hess <id@joeyh.name>@@ -88,21 +88,20 @@ 	-- For example, a region that displays the screen size, 	-- and automatically refreshes it: 	---	-- > import System.Console.Terminal.Size 	-- > import qualified Data.Text as T 	-- 	-- > r <- openConsoleRegion Linear s 	-- > setConsoleRegion r $ do-	-- > 	sz <- readTVar consoleSize+	-- > 	w <- readTVar consoleWidth+	-- > 	h <- readTVar consoleHeight 	-- > 	return $ T.pack $ unwords 	-- > 		[ "size:"-	-- >		, show (width sz)+	-- >		, show w 	-- > 		, "x"-	-- >		, show (height sz)+	-- >		, show h 	-- > 		] 	-- > 	RegionContent(..),-	consoleSize, 	consoleWidth, 	consoleHeight, 	regionList,@@ -124,10 +123,12 @@ 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 Text.Read import Data.List+#ifndef mingw32_HOST_OS+import System.Posix.Signals+import System.Posix.Signals.Exts+#endif  import System.Console.Concurrent import Utility.Monad@@ -175,8 +176,9 @@ regionList :: TMVar [ConsoleRegion] regionList = unsafePerformIO newEmptyTMVarIO --- | On unix systems, this TVar is automatically updated when the--- terminal is resized.+-- | On Unix systems, this TVar is automatically updated when the+-- terminal is resized. On Windows, it is only initialized on program start+-- with the current terminal size. {-# NOINLINE consoleSize #-} consoleSize :: TVar (Console.Window Int) consoleSize = unsafePerformIO $ newTVarIO $ @@ -184,13 +186,24 @@  type Width = Int --- | Get the width from the `consoleSize`+-- | Gets the width of the console.+--+-- On Unix, this is automatically updated when the terminal is resized.+-- On Windows, it is only initialized on program start. consoleWidth :: STM Int-consoleWidth = Console.width <$> readTVar consoleSize+consoleWidth = munge . Console.width <$> readTVar consoleSize+  where+#ifndef mingw32_HOST_OS+	munge = id+#else+	-- On Windows, writing to the right-most column caused some+	-- problimatic wrap, so avoid it.+	munge = pred+#endif  -- | Get the height from the `consoleSize` consoleHeight :: STM Int-consoleHeight = Console.width <$> readTVar consoleSize+consoleHeight = Console.height <$> readTVar consoleSize  -- | The RegionList TMVar is left empty when `displayConsoleRegions` -- is not running.@@ -304,8 +317,8 @@ 	return h  -- | Makes a new region, but does not add it to the display.-newConsoleRegion :: ToRegionContent v => RegionLayout -> v -> STM ConsoleRegion-newConsoleRegion ly v = do+newConsoleRegion :: (LiftRegion m) => ToRegionContent v => RegionLayout -> v -> m ConsoleRegion+newConsoleRegion ly v = liftRegion $ do 	rc <- newTVar mempty 	rl <- newTVar mempty 	rs <- newTVar mempty@@ -439,7 +452,7 @@ 	installResizeHandler (Just getwidth)  data DisplayChange-	= BufferChange [(StdHandle, OutputBuffer)]+	= BufferChange (StdHandle, OutputBuffer) 	| RegionChange RegionSnapshot 	| TerminalResize Width 	| EndSignal ()@@ -455,7 +468,7 @@ 		let waitwidthchange = do 			w <- consoleWidth 			if w == origwidth then retry else return w-		change <- atomically $+		let waitanychange = 			(RegionChange <$> regionWaiter origsnapshot origwidth) 				`orElse` 			(RegionChange <$> regionListWaiter origsnapshot)@@ -465,21 +478,31 @@ 			(TerminalResize <$> waitwidthchange) 				`orElse` 			(EndSignal <$> waitTSem endsignal)+		(change, height) <- atomically $ (,)+			<$> waitanychange+			<*> consoleHeight+		let onscreen = take (height - 1) . concat 		case change of 			RegionChange snapshot@(_, _, newlines) -> do 				when isterm $ do-					changedLines (concat origlines) (concat newlines)+					changedLines (onscreen origlines) (onscreen newlines) 				go snapshot origwidth-			BufferChange buffers -> do-				inAreaAbove isterm (length $ concat origlines) (concat origlines) $-					mapM_ (uncurry emitOutputBuffer) buffers+			BufferChange (h, buf) -> do+				-- Note that even when every available line+				-- is dedicated to visible regions, the+				-- buffer is still displayed. It would be+				-- more efficient to not display it, but+				-- this makes it available in scroll back.+				let origlines' = onscreen origlines+				inAreaAbove isterm (length origlines') origlines' $+					emitOutputBuffer h buf 				go origsnapshot origwidth 			TerminalResize newwidth -> do 				(newregions, lls) <- unzip <$>  					atomically (mapM (resizeRegion newwidth) orighandles) 				let newlines = map reverse lls 				when isterm $ do-					resizeRecovery newlines+					resizeRecovery (onscreen newlines) 				go (orighandles, newregions, newlines) newwidth 			EndSignal () -> return () @@ -563,8 +586,16 @@ 	| otherwise = do 		forM_ l' $ \((newt, offset), oldt) -> do 			cursorUpLine offset-			T.hPutStr stdout $ +#ifndef mingw32_HOST_OS+			T.hPutStr stdout $ 				genLineUpdate $ calcLineUpdate oldt newt+#else+			-- Windows does not support ansi characters+			-- emitted in a string, so do a full line+			-- redraw.+			T.hPutStr stdout newt+			clearFromCursorToLineEnd+#endif 		cursorDownLine (sum (map (snd . fst) l')) 		setCursorColumn 0 		hFlush stdout@@ -576,10 +607,10 @@ -- The resize can change the position of the cursor, which would garble -- the display going forward. To fix, the cursor is moved to the top of -- the screen, which is cleared, and all regions are redrawn from there.-resizeRecovery :: [[Text]] -> IO ()+resizeRecovery :: [Text] -> IO () resizeRecovery newlines = do 	setCursorPosition 0 0-	inAreaAbove True 0 (concat newlines) $+	inAreaAbove True 0 newlines $ 		return ()  -- Move cursor up before the lines, performs some output there,@@ -591,6 +622,9 @@ 		unless (numlines < 1) $ 			cursorUpLine $ numlines 		clearFromCursorToScreenEnd+	-- Flush stdout now, because the outputter may write to stderr, so+	-- the cursor needs to be moved first.+	hFlush stdout 	outputter 	when isterm $ do 		setCursorColumn 0 -- just in case the output lacked a newline@@ -603,8 +637,12 @@ 	putChar '\n'  installResizeHandler :: Maybe (IO ()) -> IO ()+#ifndef mingw32_HOST_OS installResizeHandler h = void $ 	installHandler windowChange (maybe Default Catch h) Nothing+#else+installResizeHandler _ = return ()+#endif  calcRegionLines :: R -> Text -> Width -> STM [Text] calcRegionLines r content width = do

@@ -5,6 +5,8 @@ -- 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.+--+-- Not currently available on Windows.  module System.Process.Concurrent where @@ -19,6 +21,8 @@ -- You should use the waitForProcess in this module on the resulting -- ProcessHandle. Using System.Process.waitForProcess instead can have -- mildly unexpected results.+--+-- Not available on Windows. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do 	(i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p

@@ -12,10 +12,15 @@ 		, [dl "foo", dl "bar", dl "very large"] 		] 		`concurrently` mapM_ message [1..20]+		`concurrently` mapM_ errormessage [2,6..20]  message n = do 	threadDelay 500000 	outputConcurrent ("Updated blah blah #" ++ show n ++ "\n")++errormessage n = do+	threadDelay 2300000+	outputConcurrent ("Failed to frob " ++ show n ++ "\n")  downline cs = withConsoleRegion Linear $ \r -> 	mapConcurrently (\a -> a r) (reverse cs)

@@ -1,5 +1,5 @@ Name: concurrent-output-Version: 1.5.0+Version: 1.6.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -37,7 +37,6 @@     , async (>= 2.0 && < 2.1)     , stm (>= 2.0 && < 2.5)     , process (>= 1.2.0 && < 1.4.0)-    , unix (>= 2.7.0 && < 2.8.0)     , directory (>= 1.2.0 && < 1.3.0)     , transformers (>= 0.3.0 && < 0.5.0)     , exceptions (>= 0.8.0 && < 0.9.0)@@ -47,11 +46,14 @@     System.Console.Concurrent     System.Console.Concurrent.Internal     System.Console.Regions-    System.Process.Concurrent   Other-Modules:     Utility.Monad     Utility.Data     Utility.Exception++  if (! os(Windows))+    Build-Depends: unix (>= 2.7.0 && < 2.8.0)+    Exposed-Modules: System.Process.Concurrent  source-repository head   type: git

@@ -1,7 +1,6 @@ import Control.Concurrent.Async import Control.Concurrent import System.Console.Regions-import System.Console.Terminal.Size import qualified Data.Text as T import Control.Concurrent.STM import Control.Applicative@@ -21,13 +20,14 @@ infoRegion = do 	r <- openConsoleRegion Linear 	setConsoleRegion r $ do-	 	sz <- readTVar consoleSize+	 	w <- readTVar consoleWidth+	 	h <- readTVar consoleHeight 		regions <- readTMVar regionList  		return $ T.pack $ unwords  			[ "size:"-			, show (width sz)+			, show w  			, "x"-			, show (height sz)+			, show h 			, "regions: " 			, show (length regions)  			]