concurrent-output 1.8.0 → 1.9.0

raw patch · 4 files changed

+61/−26 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +7/−0
• System/Console/Regions.hs +52/−15
• concurrent-output.cabal +1/−1
• stmdemo.hs +1/−10

@@ -1,3 +1,10 @@+concurrent-output (1.9.0) unstable; urgency=medium++  * Replaced displayUpdateNotifier with a simpler and safer+    waitDisplayChange interface.++ -- Joey Hess <id@joeyh.name>  Fri, 12 May 2017 17:17:09 -0400+ concurrent-output (1.8.0) unstable; urgency=medium    * Added displayUpdateNotifier, which can be used to wait for

@@ -108,8 +108,7 @@ 	consoleWidth, 	consoleHeight, 	regionList,-	displayUpdateNotifier,-	DisplayChange(..),+	waitDisplayChange, ) where  import Data.Monoid@@ -213,13 +212,6 @@ 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.@@ -450,19 +442,57 @@ 	| RegionListChange RegionSnapshot 	| TerminalResize Width 	| Shutdown+	| DisplayChangeBarrier Barrier  type BufferSnapshot = (StdHandle, OutputBuffer) type RegionSnapshot = ([ConsoleRegion], [R], [[Text]])+type Barrier = Integer +-- | 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++{-# NOINLINE displayChangeBarrier #-}+displayChangeBarrier :: TVar Barrier+displayChangeBarrier = unsafePerformIO $ newTVarIO 0++-- | Runs a STM action, and waits for the display to be fully updated+-- before returning.+waitDisplayChange :: STM a -> IO a+waitDisplayChange a = do+	r <- atomically a+	c <- atomically $ dupTChan displayUpdateNotifier+	b <- atomically $ do+		!b <- succ <$> readTVar displayChangeBarrier+		writeTVar displayChangeBarrier b+		return b+	atomically $ waitchange c b+	return r+  where+	waitchange c b = do+		change <- readTChan c+		case change of+			DisplayChangeBarrier b' | b' == b -> return ()+			_ -> waitchange c b+ displayThread :: Bool -> TSem -> IO () displayThread isterm endsignal = do 	origwidth <- atomically consoleWidth-	go ([], [], []) origwidth+	origbarrier <- atomically (readTVar displayChangeBarrier)+	go ([], [], []) origwidth origbarrier   where-	go origsnapshot@(orighandles, origregions, origlines) origwidth = do+	go origsnapshot@(orighandles, origregions, origlines) origwidth origbarrier = do 		let waitwidthchange = do 			w <- consoleWidth 			if w == origwidth then retry else return w+		let waitbarrierchange = do+			b <- readTVar displayChangeBarrier+			if b /= origbarrier+				then return b+				else retry 		let waitanychange = 			(RegionChange <$> regionWaiter origsnapshot origwidth) 				`orElse`@@ -473,6 +503,10 @@ 			(TerminalResize <$> waitwidthchange) 				`orElse` 			(waitTSem endsignal >> pure Shutdown)+				`orElse`+			-- Must come last, so the changes above are+			-- processed before barriers.+			(DisplayChangeBarrier <$> waitbarrierchange) 		(change, height) <- atomically $ (,) 			<$> waitanychange 			<*> consoleHeight@@ -480,7 +514,7 @@ 		let update snapshot@(_, _, newlines) = do 			when isterm $ do 				changedLines (onscreen origlines) (onscreen newlines)-			return $ go snapshot origwidth+			return $ go snapshot origwidth origbarrier 		next <- case change of 			RegionChange snapshot -> update snapshot 			RegionListChange snapshot -> update snapshot@@ -493,13 +527,16 @@ 				let origlines' = onscreen origlines 				inAreaAbove isterm (length origlines') origlines' $ 					emitOutputBuffer h buf-				return $ go origsnapshot origwidth+				return $ go origsnapshot origwidth origbarrier 			TerminalResize newwidth -> do 				newlines <- atomically (mapM (resizeRegion newwidth) orighandles) 				when isterm $ do 					resizeRecovery (onscreen newlines)-				return $ go (orighandles, origregions, newlines) newwidth-			Shutdown -> return $ return ()+				return $ go (orighandles, origregions, newlines) newwidth origbarrier+			Shutdown ->+				return $ return ()+			DisplayChangeBarrier b ->+				return $ go origsnapshot origwidth b 		atomically $ writeTChan displayUpdateNotifier change 		next 

@@ -1,5 +1,5 @@ Name: concurrent-output-Version: 1.8.0+Version: 1.9.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>

@@ -83,18 +83,9 @@  runBash :: IO () runBash = do-	c <- atomically $ dupTChan displayUpdateNotifier 	-- Temporarily clear whatever console regions are open.-	rs <- atomically $ swapTMVar regionList []-	atomically $ waitDisplayUpdate c+	rs <- waitDisplayChange $ swapTMVar regionList [] 	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