concurrent-output 1.7.1 → 1.7.2

raw patch · 4 files changed

+30/−17 lines, 4 files

Files

• CHANGELOG +9/−0
• System/Console/Concurrent/Internal.hs +17/−12
• System/Console/Regions.hs +3/−4
• concurrent-output.cabal +1/−1

@@ -1,3 +1,12 @@+concurrent-output (1.7.2) unstable; urgency=medium++  * Running a process within displayConsoleRegions caused a small+    resource leak, due to a thread that stalled until the+    displayConsoleRegions action finished. This is fixed.+  * Clean build with ghc 7.10.++ -- Joey Hess <id@joeyh.name>  Sat, 19 Dec 2015 16:47:08 -0400+ concurrent-output (1.7.1) unstable; urgency=medium    * Simplify code.

@@ -19,7 +19,6 @@ import System.Exit import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Applicative import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import Control.Concurrent.STM@@ -30,6 +29,8 @@ import qualified System.Process as P import qualified Data.Text as T import qualified Data.Text.IO as T+import Control.Applicative+import Prelude  import Utility.Monad import Utility.Exception@@ -113,21 +114,20 @@ withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput  -- | Blocks until any processes started by `createProcessConcurrent` have--- finished, and any buffered output is displayed. +-- finished, and any buffered output is displayed. Also blocks while+-- `lockOutput` is is use. ----- `withConcurrentOutput` calls this at the end; you can call it anytime--- you want to flush output.+-- `withConcurrentOutput` calls this at the end, so you do not normally+-- need to use this. flushConcurrentOutput :: IO () flushConcurrentOutput = do-	-- Wait for all outputThreads to finish.-	let v = outputThreads globalOutputHandle 	atomically $ do-		r <- takeTMVar v+		r <- takeTMVar (outputThreads globalOutputHandle) 		if r <= 0-			then putTMVar v r+			then putTMVar (outputThreads globalOutputHandle) r 			else retry-	-- Take output lock to ensure that nothing else is currently-	-- generating output, and flush any buffered output.+	-- Take output lock to wait for anything else that might be+	-- currently generating output. 	lockOutput $ return ()  -- | Values that can be output.@@ -285,9 +285,11 @@ fgProcess p = do 	r@(_, _, _, h) <- P.createProcess p 		`onException` dropOutputLock+	registerOutputThread 	-- Wait for the process to exit and drop the lock. 	asyncProcessWaiter $ do 		void $ tryIO $ P.waitForProcess h+		unregisterOutputThread 		dropOutputLock 	return (toConcurrentProcessHandle r) @@ -401,7 +403,7 @@ 			( void $ mapConcurrently displaybuf ts 			, noop -- buffers already moved to global 			)-	worker2 <- async $ void $ globalbuf activitysig+	worker2 <- async $ void $ globalbuf activitysig worker1 	void $ async $ do 		void $ waitCatch worker1 		void $ waitCatch worker2@@ -418,7 +420,7 @@ 		case change of 			Right BufSig -> displaybuf v 			Left AtEnd -> return ()-	globalbuf activitysig = do+	globalbuf activitysig worker1 = do 		ok <- atomically $ do 			-- signal we're going to handle it 			-- (returns false if the displaybuf already did)@@ -435,6 +437,9 @@ 			atomically $ 				forM_ bs $ \(outh, b) ->  					bufferOutputSTM' outh b+			-- worker1 might be blocked waiting for the output+			-- lock, and we've already done its job, so cancel it+			cancel worker1  -- Adds a value to the OutputBuffer. When adding Output to a Handle, -- it's cheaper to combine it with any already buffered Output to that

@@ -114,7 +114,6 @@ import qualified Data.Text.IO as T import Data.Text (Text) import Control.Monad-import Control.Applicative import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Concurrent.STM import Control.Concurrent.STM.TSem@@ -129,6 +128,8 @@ import System.Posix.Signals import System.Posix.Signals.Exts #endif+import Control.Applicative+import Prelude  import System.Console.Concurrent import Utility.Monad@@ -269,8 +270,6 @@ modifyRegion (ConsoleRegion tv) f = do 	r <- readTVar tv 	rc <- f (regionContent r)-	t <- readRegionContent rc-	width <- consoleWidth 	let r' = r { regionContent = rc } 	writeTVar tv r' @@ -372,7 +371,7 @@ -- Normally, the STM action should avoid retrying, as that would -- block all display updates. tuneDisplay :: LiftRegion m => ConsoleRegion -> (Text -> STM Text) -> m ()-tuneDisplay cr@(ConsoleRegion tv) renderer = liftRegion $ do+tuneDisplay (ConsoleRegion tv) renderer = liftRegion $ do 	r <- readTVar tv 	let rr = \t -> renderer =<< regionRender r t 	let r' = r { regionRender = rr }

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