terminal-progress-bar 0.2 → 0.4
raw patch · 7 files changed
+644/−483 lines, 7 filesdep +criteriondep +deepseqdep +textdep −asyncdep −randomdep −stmdep ~base
Dependencies added: criterion, deepseq, text, time
Dependencies removed: async, random, stm, stm-chans
Dependency ranges changed: base
Files
- LICENSE +1/−1
- bench/bench.hs +51/−0
- example.hs +0/−56
- src/System/ProgressBar.hs +514/−95
- src/System/ProgressBar/State.hs +0/−280
- terminal-progress-bar.cabal +21/−27
- test/test.hs +57/−24
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2012–2018 Roel van Dijk+Copyright 2012–2019 Roel van Dijk All rights reserved.
+ bench/bench.hs view
@@ -0,0 +1,51 @@+{-# language PackageImports #-}+module Main where++import "base" Data.Monoid ( (<>) )+import "criterion" Criterion.Main+import "terminal-progress-bar" System.ProgressBar+import "time" Data.Time.Clock ( UTCTime(..) )++main :: IO ()+main = defaultMain+ [ renderProgressBarBenchmark 10 0+ , renderProgressBarBenchmark 10 50+ , renderProgressBarBenchmark 10 100+ , renderProgressBarBenchmark 100 0+ , renderProgressBarBenchmark 100 50+ , renderProgressBarBenchmark 100 100+ , renderProgressBarBenchmark 200 0+ , renderProgressBarBenchmark 200 50+ , renderProgressBarBenchmark 200 100+ , labelBenchmark "percentage" percentage (Progress 0 100 ())+ , labelBenchmark "percentage" percentage (Progress 50 100 ())+ , labelBenchmark "percentage" percentage (Progress 100 100 ())+ , labelBenchmark "exact" exact (Progress 0 100 ())+ , labelBenchmark "exact" exact (Progress 50 100 ())+ , labelBenchmark "exact" exact (Progress 100 100 ())+ ]++renderProgressBarBenchmark :: Int -> Int -> Benchmark+renderProgressBarBenchmark width done =+ bench name $ nf (\(s, p, t) -> renderProgressBar s p t)+ ( defStyle{styleWidth = ConstantWidth width}+ , Progress done 100 ()+ , someTiming+ )+ where+ name = "progressBar/default - "+ <> show width <> " wide - progress " <> show done <> " % 100"++labelBenchmark :: String -> Label () -> Progress () -> Benchmark+labelBenchmark labelName label progress =+ bench name $ nf (\(p, t) -> runLabel label p t) (progress, someTiming)+ where+ name = "label/" <> labelName <> " "+ <> show (progressDone progress) <> " % "+ <> show (progressTodo progress)++someTime :: UTCTime+someTime = UTCTime (toEnum 0) 0++someTiming :: Timing+someTiming = Timing someTime someTime
− example.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE PackageImports #-}--module Main where--import "async" Control.Concurrent.Async ( async, wait )-import "base" Control.Concurrent ( threadDelay )-import "base" Control.Monad ( forM_ )-import "base" Data.Functor ( void )-import "random" System.Random ( randomRIO )-import "terminal-progress-bar" System.ProgressBar--main :: IO ()-main = do- example 60 (13 + 60) 25000- exampleAsync 60 (13 + 60) 25000- exampleAsync2 (13 + 100) 25000--example :: Integer -> Integer -> Int -> IO ()-example todo width delay = do- forM_ [1 .. todo] $ \done -> do- autoProgressBar percentage exact width $ Progress done todo- threadDelay delay- putStrLn ""--exampleAsync :: Integer -> Integer -> Int -> IO ()-exampleAsync todo width delay = do- (pr, a) <- startProgress percentage exact width $ Progress 0 todo- forM_ [1 .. todo] $ \_done -> do- incProgress pr 1- threadDelay delay- wait a- putStrLn ""--exampleAsync2 :: Integer -> Int -> IO ()-exampleAsync2 width delay = do- (pr, a) <- startProgress percentage exact width $ Progress 0 todo- -- Spawn some threads which each increment progress a bit.- forM_ [1 .. numThreads] $ \_ ->- void $ async $- forM_ [1 .. progressPerThread] $ \_ -> do- incProgress pr 1- d <- randomRIO (delay * numThreads, 2 * delay * numThreads)- threadDelay d-- -- Wait until the task is completed.- wait a- putStrLn ""- where- todo :: Integer- todo = fromIntegral $ numThreads * progressPerThread-- numThreads :: Int- numThreads = 10-- progressPerThread :: Int- progressPerThread = 10
src/System/ProgressBar.hs view
@@ -1,141 +1,560 @@+{-# language DeriveGeneric #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language OverloadedStrings #-} {-# language PackageImports #-}+{-# language ScopedTypeVariables #-} module System.ProgressBar ( -- * Progress bars ProgressBar- , progressBar- , autoProgressBar- , hProgressBar- , mkProgressBar- -- * Progress state+ , newProgressBar+ , hNewProgressBar+ , renderProgressBar+ , updateProgress+ , incProgress+ -- * Options+ , Style(..)+ , EscapeCode+ , defStyle+ , ProgressBarWidth(..)+ -- * Progress , Progress(..) -- * Labels- , Label- , noLabel+ , Label(..)+ , Timing(..) , msg , percentage , exact- -- * Auto printing- , ProgressRef- , startProgress- , incProgress+ , elapsedTime+ , remainingTime+ , totalTime+ , renderDuration ) where -import "async" Control.Concurrent.Async ( Async )-import "base" System.IO ( Handle, stderr )-import "this" System.ProgressBar.State ( Progress(..) )-import qualified "this" System.ProgressBar.State as State+import "base" Control.Concurrent.MVar ( MVar, newMVar, modifyMVar_)+import "base" Control.Monad ( when )+import "base" Data.Int ( Int64 )+import "base" Data.Monoid ( Monoid, mempty )+import "base" Data.Ratio ( Ratio, (%) )+import "base" Data.Semigroup ( Semigroup, (<>) )+import "base" Data.String ( IsString, fromString )+import "base" GHC.Generics ( Generic )+import "base" System.IO ( Handle, stderr, hFlush )+import "deepseq" Control.DeepSeq ( NFData, rnf )+import qualified "terminal-size" System.Console.Terminal.Size as TS+import qualified "text" Data.Text.Lazy as TL+import qualified "text" Data.Text.Lazy.Builder as TLB+import qualified "text" Data.Text.Lazy.Builder.Int as TLB+import qualified "text" Data.Text.Lazy.IO as TL+import "time" Data.Time.Clock ( UTCTime, NominalDiffTime, diffUTCTime, getCurrentTime ) --- | Type of functions producing a progress bar.-type ProgressBar a- = Label -- ^ Prefixed label.- -> Label -- ^ Postfixed label.- -> Integer- -- ^ Total progress bar width in characters. Either used as given- -- or as a default when the width of the terminal can not be- -- determined.- --- -- See 'autoProgressBar'.- -> Progress -- ^ Current progress.- -> a+-------------------------------------------------------------------------------- --- | Print a progress bar to 'stderr'------ See 'hProgressBar'.-progressBar :: ProgressBar (IO ())-progressBar = hProgressBar stderr+data ProgressBar s+ = ProgressBar+ { pbStyle :: !(Style s)+ , pbStateMv :: !(MVar (State s))+ , pbRefreshDelay :: !Double+ , pbStartTime :: !UTCTime+ , pbHandle :: !Handle+ } --- | Print a progress bar to 'stderr' which takes up all available space.+instance (NFData s) => NFData (ProgressBar s) where+ rnf pb = pbStyle pb+ `seq` pbStateMv pb+ `seq` pbRefreshDelay pb+ `seq` pbStartTime pb+ -- pbHandle is ignored+ `seq` ()++data State s+ = State+ { stProgress :: !(Progress s)+ , stRenderTime :: !UTCTime+ }++-- | State of a progress bar.+data Progress s+ = Progress+ { progressDone :: !Int+ -- ^ Amount of work completed.+ , progressTodo :: !Int+ -- ^ Total amount of work.+ , progressCustom :: !s+ -- ^ A custom value which can be used by custom labels.+ -- Simply use '()' if you do not need custom progress values.+ }++progressFinished :: Progress s -> Bool+progressFinished p = progressDone p >= progressTodo p++newProgressBar+ :: Style s+ -> Double -- ^ Maximum refresh rate in Hertz.+ -> Progress s -- ^ Initial progress.+ -> IO (ProgressBar s)+newProgressBar = hNewProgressBar stderr++hNewProgressBar+ :: Handle+ -> Style s+ -> Double -- ^ Maximum refresh rate in Hertz.+ -> Progress s -- ^ Initial progress.+ -> IO (ProgressBar s)+hNewProgressBar hndl style maxRefreshRate initProgress = do+ style' <- updateWidth style++ startTime <- getCurrentTime+ hPutProgressBar hndl style' initProgress (Timing startTime startTime)++ stateMv <- newMVar+ State+ { stProgress = initProgress+ , stRenderTime = startTime+ }+ pure ProgressBar+ { pbStyle = style'+ , pbStateMv = stateMv+ , pbRefreshDelay = recip maxRefreshRate+ , pbStartTime = startTime+ , pbHandle = hndl+ }++updateWidth :: Style s -> IO (Style s)+updateWidth style =+ case styleWidth style of+ ConstantWidth {} -> pure style+ TerminalWidth {} -> do+ mbWindow <- TS.size+ pure $ case mbWindow of+ Nothing -> style+ Just window -> style{ styleWidth = TerminalWidth (TS.width window) }++updateProgress+ :: forall s. ProgressBar s -> (Progress s -> Progress s) -> IO ()+updateProgress progressBar f = do+ updateTime <- getCurrentTime+ modifyMVar_ (pbStateMv progressBar) $ renderAndUpdate updateTime+ where+ renderAndUpdate :: UTCTime -> State s -> IO (State s)+ renderAndUpdate updateTime state = do+ when shouldRender $+ hPutProgressBar hndl (pbStyle progressBar) newProgress timing+ pure State+ { stProgress = newProgress+ , stRenderTime = if shouldRender then updateTime else stRenderTime state+ }+ where+ timing = Timing+ { timingStart = pbStartTime progressBar+ , timingLastUpdate = updateTime+ }++ shouldRender = not tooFast || finished+ tooFast = secSinceLastRender <= pbRefreshDelay progressBar+ finished = progressFinished newProgress++ newProgress = f $ stProgress state++ -- Amount of time that passed since last render, in seconds.+ secSinceLastRender :: Double+ secSinceLastRender = realToFrac $ diffUTCTime updateTime (stRenderTime state)++ hndl = pbHandle progressBar++incProgress :: ProgressBar s -> Int -> IO ()+incProgress pb n = updateProgress pb $ \p -> p{ progressDone = progressDone p + n }++hPutProgressBar :: Handle -> Style s -> Progress s -> Timing -> IO ()+hPutProgressBar hndl style progress timing = do+ TL.hPutStr hndl $ renderProgressBar style progress timing+ TL.hPutStr hndl $+ if progressFinished progress+ then "\n"+ else "\r"+ hFlush hndl++-- | Renders a progress bar ----- The given width will be used if the width of the terminal can not--- be determined.+-- >>> renderProgressBar (msg "Working") percentage 40 30 100+-- "Working [=======>.................] 30%" ----- See 'hProgressBar'.-autoProgressBar :: ProgressBar (IO ())-autoProgressBar = State.autoProgressBar+-- Not that this function can not use 'TerminalWidth' because it+-- doesn't use 'IO'. Use 'progressBar' or 'hProgressBar' to get+-- automatic width.+renderProgressBar :: Style s -> Progress s -> Timing -> TL.Text+renderProgressBar style progress timing = TL.concat+ [ styleEscapePrefix style progress+ , prefixLabel+ , prefixPad+ , styleEscapeOpen style progress+ , styleOpen style+ , styleEscapeDone style progress+ , TL.replicate completed $ TL.singleton $ styleDone style+ , styleEscapeCurrent style progress+ , if remaining /= 0 && completed /= 0+ then TL.singleton $ styleCurrent style+ else ""+ , styleEscapeTodo style progress+ , TL.replicate+ (remaining - if completed /= 0 then 1 else 0)+ (TL.singleton $ styleTodo style)+ , styleEscapeClose style progress+ , styleClose style+ , styleEscapePostfix style progress+ , postfixPad+ , postfixLabel+ ]+ where+ todo = fromIntegral $ progressTodo progress+ done = fromIntegral $ progressDone progress+ -- Amount of (visible) characters that should be used to display to progress bar.+ width = fromIntegral $ getProgressBarWidth $ styleWidth style --- | Print a progress bar to a file handle.+ -- Amount of work completed.+ fraction :: Ratio Int64+ fraction | todo /= 0 = done % todo+ | otherwise = 0 % 1++ -- Amount of characters available to visualize the progress.+ effectiveWidth = max 0 $ width - usedSpace+ -- Amount of printing characters needed to visualize everything except the bar .+ usedSpace = TL.length (styleOpen style)+ + TL.length (styleClose style)+ + TL.length prefixLabel+ + TL.length postfixLabel+ + TL.length prefixPad+ + TL.length postfixPad++ -- Number of characters needed to represent the amount of work+ -- that is completed. Note that this can not always be represented+ -- by an integer.+ numCompletedChars :: Ratio Int64+ numCompletedChars = fraction * (effectiveWidth % 1)++ completed, remaining :: Int64+ completed = min effectiveWidth $ floor numCompletedChars+ remaining = effectiveWidth - completed++ prefixLabel, postfixLabel :: TL.Text+ prefixLabel = runLabel (stylePrefix style) progress timing+ postfixLabel = runLabel (stylePostfix style) progress timing++ prefixPad, postfixPad :: TL.Text+ prefixPad = pad prefixLabel+ postfixPad = pad postfixLabel++pad :: TL.Text -> TL.Text+pad s | TL.null s = TL.empty+ | otherwise = TL.singleton ' '++-- | Width of progress bar in characters.+data ProgressBarWidth+ = ConstantWidth !Int+ -- ^ A constant width.+ | TerminalWidth !Int+ -- ^ Use the entire width of the terminal.+ --+ -- Identical to 'ConstantWidth' if the width of the terminal can+ -- not be determined.+ deriving (Generic)++instance NFData ProgressBarWidth++getProgressBarWidth :: ProgressBarWidth -> Int+getProgressBarWidth (ConstantWidth n) = n+getProgressBarWidth (TerminalWidth n) = n++{- | Options that determine the textual representation of a progress+bar.++The textual representation of a progress bar follows the following template:++\<__prefix__>\<__open__>\<__done__>\<__current__>\<__todo__>\<__close__>\<__postfix__>++Where \<__done__> and \<__todo__> are repeated as often as necessary.++Consider the following progress bar++> "Working [=======>.................] 30%"++This bar can be specified using the following style:++@+'Style'+{ 'styleOpen' = \"["+, 'styleClose' = \"]"+, 'styleDone' = \'='+, 'styleCurrent' = \'>'+, 'styleTodo' = \'.'+, 'stylePrefix' = 'msg' \"Working"+, 'stylePostfix' = 'percentage'+, 'styleWidth' = 'ConstantWidth' 40+, 'styleEscapeOpen' = const 'TL.empty'+, 'styleEscapeClose' = const 'TL.empty'+, 'styleEscapeDone' = const 'TL.empty'+, 'styleEscapeCurrent' = const 'TL.empty'+, 'styleEscapeTodo' = const 'TL.empty'+, 'styleEscapePrefix' = const 'TL.empty'+, 'styleEscapePostfix' = const 'TL.empty'+}+@+-}+data Style s+ = Style+ { styleOpen :: !TL.Text+ -- ^ Bar opening symbol.+ , styleClose :: !TL.Text+ -- ^ Bar closing symbol+ , styleDone :: !Char+ -- ^ Completed work.+ , styleCurrent :: !Char+ -- ^ Symbol used to denote the current amount of work that has been done.+ , styleTodo :: !Char+ -- ^ Work not yet completed.+ , stylePrefix :: Label s+ -- ^ Prefixed label.+ , stylePostfix :: Label s+ -- ^ Postfixed label.+ , styleWidth :: !ProgressBarWidth+ -- ^ Total width of the progress bar.+ , styleEscapeOpen :: EscapeCode s+ -- ^ Escape code printed just before the 'styleOpen' symbol.+ , styleEscapeClose :: EscapeCode s+ -- ^ Escape code printed just before the 'styleClose' symbol.+ , styleEscapeDone :: EscapeCode s+ -- ^ Escape code printed just before the first 'styleDone' character.+ , styleEscapeCurrent :: EscapeCode s+ -- ^ Escape code printed just before the 'styleCurrent' character.+ , styleEscapeTodo :: EscapeCode s+ -- ^ Escape code printed just before the first 'styleTodo' character.+ , styleEscapePrefix :: EscapeCode s+ -- ^ Escape code printed just before the 'stylePrefix' label.+ , styleEscapePostfix :: EscapeCode s+ -- ^ Escape code printed just before the 'stylePostfix' label.+ } deriving (Generic)++instance (NFData s) => NFData (Style s)++-- | An escape code is a sequence of bytes which the terminal looks+-- for and interprets as commands, not as character codes. ----- Erases the current line! (by outputting '\r') Does not print a--- newline '\n'. Subsequent invocations will overwrite the previous--- output.-hProgressBar :: Handle -> ProgressBar (IO ())-hProgressBar = State.hProgressBar+-- It is vital that the output of this function, when send to the+-- terminal, does not result in characters being drawn.+type EscapeCode s+ = Progress s -- ^ Current progress bar state.+ -> TL.Text -- ^ Resulting escape code. Must be non-printable. --- | Renders a progress bar+-- | A default style. ----- >>> mkProgressBar (msg "Working") percentage 40 30 100--- "Working [=======>.................] 30%"-mkProgressBar :: ProgressBar String-mkProgressBar = State.mkProgressBar+-- You can override some fields of the default instead of specifying+-- all the fields of a 'Style' record.+--+-- The default does not use any escape sequences.+defStyle :: Style s+defStyle =+ Style+ { styleOpen = "["+ , styleClose = "]"+ , styleDone = '='+ , styleCurrent = '>'+ , styleTodo = '.'+ , stylePrefix = mempty+ , stylePostfix = percentage+ , styleWidth = TerminalWidth 50+ , styleEscapeOpen = const TL.empty+ , styleEscapeClose = const TL.empty+ , styleEscapeDone = const TL.empty+ , styleEscapeCurrent = const TL.empty+ , styleEscapeTodo = const TL.empty+ , styleEscapePrefix = const TL.empty+ , styleEscapePostfix = const TL.empty+ } -- | A label that can be pre- or postfixed to a progress bar.-type Label- = Progress -- ^ Current progress.- -> String -- ^ Resulting label.+newtype Label s = Label{ runLabel :: Progress s -> Timing -> TL.Text } deriving (NFData) --- | The empty label.------ >>> noLabel 30 100--- ""-noLabel :: Label-noLabel = State.noLabel+instance Semigroup (Label s) where+ Label f <> Label g = Label $ \p t -> f p t <> g p t +instance Monoid (Label s) where+ mempty = msg TL.empty+ mappend = (<>)++instance IsString (Label s) where+ fromString = msg . TL.pack++data Timing+ = Timing+ { timingStart :: !UTCTime+ , timingLastUpdate :: !UTCTime+ }+ -- | A label consisting of a static string. ----- >>> msg "foo" 30 100+-- >>> msg "foo" st -- "foo"-msg :: String -> Label-msg = State.msg+msg :: TL.Text -> Label s+msg s = Label $ \_ _ -> s -- | A label which displays the progress as a percentage. ----- Constant width property:--- ∀ d t : ℕ. d ≤ t → length (percentage d t) ≡ 4------ >>> percentage 30 100+-- >>> runLabel $ percentage (Progress 30 100 ()) someTiming -- " 30%" -- -- __Note__: if no work is to be done (todo == 0) the percentage will -- always be 100%.---- ∀ d t : ℕ. d ≤ t -> length (percentage d t) ≡ 3-percentage :: Label-percentage = State.percentage+percentage :: Label s+percentage = Label render+ where+ render progress _timing+ | todo == 0 = "100%"+ | otherwise = TL.justifyRight 4 ' ' $ TLB.toLazyText $+ TLB.decimal (round (done % todo * 100) :: Int)+ <> TLB.singleton '%'+ where+ done = progressDone progress+ todo = progressTodo progress -- | A label which displays the progress as a fraction of the total -- amount of work. ----- Equal width property:--- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t → length (exact d₁ t) ≡ length (exact d₂ t)+-- Equal width property - the length of the resulting label is a function of the+-- total amount of work: ----- >>> exact 30 100+-- >>> runLabel $ exact (Progress 30 100 ()) someTiming -- " 30/100"+exact :: Label s+exact = Label render+ where+ render progress _timing =+ TL.justifyRight (TL.length todoStr) ' ' doneStr <> "/" <> todoStr+ where+ todoStr = TLB.toLazyText $ TLB.decimal todo+ doneStr = TLB.toLazyText $ TLB.decimal done --- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t -> length (exact d₁ t) ≡ length (exact d₂ t)-exact :: Label-exact = State.exact+ done = progressDone progress+ todo = progressTodo progress --- * Auto-Printing Progress+-- | A label which displays the amount of time that has elapsed.+--+-- Time starts when a progress bar is created.+--+-- The user must supply a function which actually renders the amount+-- of time that has elapsed. You can use 'renderDuration' or+-- @formatTime@ from time >= 1.9.+elapsedTime+ :: (NominalDiffTime -> TL.Text)+ -> Label s+elapsedTime formatNDT = Label render+ where+ render _progress timing = formatNDT dt+ where+ dt :: NominalDiffTime+ dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) -type ProgressRef = State.ProgressRef Progress+-- | Displays the estimated remaining time until all work is done.+--+-- Tells you how much longer some task will take.+--+-- This label uses a really simple estimation algorithm. It assumes+-- progress is linear. To prevent nonsense results it won't estimate+-- remaining time until at least 1 second of work has been done.+--+-- When it refuses to estimate the remaining time it will show an+-- alternative message instead.+--+-- The user must supply a function which actually renders the amount+-- of time that has elapsed. You can use 'renderDuration' or+-- @formatTime@ from time >= 1.9.+remainingTime+ :: (NominalDiffTime -> TL.Text)+ -> TL.Text+ -- ^ Alternative message when remaining time can't be+ -- calculated (yet).+ -> Label s+remainingTime formatNDT altMsg = Label render+ where+ render progress timing+ | dt > 1 = formatNDT estimatedRemainingTime+ | progressDone progress <= 0 = altMsg+ | otherwise = altMsg+ where+ estimatedRemainingTime = estimatedTotalTime - dt+ estimatedTotalTime = dt * recip progressFraction --- | Start a thread to automatically display progress. Use incProgress to step--- the progress bar.-startProgress- :: Label -- ^ Prefixed label.- -> Label -- ^ Postfixed label.- -> Integer- -- ^ Total progress bar width in characters. Only used if the- -- width can not be automatically determined.- -> Progress -- ^ Initial progress state.- -> IO (ProgressRef, Async ())-startProgress = State.startProgress+ progressFraction :: NominalDiffTime+ progressFraction+ | progressTodo progress <= 0 = 1+ | otherwise = fromIntegral (progressDone progress)+ / fromIntegral (progressTodo progress) --- | Increment the progress bar. Negative values will reverse the progress.--- Progress will never be negative and will silently stop taking data--- when it completes.-incProgress :: ProgressRef -> Integer -> IO ()-incProgress pr amount =- State.incProgress pr- (\st -> st { progressDone = progressDone st + amount })+ dt :: NominalDiffTime+ dt = diffUTCTime (timingLastUpdate timing) (timingStart timing)++-- | Displays the estimated total time a task will take.+--+-- This label uses a really simple estimation algorithm. It assumes+-- progress is linear. To prevent nonsense results it won't estimate+-- the total time until at least 1 second of work has been done.+--+-- When it refuses to estimate the total time it will show an+-- alternative message instead.+--+-- The user must supply a function which actually renders the total+-- amount of time that a task will take. You can use 'renderDuration'+-- or @formatTime@ from time >= 1.9.+totalTime+ :: (NominalDiffTime -> TL.Text)+ -> TL.Text+ -- ^ Alternative message when total time can't be calculated+ -- (yet).+ -> Label s+totalTime formatNDT altMsg = Label render+ where+ render progress timing+ | dt > 1 = formatNDT estimatedTotalTime+ | progressDone progress <= 0 = altMsg+ | otherwise = altMsg+ where+ estimatedTotalTime = dt * recip progressFraction++ progressFraction :: NominalDiffTime+ progressFraction+ | progressTodo progress <= 0 = 1+ | otherwise = fromIntegral (progressDone progress)+ / fromIntegral (progressTodo progress)++ dt :: NominalDiffTime+ dt = diffUTCTime (timingLastUpdate timing) (timingStart timing)++-- | Show amount of time.+--+-- > renderDuration (fromInteger 42)+-- 42+--+-- > renderDuration (fromInteger $ 5 * 60 + 42)+-- 05:42+--+-- > renderDuration (fromInteger $ 8 * 60 * 60 + 5 * 60 + 42)+-- 08:05:42+--+-- Use the time >= 1.9 package to get a formatTime function which+-- accepts 'NominalDiffTime'.+renderDuration :: NominalDiffTime -> TL.Text+renderDuration dt = hTxt <> mTxt <> sTxt+ where+ hTxt | h == 0 = mempty+ | otherwise = renderDecimal h <> ":"+ mTxt | m == 0 = mempty+ | otherwise = renderDecimal m <> ":"+ sTxt = renderDecimal s++ (h, hRem) = ts `quotRem` 3600+ (m, s ) = hRem `quotRem` 60++ -- Total amount of seconds+ ts :: Int+ ts = round dt++ renderDecimal n = TL.justifyRight 2 '0' $ TLB.toLazyText $ TLB.decimal n
− src/System/ProgressBar/State.hs
@@ -1,280 +0,0 @@-{-# language PackageImports #-}-{-# OPTIONS_HADDOCK not-home #-}--module System.ProgressBar.State- ( -- * Progress bars- ProgressBar- , progressBar- , autoProgressBar- , hProgressBar- , mkProgressBar- -- * Progress state- , Progress(..)- , HasProgress(..)- -- * Labels- , Label- , noLabel- , msg- , percentage- , exact- -- * Auto printing- , ProgressRef- , startProgress- , incProgress- ) where--import "async" Control.Concurrent.Async ( Async, async )-import "base" Control.Monad ( when )-import "base" Data.List ( genericLength, genericReplicate )-import "base" Data.Ratio ( (%) )-import "base" System.IO ( Handle, stderr, hPutChar, hPutStr, hFlush )-import "base" Text.Printf ( printf )-import "stm" Control.Concurrent.STM- ( TVar, readTVar, writeTVar, newTVar, atomically, STM )-import "stm-chans" Control.Concurrent.STM.TMQueue- ( TMQueue, readTMQueue, closeTMQueue, writeTMQueue, newTMQueue )-import qualified "terminal-size" System.Console.Terminal.Size as TS---- | Type of functions producing a progress bar.-type ProgressBar s a- = Label s -- ^ Prefixed label.- -> Label s -- ^ Postfixed label.- -> Integer- -- ^ Total progress bar width in characters. Either used as given- -- or as a default when the width of the terminal can not be- -- determined.- --- -- See 'autoProgressBar'.- -> s -- ^ Progress bar state.- -> a---- | Print a progress bar to 'stderr'------ See 'hProgressBar'.-progressBar :: (HasProgress s) => ProgressBar s (IO ())-progressBar = hProgressBar stderr---- | Print a progress bar to 'stderr' which takes up all available space.------ The given width will be used if the width of the terminal can not--- be determined.------ See 'hProgressBar'.-autoProgressBar :: (HasProgress s) => ProgressBar s (IO ())-autoProgressBar mkPreLabel mkPostLabel defaultWidth st = do- mbWindow <- TS.size- let width = maybe defaultWidth TS.width mbWindow- progressBar mkPreLabel mkPostLabel width st---- | Print a progress bar to a file handle.------ Erases the current line! (by outputting '\r') Does not print a--- newline '\n'. Subsequent invocations will overwrite the previous--- output.-hProgressBar :: HasProgress s => Handle -> ProgressBar s (IO ())-hProgressBar hndl mkPreLabel mkPostLabel width st = do- hPutChar hndl '\r'- hPutStr hndl $ mkProgressBar mkPreLabel mkPostLabel width st- hFlush hndl---- | Renders a progress bar------ >>> mkProgressBar (msg "Working") percentage 40 30 100--- "Working [=======>.................] 30%"-mkProgressBar :: (HasProgress s) => ProgressBar s String-mkProgressBar mkPreLabel mkPostLabel width st =- printf "%s%s[%s%s%s]%s%s"- preLabel- prePad- (genericReplicate completed '=')- (if remaining /= 0 && completed /= 0 then ">" else "")- (genericReplicate (remaining - if completed /= 0 then 1 else 0)- '.'- )- postPad- postLabel- where- progress = getProgress st- todo = progressTodo progress- done = progressDone progress-- -- Amount of work completed.- fraction :: Rational- fraction | todo /= 0 = done % todo- | otherwise = 0 % 1-- -- Amount of characters available to visualize the progress.- effectiveWidth = max 0 $ width - usedSpace- usedSpace = 2 + genericLength preLabel- + genericLength postLabel- + genericLength prePad- + genericLength postPad-- -- Number of characters needed to represent the amount of work- -- that is completed. Note that this can not always be represented- -- by an integer.- numCompletedChars :: Rational- numCompletedChars = fraction * (effectiveWidth % 1)-- completed, remaining :: Integer- completed = min effectiveWidth $ floor numCompletedChars- remaining = effectiveWidth - completed-- preLabel, postLabel :: String- preLabel = mkPreLabel st- postLabel = mkPostLabel st-- prePad, postPad :: String- prePad = pad preLabel- postPad = pad postLabel-- pad :: String -> String- pad s | null s = ""- | otherwise = " "---- | State of a progress bar.-data Progress- = Progress- { progressDone :: !Integer- -- ^ Amount of work completed.- , progressTodo :: !Integer- -- ^ Total amount of work.- }---- | Types that can represent progress.------ Any progress bar state that implements this class can be used by--- the default label functions.-class HasProgress a where- getProgress :: a -> Progress--instance HasProgress Progress where- getProgress = id---- | A label that can be pre- or postfixed to a progress bar.-type Label s- = s -- ^ Current progress bar state.- -> String -- ^ Resulting label.---- | The empty label.------ >>> noLabel st--- ""-noLabel :: Label s-noLabel = msg ""---- | A label consisting of a static string.------ >>> msg "foo" st--- "foo"-msg :: String -> Label s-msg s _ = s---- | A label which displays the progress as a percentage.------ Constant width property:--- ∀ d t : ℕ. d ≤ t → length (percentage d t) ≡ 4------ >>> percentage 30 100--- " 30%"------ __Note__: if no work is to be done (todo == 0) the percentage will--- always be 100%.---- ∀ d t : ℕ. d ≤ t -> length (percentage d t) ≡ 3-percentage :: HasProgress s => Label s-percentage s- | todo == 0 = "100%"- | otherwise = printf "%3i%%" (round (done % todo * 100) :: Integer)- where- done = progressDone progress- todo = progressTodo progress- progress = getProgress s---- | A label which displays the progress as a fraction of the total--- amount of work.------ Equal width property:--- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t → length (exact d₁ t) ≡ length (exact d₂ t)------ >>> exact (30, 100)--- " 30/100"---- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t -> length (exact d₁ t) ≡ length (exact d₂ t)-exact :: HasProgress s => Label s-exact s = printf "%*i/%s" (length totalStr) done totalStr- where- totalStr = show todo- done = progressDone progress- todo = progressTodo progress- progress = getProgress s----- * Auto-Printing Progress--data ProgressRef s- = ProgressRef- { prPrefix :: !(Label s)- , prPostfix :: !(Label s)- , prWidth :: !Integer- , prState :: !(TVar s)- , prQueue :: !(TMQueue (s -> s))- }---- | Start a thread to automatically display progress. Use incProgress to step--- the progress bar.-startProgress- :: (HasProgress s)- => Label s -- ^ Prefixed label.- -> Label s -- ^ Postfixed label.- -> Integer -- ^ Total progress bar width in characters.- -> s -- ^ Init state- -> IO (ProgressRef s, Async ())-startProgress mkPreLabel mkPostLabel width st = do- pr <- buildProgressRef- a <- async $ reportProgress pr- return (pr, a)- where- buildProgressRef = do- tvSt <- atomically $ newTVar st- queue <- atomically $ newTMQueue- return $ ProgressRef mkPreLabel mkPostLabel width tvSt queue---- | Increment the progress bar. Negative values will reverse the progress.--- Progress will never be negative and will silently stop taking data--- when it completes.-incProgress :: ProgressRef s -> (s -> s) -> IO ()-incProgress progressRef =- atomically . writeTMQueue (prQueue progressRef)--reportProgress :: (HasProgress s) => ProgressRef s -> IO ()-reportProgress pr = do- continue <- atomically $ updateProgress pr- renderProgress pr- when continue $ reportProgress pr--updateProgress :: (HasProgress s) => ProgressRef s -> STM Bool-updateProgress pr =- maybe dontContinue doUpdate =<< readTMQueue (prQueue pr)- where- dontContinue = return False- doUpdate updateState = do- st <- readTVar $ prState pr- let newState = updateState st- progress = getProgress newState- todo = progressTodo progress- done = progressDone progress- let newDone = min todo $ max 0 done- writeTVar (prState pr) newState- if newDone >= todo- then closeTMQueue (prQueue pr) >> dontContinue- else return True--renderProgress :: (HasProgress s) => ProgressRef s -> IO ()-renderProgress pr = do- st <- atomically $ readTVar $ prState pr- autoProgressBar- (prPrefix pr)- (prPostfix pr)- (prWidth pr)- st
terminal-progress-bar.cabal view
@@ -1,11 +1,11 @@ name: terminal-progress-bar-version: 0.2+version: 0.4 cabal-version: >=1.10 build-type: Simple stability: provisional author: Roel van Dijk <vandijk.roel@gmail.com> maintainer: Roel van Dijk <vandijk.roel@gmail.com>-copyright: 2012–2018 Roel van Dijk <vandijk.roel@gmail.com>+copyright: 2012–2019 Roel van Dijk <vandijk.roel@gmail.com> license: BSD3 license-file: LICENSE category: System, User Interfaces@@ -17,8 +17,7 @@ package implements a very simple textual progress bar. . See the module 'System.ProgressBar' on how to use the progress bar- or build the package with the -fexample flag for a small example- program.+ or look at the terminal-progress-bar-example package. . The animated progress bar depends entirely on the interpretation of the carriage return character (\'\\r\'). If your terminal interprets@@ -31,20 +30,15 @@ type: git location: git://github.com/roelvandijk/terminal-progress-bar.git -flag example- description: Build a small example program.- default: False- library hs-source-dirs: src build-depends:- async >= 2.1.1- , base >= 3.0.3.1 && < 5- , stm >= 2.4- , stm-chans >= 3.0.0+ base >= 4.5 && < 5+ , deepseq >= 1.4.3 , terminal-size >= 0.3.2+ , text >= 1.2+ , time >= 1.8 exposed-modules: System.ProgressBar- System.ProgressBar.State ghc-options: -Wall default-language: Haskell2010 @@ -54,24 +48,24 @@ hs-source-dirs: test ghc-options: -Wall build-depends:- base >= 3.0.3.1 && < 5+ base >= 4.5 && < 5 , HUnit >= 1.2.4.2 , terminal-progress-bar , test-framework >= 0.3.3 , test-framework-hunit >= 0.2.6+ , text >= 1.2+ , time >= 1.8 default-language: Haskell2010 -executable example- main-is: example.hs- hs-source-dirs: .- ghc-options: -Wall- if flag(example)- build-depends:- async >= 2.1.1- , base >= 3.0.3.1 && < 5- , random >= 1.1- , terminal-progress-bar- buildable: True- else- buildable: False+benchmark bench-terminal-progress-bar+ type: exitcode-stdio-1.0+ main-is: bench.hs+ hs-source-dirs: bench++ build-depends:+ base >= 4.5 && < 5+ , criterion >= 1.1.4+ , terminal-progress-bar+ , time >= 1.8+ ghc-options: -Wall -O2 default-language: Haskell2010
test/test.hs view
@@ -1,3 +1,4 @@+{-# language OverloadedStrings #-} {-# language PackageImports #-} module Main where@@ -7,11 +8,14 @@ -------------------------------------------------------------------------------- import "base" System.Environment ( getArgs )+import "base" Data.Semigroup ( (<>) ) import "HUnit" Test.HUnit.Base ( assertEqual ) import "test-framework" Test.Framework ( defaultMainWithOpts, interpretArgsOrExit, Test, testGroup ) import "test-framework-hunit" Test.Framework.Providers.HUnit ( testCase ) import "terminal-progress-bar" System.ProgressBar+import qualified "text" Data.Text.Lazy as TL+import "time" Data.Time.Clock ( UTCTime(..), NominalDiffTime ) -------------------------------------------------------------------------------- -- Test suite@@ -24,46 +28,75 @@ tests :: [Test] tests = [ testGroup "Label padding"- [ eqTest "no labels" "[]" noLabel noLabel 0 $ Progress 0 0- , eqTest "pre" "pre []" (msg "pre") noLabel 0 $ Progress 0 0- , eqTest "post" "[] post" noLabel (msg "post") 0 $ Progress 0 0- , eqTest "pre & post" "pre [] post" (msg "pre") (msg "post") 0 $ Progress 0 0+ [ eqTest "no labels" "[]" mempty mempty 0 $ Progress 0 0 ()+ , eqTest "pre" "pre []" (msg "pre") mempty 0 $ Progress 0 0 ()+ , eqTest "post" "[] post" mempty (msg "post") 0 $ Progress 0 0 ()+ , eqTest "pre & post" "pre [] post" (msg "pre") (msg "post") 0 $ Progress 0 0 () ] , testGroup "Bar fill"- [ eqTest "empty" "[....]" noLabel noLabel 6 $ Progress 0 1- , eqTest "almost half" "[=>..]" noLabel noLabel 6 $ Progress 49 100- , eqTest "half" "[==>.]" noLabel noLabel 6 $ Progress 1 2- , eqTest "almost full" "[===>]" noLabel noLabel 6 $ Progress 99 100- , eqTest "full" "[====]" noLabel noLabel 6 $ Progress 1 1- , eqTest "overfull" "[====]" noLabel noLabel 6 $ Progress 2 1+ [ eqTest "empty" "[....]" mempty mempty 6 $ Progress 0 1 ()+ , eqTest "almost half" "[=>..]" mempty mempty 6 $ Progress 49 100 ()+ , eqTest "half" "[==>.]" mempty mempty 6 $ Progress 1 2 ()+ , eqTest "almost full" "[===>]" mempty mempty 6 $ Progress 99 100 ()+ , eqTest "full" "[====]" mempty mempty 6 $ Progress 1 1 ()+ , eqTest "overfull" "[====]" mempty mempty 6 $ Progress 2 1 () ] , testGroup "Labels" [ testGroup "Percentage"- [ eqTest " 0%" " 0% [....]" percentage noLabel 11 $ Progress 0 1- , eqTest "100%" "100% [====]" percentage noLabel 11 $ Progress 1 1- , eqTest " 50%" " 50% [==>.]" percentage noLabel 11 $ Progress 1 2- , eqTest "200%" "200% [====]" percentage noLabel 11 $ Progress 2 1- , labelTest "0 work todo" percentage (Progress 10 0) "100%"+ [ eqTest " 0%" " 0% [....]" percentage mempty 11 $ Progress 0 1 ()+ , eqTest "100%" "100% [====]" percentage mempty 11 $ Progress 1 1 ()+ , eqTest " 50%" " 50% [==>.]" percentage mempty 11 $ Progress 1 2 ()+ , eqTest "200%" "200% [====]" percentage mempty 11 $ Progress 2 1 ()+ , labelTest "0 work todo" percentage (Progress 10 0 ()) "100%" ] , testGroup "Exact"- [ eqTest "0/0" "0/0 [....]" exact noLabel 10 $ Progress 0 0- , eqTest "1/1" "1/1 [====]" exact noLabel 10 $ Progress 1 1- , eqTest "1/2" "1/2 [==>.]" exact noLabel 10 $ Progress 1 2- , eqTest "2/1" "2/1 [====]" exact noLabel 10 $ Progress 2 1- , labelTest "0 work todo" exact (Progress 10 0) "10/0"+ [ eqTest "0/0" "0/0 [....]" exact mempty 10 $ Progress 0 0 ()+ , eqTest "1/1" "1/1 [====]" exact mempty 10 $ Progress 1 1 ()+ , eqTest "1/2" "1/2 [==>.]" exact mempty 10 $ Progress 1 2 ()+ , eqTest "2/1" "2/1 [====]" exact mempty 10 $ Progress 2 1 ()+ , labelTest "0 work todo" exact (Progress 10 0 ()) "10/0" ]+ , testGroup "Label Semigroup"+ [ eqTest "exact <> msg <> percentage"+ "1/2 - 50% [===>...]"+ (exact <> msg " - " <> percentage)+ mempty 20 $ Progress 1 2 ()+ ]+ , testGroup "rendeRuration"+ [ renderDurationTest 42 "42"+ , renderDurationTest (5 * 60 + 42) "05:42"+ , renderDurationTest (8 * 60 * 60 + 5 * 60 + 42) "08:05:42"+ , renderDurationTest (123 * 60 * 60 + 59 * 60 + 59) "123:59:59"+ ] ] ] -labelTest :: String -> Label -> Progress -> String -> Test+labelTest :: String -> Label () -> Progress () -> TL.Text -> Test labelTest testName label progress expected =- testCase testName $ assertEqual expectationError expected (label progress)+ testCase testName $ assertEqual expectationError expected $ runLabel label progress someTiming -eqTest :: String -> String -> Label -> Label -> Integer -> Progress -> Test+renderDurationTest :: NominalDiffTime -> TL.Text -> Test+renderDurationTest dt expected =+ testCase ("renderDuration " <> show dt) $ assertEqual expectationError expected $ renderDuration dt++eqTest :: String -> TL.Text -> Label () -> Label () -> Int -> Progress () -> Test eqTest name expected mkPreLabel mkPostLabel width progress = testCase name $ assertEqual expectationError expected actual where- actual = mkProgressBar mkPreLabel mkPostLabel width progress+ actual = renderProgressBar style progress someTiming++ style :: Style ()+ style = defStyle+ { stylePrefix = mkPreLabel+ , stylePostfix = mkPostLabel+ , styleWidth = ConstantWidth width+ }++someTime :: UTCTime+someTime = UTCTime (toEnum 0) 0++someTiming :: Timing+someTiming = Timing someTime someTime expectationError :: String expectationError = "Expected result doesn't match actual result"