concurrent-output-1.10.21/0000755000000000000000000000000007346545000013565 5ustar0000000000000000concurrent-output-1.10.21/CHANGELOG0000644000000000000000000002600407346545000015001 0ustar0000000000000000concurrent-output (1.10.21) unstable; urgency=medium * Allow ansi-terminal-1.1 -- Joey Hess Mon, 29 Apr 2024 10:15:55 -0400 concurrent-output (1.10.20) unstable; urgency=medium * Allow text-2.1. -- Joey Hess Thu, 12 Oct 2023 15:46:36 -0400 concurrent-output (1.10.19) unstable; urgency=medium * Support building for WASM. -- Joey Hess Wed, 30 Aug 2023 16:03:03 -0400 concurrent-output (1.10.18) unstable; urgency=medium * Avoid some build warnings on Windows. * Allow ansi-terminal-1.0 -- Joey Hess Mon, 15 May 2023 16:32:50 -0400 concurrent-output (1.10.17) unstable; urgency=medium * Fix ansi-terminal dependency to only include >= 0.6.2, which is needed for hSupportsANSI. -- Joey Hess Tue, 10 Jan 2023 15:40:11 -0400 concurrent-output (1.10.16) unstable; urgency=medium * Allow transformers-0.6 (Thanks, Janus Troelsen) -- Joey Hess Fri, 20 May 2022 19:31:56 -0400 concurrent-output (1.10.15) unstable; urgency=medium * Allow text-2.0 -- Joey Hess Fri, 04 Feb 2022 15:32:58 -0400 concurrent-output (1.10.14) unstable; urgency=medium * Allow ansi-terminal-0.11.1. -- Joey Hess Wed, 24 Nov 2021 09:18:20 -0400 concurrent-output (1.10.13) unstable; urgency=medium * outputConcurrent and errorConcurrent are now safe to call from a thread that receives async exceptions. * Fix compilation with GHC head. (Thanks, Ellie Hermaszewska) -- Joey Hess Mon, 22 Nov 2021 11:19:21 -0400 concurrent-output (1.10.12) unstable; urgency=medium * Bugfix: createProcessConcurrent would sometimes send the process's output to the console when it was supposed to be piped to a handle. (1.7.5 introduced this bug) * System.Console.Regions should be safe to use in a thread that receives async exceptions; displayConsoleRegions and withConsoleRegion have been made async exception safe. (However, System.Console.Concurrent is not async exception safe.) * Improve documentation about when withConcurrentOutput should be used. * Remove some unused code. * Allow building with older ansi-terminal versions, not only 0.9+. -- Joey Hess Wed, 10 Jun 2020 17:22:39 -0400 concurrent-output (1.10.11) unstable; urgency=medium * Improve documentation of how to use ANSI color codes. * Allow ansi-terminal-0.10. -- Joey Hess Sun, 06 Oct 2019 15:14:42 -0400 concurrent-output (1.10.10) unstable; urgency=medium * Allow ansi-terminal-0.9. * Fix a build warning. -- Joey Hess Sun, 12 May 2019 16:29:18 -0400 concurrent-output (1.10.9) unstable; urgency=medium * waitDisplayChange would deadlock if the STM action passed to it did not cause any changes to the display. That is now safe to do. -- Joey Hess Mon, 19 Nov 2018 18:40:55 -0400 concurrent-output (1.10.8) unstable; urgency=medium * Fix bug in waitDisplayChange that could result in an STM deadlock exception. -- Joey Hess Mon, 19 Nov 2018 17:01:12 -0400 concurrent-output (1.10.7) unstable; urgency=medium * Allow stm-2.5. -- Joey Hess Sat, 22 Sep 2018 17:14:59 -0400 concurrent-output (1.10.6) unstable; urgency=medium * Relax unix bound for ghc 8.6. -- Joey Hess Mon, 02 Jul 2018 10:58:59 -0400 concurrent-output (1.10.5) unstable; urgency=medium * Allow exceptions-0.10. -- Joey Hess Tue, 13 Mar 2018 11:50:39 -0400 concurrent-output (1.10.4) unstable; urgency=medium * Allow exceptions-0.9. -- Joey Hess Mon, 26 Feb 2018 11:45:08 -0400 concurrent-output (1.10.3) unstable; urgency=medium * Allow async-2.2. -- Joey Hess Mon, 05 Feb 2018 11:07:27 -0400 concurrent-output (1.10.2) unstable; urgency=medium * Allow ansi-terminal-0.8. -- Joey Hess Thu, 25 Jan 2018 11:51:43 -0400 concurrent-output (1.10.1) unstable; urgency=medium * Allow ansi-terminal-0.7. -- Joey Hess Sat, 25 Nov 2017 17:11:50 -0400 concurrent-output (1.10.0) unstable; urgency=medium * Simplified by removing workaround for waitForProcess race condition (https://github.com/haskell/process/issues/46). * Depends on process-1.6.0.0 which fixed that race. * ConcurrentProcessHandle is now a type alias for ProcessHandle, and waitForProcessConcurrent simply calls waitForProcess. These are now only provided to avoid breaking backwards compatability. -- Joey Hess Fri, 19 May 2017 11:54:49 -0400 concurrent-output (1.9.2) unstable; urgency=medium * Allow process-1.6.0.0. -- Joey Hess Fri, 19 May 2017 11:36:35 -0400 concurrent-output (1.9.1) unstable; urgency=medium * Documentation fix: createProcessConcurrent has been available on Windows since 1.7.5 but the docs said not. * When all regions are closed, flush stdout so that the display gets updated, which didn't happen before. -- Joey Hess Tue, 16 May 2017 16:49:43 -0400 concurrent-output (1.9.0) unstable; urgency=medium * Replaced displayUpdateNotifier with a simpler and safer waitDisplayChange interface. -- Joey Hess Fri, 12 May 2017 17:17:09 -0400 concurrent-output (1.8.0) unstable; urgency=medium * Added displayUpdateNotifier, which can be used to wait for changes to console regions to be displayed. (stmdemo has an example of using that to temporarily shut down the region based display to run a bash prompt, and restore the region display later.) -- Joey Hess Fri, 12 May 2017 16:27:41 -0400 concurrent-output (1.7.9) unstable; urgency=medium * Allow lazy text to be used as an Outputable value, and as the content of a Region. -- Joey Hess Sun, 12 Feb 2017 18:13:47 -0400 concurrent-output (1.7.8) unstable; urgency=medium * Update directory dep to allow 1.3. -- Joey Hess Tue, 20 Dec 2016 15:17:55 -0400 concurrent-output (1.7.7) unstable; urgency=medium * Fix build on Windows. -- Joey Hess Tue, 06 Sep 2016 13:41:46 -0400 concurrent-output (1.7.6) unstable; urgency=medium * Update transformers dep to allow 0.5. -- Joey Hess Mon, 02 May 2016 08:01:20 -0400 concurrent-output (1.7.5) unstable; urgency=medium * createProcessConcurrent and System.Process.Concurrent are now available on Windows. -- Joey Hess Sun, 01 May 2016 19:40:38 -0400 concurrent-output (1.7.4) unstable; urgency=medium * Update process dep to allow 1.4. -- Joey Hess Sat, 12 Mar 2016 13:17:59 -0400 concurrent-output (1.7.3) unstable; urgency=medium * Update async dep to allow 2.1. -- Joey Hess Tue, 05 Jan 2016 14:07:43 -0400 concurrent-output (1.7.2) unstable; urgency=medium * Running a process within displayConsoleRegions caused a small resource leak, due to a thread that stalled until the displayConsoleRegions action finished. This is fixed. * Clean build with ghc 7.10. -- Joey Hess Sat, 19 Dec 2015 16:47:08 -0400 concurrent-output (1.7.1) unstable; urgency=medium * Simplify code. * Improve package description. * Relax lower bounds of process, text, exceptions. -- Joey Hess Mon, 16 Nov 2015 12:06:11 -0400 concurrent-output (1.7.0) unstable; urgency=medium * Simplified the RegionContent type; a region's content is now internally always an STM action. * This simplification fixed a bug that had prevented sometimes displaying changes to InLine regions with STM actions for content. Now any changes to TVars etc accessed by such STM actions will be noticed when waiting on the parent region's content changing. * Fix bug that caused double display of children of regions in some circumstances. -- Joey Hess Mon, 09 Nov 2015 16:13:19 -0400 concurrent-output (1.6.1) unstable; urgency=medium * Avoid cursorUpLine, which is not as portable as cursorUp. This fixes display on such systems as MS-DOS with ANSI.SYS, and OSX. -- Joey Hess Sun, 08 Nov 2015 17:56:43 -0400 concurrent-output (1.6.0) unstable; urgency=medium * Generalized newConsoleRegion. * Better efficiency when there are more regions than will fit on the screen. * Fixed consoleHeight (was returning width) * Fix outputBufferWaiterSTM which never returned any buffered stderr, and fix regional display of buffered error messages. * Ported to Windows, although createProcessConcurrent is omitted due to needing support for pipe(), and consoleSize is not updated by resize. * Stopped exporting consoleSize; use consoleWidth and consoleHeight instead. -- Joey Hess Thu, 05 Nov 2015 15:35:16 -0400 concurrent-output (1.5.0) unstable; urgency=medium * Added errorConcurrent. * Added getRegionContent. -- Joey Hess Wed, 04 Nov 2015 17:20:44 -0400 concurrent-output (1.4.0) unstable; urgency=medium * Renamed many of the functions and types. * Added tuneDisplay, which makes it easy to size-limit regions, right-justify regions, or otherwise transform how their values are displayed. -- Joey Hess Wed, 04 Nov 2015 00:32:38 -0400 concurrent-output (1.3.0) unstable; urgency=medium * The contents of a Region can now be set to a STM Text transaction. Their display will be automatically updated whenever the transaction's value changes. * Removed updateRegionListSTM, and export regionList instead, which is more general-purpose. * Other improvements to STM interface. -- Joey Hess Tue, 03 Nov 2015 15:50:47 -0400 concurrent-output (1.2.0) unstable; urgency=medium * Avoid crash when not all of a program's output is consumed, as happens when eg, piping to head(1). * Use text, and not bytestring internally. * Added createProcessForeground, useful for running commands like vim. * Fix race that sometimes caused processes to run in background mode even though no other foreground process was still running. * Concurrent process functions now use ConcurrentProcessHandle instead of ProcessHandle. * Multi-line regions now supported. * Optimize region update, avoiding outputting characters already on-screen. -- Joey Hess Mon, 02 Nov 2015 23:25:40 -0400 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. * Dropped dependency on MissingH; added dependency on text. -- Joey Hess Thu, 29 Oct 2015 00:47:12 -0400 concurrent-output (1.0.0) unstable; urgency=medium * First release. -- Joey Hess Wed, 28 Oct 2015 21:01:23 -0400 concurrent-output-1.10.21/LICENSE0000644000000000000000000000243407346545000014575 0ustar0000000000000000Copyright © 2015-2017 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 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. THIS SOFTWARE IS PROVIDED BY AUTHORS 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 AUTHORS 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. concurrent-output-1.10.21/Setup.hs0000644000000000000000000000010707346545000015217 0ustar0000000000000000{- cabal setup file -} import Distribution.Simple main = defaultMain concurrent-output-1.10.21/System/Console/0000755000000000000000000000000007346545000016453 5ustar0000000000000000concurrent-output-1.10.21/System/Console/Concurrent.hs0000644000000000000000000000161207346545000021131 0ustar0000000000000000-- | -- Copyright: 2015 Joey Hess -- License: BSD-2-clause -- -- Concurrent output handling. -- -- > import Control.Concurrent.Async -- > import System.Console.Concurrent -- > -- > main = withConcurrentOutput $ do -- > outputConcurrent "washed the car\n" -- > `concurrently` -- > outputConcurrent "walked the dog\n" -- > `concurrently` -- > createProcessConcurrent (proc "ls" []) module System.Console.Concurrent ( -- * Concurrent output withConcurrentOutput, Outputable(..), outputConcurrent, errorConcurrent, createProcessConcurrent, createProcessForeground, flushConcurrentOutput, lockOutput, ConcurrentProcessHandle, waitForProcessConcurrent, -- * Low level access to the output buffer OutputBuffer, StdHandle(..), bufferOutputSTM, outputBufferWaiterSTM, waitAnyBuffer, waitCompleteLines, emitOutputBuffer, ) where import System.Console.Concurrent.Internal concurrent-output-1.10.21/System/Console/Concurrent/0000755000000000000000000000000007346545000020575 5ustar0000000000000000concurrent-output-1.10.21/System/Console/Concurrent/Internal.hs0000644000000000000000000004047107346545000022713 0ustar0000000000000000{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances, TupleSections #-} {-# OPTIONS_GHC -O2 #-} {- Building this module with -O0 causes streams not to fuse and too much - memory to be used. -} -- | -- Copyright: 2015 Joey Hess -- License: BSD-2-clause -- -- Concurrent output handling, internals. -- -- May change at any time. module System.Console.Concurrent.Internal where import System.IO import System.Directory import System.Exit import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) 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.Text as T import qualified Data.Text.IO as T import qualified Data.Text.Lazy as L import Control.Applicative import Prelude 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`, unless -- `System.Console.Regions.displayConsoleRegions` is being used. -- -- 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. Also blocks while -- `lockOutput` is is use. -- -- `withConcurrentOutput` calls this at the end, so you do not normally -- need to use this. flushConcurrentOutput :: IO () flushConcurrentOutput = do atomically $ do r <- takeTMVar (outputThreads globalOutputHandle) if r <= 0 then putTMVar (outputThreads globalOutputHandle) r else retry -- Take output lock to wait for anything else that might be -- currently generating output. lockOutput $ return () -- | Values that can be output. class Outputable v where toOutput :: v -> T.Text instance Outputable T.Text where toOutput = id -- | Note that using a lazy Text as an Outputable value -- will buffer it all in memory. instance Outputable L.Text where toOutput = toOutput . L.toStrict instance Outputable String where toOutput = toOutput . T.pack -- | Displays a value to stdout. -- -- Uses locking to ensure that the whole output occurs atomically -- even when other threads are concurrently generating output. -- -- No newline is appended to the value, so if you want a newline, be sure -- to include it yourself. -- -- 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. -- -- When outputConcurrent is used within a call to -- `System.Console.Regions.displayConsoleRegions`, the output is displayed -- above the currently open console regions. Only lines ending in a newline -- are displayed in this case (it uses `waitCompleteLines`). outputConcurrent :: Outputable v => v -> IO () outputConcurrent = outputConcurrent' StdOut -- | Like `outputConcurrent`, but displays to stderr. -- -- (Does not throw an exception.) errorConcurrent :: Outputable v => v -> IO () errorConcurrent = outputConcurrent' StdErr outputConcurrent' :: Outputable v => StdHandle -> v -> IO () outputConcurrent' stdh v = do -- Use a worker thread. This is so any async exception that -- is thrown to the current thread does not affect -- tryTakeOutputLock, which is not async exception safe. worker <- async $ bracket setup cleanup go wait worker where setup = tryTakeOutputLock cleanup False = return () cleanup True = dropOutputLock go True = do T.hPutStr h (toOutput v) hFlush h go False = do oldbuf <- atomically $ takeTMVar bv newbuf <- addOutputBuffer (Output (toOutput v)) oldbuf atomically $ putTMVar bv newbuf h = toHandle stdh bv = bufferFor stdh -- | This alias is provided to avoid breaking backwards compatibility. type ConcurrentProcessHandle = P.ProcessHandle -- | Same as `P.waitForProcess`; provided to avoid breaking backwards -- compatibility. waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode waitForProcessConcurrent = P.waitForProcess -- | 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. -- -- Note that the the process is waited for by a background thread, -- so unlike createProcess, neglecting to call waitForProcess will not -- result in zombie processess. 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 ( fgProcess p , bgProcess p ) | otherwise = do r@(_, _, _, h) <- P.createProcess p _ <- async $ void $ tryIO $ P.waitForProcess h return r -- | Wrapper around `System.Process.createProcess` that makes sure a process -- is run in the foreground, with direct access to stdout and stderr. -- Useful when eg, running an interactive process. -- -- Note that the the process is waited for by a background thread, -- so unlike createProcess, neglecting to call waitForProcess will not -- result in zombie processess. createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) createProcessForeground p = do takeOutputLock fgProcess p fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) fgProcess p = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock registerOutputThread -- Wait for the process to exit and drop the lock. _ <- async $ do void $ tryIO $ P.waitForProcess h unregisterOutputThread dropOutputLock return r bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) bgProcess p = do let p' = p { P.std_out = rediroutput (P.std_out p) , P.std_err = rediroutput (P.std_err p) } registerOutputThread (stdin_h, stdout_h, stderr_h, h) <- P.createProcess p' `onException` unregisterOutputThread let r = ( stdin_h , mungeret (P.std_out p) stdout_h , mungeret (P.std_err p) stderr_h , h ) -- Wait for the process for symmetry with fgProcess, -- which does the same. _ <- async $ void $ tryIO $ P.waitForProcess h outbuf <- setupOutputBuffer StdOut (mungebuf (P.std_out p) stdout_h) errbuf <- setupOutputBuffer StdErr (mungebuf (P.std_err p) stderr_h) void $ async $ bufferWriter [outbuf, errbuf] return r where rediroutput ss | willOutput ss = P.CreatePipe | otherwise = ss mungebuf ss mh | willOutput ss = mh | otherwise = Nothing mungeret ss mh | willOutput ss = Nothing | otherwise = mh 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 T.Text | InTempFile { tempFile :: FilePath , endsInNewLine :: Bool } deriving (Eq) data AtEnd = AtEnd deriving Eq data BufSig = BufSig setupOutputBuffer :: StdHandle -> Maybe Handle -> IO (StdHandle, MVar OutputBuffer, TMVar BufSig, TMVar AtEnd) setupOutputBuffer h fromh = do buf <- newMVar (OutputBuffer []) bufsig <- atomically newEmptyTMVar bufend <- atomically newEmptyTMVar void $ async $ outputDrainer fromh buf bufsig bufend return (h, buf, bufsig, bufend) -- Drain output from the handle, and buffer it. outputDrainer :: Maybe Handle -> MVar OutputBuffer -> TMVar BufSig -> TMVar AtEnd -> IO () outputDrainer mfromh buf bufsig bufend = case mfromh of Nothing -> atend Just fromh -> go fromh where go fromh = do t <- T.hGetChunk fromh if T.null t then do atend hClose fromh else do modifyMVar_ buf $ addOutputBuffer (Output t) changed go fromh atend = atomically $ putTMVar bufend AtEnd changed = atomically $ do void $ tryTakeTMVar bufsig putTMVar bufsig BufSig registerOutputThread :: IO () registerOutputThread = do let v = outputThreads globalOutputHandle atomically $ putTMVar v . succ =<< takeTMVar v unregisterOutputThread :: IO () unregisterOutputThread = do 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 worker1 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 worker1 = 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 -- worker1 might be blocked waiting for the output -- lock, and we've already done its job, so cancel it cancel worker1 -- 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 t) (OutputBuffer buf) | T.length t' <= 1048576 = return $ OutputBuffer (Output t' : other) | otherwise = do tmpdir <- getTemporaryDirectory (tmp, h) <- openTempFile tmpdir "output.tmp" let !endnl = endsNewLine t' let i = InTempFile { tempFile = tmp , endsInNewLine = endnl } T.hPutStr h t' hClose h return $ OutputBuffer (i : other) where !t' = T.concat (mapMaybe getOutput this) <> t !(this, other) = partition isOutput buf isOutput v = case v of Output _ -> True _ -> False getOutput v = case v of Output t'' -> Just t'' _ -> 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 = waitgetbuf StdOut `orElse` waitgetbuf StdErr where waitgetbuf h = do let bv = bufferFor h (selected, rest) <- selector <$> takeTMVar bv when (selected == OutputBuffer []) retry putTMVar bv rest return (h, selected) 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 :: T.Text -> Bool endsNewLine t = not (T.null t) && T.last t == '\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 t -> emit t InTempFile tmp _ -> do emit =<< T.readFile tmp void $ tryWhenExists $ removeFile tmp where outh = toHandle stdh emit t = void $ tryIO $ do T.hPutStr outh t hFlush outh concurrent-output-1.10.21/System/Console/Regions.hs0000644000000000000000000007441007346545000020423 0ustar0000000000000000{-# LANGUAGE BangPatterns, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -O2 #-} {- This module does a lot of calculation that can be expensive, so optimise - it well -} -- | -- Copyright: 2015 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 lines 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 -- > import System.Process -- > -- > main = displayConsoleRegions $ do -- > mapConcurrently download [1..5] -- > `concurrently` mapM_ message [1..10] -- > `concurrently` createProcessConcurrent (proc "echo" ["hello world"]) -- > -- > 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 -- > hello world -- > 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 -- > hello world -- > Message 2 -- > Download 1 done! -- > Message 3 -- > Download 2 ... ... -- > Download 3 ... ... module System.Console.Regions ( -- * Types ConsoleRegion, RegionLayout(..), ToRegionContent(..), RegionContent(..), LiftRegion(..), -- * Initialization displayConsoleRegions, withConsoleRegion, openConsoleRegion, newConsoleRegion, closeConsoleRegion, -- * Region content and display setConsoleRegion, appendConsoleRegion, finishConsoleRegion, getConsoleRegion, tuneDisplay, -- * STM region contents -- -- | The `ToRegionContent` instance for `STM` `Text` can be used to -- make regions that automatically update whenever there's -- a change to any of the STM values that they use. -- -- For example, a region that displays the screen size, -- and automatically refreshes it: -- -- > import qualified Data.Text as T -- -- > r <- openConsoleRegion Linear s -- > setConsoleRegion r $ do -- > w <- readTVar consoleWidth -- > h <- readTVar consoleHeight -- > return $ T.pack $ unwords -- > [ "size:" -- > , show w -- > , "x" -- > , show h -- > ] -- > consoleWidth, consoleHeight, regionList, waitDisplayChange, ) where import Data.Monoid import Data.String import Data.Char import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.IO as T import Data.Text (Text) import Control.Monad 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 System.IO import System.IO.Unsafe (unsafePerformIO) import Text.Read import Data.List (intercalate, nubBy) import Control.Applicative import Prelude #ifdef VERSION_terminal_size import qualified System.Console.Terminal.Size as Console #ifndef mingw32_HOST_OS import System.Posix.Signals import System.Posix.Signals.Exts #endif #endif 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. -- Each sequence of the same letter represents a distinct region. -- -- > scrolling...... -- > scrolling...... -- > scrolling...... -- > aaaaaa......... -- Linear -- > bbbbbbbbbbbbbbb -- Linear -- > bbb............ (expanded to multiple lines) -- > ccccccccc...... -- Linear -- > ddddeeeefffffff -- [InLine] -- > fffffggggg..... (expanded to multiple lines) -- > data RegionLayout = Linear | InLine ConsoleRegion deriving (Eq) -- | A handle allowing access to a region of the console. newtype ConsoleRegion = ConsoleRegion (TVar R) deriving (Eq) data R = R { regionContent :: RegionContent , regionRender :: (Text -> STM Text) , regionLayout :: RegionLayout , regionChildren :: TVar [ConsoleRegion] } newtype RegionContent = RegionContent (STM Text) -- | All the regions that are currently displayed on the screen. -- -- 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. {-# NOINLINE regionList #-} regionList :: TMVar [ConsoleRegion] regionList = unsafePerformIO newEmptyTMVarIO data ConsoleSize = ConsoleSize { _consoleHeight :: Int , _consoleWidth :: Int } {-# NOINLINE consoleSize #-} consoleSize :: TVar ConsoleSize consoleSize = unsafePerformIO $ newTVarIO $ ConsoleSize { _consoleWidth = 80, _consoleHeight = 25} type Width = Int -- | Gets the width of the console. -- -- On Unix, this is automatically updated when the terminal is resized. -- On Windows, it is determined at start. On WASM, -- the console width is hard coded to 80 since WASI does not provide a way -- to determine it. consoleWidth :: STM Int consoleWidth = munge . _consoleWidth <$> readTVar consoleSize where #ifndef mingw32_HOST_OS munge = id #else -- On Windows, writing to the right-most column caused some -- problimatic wrap, so avoid it. munge = pred #endif -- | Get the height of the console. -- -- On Unix, this is automatically updated when the terminal is resized. -- On Windows, it is determined at start. On WASM, -- the console heigth is hard coded to 25 since WASI does not provide a way -- to determine it. consoleHeight :: STM Int consoleHeight = _consoleHeight <$> readTVar consoleSize -- | Check if `displayConsoleRegions` is running. regionDisplayEnabled :: IO Bool regionDisplayEnabled = atomically $ not <$> isEmptyTMVar regionList -- | Many actions in this module can be run in either the IO monad -- or the STM monad. Using STM allows making several changes to the -- displayed regions atomically, with the display updated a single time. class LiftRegion m where liftRegion :: STM a -> m a instance LiftRegion STM where liftRegion = id instance LiftRegion IO where liftRegion = atomically -- | Values that can be displayed in a region. class ToRegionContent v where toRegionContent :: v -> RegionContent instance ToRegionContent String where toRegionContent = fromOutput instance ToRegionContent Text where toRegionContent = fromOutput -- | Note that using a lazy Text in a region will buffer it all in memory. instance ToRegionContent L.Text where toRegionContent = fromOutput fromOutput :: Outputable v => v -> RegionContent fromOutput = RegionContent . pure . toOutput -- | Makes a STM action be run to get the content of a region. -- -- Any change to the values that action reads will result in an immediate -- refresh of the display. instance ToRegionContent (STM Text) where toRegionContent = RegionContent -- | Sets the value of a console region. This will cause the -- console to be updated to display the new value. -- -- It's fine for the value to be longer than the terminal is wide, -- or to include newlines ('\n'). Regions expand to multiple lines as -- necessary. -- -- The value can include ANSI SGR escape sequences for changing -- the colors of all or part of a region. For this to display properly, -- a reset escape sequence must be included to get the color back -- to default. System.Console.ANSI makes it easy to construct such -- values. For example: -- -- > import System.Console.ANSI -- > -- > setConsoleRegion region -- > ( "hello " -- > <> setSGRCode [SetColor Foreground Vivid Red] -- > <> "Mars" -- > <> setSGRCode [Reset] -- > <> "!" -- > ) -- -- Other ANSI escape sequences, especially those doing cursor -- movement, will mess up the layouts of regions. Caveat emptor. -- -- ANSI SGR escape sequences that span multiple lines do not currently -- display as you might hope. (Patches would be accepted.) setConsoleRegion :: (ToRegionContent v, LiftRegion m) => ConsoleRegion -> v -> m () setConsoleRegion r v = liftRegion $ modifyRegion r $ const $ pure $ toRegionContent v -- | Appends a value to the current value of a console region. -- -- > appendConsoleRegion progress "." -- add another dot to progress display appendConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m () appendConsoleRegion r v = liftRegion $ modifyRegion r $ \(RegionContent a) -> return $ RegionContent $ do t <- a return (t <> toOutput v) modifyRegion :: ConsoleRegion -> (RegionContent -> STM RegionContent) -> STM () modifyRegion (ConsoleRegion tv) f = do r <- readTVar tv rc <- f (regionContent r) let r' = r { regionContent = rc } writeTVar tv r' readRegionContent :: RegionContent -> STM Text readRegionContent (RegionContent a) = a resizeRegion :: Width -> ConsoleRegion -> STM [Text] resizeRegion width (ConsoleRegion tv) = do r <- readTVar tv ls <- calcRegionLines r width return ls -- | Runs the action with a new console region, closing the region when -- the action finishes or on exception. withConsoleRegion :: (MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegion -> m a) -> m a withConsoleRegion ly = bracketIO (openConsoleRegion ly) (uninterruptibleMask_ . closeConsoleRegion) -- | Opens a new console region. openConsoleRegion :: LiftRegion m => RegionLayout -> m ConsoleRegion openConsoleRegion ly = liftRegion $ do h <- newConsoleRegion ly T.empty case ly of Linear -> do ml <- tryTakeTMVar regionList case ml of Just l -> 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 -- | Makes a new region, but does not add it to the display. newConsoleRegion :: (LiftRegion m) => ToRegionContent v => RegionLayout -> v -> m ConsoleRegion newConsoleRegion ly v = liftRegion $ do cs <- newTVar mempty let r = R { regionContent = RegionContent $ return mempty , regionRender = pure , regionLayout = ly , regionChildren = cs } h <- ConsoleRegion <$> newTVar r displayChildren h setConsoleRegion h v return h displayChildren :: ConsoleRegion -> STM () displayChildren p@(ConsoleRegion tv) = tuneDisplay p $ \t -> do children <- readTVar . regionChildren =<< readTVar tv ct <- T.concat <$> mapM getc children return $ t <> ct where getc (ConsoleRegion cv) = do c <- readTVar cv regionRender c =<< readRegionContent (regionContent c) -- | Closes a console region. Once closed, the region is removed from the -- display. closeConsoleRegion :: LiftRegion m => ConsoleRegion -> m () closeConsoleRegion h@(ConsoleRegion tv) = liftRegion $ 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. When Nothing is passed, -- displays the current value of the console region. finishConsoleRegion :: (Outputable v, LiftRegion m) => ConsoleRegion -> v -> m () finishConsoleRegion h v = liftRegion $ do closeConsoleRegion h bufferOutputSTM StdOut (toOutput v <> fromString "\n") -- | Gets the current content of a console region. getConsoleRegion :: LiftRegion m => ConsoleRegion -> m Text getConsoleRegion (ConsoleRegion tv) = liftRegion $ readRegionContent . regionContent =<< readTVar tv -- | Changes how a console region displays. -- -- Each time the region's value changes, the STM action is provided -- with the current value of the region, and returns the value to display. -- -- For example, this will prevent a region from ever displaying more -- than 10 characters wide, and will make it display text reversed: -- -- > tuneDisplay myregion $ pure . T.take 10 -- > tuneDisplay myregion $ pure . T.reverse -- -- Note that repeated calls to tuneDisplay are cumulative. -- -- Normally, the STM action should avoid retrying, as that would -- block all display updates. tuneDisplay :: LiftRegion m => ConsoleRegion -> (Text -> STM Text) -> m () tuneDisplay (ConsoleRegion tv) renderer = liftRegion $ do r <- readTVar tv let rr = \t -> renderer =<< regionRender r t let r' = r { regionRender = rr } writeTVar tv r' addChild :: ConsoleRegion -> ConsoleRegion -> STM () addChild child _parent@(ConsoleRegion pv) = do cv <- regionChildren <$> readTVar pv children <- readTVar cv let !children' = filter (/= child) children ++ [child] writeTVar cv children' removeChild :: ConsoleRegion -> ConsoleRegion -> STM () removeChild child _parent@(ConsoleRegion pv) = do cv <- regionChildren <$> readTVar pv modifyTVar' cv (filter (/= child)) -- | 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`. So, -- `withConcurrentOutput` and `flushConcurrentOutput` should not be run -- while this is in use, and will block. -- -- 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 $ uninterruptibleMask $ \unmask -> do atomically $ putTMVar regionList [] endsignal <- atomically $ do s <- newTSem 1 waitTSem s return s isterm <- liftIO $ hSupportsANSI stdout when isterm (unmask trackConsoleWidth) da <- async $ unmask $ displayThread isterm endsignal return (isterm, da, endsignal) cleanup (isterm, da, endsignal) = liftIO $ uninterruptibleMask_ $ do atomically $ signalTSem endsignal void $ wait da void $ atomically $ takeTMVar regionList when isterm $ installResizeHandler Nothing trackConsoleWidth :: IO () #ifdef VERSION_terminal_size trackConsoleWidth = do let getsz = maybe noop (atomically . writeTVar consoleSize . conv) =<< Console.size getsz installResizeHandler (Just getsz) where conv wsz = ConsoleSize { _consoleWidth = Console.width wsz , _consoleHeight = Console.height wsz } #else trackConsoleWidth = return () #endif data DisplayChange = BufferChange BufferSnapshot | RegionChange RegionSnapshot | RegionListChange RegionSnapshot | TerminalResize Width | Shutdown | DisplayChangeBarrier Barrier type BufferSnapshot = (StdHandle, OutputBuffer) type RegionSnapshot = ([ConsoleRegion], [R], [[Text]]) type Barrier = Integer -- | This is a broadcast TChan, which gets a DisplayChange written to it -- after the display has been updated. It can be used to wait for something -- to be displayed. {-# NOINLINE displayUpdateNotifier #-} displayUpdateNotifier :: TChan DisplayChange displayUpdateNotifier = unsafePerformIO $ newBroadcastTChanIO {-# NOINLINE displayChangeBarrier #-} displayChangeBarrier :: TVar Barrier displayChangeBarrier = unsafePerformIO $ newTVarIO 0 -- | Runs a STM action, and waits for the display to be fully updated -- with any changes that action makes to the displayed regions. waitDisplayChange :: STM a -> IO a waitDisplayChange a = do c <- atomically $ dupTChan displayUpdateNotifier bv <- newEmptyTMVarIO _ <- setbarrier bv `concurrently` waitchange c bv snd <$> atomically (readTMVar bv) where setbarrier bv = atomically $ do !b <- succ <$> readTVar displayChangeBarrier r <- a writeTVar displayChangeBarrier b putTMVar bv (b, r) waitchange c bv = do change <- atomically $ readTChan c -- this blocks until the STM action has run, and the -- barrier is set. b <- fst <$> atomically (readTMVar bv) case change of DisplayChangeBarrier b' | b' >= b -> return () _ -> waitchange c bv displayThread :: Bool -> TSem -> IO () displayThread isterm endsignal = do origwidth <- atomically consoleWidth origbarrier <- atomically (readTVar displayChangeBarrier) go ([], [], []) origwidth origbarrier where go origsnapshot@(orighandles, origregions, origlines) origwidth origbarrier = do let waitwidthchange = do w <- consoleWidth if w == origwidth then retry else return w let waitbarrierchange = do b <- readTVar displayChangeBarrier if b /= origbarrier then return b else retry let waitanychange = (RegionChange <$> regionWaiter origsnapshot origwidth) `orElse` (RegionListChange <$> regionListWaiter origsnapshot) `orElse` (BufferChange <$> outputBufferWaiterSTM waitCompleteLines) `orElse` (TerminalResize <$> waitwidthchange) `orElse` (waitTSem endsignal >> pure Shutdown) `orElse` -- Must come last, so the changes above are -- processed before barriers. (DisplayChangeBarrier <$> waitbarrierchange) (change, height) <- atomically $ (,) <$> waitanychange <*> consoleHeight let onscreen = take (height - 1) . concat let update snapshot@(_, _, newlines) = do when isterm $ changedLines (onscreen origlines) (onscreen newlines) return $ go snapshot origwidth origbarrier next <- case change of RegionChange snapshot -> update snapshot RegionListChange snapshot -> update snapshot BufferChange (h, buf) -> do -- Note that even when every available line -- is dedicated to visible regions, the -- buffer is still displayed. It would be -- more efficient to not display it, but -- this makes it available in scroll back. let origlines' = onscreen origlines inAreaAbove isterm (length origlines') origlines' $ emitOutputBuffer h buf return $ go origsnapshot origwidth origbarrier TerminalResize newwidth -> do newlines <- atomically (mapM (resizeRegion newwidth) orighandles) when isterm $ do resizeRecovery (onscreen newlines) return $ go (orighandles, origregions, newlines) newwidth origbarrier Shutdown -> return $ return () DisplayChangeBarrier b -> return $ go origsnapshot origwidth b hFlush stdout atomically $ writeTChan displayUpdateNotifier change next readRegions :: [ConsoleRegion] -> STM [R] readRegions = mapM (\(ConsoleRegion h) -> readTVar h) -- | Wait for any changes to the region list, eg adding or removing a region. regionListWaiter :: RegionSnapshot -> STM RegionSnapshot regionListWaiter (orighandles, _origregions, origlines) = do handles <- readTMVar regionList if handles == orighandles then retry else do rs <- readRegions handles return (handles, rs, origlines) -- Wait for any changes to any of the contents of regions currently in the -- region list. regionWaiter :: RegionSnapshot -> Width -> STM RegionSnapshot regionWaiter (orighandles, _origregions, origlines) width = do rs <- readRegions orighandles newlines <- mapM getr rs unless (newlines /= origlines) retry return (orighandles, rs, newlines) where getr r = calcRegionLines r width -- This is not an optimal screen update like curses can do, but it's -- pretty efficient, most of the time! changedLines :: [Text] -> [Text] -> IO () changedLines origlines newlines | delta == 0 = do -- The total number of lines is unchanged, so update -- whichever ones have changed, and leave the rest as-is. diffUpdate origlines newlines | delta > 0 = do -- Added more lines, so output each, with a -- newline, thus scrolling the old lines up -- the screen. (We can do this, because the cursor -- is left below the first line.) let addedlines = reverse (take delta newlines) displayLines addedlines -- Some existing lines may have also changed.. let scrolledlines = addedlines ++ origlines diffUpdate scrolledlines newlines | otherwise = do -- Some lines were removed. Move up that many lines, -- clearing each line, and update any changed lines. replicateM_ (abs delta) $ do setCursorColumn 0 cursorUp 1 clearLine diffUpdate (drop (abs delta) origlines) newlines where delta = length newlines - length origlines diffUpdate :: [Text] -> [Text] -> IO () diffUpdate old new = updateLines (zip (zip new changed) old) where changed = map (uncurry (/=)) (zip new old) ++ repeat True changeOffsets :: [((r, Bool), r)] -> Int -> [((r, Int), r)] -> [((r, Int), r)] changeOffsets [] _ c = reverse c changeOffsets (((new, changed), old):rs) n c | changed = changeOffsets rs 1 (((new, n), old):c) | otherwise = changeOffsets rs (succ n) c -- Displays lines that are paired with True, and skips over the rest. -- Cursor is assumed to be just below the first line at the -- beginning, and is put back there at the end. updateLines :: [((Text, Bool), Text)] -> IO () updateLines l | null l' = noop | otherwise = do forM_ l' $ \((newt, offset), oldt) -> do setCursorColumn 0 cursorUp offset #ifndef mingw32_HOST_OS T.hPutStr stdout $ genLineUpdate $ calcLineUpdate oldt newt #else -- Windows does not support ansi characters -- emitted in a string, so do a full line -- redraw. T.hPutStr stdout newt clearFromCursorToLineEnd #endif cursorDown (sum (map (snd . fst) l')) setCursorColumn 0 where l' = changeOffsets l 1 [] -- Recover from a resize by redrawing all region lines. -- -- The resize can change the position of the cursor, which would garble -- the display going forward. To fix, the cursor is moved to the top of -- the screen, which is cleared, and all regions are redrawn from there. resizeRecovery :: [Text] -> IO () resizeRecovery newlines = do setCursorPosition 0 0 inAreaAbove True 0 newlines $ return () -- Move cursor up before the lines, performs some output there, -- which will scroll down and overwrite the lines, so -- redraws all the lines below. inAreaAbove :: Bool -> Int -> [Text] -> IO () -> IO () inAreaAbove isterm numlines ls outputter = do when isterm $ do unless (numlines < 1) $ do setCursorColumn 0 cursorUp $ numlines clearFromCursorToScreenEnd -- Flush stdout now, because the outputter may write to stderr, so -- the cursor needs to be moved first. hFlush stdout outputter when isterm $ do setCursorColumn 0 -- just in case the output lacked a newline displayLines (reverse ls) displayLines :: [Text] -> IO () displayLines = mapM_ $ \l -> do T.hPutStr stdout l putChar '\n' installResizeHandler :: Maybe (IO ()) -> IO () #ifndef mingw32_HOST_OS #ifdef VERSION_terminal_size installResizeHandler h = void $ installHandler windowChange (maybe Default Catch h) Nothing #else installResizeHandler _ = return () #endif #else installResizeHandler _ = return () #endif calcRegionLines :: R -> Width -> STM [Text] calcRegionLines r width = do t <- regionRender r =<< readRegionContent (regionContent r) return $ reverse $ calcLines t width -- | Splits a Text into the lines it would display using when output onto -- a console with a given width, starting from the first column. -- -- ANSI SGR sequences are handled specially, so that color, etc settings -- work despite the lines being split up, and the lines can be output -- indepedently. For example, "foooREDbar bazRESET" when split into lines -- becomes ["fooREDbarRESET", "RED bazRESET"] calcLines :: Text -> Width -> [Text] calcLines t width | width < 1 || T.null t = [t] -- even an empty text is 1 line high | otherwise = calcLines' width [] [] 0 1 (T.length t) t calcLines' :: Int -> [Text] -> [Text] -> Int -> Int -> Int -> Text -> [Text] calcLines' width collectedlines collectedSGR i displaysize len t | i >= len = if i > 0 then reverse (finishline t) else reverse collectedlines | t1 == '\n' = calcLines' width (finishline $ T.init currline) [] 0 1 (T.length rest) (contSGR rest) -- ANSI escape sequences do not take up space on screen. | t1 == '\ESC' && i+1 < len = case T.index t (i+1) of '[' -> skipansi endCSI True ']' -> skipansi endOSC False _ -> calcLines' width collectedlines collectedSGR (i+1) displaysize len t -- Control characters do not take up space on screen. | isControl t1 = calcLines' width collectedlines collectedSGR (i+1) displaysize len t | displaysize >= width = calcLines' width (finishline currline) [] 0 1 (T.length rest) (contSGR rest) | otherwise = calcLines' width collectedlines collectedSGR (i+1) (displaysize+1) len t where t1 = T.index t i (currline, rest) = T.splitAt (i+1) t skipansi toend isCSI = case T.findIndex toend (T.drop (i+2) t) of Just csiend -> calcLines' width collectedlines (addSGR (csiend+2)) (i+2+csiend) (displaysize-1) len t Nothing -> reverse (finishline t) where addSGR csiend | not isCSI = collectedSGR | ansicode == resetSGR = [] | not (T.null ansicode) && T.last ansicode == endSGR = ansicode : collectedSGR | otherwise = collectedSGR where ansicode = T.take (csiend + 1) (T.drop i t) finishline l = closeSGR l : collectedlines -- Close any open SGR codes at end of line closeSGR l | null collectedSGR = l | otherwise = l <> resetSGR -- Continue any open SGR codes from previous line contSGR l = mconcat (reverse collectedSGR) <> l resetSGR :: Text resetSGR = T.pack (setSGRCode [Reset]) endCSI :: Char -> Bool endCSI c = let o = ord c in o >= 64 && o < 127 endOSC :: Char -> Bool endOSC c = c == '\BEL' endSGR :: Char endSGR = 'm' #ifndef mingw32_HOST_OS -- | Finds the least expensive output to make a console that was displaying -- the old line display the new line. Cursor starts at far left. -- -- Basically, loop through and find spans where the old and new line are -- the same. Generate cursorForwardCode ANSI sequences to skip over those -- spans, unless such a sequence would be longer than the span it's skipping. -- -- Since ANSI sequences can be present in the line, need to take them -- into account. Generally, each of the sequences in new has to be included, -- even if old contained the same sequence: -- -- > old: GREENfoofoofooREDbarbarbarRESETbaz -- > new: GREENfoofoofooREDxarbarbaxRESETbaz -- > ret: GREEN-------->REDx------>yRESET -- -- (The first GREEN does not effect any output text, so it can be elided.) -- -- Also, despite old having the same second span as new, in the same -- location, that span has to be re-emitted because its color changed: -- -- > old: GREENfoofooREDbarbarbarbarbar -- > new: GREENfoofoofooTANbarbarbar -- > ret: GREEN----->fooTANbarbarbarCLEARREST -- -- Also note above that the sequence has to clear the rest of the line, -- since the new line is shorter than the old. calcLineUpdate :: Text -> Text -> [LineUpdate] calcLineUpdate old new = reverse $ go (advanceLine old [] []) (advanceLine new [] []) where go (Just _, _, _, _) (Nothing, _, past, _) = ClearToEnd : past go (Nothing, _, _, _) (Nothing, _, past, _) = past go (Nothing, _, _, _) (Just n, ns, past, _) = Display ns : Display (T.singleton n) : past go (Just o, os, _, oinvis) (Just n, ns, past, ninvis) | o == n && oinvis == ninvis = go (advanceLine os [] oinvis) (advanceLine ns (Skip [o] : past) ninvis) | otherwise = go (advanceLine os [] oinvis) (advanceLine ns (Display (T.singleton n) : past) ninvis) type Past = [LineUpdate] type Invis = [LineUpdate] -- Find next character of t that is not a ANSI escape sequence -- or control char. Any such passed on the way to the character -- are prepended to past, and added to invis. -- -- resetSGR is handled specially; it causes all SGRs to be removed from -- invis, It's still prepended to past. advanceLine :: Text -> Past -> Invis -> (Maybe Char, Text, Past, Invis) advanceLine t past invis | T.null t = (Nothing, T.empty, past, invis) | otherwise = case T.head t of '\ESC' -> case T.drop 1 t of t' | T.null t' -> advanceLine (T.drop 1 t) (Skip "\ESC":past) (Skip "\ESC":invis) | otherwise -> case T.head t' of '[' -> skipansi endCSI ']' -> skipansi endOSC c -> (Just c, T.drop 2 t, Skip "\ESC":past, Skip "\ESC":invis) c | isControl c -> advanceLine (T.drop 1 t) (Skip [c]:past) (Skip [c]:invis) | otherwise -> (Just c, T.drop 1 t, past, invis) where skipansi toend = case T.findIndex toend (T.drop 2 t) of Just csiend -> let sgr = SGR (T.take (csiend+3) t) in advanceLine (T.drop (csiend+3) t) (sgr:past) (addsgr sgr invis) Nothing -> (Nothing, T.empty, past, invis) addsgr (SGR sgrt) l | sgrt == resetSGR = filter (not . isSGR) l addsgr s l = s:l data LineUpdate = Display Text | Skip [Char] | SGR Text | ClearToEnd deriving (Eq, Show) isSGR :: LineUpdate -> Bool isSGR (SGR _) = True isSGR _ = False genLineUpdate :: [LineUpdate] -> Text genLineUpdate l = T.concat $ map tot (optimiseLineUpdate l) where tot (Display t) = t tot (Skip s) -- length (cursorForwardCode 1) == 4 so there's no point -- generating that for a skip of less than 5. | len < 5 = T.pack s | otherwise = T.pack (cursorForwardCode len) where len = length s tot (SGR t) = t tot ClearToEnd = T.pack clearFromCursorToLineEndCode optimiseLineUpdate :: [LineUpdate] -> [LineUpdate] optimiseLineUpdate = go [] where -- elide trailing Skips go (Skip _:rest) [] = go rest [] -- elide SGRs at the end of the line, except for the reset SGR go (SGR t:rest) [] | t /= resetSGR = go rest [] go c [] = reverse c -- combine adjacent SGRs and Skips go c (SGR t1:Skip s:SGR t2:rest) = tryharder c (SGR (combineSGR t1 t2):Skip s:rest) go c (Skip s:Skip s':rest) = tryharder c (Skip (s++s'):rest) go c (SGR t1:SGR t2:rest) = tryharder c (SGR (combineSGR t1 t2):rest) go c (v:rest) = go (v:c) rest tryharder c l = go [] (reverse c ++ l) -- Parse and combine 2 ANSI SGR sequences into one. combineSGR :: Text -> Text -> Text combineSGR a b = case combineSGRCodes (codes a) (codes b) of Nothing -> a <> b Just cs -> T.pack $ "\ESC[" ++ intercalate ";" (map show cs) ++ "m" where codes = map (readMaybe . T.unpack) . T.split (== ';') . T.drop 2 . T.init -- Prefers values from the second sequence when there's a conflict with -- values from the first sequence. combineSGRCodes :: [Maybe Int] -> [Maybe Int] -> Maybe [Int] combineSGRCodes as bs = map snd . nubBy (\a b -> fst a == fst b) <$> mapM range (reverse bs ++ reverse as) where range Nothing = Nothing range (Just x) | x >= 30 && x <= 37 = Just (Foreground, x) | x >= 40 && x <= 47 = Just (Background, x) | x >= 90 && x <= 97 = Just (Foreground, x) | x >= 100 && x <= 107 = Just (Background, x) | otherwise = Nothing #endif concurrent-output-1.10.21/System/Process/0000755000000000000000000000000007346545000016467 5ustar0000000000000000concurrent-output-1.10.21/System/Process/Concurrent.hs0000644000000000000000000000134007346545000021143 0ustar0000000000000000-- | -- Copyright: 2015 Joey Hess -- License: BSD-2-clause -- -- The functions exported by this module are intended to be drop-in -- replacements for those from System.Process, when converting a whole -- program to use System.Console.Concurrent. module System.Process.Concurrent where import System.Console.Concurrent import System.Process hiding (createProcess, waitForProcess) import System.IO import System.Exit -- | Calls `createProcessConcurrent` createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess = createProcessConcurrent -- | Calls `waitForProcessConcurrent` waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess = waitForProcessConcurrent concurrent-output-1.10.21/TODO0000644000000000000000000000474507346545000014267 0ustar0000000000000000* System.Console.Regions handling of outputConcurrent and errorConcurrent when the output lacks a newline is surprising. The output may never be displayed. A better approach: When output arrives that lacks a newline, allocate a region for it and buffer it in that region, so it displays immediately and more output will go to the same region. When a newline arrives, close the region and scroll up the completed line the same way any completed region is displayed. * Parts of System.Console.Concurrent may not be async exception safe. If a thread is running an action from that module and an async exception is sent to it, it may result in a deadlock or other problem. (System.Console.Regions has been made safe, also outputConcurrent and errorConcurrent.) Particularly problematic is takeOutputLock', which takes the lock and then outputs buffers to the console. If the emitOutputBuffer calls are interrupted by async exception, it will be left locked and the buffered output is also lost. But masking them is not good because emitOutputBuffer could run for a long time in some situations. fgProcess and bgProcess also do stuff with registerOutputThread/unregisterOutputThread that may not be async exception safe. And createProcessForeground uses takeOutputLock but then calls fgProcess, which could be interrupted (during its call to registerOutputThread) before it starts the async thread that drops the lock. One approach to all this might be to fork off a worker thread, which will thus be immune to any async exception directed at the calling thread. * Calling setConsoleRegion with something that throws an error will cause no further display updates to happen. The exception in the thunk will crash the displayThread, and that is not waited on until the action passed to displayConsoleRegions finishes, so the exception is deferred to that point. Of course if the action never finishes, that hides the exception. It does seem this should be improved, by catching the crashing displayThread and ideally propigating the exception immediately. But displayConsoleRegions would need to use a different class than the current MonadIO to be able to do that. Eg, MonadBaseControl so lifted-async can be used, or a class that lets the action be canceled. Or it could be dealt with by having setConsoleRegion force the thunk before passing it over to the displayThread. But the instance ToRegionContent (STM Text) seems to prevent doing that. concurrent-output-1.10.21/Utility/0000755000000000000000000000000007346545000015230 5ustar0000000000000000concurrent-output-1.10.21/Utility/Exception.hs0000644000000000000000000000561407346545000017530 0ustar0000000000000000{- Simple IO exception handling (and some more) - - Copyright 2011-2015 Joey Hess - - License: BSD-2-clause -} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Exception ( module X, catchBoolIO, catchMaybeIO, catchDefaultIO, catchMsgIO, catchIO, tryIO, bracketIO, catchNonAsync, tryNonAsync, tryWhenExists, catchHardwareFault, ) where import Control.Monad.Catch as X hiding (Handler) import qualified Control.Monad.Catch as M import Control.Exception (IOException, AsyncException) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import System.IO.Error (isDoesNotExistError, ioeGetErrorType) import GHC.IO.Exception (IOErrorType(..)) {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False {- Catches IO errors and returns a Maybe -} catchMaybeIO :: MonadCatch m => m a -> m (Maybe a) catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just) {- Catches IO errors and returns a default value. -} catchDefaultIO :: MonadCatch m => a -> m a -> m a catchDefaultIO def a = catchIO a (const $ return def) {- Catches IO errors and returns the error message. -} catchMsgIO :: MonadCatch m => m a -> m (Either String a) catchMsgIO a = do v <- tryIO a return $ either (Left . show) Right v {- catch specialized for IO errors only -} catchIO :: MonadCatch m => m a -> (IOException -> m a) -> m a catchIO = M.catch {- try specialized for IO errors only -} tryIO :: MonadCatch m => m a -> m (Either IOException a) tryIO = M.try {- bracket with setup and cleanup actions lifted to IO. - - Note that unlike catchIO and tryIO, this catches all exceptions. -} bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a bracketIO setup cleanup = bracket (liftIO setup) (liftIO . cleanup) {- Catches all exceptions except for async exceptions. - This is often better to use than catching them all, so that - ThreadKilled and UserInterrupt get through. -} catchNonAsync :: MonadCatch m => m a -> (SomeException -> m a) -> m a catchNonAsync a onerr = a `catches` [ M.Handler (\ (e :: AsyncException) -> throwM e) , M.Handler (\ (e :: SomeException) -> onerr e) ] tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) tryNonAsync a = go `catchNonAsync` (return . Left) where go = do v <- a return (Right v) {- Catches only DoesNotExist exceptions, and lets all others through. -} tryWhenExists :: MonadCatch m => m a -> m (Maybe a) tryWhenExists a = do v <- tryJust (guard . isDoesNotExistError) a return (either (const Nothing) Just v) {- Catches only exceptions caused by hardware faults. - Ie, disk IO error. -} catchHardwareFault :: MonadCatch m => m a -> (IOException -> m a) -> m a catchHardwareFault a onhardwareerr = catchIO a onlyhw where onlyhw e | ioeGetErrorType e == HardwareFault = onhardwareerr e | otherwise = throwM e concurrent-output-1.10.21/Utility/Monad.hs0000644000000000000000000000061407346545000016623 0ustar0000000000000000{- monadic stuff - - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Monad where {- if with a monadic conditional. -} ifM :: Monad m => m Bool -> (m a, m a) -> m a ifM cond (thenclause, elseclause) = do c <- cond if c then thenclause else elseclause {- do nothing -} noop :: Monad m => m () noop = return () concurrent-output-1.10.21/aptdemo.hs0000644000000000000000000000247507346545000015562 0ustar0000000000000000-- Demo similar to apt-get's download display. import Control.Concurrent.Async import Control.Concurrent import System.Console.Concurrent import System.Console.Regions import System.Console.ANSI main = displayConsoleRegions $ do mapConcurrently downline [ [dl "pony", growingdots, dl "mango"] , [dl "foo", dl "bar", dl "very large"] ] `concurrently` mapM_ message [1..20] `concurrently` mapM_ errormessage [2,6..20] message n = do threadDelay 500000 outputConcurrent ("Updated blah blah #" ++ show n ++ "\n") errormessage n = do threadDelay 2300000 outputConcurrent ("Failed to frob " ++ show n ++ "\n") downline cs = withConsoleRegion Linear $ \r -> mapConcurrently (\a -> a r) (reverse cs) dl c parent = withConsoleRegion (InLine parent) (go 0) where go n r | n <= 100 = do setConsoleRegion r $ "[" ++ setSGRCode [SetColor Foreground Vivid Green] ++ c ++ setSGRCode [Reset] ++ " " ++ show n ++ "%] " threadDelay (25000 * length c) go (n+1) r | otherwise = finishConsoleRegion r $ "Downloaded " ++ c ++ ".deb" growingdots parent = withConsoleRegion (InLine parent) (go 0) where go n r | n <= 300 = do setConsoleRegion r ("[" ++ setSGRCode [SetColor Foreground Vivid Blue] ++ replicate n '.' ++ setSGRCode [Reset] ++ "] ") threadDelay (100000) go (n+1) r | otherwise = return () concurrent-output-1.10.21/concurrent-output.cabal0000644000000000000000000000326007346545000020272 0ustar0000000000000000Name: concurrent-output Version: 1.10.21 Cabal-Version: >= 1.10 License: BSD2 Maintainer: Joey Hess Author: Joey Hess, Joachim Breitner Stability: Stable Copyright: 2015-2021 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple Category: User Interfaces, Concurrency Synopsis: Ungarble output from several threads or commands Description: Lets multiple threads and external processes concurrently output to the console, without it getting all garbled up. . 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 by concurrent threads. Can be used for progress displays etc. . <> Extra-Source-Files: CHANGELOG TODO demo.hs demo2.hs demo3.hs aptdemo.hs stmdemo.hs Library Default-Language: Haskell2010 GHC-Options: -Wall -fno-warn-tabs -O2 Build-Depends: base (>= 4.6), base < 5 , text (>= 0.11.0 && < 2.2) , async (>= 2.0 && < 2.3) , stm (>= 2.0 && < 2.6) , process (>= 1.6.0 && < 1.7.0) , directory (>= 1.2.0 && < 1.4.0) , transformers (>= 0.3.0 && < 0.7.0) , exceptions (>= 0.6.0 && < 0.11.0) , ansi-terminal (>= 0.6.2 && < 1.2.0) Exposed-Modules: System.Console.Concurrent System.Console.Concurrent.Internal System.Console.Regions System.Process.Concurrent Other-Modules: Utility.Monad Utility.Exception if (! os(Windows)) Build-Depends: unix (>= 2.7.0 && < 2.9.0) if (! arch(wasm32)) Build-Depends: terminal-size (>= 0.3.0 && < 0.4.0) source-repository head type: git location: git://git.joeyh.name/concurrent-output.git concurrent-output-1.10.21/demo.hs0000644000000000000000000000204107346545000015042 0ustar0000000000000000import Control.Concurrent.Async import Control.Concurrent import Control.Concurrent.STM import System.Console.Concurrent import System.Console.Regions import System.Process import qualified Data.Text as T import Data.List 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 appendConsoleRegion r " ... " threadDelay 1000000 go (c-1) r ls :: IO () ls = do threadDelay 1000000 (Nothing, Nothing, Nothing, p) <- createProcessConcurrent (proc "ls" ["-C"]) outputConcurrent "started running ls >>>" _ <- waitForProcessConcurrent p outputConcurrent "<<< ls is done!\n" return () concurrent-output-1.10.21/demo2.hs0000644000000000000000000000212407346545000015126 0ustar0000000000000000import Control.Concurrent.Async import Control.Concurrent import System.Console.Regions import Control.Monad main :: IO () main = displayConsoleRegions $ void $ mapConcurrently id [ spinner 100 1 "Pinwheels!!" setConsoleRegion "/-\\|" (withtitle 1) , spinner 100 1 "Bubbles!!!!" setConsoleRegion ".oOo." (withtitle 1) , spinner 100 1 "Dots......!" appendConsoleRegion "." (const (take 3)) , spinner 30 2 "KleisiFish?" setConsoleRegion " <=< <=< " (withtitle 10) , spinner 9 9 "Countdowns!" setConsoleRegion (reverse ([1..10] :: [Int])) (\t n -> t ++ show (head n)) ] where withtitle n t s = t ++ take n s spinner :: Int -> Int -> String -> (ConsoleRegion -> 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) concurrent-output-1.10.21/demo3.hs0000644000000000000000000000057607346545000015140 0ustar0000000000000000import Control.Concurrent.Async import System.Console.Concurrent import System.Process main = withConcurrentOutput $ outputConcurrent "hello world\n" `concurrently` createProcessConcurrent (proc "ls" []) `concurrently` createProcessConcurrent (proc "who" []) `concurrently` createProcessForeground (proc "vim" []) `concurrently` outputConcurrent "hello world again\n" concurrent-output-1.10.21/stmdemo.hs0000644000000000000000000000436507346545000015601 0ustar0000000000000000import Control.Concurrent.Async import Control.Concurrent import System.Console.Regions import qualified Data.Text as T import Control.Concurrent.STM import Control.Applicative import Data.Time.Clock import Control.Monad import Data.Monoid import System.Process main :: IO () main = void $ displayConsoleRegions $ do void titleRegion ir <- infoRegion cr <- clockRegion rr <- rulerRegion growingDots `concurrently` runBash mapM_ closeConsoleRegion [ir, cr] titleRegion :: IO ConsoleRegion titleRegion = do r <- openConsoleRegion Linear setConsoleRegion r "STM demo!" return r infoRegion :: IO ConsoleRegion infoRegion = do r <- openConsoleRegion Linear setConsoleRegion r $ do w <- consoleWidth h <- consoleHeight regions <- readTMVar regionList return $ T.pack $ unwords [ "size:" , show w , "x" , show h , "regions: " , show (length regions) ] return r timeDisplay :: TVar UTCTime -> STM T.Text timeDisplay tv = T.pack . show <$> readTVar tv clockRegion :: IO ConsoleRegion clockRegion = do tv <- atomically . newTVar =<< getCurrentTime async $ forever $ do threadDelay 1000000 -- 1 sec atomically . (writeTVar tv) =<< getCurrentTime atomically $ do r <- openConsoleRegion Linear setConsoleRegion r (timeDisplay tv) rightAlign r return r rulerRegion :: IO ConsoleRegion rulerRegion = do r <- openConsoleRegion Linear setConsoleRegion r $ do width <- consoleWidth return $ T.pack $ take width nums return r where nums = cycle $ concatMap show [0..9] rightAlign :: ConsoleRegion -> STM () rightAlign r = tuneDisplay r $ \t -> do w <- consoleWidth return (T.replicate (w - T.length t) (T.singleton ' ') <> t) growingDots :: IO () growingDots = withConsoleRegion Linear $ \r -> do atomically $ rightAlign r width <- atomically consoleWidth void $ replicateM width $ do appendConsoleRegion r "." threadDelay (100000) runBash :: IO () runBash = do -- Wait for growingDots to display some. threadDelay 1000000 -- Temporarily clear whatever console regions are open. rs <- waitDisplayChange $ swapTMVar regionList [] putStrLn "We interrupt this demo to run a shell prompt. exit to continue!" callCommand "bash" -- Restore the console regions. void $ atomically $ swapTMVar regionList rs