concurrentoutput (empty) → 0.1

raw patch · 5 files changed

+201/−0 lines, 5 filesdep +basesetup-changed

Dependencies added: base

Files

LICENSE +26/−0
Setup.hs +3/−0
Test.hs +17/−0
concurrentoutput.cabal +58/−0
src/System/Terminal/Concurrent.hs +97/−0

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright © 2009 Joachim Breitner+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the University nor the names of its contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple+main = defaultMain

+ Test.hs view

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

+ concurrentoutput.cabal view

@@ -0,0 +1,58 @@+Name:            concurrentoutput+version:         0.1+Category:        User Interfaces+author:          Joachim Breitner+maintainer:      Joachim Breitner <mail@joachim-breitner.de>+Synopsis:        Ungarble output from several threads +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")+		 to the correct line and continue scrolling when a line is done.+		 .+		 For example, this screen:+		 .+		 @Thread ThreadId 27: still working... done@+		 .+                 @Thread ThreadId 25: still working... @+		 .+                 @Thread ThreadId 26: still working... @+	         .+		 @_@+		 .+		 will, once thread 25 has finished, look like this+		 .	+                 @Thread ThreadId 25: still working... done@+		 .+		 @Thread ThreadId 27: still working... done@+		 .+                 @Thread ThreadId 26: still working... @+	         .+		 @_@+		 .+		 If standard output is not a terminal, it will only print+		 complete lines.+		 .+		 At the moment, it can only handle lines that are shorter than+		 the terminal. If they are not, output will be garbled again.+		 .+		 +Cabal-Version:   >= 1.6+License:         BSD3+License-File:    LICENSE+extra-source-files: Test.hs+Build-Type:      Simple++Library+        hs-source-dirs: src+        Exposed-Modules: System.Terminal.Concurrent+        Build-Depends:  base > 3 && < 4++source-repository head+  type:     darcs+  location: http://darcs.nomeata.de/concurrentoutput/++source-repository this+  type:     darcs+  location: http://darcs.nomeata.de/darcswatch/+  tag:      v0.1

+ src/System/Terminal/Concurrent.hs view

@@ -0,0 +1,97 @@+-- | 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+	) where++import Control.Concurrent+import Control.Monad+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++	        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"++		-- Write a new done line, if suitable+		when d $ putLnStr s' ++		-- Write the new not-yet-done lines+		mapM_ (putLnStr) $ map snd os'++		-- Go to the beginning of the next new line+		putStrLn ""++		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++	        let s' = maybe s (++s) (lookup t os)+		let os'= if d then filter ((/=t).fst) os+		              else replaceOrAppend t s' os++		-- Write a new done line, if suitable+		when d $ putStrLn s' ++		runner os'++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++putLnStr s = putStr ('\n':s)