urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-11-28 05:22:27 +03:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #2121 from urbit/kh/better-progress-bar

Browse Source 
Better Progress Bars
This commit is contained in:
benjamin-tlon 2019-12-19 10:22:56 -08:00 committed by GitHub
commit 544fa42f65
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
12 changed files with 961 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkg/hs/king/app/Main.hs
View File

@ -64,7 +64,6 @@ import Noun hiding (Parser)
import Noun.Atom
import Noun.Conversions (cordToUW)
import RIO.Directory
import System.ProgressBar
import Vere.Pier
import Vere.Pier.Types
import Vere.Serf
@ -92,6 +91,7 @@ import qualified EventBrowser as EventBrowser
import qualified Network.HTTP.Client as C
import qualified System.Console.Terminal.Size as TSize
import qualified System.IO.LockFile.Internal as Lock
import qualified System.ProgressBar as PB
import qualified Urbit.Ob as Ob
import qualified Vere.Log as Log
import qualified Vere.Pier as Pier
@ -219,14 +219,14 @@ checkEvs :: forall e. HasLogFunc e => FilePath -> Word64 -> Word64 -> RIO e ()
checkEvs pierPath first last = do
rwith (Log.existing logPath) $ \log -> do
let ident = Log.identity log
let pbSty = defStyle { stylePostfix = exact }
let pbSty = PB.defStyle { PB.stylePostfix = PB.exact }
logTrace (displayShow ident)
last <- Log.lastEv log <&> \lastReal -> min last lastReal
let evCount = fromIntegral (last - first)
print (last, first, evCount)
pb <- io $ newProgressBar pbSty 10 (Progress 1 evCount ())
pb <- PB.newProgressBar pbSty 10 (PB.Progress 1 evCount ())
runConduit $ Log.streamEvents log first
.| showEvents pb first (fromIntegral $ lifecycleLen ident)
@ -234,13 +234,15 @@ checkEvs pierPath first last = do
logPath :: FilePath
logPath = pierPath <> "/.urb/log"
showEvents :: ProgressBar () -> EventId -> EventId
showEvents :: PB.ProgressBar () -> EventId -> EventId
-> ConduitT ByteString Void (RIO e) ()
showEvents pb eId _ | eId > last = pure ()
showEvents pb eId cycle = await >>= \case
Nothing -> lift $ logTrace "Everything checks out."
Nothing -> do
lift $ PB.killProgressBar pb
lift $ logTrace "Everything checks out."
Just bs -> do
io $ incProgress pb 1
lift $ PB.incProgress pb 1
lift $ do
n <- io $ cueBSExn bs
when (eId > cycle) $ do

7
pkg/hs/king/lib/Vere/Serf.hs
View File

@ -359,7 +359,8 @@ replayJob serf job = do
--------------------------------------------------------------------------------
updateProgressBar :: Int -> Text -> Maybe (ProgressBar ())
updateProgressBar :: HasLogFunc e
=> Int -> Text -> Maybe (ProgressBar ())
-> RIO e (Maybe (ProgressBar ()))
updateProgressBar count startMsg = \case
Nothing -> do
@ -368,10 +369,10 @@ updateProgressBar count startMsg = \case
-- bar when the snapshot is caught up to the log.
putStrLn startMsg
let style = defStyle { stylePostfix = exact }
pb <- io $ newProgressBar style 10 (Progress 0 count ())
pb <- newProgressBar style 10 (Progress 0 count ())
pure (Just pb)
Just pb -> do
io $ incProgress pb 1
incProgress pb 1
pure (Just pb)
--------------------------------------------------------------------------------

1
pkg/hs/stack.yaml
View File

@ -4,6 +4,7 @@ packages:
- proto
- king
- lmdb-static
- terminal-progress-bar
extra-deps:
- flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38

1
pkg/hs/terminal-progress-bar/LICENSE Symbolic link
View File

@ -0,0 +1 @@
../LICENSE

1
pkg/hs/terminal-progress-bar/README.markdown Symbolic link
View File

@ -0,0 +1 @@
../README.markdown

2
pkg/hs/terminal-progress-bar/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

51
pkg/hs/terminal-progress-bar/bench/bench.hs Normal file
View File

@ -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

1
pkg/hs/terminal-progress-bar/changelog.md Symbolic link
View File

@ -0,0 +1 @@
../changelog.md

2
pkg/hs/terminal-progress-bar/shell.nix Normal file
View File

@ -0,0 +1,2 @@
(import ../.).haskellPackages.terminal-progress-bar.env
# (import ../.).haskell.packages.ghc844.terminal-progress-bar.env

715
pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs Normal file
View File

@ -0,0 +1,715 @@
{-# 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
( -- * Getting started
-- $start
-- * Example
-- $example
-- * Progress bars
ProgressBar
, newProgressBar
, killProgressBar
, hNewProgressBar
, renderProgressBar
, updateProgress
, incProgress
-- * Options
, Style(..)
, EscapeCode
, OnComplete(..)
, defStyle
, ProgressBarWidth(..)
-- * Progress
, Progress(..)
-- * Labels
, Label(..)
, Timing(..)
, msg
, percentage
, exact
, elapsedTime
, remainingTime
, totalTime
, renderDuration
) where
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 "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 "time" Data.Time.Clock ( UTCTime, NominalDiffTime, diffUTCTime, getCurrentTime )
import ClassyPrelude (liftIO, MVar, newMVar, modifyMVar_)
import RIO (logSticky, logStickyDone, HasLogFunc, RIO, display)
--------------------------------------------------------------------------------
-- | A terminal progress bar.
--
-- 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
}
instance (NFData s) => NFData (ProgressBar s) where
rnf pb = pbStyle pb
`seq` pbStateMv pb
`seq` pbRefreshDelay pb
`seq` pbStartTime pb
`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.
--
-- 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
:: HasLogFunc e
=> Style s -- ^ Visual style of the progress bar.
-> Double -- ^ Maximum refresh rate in Hertz.
-> Progress s -- ^ Initial progress.
-> RIO e (ProgressBar s)
newProgressBar = hNewProgressBar
-- | Creates a progress bar which outputs to the given handle.
--
-- See 'newProgressBar'.
hNewProgressBar
:: HasLogFunc e
=> Style s -- ^ Visual style of the progress bar.
-> Double -- ^ Maximum refresh rate in Hertz.
-> Progress s -- ^ Initial progress.
-> RIO e (ProgressBar s)
hNewProgressBar style maxRefreshRate initProgress = do
style' <- updateWidth style
startTime <- liftIO getCurrentTime
hPutProgressBar style' initProgress (Timing startTime startTime)
stateMv <- newMVar
State
{ stProgress = initProgress
, stRenderTime = startTime
}
pure ProgressBar
{ pbStyle = style'
, pbStateMv = stateMv
, pbRefreshDelay = recip maxRefreshRate
, pbStartTime = startTime
}
-- | Update the width based on the current terminal.
updateWidth :: Style s -> RIO e (Style s)
updateWidth style =
case styleWidth style of
ConstantWidth {} -> pure style
TerminalWidth {} -> do
mbWindow <- liftIO 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 e
. HasLogFunc e
=> ProgressBar s -- ^ Progress bar to update.
-> (Progress s -> Progress s) -- ^ Function to change the progress.
-> RIO e ()
updateProgress progressBar f = do
updateTime <- liftIO getCurrentTime
modifyMVar_ (pbStateMv progressBar) $ renderAndUpdate updateTime
where
renderAndUpdate :: UTCTime -> State s -> RIO e (State s)
renderAndUpdate updateTime state = do
when shouldRender $
hPutProgressBar (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)
-- | Increment the progress of an existing progress bar.
--
-- See 'updateProgress' for more information.
incProgress
:: HasLogFunc e
=> ProgressBar s -- ^ Progress bar which needs an update.
-> Int -- ^ Amount by which to increment the progress.
-> RIO e ()
incProgress pb n = updateProgress pb $ \p -> p{ progressDone = progressDone p + n }
killProgressBar :: HasLogFunc e => ProgressBar s -> RIO e ()
killProgressBar _ = pure ()
hPutProgressBar :: HasLogFunc e => Style s -> Progress s -> Timing -> RIO e ()
hPutProgressBar style progress timing = do
logSticky (display (renderProgressBar style progress timing))
when (progressFinished progress) $ do
logStickyDone ""
-- | Renders a progress bar.
--
-- >>> 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 :: 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
{- | 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.
--
-- 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.
-- | 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.
--
-- 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 is a part of a progress bar that changes based on the progress.
--
-- Labels can be at the front (prefix) or at the back (postfix) of a progress bar.
--
-- 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)
-- | Combining labels combines their output.
instance Semigroup (Label s) where
Label f <> Label g = Label $ \p t -> f p t <> g p t
-- | 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'.
--
-- This information is used by 'Label's to calculate elapsed time, remaining time, total time, etc.
--
-- 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
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
render _progress timing = formatNDT dt
where
dt :: NominalDiffTime
dt = diffUTCTime (timingLastUpdate timing) (timingStart timing)
-- | 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
| dt > 1 = formatNDT estimatedRemainingTime
| progressDone progress <= 0 = altMsg
| otherwise = altMsg
where
estimatedRemainingTime = estimatedTotalTime - dt
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)
-- | 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
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
{- $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%
@
-}

72
pkg/hs/terminal-progress-bar/terminal-progress-bar.cabal Normal file
View File

@ -0,0 +1,72 @@
name: terminal-progress-bar
version: 0.4.1
cabal-version: >=1.10
build-type: Simple
author: Roel van Dijk <roel@lambdacube.nl>
maintainer: Roel van Dijk <roel@lambdacube.nl>
copyright: 2012–2019 Roel van Dijk <roel@lambdacube.nl>
license: BSD3
-- ense-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 progress bar in the terminal
description:
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' 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.
-- ra-source-files: LICENSE, README.markdown, changelog.md
source-repository head
type: git
location: git://github.com/roelvandijk/terminal-progress-bar.git
library
hs-source-dirs: src
build-depends:
base >= 4.5 && < 5
, deepseq >= 1.4.3
, terminal-size >= 0.3.2
, text >= 1.2
, time >= 1.8
, rio
, classy-prelude
exposed-modules: System.ProgressBar
ghc-options: -Wall
default-language: Haskell2010
test-suite test-terminal-progress-bar
type: exitcode-stdio-1.0
main-is: test.hs
hs-source-dirs: test
ghc-options: -Wall
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
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

102
pkg/hs/terminal-progress-bar/test/test.hs Normal file
View File

@ -0,0 +1,102 @@
{-# language OverloadedStrings #-}
{-# language PackageImports #-}
module Main where
--------------------------------------------------------------------------------
-- Imports
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
main :: IO ()
main = do opts <- interpretArgsOrExit =<< getArgs
defaultMainWithOpts tests opts
tests :: [Test]
tests =
[ testGroup "Label padding"
[ 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" "[....]" 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 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 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 () -> TL.Text -> Test
labelTest testName label progress expected =
testCase testName $ assertEqual expectationError expected $ runLabel label progress someTiming
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 = 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"