Vendored terminal-progress-bar.

pkg/hs/stack.yaml

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

pkg/hs/terminal-progress-bar/LICENSE

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

pkg/hs/terminal-progress-bar/README.markdown

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

pkg/hs/terminal-progress-bar/Setup.hs

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

pkg/hs/terminal-progress-bar/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

pkg/hs/terminal-progress-bar/changelog.md

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

pkg/hs/terminal-progress-bar/shell.nix

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

pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs

@@ -0,0 +1,721 @@
+{-# 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
+    , 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.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 )
+
+--------------------------------------------------------------------------------
+
+-- | 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
+     , pbHandle :: !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.
+--
+-- 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.
+--
+-- >>> 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%
+@
+-}

pkg/hs/terminal-progress-bar/terminal-progress-bar.cabal

@@ -0,0 +1,70 @@
+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
+    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

pkg/hs/terminal-progress-bar/test/test.hs

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