diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ This library can be used to display progress meters or other diagnostics for concurrently running actions. It supports dynamic creation and -removal of new sub-meters as well es correct behaviour when printing +removal of new sub-meters as well as correct behaviour when printing diagnostics that are not part of the progress meter and should just scroll by. diff --git a/progress-meter.cabal b/progress-meter.cabal --- a/progress-meter.cabal +++ b/progress-meter.cabal @@ -1,5 +1,5 @@ name: progress-meter -version: 0.1.0 +version: 1.0.0 category: System synopsis: Live diagnostics for concurrent activity @@ -11,13 +11,13 @@ license: BSD3 license-file: LICENSE -description: This library can be used to display progress meters or - other diagnostics for concurrently running actions. It supports - dynamic creation and removal of new sub-meters as well es correct - behaviour when printing diagnostics that are not part of the - progress meter and should just scroll by. +description: This library can be used to display a progress bar or + other live diagnostics for your application. It supports partial + updates from multiple threads without interfering with each other, + and it has the correct behaviour when printing diagnostics that are + not part of the progress bar and should just scroll by. . - The @System.ProgressMeter@ module contains a tutorial. + The @System.Progress@ module contains a tutorial. build-type: Simple cabal-version: >= 1.10 @@ -32,12 +32,17 @@ description: Development dependencies manual: True +flag Examples + default: False + description: Build the example programs + manual: True + library build-depends: - async == 2.1.*, - base >= 4.8 && < 4.10, - containers == 0.5.*, + ansi-terminal >= 0.6 && < 0.8, + async >= 2.1.1 && < 2.2, + base >= 4.8 && < 4.11, stm == 2.4.* if flag(devel) build-depends: rapid, rapid-term @@ -45,4 +50,17 @@ ghc-options: -W hs-source-dirs: src exposed-modules: - System.ProgressMeter + System.Progress + +-- executable pm-http-get +-- if flag(examples) +-- build-depends: +-- base >= 4.8 && < 4.10, +-- http-conduit, +-- progress-meter +-- else +-- buildable: False +-- default-language: Haskell2010 +-- ghc-options: -W -threaded +-- hs-source-dirs: examples +-- main-is: pm-http-get.hs diff --git a/src/System/Progress.hs b/src/System/Progress.hs new file mode 100644 --- /dev/null +++ b/src/System/Progress.hs @@ -0,0 +1,470 @@ +-- | +-- Copyright: (c) 2017 Ertugrul Söylemez +-- License: BSD3 +-- Maintainer: Ertugrul Söylemez +-- +-- This module implements a progress bar with support for multiple +-- individual text chunks that can be updated independently (called +-- /meters/). + +{-# LANGUAGE RankNTypes #-} + +module System.Progress + ( -- * Tutorial + -- $tutorial + + -- ** Zooming + -- $zooming + + -- ** Concurrent updates + -- $concurrent_updates + + -- ** Further notes + -- $notes + + -- * Progress bars + Progress(..), + withProgress, + withProgress_, + -- ** I/O + meterIO, + putMsg, + putMsgLn, + + -- * Meters + Meter, + Meter', + modifyMeter, + setMeter, + zoomMeter, + zoomMeterL, + -- ** STM variants + modifyMeterSTM, + setMeterSTM + ) + where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Data.Functor.Identity +import System.Console.ANSI +import System.IO + + +-- | Progress bars displaying state information of the given type + +data Progress a = + Progress { + progressDelay :: Int, -- ^ Update delay in microseconds + progressHandle :: Handle, -- ^ Output handle + progressInitial :: a, -- ^ Initial state + progressRender :: a -> String -- ^ State renderer + } + + +-- | A value of type @Meter a b@ can be used to update part of the +-- current state of the progress bar by supplying a function of type @(a +-- -> b)@, where @a@ is the type of the current value and @b@ is the +-- type of the new value. See the 'modifyMeter' function for details. +-- +-- In most cases you can just assume @a = b@ and use the @Meter'@ alias. + +data Meter a b = + Meter { + _mModify :: (a -> b) -> STM (), + _mRunIO :: forall r. (Handle -> IO r) -> IO r + } + + +-- | Handy type alias for the common case where the current state type +-- and the new state type are the same + +type Meter' a = Meter a a + + +-- | Perform the given action while temporarily hiding the progress bar +-- +-- The given action is sequenced with concurrent uses of @meterIO@, so +-- it can be used for regular output without artifacts. The function +-- receives the output handle of the progress bar. + +meterIO :: Meter a b -> (Handle -> IO r) -> IO r +meterIO = _mRunIO + + +-- | Modify the part of the state represented by the given meter using +-- the given function +-- +-- The function receives the current value of type @a@ of the meter and +-- should return the new value of type @b@. Note that for most +-- applications those types will be the same. +-- +-- Updates are performed strictly, so they don't pile up when updates +-- are throttled, unless the progress bar is disabled (because the +-- output handle is not a terminal), in which case no state is +-- maintained at all. + +modifyMeter :: Meter a b -> (a -> b) -> IO () +modifyMeter meter = atomically . _mModify meter + + +-- | STM variant of 'modifyMeter': modify the given meter in a +-- transaction +-- +-- You can use this function to modify multiple meters simultaneously. +-- This is useful, if you want to make sure that users don't observe +-- partial updates. + +modifyMeterSTM :: Meter a b -> (a -> b) -> STM () +modifyMeterSTM = _mModify + + +-- | Variant of 'putMsgLn' that omits the final line feed +-- +-- Note: Use this function only when the given string ends with a line +-- feed, otherwise the progress bar will overwrite its last line when it +-- is redisplayed. + +putMsg :: Meter a b -> String -> IO () +putMsg meter str = meterIO meter (\h -> hPutStr h str) + + +-- | Print the given string to the output handle of the progress bar +-- +-- This is implemented in terms of 'meterIO', so it does The Right +-- Thing: it temporarily hides the progress bar, prints the string, then +-- redisplays it. It also makes sure that concurrent messages are +-- properly sequenced. + +putMsgLn :: Meter a b -> String -> IO () +putMsgLn meter str = meterIO meter (\h -> hPutStrLn h str) + + +-- | Variant of 'modifyMeter': set the given meter to the given new +-- state +-- +-- See 'modifyMeter' for details. + +setMeter :: Meter a b -> b -> IO () +setMeter m = modifyMeter m . const + + +-- | Variant of 'modifyMeterSTM': set the given meter to the given new +-- state in a transaction +-- +-- See 'modifyMeterSTM' for details. + +setMeterSTM :: Meter a b -> b -> STM () +setMeterSTM m = modifyMeterSTM m . const + + +-- | Display a progress bar for the duration of the given action +-- +-- Note: If the output handle is not a terminal (as determined by +-- 'hIsTerminalDevice'), no progress bar is displayed and no state is +-- maintained. In this case 'modifyMeter' and 'modifyMeterSTM' are +-- no-ops. +-- +-- For most applications the simpler variant 'withProgress_' is +-- sufficient. + +withProgress + :: Progress a -- ^ Progress bar configuration + -> (Meter' a -> IO r) -- ^ Action with a progress bar + -> IO r +withProgress prog k = do + let h = progressHandle prog + x0 = progressInitial prog + + stateVar <- newTVarIO (progressInitial prog) + changeVar <- newTVarIO False + drawLock <- newMVar () + + let withDrawLock c = + modifyMVar drawLock (\s -> (,) s <$> c) + + clear = do + hPutChar h '\r' + hClearFromCursorToLineEnd h + hFlush h + + render x = do + hPutChar h '\r' + hPutStr h (progressRender prog x) + hClearFromCursorToLineEnd h + hFlush h + + renderLoop = (withDrawLock (render x0) >> go) + `finally` withDrawLock clear + where + go = join . atomically $ do + readTVar changeVar >>= check + writeTVar changeVar False + x <- readTVar stateVar + pure $ do + withDrawLock (render x) + threadDelay (progressDelay prog) + go + + mModify f = do + x <- f <$> readTVar stateVar + x `seq` writeTVar stateVar x + writeTVar changeVar True + + mRunIO f = withDrawLock $ do + clear + f h `finally` (atomically (readTVar stateVar) >>= render) + + mRunIONoTerm f = withDrawLock (f h) + + isTerm <- hIsTerminalDevice h + if isTerm + then withAsync renderLoop $ \_ -> + k (Meter { _mModify = mModify, + _mRunIO = mRunIO }) + else k (Meter { _mModify = const (pure ()), + _mRunIO = mRunIONoTerm }) + + +-- | Simpler variant of 'withProgress' +-- +-- Uses a delay of 0.1 seconds and displays the progress bar on stderr. + +withProgress_ + :: a -- ^ Initial state value + -> (a -> String) -- ^ State renderer + -> (Meter' a -> IO r) -- ^ Action with a progress bar + -> IO r +withProgress_ x0 render = withProgress prog + where + prog = Progress { + progressDelay = 100000, + progressHandle = stderr, + progressInitial = x0, + progressRender = render + } + + +-- | Zoom into part of the state +-- +-- This function returns a variant of the given meter that focusses on +-- the value(s) the given setter modifies. You can use this for example +-- to focus on a single key in a map or all the values in a list. +-- +-- Examples: +-- +-- > -- Zoom into all values of a list (warning: non-strict!): +-- > zoomMeter map :: Meter' [a] -> Meter' a +-- > +-- > -- Zoom into the left component of a tuple: +-- > zoomMeter (\f (x', y) -> let x = f x' in x `seq` (x, y)) +-- > :: Meter' (a, b) -> Meter' a +-- > +-- > -- Zoom into the element indexed by the "foo" key, +-- > -- where M = Data.Map.Strict: +-- > zoomMeter (\f -> M.alter f "foo") +-- > :: Meter' (M.Map String a) -> Meter' (Maybe a) +-- > +-- > -- Variant of the previous example that always +-- > -- adds the element if it didn't exist before: +-- > zoomMeter (\f -> M.alter (Just . f) "foo") +-- > :: Meter' (M.Map String a) -> Meter (Maybe a) a + +zoomMeter :: ((a -> b) -> s -> t) -> Meter s t -> Meter a b +zoomMeter f meter = + meter { _mModify = _mModify meter . f } + + +-- | Variant of 'zoomMeter' that works with van Laarhoven setters as +-- used by libraries like : +-- +-- > zoomMeterL f = zoomMeter (over f) +-- +-- Keep in mind that most predefined lenses are non-strict. See the +-- tutorial section on zooming to understand why this can be a problem. + +zoomMeterL :: ((a -> Identity b) -> s -> Identity t) -> Meter s t -> Meter a b +zoomMeterL f = + zoomMeter (\g -> runIdentity . f (Identity . g)) + + +{- $tutorial + +A progress bar runs concurrently and redraws itself whenever something +changes to inform the impatient user that, yes, your application is +actually doing stuff. Redraws are throttled to a user-chosen rate in +order not to impact performance in the inconceivable case that changes +come in too frequently. + +The 'withProgress_' function adds a progress bar to your application for +the duration of the given action: + +> withProgress_ +> :: s +> -> (s -> String) +> -> (Meter' s -> IO r) +> -> IO r + +Progress bars maintain mutable state of a user-chosen type @s@ and use a +user-supplied rendering function of type @(s -> String)@ in order to +display the current state whenever your application brings itself to +update it. The first argument is the initial state, the second argument +is the rendering function. + +For example if you would like to display a simple percentage you could +use @s = 'Int'@ and an initial state of @0@. The rendering function +could turn the plain number into simple text, an ASCII art or any other +single-line entertainment: + +> render :: Int -> String +> render x = "Progress: " ++ show x ++ "%" + +To change the current state (in this case: the current percentage) you +can use the 'setMeter' function with the @Meter'@ value that your +application receives from 'withProgress_' (simplified type signature): + +> setMeter :: Meter' s -> s -> IO () + +Here is a full example in the spirit of the last percent challenging +your patience much worse than the rest: + +> import Control.Concurrent +> import Data.Foldable +> import System.Progress +> +> main :: IO () +> main = +> withProgress_ 0 render $ \pm -> do +> for_ [1..99] $ \p -> do +> threadDelay 20000 +> setMeter pm p +> threadDelay 3000000 +> setMeter pm 100 +> threadDelay 1000000 +> +> where +> render :: Int -> String +> render x = "Progress: " ++ show x ++ "%" + +From time to time you might like to perform regular output for +diagnostics, logging or other purposes. However, you can't just write +to 'stderr' as that would corrupt the progress bar. Instead you should +use the 'putMsgLn' function (simplified type signature): + +> putMsgLn :: Meter' s -> String -> IO () + +You can perform arbitrary actions while temporarily hiding the progress +bar by using the 'meterIO' function, of which 'putMsgLn' is a special +case. + +This library fully supports concurrency. You can use 'setMeter' and +'meterIO' from multiple threads. The latter will also properly sequence +concurrent actions, so you can safely output diagnostics from multiple +threads. + +-} + + +{- $zooming + +A meter of type @('Meter'' s)@ allows you update the current state of +type @s@. However, especially in highly concurrent applications it can +be useful to give a thread a meter that updates only the part of the +state that is relevant to that thread. For those applications you can +use the 'zoomMeter' function (simplified type signature): + +> zoomMeter :: ((a -> a) -> s -> s) -> Meter' s -> Meter' a + +Given a function that can map a function of type @(a -> a)@ over values +of type @s@, this function converts a @('Meter'' s)@ into a @('Meter'' +a)@. This is best illustrated with an example. The following function +strictly maps over the left component of a tuple: + +> {-# LANGUAGE BangPatterns #-} +> +> mapLeft :: (a -> b) -> (a, c) -> (b, c) +> mapLeft f (x', y) = let !x = f x' in (x, y) + +You can use this function with 'zoomMeter' to turn a @('Meter'' (a, b))@ +into a @('Meter'' a)@: + +> zoomMeter mapLeft :: Meter' (a, b) -> Meter' a + +This meter can then be used to update only the left component of the +state. Zooms can be cascaded as well. + +If you are using van Laarhoven lenses as defined by the + you can also use +the 'zoomMeterL' function (simplified type signature): + +> zoomMeterL :: ASetter' s a -> Meter' s -> Meter' a + +Caveat: Unfortunately most if not all of the predefined lenses are +non-strict. As mentioned earlier the progress bar's rendering loop is +throttled, so a state update may not cause an immediate redraw. For +that reason the 'setMeter' function updates the state strictly, so that +updates don't cause unevaluated expressions to pile up. However, it's +only WHNF-strict, so if you do any deep updates using a non-strict +function, they will not be evaluated until the next redraw. The +@mapLeft@ example above is strict in order to avoid that. + +The solution is either to write strict lenses by hand, or to make sure +the state type is fully strict in all its fields on all layers. + +-} + + +{- $concurrent_updates + +The rendering loop waits for updates to the current state. Whenever an +update comes in, it redraws the progress bar and then sleeps for a +user-specified duration (0.1 seconds if you use 'withProgress_'). If +further state updates have been done in the meantime, it redraws itself +and sleeps again, etc. Otherwise it waits for updates. + +Now imagine you need to do two state updates in a row to inform the user +of a certain change, for example you have done one step to completion +and want to start a new phase: + +> setMeter statusMeter "Done with foo, now doing bar" +> setMeter percentMeter 0 + +If the rendering loop is currently in the waiting phase it is very +likely that the first 'setMeter' will immediately wake up the rendering +thread and cause a redraw, after which it goes to its throttle sleep. +Users would then observe a partial state update for a brief amount of +time (the new message, but not the new percentage). In order to avoid +that you should use the STM variant of 'setMeter' called 'setMeterSTM': + +> atomically $ do +> setMeterSTM statusMeter "Done with foo, now doing bar" +> setMeterSTM percentMeter 0 + +This will make sure that the rendering loop never observes a partial +update. + +-} + + +{- $notes + +* This library does not do any fancy terminal magic; in particular it + doesn't check the terminal width, so if the text is too long, the user + may observe some undesired scrolling. You may know this effect from + @curl@. However, this keeps the implementation simple and portable + (terminfo is not portable to Windows). + + The author's recommendation is to just ignore this fact. Even if + you overdraw the progress bar itself will still work, and it will + span multiple lines properly. The scrolling effect is ugly, but + doesn't severely impact the user experience. + +* The default throttle of 0.1 seconds may seem too low, but it really + isn't. Keep in mind that the rendering loop does not draw at all, + unless there are actual updates, so even if your application updates + very infrequently the default throttle is fine. + +-} diff --git a/src/System/ProgressMeter.hs b/src/System/ProgressMeter.hs deleted file mode 100644 --- a/src/System/ProgressMeter.hs +++ /dev/null @@ -1,422 +0,0 @@ --- | --- Copyright: (c) 2017 Ertugrul Söylemez --- License: BSD3 --- Maintainer: Ertugrul Söylemez --- --- This module implements a progress bar with support for multiple --- individual text chunks that can be updated independently (called --- /meters/). - -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -module System.ProgressMeter - ( -- * Tutorial - -- $tutorial - - -- * Progress handles - Progress, - withProgress, - hWithProgress, - setProgressSep, - -- ** Low-level - newProgress, - runProgress, - quitProgress, - - -- * Meters - Meter, - setMeter, - -- ** Creation and deletion - appendMeter, - deleteMeter, - prependMeter, - withAppendMeter, - withPrependMeter, - - -- * Commands and messages - putCmd, - putMsg, - putMsgLn - ) - where - -import Control.Applicative -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import Data.Foldable -import Data.IORef -import Data.IntMap.Strict (IntMap) -import qualified Data.IntMap.Strict as Mi -import Data.List (intercalate) -import System.IO -import System.Mem.Weak - - --- | Handle to an individual progress meter - -data Meter = - Meter { - _meterGcVar :: IORef (), - _meterProg :: Progress, - _meterProgVar :: TVar String, - _meterWeakRef :: Weak (IORef ()) - } - - --- | Handle to a progress bar - -data Progress = - Progress { - _progCmdVar :: TQueue (Handle -> IO ()), - _progProgsVar :: TVar (IntMap (TVar String)), - _progQuitVar :: TVar Bool, - _progSepVar :: TVar String, - _progSignalVar :: TVar Bool - } - - --- | Add a progress meter using the given key selection function - -addMeterWith :: (forall a. IntMap a -> Int) -> Progress -> IO Meter -addMeterWith key _meterProg@Progress{..} = - mask_ $ do - (k, _meterProgVar) <- atomically $ do - ps <- readTVar _progProgsVar - let k = key ps - progVar <- newTVar mempty - writeTVar _progSignalVar True - (k, progVar) <$ writeTVar _progProgsVar (Mi.insert k progVar ps) - _meterGcVar <- newIORef () - _meterWeakRef <- mkWeakIORef _meterGcVar . atomically $ - modifyTVar _progProgsVar (Mi.delete k) - pure Meter{..} - - --- | Append a new progress meter to the given progress bar --- --- The meter is removed when garbage-collected or when 'deleteMeter' is --- used. The latter is preferable. - -appendMeter :: Progress -> IO Meter -appendMeter = - addMeterWith (maybe 0 (succ . fst . fst) . Mi.maxViewWithKey) - - --- | Delete the given progress meter --- --- Changes to the meter after running this action will not have any --- effect. - -deleteMeter :: Meter -> IO () -deleteMeter Meter{..} = do - finalize _meterWeakRef - atomically (writeTVar (_progSignalVar _meterProg) True) - - --- | High-level interface to create a progress bar --- --- This action creates a progress bar with the given update delay (in --- microseconds) on the given output handle and runs it in a background --- thread. It passes the progress handle to the given function and --- quits the bar after the action completes. - -hWithProgress - :: Int -- ^ Update delay (microseconds) - -> Handle -- ^ Output handle (most likely 'stderr') - -> (Progress -> IO a) -- ^ Action with progress bar - -> IO a -hWithProgress delay h k = do - prog <- newProgress - withAsync (runProgress prog delay h) $ \a -> - k prog `finally` do - quitProgress prog - waitCatch a - - --- | Create a progress handle using the given update delay (in --- microseconds) --- --- Note: In most cases you can and should just use 'withProgress'. - -newProgress :: IO Progress -newProgress = do - _progCmdVar <- newTQueueIO - _progProgsVar <- newTVarIO mempty - _progQuitVar <- newTVarIO False - _progSepVar <- newTVarIO " | " - _progSignalVar <- newTVarIO False - pure Progress{..} - - --- | Prepend a new progress to the given progress bar --- --- The meter is removed when garbage-collected or when 'deleteMeter' is --- used. The latter is preferable. - -prependMeter :: Progress -> IO Meter -prependMeter = - addMeterWith (maybe 0 (pred . fst . fst) . Mi.minViewWithKey) - - --- | Send an action to be executed by the progress bar after temporarily --- clearing its display --- --- This function can be used, for example, to print something safely. --- It returns immediately after queuing the action. Commands are --- executed in the order they are sent. --- --- Actions sent by this function are /not/ subject to the update delay --- and cause the display to be redrawn immediately. - -putCmd - :: Progress -- ^ Progress bar - -> (Handle -> IO ()) -- ^ Action to run, receives output handle - -> IO () -putCmd Progress{..} = atomically . writeTQueue _progCmdVar - - --- | Send a message to be printed by the progress bar after temporarily --- clearing its display --- --- Messages are printed in the order they are sent. Note: unless the --- message includes a line feed, it will most likely be overwritten by --- the progress bar. --- --- Messages sent by this function are /not/ subject to the update delay --- and cause the display to be redrawn immediately. - -putMsg :: Progress -> String -> IO () -putMsg prog str = putCmd prog (\h -> hPutStr h str) - - --- | Variant of 'putMsg' that prints a line feed after the message - -putMsgLn :: Progress -> String -> IO () -putMsgLn prog str = putCmd prog (\h -> hPutStrLn h str) - - --- | Make 'runProgress' clear its display and return --- --- Note: In most cases you can and should just use 'withProgress'. - -quitProgress :: Progress -> IO () -quitProgress Progress{..} = - atomically (writeTVar _progQuitVar True) - - --- | Run the given progress bar --- --- If the given handle is not a terminal, this action --- --- Note: In most cases you can and should just use 'withProgress'. - -runProgress :: Progress -> Int -> Handle -> IO () -runProgress Progress{..} delay h = do - -- NOTE: Terminal width handling is disabled until the wcwidth() - -- function is integrated in some way - - -- widthVar <- newTVarIO 80 - - -- let updateTermWidth = do - -- runInBoundThread $ do - -- term <- setupTermFromEnv - -- maybe (pure ()) - -- (\w -> atomically (writeTVar widthVar w)) - -- (getCapability term (tiGetNum "cols")) - -- stopDelay prog - -- atomically (writeTVar _progSignalVar True) - - -- when isTerm $ Codensity $ \k -> - -- bracket - -- (installHandler sigWINCH (Catch updateTermWidth) Nothing) - -- (\old -> installHandler sigWINCH old Nothing) - -- (\_ -> k ()) - - isTerm <- hIsTerminalDevice h - - let go delayA = - join . atomically $ - if isTerm - then command <|> quit <|> redrawNow - else commandNoTerm <|> quit - - where - command = do - c <- readTQueue _progCmdVar - writeTVar _progSignalVar True - pure $ do - cancel delayA - hPutStr h "\r\027[2K" - hFlush h - c h `catch` \(SomeException ex) -> do - hPrint h ex - hFlush h - go delayA - - commandNoTerm = do - c <- readTQueue _progCmdVar - pure $ do - c h `catch` \(SomeException ex) -> do - hPrint h ex - hFlush h - go delayA - - quit = do - readTVar _progQuitVar >>= check - pure (cancel delayA) - - redrawNow = do - readTVar _progSignalVar >>= check - waitCatchSTM delayA - writeTVar _progSignalVar False - sep <- readTVar _progSepVar - str <- readTVar _progProgsVar >>= - fmap (intercalate sep . toList) . traverse readTVar - pure $ do - hPutChar h '\r' - hPutStr h str - hPutStr h "\027[K" - hFlush h - async (threadDelay delay) >>= go - - (async (pure ()) >>= go) `finally` - when isTerm (hPutStr h "\r\027[2K" >> hFlush h) - - --- | Set the text of the given meter - -setMeter :: Meter -> String -> IO () -setMeter Meter{..} str = do - readIORef _meterGcVar - atomically $ do - writeTVar _meterProgVar str - writeTVar (_progSignalVar _meterProg) True - - --- | Set the separator string between individual meters (@" | "@ by --- default) - -setProgressSep :: Progress -> String -> IO () -setProgressSep Progress{..} sep = - atomically $ do - writeTVar _progSepVar sep - writeTVar _progSignalVar True - - --- | High-level interface to 'appendMeter' that makes sure the meter is --- deleted after the given action - -withAppendMeter :: Progress -> (Meter -> IO a) -> IO a -withAppendMeter prog = - bracket (appendMeter prog) - deleteMeter - - --- | High-level interface to 'prependMeter' that makes sure the meter is --- deleted after the given action - -withPrependMeter :: Progress -> (Meter -> IO a) -> IO a -withPrependMeter prog = - bracket (prependMeter prog) - deleteMeter - - --- | Variant of 'hWithProgress' that uses 'stderr' - -withProgress - :: Int -- ^ Update delay (microseconds) - -> (Progress -> IO a) -- ^ Action with progress bar - -> IO a -withProgress delay = hWithProgress delay stderr - - -{- $tutorial - -First you need to create a progress bar. The easiest way is to use the -'withProgress' function: - -> withProgress 100000 $ \prog -> do -> -- stuff -- - -The first argument to the function is the update delay in microseconds. -Each time the bar display is updated, a timer of that duration is -started, during which no further updates are drawn. When the action -given to 'withProgress' finishes, the display is cleared. - -In order to actually draw something you need to create a 'Meter', which -corresponds to a dynamic-width space within the progress bar. The -recommended interfaces to do that are 'withAppendMeter' and -'withPrependMeter'. The function 'setMeter' sets the content of that -meter. Example: - -> import Control.Concurrent -> import System.ProgressMeter -> -> main = -> withProgress 100000 $ \prog -> -> withAppendMeter prog $ \meter -> do -> setMeter meter "Hello ..." -> threadDelay 1000000 -> setMeter meter "... world!" -> threadDelay 1000000 - -In many applications you will want to print diagnostic messages that -should not be treated as part of the progress bar, but should just -scroll by as regular terminal text. You can do that by using 'putCmd', -'putMsg' and 'putMsgLn': - -> import Control.Concurrent -> import System.ProgressMeter -> -> main = -> withProgress 100000 $ \prog -> -> withAppendMeter prog $ \meter -> do -> setMeter meter "Hello ..." -> threadDelay 1000000 -> putMsgLn prog "Some diagnostics." -> threadDelay 1000000 -> putMsgLn prog "Some more diagnostics." -> threadDelay 1000000 -> setMeter meter "... world!" -> threadDelay 1000000 -> putMsgLn prog "More and more diagnostics." -> threadDelay 1000000 - -Of course the main purpose of this library is to show a progress bar for -concurrent activity. Therefore meters can be created and updated from -separate threads. Run the following program and watch how the -individual threads update their meters, print diagnostics and disappear -concurrently: - -> import Control.Concurrent -> import Control.Concurrent.Async -> import Control.Monad -> import Data.Foldable -> import Text.Printf -> -> main = -> withProgress 500000 $ \prog -> -> let thread n = do -> threadDelay (100000*n) -> withAppendMeter prog $ \meter -> do -> putMsgLn prog (printf "Thread %d started." n) -> for_ [0..100 :: Int] $ \p -> do -> when (p == 50) $ -> putMsgLn prog (printf "Thread %d reached half-way point." n) -> setMeter meter (printf "T%d: %d%%" n p) -> threadDelay (280000 - 40000*n) -> putMsgLn prog (printf "Thread %d done." n) -> threadDelay 500000 -> in mapConcurrently_ thread [1..6] - -The actual terminal handling is very conservative. Only ANSI codes are -used to draw the display, and terminal width is not taken into account -in this version. If the output handle is not a terminal, the meters are -not drawn, but only messages sent by 'putMsg' and 'putMsgLn' are -printed. - --}