module System.Terminal.Concurrent
( getConcurrentOutputter
) where
import Control.Concurrent
import Control.Monad
import Data.IORef
import Data.List
import System.IO
type OutputState = [(ThreadId,String)]
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 all_lines = lines $ maybe s (++s) (lookup t os)
let done = last s == '\n'
let (done_lines, current_line) =
if done || null all_lines
then (all_lines, Nothing)
else (init all_lines, Just (last all_lines))
when isTerm $ do
unless (null os) $ do
putStr $ "\ESC[" ++ show (length os) ++ "A"
unless (null os) $ putStr "\ESC[0J"
putStr $ "\ESC[1A"
mapM_ putLnStr done_lines
unless isTerm $ do
mapM_ putStrLn done_lines
let os'= replaceAppendOrDelete t current_line os
when isTerm $ do
mapM_ (putLnStr) $ map snd os'
putStrLn ""
writeIORef osRef os'
signalQSem lock
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)