From ef6d0cc1898c0ce6f29559714f62ead7640f2202 Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Thu, 19 Dec 2019 09:39:37 -0800 Subject: [PATCH] Vendored `terminal-progress-bar`. --- pkg/hs/stack.yaml | 1 + pkg/hs/terminal-progress-bar/LICENSE | 1 + pkg/hs/terminal-progress-bar/README.markdown | 1 + pkg/hs/terminal-progress-bar/Setup.hs | 2 + pkg/hs/terminal-progress-bar/bench/bench.hs | 51 ++ pkg/hs/terminal-progress-bar/changelog.md | 1 + pkg/hs/terminal-progress-bar/shell.nix | 2 + .../src/System/ProgressBar.hs | 721 ++++++++++++++++++ .../terminal-progress-bar.cabal | 70 ++ pkg/hs/terminal-progress-bar/test/test.hs | 102 +++ 10 files changed, 952 insertions(+) create mode 120000 pkg/hs/terminal-progress-bar/LICENSE create mode 120000 pkg/hs/terminal-progress-bar/README.markdown create mode 100644 pkg/hs/terminal-progress-bar/Setup.hs create mode 100644 pkg/hs/terminal-progress-bar/bench/bench.hs create mode 120000 pkg/hs/terminal-progress-bar/changelog.md create mode 100644 pkg/hs/terminal-progress-bar/shell.nix create mode 100644 pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs create mode 100644 pkg/hs/terminal-progress-bar/terminal-progress-bar.cabal create mode 100644 pkg/hs/terminal-progress-bar/test/test.hs diff --git a/pkg/hs/stack.yaml b/pkg/hs/stack.yaml index 71c13d6ba..ca46ce16b 100644 --- a/pkg/hs/stack.yaml +++ b/pkg/hs/stack.yaml @@ -4,6 +4,7 @@ packages: - proto - king - lmdb-static + - terminal-progress-bar extra-deps: - flat-0.3.4@sha256:002a0e0ae656ea8cc02a772d0bcb6ea7dbd7f2e79070959cc748ad1e7138eb38 diff --git a/pkg/hs/terminal-progress-bar/LICENSE b/pkg/hs/terminal-progress-bar/LICENSE new file mode 120000 index 000000000..ea5b60640 --- /dev/null +++ b/pkg/hs/terminal-progress-bar/LICENSE @@ -0,0 +1 @@ +../LICENSE \ No newline at end of file diff --git a/pkg/hs/terminal-progress-bar/README.markdown b/pkg/hs/terminal-progress-bar/README.markdown new file mode 120000 index 000000000..1691050d1 --- /dev/null +++ b/pkg/hs/terminal-progress-bar/README.markdown @@ -0,0 +1 @@ +../README.markdown \ No newline at end of file diff --git a/pkg/hs/terminal-progress-bar/Setup.hs b/pkg/hs/terminal-progress-bar/Setup.hs new file mode 100644 index 000000000..9a994af67 --- /dev/null +++ b/pkg/hs/terminal-progress-bar/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pkg/hs/terminal-progress-bar/bench/bench.hs b/pkg/hs/terminal-progress-bar/bench/bench.hs new file mode 100644 index 000000000..9f00ac6bb --- /dev/null +++ b/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 diff --git a/pkg/hs/terminal-progress-bar/changelog.md b/pkg/hs/terminal-progress-bar/changelog.md new file mode 120000 index 000000000..7b91ffb65 --- /dev/null +++ b/pkg/hs/terminal-progress-bar/changelog.md @@ -0,0 +1 @@ +../changelog.md \ No newline at end of file diff --git a/pkg/hs/terminal-progress-bar/shell.nix b/pkg/hs/terminal-progress-bar/shell.nix new file mode 100644 index 000000000..1f56dc42c --- /dev/null +++ b/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 diff --git a/pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs b/pkg/hs/terminal-progress-bar/src/System/ProgressBar.hs new file mode 100644 index 000000000..1bc015a31 --- /dev/null +++ b/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% +@ +-} diff --git a/pkg/hs/terminal-progress-bar/terminal-progress-bar.cabal b/pkg/hs/terminal-progress-bar/terminal-progress-bar.cabal new file mode 100644 index 000000000..1bb18f01d --- /dev/null +++ b/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 +maintainer: Roel van Dijk +copyright: 2012–2019 Roel van Dijk +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 diff --git a/pkg/hs/terminal-progress-bar/test/test.hs b/pkg/hs/terminal-progress-bar/test/test.hs new file mode 100644 index 000000000..1cb2c9810 --- /dev/null +++ b/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"