diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# 0.1.0 + + * Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +> module Main (main) where +> +> import Distribution.Simple +> +> main :: IO () +> main = defaultMain diff --git a/progress-meter.cabal b/progress-meter.cabal new file mode 100644 --- /dev/null +++ b/progress-meter.cabal @@ -0,0 +1,48 @@ +name: progress-meter +version: 0.1.0 +category: System +synopsis: Live diagnostics for concurrent activity + +maintainer: Ertugrul Söylemez +author: Ertugrul Söylemez +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 diff --git a/src/System/ProgressMeter.hs b/src/System/ProgressMeter.hs new file mode 100644 --- /dev/null +++ b/src/System/ProgressMeter.hs @@ -0,0 +1,422 @@ +-- | +-- 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. + +-}