diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright 2012–2018 Roel van Dijk +Copyright 2012–2019 Roel van Dijk All rights reserved. diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -0,0 +1,51 @@ +{-# language PackageImports #-} +module Main where + +import "base" Data.Monoid ( (<>) ) +import "criterion" Criterion.Main +import "terminal-progress-bar" System.ProgressBar +import "time" Data.Time.Clock ( UTCTime(..) ) + +main :: IO () +main = defaultMain + [ renderProgressBarBenchmark 10 0 + , renderProgressBarBenchmark 10 50 + , renderProgressBarBenchmark 10 100 + , renderProgressBarBenchmark 100 0 + , renderProgressBarBenchmark 100 50 + , renderProgressBarBenchmark 100 100 + , renderProgressBarBenchmark 200 0 + , renderProgressBarBenchmark 200 50 + , renderProgressBarBenchmark 200 100 + , labelBenchmark "percentage" percentage (Progress 0 100 ()) + , labelBenchmark "percentage" percentage (Progress 50 100 ()) + , labelBenchmark "percentage" percentage (Progress 100 100 ()) + , labelBenchmark "exact" exact (Progress 0 100 ()) + , labelBenchmark "exact" exact (Progress 50 100 ()) + , labelBenchmark "exact" exact (Progress 100 100 ()) + ] + +renderProgressBarBenchmark :: Int -> Int -> Benchmark +renderProgressBarBenchmark width done = + bench name $ nf (\(s, p, t) -> renderProgressBar s p t) + ( defStyle{styleWidth = ConstantWidth width} + , Progress done 100 () + , someTiming + ) + where + name = "progressBar/default - " + <> show width <> " wide - progress " <> show done <> " % 100" + +labelBenchmark :: String -> Label () -> Progress () -> Benchmark +labelBenchmark labelName label progress = + bench name $ nf (\(p, t) -> runLabel label p t) (progress, someTiming) + where + name = "label/" <> labelName <> " " + <> show (progressDone progress) <> " % " + <> show (progressTodo progress) + +someTime :: UTCTime +someTime = UTCTime (toEnum 0) 0 + +someTiming :: Timing +someTiming = Timing someTime someTime diff --git a/example.hs b/example.hs deleted file mode 100644 --- a/example.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Main where - -import "async" Control.Concurrent.Async ( async, wait ) -import "base" Control.Concurrent ( threadDelay ) -import "base" Control.Monad ( forM_ ) -import "base" Data.Functor ( void ) -import "random" System.Random ( randomRIO ) -import "terminal-progress-bar" System.ProgressBar - -main :: IO () -main = do - example 60 (13 + 60) 25000 - exampleAsync 60 (13 + 60) 25000 - exampleAsync2 (13 + 100) 25000 - -example :: Integer -> Integer -> Int -> IO () -example todo width delay = do - forM_ [1 .. todo] $ \done -> do - autoProgressBar percentage exact width $ Progress done todo - threadDelay delay - putStrLn "" - -exampleAsync :: Integer -> Integer -> Int -> IO () -exampleAsync todo width delay = do - (pr, a) <- startProgress percentage exact width $ Progress 0 todo - forM_ [1 .. todo] $ \_done -> do - incProgress pr 1 - threadDelay delay - wait a - putStrLn "" - -exampleAsync2 :: Integer -> Int -> IO () -exampleAsync2 width delay = do - (pr, a) <- startProgress percentage exact width $ Progress 0 todo - -- Spawn some threads which each increment progress a bit. - forM_ [1 .. numThreads] $ \_ -> - void $ async $ - forM_ [1 .. progressPerThread] $ \_ -> do - incProgress pr 1 - d <- randomRIO (delay * numThreads, 2 * delay * numThreads) - threadDelay d - - -- Wait until the task is completed. - wait a - putStrLn "" - where - todo :: Integer - todo = fromIntegral $ numThreads * progressPerThread - - numThreads :: Int - numThreads = 10 - - progressPerThread :: Int - progressPerThread = 10 diff --git a/src/System/ProgressBar.hs b/src/System/ProgressBar.hs --- a/src/System/ProgressBar.hs +++ b/src/System/ProgressBar.hs @@ -1,141 +1,560 @@ +{-# language DeriveGeneric #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language OverloadedStrings #-} {-# language PackageImports #-} +{-# language ScopedTypeVariables #-} module System.ProgressBar ( -- * Progress bars ProgressBar - , progressBar - , autoProgressBar - , hProgressBar - , mkProgressBar - -- * Progress state + , newProgressBar + , hNewProgressBar + , renderProgressBar + , updateProgress + , incProgress + -- * Options + , Style(..) + , EscapeCode + , defStyle + , ProgressBarWidth(..) + -- * Progress , Progress(..) -- * Labels - , Label - , noLabel + , Label(..) + , Timing(..) , msg , percentage , exact - -- * Auto printing - , ProgressRef - , startProgress - , incProgress + , elapsedTime + , remainingTime + , totalTime + , renderDuration ) where -import "async" Control.Concurrent.Async ( Async ) -import "base" System.IO ( Handle, stderr ) -import "this" System.ProgressBar.State ( Progress(..) ) -import qualified "this" System.ProgressBar.State as State +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 ) --- | Type of functions producing a progress bar. -type ProgressBar a - = Label -- ^ Prefixed label. - -> Label -- ^ Postfixed label. - -> Integer - -- ^ Total progress bar width in characters. Either used as given - -- or as a default when the width of the terminal can not be - -- determined. - -- - -- See 'autoProgressBar'. - -> Progress -- ^ Current progress. - -> a +-------------------------------------------------------------------------------- --- | Print a progress bar to 'stderr' --- --- See 'hProgressBar'. -progressBar :: ProgressBar (IO ()) -progressBar = hProgressBar stderr +data ProgressBar s + = ProgressBar + { pbStyle :: !(Style s) + , pbStateMv :: !(MVar (State s)) + , pbRefreshDelay :: !Double + , pbStartTime :: !UTCTime + , pbHandle :: !Handle + } --- | Print a progress bar to 'stderr' which takes up all available space. +instance (NFData s) => NFData (ProgressBar s) where + rnf pb = pbStyle pb + `seq` pbStateMv pb + `seq` pbRefreshDelay pb + `seq` pbStartTime pb + -- pbHandle is ignored + `seq` () + +data State s + = State + { stProgress :: !(Progress s) + , stRenderTime :: !UTCTime + } + +-- | State of a progress bar. +data Progress s + = Progress + { progressDone :: !Int + -- ^ Amount of work completed. + , progressTodo :: !Int + -- ^ Total amount of work. + , progressCustom :: !s + -- ^ A custom value which can be used by custom labels. + -- Simply use '()' if you do not need custom progress values. + } + +progressFinished :: Progress s -> Bool +progressFinished p = progressDone p >= progressTodo p + +newProgressBar + :: Style s + -> Double -- ^ Maximum refresh rate in Hertz. + -> Progress s -- ^ Initial progress. + -> IO (ProgressBar s) +newProgressBar = hNewProgressBar stderr + +hNewProgressBar + :: Handle + -> Style s + -> 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 + } + +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) } + +updateProgress + :: forall s. ProgressBar s -> (Progress s -> Progress s) -> 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 + +incProgress :: ProgressBar s -> Int -> 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 "\n" + else "\r" + hFlush hndl + +-- | Renders a progress bar -- --- The given width will be used if the width of the terminal can not --- be determined. +-- >>> renderProgressBar (msg "Working") percentage 40 30 100 +-- "Working [=======>.................] 30%" -- --- See 'hProgressBar'. -autoProgressBar :: ProgressBar (IO ()) -autoProgressBar = State.autoProgressBar +-- Not that this function can not use 'TerminalWidth' because it +-- doesn't use 'IO'. Use 'progressBar' or 'hProgressBar' to get +-- automatic width. +renderProgressBar :: Style s -> Progress s -> Timing -> TL.Text +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 --- | Print a progress bar to a file handle. + -- 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 + +{- | Options that determine the textual representation of a progress +bar. + +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' +} +@ +-} +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. + } 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. -- --- Erases the current line! (by outputting '\r') Does not print a --- newline '\n'. Subsequent invocations will overwrite the previous --- output. -hProgressBar :: Handle -> ProgressBar (IO ()) -hProgressBar = State.hProgressBar +-- 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. --- | Renders a progress bar +-- | A default style. -- --- >>> mkProgressBar (msg "Working") percentage 40 30 100 --- "Working [=======>.................] 30%" -mkProgressBar :: ProgressBar String -mkProgressBar = State.mkProgressBar +-- You can override some fields of the default instead of specifying +-- all the fields of a 'Style' record. +-- +-- The default does not use any escape sequences. +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 + } -- | A label that can be pre- or postfixed to a progress bar. -type Label - = Progress -- ^ Current progress. - -> String -- ^ Resulting label. +newtype Label s = Label{ runLabel :: Progress s -> Timing -> TL.Text } deriving (NFData) --- | The empty label. --- --- >>> noLabel 30 100 --- "" -noLabel :: Label -noLabel = State.noLabel +instance Semigroup (Label s) where + Label f <> Label g = Label $ \p t -> f p t <> g p t +instance Monoid (Label s) where + mempty = msg TL.empty + mappend = (<>) + +instance IsString (Label s) where + fromString = msg . TL.pack + +data Timing + = Timing + { timingStart :: !UTCTime + , timingLastUpdate :: !UTCTime + } + -- | A label consisting of a static string. -- --- >>> msg "foo" 30 100 +-- >>> msg "foo" st -- "foo" -msg :: String -> Label -msg = State.msg +msg :: TL.Text -> Label s +msg s = Label $ \_ _ -> s -- | A label which displays the progress as a percentage. -- --- Constant width property: --- ∀ d t : ℕ. d ≤ t → length (percentage d t) ≡ 4 --- --- >>> percentage 30 100 +-- >>> runLabel $ percentage (Progress 30 100 ()) someTiming -- " 30%" -- -- __Note__: if no work is to be done (todo == 0) the percentage will -- always be 100%. - --- ∀ d t : ℕ. d ≤ t -> length (percentage d t) ≡ 3 -percentage :: Label -percentage = State.percentage +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 -- | A label which displays the progress as a fraction of the total -- amount of work. -- --- Equal width property: --- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t → length (exact d₁ t) ≡ length (exact d₂ t) +-- Equal width property - the length of the resulting label is a function of the +-- total amount of work: -- --- >>> exact 30 100 +-- >>> runLabel $ exact (Progress 30 100 ()) someTiming -- " 30/100" +exact :: Label s +exact = Label render + where + render progress _timing = + TL.justifyRight (TL.length todoStr) ' ' doneStr <> "/" <> todoStr + where + todoStr = TLB.toLazyText $ TLB.decimal todo + doneStr = TLB.toLazyText $ TLB.decimal done --- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t -> length (exact d₁ t) ≡ length (exact d₂ t) -exact :: Label -exact = State.exact + done = progressDone progress + todo = progressTodo progress --- * Auto-Printing Progress +-- | A label which displays the 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) -type ProgressRef = State.ProgressRef Progress +-- | Displays the estimated remaining time until all work is done. +-- +-- Tells you how much longer some task will take. +-- +-- This label uses a really 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. You can use 'renderDuration' or +-- @formatTime@ from time >= 1.9. +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 --- | Start a thread to automatically display progress. Use incProgress to step --- the progress bar. -startProgress - :: Label -- ^ Prefixed label. - -> Label -- ^ Postfixed label. - -> Integer - -- ^ Total progress bar width in characters. Only used if the - -- width can not be automatically determined. - -> Progress -- ^ Initial progress state. - -> IO (ProgressRef, Async ()) -startProgress = State.startProgress + progressFraction :: NominalDiffTime + progressFraction + | progressTodo progress <= 0 = 1 + | otherwise = fromIntegral (progressDone progress) + / fromIntegral (progressTodo progress) --- | Increment the progress bar. Negative values will reverse the progress. --- Progress will never be negative and will silently stop taking data --- when it completes. -incProgress :: ProgressRef -> Integer -> IO () -incProgress pr amount = - State.incProgress pr - (\st -> st { progressDone = progressDone st + amount }) + dt :: NominalDiffTime + dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) + +-- | Displays the estimated total time a task will take. +-- +-- This label uses a really 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 time >= 1.9. +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 diff --git a/src/System/ProgressBar/State.hs b/src/System/ProgressBar/State.hs deleted file mode 100644 --- a/src/System/ProgressBar/State.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# language PackageImports #-} -{-# OPTIONS_HADDOCK not-home #-} - -module System.ProgressBar.State - ( -- * Progress bars - ProgressBar - , progressBar - , autoProgressBar - , hProgressBar - , mkProgressBar - -- * Progress state - , Progress(..) - , HasProgress(..) - -- * Labels - , Label - , noLabel - , msg - , percentage - , exact - -- * Auto printing - , ProgressRef - , startProgress - , incProgress - ) where - -import "async" Control.Concurrent.Async ( Async, async ) -import "base" Control.Monad ( when ) -import "base" Data.List ( genericLength, genericReplicate ) -import "base" Data.Ratio ( (%) ) -import "base" System.IO ( Handle, stderr, hPutChar, hPutStr, hFlush ) -import "base" Text.Printf ( printf ) -import "stm" Control.Concurrent.STM - ( TVar, readTVar, writeTVar, newTVar, atomically, STM ) -import "stm-chans" Control.Concurrent.STM.TMQueue - ( TMQueue, readTMQueue, closeTMQueue, writeTMQueue, newTMQueue ) -import qualified "terminal-size" System.Console.Terminal.Size as TS - --- | Type of functions producing a progress bar. -type ProgressBar s a - = Label s -- ^ Prefixed label. - -> Label s -- ^ Postfixed label. - -> Integer - -- ^ Total progress bar width in characters. Either used as given - -- or as a default when the width of the terminal can not be - -- determined. - -- - -- See 'autoProgressBar'. - -> s -- ^ Progress bar state. - -> a - --- | Print a progress bar to 'stderr' --- --- See 'hProgressBar'. -progressBar :: (HasProgress s) => ProgressBar s (IO ()) -progressBar = hProgressBar stderr - --- | Print a progress bar to 'stderr' which takes up all available space. --- --- The given width will be used if the width of the terminal can not --- be determined. --- --- See 'hProgressBar'. -autoProgressBar :: (HasProgress s) => ProgressBar s (IO ()) -autoProgressBar mkPreLabel mkPostLabel defaultWidth st = do - mbWindow <- TS.size - let width = maybe defaultWidth TS.width mbWindow - progressBar mkPreLabel mkPostLabel width st - --- | Print a progress bar to a file handle. --- --- Erases the current line! (by outputting '\r') Does not print a --- newline '\n'. Subsequent invocations will overwrite the previous --- output. -hProgressBar :: HasProgress s => Handle -> ProgressBar s (IO ()) -hProgressBar hndl mkPreLabel mkPostLabel width st = do - hPutChar hndl '\r' - hPutStr hndl $ mkProgressBar mkPreLabel mkPostLabel width st - hFlush hndl - --- | Renders a progress bar --- --- >>> mkProgressBar (msg "Working") percentage 40 30 100 --- "Working [=======>.................] 30%" -mkProgressBar :: (HasProgress s) => ProgressBar s String -mkProgressBar mkPreLabel mkPostLabel width st = - printf "%s%s[%s%s%s]%s%s" - preLabel - prePad - (genericReplicate completed '=') - (if remaining /= 0 && completed /= 0 then ">" else "") - (genericReplicate (remaining - if completed /= 0 then 1 else 0) - '.' - ) - postPad - postLabel - where - progress = getProgress st - todo = progressTodo progress - done = progressDone progress - - -- Amount of work completed. - fraction :: Rational - fraction | todo /= 0 = done % todo - | otherwise = 0 % 1 - - -- Amount of characters available to visualize the progress. - effectiveWidth = max 0 $ width - usedSpace - usedSpace = 2 + genericLength preLabel - + genericLength postLabel - + genericLength prePad - + genericLength postPad - - -- Number of characters needed to represent the amount of work - -- that is completed. Note that this can not always be represented - -- by an integer. - numCompletedChars :: Rational - numCompletedChars = fraction * (effectiveWidth % 1) - - completed, remaining :: Integer - completed = min effectiveWidth $ floor numCompletedChars - remaining = effectiveWidth - completed - - preLabel, postLabel :: String - preLabel = mkPreLabel st - postLabel = mkPostLabel st - - prePad, postPad :: String - prePad = pad preLabel - postPad = pad postLabel - - pad :: String -> String - pad s | null s = "" - | otherwise = " " - --- | State of a progress bar. -data Progress - = Progress - { progressDone :: !Integer - -- ^ Amount of work completed. - , progressTodo :: !Integer - -- ^ Total amount of work. - } - --- | Types that can represent progress. --- --- Any progress bar state that implements this class can be used by --- the default label functions. -class HasProgress a where - getProgress :: a -> Progress - -instance HasProgress Progress where - getProgress = id - --- | A label that can be pre- or postfixed to a progress bar. -type Label s - = s -- ^ Current progress bar state. - -> String -- ^ Resulting label. - --- | The empty label. --- --- >>> noLabel st --- "" -noLabel :: Label s -noLabel = msg "" - --- | A label consisting of a static string. --- --- >>> msg "foo" st --- "foo" -msg :: String -> Label s -msg s _ = s - --- | A label which displays the progress as a percentage. --- --- Constant width property: --- ∀ d t : ℕ. d ≤ t → length (percentage d t) ≡ 4 --- --- >>> percentage 30 100 --- " 30%" --- --- __Note__: if no work is to be done (todo == 0) the percentage will --- always be 100%. - --- ∀ d t : ℕ. d ≤ t -> length (percentage d t) ≡ 3 -percentage :: HasProgress s => Label s -percentage s - | todo == 0 = "100%" - | otherwise = printf "%3i%%" (round (done % todo * 100) :: Integer) - where - done = progressDone progress - todo = progressTodo progress - progress = getProgress s - --- | A label which displays the progress as a fraction of the total --- amount of work. --- --- Equal width property: --- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t → length (exact d₁ t) ≡ length (exact d₂ t) --- --- >>> exact (30, 100) --- " 30/100" - --- ∀ d₁ d₂ t : ℕ. d₁ ≤ d₂ ≤ t -> length (exact d₁ t) ≡ length (exact d₂ t) -exact :: HasProgress s => Label s -exact s = printf "%*i/%s" (length totalStr) done totalStr - where - totalStr = show todo - done = progressDone progress - todo = progressTodo progress - progress = getProgress s - - --- * Auto-Printing Progress - -data ProgressRef s - = ProgressRef - { prPrefix :: !(Label s) - , prPostfix :: !(Label s) - , prWidth :: !Integer - , prState :: !(TVar s) - , prQueue :: !(TMQueue (s -> s)) - } - --- | Start a thread to automatically display progress. Use incProgress to step --- the progress bar. -startProgress - :: (HasProgress s) - => Label s -- ^ Prefixed label. - -> Label s -- ^ Postfixed label. - -> Integer -- ^ Total progress bar width in characters. - -> s -- ^ Init state - -> IO (ProgressRef s, Async ()) -startProgress mkPreLabel mkPostLabel width st = do - pr <- buildProgressRef - a <- async $ reportProgress pr - return (pr, a) - where - buildProgressRef = do - tvSt <- atomically $ newTVar st - queue <- atomically $ newTMQueue - return $ ProgressRef mkPreLabel mkPostLabel width tvSt queue - --- | Increment the progress bar. Negative values will reverse the progress. --- Progress will never be negative and will silently stop taking data --- when it completes. -incProgress :: ProgressRef s -> (s -> s) -> IO () -incProgress progressRef = - atomically . writeTMQueue (prQueue progressRef) - -reportProgress :: (HasProgress s) => ProgressRef s -> IO () -reportProgress pr = do - continue <- atomically $ updateProgress pr - renderProgress pr - when continue $ reportProgress pr - -updateProgress :: (HasProgress s) => ProgressRef s -> STM Bool -updateProgress pr = - maybe dontContinue doUpdate =<< readTMQueue (prQueue pr) - where - dontContinue = return False - doUpdate updateState = do - st <- readTVar $ prState pr - let newState = updateState st - progress = getProgress newState - todo = progressTodo progress - done = progressDone progress - let newDone = min todo $ max 0 done - writeTVar (prState pr) newState - if newDone >= todo - then closeTMQueue (prQueue pr) >> dontContinue - else return True - -renderProgress :: (HasProgress s) => ProgressRef s -> IO () -renderProgress pr = do - st <- atomically $ readTVar $ prState pr - autoProgressBar - (prPrefix pr) - (prPostfix pr) - (prWidth pr) - st diff --git a/terminal-progress-bar.cabal b/terminal-progress-bar.cabal --- a/terminal-progress-bar.cabal +++ b/terminal-progress-bar.cabal @@ -1,11 +1,11 @@ name: terminal-progress-bar -version: 0.2 +version: 0.4 cabal-version: >=1.10 build-type: Simple stability: provisional author: Roel van Dijk maintainer: Roel van Dijk -copyright: 2012–2018 Roel van Dijk +copyright: 2012–2019 Roel van Dijk license: BSD3 license-file: LICENSE category: System, User Interfaces @@ -17,8 +17,7 @@ package implements a very simple textual progress bar. . See the module 'System.ProgressBar' on how to use the progress bar - or build the package with the -fexample flag for a small example - program. + 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 @@ -31,20 +30,15 @@ type: git location: git://github.com/roelvandijk/terminal-progress-bar.git -flag example - description: Build a small example program. - default: False - library hs-source-dirs: src build-depends: - async >= 2.1.1 - , base >= 3.0.3.1 && < 5 - , stm >= 2.4 - , stm-chans >= 3.0.0 + base >= 4.5 && < 5 + , deepseq >= 1.4.3 , terminal-size >= 0.3.2 + , text >= 1.2 + , time >= 1.8 exposed-modules: System.ProgressBar - System.ProgressBar.State ghc-options: -Wall default-language: Haskell2010 @@ -54,24 +48,24 @@ hs-source-dirs: test ghc-options: -Wall build-depends: - base >= 3.0.3.1 && < 5 + base >= 4.5 && < 5 , HUnit >= 1.2.4.2 , terminal-progress-bar , test-framework >= 0.3.3 , test-framework-hunit >= 0.2.6 + , text >= 1.2 + , time >= 1.8 default-language: Haskell2010 -executable example - main-is: example.hs - hs-source-dirs: . - ghc-options: -Wall - if flag(example) - build-depends: - async >= 2.1.1 - , base >= 3.0.3.1 && < 5 - , random >= 1.1 - , terminal-progress-bar - buildable: True - else - buildable: False +benchmark bench-terminal-progress-bar + type: exitcode-stdio-1.0 + main-is: bench.hs + hs-source-dirs: bench + + build-depends: + base >= 4.5 && < 5 + , criterion >= 1.1.4 + , terminal-progress-bar + , time >= 1.8 + ghc-options: -Wall -O2 default-language: Haskell2010 diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,3 +1,4 @@ +{-# language OverloadedStrings #-} {-# language PackageImports #-} module Main where @@ -7,11 +8,14 @@ -------------------------------------------------------------------------------- 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 @@ -24,46 +28,75 @@ tests :: [Test] tests = [ testGroup "Label padding" - [ eqTest "no labels" "[]" noLabel noLabel 0 $ Progress 0 0 - , eqTest "pre" "pre []" (msg "pre") noLabel 0 $ Progress 0 0 - , eqTest "post" "[] post" noLabel (msg "post") 0 $ Progress 0 0 - , eqTest "pre & post" "pre [] post" (msg "pre") (msg "post") 0 $ Progress 0 0 + [ eqTest "no labels" "[]" mempty mempty 0 $ Progress 0 0 () + , eqTest "pre" "pre []" (msg "pre") mempty 0 $ Progress 0 0 () + , eqTest "post" "[] post" mempty (msg "post") 0 $ Progress 0 0 () + , eqTest "pre & post" "pre [] post" (msg "pre") (msg "post") 0 $ Progress 0 0 () ] , testGroup "Bar fill" - [ eqTest "empty" "[....]" noLabel noLabel 6 $ Progress 0 1 - , eqTest "almost half" "[=>..]" noLabel noLabel 6 $ Progress 49 100 - , eqTest "half" "[==>.]" noLabel noLabel 6 $ Progress 1 2 - , eqTest "almost full" "[===>]" noLabel noLabel 6 $ Progress 99 100 - , eqTest "full" "[====]" noLabel noLabel 6 $ Progress 1 1 - , eqTest "overfull" "[====]" noLabel noLabel 6 $ Progress 2 1 + [ eqTest "empty" "[....]" mempty mempty 6 $ Progress 0 1 () + , eqTest "almost half" "[=>..]" mempty mempty 6 $ Progress 49 100 () + , eqTest "half" "[==>.]" mempty mempty 6 $ Progress 1 2 () + , eqTest "almost full" "[===>]" mempty mempty 6 $ Progress 99 100 () + , eqTest "full" "[====]" mempty mempty 6 $ Progress 1 1 () + , eqTest "overfull" "[====]" mempty mempty 6 $ Progress 2 1 () ] , testGroup "Labels" [ testGroup "Percentage" - [ eqTest " 0%" " 0% [....]" percentage noLabel 11 $ Progress 0 1 - , eqTest "100%" "100% [====]" percentage noLabel 11 $ Progress 1 1 - , eqTest " 50%" " 50% [==>.]" percentage noLabel 11 $ Progress 1 2 - , eqTest "200%" "200% [====]" percentage noLabel 11 $ Progress 2 1 - , labelTest "0 work todo" percentage (Progress 10 0) "100%" + [ eqTest " 0%" " 0% [....]" percentage mempty 11 $ Progress 0 1 () + , eqTest "100%" "100% [====]" percentage mempty 11 $ Progress 1 1 () + , eqTest " 50%" " 50% [==>.]" percentage mempty 11 $ Progress 1 2 () + , eqTest "200%" "200% [====]" percentage mempty 11 $ Progress 2 1 () + , labelTest "0 work todo" percentage (Progress 10 0 ()) "100%" ] , testGroup "Exact" - [ eqTest "0/0" "0/0 [....]" exact noLabel 10 $ Progress 0 0 - , eqTest "1/1" "1/1 [====]" exact noLabel 10 $ Progress 1 1 - , eqTest "1/2" "1/2 [==>.]" exact noLabel 10 $ Progress 1 2 - , eqTest "2/1" "2/1 [====]" exact noLabel 10 $ Progress 2 1 - , labelTest "0 work todo" exact (Progress 10 0) "10/0" + [ 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 -> String -> Test +labelTest :: String -> Label () -> Progress () -> TL.Text -> Test labelTest testName label progress expected = - testCase testName $ assertEqual expectationError expected (label progress) + testCase testName $ assertEqual expectationError expected $ runLabel label progress someTiming -eqTest :: String -> String -> Label -> Label -> Integer -> Progress -> Test +renderDurationTest :: NominalDiffTime -> TL.Text -> Test +renderDurationTest dt expected = + testCase ("renderDuration " <> show dt) $ assertEqual expectationError expected $ renderDuration dt + +eqTest :: String -> TL.Text -> Label () -> Label () -> Int -> Progress () -> Test eqTest name expected mkPreLabel mkPostLabel width progress = testCase name $ assertEqual expectationError expected actual where - actual = mkProgressBar mkPreLabel mkPostLabel width progress + 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"