concurrent-output 1.7.9 → 1.8.0

raw patch · 5 files changed

+83/−30 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +10/−0
• LICENSE +1/−1
• System/Console/Regions.hs +31/−17
• concurrent-output.cabal +2/−2
• stmdemo.hs +39/−10

@@ -1,3 +1,13 @@+concurrent-output (1.8.0) unstable; urgency=medium++  * Added displayUpdateNotifier, which can be used to wait for+    changes to console regions to be displayed.+    (stmdemo has an example of using that to temporarily shut down the+    region based display to run a bash prompt, and restore the region+    display later.)++ -- Joey Hess <id@joeyh.name>  Fri, 12 May 2017 16:27:41 -0400+ concurrent-output (1.7.9) unstable; urgency=medium    * Allow lazy text to be used as an Outputable value, and as

@@ -1,4 +1,4 @@-Copyright © 2015 Joey Hess <id@joeyh.name>+Copyright © 2015-2017 Joey Hess <id@joeyh.name> Copyright © 2009 Joachim Breitner  Redistribution and use in source and binary forms, with or without

@@ -108,6 +108,8 @@ 	consoleWidth, 	consoleHeight, 	regionList,+	displayUpdateNotifier,+	DisplayChange(..), ) where  import Data.Monoid@@ -207,11 +209,17 @@ consoleHeight :: STM Int consoleHeight = Console.height <$> readTVar consoleSize --- | The RegionList TMVar is left empty when `displayConsoleRegions`--- is not running.+-- | Check if `displayConsoleRegions` is running. regionDisplayEnabled :: IO Bool regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList +-- | This is a broadcast TChan, which gets a DisplayChange written to it+-- after the display has been updated. It can be used to wait for something+-- to be displayed.+{-# NOINLINE displayUpdateNotifier #-}+displayUpdateNotifier :: TChan DisplayChange+displayUpdateNotifier = unsafePerformIO $ newBroadcastTChanIO+ -- | Many actions in this module can be run in either the IO monad -- or the STM monad. Using STM allows making several changes to the -- displayed regions atomically, with the display updated a single time.@@ -431,17 +439,19 @@  trackConsoleWidth :: IO () trackConsoleWidth = do-	let getwidth = maybe noop (atomically . writeTVar consoleSize)+	let getsz = maybe noop (atomically . writeTVar consoleSize) 		=<< Console.size-	getwidth-	installResizeHandler (Just getwidth)+	getsz+	installResizeHandler (Just getsz)  data DisplayChange-	= BufferChange (StdHandle, OutputBuffer)+	= BufferChange BufferSnapshot  	| RegionChange RegionSnapshot+	| RegionListChange RegionSnapshot 	| TerminalResize Width-	| EndSignal ()+	| Shutdown +type BufferSnapshot = (StdHandle, OutputBuffer) type RegionSnapshot = ([ConsoleRegion], [R], [[Text]])  displayThread :: Bool -> TSem -> IO ()@@ -456,22 +466,24 @@ 		let waitanychange = 			(RegionChange <$> regionWaiter origsnapshot origwidth) 				`orElse`-			(RegionChange <$> regionListWaiter origsnapshot)+			(RegionListChange <$> regionListWaiter origsnapshot) 				`orElse` 			(BufferChange <$> outputBufferWaiterSTM waitCompleteLines) 				`orElse` 			(TerminalResize <$> waitwidthchange) 				`orElse`-			(EndSignal <$> waitTSem endsignal)+			(waitTSem endsignal >> pure Shutdown) 		(change, height) <- atomically $ (,) 			<$> waitanychange 			<*> consoleHeight 		let onscreen = take (height - 1) . concat-		case change of-			RegionChange snapshot@(_, _, newlines) -> do-				when isterm $ do-					changedLines (onscreen origlines) (onscreen newlines)-				go snapshot origwidth+		let update snapshot@(_, _, newlines) = do+			when isterm $ do+				changedLines (onscreen origlines) (onscreen newlines)+			return $ go snapshot origwidth+		next <- case change of+			RegionChange snapshot -> update snapshot+			RegionListChange snapshot -> update snapshot 			BufferChange (h, buf) -> do 				-- Note that even when every available line 				-- is dedicated to visible regions, the@@ -481,13 +493,15 @@ 				let origlines' = onscreen origlines 				inAreaAbove isterm (length origlines') origlines' $ 					emitOutputBuffer h buf-				go origsnapshot origwidth+				return $ go origsnapshot origwidth 			TerminalResize newwidth -> do 				newlines <- atomically (mapM (resizeRegion newwidth) orighandles) 				when isterm $ do 					resizeRecovery (onscreen newlines)-				go (orighandles, origregions, newlines) newwidth-			EndSignal () -> return ()+				return $ go (orighandles, origregions, newlines) newwidth+			Shutdown -> return $ return ()+		atomically $ writeTChan displayUpdateNotifier change+		next  readRegions :: [ConsoleRegion] -> STM [R] readRegions = mapM (\(ConsoleRegion h) -> readTVar h)

@@ -1,11 +1,11 @@ Name: concurrent-output-Version: 1.7.9+Version: 1.8.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess, Joachim Breitner Stability: Stable-Copyright: 2015 Joey Hess, 2009 Joachim Breitner+Copyright: 2015-2017 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple Category: User Interfaces

@@ -7,15 +7,25 @@ import Data.Time.Clock import Control.Monad import Data.Monoid+import System.Process  main :: IO () main = void $ displayConsoleRegions $ do+	void titleRegion 	ir <- infoRegion 	cr <- clockRegion 	rr <- rulerRegion 	growingDots+	runBash+	growingDots 	mapM_ closeConsoleRegion [ir, cr] +titleRegion :: IO ConsoleRegion+titleRegion = do+	r <- openConsoleRegion Linear+	setConsoleRegion r "STM demo!"+	return r+ infoRegion :: IO ConsoleRegion infoRegion = do 	r <- openConsoleRegion Linear@@ -48,24 +58,43 @@ 		rightAlign r 		return r +rulerRegion :: IO ConsoleRegion+rulerRegion = do+	r <- openConsoleRegion Linear+	setConsoleRegion r $ do+		width <- consoleWidth+		return $ T.pack $ take width nums+	return r+  where+	nums = cycle $ concatMap show [0..9]+ rightAlign :: ConsoleRegion -> STM () rightAlign r = tuneDisplay r $ \t -> do         w <- consoleWidth         return (T.replicate (w - T.length t) (T.singleton ' ') <> t) +growingDots :: IO () growingDots = withConsoleRegion Linear $ \r -> do 	atomically $ rightAlign r 	width <- atomically consoleWidth-	replicateM width $ do+	void $ replicateM width $ do 		appendConsoleRegion r "."  		threadDelay (100000) -rulerRegion :: IO ConsoleRegion-rulerRegion = do-	r <- openConsoleRegion Linear-	setConsoleRegion r $ do-		width <- consoleWidth-		return $ T.pack $ take width nums-	return r-  where-	nums = cycle $ concatMap show [0..9]+runBash :: IO ()+runBash = do+	c <- atomically $ dupTChan displayUpdateNotifier+	-- Temporarily clear whatever console regions are open.+	rs <- atomically $ swapTMVar regionList []+	atomically $ waitDisplayUpdate c+	putStrLn "We interrupt this demo to run a shell prompt. exit to continue!"+	callCommand "bash"+	-- Restore the console regions.+	void $ atomically $ swapTMVar regionList rs++waitDisplayUpdate :: TChan DisplayChange -> STM ()+waitDisplayUpdate c = do+	v <- readTChan c+	case v of+		RegionListChange ([],_,_) -> return ()+		_ -> waitDisplayUpdate c