concurrent-output 1.4.0 → 1.5.0

raw patch · 6 files changed

+71/−29 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG +7/−0
• System/Console/Concurrent.hs +1/−0
• System/Console/Concurrent/Internal.hs +14/−4
• System/Console/Regions.hs +21/−11
• concurrent-output.cabal +1/−1
• stmdemo.hs +27/−13

@@ -1,3 +1,10 @@+concurrent-output (1.5.0) unstable; urgency=medium++  * Added errorConcurrent.+  * Added getRegionContent.++ -- Joey Hess <id@joeyh.name>  Wed, 04 Nov 2015 17:20:44 -0400+ concurrent-output (1.4.0) unstable; urgency=medium    * Renamed many of the functions and types.

@@ -19,6 +19,7 @@ 	withConcurrentOutput, 	Outputable(..), 	outputConcurrent,+	errorConcurrent, 	ConcurrentProcessHandle, 	createProcessConcurrent, 	waitForProcessConcurrent,

@@ -149,19 +149,29 @@ -- 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+outputConcurrent = outputConcurrent' StdOut++-- | Like `outputConcurrent`, but displays to stderr.+--+-- (Does not throw an exception.)+errorConcurrent :: Outputable v => v -> IO ()+errorConcurrent = outputConcurrent' StdErr++outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()+outputConcurrent' stdh v = bracket setup cleanup go   where 	setup = tryTakeOutputLock 	cleanup False = return () 	cleanup True = dropOutputLock 	go True = do-		T.hPutStr stdout (toOutput v)-		hFlush stdout+		T.hPutStr h (toOutput v)+		hFlush h 	go False = do-		let bv = outputBuffer globalOutputHandle 		oldbuf <- atomically $ takeTMVar bv 		newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf 		atomically $ putTMVar bv newbuf+	h = toHandle stdh+	bv = bufferFor stdh  newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle 

@@ -77,6 +77,7 @@ 	setConsoleRegion, 	appendConsoleRegion, 	finishConsoleRegion,+	getConsoleRegion, 	tuneDisplay, 	-- * STM region contents 	--@@ -334,13 +335,19 @@ 		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.+-- | Closes the console region, and displays the passed value in the+-- scrolling area above the active console regions. When Nothing is passed,+-- displays the current value of the console region. finishConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m () finishConsoleRegion h v = liftRegion $ do 	closeConsoleRegion h 	bufferOutputSTM StdOut (toOutput v <> fromString "\n") +-- | Gets the current content of a console region.+getConsoleRegion :: LiftRegion m => ConsoleRegion -> m Text+getConsoleRegion (ConsoleRegion tv) = liftRegion $+	readRegionContent . regionContent =<< readTVar tv+ -- | Changes how a console region displays. -- -- Each time the region's value changes, the STM action is provided@@ -472,15 +479,7 @@ 					atomically (mapM (resizeRegion newwidth) orighandles) 				let newlines = map reverse lls 				when isterm $ do-					-- A resize can leave the cursor-					-- in a fairly undefined location,-					-- if it occurred while a screen-					-- draw was in progress. Move the-					-- cursor to top of screen, clear-					-- entire screen, and redisplay.-					setCursorPosition 0 0-					inAreaAbove isterm 0 (concat newlines) $-						return ()+					resizeRecovery newlines 				go (orighandles, newregions, newlines) newwidth 			EndSignal () -> return () @@ -571,6 +570,17 @@ 		hFlush stdout   where 	l' = changeOffsets l 1 []++-- Recover from a resize by redrawing all region lines.+--+-- 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 newlines = do+	setCursorPosition 0 0+	inAreaAbove True 0 (concat newlines) $+		return ()  -- Move cursor up before the lines, performs some output there, -- which will scroll down and overwrite the lines, so 

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

@@ -10,13 +10,14 @@ import Data.Monoid  main :: IO ()-main = void $ displayConsoleRegions $ mapConcurrently id-	[ infoRegion-	, clockRegion-	, growingDots-	]+main = void $ displayConsoleRegions $ do+	ir <- infoRegion+	cr <- clockRegion+	rr <- rulerRegion+	growingDots+	mapM_ closeConsoleRegion [ir, cr] -infoRegion :: IO ()+infoRegion :: IO ConsoleRegion infoRegion = do 	r <- openConsoleRegion Linear 	setConsoleRegion r $ do@@ -30,20 +31,22 @@ 			, "regions: " 			, show (length regions)  			]+	return r  timeDisplay :: TVar UTCTime -> STM T.Text timeDisplay tv = T.pack . show <$> readTVar tv -clockRegion :: IO ()+clockRegion :: IO ConsoleRegion clockRegion = do 	tv <- atomically . newTVar =<< getCurrentTime-	void $ atomically $ do+	async $ forever $ do+		threadDelay 1000000 -- 1 sec+		atomically . (writeTVar tv) =<< getCurrentTime+	atomically $ do 		r <- openConsoleRegion Linear 		setConsoleRegion r (timeDisplay tv) 		rightAlign r-	forever $ do-		threadDelay 1000000 -- 1 sec-		atomically . (writeTVar tv) =<< getCurrentTime+		return r  rightAlign :: ConsoleRegion -> STM () rightAlign r = tuneDisplay r $ \t -> do@@ -52,6 +55,17 @@  growingDots = withConsoleRegion Linear $ \r -> do 	atomically $ rightAlign r-	forever $ do-		appendConsoleRegion r "."+	width <- atomically consoleWidth+	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]