diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,13 @@ +concurrent-output (1.1.0) unstable; urgency=medium + + * Renamed module. + * Incorporated console region support, based on Joachim Breitner's + concurrentoutput library. + * Fix race that sometimes prevented a concurrent processes's output from + being displayed as program shut down. + + -- Joey Hess Fri, 30 Oct 2015 21:27:41 -0400 + concurrent-output (1.0.1) unstable; urgency=medium * Generalize what can be output. diff --git a/Control/Concurrent/Output.hs b/Control/Concurrent/Output.hs deleted file mode 100644 --- a/Control/Concurrent/Output.hs +++ /dev/null @@ -1,348 +0,0 @@ -{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-tabs #-} - --- | --- Copyright: 2013 Joey Hess --- License: BSD-2-clause --- --- Concurrent output handling. --- --- > import Control.Concurrent.Async --- > import Control.Concurrent.Output --- > --- > main = withConcurrentOutput $ --- > outputConcurrent "washed the car\n" --- > `concurrently` --- > outputConcurrent "walked the dog\n" --- > `concurrently` --- > createProcessConcurrent (proc "ls" []) - -module Control.Concurrent.Output ( - withConcurrentOutput, - flushConcurrentOutput, - Outputable(..), - outputConcurrent, - createProcessConcurrent, - waitForProcessConcurrent, - lockOutput, -) where - -import System.IO -import System.Posix.IO -import System.Directory -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 -import Control.Concurrent.Async -import Data.Maybe -import Data.List -import Data.Monoid -import qualified System.Process as P -import qualified Data.Set as S -import qualified Data.ByteString as B -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) - -import Utility.Monad -import Utility.Exception - -data OutputHandle = OutputHandle - { outputLock :: TMVar Lock - , outputBuffer :: TMVar Buffer - , outputThreads :: TMVar (S.Set (Async ())) - } - -data Lock = Locked - --- | A shared global variable for the OutputHandle. -{-# NOINLINE globalOutputHandle #-} -globalOutputHandle :: MVar OutputHandle -globalOutputHandle = unsafePerformIO $ - newMVar =<< OutputHandle - <$> newEmptyTMVarIO - <*> newTMVarIO [] - <*> newTMVarIO S.empty - --- | Gets the global OutputHandle. -getOutputHandle :: IO OutputHandle -getOutputHandle = readMVar globalOutputHandle - --- | Holds a lock while performing an action that will display output. --- While this is running, other threads that try to lockOutput will block, --- and calls to `outputConcurrent` and `createProcessConcurrent` --- will result in that concurrent output being buffered and not --- displayed until the action is done. -lockOutput :: (MonadIO m, MonadMask m) => m a -> m a -lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) - --- | Blocks until we have the output lock. -takeOutputLock :: IO () -takeOutputLock = void $ takeOutputLock' True - --- | Tries to take the output lock, without blocking. -tryTakeOutputLock :: IO Bool -tryTakeOutputLock = takeOutputLock' False - -withLock :: (TMVar Lock -> STM a) -> IO a -withLock a = do - lck <- outputLock <$> getOutputHandle - atomically (a lck) - -takeOutputLock' :: Bool -> IO Bool -takeOutputLock' block = do - locked <- withLock $ \l -> do - v <- tryTakeTMVar l - case v of - Just Locked - | block -> retry - | otherwise -> do - -- Restore value we took. - putTMVar l Locked - return False - Nothing -> do - putTMVar l Locked - return True - when locked $ do - bv <- outputBuffer <$> getOutputHandle - buf <- atomically $ swapTMVar bv [] - emitBuffer stdout buf - return locked - --- | Only safe to call after taking the output lock. -dropOutputLock :: IO () -dropOutputLock = withLock $ void . takeTMVar - --- | Use this around any IO actions that use `outputConcurrent` --- or `createProcessConcurrent` --- --- This is necessary to ensure that buffered concurrent output actually --- gets displayed before the program exits. -withConcurrentOutput :: IO a -> IO a -withConcurrentOutput a = a `finally` flushConcurrentOutput - --- | Blocks until any processes started by `createProcessConcurrent` have --- finished, and any buffered output is displayed. -flushConcurrentOutput :: IO () -flushConcurrentOutput = do - -- Wait for all outputThreads to finish. - v <- outputThreads <$> getOutputHandle - atomically $ do - r <- takeTMVar v - if r == S.empty - then putTMVar v r - else retry - -- Take output lock to ensure that nothing else is currently - -- generating output, and flush any buffered output. - lockOutput $ return () - --- | Values that can be output. -class Outputable v where - toOutput :: v -> B.ByteString - -instance Outputable B.ByteString where - toOutput = id - -instance Outputable T.Text where - toOutput = encodeUtf8 - -instance Outputable String where - toOutput = toOutput . T.pack - --- | Displays a value to stdout, and flush output so it's displayed. --- --- Uses locking to ensure that the whole output occurs atomically --- even when other threads are concurrently generating output. --- --- When something else is writing to the console at the same time, this does --- not block. It buffers the value, so it will be displayed once the other --- writer is done. -outputConcurrent :: Outputable v => v -> IO () -outputConcurrent v = bracket setup cleanup go - where - setup = tryTakeOutputLock - cleanup False = return () - cleanup True = dropOutputLock - go True = do - B.hPut stdout (toOutput v) - hFlush stdout - go False = do - bv <- outputBuffer <$> getOutputHandle - oldbuf <- atomically $ takeTMVar bv - newbuf <- addBuffer (Output (toOutput v)) oldbuf - atomically $ putTMVar bv newbuf - --- | This must be used to wait for processes started with --- `createProcessConcurrent`. --- --- This is necessary because `System.Process.waitForProcess` has a --- race condition when two threads check the same process. If the race --- is triggered, one thread will successfully wait, but the other --- throws a DoesNotExist exception. -waitForProcessConcurrent :: P.ProcessHandle -> IO ExitCode -waitForProcessConcurrent h = do - v <- tryWhenExists (P.waitForProcess h) - case v of - Just r -> return r - Nothing -> maybe (waitForProcessConcurrent h) return =<< P.getProcessExitCode h - --- | Wrapper around `System.Process.createProcess` that prevents --- multiple processes that are running concurrently from writing --- to stdout/stderr at the same time. --- --- If the process does not output to stdout or stderr, it's run --- by createProcess entirely as usual. Only processes that can generate --- output are handled specially: --- --- A process is allowed to write to stdout and stderr in the usual --- way, assuming it can successfully take the output lock. --- --- When the output lock is held (by another concurrent process, --- or because `outputConcurrent` is being called at the same time), --- the process is instead run with its stdout and stderr --- redirected to a buffer. The buffered output will be displayed as soon --- as the output lock becomes free. -createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -createProcessConcurrent p - | willOutput (P.std_out p) || willOutput (P.std_err p) = - ifM tryTakeOutputLock - ( firstprocess - , concurrentprocess - ) - | otherwise = P.createProcess p - where - rediroutput ss h - | willOutput ss = P.UseHandle h - | otherwise = ss - - firstprocess = do - r@(_, _, _, h) <- P.createProcess p - `onException` dropOutputLock - -- Wait for the process to exit and drop the lock. - void $ async $ do - void $ tryIO $ waitForProcessConcurrent h - dropOutputLock - return r - - concurrentprocess = do - (toouth, fromouth) <- pipe - (toerrh, fromerrh) <- pipe - let p' = p - { P.std_out = rediroutput (P.std_out p) toouth - , P.std_err = rediroutput (P.std_err p) toerrh - } - r <- P.createProcess p' - outbuf <- setupBuffer stdout toouth (P.std_out p) fromouth - errbuf <- setupBuffer stderr toerrh (P.std_err p) fromerrh - void $ async $ bufferWriter [outbuf, errbuf] - return r - - pipe = do - (from, to) <- createPipe - (,) <$> fdToHandle to <*> fdToHandle from - -willOutput :: P.StdStream -> Bool -willOutput P.Inherit = True -willOutput _ = False - --- Built up with newest seen output first. -type Buffer = [BufferedActivity] - -data BufferedActivity - = ReachedEnd - | Output B.ByteString - | InTempFile FilePath - deriving (Eq) - -setupBuffer :: Handle -> Handle -> P.StdStream -> Handle -> IO (Handle, MVar Buffer, TMVar ()) -setupBuffer h toh ss fromh = do - hClose toh - buf <- newMVar [] - bufsig <- atomically newEmptyTMVar - void $ async $ outputDrainer ss fromh buf bufsig - return (h, buf, bufsig) - --- Drain output from the handle, and buffer it. -outputDrainer :: P.StdStream -> Handle -> MVar Buffer -> TMVar () -> IO () -outputDrainer ss fromh buf bufsig - | willOutput ss = go - | otherwise = atend - where - go = do - v <- tryIO $ B.hGetSome fromh 1048576 - case v of - Right b | not (B.null b) -> do - modifyMVar_ buf $ addBuffer (Output b) - changed - go - _ -> atend - atend = do - modifyMVar_ buf $ pure . (ReachedEnd :) - changed - hClose fromh - changed = atomically $ do - void $ tryTakeTMVar bufsig - putTMVar bufsig () - --- Wait to lock output, and once we can, display everything --- that's put into the buffers, until the end. -bufferWriter :: [(Handle, MVar Buffer, TMVar ())] -> IO () -bufferWriter ts = do - worker <- async $ void $ lockOutput $ mapConcurrently go ts - v <- outputThreads <$> getOutputHandle - atomically $ do - s <- takeTMVar v - putTMVar v (S.insert worker s) - void $ async $ do - void $ waitCatch worker - atomically $ do - s <- takeTMVar v - putTMVar v (S.delete worker s) - where - go v@(outh, buf, bufsig) = do - void $ atomically $ takeTMVar bufsig - l <- takeMVar buf - putMVar buf [] - emitBuffer outh l - if any (== ReachedEnd) l - then return () - else go v - -emitBuffer :: Handle -> Buffer -> IO () -emitBuffer outh l = forM_ (reverse l) $ \ba -> case ba of - Output b -> do - B.hPut outh b - hFlush outh - InTempFile tmp -> do - B.hPut outh =<< B.readFile tmp - void $ tryWhenExists $ removeFile tmp - ReachedEnd -> return () - --- Adds a value to the Buffer. When adding Output to a Handle, it's cheaper --- to combine it with any already buffered Output to that same Handle. --- --- When the total buffered Output exceeds 1 mb in size, it's moved out of --- memory, to a temp file. This should only happen rarely, but is done to --- avoid some verbose process unexpectedly causing excessive memory use. -addBuffer :: BufferedActivity -> Buffer -> IO Buffer -addBuffer (Output b) buf - | B.length b' <= 1048576 = return (Output b' : other) - | otherwise = do - tmpdir <- getTemporaryDirectory - (tmp, h) <- openTempFile tmpdir "output.tmp" - B.hPut h b' - hClose h - return (InTempFile tmp : other) - where - !b' = B.concat (mapMaybe getOutput this) <> b - !(this, other) = partition isOutput buf - isOutput v = case v of - Output _ -> True - _ -> False - getOutput v = case v of - Output b'' -> Just b'' - _ -> Nothing -addBuffer v buf = return (v:buf) diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright 2015 Joey Hess . +Copyright © 2015 Joey Hess +Copyright © 2009 Joachim Breitner Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions diff --git a/System/Console/Concurrent.hs b/System/Console/Concurrent.hs new file mode 100644 --- /dev/null +++ b/System/Console/Concurrent.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} + +-- | +-- Copyright: 2013 Joey Hess +-- License: BSD-2-clause +-- +-- Concurrent output handling. +-- +-- > import Control.Concurrent.Async +-- > import System.Console.Concurrent +-- > +-- > main = withConcurrentOutput $ +-- > outputConcurrent "washed the car\n" +-- > `concurrently` +-- > outputConcurrent "walked the dog\n" +-- > `concurrently` +-- > createProcessConcurrent (proc "ls" []) + +module System.Console.Concurrent ( + -- * Concurrent output + withConcurrentOutput, + Outputable(..), + outputConcurrent, + createProcessConcurrent, + waitForProcessConcurrent, + flushConcurrentOutput, + lockOutput, + -- * Low level access to the output buffer + OutputBuffer, + StdHandle(..), + bufferOutputSTM, + outputBufferWaiterSTM, + waitAnyBuffer, + waitCompleteLines, + emitOutputBuffer, +) where + +import System.IO +import System.Posix.IO +import System.Directory +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 +import Control.Concurrent.Async +import Data.Maybe +import Data.List +import Data.Monoid +import Data.Char +import qualified System.Process as P +import qualified Data.ByteString as B +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) + +import Utility.Monad +import Utility.Exception + +data OutputHandle = OutputHandle + { outputLock :: TMVar Lock + , outputBuffer :: TMVar OutputBuffer + , errorBuffer :: TMVar OutputBuffer + , outputThreads :: TMVar Integer + } + +data Lock = Locked + +-- | A shared global variable for the OutputHandle. +{-# NOINLINE globalOutputHandle #-} +globalOutputHandle :: OutputHandle +globalOutputHandle = unsafePerformIO $ OutputHandle + <$> newEmptyTMVarIO + <*> newTMVarIO (OutputBuffer []) + <*> newTMVarIO (OutputBuffer []) + <*> newTMVarIO 0 + +-- | Holds a lock while performing an action. This allows the action to +-- perform its own output to the console, without using functions from this +-- module. +-- +-- While this is running, other threads that try to lockOutput will block. +-- Any calls to `outputConcurrent` and `createProcessConcurrent` will not +-- block, but the output will be buffered and displayed only once the +-- action is done. +lockOutput :: (MonadIO m, MonadMask m) => m a -> m a +lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) + +-- | Blocks until we have the output lock. +takeOutputLock :: IO () +takeOutputLock = void $ takeOutputLock' True + +-- | Tries to take the output lock, without blocking. +tryTakeOutputLock :: IO Bool +tryTakeOutputLock = takeOutputLock' False + +withLock :: (TMVar Lock -> STM a) -> IO a +withLock a = atomically $ a (outputLock globalOutputHandle) + +takeOutputLock' :: Bool -> IO Bool +takeOutputLock' block = do + locked <- withLock $ \l -> do + v <- tryTakeTMVar l + case v of + Just Locked + | block -> retry + | otherwise -> do + -- Restore value we took. + putTMVar l Locked + return False + Nothing -> do + putTMVar l Locked + return True + when locked $ do + (outbuf, errbuf) <- atomically $ (,) + <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer []) + <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer []) + emitOutputBuffer StdOut outbuf + emitOutputBuffer StdErr errbuf + return locked + +-- | Only safe to call after taking the output lock. +dropOutputLock :: IO () +dropOutputLock = withLock $ void . takeTMVar + +-- | Use this around any actions that use `outputConcurrent` +-- or `createProcessConcurrent` +-- +-- This is necessary to ensure that buffered concurrent output actually +-- gets displayed before the program exits. +withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a +withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput + +-- | Blocks until any processes started by `createProcessConcurrent` have +-- finished, and any buffered output is displayed. +-- +-- `withConcurrentOutput` calls this at the end; you can call it anytime +-- you want to flush output. +flushConcurrentOutput :: IO () +flushConcurrentOutput = do + -- Wait for all outputThreads to finish. + let v = outputThreads globalOutputHandle + atomically $ do + r <- takeTMVar v + if r <= 0 + then putTMVar v r + else retry + -- Take output lock to ensure that nothing else is currently + -- generating output, and flush any buffered output. + lockOutput $ return () + +-- | Values that can be output. +class Outputable v where + toOutput :: v -> B.ByteString + +instance Outputable B.ByteString where + toOutput = id + +instance Outputable T.Text where + toOutput = encodeUtf8 + +instance Outputable String where + toOutput = toOutput . T.pack + +-- | Displays a value to stdout. +-- +-- No newline is appended to the value, so if you want a newline, be sure +-- to include it yourself. +-- +-- Uses locking to ensure that the whole output occurs atomically +-- even when other threads are concurrently generating output. +-- +-- When something else is writing to the console at the same time, this does +-- not block. It buffers the value, so it will be displayed once the other +-- writer is done. +outputConcurrent :: Outputable v => v -> IO () +outputConcurrent v = bracket setup cleanup go + where + setup = tryTakeOutputLock + cleanup False = return () + cleanup True = dropOutputLock + go True = do + B.hPut stdout (toOutput v) + hFlush stdout + go False = do + let bv = outputBuffer globalOutputHandle + oldbuf <- atomically $ takeTMVar bv + newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf + atomically $ putTMVar bv newbuf + +-- | This must be used to wait for processes started with +-- `createProcessConcurrent`. +-- +-- This is necessary because `System.Process.waitForProcess` has a +-- race condition when two threads check the same process. If the race +-- is triggered, one thread will successfully wait, but the other +-- throws a DoesNotExist exception. +waitForProcessConcurrent :: P.ProcessHandle -> IO ExitCode +waitForProcessConcurrent h = do + v <- tryWhenExists (P.waitForProcess h) + case v of + Just r -> return r + Nothing -> maybe (waitForProcessConcurrent h) return =<< P.getProcessExitCode h + +-- | Wrapper around `System.Process.createProcess` that prevents +-- multiple processes that are running concurrently from writing +-- to stdout/stderr at the same time. +-- +-- If the process does not output to stdout or stderr, it's run +-- by createProcess entirely as usual. Only processes that can generate +-- output are handled specially: +-- +-- A process is allowed to write to stdout and stderr in the usual +-- way, assuming it can successfully take the output lock. +-- +-- When the output lock is held (ie, by another concurrent process, +-- or because `outputConcurrent` is being called at the same time), +-- the process is instead run with its stdout and stderr +-- redirected to a buffer. The buffered output will be displayed as soon +-- as the output lock becomes free, or after the command has finished. +createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) +createProcessConcurrent p + | willOutput (P.std_out p) || willOutput (P.std_err p) = + ifM tryTakeOutputLock + ( firstprocess + , concurrentprocess + ) + | otherwise = P.createProcess p + where + rediroutput ss h + | willOutput ss = P.UseHandle h + | otherwise = ss + + firstprocess = do + r@(_, _, _, h) <- P.createProcess p + `onException` dropOutputLock + -- Wait for the process to exit and drop the lock. + void $ async $ do + void $ tryIO $ waitForProcessConcurrent h + dropOutputLock + return r + + concurrentprocess = do + (toouth, fromouth) <- pipe + (toerrh, fromerrh) <- pipe + let p' = p + { P.std_out = rediroutput (P.std_out p) toouth + , P.std_err = rediroutput (P.std_err p) toerrh + } + registerOutputThread + r <- P.createProcess p' + `onException` unregisterOutputThread + outbuf <- setupOutputBuffer StdOut toouth (P.std_out p) fromouth + errbuf <- setupOutputBuffer StdErr toerrh (P.std_err p) fromerrh + void $ async $ bufferWriter [outbuf, errbuf] + return r + + pipe = do + (from, to) <- createPipe + (,) <$> fdToHandle to <*> fdToHandle from + +willOutput :: P.StdStream -> Bool +willOutput P.Inherit = True +willOutput _ = False + +-- | Buffered output. +data OutputBuffer = OutputBuffer [OutputBufferedActivity] + deriving (Eq) + +data StdHandle = StdOut | StdErr + +toHandle :: StdHandle -> Handle +toHandle StdOut = stdout +toHandle StdErr = stderr + +bufferFor :: StdHandle -> TMVar OutputBuffer +bufferFor StdOut = outputBuffer globalOutputHandle +bufferFor StdErr = errorBuffer globalOutputHandle + +data OutputBufferedActivity + = Output B.ByteString + | InTempFile + { tempFile :: FilePath + , endsInNewLine :: Bool + } + deriving (Eq) + +data AtEnd = AtEnd + deriving Eq + +data BufSig = BufSig + +setupOutputBuffer :: StdHandle -> Handle -> P.StdStream -> Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) +setupOutputBuffer h toh ss fromh = do + hClose toh + buf <- newMVar (OutputBuffer []) + bufsig <- atomically newEmptyTMVar + bufend <- atomically newEmptyTMVar + void $ async $ outputDrainer ss fromh buf bufsig bufend + return (h, buf, bufsig, bufend) + +-- Drain output from the handle, and buffer it. +outputDrainer :: P.StdStream -> Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () +outputDrainer ss fromh buf bufsig bufend + | willOutput ss = go + | otherwise = atend + where + go = do + v <- tryIO $ B.hGetSome fromh 1048576 + case v of + Right b | not (B.null b) -> do + modifyMVar_ buf $ addOutputBuffer (Output b) + changed + go + _ -> atend + atend = do + atomically $ putTMVar bufend AtEnd + hClose fromh + changed = atomically $ do + void $ tryTakeTMVar bufsig + putTMVar bufsig BufSig + +registerOutputThread :: IO () +registerOutputThread = do + hFlush stdout + let v = outputThreads globalOutputHandle + atomically $ putTMVar v . succ =<< takeTMVar v + +unregisterOutputThread :: IO () +unregisterOutputThread = do + hFlush stdout + let v = outputThreads globalOutputHandle + atomically $ putTMVar v . pred =<< takeTMVar v + +-- Wait to lock output, and once we can, display everything +-- that's put into the buffers, until the end. +-- +-- If end is reached before lock is taken, instead add the command's +-- buffers to the global outputBuffer and errorBuffer. +bufferWriter :: [(StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd)] -> IO () +bufferWriter ts = do + activitysig <- atomically newEmptyTMVar + worker1 <- async $ lockOutput $ + ifM (atomically $ tryPutTMVar activitysig ()) + ( void $ mapConcurrently displaybuf ts + , noop -- buffers already moved to global + ) + worker2 <- async $ void $ globalbuf activitysig + void $ async $ do + void $ waitCatch worker1 + void $ waitCatch worker2 + unregisterOutputThread + where + displaybuf v@(outh, buf, bufsig, bufend) = do + change <- atomically $ + (Right <$> takeTMVar bufsig) + `orElse` + (Left <$> takeTMVar bufend) + l <- takeMVar buf + putMVar buf (OutputBuffer []) + emitOutputBuffer outh l + case change of + Right BufSig -> displaybuf v + Left AtEnd -> return () + globalbuf activitysig = do + ok <- atomically $ do + -- signal we're going to handle it + -- (returns false if the displaybuf already did) + ok <- tryPutTMVar activitysig () + -- wait for end of all buffers + when ok $ + mapM_ (\(_outh, _buf, _bufsig, bufend) -> takeTMVar bufend) ts + return ok + when ok $ do + -- add all of the command's buffered output to the + -- global output buffer, atomically + bs <- forM ts $ \(outh, buf, _bufsig, _bufend) -> + (outh,) <$> takeMVar buf + atomically $ + forM_ bs $ \(outh, b) -> + bufferOutputSTM' outh b + +-- 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 +-- same Handle. +-- +-- When the total buffered Output exceeds 1 mb in size, it's moved out of +-- memory, to a temp file. This should only happen rarely, but is done to +-- avoid some verbose process unexpectedly causing excessive memory use. +addOutputBuffer :: OutputBufferedActivity -> OutputBuffer -> IO OutputBuffer +addOutputBuffer (Output b) (OutputBuffer buf) + | B.length b' <= 1048576 = return $ OutputBuffer (Output b' : other) + | otherwise = do + tmpdir <- getTemporaryDirectory + (tmp, h) <- openTempFile tmpdir "output.tmp" + let !endnl = endsNewLine b' + let i = InTempFile + { tempFile = tmp + , endsInNewLine = endnl + } + B.hPut h b' + hClose h + return $ OutputBuffer (i : other) + where + !b' = B.concat (mapMaybe getOutput this) <> b + !(this, other) = partition isOutput buf + isOutput v = case v of + Output _ -> True + _ -> False + getOutput v = case v of + Output b'' -> Just b'' + _ -> Nothing +addOutputBuffer v (OutputBuffer buf) = return $ OutputBuffer (v:buf) + +-- | Adds a value to the output buffer for later display. +-- +-- Note that buffering large quantities of data this way will keep it +-- resident in memory until it can be displayed. While `outputConcurrent` +-- uses temp files if the buffer gets too big, this STM function cannot do +-- so. +bufferOutputSTM :: Outputable v => StdHandle -> v -> STM () +bufferOutputSTM h v = bufferOutputSTM' h (OutputBuffer [Output (toOutput v)]) + +bufferOutputSTM' :: StdHandle -> OutputBuffer -> STM () +bufferOutputSTM' h (OutputBuffer newbuf) = do + (OutputBuffer buf) <- takeTMVar bv + putTMVar bv (OutputBuffer (newbuf ++ buf)) + where + bv = bufferFor h + +-- | A STM action that waits for some buffered output to become +-- available, and returns it. +-- +-- The function can select a subset of output when only some is desired; +-- the fst part is returned and the snd is left in the buffer. +-- +-- This will prevent it from being displayed in the usual way, so you'll +-- need to use `emitOutputBuffer` to display it yourself. +outputBufferWaiterSTM :: (OutputBuffer -> (OutputBuffer, OutputBuffer)) -> STM [(StdHandle, OutputBuffer)] +outputBufferWaiterSTM selector = do + bs <- forM hs $ \h -> do + let bv = bufferFor h + (selected, rest) <- selector <$> takeTMVar bv + putTMVar bv rest + return selected + if all (== OutputBuffer []) bs + then retry + else do + return (zip hs bs) + where + hs = [StdOut, StdErr] + +waitAnyBuffer :: OutputBuffer -> (OutputBuffer, OutputBuffer) +waitAnyBuffer b = (b, OutputBuffer []) + +-- | Use with `outputBufferWaiterSTM` to make it only return buffered +-- output that ends with a newline. Anything buffered without a newline +-- is left in the buffer. +waitCompleteLines :: OutputBuffer -> (OutputBuffer, OutputBuffer) +waitCompleteLines (OutputBuffer l) = + let (selected, rest) = span completeline l + in (OutputBuffer selected, OutputBuffer rest) + where + completeline (v@(InTempFile {})) = endsInNewLine v + completeline (Output b) = endsNewLine b + +endsNewLine :: B.ByteString -> Bool +endsNewLine b = not (B.null b) && B.last b == fromIntegral (ord '\n') + +-- | Emits the content of the OutputBuffer to the Handle +-- +-- If you use this, you should use `lockOutput` to ensure you're the only +-- thread writing to the console. +emitOutputBuffer :: StdHandle -> OutputBuffer -> IO () +emitOutputBuffer stdh (OutputBuffer l) = + forM_ (reverse l) $ \ba -> case ba of + Output b -> do + B.hPut outh b + hFlush outh + InTempFile tmp _ -> do + B.hPut outh =<< B.readFile tmp + void $ tryWhenExists $ removeFile tmp + where + outh = toHandle stdh diff --git a/System/Console/Regions.hs b/System/Console/Regions.hs new file mode 100644 --- /dev/null +++ b/System/Console/Regions.hs @@ -0,0 +1,540 @@ +{-# LANGUAGE BangPatterns, TupleSections #-} + +-- | +-- Copyright: 2013 Joey Hess +-- License: BSD-2-clause +-- +-- Console regions are displayed near the bottom of the console, and can be +-- updated concurrently by threads. Any other output displayed using +-- `outputConcurrent` and `createProcessConcurrent` +-- will scroll up above the open console regions. +-- +-- For example, this program: +-- +-- > import Control.Concurrent.Async +-- > import Control.Concurrent +-- > import System.Console.Concurrent +-- > import System.Console.Regions +-- > +-- > main = displayConsoleRegions $ do +-- > mapConcurrently download [1..5] `concurrently` mapM_ message [1..10] +-- > +-- > message :: Int -> IO () +-- > message n = do +-- > threadDelay 500000 +-- > outputConcurrent ("Message " ++ show n ++ "\n") +-- > +-- > download :: Int -> IO () +-- > download n = withConsoleRegion Linear $ \r -> do +-- > setConsoleRegion r basemsg +-- > go n r +-- > where +-- > basemsg = "Download " ++ show n +-- > go c r +-- > | c < 1 = finishConsoleRegion r (basemsg ++ " done!") +-- > | otherwise = do +-- > threadDelay 1000000 +-- > appendConsoleRegion r " ... " +-- > go (c-1) r +-- +-- Will display like this: +-- +-- > Message 1 +-- > Message 2 +-- > Download 1 ... +-- > Download 2 ... +-- > Download 3 ... +-- +-- Once the 1st download has finished, and another message has displayed, +-- the console will update like this: +-- +-- > Message 1 +-- > Message 2 +-- > Download 1 done! +-- > Message 3 +-- > Download 2 ... ... +-- > Download 3 ... ... + +module System.Console.Regions ( + -- * Initialization + displayConsoleRegions, + ConsoleRegionHandle, + RegionLayout(..), + withConsoleRegion, + openConsoleRegion, + closeConsoleRegion, + -- * Output + setConsoleRegion, + appendConsoleRegion, + finishConsoleRegion, + -- * STM interface + -- + -- | These actions can be composed into a STM transaction; + -- once the transaction completes the console will be updated + -- a single time to reflect all the changes made. + openConsoleRegionSTM, + closeConsoleRegionSTM, + setConsoleRegionSTM, + appendConsoleRegionSTM, + updateRegionListSTM, +) where + +import Data.Monoid +import Data.Maybe +import Data.String +import Data.Char +import qualified Data.ByteString as B +import Control.Monad +import Control.Applicative +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Concurrent.STM +import Control.Concurrent.STM.TSem +import Control.Concurrent.Async +import System.Console.ANSI +import qualified System.Console.Terminal.Size as Console +import System.IO +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Signals +import System.Posix.Signals.Exts + +import System.Console.Concurrent +import Utility.Monad +import Utility.Exception + +-- | Controls how a region is laid out in the console. +-- +-- Here's an annotated example of how the console layout works. +-- +-- > scrolling...... +-- > scrolling...... +-- > scrolling...... +-- > aaaaaa......... -- Linear +-- > bbbbbbbbbbbbbbb -- Linear +-- > bbb............ (expanded to multiple lines) +-- > ccccccccc...... -- Linear +-- > ddd eee fffffff -- [InLine] +-- > ffff ggggg..... (expanded to multiple lines) +-- > +data RegionLayout = Linear | InLine ConsoleRegionHandle + deriving (Eq) + +newtype ConsoleRegionHandle = ConsoleRegionHandle (TVar Region) + deriving (Eq) + +type Width = Int +type Height = Int + +data Region = Region + { regionContent :: B.ByteString + , regionHeight :: (Width -> Height) + -- ^ Function from console width to the height of this region + , regionLayout :: RegionLayout + , regionChildren :: Maybe [ConsoleRegionHandle] + } + +instance Eq Region where + a == b = regionContent a == regionContent b + && regionLayout a == regionLayout b + +type RegionList = TMVar [ConsoleRegionHandle] + +-- | A shared global list of regions. +{-# NOINLINE regionList #-} +regionList :: RegionList +regionList = unsafePerformIO newEmptyTMVarIO + +-- | Updates the list of regions. The list is ordered from the bottom of +-- the screen up. Reordering it will change the order in which regions are +-- displayed. It's also fine to remove, duplicate, or add new regions to the +-- list. +updateRegionListSTM :: ([ConsoleRegionHandle] -> [ConsoleRegionHandle]) -> STM () +updateRegionListSTM f = + maybe noop (putTMVar regionList . f) =<< tryTakeTMVar regionList + +-- | The RegionList TMVar is left empty when `displayConsoleRegions` +-- is not running. +regionDisplayEnabled :: IO Bool +regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList + +-- | Sets the value to display within a console region. +{- TODO +-- It's fine for the value to be longer than the terminal is wide. +-- Regions are laid out according to the size of their contents, +-- and expand to multiple lines if necessary. +-- +-- The value of a `Linear` region can contain newlines ('\n'). +-- And it's ok to include ANSI escape sequences for changing colors, +-- or setting the terminal title. However, ANSI cursor movement sequences +-- will mess up the layouts of regions, '\r' is not handled, and +-- other control characters or ANSI codes may confuse the region +-- display. Caveat emptor. +-} +setConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO () +setConsoleRegion h = atomically . setConsoleRegionSTM h + +setConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () +setConsoleRegionSTM (ConsoleRegionHandle tv) v = do + r <- readTVar tv + writeTVar tv (modifyRegion r (const (toOutput v))) + case regionLayout r of + Linear -> return () + InLine p -> refreshParent p + +-- | Appends the value to whatever was already on display within a console +-- region. +appendConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO () +appendConsoleRegion h = atomically . appendConsoleRegionSTM h + +appendConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () +appendConsoleRegionSTM (ConsoleRegionHandle tv) v = do + r <- readTVar tv + writeTVar tv (modifyRegion r (<> toOutput v)) + case regionLayout r of + Linear -> return () + InLine p -> refreshParent p + +modifyRegion :: Region -> (B.ByteString -> B.ByteString) -> Region +modifyRegion r f = r { regionContent = c, regionHeight = calcRegionHeight c } + where + !c = f (regionContent r) + +-- | Runs the action with a new console region, closing the region when +-- the action finishes or on exception. +withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegionHandle -> m a) -> m a +withConsoleRegion l = bracketIO (openConsoleRegion l) closeConsoleRegion + +-- | Opens a new console region for output. +openConsoleRegion :: RegionLayout -> IO ConsoleRegionHandle +openConsoleRegion = atomically . openConsoleRegionSTM + +-- | STM version of `openConsoleRegion`. Allows atomically opening multiple +-- regions at the same time, which guarantees they are on adjacent lines. +-- +-- > [r1, r2, r3] <- atomically $ +-- > replicateM 3 (openConsoleRegionSTM Linear) +openConsoleRegionSTM :: RegionLayout -> STM ConsoleRegionHandle +openConsoleRegionSTM ly = do + let r = Region + { regionContent = mempty + , regionHeight = calcRegionHeight mempty + , regionLayout = ly + , regionChildren = Nothing + } + h <- ConsoleRegionHandle <$> newTVar r + case ly of + Linear -> do + v <- tryTakeTMVar regionList + case v of + Just l -> do putTMVar regionList (h:l) + -- displayConsoleRegions is not active, so + -- it's not put on any list, and won't display + Nothing -> return () + InLine parent -> addChild h parent + + return h + +-- | Closes a console region. Once closed, the region is removed from the +-- display. +closeConsoleRegion :: ConsoleRegionHandle -> IO () +closeConsoleRegion = atomically . closeConsoleRegionSTM + +closeConsoleRegionSTM :: ConsoleRegionHandle -> STM () +closeConsoleRegionSTM h@(ConsoleRegionHandle tv) = do + v <- tryTakeTMVar regionList + case v of + Just l -> + let !l' = filter (/= h) l + in putTMVar regionList l' + _ -> return () + ly <- regionLayout <$> readTVar tv + case ly of + Linear -> return () + InLine parent -> removeChild h parent + +-- | Closes the console region and displays the passed value in the +-- scrolling area above the active console regions. +finishConsoleRegion :: Outputable v => ConsoleRegionHandle -> v -> IO () +finishConsoleRegion h = atomically . finishConsoleRegionSTM h + +finishConsoleRegionSTM :: Outputable v => ConsoleRegionHandle -> v -> STM () +finishConsoleRegionSTM h v = do + closeConsoleRegionSTM h + bufferOutputSTM StdOut (toOutput v <> fromString "\n") + +removeChild :: ConsoleRegionHandle -> ConsoleRegionHandle -> STM () +removeChild child parent@(ConsoleRegionHandle pv) = do + modifyTVar' pv $ \p -> case regionChildren p of + Nothing -> p + Just l -> p { regionChildren = Just $ filter (/= child) l } + refreshParent parent + +addChild :: ConsoleRegionHandle -> ConsoleRegionHandle -> STM () +addChild child parent@(ConsoleRegionHandle pv) = do + modifyTVar' pv $ \p -> p + { regionChildren = Just $ child : filter (/= child) (fromMaybe [] (regionChildren p)) } + refreshParent parent + +refreshParent :: ConsoleRegionHandle -> STM () +refreshParent parent@(ConsoleRegionHandle pv) = do + p <- readTVar pv + case regionChildren p of + Nothing -> return () + Just l -> do + cs <- forM l $ \child@(ConsoleRegionHandle cv) -> do + refreshParent child + regionContent <$> readTVar cv + let p' = p { regionContent = mconcat cs } + writeTVar pv p' + +-- | Handles all display for the other functions in this module. +-- +-- Note that this uses `lockOutput`, so it takes over all output to the +-- console while the passed IO action is running. As well as displaying +-- the console regions, this handles display of anything buffered by +-- `outputConcurrent` and `createProcessConcurrent`. +-- +-- When standard output is not an ANSI capable terminal, +-- console regions are not displayed. +displayConsoleRegions :: (MonadIO m, MonadMask m) => m a -> m a +displayConsoleRegions a = ifM (liftIO regionDisplayEnabled) + ( a -- displayConsoleRegions is already running + , lockOutput $ bracket setup cleanup (const a) + ) + where + setup = liftIO $ do + atomically $ putTMVar regionList [] + endsignal <- atomically $ do + s <- newTSem 1 + waitTSem s + return s + isterm <- liftIO $ hSupportsANSI stdout + cwidth <- atomically newEmptyTMVar + when isterm $ + trackConsoleWidth cwidth + da <- async $ displayThread isterm cwidth endsignal + return (isterm, da, endsignal) + cleanup (isterm, da, endsignal) = liftIO $ do + atomically $ signalTSem endsignal + void $ wait da + void $ atomically $ takeTMVar regionList + when isterm $ + installResizeHandler Nothing + +trackConsoleWidth :: TMVar Width -> IO () +trackConsoleWidth cwidth = do + let getwidth = do + v <- Console.size + case v of + Nothing -> return () + Just (Console.Window _height width) -> + atomically $ void $ do + void $ tryTakeTMVar cwidth + putTMVar cwidth width + getwidth + installResizeHandler $ Just getwidth + +data DisplayChange + = BufferChange [(StdHandle, OutputBuffer)] + | RegionChange RegionSnapshot + | TerminalResize (Maybe Width) + | EndSignal () + +type RegionSnapshot = ([ConsoleRegionHandle], [Region], Maybe Width) + +displayThread :: Bool -> TMVar Width -> TSem -> IO () +displayThread isterm cwidth endsignal = do + origwidth <- atomically $ tryReadTMVar cwidth + go ([], [], origwidth) + where + go origsnapshot@(orighandles, origregions, origwidth) = do + let waitwidthchange = do + v <- tryReadTMVar cwidth + if v == origwidth then retry else return v + change <- atomically $ + (RegionChange <$> regionWaiter origsnapshot) + `orElse` + (RegionChange <$> regionListWaiter origsnapshot) + `orElse` + (BufferChange <$> outputBufferWaiterSTM waitCompleteLines) + `orElse` + (TerminalResize <$> waitwidthchange) + `orElse` + (EndSignal <$> waitTSem endsignal) + case change of + RegionChange snapshot@(_, regions, _) -> do + when isterm $ + changedRegions origregions regions + go snapshot + BufferChange buffers -> do + inAreaAbove isterm origregions $ + mapM_ (uncurry emitOutputBuffer) buffers + go origsnapshot + TerminalResize width -> do + when isterm $ + -- force redraw of all regions + inAreaAbove isterm origregions $ + return () + go (orighandles, origregions, width) + EndSignal () -> return () + +readRegions :: [ConsoleRegionHandle] -> STM [Region] +readRegions = mapM (\(ConsoleRegionHandle h) -> readTVar h) + +-- Wait for any changes to the region list, eg adding or removing a handle. +regionListWaiter :: RegionSnapshot -> STM RegionSnapshot +regionListWaiter (orighandles, _origregions, origwidth) = do + handles <- readTMVar regionList + if handles == orighandles + then retry + else (handles,,origwidth) <$> readRegions handles + +-- Wait for any changes to any of the regions currently in the region list. +regionWaiter :: RegionSnapshot -> STM RegionSnapshot +regionWaiter (orighandles, origregions, origwidth) = do + rs <- readRegions orighandles + if rs == origregions + then retry + else return (orighandles, rs, origwidth) + +-- This is not an optimal screen update like curses can do, but it's +-- pretty efficient, most of the time! The only particularly +-- expensive part is removing a region, which typically reorders +-- the regions and so requires redrawing them all. +changedRegions :: [Region] -> [Region] -> IO () +changedRegions origregions regions + | delta == 0 = do + -- The total number of regions is unchanged, so update + -- whichever ones have changed, and leave the rest as-is. + diffUpdate origregions regions + | delta > 0 = do + -- Added more regions, so output each, with a + -- newline, thus scrolling the old regions up + -- the screen. (We can do this, because the cursor + -- is left below the first region.) + let newregions = reverse (take delta regions) + displayRegions newregions + hFlush stdout + -- Some existing regions may have also changed.. + let scrolledregions = newregions ++ origregions + diffUpdate scrolledregions regions + | otherwise = do + -- Some regions were removed. Move up that many lines, + -- clearing each line, and update any changed regions. + replicateM_ (abs delta) $ do + cursorUpLine 1 + clearLine + diffUpdate (drop (abs delta) origregions) regions + where + delta = length regions - length origregions + +-- TODO Rather than writing the whole text of a region, find +-- a more efficient update, reusing parts of the old content of the region. +diffUpdate :: [Region] -> [Region] -> IO () +diffUpdate origregions regions = updateRegions (zip regions changed) + where + changed = map (uncurry (/=)) (zip regions origregions) ++ repeat True + +-- Displays regions that are paired with True, and skips over the rest. +-- Cursor is assumed to be just below the line of the first region at the +-- beginning, and is put back there at the end. +updateRegions :: [(Region, Bool)] -> IO () +updateRegions l + | null l' = noop + | otherwise = do + forM_ l' $ \(r, offset) -> do + cursorUpLine offset + clearLine + B.hPut stdout (regionContent r) + hFlush stdout + cursorDownLine (sum (map snd l')) + setCursorColumn 0 + hFlush stdout + where + l' = changeOffsets l 1 [] + +changeOffsets :: [(r, Bool)] -> Int -> [(r, Int)] -> [(r, Int)] +changeOffsets [] _ c = reverse c +changeOffsets ((r, changed):rs) n c + | changed = changeOffsets rs 1 ((r, n):c) + | otherwise = changeOffsets rs (succ n) c + +-- Move cursor up before the regions, performs some output there, +-- which will scroll down and overwrite the regions, so +-- redraws all the regions below. +inAreaAbove :: Bool -> [Region] -> IO () -> IO () +inAreaAbove isterm regions outputter = do + when isterm $ do + unless (null regions) $ + cursorUpLine (length regions) + clearFromCursorToScreenEnd + outputter + when isterm $ do + setCursorColumn 0 -- just in case the output lacked a newline + displayRegions (reverse regions) + hFlush stdout + +displayRegions :: [Region] -> IO () +displayRegions = mapM_ $ \r -> do + B.hPut stdout (regionContent r) + putChar '\n' + +installResizeHandler :: Maybe (IO ()) -> IO () +installResizeHandler h = void $ + installHandler windowChange (maybe Default Catch h) Nothing + +calcRegionHeight :: B.ByteString -> Width -> Height +calcRegionHeight b width = sum $ map (calcLineHeight width) (B.split wnl b) + where + wnl = fromIntegral (ord '\n') + +-- Calculate the height a line would occupy if output onto a console +-- with a given width, starting from the first column. +-- +-- Note that this counts each byte, is not aware of multibyte characters, +-- so will over-estimate a bit for those. +-- +-- Also an issue are ANSI escape sequences for eg, setting colors or the +-- title. This is handled by stripping out common ANSI escape sequences +-- and control characters. +calcLineHeight :: Width -> B.ByteString -> Height +calcLineHeight width b + | width < 1 || B.null b = 1 -- even an empty line is 1 line high + | otherwise = + let (q,r) = (B.length b - countInvisibleBytes b) `quotRem` width + in q + if r > 0 then 1 else 0 + +-- ANSI sequences and control characters. +countInvisibleBytes :: B.ByteString -> Int +countInvisibleBytes = go 0 . breakesc + where + go c (beforeesc, b) + | B.length b <= 1 = B.length b + c' + | headis csi (B.drop 1 b) = countseq breakcsi + | headis osc (B.drop 1 b) = countseq breakosc + -- found an ESC but apparently not in an ANSI sequence; + -- count it as 1 invisible control character + | otherwise = go (c'+1) (breakesc (B.drop 1 b)) + where + c' = c + countControlChars beforeesc + countseq breaker = + let (inseq, b') = breaker (B.drop 2 b) + -- add 1 for the ESC and one for the head char + -- that introduced the sequence, plus the length + -- of the rest of the sequence, plus 1 for + -- the end char of the sequence. + in go (c'+1+1+B.length inseq+1) (breakesc (B.drop 1 b')) + + esc = fromIntegral (ord '\ESC') + bel = fromIntegral (ord '\BEL') + breakesc = B.break (== esc) + headis c b = B.head b ==c + csi = fromIntegral (ord '[') -- Control Sequence Introducer + csiend c = c >= 64 && c < 127 + breakcsi = B.break csiend + osc = fromIntegral (ord ']') -- Operating system command + breakosc = B.break (== bel) + +countControlChars :: B.ByteString -> Int +countControlChars = length . filter iscontrol8 . B.unpack + where + iscontrol8 c = c < 32 || c == 127 -- del diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,5 @@ +Optimize line update, avoiding outputting characters already on-screen (aka +what curses does, but this is portable to even windows, so no curses. Anway, +should be under 20 line function.) + +Make layout take region width into account. diff --git a/aptdemo.hs b/aptdemo.hs new file mode 100644 --- /dev/null +++ b/aptdemo.hs @@ -0,0 +1,30 @@ +-- Demo similar to apt-get's download display. + +import Control.Concurrent.Async +import Control.Concurrent +import System.Console.Concurrent +import System.Console.Regions + +main = displayConsoleRegions $ do + mapConcurrently downline + [ ["foo", "bar", "baz"] + , ["pony", "mango", "very_large"] + ] + `concurrently` mapM_ message [1..20] + +message n = do + threadDelay 500000 + outputConcurrent ("Updated blah blah #" ++ show n ++ "\n") + +downline cs = withConsoleRegion Linear $ \r -> + mapConcurrently (kid r) (reverse cs) + where + kid parent c = withConsoleRegion (InLine parent) (go c 0) + go c n r + | n <= 100 = do + setConsoleRegion r $ + "[" ++ c ++ " " ++ show n ++ "%] " + threadDelay (25000 * length c) + go c (n+1) r + | otherwise = finishConsoleRegion r $ + "Downloaded " ++ c ++ ".deb" diff --git a/concurrent-output.cabal b/concurrent-output.cabal --- a/concurrent-output.cabal +++ b/concurrent-output.cabal @@ -1,21 +1,33 @@ Name: concurrent-output -Version: 1.0.1 +Version: 1.1.0 Cabal-Version: >= 1.8 -License: BSD3 +License: BSD2 Maintainer: Joey Hess -Author: Joey Hess +Author: Joey Hess, Joachim Breitner Stability: Stable -Copyright: 2015 Joey Hess +Copyright: 2015 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple -Category: Concurrency -Synopsis: handling concurrent output +Category: User Interfaces +Synopsis: Ungarble output from several threads Description: Provides a simple interface for writing concurrent programs that - need to output a lot of status messages to the console, and/or run - concurrent external commands that output to the console. + need to output a lot of status messages to the console, or display + multiple progress bars for different activities at the same time, + or concurrently run external commands that output to the console. + . + Built on top of that is a way of defining multiple output regions, + which are automatically laid out on the screen and can be individually + updated. Can be used for progress displays etc. + . + <> Extra-Source-Files: CHANGELOG + TODO + demo.hs + demo2.hs + demo3.hs + aptdemo.hs Library GHC-Options: -Wall -fno-warn-tabs -O2 @@ -27,11 +39,13 @@ , process (>= 1.2.0 && < 1.4.0) , unix (>= 2.7.0 && < 2.8.0) , directory (>= 1.2.0 && < 1.3.0) - , containers (>= 0.5.0 && < 0.6.0) , transformers (>= 0.3.0 && < 0.5.0) , exceptions (>= 0.8.0 && < 0.9.0) + , ansi-terminal (>= 0.6.0 && < 0.7.0) + , terminal-size (>= 0.3.0 && < 0.4.0) Exposed-Modules: - Control.Concurrent.Output + System.Console.Concurrent + System.Console.Regions Other-Modules: Utility.Monad Utility.Data diff --git a/demo.hs b/demo.hs new file mode 100644 --- /dev/null +++ b/demo.hs @@ -0,0 +1,41 @@ +import Control.Concurrent.Async +import Control.Concurrent +import System.Console.Concurrent +import System.Console.Regions +import System.Process + +main = displayConsoleRegions $ do + mapConcurrently download [1..5] + `concurrently` mapM_ message [1..15] + `concurrently` ls + +message :: Int -> IO () +message n = do + threadDelay 300000 + outputConcurrent ("Message " ++ show n ++ "\n") + +download :: Int -> IO () +download n = withConsoleRegion Linear $ \r -> do + threadDelay (10000 * n) + setConsoleRegion r basemsg + go n r + where + basemsg = "Download " ++ show n + go c r + | c < 1 = finishConsoleRegion r + (basemsg ++ " done!\n Took xxx seconds.") + | otherwise = do + threadDelay 1000000 + appendConsoleRegion r " ... " + go (c-1) r + +ls :: IO () +ls = do + threadDelay 1000000 + (Nothing, Nothing, Nothing, p) <- createProcessConcurrent (proc "ls" ["-C"]) + outputConcurrent "started running ls >>>" + _ <- waitForProcess p + outputConcurrent "<<< ls is done!\n" + return () + + diff --git a/demo2.hs b/demo2.hs new file mode 100644 --- /dev/null +++ b/demo2.hs @@ -0,0 +1,29 @@ +import Control.Concurrent.Async +import Control.Concurrent +import System.Console.Concurrent +import System.Console.Regions + +main = displayConsoleRegions $ mapConcurrently id + [ spinner 100 1 "Pinwheels!!" setConsoleRegion "/-\\|" (withtitle 1) + , spinner 100 1 "Bubbles!!!!" setConsoleRegion ".oOo." (withtitle 1) + , spinner 40 2 "Dots......!" appendConsoleRegion "." (const (take 1)) + , spinner 30 2 "KleisiFish?" setConsoleRegion " <=< <=< " (withtitle 10) + , spinner 10 9 "Countdowns!" setConsoleRegion + (reverse [1..10]) + (\t n -> t ++ show (head n)) + ] + where + withtitle n t s = t ++ take n s + +spinner :: Int -> Int -> String -> (ConsoleRegionHandle -> String -> IO ()) -> [s] -> (String -> [s] -> String) -> IO () +spinner cycles delay title updater source f = + withConsoleRegion Linear $ \r -> do + setConsoleRegion r title' + mapM_ (go r) (zip [1..cycles] sourcestream) + finishConsoleRegion r ("Enough " ++ title) + where + title' = title ++ " " + sourcestream = repeat (concat (repeat source)) + go r (n, s) = do + updater r (f title' (drop n s)) + threadDelay (delay * 100000) diff --git a/demo3.hs b/demo3.hs new file mode 100644 --- /dev/null +++ b/demo3.hs @@ -0,0 +1,12 @@ +import Control.Concurrent.Async +import System.Console.Concurrent +import System.Process + +main = withConcurrentOutput $ + outputConcurrent "washed the car\n" + `concurrently` + createProcessConcurrent (proc "ls" []) + `concurrently` + createProcessConcurrent (proc "sh" ["-c", "echo \"hi from echo!\" >&2"]) + `concurrently` + outputConcurrent "walked the dog\n"