progress-meter (empty) → 0.1.0
raw patch · 6 files changed
+516/−0 lines, 6 filesdep +asyncdep +basedep +containerssetup-changed
Dependencies added: async, base, containers, rapid, rapid-term, stm
Files
- CHANGELOG.md +3/−0
- LICENSE +27/−0
- README.md +10/−0
- Setup.lhs +6/−0
- progress-meter.cabal +48/−0
- src/System/ProgressMeter.hs +422/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0++ * Initial version.
+ LICENSE view
@@ -0,0 +1,27 @@+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.++ (3)The name of the author may not be used to endorse or promote+ products derived from this software without specific prior written+ permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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.
+ README.md view
@@ -0,0 +1,10 @@+progress-meter+==============++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.++The `System.ProgressMeter` module contains a tutorial.
+ Setup.lhs view
@@ -0,0 +1,6 @@+> module Main (main) where+>+> import Distribution.Simple+>+> main :: IO ()+> main = defaultMain
+ progress-meter.cabal view
@@ -0,0 +1,48 @@+name: progress-meter+version: 0.1.0+category: System+synopsis: Live diagnostics for concurrent activity++maintainer: Ertugrul Söylemez <esz@posteo.de>+author: Ertugrul Söylemez <esz@posteo.de>+copyright: Copyright 2017 Ertugrul Söylemez+homepage: https://github.com/esoeylemez/progress-meter+bug-reports: https://github.com/esoeylemez/progress-meter/issues+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.+ .+ The @System.ProgressMeter@ module contains a tutorial.++build-type: Simple+cabal-version: >= 1.10+extra-source-files: CHANGELOG.md README.md++source-repository head+ type: git+ location: https://github.com/esoeylemez/progress-meter.git++flag Devel+ default: False+ description: Development dependencies+ manual: True+++library+ build-depends:+ async == 2.1.*,+ base >= 4.8 && < 4.10,+ containers == 0.5.*,+ stm == 2.4.*+ if flag(devel)+ build-depends: rapid, rapid-term+ default-language: Haskell2010+ ghc-options: -W+ hs-source-dirs: src+ exposed-modules:+ System.ProgressMeter
+ src/System/ProgressMeter.hs view
@@ -0,0 +1,422 @@+-- |+-- Copyright: (c) 2017 Ertugrul Söylemez+-- License: BSD3+-- Maintainer: Ertugrul Söylemez <esz@posteo.de>+--+-- 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.++-}