diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -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 diff --git a/concurrentoutput.cabal b/concurrentoutput.cabal --- a/concurrentoutput.cabal +++ b/concurrentoutput.cabal @@ -1,5 +1,5 @@ Name: concurrentoutput -version: 0.1 +version: 0.2 Category: User Interfaces author: Joachim Breitner maintainer: Joachim Breitner @@ -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 diff --git a/src/System/Terminal/Concurrent.hs b/src/System/Terminal/Concurrent.hs --- a/src/System/Terminal/Concurrent.hs +++ b/src/System/Terminal/Concurrent.hs @@ -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 +-- 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)