concurrentoutput 0.1 → 0.2

raw patch · 3 files changed

+75/−85 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Test.hs +7/−6
• concurrentoutput.cabal +5/−5
• src/System/Terminal/Concurrent.hs +63/−74

@@ -1,17 +1,18 @@ import System.Terminal.Concurrent import Control.Concurrent -testThread co n1 n2 = do+testThread writeC n1 n2 = do 	t <- myThreadId 	threadDelay $ n1 * 100000-	writeConcurrent co ("Thread " ++ show t ++ ": ")+	writeC("Thread " ++ show t ++ ": ") 	threadDelay $ n1 * 100000-	writeConcurrent co "still working... "+	writeC "still working... "+	writeC "" 	threadDelay $ n2 * 100000-	writeConcurrentDone co "done"+	writeC "done\n"  main = do-	co <- startConcurrentOutput-	mapM forkIO  $ zipWith (testThread co) [0,0,3,4,3] [4,8,5,5,2]+	writeC <- getConcurrentOutputter+	mapM forkIO  $ zipWith (testThread writeC) [0,0,3,5,2,3] [4,8,5,4,1,2] 	threadDelay $ 15*100000 	

@@ -1,5 +1,5 @@ Name:            concurrentoutput-version:         0.1+version:         0.2 Category:        User Interfaces author:          Joachim Breitner maintainer:      Joachim Breitner <mail@joachim-breitner.de>@@ -7,7 +7,7 @@ Description:     This library provides a simple interface to output status                  messages from more than one thread. 		 .-		 It will continue adding information (such as dots, or "done")+		 It will continue adding information (such as dots, or \"done\") 		 to the correct line and continue scrolling when a line is done. 		 . 		 For example, this screen:@@ -31,7 +31,7 @@ 		 @_@ 		 . 		 If standard output is not a terminal, it will only print-		 complete lines.+		 complete lines and not output any control characters. 		 . 		 At the moment, it can only handle lines that are shorter than 		 the terminal. If they are not, output will be garbled again.@@ -54,5 +54,5 @@  source-repository this   type:     darcs-  location: http://darcs.nomeata.de/darcswatch/-  tag:      v0.1+  location: http://darcs.nomeata.de/concurrentoutput/+  tag:      v0.2

@@ -1,97 +1,86 @@--- | This library provides a simple interface to output status---   messages from more than one thread.+-----------------------------------------------------------------------------+-- |+-- Module      :  System.Terminal.Concurrent+-- Copyright   :  © 2009 Joachim Breitner +-- License     :  BSD-style (see the file LICENSE)+-- +-- Maintainer  :  Joachim Breitner <mail@joachin-breitner.de>+-- Stability   :  experimental+-- Portability :  non-portable (concurrency) -----   It will continue adding information (such as dots, or "done")---   to the correct line corresponding to the issuing thread and continue---   scrolling when a line is done.+-- This library provides a simple interface to output status+-- messages from more than one thread.+--+-- It will continue adding information (such as dots, or "done")+-- to the correct line corresponding to the issuing thread and continue+-- scrolling when a line is done.+--+----------------------------------------------------------------------------- module System.Terminal.Concurrent -	( ConcurrentOutput-	, startConcurrentOutput-	, writeConcurrent-	, writeConcurrentDone+	( getConcurrentOutputter 	) where  import Control.Concurrent import Control.Monad+import Data.IORef import Data.List import System.IO -data ConcurrentOutput = ConcurrentOutput { coChan :: Chan (ThreadId, Bool, String) }---- | Starts the thread responsible for gathering and formatting the outputs.---    ---   You can not kill this thread, so only start one for your application.-startConcurrentOutput :: IO ConcurrentOutput-startConcurrentOutput = do-	chan <- newChan-	isTerm <- hIsTerminalDevice stdout-	forkIO (receiverThread chan isTerm)-	return (ConcurrentOutput chan)---- | Begin a new line of output for your thread or, if there already is one, append to it.---    ---   Do not put newline characters in there, or it will break the output. This---   will also happen if your total line will be wider than the terminal.-writeConcurrent :: ConcurrentOutput -> String -> IO ()-writeConcurrent (ConcurrentOutput chan) s = do-	threadId <- myThreadId-	writeChan chan (threadId, False, s)---- | Finish your line of output with the given string.---    ---   Do not put newline characters in there, or it will break the output. This---   will also happen if your total line will be wider than the terminal.-writeConcurrentDone :: ConcurrentOutput -> String -> IO ()-writeConcurrentDone (ConcurrentOutput chan) s = do-	threadId <- myThreadId-	writeChan chan (threadId, True, s)- -- What threadid has written to what line, counting from below type OutputState = [(ThreadId,String)] -receiverThread :: Chan (ThreadId, Bool, String) -> Bool -> IO ()-receiverThread chan True = runner []-	where runner os = do-		(t,d,s) <- readChan chan+-- | Returns an IO action to be called to output strings in a thread-safe manner.+getConcurrentOutputter :: IO (String -> IO ())+getConcurrentOutputter = do+	chan <- newChan+	isTerm <- hIsTerminalDevice stdout+	osRef <- newIORef []	+	lock <- newQSem 1+	return $ \s -> unless (null s) $ do+		waitQSem lock+		t <- myThreadId+		os <- readIORef osRef -	        let s' = maybe s (++s) (lookup t os)-		let os'= if d then filter ((/=t).fst) os-		              else replaceOrAppend t s' os-		unless (null os) $ do-			-- Go up some lines-			putStr $ "\ESC[" ++ show (length os) ++ "A"-			-- Clear everything-			unless (null os) $ putStr "\ESC[0J"-		-- Go up once more, to make it fit-		putStr $ "\ESC[1A"+	        let all_lines = lines $ maybe s (++s) (lookup t os)+		let done = last s == '\n' -		-- Write a new done line, if suitable-		when d $ putLnStr s' +		let (done_lines, current_line) =+			if done || null all_lines+                        then (all_lines,     Nothing)+			else (init all_lines, Just (last all_lines))  -		-- Write the new not-yet-done lines-		mapM_ (putLnStr) $ map snd os'+		when isTerm $ do+			unless (null os) $ do+				-- Go up some lines+				putStr $ "\ESC[" ++ show (length os) ++ "A"+				-- Clear everything+				unless (null os) $ putStr "\ESC[0J"+			-- Go up once more, to make it fit+			putStr $ "\ESC[1A" -		-- Go to the beginning of the next new line-		putStrLn ""+			-- Write a new done line, if suitable+			mapM_ putLnStr done_lines+		unless isTerm $ do+			mapM_ putStrLn done_lines -		runner os'--- We do not have a terminal, just output complete lines-receiverThread chan False = runner []-	where runner os = do-		(t,d,s) <- readChan chan+		-- Update line+		let os'= replaceAppendOrDelete t current_line os -	        let s' = maybe s (++s) (lookup t os)-		let os'= if d then filter ((/=t).fst) os-		              else replaceOrAppend t s' os+		when isTerm $ do+			-- Write the new not-yet-done lines+			mapM_ (putLnStr) $ map snd os' -		-- Write a new done line, if suitable-		when d $ putStrLn s' +			-- Go to the beginning of the next new line+			putStrLn "" -		runner os'+		writeIORef osRef os'+		signalQSem lock -replaceOrAppend :: (Eq a) => a -> b -> [(a,b)] -> [(a,b)]-replaceOrAppend a b []                       = [(a,b)]-replaceOrAppend a b ((a',b'):xs) | a == a'   = (a,b):xs-                                 | otherwise = (a',b') : replaceOrAppend a b xs+replaceAppendOrDelete :: (Eq a) => a -> Maybe b -> [(a,b)] -> [(a,b)]+replaceAppendOrDelete a Nothing  []                     = []+replaceAppendOrDelete a (Just b) []                     = [(a,b)]+replaceAppendOrDelete a Nothing  ((a',_):xs)  | a == a' = xs+replaceAppendOrDelete a (Just b) ((a',b'):xs) | a == a' = (a,b):xs+replaceAppendOrDelete a mbB      (x:xs)                 = x : replaceAppendOrDelete a mbB xs  putLnStr s = putStr ('\n':s)