concurrent-output 1.9.2 → 1.10.21
raw patch · 12 files changed
Files
- CHANGELOG +157/−0
- System/Console/Concurrent.hs +3/−3
- System/Console/Concurrent/Internal.hs +38/−80
- System/Console/Regions.hs +85/−32
- System/Process/Concurrent.hs +2/−14
- TODO +53/−0
- Utility/Data.hs +0/−19
- Utility/Exception.hs +1/−3
- Utility/Monad.hs +0/−51
- concurrent-output.cabal +15/−14
- demo2.hs +4/−9
- stmdemo.hs +3/−3
CHANGELOG view
@@ -1,3 +1,160 @@+concurrent-output (1.10.21) unstable; urgency=medium++ * Allow ansi-terminal-1.1++ -- Joey Hess <id@joeyh.name> Mon, 29 Apr 2024 10:15:55 -0400++concurrent-output (1.10.20) unstable; urgency=medium++ * Allow text-2.1.++ -- Joey Hess <id@joeyh.name> Thu, 12 Oct 2023 15:46:36 -0400++concurrent-output (1.10.19) unstable; urgency=medium++ * Support building for WASM.++ -- Joey Hess <id@joeyh.name> 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 <id@joeyh.name> 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 <id@joeyh.name> 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 <id@joeyh.name> Fri, 20 May 2022 19:31:56 -0400++concurrent-output (1.10.15) unstable; urgency=medium++ * Allow text-2.0++ -- Joey Hess <id@joeyh.name> Fri, 04 Feb 2022 15:32:58 -0400++concurrent-output (1.10.14) unstable; urgency=medium++ * Allow ansi-terminal-0.11.1.++ -- Joey Hess <id@joeyh.name> 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 <id@joeyh.name> 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 <id@joeyh.name> 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 <id@joeyh.name> 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 <id@joeyh.name> 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 <id@joeyh.name> 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 <id@joeyh.name> Mon, 19 Nov 2018 17:01:12 -0400++concurrent-output (1.10.7) unstable; urgency=medium++ * Allow stm-2.5.++ -- Joey Hess <id@joeyh.name> 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 <id@joeyh.name> Mon, 02 Jul 2018 10:58:59 -0400++concurrent-output (1.10.5) unstable; urgency=medium++ * Allow exceptions-0.10.++ -- Joey Hess <id@joeyh.name> Tue, 13 Mar 2018 11:50:39 -0400++concurrent-output (1.10.4) unstable; urgency=medium++ * Allow exceptions-0.9.++ -- Joey Hess <id@joeyh.name> Mon, 26 Feb 2018 11:45:08 -0400++concurrent-output (1.10.3) unstable; urgency=medium++ * Allow async-2.2.++ -- Joey Hess <id@joeyh.name> Mon, 05 Feb 2018 11:07:27 -0400++concurrent-output (1.10.2) unstable; urgency=medium++ * Allow ansi-terminal-0.8.++ -- Joey Hess <id@joeyh.name> Thu, 25 Jan 2018 11:51:43 -0400++concurrent-output (1.10.1) unstable; urgency=medium++ * Allow ansi-terminal-0.7.++ -- Joey Hess <id@joeyh.name> 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 <id@joeyh.name> Fri, 19 May 2017 11:54:49 -0400+ concurrent-output (1.9.2) unstable; urgency=medium * Allow process-1.6.0.0.
System/Console/Concurrent.hs view
@@ -7,7 +7,7 @@ -- > import Control.Concurrent.Async -- > import System.Console.Concurrent -- >--- > main = withConcurrentOutput $+-- > main = withConcurrentOutput $ do -- > outputConcurrent "washed the car\n" -- > `concurrently` -- > outputConcurrent "walked the dog\n"@@ -20,12 +20,12 @@ Outputable(..), outputConcurrent, errorConcurrent,- ConcurrentProcessHandle, createProcessConcurrent,- waitForProcessConcurrent, createProcessForeground, flushConcurrentOutput, lockOutput,+ ConcurrentProcessHandle,+ waitForProcessConcurrent, -- * Low level access to the output buffer OutputBuffer, StdHandle(..),
System/Console/Concurrent/Internal.hs view
@@ -40,8 +40,6 @@ , outputBuffer :: TMVar OutputBuffer , errorBuffer :: TMVar OutputBuffer , outputThreads :: TMVar Integer- , processWaiters :: TMVar [Async ()]- , waitForProcessLock :: TMVar () } data Lock = Locked@@ -54,8 +52,6 @@ <*> newTMVarIO (OutputBuffer []) <*> newTMVarIO (OutputBuffer []) <*> newTMVarIO 0- <*> newTMVarIO []- <*> newEmptyTMVarIO -- | Holds a lock while performing an action. This allows the action to -- perform its own output to the console, without using functions from this@@ -106,7 +102,8 @@ dropOutputLock = withLock $ void . takeTMVar -- | Use this around any actions that use `outputConcurrent`--- or `createProcessConcurrent`+-- 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.@@ -171,7 +168,12 @@ errorConcurrent = outputConcurrent' StdErr outputConcurrent' :: Outputable v => StdHandle -> v -> IO ()-outputConcurrent' stdh v = bracket setup cleanup go+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 ()@@ -186,69 +188,13 @@ h = toHandle stdh bv = bufferFor stdh -newtype ConcurrentProcessHandle = ConcurrentProcessHandle P.ProcessHandle--toConcurrentProcessHandle :: (Maybe Handle, Maybe Handle, Maybe Handle, P.ProcessHandle) -> (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)-toConcurrentProcessHandle (i, o, e, h) = (i, o, e, ConcurrentProcessHandle h)+-- | This alias is provided to avoid breaking backwards compatibility.+type ConcurrentProcessHandle = P.ProcessHandle --- | Use this to wait for processes started with --- `createProcessConcurrent` and `createProcessForeground`, and get their--- exit status.------ Note that such processes are actually automatically waited for--- internally, so not calling this explicitly will not result--- in zombie processes. This behavior differs from `P.waitForProcess`+-- | Same as `P.waitForProcess`; provided to avoid breaking backwards+-- compatibility. waitForProcessConcurrent :: ConcurrentProcessHandle -> IO ExitCode-waitForProcessConcurrent (ConcurrentProcessHandle h) = - bracket lock unlock checkexit- where- lck = waitForProcessLock globalOutputHandle- lock = atomically $ tryPutTMVar lck ()- unlock True = atomically $ takeTMVar lck- unlock False = return ()- checkexit locked = maybe (waitsome locked) return- =<< P.getProcessExitCode h- waitsome True = do- let v = processWaiters globalOutputHandle- l <- atomically $ readTMVar v- if null l- -- Avoid waitAny [] which blocks forever- then P.waitForProcess h- else do- -- Wait for any of the running- -- processes to exit. It may or may not- -- be the one corresponding to the- -- ProcessHandle. If it is,- -- getProcessExitCode will succeed.- void $ tryIO $ waitAny l- checkexit True- waitsome False = do- -- Another thread took the lck first. Wait for that thread to- -- wait for one of the running processes to exit.- atomically $ do- putTMVar lck ()- takeTMVar lck- checkexit False---- Registers an action that waits for a process to exit,--- adding it to the processWaiters list, and removing it once the action--- completes.-asyncProcessWaiter :: IO () -> IO ()-asyncProcessWaiter waitaction = do- regdone <- newEmptyTMVarIO- waiter <- async $ do- self <- atomically (takeTMVar regdone)- waitaction `finally` unregister self- register waiter regdone- where- v = processWaiters globalOutputHandle- register waiter regdone = atomically $ do- l <- takeTMVar v- putTMVar v (waiter:l)- putTMVar regdone waiter- unregister waiter = atomically $ do- l <- takeTMVar v- putTMVar v (filter (/= waiter) l)+waitForProcessConcurrent = P.waitForProcess -- | Wrapper around `System.Process.createProcess` that prevents -- multiple processes that are running concurrently from writing@@ -266,7 +212,11 @@ -- 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, ConcurrentProcessHandle) +--+-- 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@@ -275,31 +225,34 @@ ) | otherwise = do r@(_, _, _, h) <- P.createProcess p- asyncProcessWaiter $- void $ tryIO $ P.waitForProcess h- return (toConcurrentProcessHandle r)+ _ <- 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.-createProcessForeground :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+--+-- 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, ConcurrentProcessHandle)+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.- asyncProcessWaiter $ do+ _ <- async $ do void $ tryIO $ P.waitForProcess h unregisterOutputThread dropOutputLock- return (toConcurrentProcessHandle r)+ return r -bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle)+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)@@ -314,15 +267,20 @@ , mungeret (P.std_err p) stderr_h , h )- asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h- outbuf <- setupOutputBuffer StdOut stdout_h- errbuf <- setupOutputBuffer StdErr stderr_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 (toConcurrentProcessHandle r)+ 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
System/Console/Regions.hs view
@@ -126,17 +126,19 @@ 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 Text.Read-import Data.List+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-import Control.Applicative-import Prelude+#endif import System.Console.Concurrent import Utility.Monad@@ -145,6 +147,7 @@ -- | 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......@@ -181,22 +184,26 @@ regionList :: TMVar [ConsoleRegion] regionList = unsafePerformIO newEmptyTMVarIO --- | On Unix systems, this TVar is automatically updated when the--- terminal is resized. On Windows, it is only initialized on program start--- with the current terminal size.+data ConsoleSize = ConsoleSize+ { _consoleHeight :: Int+ , _consoleWidth :: Int+ }+ {-# NOINLINE consoleSize #-}-consoleSize :: TVar (Console.Window Int)-consoleSize = unsafePerformIO $ newTVarIO $ - Console.Window { Console.width = 80, Console.height = 25}+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 only initialized on program start.+-- 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 . Console.width <$> readTVar consoleSize+consoleWidth = munge . _consoleWidth <$> readTVar consoleSize where #ifndef mingw32_HOST_OS munge = id@@ -207,8 +214,13 @@ #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 = Console.height <$> readTVar consoleSize+consoleHeight = _consoleHeight <$> readTVar consoleSize -- | Check if `displayConsoleRegions` is running. regionDisplayEnabled :: IO Bool@@ -258,10 +270,26 @@ -- necessary. -- -- The value can include ANSI SGR escape sequences for changing--- the colors etc of all or part of a region.+-- 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@@ -295,7 +323,9 @@ -- | 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) (closeConsoleRegion)+withConsoleRegion ly = bracketIO+ (openConsoleRegion ly)+ (uninterruptibleMask_ . closeConsoleRegion) -- | Opens a new console region. openConsoleRegion :: LiftRegion m => RegionLayout -> m ConsoleRegion@@ -404,7 +434,9 @@ -- 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`.+-- `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.@@ -414,17 +446,17 @@ , lockOutput $ bracket setup cleanup (const a) ) where- setup = liftIO $ do+ setup = liftIO $ uninterruptibleMask $ \unmask -> do atomically $ putTMVar regionList [] endsignal <- atomically $ do s <- newTSem 1 waitTSem s return s isterm <- liftIO $ hSupportsANSI stdout- when isterm trackConsoleWidth- da <- async $ displayThread isterm endsignal+ when isterm (unmask trackConsoleWidth)+ da <- async $ unmask $ displayThread isterm endsignal return (isterm, da, endsignal)- cleanup (isterm, da, endsignal) = liftIO $ do+ cleanup (isterm, da, endsignal) = liftIO $ uninterruptibleMask_ $ do atomically $ signalTSem endsignal void $ wait da void $ atomically $ takeTMVar regionList@@ -432,11 +464,20 @@ installResizeHandler Nothing trackConsoleWidth :: IO ()+#ifdef VERSION_terminal_size trackConsoleWidth = do- let getsz = maybe noop (atomically . writeTVar consoleSize)+ 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 @@ -462,23 +503,27 @@ displayChangeBarrier = unsafePerformIO $ newTVarIO 0 -- | Runs a STM action, and waits for the display to be fully updated--- before returning.+-- with any changes that action makes to the displayed regions. waitDisplayChange :: STM a -> IO a waitDisplayChange a = do- r <- atomically a c <- atomically $ dupTChan displayUpdateNotifier- b <- atomically $ do+ 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- return b- atomically $ waitchange c b- return r- where- waitchange c b = do- change <- readTChan c+ 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 b+ DisplayChangeBarrier b' | b' >= b -> return ()+ _ -> waitchange c bv displayThread :: Bool -> TSem -> IO () displayThread isterm endsignal = do@@ -669,11 +714,15 @@ 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@@ -746,6 +795,8 @@ 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. --@@ -881,3 +932,5 @@ | x >= 90 && x <= 97 = Just (Foreground, x) | x >= 100 && x <= 107 = Just (Background, x) | otherwise = Nothing++#endif
System/Process/Concurrent.hs view
@@ -9,26 +9,14 @@ module System.Process.Concurrent where import System.Console.Concurrent-import System.Console.Concurrent.Internal (ConcurrentProcessHandle(..)) import System.Process hiding (createProcess, waitForProcess) import System.IO import System.Exit -- | Calls `createProcessConcurrent`------ You should use the waitForProcess in this module on the resulting--- ProcessHandle. Using System.Process.waitForProcess instead can have--- mildly unexpected results. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)-createProcess p = do- (i, o, e, ConcurrentProcessHandle h) <- createProcessConcurrent p- return (i, o, e, h)+createProcess = createProcessConcurrent -- | Calls `waitForProcessConcurrent`------ You should only use this on a ProcessHandle obtained by calling--- createProcess from this module. Using this with a ProcessHandle--- obtained from System.Process.createProcess etc will have extremely--- unexpected results; it can wait a very long time before returning. waitForProcess :: ProcessHandle -> IO ExitCode-waitForProcess = waitForProcessConcurrent . ConcurrentProcessHandle+waitForProcess = waitForProcessConcurrent
TODO view
@@ -0,0 +1,53 @@+* 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.
− Utility/Data.hs
@@ -1,19 +0,0 @@-{- utilities for simple data types- -- - Copyright 2013 Joey Hess <id@joeyh.name>- -- - License: BSD-2-clause- -}--{-# OPTIONS_GHC -fno-warn-tabs #-}--module Utility.Data where--{- First item in the list that is not Nothing. -}-firstJust :: Eq a => [Maybe a] -> Maybe a-firstJust ms = case dropWhile (== Nothing) ms of- [] -> Nothing- (md:_) -> md--eitherToMaybe :: Either a b -> Maybe b-eitherToMaybe = either (const Nothing) Just
Utility/Exception.hs view
@@ -31,8 +31,6 @@ import System.IO.Error (isDoesNotExistError, ioeGetErrorType) import GHC.IO.Exception (IOErrorType(..)) -import Utility.Data- {- Catches IO errors and returns a Bool -} catchBoolIO :: MonadCatch m => m Bool -> m Bool catchBoolIO = catchDefaultIO False@@ -86,7 +84,7 @@ tryWhenExists :: MonadCatch m => m a -> m (Maybe a) tryWhenExists a = do v <- tryJust (guard . isDoesNotExistError) a- return (eitherToMaybe v)+ return (either (const Nothing) Just v) {- Catches only exceptions caused by hardware faults. - Ie, disk IO error. -}
Utility/Monad.hs view
@@ -9,62 +9,11 @@ module Utility.Monad where -import Data.Maybe-import Control.Monad--{- Return the first value from a list, if any, satisfying the given- - predicate -}-firstM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-firstM _ [] = return Nothing-firstM p (x:xs) = ifM (p x) (return $ Just x , firstM p xs)--{- Runs the action on values from the list until it succeeds, returning- - its result. -}-getM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)-getM _ [] = return Nothing-getM p (x:xs) = maybe (getM p xs) (return . Just) =<< p x--{- Returns true if any value in the list satisfies the predicate,- - stopping once one is found. -}-anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool-anyM p = liftM isJust . firstM p--allM :: Monad m => (a -> m Bool) -> [a] -> m Bool-allM _ [] = return True-allM p (x:xs) = p x <&&> allM p xs--{- Runs an action on values from a list until it succeeds. -}-untilTrue :: Monad m => [a] -> (a -> m Bool) -> m Bool-untilTrue = flip anyM- {- 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--{- short-circuiting monadic || -}-(<||>) :: Monad m => m Bool -> m Bool -> m Bool-ma <||> mb = ifM ma ( return True , mb )--{- short-circuiting monadic && -}-(<&&>) :: Monad m => m Bool -> m Bool -> m Bool-ma <&&> mb = ifM ma ( mb , return False )--{- Same fixity as && and || -}-infixr 3 <&&>-infixr 2 <||>--{- Runs an action, passing its value to an observer before returning it. -}-observe :: Monad m => (a -> m b) -> m a -> m a-observe observer a = do- r <- a- _ <- observer r- return r--{- b `after` a runs first a, then b, and returns the value of a -}-after :: Monad m => m b -> m a -> m a-after = observe . const {- do nothing -} noop :: Monad m => m ()
concurrent-output.cabal view
@@ -1,14 +1,14 @@ Name: concurrent-output-Version: 1.9.2-Cabal-Version: >= 1.8+Version: 1.10.21+Cabal-Version: >= 1.10 License: BSD2 Maintainer: Joey Hess <id@joeyh.name> Author: Joey Hess, Joachim Breitner Stability: Stable-Copyright: 2015-2017 Joey Hess, 2009 Joachim Breitner+Copyright: 2015-2021 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple-Category: User Interfaces+Category: User Interfaces, Concurrency Synopsis: Ungarble output from several threads or commands Description: Lets multiple threads and external processes concurrently output to the@@ -29,17 +29,17 @@ stmdemo.hs Library+ Default-Language: Haskell2010 GHC-Options: -Wall -fno-warn-tabs -O2 Build-Depends: base (>= 4.6), base < 5- , text (>= 0.11.0 && < 1.3.0)- , async (>= 2.0 && < 2.2)- , stm (>= 2.0 && < 2.5)- , process (>= 1.1.0 && < 1.7.0)+ , 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.6.0)- , exceptions (>= 0.6.0 && < 0.9.0)- , ansi-terminal (>= 0.6.0 && < 0.7.0)- , terminal-size (>= 0.3.0 && < 0.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@@ -47,11 +47,12 @@ System.Process.Concurrent Other-Modules: Utility.Monad- Utility.Data Utility.Exception if (! os(Windows))- Build-Depends: unix (>= 2.7.0 && < 2.8.0)+ 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
demo2.hs view
@@ -1,21 +1,16 @@ import Control.Concurrent.Async import Control.Concurrent-import System.Console.Concurrent import System.Console.Regions-import System.Console.Terminal.Size-import qualified Data.Text as T-import Control.Concurrent.STM-import Control.Applicative-import Data.Time.Clock import Control.Monad -main = displayConsoleRegions $ mapConcurrently id+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 10 9 "Countdowns!" setConsoleRegion- (reverse [1..10])+ , spinner 9 9 "Countdowns!" setConsoleRegion+ (reverse ([1..10] :: [Int])) (\t n -> t ++ show (head n)) ] where
stmdemo.hs view
@@ -15,9 +15,7 @@ ir <- infoRegion cr <- clockRegion rr <- rulerRegion- growingDots- runBash- growingDots+ growingDots `concurrently` runBash mapM_ closeConsoleRegion [ir, cr] titleRegion :: IO ConsoleRegion@@ -83,6 +81,8 @@ 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!"