concurrent-output 1.2.0 → 1.3.0

raw patch · 7 files changed

+247/−101 lines, 7 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +11/−0
• System/Console/Regions.hs +174/−92
• TODO +0/−4
• concurrent-output.cabal +2/−1
• demo.hs +4/−3
• demo2.hs +7/−1
• stmdemo.hs +49/−0

@@ -1,3 +1,14 @@+concurrent-output (1.3.0) unstable; urgency=medium++  * The contents of a Region can now be set to a STM Text+    transaction. Their display will be automatically updated whenever the+    transaction's value changes.+  * Removed updateRegionListSTM, and export regionList instead, which is+    more general-purpose.+  * Other improvements to STM interface.++ -- Joey Hess <id@joeyh.name>  Tue, 03 Nov 2015 15:50:47 -0400+ concurrent-output (1.2.0) unstable; urgency=medium    * Avoid crash when not all of a program's output is consumed, as

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, TupleSections #-}+{-# LANGUAGE BangPatterns, TupleSections, TypeSynonymInstances, FlexibleInstances #-}  -- |  -- Copyright: 2015 Joey Hess <id@joeyh.name>@@ -68,7 +68,8 @@ 	withConsoleRegion, 	openConsoleRegion, 	closeConsoleRegion,-	-- * Output+	-- * Region display+	Displayable(..), 	setConsoleRegion, 	appendConsoleRegion, 	finishConsoleRegion,@@ -78,10 +79,38 @@ 	-- once the transaction completes the console will be updated 	-- a single time to reflect all the changes made. 	openConsoleRegionSTM,+	newConsoleRegionSTM, 	closeConsoleRegionSTM, 	setConsoleRegionSTM, 	appendConsoleRegionSTM,-	updateRegionListSTM,+	-- * STM regions+	--+	-- | The `Displayable` instance for STM text can be used to+	-- make regions that automatically update whenever there's+	-- a change to any of the STM values that they use.+	--+	-- 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+	-- > 	return $ T.pack $ unwords+	-- > 		[ "size:"+	-- >		, show (width sz)+	-- > 		, "x"+	-- >		, show (height sz)+	-- > 		]+	-- >+	RegionContent(..),+	readRegionContent,+	consoleSize,+	Width,+	consoleWidth,+	regionList, ) where  import Data.Monoid@@ -120,8 +149,8 @@ -- > bbbbbbbbbbbbbbb -- Linear -- > bbb............       (expanded to multiple lines) -- > ccccccccc...... -- Linear--- > ddd eee fffffff -- [InLine]--- > ffff ggggg.....       (expanded to multiple lines)+-- > ddddeeeefffffff -- [InLine]+-- > fffffggggg.....       (expanded to multiple lines) -- >  data RegionLayout = Linear | InLine ConsoleRegionHandle 	deriving (Eq)@@ -130,43 +159,63 @@ 	deriving (Eq)  data Region = Region-	{ regionContent :: T.Text-	, regionLines :: [T.Text] -- cache+	{ regionContent :: RegionContent+	, regionLines :: TVar [T.Text] -- ^ cache of regionContent 	, regionLayout :: RegionLayout 	, regionChildren :: Maybe [ConsoleRegionHandle] 	} -instance Eq Region where-	a == b = regionContent a == regionContent b-		&& regionLayout a == regionLayout b--type RegionList = TMVar [ConsoleRegionHandle]+data RegionContent+	= RegionContent (TVar T.Text) +	| RegionContentSTM (STM T.Text) --- | A shared global list of regions.+-- | All the regions that are currently displayed on the screen.+--+-- 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. {-# NOINLINE regionList #-}-regionList :: RegionList+regionList :: TMVar [ConsoleRegionHandle] regionList = unsafePerformIO newEmptyTMVarIO -type Width = Int+-- | On unix systems, this TVar is automatically updated when the+-- terminal is resized.+{-# NOINLINE consoleSize #-}+consoleSize :: TVar (Console.Window Int)+consoleSize = unsafePerformIO $ newTVarIO $ +	Console.Window { Console.width = 80, Console.height = 25} --- | A shared global console width.-{-# NOINLINE consoleWidth #-}-consoleWidth :: TVar Width-consoleWidth = unsafePerformIO (newTVarIO 80)+type Width = Int --- | 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+-- Get the width from the `consoleSize`+consoleWidth :: STM Width+consoleWidth = Console.width <$> readTVar consoleSize  -- | The RegionList TMVar is left empty when `displayConsoleRegions` -- is not running. regionDisplayEnabled :: IO Bool regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList +-- | Values that can be displayed in a region.+class Displayable v where+	toRegionContent :: v -> STM RegionContent++instance Displayable String where+	toRegionContent = fromOutput++instance Displayable T.Text where+	toRegionContent = fromOutput++fromOutput :: Outputable v => v -> STM RegionContent+fromOutput v = RegionContent <$> newTVar (toOutput v)++-- | Makes a STM action be run to get the content of a region.+--+-- Any change to the values that action reads will result in an immediate+-- refresh of the display.+instance Displayable (STM T.Text) where+	toRegionContent = pure . RegionContentSTM+ -- | Sets the value to display within a console region. -- -- It's fine for the value to be longer than the terminal is wide,@@ -178,14 +227,16 @@ --  -- 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 :: Displayable v => ConsoleRegionHandle -> v -> IO () setConsoleRegion h = atomically . setConsoleRegionSTM h -setConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM ()+-- | STM version of `setConsoleRegion`+setConsoleRegionSTM :: Displayable v => ConsoleRegionHandle -> v -> STM () setConsoleRegionSTM (ConsoleRegionHandle tv) v = do 	r <- readTVar tv-	width <- readTVar consoleWidth-	writeTVar tv (modifyRegion r width (const (toOutput v)))+	width <- consoleWidth+	r' <- modifyRegion r width $ const $ toRegionContent v+	writeTVar tv r' 	case regionLayout r of 		Linear -> return () 		InLine p -> refreshParent p@@ -195,26 +246,46 @@ appendConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO () appendConsoleRegion h = atomically . appendConsoleRegionSTM h +-- | STM version of `appendConsoleRegion` appendConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () appendConsoleRegionSTM (ConsoleRegionHandle tv) v = do 	r <- readTVar tv-	width <- readTVar consoleWidth-	writeTVar tv (modifyRegion r width (<> toOutput v))+	width <- consoleWidth+	r' <- modifyRegion r width $ \rc -> case rc of+		RegionContent cv -> do+			modifyTVar' cv (<> toOutput v)+			return rc+		RegionContentSTM a -> return $ RegionContentSTM $ do+			t <- a+			return (t <> toOutput v)+	writeTVar tv r' 	case regionLayout r of 		Linear -> return () 		InLine p -> refreshParent p -modifyRegion :: Region -> Width -> (T.Text -> T.Text) -> Region-modifyRegion r width f = r { regionContent = c, regionLines = calcRegionLines c width }-  where-	!c = f (regionContent r)+modifyRegion :: Region -> Width -> (RegionContent -> STM RegionContent) -> STM Region+modifyRegion r width f = do+	rc <- f (regionContent r)+	t <- readRegionContent' rc+	writeTVar (regionLines r) (calcRegionLines t width)+	return $ r { regionContent = rc } -resizeRegion :: Width -> ConsoleRegionHandle -> STM Region+-- | Reads the content of a region.+readRegionContent :: ConsoleRegionHandle -> STM T.Text+readRegionContent (ConsoleRegionHandle tv) =+	readRegionContent' . regionContent =<< readTVar tv++readRegionContent' :: RegionContent -> STM T.Text+readRegionContent' (RegionContent t) = readTVar t+readRegionContent' (RegionContentSTM a) = a++resizeRegion :: Width -> ConsoleRegionHandle -> STM (Region, [T.Text]) resizeRegion width (ConsoleRegionHandle tv) = do 	r <- readTVar tv-	let !r' = modifyRegion r width id-	writeTVar tv r'-	return r'+	t <- readRegionContent' (regionContent r)+	let ls = calcRegionLines t width+	writeTVar (regionLines r) ls+	return (r, ls)  -- | Runs the action with a new console region, closing the region when -- the action finishes or on exception.@@ -223,23 +294,16 @@  -- | Opens a new console region for output. openConsoleRegion :: RegionLayout -> IO ConsoleRegionHandle-openConsoleRegion = atomically . openConsoleRegionSTM+openConsoleRegion ly = atomically $ openConsoleRegionSTM ly T.empty  -- | STM version of `openConsoleRegion`. Allows atomically opening multiple--- regions at the same time, which guarantees they are on adjacent lines.+-- regions at the same time, which guarantees they are adjacent. -- -- > [r1, r2, r3] <- atomically $--- >	replicateM 3 (openConsoleRegionSTM Linear)-openConsoleRegionSTM :: RegionLayout -> STM ConsoleRegionHandle-openConsoleRegionSTM ly = do-	width <- readTVar consoleWidth-	let r = Region-		{ regionContent = mempty-		, regionLines = calcRegionLines mempty width-		, regionLayout = ly-		, regionChildren = Nothing-		}-	h <- ConsoleRegionHandle <$> newTVar r+-- >	replicateM 3 (openConsoleRegionSTM Linear T.empty)+openConsoleRegionSTM :: Displayable v => RegionLayout -> v -> STM ConsoleRegionHandle+openConsoleRegionSTM ly v = do+	h <- newConsoleRegionSTM ly T.empty 	case ly of 		Linear -> do 			v <- tryTakeTMVar regionList@@ -249,7 +313,23 @@ 				-- it's not put on any list, and won't display 				Nothing -> return () 		InLine parent -> addChild h parent+	setConsoleRegionSTM h v+	return h +-- | Makes a new region, but does not add it to the display.+newConsoleRegionSTM :: Displayable v => RegionLayout -> v -> STM ConsoleRegionHandle+newConsoleRegionSTM ly v = do+	width <- consoleWidth+	rc <- newTVar mempty+	ls <- newTVar $ calcRegionLines mempty width+	let r = Region+		{ regionContent = RegionContent rc+		, regionLines = ls+		, regionLayout = ly+		, regionChildren = Nothing+		}+	h <- ConsoleRegionHandle <$> newTVar r+	setConsoleRegionSTM h v 	return h  -- | Closes a console region. Once closed, the region is removed from the@@ -296,19 +376,18 @@ refreshParent :: ConsoleRegionHandle -> STM () refreshParent (ConsoleRegionHandle pv) = do 	p <- readTVar pv-	width <- readTVar consoleWidth+	width <- consoleWidth 	case regionChildren p of 		Nothing -> return () 		Just l -> do-			cs <- forM l $ \child@(ConsoleRegionHandle cv) -> do+			cs <- forM l $ \child -> do 				refreshParent child-				regionContent <$> readTVar cv+				readRegionContent child 			let !c = mconcat cs-			let p' = p-				{ regionContent = c-				, regionLines = calcRegionLines c width-				}+			rc <- newTVar c+			let p' = p { regionContent = RegionContent rc } 			writeTVar pv p'+			writeTVar (regionLines p) (calcRegionLines c width)  -- | Handles all display for the other functions in this module. --@@ -344,13 +423,8 @@  trackConsoleWidth :: IO () trackConsoleWidth = do-	let getwidth = do-		v <- Console.size-		case v of-			Nothing -> return ()-			Just (Console.Window _height width) ->-				atomically $ void $-					swapTVar consoleWidth width+	let getwidth = maybe noop (atomically . writeTVar consoleSize)+		=<< Console.size 	getwidth 	installResizeHandler (Just getwidth) @@ -360,19 +434,19 @@ 	| TerminalResize Width 	| EndSignal () -type RegionSnapshot = ([ConsoleRegionHandle], [Region])+type RegionSnapshot = ([ConsoleRegionHandle], [Region], [[T.Text]])  displayThread :: Bool -> TSem -> IO () displayThread isterm endsignal = do-	origwidth <- atomically $ readTVar consoleWidth-	go ([], []) origwidth+	origwidth <- atomically consoleWidth+	go ([], [], []) origwidth   where-	go origsnapshot@(orighandles, origregions) origwidth = do+	go origsnapshot@(orighandles, _origregions, origlines) origwidth = do 		let waitwidthchange = do-			w <- readTVar consoleWidth+			w <- consoleWidth 			if w == origwidth then retry else return w 		change <- atomically $-			(RegionChange <$> regionWaiter origsnapshot)+			(RegionChange <$> regionWaiter origsnapshot origwidth) 				`orElse` 			(RegionChange <$> regionListWaiter origsnapshot) 				`orElse`@@ -382,19 +456,18 @@ 				`orElse` 			(EndSignal <$> waitTSem endsignal) 		case change of-			RegionChange snapshot@(_, newregions) -> do-				when isterm $-					changedLines-						(getlines origregions)-						(getlines newregions)+			RegionChange snapshot@(_, _, newlines) -> do+				when isterm $ do+					changedLines (concat origlines) (concat newlines) 				go snapshot origwidth 			BufferChange buffers -> do-				inAreaAbove isterm (length $ getlines origregions) (getlines origregions) $+				inAreaAbove isterm (length $ concat origlines) (concat origlines) $ 					mapM_ (uncurry emitOutputBuffer) buffers 				go origsnapshot origwidth 			TerminalResize newwidth -> do-				newregions <- atomically $-					mapM (resizeRegion newwidth) orighandles+				(newregions, lls) <- unzip <$> +					atomically (mapM (resizeRegion newwidth) orighandles)+				let newlines = map reverse lls 				when isterm $ do 					-- A resize can leave the cursor 					-- in a fairly undefined location,@@ -403,32 +476,41 @@ 					-- cursor to top of screen, clear 					-- entire screen, and redisplay. 					setCursorPosition 0 0-					inAreaAbove isterm 0 (getlines newregions) $+					inAreaAbove isterm 0 (concat newlines) $ 						return ()-				go (orighandles, newregions) newwidth+				go (orighandles, newregions, newlines) 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) = do+regionListWaiter (orighandles, _origregions, origlines) = do 	handles <- readTMVar regionList 	if handles == orighandles 		then retry 		else do 			rs <- readRegions handles-			return (handles, rs)-		+			return (handles, rs, origlines)+ -- Wait for any changes to any of the regions currently in the region list.-regionWaiter :: RegionSnapshot -> STM RegionSnapshot-regionWaiter (orighandles, origregions) = do+regionWaiter :: RegionSnapshot -> Width -> STM RegionSnapshot+regionWaiter (orighandles, _origregions, origlines) width = do 	rs <- readRegions orighandles-	if rs == origregions-		then retry-		else return (orighandles, rs)+	newlines <- mapM getr (zip rs (origlines ++ repeat [T.empty]))+	unless (newlines /= origlines)+		retry+	return (orighandles, rs, newlines)+  where+	getr (r, ols) = case regionContent r of+		RegionContent _ -> reverse <$> readTVar (regionLines r)+		RegionContentSTM a -> do+			c <- a+			let ls = reverse $ calcRegionLines c width+			when (ls /= ols) $+				writeTVar (regionLines r) ls+			return ls  -- This is not an optimal screen update like curses can do, but it's -- pretty efficient, most of the time!

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

@@ -1,5 +1,5 @@ Name: concurrent-output-Version: 1.2.0+Version: 1.3.0 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess <id@joeyh.name>@@ -28,6 +28,7 @@   demo2.hs   demo3.hs   aptdemo.hs+  stmdemo.hs  Library   GHC-Options: -Wall -fno-warn-tabs -O2

@@ -1,8 +1,11 @@ import Control.Concurrent.Async import Control.Concurrent+import Control.Concurrent.STM import System.Console.Concurrent import System.Console.Regions import System.Process+import qualified Data.Text as T+import Data.List  main = displayConsoleRegions $ do 	mapConcurrently download [1..5]@@ -25,8 +28,8 @@ 		| c < 1 = finishConsoleRegion r 			(basemsg ++ " done!\n  Took xxx seconds.") 		| otherwise = do-			threadDelay 1000000 			appendConsoleRegion r " ... "+			threadDelay 1000000 			go (c-1) r  ls :: IO ()@@ -37,5 +40,3 @@ 	_ <- waitForProcessConcurrent p 	outputConcurrent "<<< ls is done!\n" 	return ()-	-	

@@ -2,11 +2,17 @@ import Control.Concurrent import System.Console.Concurrent import System.Console.Regions+import System.Console.Terminal.Size+import qualified Data.Text as T+import Control.Concurrent.STM+import Control.Applicative+import Data.Time.Clock+import Control.Monad  main = displayConsoleRegions $ mapConcurrently id 	[ spinner 100 1 "Pinwheels!!" setConsoleRegion "/-\\|" (withtitle 1) 	, spinner 100 1 "Bubbles!!!!" setConsoleRegion ".oOo." (withtitle 1)-	, spinner 100 1 "Dots......!" appendConsoleRegion "."  (const (take 1))+	, spinner 100 1 "Dots......!" appendConsoleRegion "."  (const (take 3)) 	, spinner  30 2 "KleisiFish?" setConsoleRegion "  <=<   <=<  " (withtitle 10) 	, spinner  10 9 "Countdowns!" setConsoleRegion 		(reverse [1..10])

@@ -0,0 +1,49 @@+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+import Data.Time.Clock+import Control.Monad+import Data.Monoid++main :: IO ()+main = void $ displayConsoleRegions $ mapConcurrently id+	[ infoRegion+	, clockRegion+	]++infoRegion :: IO ()+infoRegion = do+	r <- openConsoleRegion Linear+	setConsoleRegion r $ do+	 	sz <- readTVar consoleSize+		regions <- readTMVar regionList+ 		return $ T.pack $ unwords+ 			[ "size:"+			, show (width sz)+ 			, "x"+			, show (height sz)+			, "regions: "+			, show (length regions)+ 			]++timeDisplay :: TVar UTCTime -> STM T.Text+timeDisplay tv = T.pack . show <$> readTVar tv++clockRegion :: IO ()+clockRegion = do+	tv <- atomically . newTVar =<< getCurrentTime+	void $ atomically $ openConsoleRegionSTM Linear . rightAlign+		=<< newConsoleRegionSTM Linear (timeDisplay tv)+	forever $ do+		threadDelay 1000000 -- 1 sec+		atomically . (writeTVar tv) =<< getCurrentTime++rightAlign :: ConsoleRegionHandle -> STM T.Text+rightAlign r = do+        t <- readRegionContent r+        w <- consoleWidth+        return (T.replicate (w - T.length t) (T.singleton ' ') <> t)