diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2012–2017 Roel van Dijk +Copyright 2012–2023 Roel van Dijk and project contributors All rights reserved. diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,15 @@ +### 0.4.2 + +* Fixed divide by zero error in remainingTime label (thanks to daniel-chambers). + +### 0.4.1 + +* Added styleOnComplete field to Style record. Defaults to + WriteNewLine. Gives the ability to clear the progress bar once + finished. + +* Added this changelog. + +#### 0.4.0.2 + +* Improved documentation diff --git a/example.hs b/example.hs deleted file mode 100644 --- a/example.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Main where - -import "base" Control.Concurrent ( threadDelay ) -import "base" Control.Monad ( forM_ ) -import "terminal-progress-bar" System.ProgressBar - ( progressBar, percentage, exact, startProgress, incProgress ) - -main :: IO () -main = do - example 60 (13 + 60) 25000 - example' 60 (13 + 60) 25000 - -example :: Integer -> Integer -> Int -> IO () -example t w delay = do - forM_ [1..t] $ \d -> do - progressBar percentage exact w d t - threadDelay delay - putStrLn "" - -example' :: Integer -> Integer -> Int -> IO () -example' t w delay = do - (pr, _) <- startProgress percentage exact w t - forM_ [1..t] $ \_d -> do - incProgress pr 1 - threadDelay delay - putStrLn "" diff --git a/src/System/ProgressBar.hs b/src/System/ProgressBar.hs --- a/src/System/ProgressBar.hs +++ b/src/System/ProgressBar.hs @@ -1,216 +1,721 @@ -{-# language PackageImports, NamedFieldPuns, RecordWildCards #-} +{-# language DeriveGeneric #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language OverloadedStrings #-} +{-# language PackageImports #-} +{-# language ScopedTypeVariables #-} +{- | +A progress bar in the terminal. + +A progress bar conveys the progress of a task. Use a progress bar to +provide a visual cue that processing is underway. +-} module System.ProgressBar - ( -- * Progress bars + ( -- * Getting started + -- $start + + -- * Example + -- $example + + -- * Progress bars ProgressBar - , progressBar - , hProgressBar - , mkProgressBar + , newProgressBar + , hNewProgressBar + , renderProgressBar + , updateProgress + , incProgress + -- * Options + , Style(..) + , EscapeCode + , OnComplete(..) + , defStyle + , ProgressBarWidth(..) + -- * Progress + , Progress(..) -- * Labels - , Label - , noLabel + , Label(..) + , Timing(..) , msg , percentage , exact - -- * Auto printing - , ProgressRef - , startProgress - , incProgress + , elapsedTime + , remainingTime + , totalTime + , renderDuration ) where +import "base" Control.Concurrent.MVar ( MVar, newMVar, modifyMVar_) 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 "base" Control.Concurrent ( ThreadId, forkIO ) -import "stm" Control.Concurrent.STM - ( TVar, readTVar, writeTVar, newTVar, atomically, STM ) -import "stm-chans" Control.Concurrent.STM.TMQueue - ( TMQueue, readTMQueue, closeTMQueue, writeTMQueue, newTMQueue ) +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. - -> Integer -- ^ Amount of work completed. - -> Integer -- ^ Total amount of work. - -> a +-------------------------------------------------------------------------------- --- | Print a progress bar to 'stderr' +-- | A terminal progress bar. -- --- See 'hProgressBar'. -progressBar :: ProgressBar (IO ()) -progressBar = hProgressBar stderr +-- A 'ProgressBar' value contains the state of a progress bar. +-- +-- Create a progress bar with 'newProgressBar' or 'hNewProgressBar'. +-- Update a progress bar with 'updateProgress' or 'incProgress'. +data ProgressBar s + = ProgressBar + { pbStyle :: !(Style s) + , pbStateMv :: !(MVar (State s)) + , pbRefreshDelay :: !Double + , pbStartTime :: !UTCTime + , pbHandle :: !Handle + } --- | Print a progress bar to a file handle. +instance (NFData s) => NFData (ProgressBar s) where + rnf pb = pbStyle pb + `seq` pbStateMv pb + `seq` pbRefreshDelay pb + `seq` pbStartTime pb + -- pbHandle is ignored + `seq` () + +-- | State of a progress bar. +data State s + = State + { stProgress :: !(Progress s) + -- ^ Current progress. + , stRenderTime :: !UTCTime + -- ^ Moment in time of last render. + } + +-- | An amount of progress. +data Progress s + = Progress + { progressDone :: !Int + -- ^ Amount of work completed. + , progressTodo :: !Int + -- ^ Total amount of work. + , progressCustom :: !s + -- ^ A value which is used by custom labels. The builtin labels + -- do not care about this field. You can ignore it by using the + -- unit value '()'. + } + +progressFinished :: Progress s -> Bool +progressFinished p = progressDone p >= progressTodo p + +-- | Creates a progress bar. -- --- 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 hndl mkPreLabel mkPostLabel width todo done = do - hPutChar hndl '\r' - hPutStr hndl $ mkProgressBar mkPreLabel mkPostLabel width todo done +-- The progress bar is drawn immediately. Update the progress bar with +-- 'updateProgress' or 'incProgress'. Do not output anything to your +-- terminal between updates. It will mess up the animation. +-- +-- The progress bar is written to 'stderr'. Write to another handle +-- with 'hNewProgressBar'. +newProgressBar + :: Style s -- ^ Visual style of the progress bar. + -> Double -- ^ Maximum refresh rate in Hertz. + -> Progress s -- ^ Initial progress. + -> IO (ProgressBar s) +newProgressBar = hNewProgressBar stderr + +-- | Creates a progress bar which outputs to the given handle. +-- +-- See 'newProgressBar'. +hNewProgressBar + :: Handle + -- ^ File handle on which the progress bar is drawn. Usually + -- you select a standard stream like 'stderr' or 'stdout'. + -> Style s -- ^ Visual style of the progress bar. + -> 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 + } + +-- | Update the width based on the current terminal. +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) } + +-- | Change the progress of a progress bar. +-- +-- This function is thread safe. Multiple threads may update a single +-- progress bar at the same time. +-- +-- There is a maximum refresh rate. This means that some updates might not be drawn. +updateProgress + :: forall s + . ProgressBar s -- ^ Progress bar to update. + -> (Progress s -> Progress s) -- ^ Function to change the progress. + -> 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 + +-- | Increment the progress of an existing progress bar. +-- +-- See 'updateProgress' for more information. +incProgress + :: ProgressBar s -- ^ Progress bar which needs an update. + -> Int -- ^ Amount by which to increment the progress. + -> 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 case styleOnComplete style of + WriteNewline -> "\n" + -- Move to beginning of line and then clear everything to + -- the right of the cursor. + Clear -> "\r\ESC[K" + else "\r" hFlush hndl --- | Renders a progress bar +-- | Renders a progress bar. -- --- >>> mkProgressBar (msg "Working") percentage 40 30 100 --- "Working [=======>.................] 30%" -mkProgressBar :: ProgressBar String -mkProgressBar mkPreLabel mkPostLabel width todo done = - 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 +-- >>> let t = UTCTime (ModifiedJulianDay 0) 0 +-- >>> renderProgressBar defStyle (Progress 30 100 ()) (Timing t t) +-- "[============>..............................] 30%" +-- +-- Note that this function can not use 'TerminalWidth' because it +-- doesn't use 'IO'. Use 'newProgressBar' or 'hNewProgressBar' to get +-- automatic width. +renderProgressBar + :: Style s + -> Progress s -- ^ Current progress. + -> Timing -- ^ Timing information. + -> TL.Text -- ^ Textual representation of the 'Progress' in the given 'Style'. +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 + -- Amount of work completed. - fraction :: Rational - fraction | done /= 0 = todo % done + fraction :: Ratio Int64 + 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 + -- 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 :: Rational + numCompletedChars :: Ratio Int64 numCompletedChars = fraction * (effectiveWidth % 1) - completed, remaining :: Integer + completed, remaining :: Int64 completed = min effectiveWidth $ floor numCompletedChars remaining = effectiveWidth - completed - preLabel, postLabel :: String - preLabel = mkPreLabel todo done - postLabel = mkPostLabel todo done + prefixLabel, postfixLabel :: TL.Text + prefixLabel = runLabel (stylePrefix style) progress timing + postfixLabel = runLabel (stylePostfix style) progress timing - prePad, postPad :: String - prePad = pad preLabel - postPad = pad postLabel + prefixPad, postfixPad :: TL.Text + prefixPad = pad prefixLabel + postfixPad = pad postfixLabel - pad :: String -> String - pad s | null s = "" - | otherwise = " " +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) --- | A label that can be pre- or postfixed to a progress bar. -type Label - = Integer -- ^ Completed amount of work. - -> Integer -- ^ Total amount of work. - -> String -- ^ Resulting label. +instance NFData ProgressBarWidth --- | The empty label. +getProgressBarWidth :: ProgressBarWidth -> Int +getProgressBarWidth (ConstantWidth n) = n +getProgressBarWidth (TerminalWidth n) = n + +{- | Visual style of a progress bar. + +The style determines how a progress bar is rendered to text. + +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' +, 'styleOnComplete' = 'WriteNewline' +} +@ +-} +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. + , styleOnComplete :: !OnComplete + -- ^ What happens when progress is finished. + } 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. -- --- >>> noLabel 30 100 --- "" -noLabel :: Label -noLabel = msg "" +-- 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. --- | A label consisting of a static string. +-- | What happens when a progress bar is finished. +data OnComplete + = WriteNewline + -- ^ Write a new line when the progress bar is finished. The + -- completed progress bar will remain visible. + | Clear -- ^ Clear the progress bar once it is finished. + deriving (Generic) + +instance NFData OnComplete + +-- | The default style. -- --- >>> msg "foo" 30 100 --- "foo" -msg :: String -> Label -msg s _ _ = s +-- This style shows the progress as a percentage. It does not use any +-- escape sequences. +-- +-- Override some fields of the default instead of specifying all the +-- fields of a 'Style' record. +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 + , styleOnComplete = WriteNewline + } --- | A label which displays the progress as a percentage. +-- | A label is a part of a progress bar that changes based on the progress. -- --- Constant width property: --- ∀ d t : ℕ. d ≤ t → length (percentage d t) ≡ 4 +-- Labels can be at the front (prefix) or at the back (postfix) of a progress bar. -- --- >>> percentage 30 100 --- " 30%" +-- Labels can use both the current amount of progress and the timing +-- information to generate some text. +newtype Label s = Label{ runLabel :: Progress s -> Timing -> TL.Text } deriving (NFData) --- ∀ d t : ℕ. d ≤ t -> length (percentage d t) ≡ 3 -percentage :: Label -percentage done todo = printf "%3i%%" (round (done % todo * 100) :: Integer) +-- | Combining labels combines their output. +instance Semigroup (Label s) where + Label f <> Label g = Label $ \p t -> f p t <> g p t --- | A label which displays the progress as a fraction of the total --- amount of work. +-- | The mempty label always outputs an empty text. +instance Monoid (Label s) where + mempty = msg TL.empty + mappend = (<>) + +-- | Every string is a label which ignores its input and just outputs +-- that string. +instance IsString (Label s) where + fromString = msg . TL.pack + +-- | Timing information about a 'ProgressBar'. -- --- Equal width property: --- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t → length (exact d₁ t) ≡ length (exact d₂ t) +-- This information is used by 'Label's to calculate elapsed time, remaining time, total time, etc. -- --- >>> exact 30 100 +-- See 'elapsedTime', 'remainingTime' and 'totalTime'. +data Timing + = Timing + { timingStart :: !UTCTime + -- ^ Moment in time when a progress bar was created. See + -- 'newProgressBar'. + , timingLastUpdate :: !UTCTime + -- ^ Moment in time of the most recent progress update. + } + +-- | Static text. +-- +-- The output does not depend on the input. +-- +-- >>> msg "foo" st +-- "foo" +msg :: TL.Text -> Label s +msg s = Label $ \_ _ -> s + +-- | Progress as a percentage. +-- +-- >>> runLabel $ percentage (Progress 30 100 ()) someTiming +-- " 30%" +-- +-- __Note__: if no work is to be done (todo == 0) the percentage will +-- be shown as 100%. +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 + +-- | Progress as a fraction of the total amount of work. +-- +-- >>> 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 done total = printf "%*i/%s" (length totalStr) done totalStr + done = progressDone progress + todo = progressTodo progress + +-- | 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 - totalStr = show total + render _progress timing = formatNDT dt + where + dt :: NominalDiffTime + dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) --- * Auto-Printing Progress +-- | Estimated remaining time. +-- +-- Tells you how much longer some task is expected to take. +-- +-- This label uses a 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. Use 'renderDuration' or @formatTime@ from +-- the time >= 1.9 package. +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 + | progressDone progress <= 0 = altMsg + | dt > 1 = formatNDT estimatedRemainingTime + | otherwise = altMsg + where + estimatedRemainingTime = estimatedTotalTime - dt + estimatedTotalTime = dt * recip progressFraction -data ProgressRef - = ProgressRef - { prPrefix :: Label - , prPostfix :: Label - , prWidth :: Integer - , prCompleted :: TVar Integer - , prTotal :: Integer - , prQueue :: TMQueue Integer - } + progressFraction :: NominalDiffTime + progressFraction + | progressTodo progress <= 0 = 1 + | otherwise = fromIntegral (progressDone progress) + / fromIntegral (progressTodo progress) --- | 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. - -> Integer -- ^ Total amount of work. - -> IO (ProgressRef, ThreadId) -startProgress mkPreLabel mkPostLabel width total = do - pr <- buildProgressRef - tid <- forkIO $ reportProgress pr - return (pr, tid) - where - buildProgressRef = do - completed <- atomically $ newTVar 0 - queue <- atomically $ newTMQueue - return $ ProgressRef mkPreLabel mkPostLabel width completed total queue + dt :: NominalDiffTime + dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) --- | 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 progressRef = - atomically . writeTMQueue (prQueue progressRef) +-- | Estimated total time. +-- +-- This label uses a 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 the time >= 1.9 package. +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 -reportProgress :: ProgressRef -> IO () -reportProgress pr = do - continue <- atomically $ updateProgress pr - renderProgress pr - when continue $ reportProgress pr + progressFraction :: NominalDiffTime + progressFraction + | progressTodo progress <= 0 = 1 + | otherwise = fromIntegral (progressDone progress) + / fromIntegral (progressTodo progress) -updateProgress :: ProgressRef -> STM Bool -updateProgress ProgressRef {prCompleted, prQueue, prTotal} = do - maybe dontContinue doUpdate =<< readTMQueue prQueue - where - dontContinue = return False - doUpdate countDiff = do - count <- readTVar prCompleted - let newCount = min prTotal $ max 0 $ count + countDiff - writeTVar prCompleted newCount - if newCount >= prTotal - then closeTMQueue prQueue >> dontContinue - else return True + dt :: NominalDiffTime + dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) -renderProgress :: ProgressRef -> IO () -renderProgress ProgressRef {..} = do - completed <- atomically $ readTVar prCompleted - progressBar prPrefix prPostfix prWidth completed prTotal +-- | 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 + +{- $start + +You want to perform some task which will take some time. You wish to +show the progress of this task in the terminal. + + 1. Determine the total amount of work + + 2. Create a progress bar with 'newProgressBar' + + 3. For each unit of work: + + 3a. Perform the work + + 3b. Update the progress bar with 'incProgress' + +Explore the 'Style' and the 'Label' types to see various ways in which +you can customize the progress bar. + +You do not have to close the progress bar, or even finish the task. It +is perfectly fine to stop half way (maybe your task throws an +exception). + +Just remember to avoid outputting text to the terminal while a +progress bar is active. It will mess up the output a bit. +-} + +{- $example + +Write a function which represents a unit of work. This could be a file +copy operation, a network operation or some other expensive +calculation. This example simply waits 1 second. + +@ + work :: IO () + work = threadDelay 1000000 -- 1 second +@ + +And you define some work to be done. This could be a list of files to +process or some jobs that need to be processed. + +@ + toBeDone :: [()] + toBeDone = replicate 20 () +@ + +Now create the progress bar. Use the default style and choose a +maximum refresh rate of 10 Hz. The initial progress is 0 work done out +of 20. + +@ + pb <- 'newProgressBar' 'defStyle' 10 ('Progress' 0 20 ()) +@ + +Start performing the work while keeping the user informed of the progress: + +@ + for_ toBeDone $ \() -> do + work -- perform 1 unit of work + 'incProgress' pb 1 -- increment progress by 1 +@ + +That's it! You get a nice animated progress bar in your terminal. It +will look like this: + +@ +[==========>................................] 25% +@ +-} diff --git a/terminal-progress-bar.cabal b/terminal-progress-bar.cabal --- a/terminal-progress-bar.cabal +++ b/terminal-progress-bar.cabal @@ -1,45 +1,42 @@ name: terminal-progress-bar -version: 0.1.1.1 +version: 0.4.2 cabal-version: >=1.10 build-type: Simple -stability: provisional -author: Roel van Dijk -maintainer: Roel van Dijk -copyright: 2012–2014 Roel van Dijk +author: Roel van Dijk +maintainer: Roel van Dijk +copyright: 2012–2019 Roel van Dijk license: BSD3 license-file: LICENSE category: System, User Interfaces homepage: https://github.com/roelvandijk/terminal-progress-bar bug-reports: https://github.com/roelvandijk/terminal-progress-bar/issues -synopsis: A simple progress bar in the terminal +synopsis: A progress bar in the terminal description: - A progress bar is used to convey the progress of a task. This - package implements a very simple textual progress bar. + A progress bar conveys the progress of a task. This package + implements a progress bar that is displayed in a terminal. . - 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. + See the module 'System.ProgressBar' to get started 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 it as something else than \"move cursor to beginning of line\", the animation won't work. -extra-source-files: LICENSE, README.markdown +extra-source-files: LICENSE, README.markdown, changelog.md source-repository head 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: base >= 3.0.3.1 && < 5.0 - , stm >= 2.4 && < 3.0 - , stm-chans >= 3.0.0 && < 4.0 + build-depends: + base >= 4.5 && < 5 + , deepseq >= 1.4.3 + , terminal-size >= 0.3.2 + , text >= 1.2 + , time >= 1.8 exposed-modules: System.ProgressBar ghc-options: -Wall default-language: Haskell2010 @@ -49,21 +46,25 @@ main-is: test.hs hs-source-dirs: test ghc-options: -Wall - build-depends: base >= 3.0.3.1 && < 5.0 - , HUnit >= 1.2.4.2 && < 1.6 - , terminal-progress-bar - , test-framework >= 0.3.3 && < 0.9 - , test-framework-hunit >= 0.2.6 && < 0.4 + build-depends: + 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: base >= 3.0.3.1 && < 5.0 - , 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 diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,3 +1,4 @@ +{-# language OverloadedStrings #-} {-# language PackageImports #-} module Main where @@ -7,12 +8,15 @@ -------------------------------------------------------------------------------- import "base" System.Environment ( getArgs ) +import "base" Data.Semigroup ( (<>) ) +import "base" Data.Fixed (Pico) 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 - ( mkProgressBar, Label, noLabel, msg, percentage, exact ) +import qualified "text" Data.Text.Lazy as TL +import "time" Data.Time (UTCTime(..), NominalDiffTime, formatTime, defaultTimeLocale, addUTCTime, secondsToNominalDiffTime) -------------------------------------------------------------------------------- -- Test suite @@ -25,38 +29,95 @@ tests :: [Test] tests = [ testGroup "Label padding" - [ eqTest "no labels" "[]" noLabel noLabel 0 0 0 - , eqTest "pre" "pre []" (msg "pre") noLabel 0 0 0 - , eqTest "post" "[] post" noLabel (msg "post") 0 0 0 - , eqTest "pre & post" "pre [] post" (msg "pre") (msg "post") 0 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 0 1 - , eqTest "almost half" "[=>..]" noLabel noLabel 6 49 100 - , eqTest "half" "[==>.]" noLabel noLabel 6 1 2 - , eqTest "almost full" "[===>]" noLabel noLabel 6 99 100 - , eqTest "full" "[====]" noLabel noLabel 6 1 1 - , eqTest "overfull" "[====]" noLabel noLabel 6 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 0 1 - , eqTest "100%" "100% [====]" percentage noLabel 11 1 1 - , eqTest " 50%" " 50% [==>.]" percentage noLabel 11 1 2 - , eqTest "200%" "200% [====]" percentage noLabel 11 2 1 + [ 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 0 0 - , eqTest "1/1" "1/1 [====]" exact noLabel 10 1 1 - , eqTest "1/2" "1/2 [==>.]" exact noLabel 10 1 2 - , eqTest "2/1" "2/1 [====]" exact noLabel 10 2 1 + [ 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 "renderDuration" + [ 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" + ] + , testGroup "remainingTime" + [ labelTestWithTiming "No progress after no time" remainingTimeLabel (Progress 0 100 ()) (elapsedSecsTiming 0) "Estimating" + , labelTestWithTiming "No progress after some time" remainingTimeLabel (Progress 0 100 ()) (elapsedSecsTiming 10) "Estimating" + , labelTestWithTiming "Some progress after no time" remainingTimeLabel (Progress 50 100 ()) (elapsedSecsTiming 0) "Estimating" + , labelTestWithTiming "Some progress after some time" remainingTimeLabel (Progress 50 100 ()) (elapsedSecsTiming 10) "10" + , labelTestWithTiming "No work to be done after no time" remainingTimeLabel (Progress 0 0 ()) (elapsedSecsTiming 0) "Estimating" + , labelTestWithTiming "No work to be done after some time" remainingTimeLabel (Progress 0 0 ()) (elapsedSecsTiming 10) "Estimating" + , labelTestWithTiming "More progress than work to be done after no time" remainingTimeLabel (Progress 50 0 ()) (elapsedSecsTiming 0) "Estimating" + , labelTestWithTiming "More progress than work to be done after some time" remainingTimeLabel (Progress 50 0 ()) (elapsedSecsTiming 10) "0" + ] ] ] -eqTest :: String -> String -> Label -> Label -> Integer -> Integer -> Integer -> Test -eqTest name expected mkPreLabel mkPostLabel width todo done = - testCase name $ assertEqual errMsg expected actual +labelTest :: String -> Label () -> Progress () -> TL.Text -> Test +labelTest testName label progress expected = + testCase testName $ assertEqual expectationError expected $ runLabel label progress someTiming + +labelTestWithTiming :: String -> Label () -> Progress () -> Timing -> TL.Text -> Test +labelTestWithTiming testName label progress timing expected = + testCase testName $ assertEqual expectationError expected $ runLabel label progress timing + +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 todo done - errMsg = "Expected result doesn't match actual result" + 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 + +elapsedSecsTiming :: Pico -> Timing +elapsedSecsTiming seconds = Timing someTime (addUTCTime (secondsToNominalDiffTime seconds) someTime) + +expectationError :: String +expectationError = "Expected result doesn't match actual result" + +remainingTimeLabel :: Label () +remainingTimeLabel = remainingTime (TL.pack . formatTime defaultTimeLocale "%s") "Estimating"