{-# 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
     { forall s. ProgressBar s -> Style s
pbStyle :: !(Style s)
     , forall s. ProgressBar s -> MVar (State s)
pbStateMv :: !(MVar (State s))
     , forall s. ProgressBar s -> Double
pbRefreshDelay :: !Double
     , forall s. ProgressBar s -> UTCTime
pbStartTime :: !UTCTime
     , forall s. ProgressBar s -> Handle
pbHandle :: !Handle
     }

instance (NFData s) => NFData (ProgressBar s) where
    rnf :: ProgressBar s -> ()
rnf ProgressBar s
pb =  forall s. ProgressBar s -> Style s
pbStyle ProgressBar s
pb
        seq :: forall a b. a -> b -> b
`seq` forall s. ProgressBar s -> MVar (State s)
pbStateMv ProgressBar s
pb
        seq :: forall a b. a -> b -> b
`seq` forall s. ProgressBar s -> Double
pbRefreshDelay ProgressBar s
pb
        seq :: forall a b. a -> b -> b
`seq` forall s. ProgressBar s -> UTCTime
pbStartTime ProgressBar s
pb
        -- pbHandle is ignored
        seq :: forall a b. a -> b -> b
`seq` ()

-- | State of a progress bar.
data State s
   = State
     { forall s. State s -> Progress s
stProgress :: !(Progress s)
       -- ^ Current progress.
     , forall s. State s -> UTCTime
stRenderTime :: !UTCTime
       -- ^ Moment in time of last render.
     }

-- | An amount of progress.
data Progress s
   = Progress
     { forall s. Progress s -> Int
progressDone :: !Int
       -- ^ Amount of work completed.
     , forall s. Progress s -> Int
progressTodo :: !Int
       -- ^ Total amount of work.
     , forall s. Progress s -> s
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 :: forall s. Progress s -> Bool
progressFinished Progress s
p = forall s. Progress s -> Int
progressDone Progress s
p forall a. Ord a => a -> a -> Bool
>= forall s. Progress s -> Int
progressTodo Progress s
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 :: forall s. Style s -> Double -> Progress s -> IO (ProgressBar s)
newProgressBar = forall s.
Handle -> Style s -> Double -> Progress s -> IO (ProgressBar s)
hNewProgressBar Handle
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 :: forall s.
Handle -> Style s -> Double -> Progress s -> IO (ProgressBar s)
hNewProgressBar Handle
hndl Style s
style Double
maxRefreshRate Progress s
initProgress = do
    Style s
style' <- forall s. Style s -> IO (Style s)
updateWidth Style s
style

    UTCTime
startTime <- IO UTCTime
getCurrentTime
    forall s. Handle -> Style s -> Progress s -> Timing -> IO ()
hPutProgressBar Handle
hndl Style s
style' Progress s
initProgress (UTCTime -> UTCTime -> Timing
Timing UTCTime
startTime UTCTime
startTime)

    MVar (State s)
stateMv <- forall a. a -> IO (MVar a)
newMVar
      State
      { stProgress :: Progress s
stProgress   = Progress s
initProgress
      , stRenderTime :: UTCTime
stRenderTime = UTCTime
startTime
      }
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ProgressBar
         { pbStyle :: Style s
pbStyle = Style s
style'
         , pbStateMv :: MVar (State s)
pbStateMv = MVar (State s)
stateMv
         , pbRefreshDelay :: Double
pbRefreshDelay = forall a. Fractional a => a -> a
recip Double
maxRefreshRate
         , pbStartTime :: UTCTime
pbStartTime = UTCTime
startTime
         , pbHandle :: Handle
pbHandle = Handle
hndl
         }

-- | Update the width based on the current terminal.
updateWidth :: Style s -> IO (Style s)
updateWidth :: forall s. Style s -> IO (Style s)
updateWidth Style s
style =
    case forall s. Style s -> ProgressBarWidth
styleWidth Style s
style of
      ConstantWidth {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Style s
style
      TerminalWidth {} -> do
        Maybe (Window Int)
mbWindow <- forall n. Integral n => IO (Maybe (Window n))
TS.size
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe (Window Int)
mbWindow of
          Maybe (Window Int)
Nothing -> Style s
style
          Just Window Int
window -> Style s
style{ styleWidth :: ProgressBarWidth
styleWidth = Int -> ProgressBarWidth
TerminalWidth (forall a. Window a -> a
TS.width Window Int
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 :: forall s. ProgressBar s -> (Progress s -> Progress s) -> IO ()
updateProgress ProgressBar s
progressBar Progress s -> Progress s
f = do
    UTCTime
updateTime <- IO UTCTime
getCurrentTime
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall s. ProgressBar s -> MVar (State s)
pbStateMv ProgressBar s
progressBar) forall a b. (a -> b) -> a -> b
$ UTCTime -> State s -> IO (State s)
renderAndUpdate UTCTime
updateTime
  where
    renderAndUpdate :: UTCTime -> State s -> IO (State s)
    renderAndUpdate :: UTCTime -> State s -> IO (State s)
renderAndUpdate UTCTime
updateTime State s
state = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
shouldRender forall a b. (a -> b) -> a -> b
$
          forall s. Handle -> Style s -> Progress s -> Timing -> IO ()
hPutProgressBar Handle
hndl (forall s. ProgressBar s -> Style s
pbStyle ProgressBar s
progressBar) Progress s
newProgress Timing
timing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure State
             { stProgress :: Progress s
stProgress = Progress s
newProgress
             , stRenderTime :: UTCTime
stRenderTime = if Bool
shouldRender then UTCTime
updateTime else forall s. State s -> UTCTime
stRenderTime State s
state
             }
      where
        timing :: Timing
timing = Timing
                 { timingStart :: UTCTime
timingStart = forall s. ProgressBar s -> UTCTime
pbStartTime ProgressBar s
progressBar
                 , timingLastUpdate :: UTCTime
timingLastUpdate = UTCTime
updateTime
                 }

        shouldRender :: Bool
shouldRender = Bool -> Bool
not Bool
tooFast Bool -> Bool -> Bool
|| Bool
finished
        tooFast :: Bool
tooFast = Double
secSinceLastRender forall a. Ord a => a -> a -> Bool
<= forall s. ProgressBar s -> Double
pbRefreshDelay ProgressBar s
progressBar
        finished :: Bool
finished = forall s. Progress s -> Bool
progressFinished Progress s
newProgress

        newProgress :: Progress s
newProgress = Progress s -> Progress s
f forall a b. (a -> b) -> a -> b
$ forall s. State s -> Progress s
stProgress State s
state

        -- Amount of time that passed since last render, in seconds.
        secSinceLastRender :: Double
        secSinceLastRender :: Double
secSinceLastRender = forall a b. (Real a, Fractional b) => a -> b
realToFrac forall a b. (a -> b) -> a -> b
$ UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
updateTime (forall s. State s -> UTCTime
stRenderTime State s
state)

    hndl :: Handle
hndl = forall s. ProgressBar s -> Handle
pbHandle ProgressBar s
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 :: forall s. ProgressBar s -> Int -> IO ()
incProgress ProgressBar s
pb Int
n = forall s. ProgressBar s -> (Progress s -> Progress s) -> IO ()
updateProgress ProgressBar s
pb forall a b. (a -> b) -> a -> b
$ \Progress s
p -> Progress s
p{ progressDone :: Int
progressDone = forall s. Progress s -> Int
progressDone Progress s
p forall a. Num a => a -> a -> a
+ Int
n }

hPutProgressBar :: Handle -> Style s -> Progress s -> Timing -> IO ()
hPutProgressBar :: forall s. Handle -> Style s -> Progress s -> Timing -> IO ()
hPutProgressBar Handle
hndl Style s
style Progress s
progress Timing
timing = do
    Handle -> Text -> IO ()
TL.hPutStr Handle
hndl forall a b. (a -> b) -> a -> b
$ forall s. Style s -> Progress s -> Timing -> Text
renderProgressBar Style s
style Progress s
progress Timing
timing
    Handle -> Text -> IO ()
TL.hPutStr Handle
hndl forall a b. (a -> b) -> a -> b
$
      if forall s. Progress s -> Bool
progressFinished Progress s
progress
      then case forall s. Style s -> OnComplete
styleOnComplete Style s
style of
             OnComplete
WriteNewline -> Text
"\n"
             -- Move to beginning of line and then clear everything to
             -- the right of the cursor.
             OnComplete
Clear -> Text
"\r\ESC[K"
      else Text
"\r"
    Handle -> IO ()
hFlush Handle
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 :: forall s. Style s -> Progress s -> Timing -> Text
renderProgressBar Style s
style Progress s
progress Timing
timing = [Text] -> Text
TL.concat
    [ forall s. Style s -> EscapeCode s
styleEscapePrefix Style s
style Progress s
progress
    , Text
prefixLabel
    , Text
prefixPad
    , forall s. Style s -> EscapeCode s
styleEscapeOpen Style s
style Progress s
progress
    , forall s. Style s -> Text
styleOpen Style s
style
    , forall s. Style s -> EscapeCode s
styleEscapeDone Style s
style Progress s
progress
    , Int64 -> Text -> Text
TL.replicate Int64
completed forall a b. (a -> b) -> a -> b
$ Char -> Text
TL.singleton forall a b. (a -> b) -> a -> b
$ forall s. Style s -> Char
styleDone Style s
style
    , forall s. Style s -> EscapeCode s
styleEscapeCurrent Style s
style Progress s
progress
    , if Int64
remaining forall a. Eq a => a -> a -> Bool
/= Int64
0 Bool -> Bool -> Bool
&& Int64
completed forall a. Eq a => a -> a -> Bool
/= Int64
0
      then Char -> Text
TL.singleton forall a b. (a -> b) -> a -> b
$ forall s. Style s -> Char
styleCurrent Style s
style
      else Text
""
    , forall s. Style s -> EscapeCode s
styleEscapeTodo Style s
style Progress s
progress
    , Int64 -> Text -> Text
TL.replicate
        (Int64
remaining forall a. Num a => a -> a -> a
- if Int64
completed forall a. Eq a => a -> a -> Bool
/= Int64
0 then Int64
1 else Int64
0)
        (Char -> Text
TL.singleton forall a b. (a -> b) -> a -> b
$ forall s. Style s -> Char
styleTodo Style s
style)
    , forall s. Style s -> EscapeCode s
styleEscapeClose Style s
style Progress s
progress
    , forall s. Style s -> Text
styleClose Style s
style
    , forall s. Style s -> EscapeCode s
styleEscapePostfix Style s
style Progress s
progress
    , Text
postfixPad
    , Text
postfixLabel
    ]
  where
    todo :: Int64
todo = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall s. Progress s -> Int
progressTodo Progress s
progress
    done :: Int64
done = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall s. Progress s -> Int
progressDone Progress s
progress
    -- Amount of (visible) characters that should be used to display to progress bar.
    width :: Int64
width = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ProgressBarWidth -> Int
getProgressBarWidth forall a b. (a -> b) -> a -> b
$ forall s. Style s -> ProgressBarWidth
styleWidth Style s
style

    -- Amount of work completed.
    fraction :: Ratio Int64
    fraction :: Ratio Int64
fraction | Int64
todo forall a. Eq a => a -> a -> Bool
/= Int64
0 = Int64
done forall a. Integral a => a -> a -> Ratio a
% Int64
todo
             | Bool
otherwise = Int64
0 forall a. Integral a => a -> a -> Ratio a
% Int64
1

    -- Amount of characters available to visualize the progress.
    effectiveWidth :: Int64
effectiveWidth = forall a. Ord a => a -> a -> a
max Int64
0 forall a b. (a -> b) -> a -> b
$ Int64
width forall a. Num a => a -> a -> a
- Int64
usedSpace
    -- Amount of printing characters needed to visualize everything except the bar .
    usedSpace :: Int64
usedSpace =   Text -> Int64
TL.length (forall s. Style s -> Text
styleOpen  Style s
style)
                forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length (forall s. Style s -> Text
styleClose Style s
style)
                forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length Text
prefixLabel
                forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length Text
postfixLabel
                forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length Text
prefixPad
                forall a. Num a => a -> a -> a
+ Text -> Int64
TL.length Text
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 :: Ratio Int64
numCompletedChars = Ratio Int64
fraction forall a. Num a => a -> a -> a
* (Int64
effectiveWidth forall a. Integral a => a -> a -> Ratio a
% Int64
1)

    completed, remaining :: Int64
    completed :: Int64
completed = forall a. Ord a => a -> a -> a
min Int64
effectiveWidth forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor Ratio Int64
numCompletedChars
    remaining :: Int64
remaining = Int64
effectiveWidth forall a. Num a => a -> a -> a
- Int64
completed

    prefixLabel, postfixLabel :: TL.Text
    prefixLabel :: Text
prefixLabel  = forall s. Label s -> Progress s -> Timing -> Text
runLabel (forall s. Style s -> Label s
stylePrefix  Style s
style) Progress s
progress Timing
timing
    postfixLabel :: Text
postfixLabel = forall s. Label s -> Progress s -> Timing -> Text
runLabel (forall s. Style s -> Label s
stylePostfix Style s
style) Progress s
progress Timing
timing

    prefixPad, postfixPad :: TL.Text
    prefixPad :: Text
prefixPad  = Text -> Text
pad Text
prefixLabel
    postfixPad :: Text
postfixPad = Text -> Text
pad Text
postfixLabel

pad :: TL.Text -> TL.Text
pad :: Text -> Text
pad Text
s | Text -> Bool
TL.null Text
s = Text
TL.empty
      | Bool
otherwise = Char -> Text
TL.singleton Char
' '

-- | 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 (forall x. Rep ProgressBarWidth x -> ProgressBarWidth
forall x. ProgressBarWidth -> Rep ProgressBarWidth x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ProgressBarWidth x -> ProgressBarWidth
$cfrom :: forall x. ProgressBarWidth -> Rep ProgressBarWidth x
Generic)

instance NFData ProgressBarWidth

getProgressBarWidth :: ProgressBarWidth -> Int
getProgressBarWidth :: ProgressBarWidth -> Int
getProgressBarWidth (ConstantWidth Int
n) = Int
n
getProgressBarWidth (TerminalWidth Int
n) = Int
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
     { forall s. Style s -> Text
styleOpen :: !TL.Text
       -- ^ Bar opening symbol.
     , forall s. Style s -> Text
styleClose :: !TL.Text
       -- ^ Bar closing symbol
     , forall s. Style s -> Char
styleDone :: !Char
       -- ^ Completed work.
     , forall s. Style s -> Char
styleCurrent :: !Char
       -- ^ Symbol used to denote the current amount of work that has been done.
     , forall s. Style s -> Char
styleTodo :: !Char
       -- ^ Work not yet completed.
     , forall s. Style s -> Label s
stylePrefix :: Label s
       -- ^ Prefixed label.
     , forall s. Style s -> Label s
stylePostfix :: Label s
       -- ^ Postfixed label.
     , forall s. Style s -> ProgressBarWidth
styleWidth :: !ProgressBarWidth
       -- ^ Total width of the progress bar.
     , forall s. Style s -> EscapeCode s
styleEscapeOpen :: EscapeCode s
       -- ^ Escape code printed just before the 'styleOpen' symbol.
     , forall s. Style s -> EscapeCode s
styleEscapeClose :: EscapeCode s
       -- ^ Escape code printed just before the 'styleClose' symbol.
     , forall s. Style s -> EscapeCode s
styleEscapeDone :: EscapeCode s
       -- ^ Escape code printed just before the first 'styleDone' character.
     , forall s. Style s -> EscapeCode s
styleEscapeCurrent :: EscapeCode s
       -- ^ Escape code printed just before the 'styleCurrent' character.
     , forall s. Style s -> EscapeCode s
styleEscapeTodo :: EscapeCode s
       -- ^ Escape code printed just before the first 'styleTodo' character.
     , forall s. Style s -> EscapeCode s
styleEscapePrefix :: EscapeCode s
       -- ^ Escape code printed just before the 'stylePrefix' label.
     , forall s. Style s -> EscapeCode s
styleEscapePostfix :: EscapeCode s
       -- ^ Escape code printed just before the 'stylePostfix' label.
     , forall s. Style s -> OnComplete
styleOnComplete :: !OnComplete
       -- ^ What happens when progress is finished.
     } deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (Style s) x -> Style s
forall s x. Style s -> Rep (Style s) x
$cto :: forall s x. Rep (Style s) x -> Style s
$cfrom :: forall s x. Style s -> Rep (Style s) x
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 (forall x. Rep OnComplete x -> OnComplete
forall x. OnComplete -> Rep OnComplete x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OnComplete x -> OnComplete
$cfrom :: forall x. OnComplete -> Rep OnComplete x
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 :: forall s. Style s
defStyle =
    Style
    { styleOpen :: Text
styleOpen          = Text
"["
    , styleClose :: Text
styleClose         = Text
"]"
    , styleDone :: Char
styleDone          = Char
'='
    , styleCurrent :: Char
styleCurrent       = Char
'>'
    , styleTodo :: Char
styleTodo          = Char
'.'
    , stylePrefix :: Label s
stylePrefix        = forall a. Monoid a => a
mempty
    , stylePostfix :: Label s
stylePostfix       = forall s. Label s
percentage
    , styleWidth :: ProgressBarWidth
styleWidth         = Int -> ProgressBarWidth
TerminalWidth Int
50
    , styleEscapeOpen :: EscapeCode s
styleEscapeOpen    = forall a b. a -> b -> a
const Text
TL.empty
    , styleEscapeClose :: EscapeCode s
styleEscapeClose   = forall a b. a -> b -> a
const Text
TL.empty
    , styleEscapeDone :: EscapeCode s
styleEscapeDone    = forall a b. a -> b -> a
const Text
TL.empty
    , styleEscapeCurrent :: EscapeCode s
styleEscapeCurrent = forall a b. a -> b -> a
const Text
TL.empty
    , styleEscapeTodo :: EscapeCode s
styleEscapeTodo    = forall a b. a -> b -> a
const Text
TL.empty
    , styleEscapePrefix :: EscapeCode s
styleEscapePrefix  = forall a b. a -> b -> a
const Text
TL.empty
    , styleEscapePostfix :: EscapeCode s
styleEscapePostfix = forall a b. a -> b -> a
const Text
TL.empty
    , styleOnComplete :: OnComplete
styleOnComplete    = OnComplete
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{ forall s. Label s -> Progress s -> Timing -> Text
runLabel :: Progress s -> Timing -> TL.Text } deriving (Label s -> ()
forall s. Label s -> ()
forall a. (a -> ()) -> NFData a
rnf :: Label s -> ()
$crnf :: forall s. Label s -> ()
NFData)

-- | Combining labels combines their output.
instance Semigroup (Label s) where
    Label Progress s -> Timing -> Text
f <> :: Label s -> Label s -> Label s
<> Label Progress s -> Timing -> Text
g = forall s. (Progress s -> Timing -> Text) -> Label s
Label forall a b. (a -> b) -> a -> b
$ \Progress s
p Timing
t -> Progress s -> Timing -> Text
f Progress s
p Timing
t forall a. Semigroup a => a -> a -> a
<> Progress s -> Timing -> Text
g Progress s
p Timing
t

-- | The mempty label always outputs an empty text.
instance Monoid (Label s) where
    mempty :: Label s
mempty = forall s. Text -> Label s
msg Text
TL.empty
    mappend :: Label s -> Label s -> Label s
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Every string is a label which ignores its input and just outputs
-- that string.
instance IsString (Label s) where
    fromString :: String -> Label s
fromString = forall s. Text -> Label s
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
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
     { Timing -> UTCTime
timingStart :: !UTCTime
       -- ^ Moment in time when a progress bar was created. See
       -- 'newProgressBar'.
     , Timing -> UTCTime
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 :: forall s. Text -> Label s
msg Text
s = forall s. (Progress s -> Timing -> Text) -> Label s
Label forall a b. (a -> b) -> a -> b
$ \Progress s
_ Timing
_ -> Text
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 :: forall s. Label s
percentage = forall s. (Progress s -> Timing -> Text) -> Label s
Label forall {s} {p}. Progress s -> p -> Text
render
  where
    render :: Progress s -> p -> Text
render Progress s
progress p
_timing
      | Int
todo forall a. Eq a => a -> a -> Bool
== Int
0 = Text
"100%"
      | Bool
otherwise = Int64 -> Char -> Text -> Text
TL.justifyRight Int64
4 Char
' ' forall a b. (a -> b) -> a -> b
$ Builder -> Text
TLB.toLazyText forall a b. (a -> b) -> a -> b
$
                      forall a. Integral a => a -> Builder
TLB.decimal (forall a b. (RealFrac a, Integral b) => a -> b
round (Int
done forall a. Integral a => a -> a -> Ratio a
% Int
todo forall a. Num a => a -> a -> a
* Ratio Int
100) :: Int)
                      forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TLB.singleton Char
'%'
      where
        done :: Int
done = forall s. Progress s -> Int
progressDone Progress s
progress
        todo :: Int
todo = forall s. Progress s -> Int
progressTodo Progress s
progress

-- | Progress as a fraction of the total amount of work.
--
-- >>> runLabel $ exact (Progress 30 100 ()) someTiming
-- " 30/100"
exact :: Label s
exact :: forall s. Label s
exact = forall s. (Progress s -> Timing -> Text) -> Label s
Label forall {s} {p}. Progress s -> p -> Text
render
  where
    render :: Progress s -> p -> Text
render Progress s
progress p
_timing =
        Int64 -> Char -> Text -> Text
TL.justifyRight (Text -> Int64
TL.length Text
todoStr) Char
' ' Text
doneStr forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
todoStr
      where
        todoStr :: Text
todoStr = Builder -> Text
TLB.toLazyText forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Builder
TLB.decimal Int
todo
        doneStr :: Text
doneStr = Builder -> Text
TLB.toLazyText forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Builder
TLB.decimal Int
done

        done :: Int
done = forall s. Progress s -> Int
progressDone Progress s
progress
        todo :: Int
todo = forall s. Progress s -> Int
progressTodo Progress s
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 :: forall s. (NominalDiffTime -> Text) -> Label s
elapsedTime NominalDiffTime -> Text
formatNDT = forall s. (Progress s -> Timing -> Text) -> Label s
Label forall {p}. p -> Timing -> Text
render
  where
    render :: p -> Timing -> Text
render p
_progress Timing
timing = NominalDiffTime -> Text
formatNDT NominalDiffTime
dt
      where
        dt :: NominalDiffTime
        dt :: NominalDiffTime
dt = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (Timing -> UTCTime
timingLastUpdate Timing
timing) (Timing -> UTCTime
timingStart Timing
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 :: forall s. (NominalDiffTime -> Text) -> Text -> Label s
remainingTime NominalDiffTime -> Text
formatNDT Text
altMsg = forall s. (Progress s -> Timing -> Text) -> Label s
Label forall {s}. Progress s -> Timing -> Text
render
  where
    render :: Progress s -> Timing -> Text
render Progress s
progress Timing
timing
        | forall s. Progress s -> Int
progressDone Progress s
progress forall a. Ord a => a -> a -> Bool
<= Int
0 = Text
altMsg
        | NominalDiffTime
dt forall a. Ord a => a -> a -> Bool
> NominalDiffTime
1 = NominalDiffTime -> Text
formatNDT NominalDiffTime
estimatedRemainingTime
        | Bool
otherwise = Text
altMsg
      where
        estimatedRemainingTime :: NominalDiffTime
estimatedRemainingTime = NominalDiffTime
estimatedTotalTime forall a. Num a => a -> a -> a
- NominalDiffTime
dt
        estimatedTotalTime :: NominalDiffTime
estimatedTotalTime = NominalDiffTime
dt forall a. Num a => a -> a -> a
* forall a. Fractional a => a -> a
recip NominalDiffTime
progressFraction

        progressFraction :: NominalDiffTime
        progressFraction :: NominalDiffTime
progressFraction
          | forall s. Progress s -> Int
progressTodo Progress s
progress forall a. Ord a => a -> a -> Bool
<= Int
0 = NominalDiffTime
1
          | Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall s. Progress s -> Int
progressDone Progress s
progress)
                      forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall s. Progress s -> Int
progressTodo Progress s
progress)

        dt :: NominalDiffTime
        dt :: NominalDiffTime
dt = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (Timing -> UTCTime
timingLastUpdate Timing
timing) (Timing -> UTCTime
timingStart Timing
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 :: forall s. (NominalDiffTime -> Text) -> Text -> Label s
totalTime NominalDiffTime -> Text
formatNDT Text
altMsg = forall s. (Progress s -> Timing -> Text) -> Label s
Label forall {s}. Progress s -> Timing -> Text
render
  where
    render :: Progress s -> Timing -> Text
render Progress s
progress Timing
timing
        | NominalDiffTime
dt forall a. Ord a => a -> a -> Bool
> NominalDiffTime
1 = NominalDiffTime -> Text
formatNDT NominalDiffTime
estimatedTotalTime
        | forall s. Progress s -> Int
progressDone Progress s
progress forall a. Ord a => a -> a -> Bool
<= Int
0 = Text
altMsg
        | Bool
otherwise = Text
altMsg
      where
        estimatedTotalTime :: NominalDiffTime
estimatedTotalTime = NominalDiffTime
dt forall a. Num a => a -> a -> a
* forall a. Fractional a => a -> a
recip NominalDiffTime
progressFraction

        progressFraction :: NominalDiffTime
        progressFraction :: NominalDiffTime
progressFraction
          | forall s. Progress s -> Int
progressTodo Progress s
progress forall a. Ord a => a -> a -> Bool
<= Int
0 = NominalDiffTime
1
          | Bool
otherwise = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall s. Progress s -> Int
progressDone Progress s
progress)
                      forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall s. Progress s -> Int
progressTodo Progress s
progress)

        dt :: NominalDiffTime
        dt :: NominalDiffTime
dt = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime (Timing -> UTCTime
timingLastUpdate Timing
timing) (Timing -> UTCTime
timingStart Timing
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 :: NominalDiffTime -> Text
renderDuration NominalDiffTime
dt = Text
hTxt forall a. Semigroup a => a -> a -> a
<> Text
mTxt forall a. Semigroup a => a -> a -> a
<> Text
sTxt
  where
    hTxt :: Text
hTxt | Int
h forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
         | Bool
otherwise = forall {a}. Integral a => a -> Text
renderDecimal Int
h forall a. Semigroup a => a -> a -> a
<> Text
":"
    mTxt :: Text
mTxt | Int
m forall a. Eq a => a -> a -> Bool
== Int
0 = forall a. Monoid a => a
mempty
         | Bool
otherwise = forall {a}. Integral a => a -> Text
renderDecimal Int
m forall a. Semigroup a => a -> a -> a
<> Text
":"
    sTxt :: Text
sTxt = forall {a}. Integral a => a -> Text
renderDecimal Int
s

    (Int
h, Int
hRem) = Int
ts   forall a. Integral a => a -> a -> (a, a)
`quotRem` Int
3600
    (Int
m, Int
s   ) = Int
hRem forall a. Integral a => a -> a -> (a, a)
`quotRem`   Int
60

    -- Total amount of seconds
    ts :: Int
    ts :: Int
ts = forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
dt

    renderDecimal :: a -> Text
renderDecimal a
n = Int64 -> Char -> Text -> Text
TL.justifyRight Int64
2 Char
'0' forall a b. (a -> b) -> a -> b
$ Builder -> Text
TLB.toLazyText forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Builder
TLB.decimal a
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%
@
-}