concurrent-output-1.7.7/0000755000000000000000000000000012763600520013435 5ustar0000000000000000concurrent-output-1.7.7/stmdemo.hs0000644000000000000000000000324712763600520015447 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 main :: IO () main = void $ displayConsoleRegions $ do ir <- infoRegion cr <- clockRegion rr <- rulerRegion growingDots mapM_ closeConsoleRegion [ir, cr] 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 rightAlign :: ConsoleRegion -> STM () rightAlign r = tuneDisplay r $ \t -> do w <- consoleWidth return (T.replicate (w - T.length t) (T.singleton ' ') <> t) growingDots = withConsoleRegion Linear $ \r -> do atomically $ rightAlign r width <- atomically consoleWidth replicateM width $ do appendConsoleRegion r "." threadDelay (100000) 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] concurrent-output-1.7.7/LICENSE0000644000000000000000000000242712763600520014447 0ustar0000000000000000Copyright © 2015 Joey Hess Copyright © 2009 Joachim Breitner Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions 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.7.7/aptdemo.hs0000644000000000000000000000247512763600520015432 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.7.7/concurrent-output.cabal0000644000000000000000000000315212763600520020142 0ustar0000000000000000Name: concurrent-output Version: 1.7.7 Cabal-Version: >= 1.8 License: BSD2 Maintainer: Joey Hess Author: Joey Hess, Joachim Breitner Stability: Stable Copyright: 2015 Joey Hess, 2009 Joachim Breitner License-File: LICENSE Build-Type: Simple Category: User Interfaces 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 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.5.0) , directory (>= 1.2.0 && < 1.3.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) Exposed-Modules: System.Console.Concurrent System.Console.Concurrent.Internal System.Console.Regions System.Process.Concurrent Other-Modules: Utility.Monad Utility.Data Utility.Exception if (! os(Windows)) Build-Depends: unix (>= 2.7.0 && < 2.8.0) source-repository head type: git location: git://git.joeyh.name/concurrent-output.git concurrent-output-1.7.7/demo.hs0000644000000000000000000000204112763600520014712 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.7.7/TODO0000644000000000000000000000000012763600520014113 0ustar0000000000000000concurrent-output-1.7.7/demo2.hs0000644000000000000000000000235112763600520015000 0ustar0000000000000000import 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 [ 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]) (\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.7.7/demo3.hs0000644000000000000000000000057612763600520015010 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.7.7/CHANGELOG0000644000000000000000000001202312763600520014645 0ustar0000000000000000concurrent-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.7.7/Setup.hs0000644000000000000000000000010712763600520015067 0ustar0000000000000000{- cabal setup file -} import Distribution.Simple main = defaultMain concurrent-output-1.7.7/System/0000755000000000000000000000000012763600520014721 5ustar0000000000000000concurrent-output-1.7.7/System/Console/0000755000000000000000000000000012763600520016323 5ustar0000000000000000concurrent-output-1.7.7/System/Console/Regions.hs0000644000000000000000000006553712763600520020305 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 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, ) where import Data.Monoid import Data.String import Data.Char import qualified Data.Text as T 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 qualified System.Console.Terminal.Size as Console import System.IO import System.IO.Unsafe (unsafePerformIO) import Text.Read import Data.List #ifndef mingw32_HOST_OS import System.Posix.Signals import System.Posix.Signals.Exts #endif import Control.Applicative import Prelude import System.Console.Concurrent import Utility.Monad import Utility.Exception -- | Controls how a region is laid out in the console. -- -- Here's an annotated example of how the console layout works. -- -- > scrolling...... -- > scrolling...... -- > scrolling...... -- > aaaaaa......... -- Linear -- > bbbbbbbbbbbbbbb -- Linear -- > bbb............ (expanded to multiple lines) -- > ccccccccc...... -- Linear -- > 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 -- | 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. {-# NOINLINE consoleSize #-} consoleSize :: TVar (Console.Window Int) consoleSize = unsafePerformIO $ newTVarIO $ Console.Window { Console.width = 80, Console.height = 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. consoleWidth :: STM Int consoleWidth = munge . Console.width <$> 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. consoleHeight :: STM Int consoleHeight = Console.height <$> readTVar consoleSize -- | The RegionList TMVar is left empty when `displayConsoleRegions` -- is not 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 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 etc of all or part of a region. -- -- Other ANSI escape sequences, especially those doing cursor -- movement, will mess up the layouts of regions. Caveat emptor. 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 :: (LiftRegion m, MonadIO m, MonadMask m) => RegionLayout -> (ConsoleRegion -> m a) -> m a withConsoleRegion ly = bracketIO (openConsoleRegion ly) (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`. -- -- When standard output is not an ANSI capable terminal, -- console regions are not displayed. displayConsoleRegions :: (MonadIO m, MonadMask m) => m a -> m a displayConsoleRegions a = ifM (liftIO regionDisplayEnabled) ( a -- displayConsoleRegions is already running , lockOutput $ bracket setup cleanup (const a) ) where setup = liftIO $ do atomically $ putTMVar regionList [] endsignal <- atomically $ do s <- newTSem 1 waitTSem s return s isterm <- liftIO $ hSupportsANSI stdout when isterm trackConsoleWidth da <- async $ displayThread isterm endsignal return (isterm, da, endsignal) cleanup (isterm, da, endsignal) = liftIO $ do atomically $ signalTSem endsignal void $ wait da void $ atomically $ takeTMVar regionList when isterm $ installResizeHandler Nothing trackConsoleWidth :: IO () trackConsoleWidth = do let getwidth = maybe noop (atomically . writeTVar consoleSize) =<< Console.size getwidth installResizeHandler (Just getwidth) data DisplayChange = BufferChange (StdHandle, OutputBuffer) | RegionChange RegionSnapshot | TerminalResize Width | EndSignal () type RegionSnapshot = ([ConsoleRegion], [R], [[Text]]) displayThread :: Bool -> TSem -> IO () displayThread isterm endsignal = do origwidth <- atomically consoleWidth go ([], [], []) origwidth where go origsnapshot@(orighandles, origregions, origlines) origwidth = do let waitwidthchange = do w <- consoleWidth if w == origwidth then retry else return w let waitanychange = (RegionChange <$> regionWaiter origsnapshot origwidth) `orElse` (RegionChange <$> regionListWaiter origsnapshot) `orElse` (BufferChange <$> outputBufferWaiterSTM waitCompleteLines) `orElse` (TerminalResize <$> waitwidthchange) `orElse` (EndSignal <$> waitTSem endsignal) (change, height) <- atomically $ (,) <$> waitanychange <*> consoleHeight let onscreen = take (height - 1) . concat case change of RegionChange snapshot@(_, _, newlines) -> do when isterm $ do changedLines (onscreen origlines) (onscreen newlines) go snapshot origwidth 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 go origsnapshot origwidth TerminalResize newwidth -> do newlines <- atomically (mapM (resizeRegion newwidth) orighandles) when isterm $ do resizeRecovery (onscreen newlines) go (orighandles, origregions, newlines) newwidth EndSignal () -> return () 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 hFlush stdout 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) hFlush stdout displayLines :: [Text] -> IO () displayLines = mapM_ $ \l -> do T.hPutStr stdout l putChar '\n' installResizeHandler :: Maybe (IO ()) -> IO () #ifndef mingw32_HOST_OS installResizeHandler h = void $ installHandler windowChange (maybe Default Catch h) Nothing #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' -- | 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 concurrent-output-1.7.7/System/Console/Concurrent.hs0000644000000000000000000000160712763600520021005 0ustar0000000000000000-- | -- Copyright: 2015 Joey Hess -- License: BSD-2-clause -- -- Concurrent output handling. -- -- > import Control.Concurrent.Async -- > import System.Console.Concurrent -- > -- > main = withConcurrentOutput $ -- > outputConcurrent "washed the car\n" -- > `concurrently` -- > outputConcurrent "walked the dog\n" -- > `concurrently` -- > createProcessConcurrent (proc "ls" []) module System.Console.Concurrent ( -- * Concurrent output withConcurrentOutput, Outputable(..), outputConcurrent, errorConcurrent, ConcurrentProcessHandle, createProcessConcurrent, waitForProcessConcurrent, createProcessForeground, flushConcurrentOutput, lockOutput, -- * Low level access to the output buffer OutputBuffer, StdHandle(..), bufferOutputSTM, outputBufferWaiterSTM, waitAnyBuffer, waitCompleteLines, emitOutputBuffer, ) where import System.Console.Concurrent.Internal concurrent-output-1.7.7/System/Console/Concurrent/0000755000000000000000000000000012763600520020445 5ustar0000000000000000concurrent-output-1.7.7/System/Console/Concurrent/Internal.hs0000644000000000000000000004250112763600520022557 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 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 , processWaiters :: TMVar [Async ()] , waitForProcessLock :: TMVar () } data Lock = Locked -- | A shared global variable for the OutputHandle. {-# NOINLINE globalOutputHandle #-} globalOutputHandle :: OutputHandle globalOutputHandle = unsafePerformIO $ OutputHandle <$> newEmptyTMVarIO <*> 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 -- module. -- -- While this is running, other threads that try to lockOutput will block. -- Any calls to `outputConcurrent` and `createProcessConcurrent` will not -- block, but the output will be buffered and displayed only once the -- action is done. lockOutput :: (MonadIO m, MonadMask m) => m a -> m a lockOutput = bracket_ (liftIO takeOutputLock) (liftIO dropOutputLock) -- | Blocks until we have the output lock. takeOutputLock :: IO () takeOutputLock = void $ takeOutputLock' True -- | Tries to take the output lock, without blocking. tryTakeOutputLock :: IO Bool tryTakeOutputLock = takeOutputLock' False withLock :: (TMVar Lock -> STM a) -> IO a withLock a = atomically $ a (outputLock globalOutputHandle) takeOutputLock' :: Bool -> IO Bool takeOutputLock' block = do locked <- withLock $ \l -> do v <- tryTakeTMVar l case v of Just Locked | block -> retry | otherwise -> do -- Restore value we took. putTMVar l Locked return False Nothing -> do putTMVar l Locked return True when locked $ do (outbuf, errbuf) <- atomically $ (,) <$> swapTMVar (outputBuffer globalOutputHandle) (OutputBuffer []) <*> swapTMVar (errorBuffer globalOutputHandle) (OutputBuffer []) emitOutputBuffer StdOut outbuf emitOutputBuffer StdErr errbuf return locked -- | Only safe to call after taking the output lock. dropOutputLock :: IO () dropOutputLock = withLock $ void . takeTMVar -- | Use this around any actions that use `outputConcurrent` -- or `createProcessConcurrent` -- -- This is necessary to ensure that buffered concurrent output actually -- gets displayed before the program exits. withConcurrentOutput :: (MonadIO m, MonadMask m) => m a -> m a withConcurrentOutput a = a `finally` liftIO flushConcurrentOutput -- | Blocks until any processes started by `createProcessConcurrent` have -- finished, and any buffered output is displayed. 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 instance Outputable String where toOutput = toOutput . T.pack -- | Displays a value to stdout. -- -- No newline is appended to the value, so if you want a newline, be sure -- to include it yourself. -- -- Uses locking to ensure that the whole output occurs atomically -- even when other threads are concurrently generating output. -- -- When something else is writing to the console at the same time, this does -- not block. It buffers the value, so it will be displayed once the other -- writer is done. outputConcurrent :: Outputable v => v -> IO () outputConcurrent = 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 = bracket setup cleanup go 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 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) -- | 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` 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) -- | 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. -- -- Currently only available on Unix systems, not Windows. createProcessConcurrent :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) 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 asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h return (toConcurrentProcessHandle 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) createProcessForeground p = do takeOutputLock fgProcess p fgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) fgProcess p = do r@(_, _, _, h) <- P.createProcess p `onException` dropOutputLock registerOutputThread -- Wait for the process to exit and drop the lock. asyncProcessWaiter $ do void $ tryIO $ P.waitForProcess h unregisterOutputThread dropOutputLock return (toConcurrentProcessHandle r) bgProcess :: P.CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ConcurrentProcessHandle) 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 ) asyncProcessWaiter $ void $ tryIO $ P.waitForProcess h outbuf <- setupOutputBuffer StdOut stdout_h errbuf <- setupOutputBuffer StdErr stderr_h void $ async $ bufferWriter [outbuf, errbuf] return (toConcurrentProcessHandle r) where rediroutput ss | willOutput ss = P.CreatePipe | otherwise = ss 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.7.7/System/Process/0000755000000000000000000000000012763600520016337 5ustar0000000000000000concurrent-output-1.7.7/System/Process/Concurrent.hs0000644000000000000000000000251112763600520021014 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.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) -- | 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 concurrent-output-1.7.7/Utility/0000755000000000000000000000000012763600520015100 5ustar0000000000000000concurrent-output-1.7.7/Utility/Monad.hs0000644000000000000000000000364712763600520016504 0ustar0000000000000000{- monadic stuff - - Copyright 2010-2012 Joey Hess - - License: BSD-2-clause -} {-# OPTIONS_GHC -fno-warn-tabs #-} 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 () noop = return () concurrent-output-1.7.7/Utility/Exception.hs0000644000000000000000000000562312763600520017400 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(..)) import Utility.Data {- 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 (eitherToMaybe 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.7.7/Utility/Data.hs0000644000000000000000000000066012763600520016307 0ustar0000000000000000{- utilities for simple data types - - Copyright 2013 Joey Hess - - 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