├── README.markdown ├── lib ├── LICENSE ├── changelog.md ├── README.markdown ├── Setup.hs ├── shell.nix ├── bench │ └── bench.hs ├── terminal-progress-bar.cabal ├── test │ └── test.hs └── src │ └── System │ └── ProgressBar.hs ├── example ├── LICENSE ├── shell.nix ├── terminal-progress-bar-example.cabal └── example.hs ├── .gitignore ├── default.nix ├── changelog.md ├── nixpkgs.nix ├── overlay.nix └── LICENSE /README.markdown: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /lib/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /example/LICENSE: -------------------------------------------------------------------------------- 1 | ../LICENSE -------------------------------------------------------------------------------- /lib/changelog.md: -------------------------------------------------------------------------------- 1 | ../changelog.md -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-newstyle 3 | -------------------------------------------------------------------------------- /lib/README.markdown: -------------------------------------------------------------------------------- 1 | ../README.markdown -------------------------------------------------------------------------------- /lib/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | import (import ./nixpkgs.nix) { 2 | overlays = [ (import ./overlay.nix) ]; 3 | } 4 | -------------------------------------------------------------------------------- /lib/shell.nix: -------------------------------------------------------------------------------- 1 | (import ../.).haskellPackages.terminal-progress-bar.env 2 | # (import ../.).haskell.packages.ghc844.terminal-progress-bar.env 3 | -------------------------------------------------------------------------------- /example/shell.nix: -------------------------------------------------------------------------------- 1 | (import ../.).haskellPackages.terminal-progress-bar-example.env 2 | # (import ../.).haskell.packages.ghc844.terminal-progress-bar-example.env 3 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | ### 0.4.2 2 | 3 | * Fixed divide by zero error in remainingTime label (thanks to daniel-chambers). 4 | 5 | ### 0.4.1 6 | 7 | * Added styleOnComplete field to Style record. Defaults to 8 | WriteNewLine. Gives the ability to clear the progress bar once 9 | finished. 10 | 11 | * Added this changelog. 12 | 13 | #### 0.4.0.2 14 | 15 | * Improved documentation 16 | -------------------------------------------------------------------------------- /nixpkgs.nix: -------------------------------------------------------------------------------- 1 | # To calculate sha256: 2 | # > nix-prefetch-url --unpack https://github.com/NixOS/nixpkgs/archive/4d2b37a84fad1091b9de401eb450aae66f1a741e.tar.gz 3 | builtins.fetchTarball { 4 | # NixOS 22.11 5 | url = "https://github.com/NixOS/nixpkgs/archive/4d2b37a84fad1091b9de401eb450aae66f1a741e.tar.gz"; 6 | sha256 = "11w3wn2yjhaa5pv20gbfbirvjq6i3m7pqrq2msf0g7cv44vijwgw"; 7 | } 8 | -------------------------------------------------------------------------------- /example/terminal-progress-bar-example.cabal: -------------------------------------------------------------------------------- 1 | name: terminal-progress-bar-example 2 | version: 0.1 3 | cabal-version: >=1.10 4 | build-type: Simple 5 | stability: provisional 6 | author: Roel van Dijk 7 | maintainer: Roel van Dijk 8 | copyright: 2012–2023 Roel van Dijk 9 | license: BSD3 10 | license-file: LICENSE 11 | category: System, User Interfaces 12 | homepage: https://github.com/roelvandijk/terminal-progress-bar 13 | bug-reports: https://github.com/roelvandijk/terminal-progress-bar/issues 14 | synopsis: An example usage of the terminal-progress-bar library 15 | description: 16 | An example usage of the terminal-progress-bar library. 17 | 18 | extra-source-files: LICENSE, README.markdown 19 | 20 | source-repository head 21 | type: git 22 | location: git://github.com/roelvandijk/terminal-progress-bar.git 23 | 24 | executable terminal-progress-bar-example 25 | main-is: example.hs 26 | hs-source-dirs: . 27 | ghc-options: -Wall 28 | build-depends: 29 | ansi-terminal >= 0.6.3 30 | , async >= 2.1.1 31 | , base >= 4.5 && < 5 32 | , random >= 1.1 33 | , terminal-progress-bar 34 | , text >= 1.2 35 | default-language: Haskell2010 36 | -------------------------------------------------------------------------------- /overlay.nix: -------------------------------------------------------------------------------- 1 | final : previous : with final.haskell.lib; { 2 | haskell = previous.haskell // { 3 | packageOverrides = self : super : { 4 | terminal-progress-bar = 5 | let src = previous.runCommand "terminal-progress-bar-src" { 6 | lib = ./lib; 7 | LICENSE = ./LICENSE; 8 | CHANGELOG = ./changelog.md; 9 | } '' 10 | mkdir -p $out 11 | cp -r $lib/src $out/src 12 | cp -r $lib/test $out/test 13 | cp -r $lib/bench $out/bench 14 | cp $LICENSE $out/LICENSE 15 | cp $CHANGELOG $out/CHANGELOG 16 | cp $lib/terminal-progress-bar.cabal $out 17 | ''; 18 | in doBenchmark (super.callCabal2nix "terminal-progress-bar" src {}); 19 | 20 | terminal-progress-bar-example = 21 | let src = previous.runCommand "terminal-progress-bar-example-src" { 22 | example = ./example; 23 | LICENSE = ./LICENSE; 24 | } '' 25 | mkdir -p $out 26 | cp $example/example.hs $out 27 | cp $LICENSE $out/LICENSE 28 | cp $example/terminal-progress-bar-example.cabal $out 29 | ''; 30 | in super.callCabal2nix "terminal-progress-bar-example" src {}; 31 | }; 32 | }; 33 | } 34 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2012–2023 Roel van Dijk and project contributors 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 7 | met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * The name of Roel van Dijk and the names of contributors may NOT 18 | be used to endorse or promote products derived from this 19 | software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /lib/bench/bench.hs: -------------------------------------------------------------------------------- 1 | {-# language PackageImports #-} 2 | module Main where 3 | 4 | import "base" Data.Monoid ( (<>) ) 5 | import "criterion" Criterion.Main 6 | import "terminal-progress-bar" System.ProgressBar 7 | import "time" Data.Time.Clock ( UTCTime(..) ) 8 | 9 | main :: IO () 10 | main = defaultMain 11 | [ renderProgressBarBenchmark 10 0 12 | , renderProgressBarBenchmark 10 50 13 | , renderProgressBarBenchmark 10 100 14 | , renderProgressBarBenchmark 100 0 15 | , renderProgressBarBenchmark 100 50 16 | , renderProgressBarBenchmark 100 100 17 | , renderProgressBarBenchmark 200 0 18 | , renderProgressBarBenchmark 200 50 19 | , renderProgressBarBenchmark 200 100 20 | , labelBenchmark "percentage" percentage (Progress 0 100 ()) 21 | , labelBenchmark "percentage" percentage (Progress 50 100 ()) 22 | , labelBenchmark "percentage" percentage (Progress 100 100 ()) 23 | , labelBenchmark "exact" exact (Progress 0 100 ()) 24 | , labelBenchmark "exact" exact (Progress 50 100 ()) 25 | , labelBenchmark "exact" exact (Progress 100 100 ()) 26 | ] 27 | 28 | renderProgressBarBenchmark :: Int -> Int -> Benchmark 29 | renderProgressBarBenchmark width done = 30 | bench name $ nf (\(s, p, t) -> renderProgressBar s p t) 31 | ( defStyle{styleWidth = ConstantWidth width} 32 | , Progress done 100 () 33 | , someTiming 34 | ) 35 | where 36 | name = "progressBar/default - " 37 | <> show width <> " wide - progress " <> show done <> " % 100" 38 | 39 | labelBenchmark :: String -> Label () -> Progress () -> Benchmark 40 | labelBenchmark labelName label progress = 41 | bench name $ nf (\(p, t) -> runLabel label p t) (progress, someTiming) 42 | where 43 | name = "label/" <> labelName <> " " 44 | <> show (progressDone progress) <> " % " 45 | <> show (progressTodo progress) 46 | 47 | someTime :: UTCTime 48 | someTime = UTCTime (toEnum 0) 0 49 | 50 | someTiming :: Timing 51 | someTiming = Timing someTime someTime 52 | -------------------------------------------------------------------------------- /lib/terminal-progress-bar.cabal: -------------------------------------------------------------------------------- 1 | name: terminal-progress-bar 2 | version: 0.4.2 3 | cabal-version: >=1.10 4 | build-type: Simple 5 | author: Roel van Dijk 6 | maintainer: Roel van Dijk 7 | copyright: 2012–2023 Roel van Dijk 8 | license: BSD3 9 | license-file: LICENSE 10 | category: System, User Interfaces 11 | homepage: https://github.com/roelvandijk/terminal-progress-bar 12 | bug-reports: https://github.com/roelvandijk/terminal-progress-bar/issues 13 | synopsis: A progress bar in the terminal 14 | description: 15 | A progress bar conveys the progress of a task. This package 16 | implements a progress bar that is displayed in a terminal. 17 | . 18 | See the module 'System.ProgressBar' to get started or look at the 19 | terminal-progress-bar-example package. 20 | . 21 | The animated progress bar depends entirely on the interpretation of 22 | the carriage return character (\'\\r\'). If your terminal interprets 23 | it as something else than \"move cursor to beginning of line\", the 24 | animation won't work. 25 | 26 | extra-source-files: LICENSE, README.markdown, changelog.md 27 | 28 | source-repository head 29 | type: git 30 | location: git://github.com/roelvandijk/terminal-progress-bar.git 31 | 32 | library 33 | hs-source-dirs: src 34 | build-depends: 35 | base >= 4.5 && < 5 36 | , deepseq >= 1.4.3 37 | , terminal-size >= 0.3.2 38 | , text >= 1.2 39 | , time >= 1.8 40 | exposed-modules: System.ProgressBar 41 | ghc-options: -Wall 42 | default-language: Haskell2010 43 | 44 | test-suite test-terminal-progress-bar 45 | type: exitcode-stdio-1.0 46 | main-is: test.hs 47 | hs-source-dirs: test 48 | ghc-options: -Wall 49 | build-depends: 50 | base >= 4.5 && < 5 51 | , HUnit >= 1.2.4.2 52 | , terminal-progress-bar 53 | , test-framework >= 0.3.3 54 | , test-framework-hunit >= 0.2.6 55 | , text >= 1.2 56 | , time >= 1.8 57 | default-language: Haskell2010 58 | 59 | benchmark bench-terminal-progress-bar 60 | type: exitcode-stdio-1.0 61 | main-is: bench.hs 62 | hs-source-dirs: bench 63 | 64 | build-depends: 65 | base >= 4.5 && < 5 66 | , criterion >= 1.1.4 67 | , terminal-progress-bar 68 | , time >= 1.8 69 | ghc-options: -Wall -O2 70 | default-language: Haskell2010 71 | -------------------------------------------------------------------------------- /example/example.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language PackageImports #-} 3 | 4 | module Main where 5 | 6 | import "ansi-terminal" System.Console.ANSI.Codes 7 | ( setSGRCode, SGR(..), ConsoleLayer(..), ColorIntensity(..), Color(..) ) 8 | import qualified "async" Control.Concurrent.Async as Async 9 | import "base" Control.Concurrent ( threadDelay ) 10 | import "base" Data.Foldable ( traverse_, for_ ) 11 | import "base" Data.Ratio ( (%) ) 12 | import "base" Data.Traversable ( for ) 13 | import "random" System.Random ( randomRIO ) 14 | import "terminal-progress-bar" System.ProgressBar 15 | import qualified "text" Data.Text.Lazy as TL 16 | 17 | main :: IO () 18 | main = do 19 | putStrLn "Simple progressBar:" 20 | example 60 25000 21 | putStrLn "" 22 | 23 | putStrLn "Incrementing process with steps of 1:" 24 | exampleAsync 60 25000 25 | putStrLn "" 26 | 27 | putStrLn "Multiple threads increasing progress:" 28 | exampleAsync2 25000 29 | putStrLn "" 30 | 31 | putStrLn "Colorful progressBar (fixed colors):" 32 | exampleColorful 100 25000 33 | putStrLn "" 34 | 35 | putStrLn "Colorful progressBar (changing colors):" 36 | exampleColorful2 100 25000 37 | putStrLn "" 38 | 39 | putStrLn "Really long task. Feel free to kill the executable with CTRL-C or similar." 40 | example 100000 250000 41 | putStrLn "" 42 | 43 | exampleStyle :: Style () 44 | exampleStyle = 45 | defStyle 46 | { stylePrefix = percentage 47 | , stylePostfix = exact <> " " <> elapsedTime renderDuration <> "/" <> totalTime renderDuration "..." 48 | , styleWidth = TerminalWidth (13 + 60) 49 | } 50 | 51 | example :: Int -> Int -> IO () 52 | example todo delay = do 53 | pb <- newProgressBar exampleStyle 30 (Progress 0 todo ()) 54 | for_ [0 .. todo] $ \done -> do 55 | updateProgress pb $ \p -> p{progressDone = done} 56 | threadDelay delay 57 | putStrLn "" 58 | 59 | exampleAsync :: Int -> Int -> IO () 60 | exampleAsync todo delay = do 61 | pb <- newProgressBar exampleStyle 30 (Progress 0 todo ()) 62 | for_ [1 .. todo] $ \_done -> do 63 | incProgress pb 1 64 | threadDelay delay 65 | putStrLn "" 66 | 67 | exampleAsync2 :: Int -> IO () 68 | exampleAsync2 delay = do 69 | pb <- newProgressBar exampleStyle 30 (Progress 0 todo ()) 70 | -- Spawn some threads which each increment progress a bit. 71 | threads <- for [1 .. numThreads] $ \_ -> 72 | Async.async $ 73 | for_ [1 .. progressPerThread] $ \_ -> do 74 | incProgress pb 1 75 | d <- randomRIO (delay * numThreads, 2 * delay * numThreads) 76 | threadDelay d 77 | 78 | -- Wait until the task is completed. 79 | traverse_ Async.wait threads 80 | 81 | putStrLn "" 82 | where 83 | todo :: Int 84 | todo = fromIntegral $ numThreads * progressPerThread 85 | 86 | numThreads :: Int 87 | numThreads = 10 88 | 89 | progressPerThread :: Int 90 | progressPerThread = 10 91 | 92 | colorStyle :: Style () 93 | colorStyle = 94 | exampleStyle 95 | { styleDone = '▇' 96 | , styleCurrent = '▶' 97 | , styleTodo = ' ' 98 | , styleOpen = "" 99 | , styleClose = "" 100 | , styleEscapeDone = const $ setSGRCodeText [SetColor Foreground Dull Green] 101 | , styleEscapePostfix = const $ setSGRCodeText [Reset] 102 | } 103 | 104 | exampleColorful :: Int -> Int -> IO () 105 | exampleColorful todo delay = do 106 | pb <- newProgressBar colorStyle 30 (Progress 0 todo ()) 107 | for_ [0 .. todo] $ \done -> do 108 | updateProgress pb $ \p -> p{progressDone = done} 109 | threadDelay delay 110 | putStrLn "" 111 | 112 | colorStyle2 :: Style () 113 | colorStyle2 = 114 | colorStyle{ styleEscapeDone = setSGRCodeText . progressColor } 115 | where 116 | progressColor :: Progress () -> [SGR] 117 | progressColor (Progress done todo ()) 118 | | r >= 90 % 100 = [SetColor Foreground Dull Green] 119 | | r >= 50 % 100 = [SetColor Foreground Vivid Yellow] 120 | | r >= 25 % 100 = [SetColor Foreground Vivid Red] 121 | | otherwise = [SetColor Foreground Dull Red] 122 | where 123 | r = done % todo 124 | 125 | exampleColorful2 :: Int -> Int -> IO () 126 | exampleColorful2 todo delay = do 127 | pb <- newProgressBar colorStyle2 30 (Progress 0 todo ()) 128 | for_ [0 .. todo] $ \done -> do 129 | updateProgress pb $ \p -> p{progressDone = done} 130 | threadDelay delay 131 | putStrLn "" 132 | 133 | setSGRCodeText :: [SGR] -> TL.Text 134 | setSGRCodeText = TL.pack . setSGRCode 135 | -------------------------------------------------------------------------------- /lib/test/test.hs: -------------------------------------------------------------------------------- 1 | {-# language OverloadedStrings #-} 2 | {-# language PackageImports #-} 3 | 4 | module Main where 5 | 6 | -------------------------------------------------------------------------------- 7 | -- Imports 8 | -------------------------------------------------------------------------------- 9 | 10 | import "base" System.Environment ( getArgs ) 11 | import "base" Data.Semigroup ( (<>) ) 12 | import "base" Data.Fixed (Pico) 13 | import "HUnit" Test.HUnit.Base ( assertEqual ) 14 | import "test-framework" Test.Framework 15 | ( defaultMainWithOpts, interpretArgsOrExit, Test, testGroup ) 16 | import "test-framework-hunit" Test.Framework.Providers.HUnit ( testCase ) 17 | import "terminal-progress-bar" System.ProgressBar 18 | import qualified "text" Data.Text.Lazy as TL 19 | import "time" Data.Time (UTCTime(..), NominalDiffTime, formatTime, defaultTimeLocale, addUTCTime, secondsToNominalDiffTime) 20 | 21 | -------------------------------------------------------------------------------- 22 | -- Test suite 23 | -------------------------------------------------------------------------------- 24 | 25 | main :: IO () 26 | main = do opts <- interpretArgsOrExit =<< getArgs 27 | defaultMainWithOpts tests opts 28 | 29 | tests :: [Test] 30 | tests = 31 | [ testGroup "Label padding" 32 | [ eqTest "no labels" "[]" mempty mempty 0 $ Progress 0 0 () 33 | , eqTest "pre" "pre []" (msg "pre") mempty 0 $ Progress 0 0 () 34 | , eqTest "post" "[] post" mempty (msg "post") 0 $ Progress 0 0 () 35 | , eqTest "pre & post" "pre [] post" (msg "pre") (msg "post") 0 $ Progress 0 0 () 36 | ] 37 | , testGroup "Bar fill" 38 | [ eqTest "empty" "[....]" mempty mempty 6 $ Progress 0 1 () 39 | , eqTest "almost half" "[=>..]" mempty mempty 6 $ Progress 49 100 () 40 | , eqTest "half" "[==>.]" mempty mempty 6 $ Progress 1 2 () 41 | , eqTest "almost full" "[===>]" mempty mempty 6 $ Progress 99 100 () 42 | , eqTest "full" "[====]" mempty mempty 6 $ Progress 1 1 () 43 | , eqTest "overfull" "[====]" mempty mempty 6 $ Progress 2 1 () 44 | ] 45 | , testGroup "Labels" 46 | [ testGroup "Percentage" 47 | [ eqTest " 0%" " 0% [....]" percentage mempty 11 $ Progress 0 1 () 48 | , eqTest "100%" "100% [====]" percentage mempty 11 $ Progress 1 1 () 49 | , eqTest " 50%" " 50% [==>.]" percentage mempty 11 $ Progress 1 2 () 50 | , eqTest "200%" "200% [====]" percentage mempty 11 $ Progress 2 1 () 51 | , labelTest "0 work todo" percentage (Progress 10 0 ()) "100%" 52 | ] 53 | , testGroup "Exact" 54 | [ eqTest "0/0" "0/0 [....]" exact mempty 10 $ Progress 0 0 () 55 | , eqTest "1/1" "1/1 [====]" exact mempty 10 $ Progress 1 1 () 56 | , eqTest "1/2" "1/2 [==>.]" exact mempty 10 $ Progress 1 2 () 57 | , eqTest "2/1" "2/1 [====]" exact mempty 10 $ Progress 2 1 () 58 | , labelTest "0 work todo" exact (Progress 10 0 ()) "10/0" 59 | ] 60 | , testGroup "Label Semigroup" 61 | [ eqTest "exact <> msg <> percentage" 62 | "1/2 - 50% [===>...]" 63 | (exact <> msg " - " <> percentage) 64 | mempty 20 $ Progress 1 2 () 65 | ] 66 | , testGroup "renderDuration" 67 | [ renderDurationTest 42 "42" 68 | , renderDurationTest (5 * 60 + 42) "05:42" 69 | , renderDurationTest (8 * 60 * 60 + 5 * 60 + 42) "08:05:42" 70 | , renderDurationTest (123 * 60 * 60 + 59 * 60 + 59) "123:59:59" 71 | ] 72 | , testGroup "remainingTime" 73 | [ labelTestWithTiming "No progress after no time" remainingTimeLabel (Progress 0 100 ()) (elapsedSecsTiming 0) "Estimating" 74 | , labelTestWithTiming "No progress after some time" remainingTimeLabel (Progress 0 100 ()) (elapsedSecsTiming 10) "Estimating" 75 | , labelTestWithTiming "Some progress after no time" remainingTimeLabel (Progress 50 100 ()) (elapsedSecsTiming 0) "Estimating" 76 | , labelTestWithTiming "Some progress after some time" remainingTimeLabel (Progress 50 100 ()) (elapsedSecsTiming 10) "10" 77 | , labelTestWithTiming "No work to be done after no time" remainingTimeLabel (Progress 0 0 ()) (elapsedSecsTiming 0) "Estimating" 78 | , labelTestWithTiming "No work to be done after some time" remainingTimeLabel (Progress 0 0 ()) (elapsedSecsTiming 10) "Estimating" 79 | , labelTestWithTiming "More progress than work to be done after no time" remainingTimeLabel (Progress 50 0 ()) (elapsedSecsTiming 0) "Estimating" 80 | , labelTestWithTiming "More progress than work to be done after some time" remainingTimeLabel (Progress 50 0 ()) (elapsedSecsTiming 10) "0" 81 | ] 82 | ] 83 | ] 84 | 85 | labelTest :: String -> Label () -> Progress () -> TL.Text -> Test 86 | labelTest testName label progress expected = 87 | testCase testName $ assertEqual expectationError expected $ runLabel label progress someTiming 88 | 89 | labelTestWithTiming :: String -> Label () -> Progress () -> Timing -> TL.Text -> Test 90 | labelTestWithTiming testName label progress timing expected = 91 | testCase testName $ assertEqual expectationError expected $ runLabel label progress timing 92 | 93 | renderDurationTest :: NominalDiffTime -> TL.Text -> Test 94 | renderDurationTest dt expected = 95 | testCase ("renderDuration " <> show dt) $ assertEqual expectationError expected $ renderDuration dt 96 | 97 | eqTest :: String -> TL.Text -> Label () -> Label () -> Int -> Progress () -> Test 98 | eqTest name expected mkPreLabel mkPostLabel width progress = 99 | testCase name $ assertEqual expectationError expected actual 100 | where 101 | actual = renderProgressBar style progress someTiming 102 | 103 | style :: Style () 104 | style = defStyle 105 | { stylePrefix = mkPreLabel 106 | , stylePostfix = mkPostLabel 107 | , styleWidth = ConstantWidth width 108 | } 109 | 110 | someTime :: UTCTime 111 | someTime = UTCTime (toEnum 0) 0 112 | 113 | someTiming :: Timing 114 | someTiming = Timing someTime someTime 115 | 116 | elapsedSecsTiming :: Pico -> Timing 117 | elapsedSecsTiming seconds = Timing someTime (addUTCTime (secondsToNominalDiffTime seconds) someTime) 118 | 119 | expectationError :: String 120 | expectationError = "Expected result doesn't match actual result" 121 | 122 | remainingTimeLabel :: Label () 123 | remainingTimeLabel = remainingTime (TL.pack . formatTime defaultTimeLocale "%s") "Estimating" 124 | -------------------------------------------------------------------------------- /lib/src/System/ProgressBar.hs: -------------------------------------------------------------------------------- 1 | {-# language DeriveGeneric #-} 2 | {-# language GeneralizedNewtypeDeriving #-} 3 | {-# language OverloadedStrings #-} 4 | {-# language PackageImports #-} 5 | {-# language ScopedTypeVariables #-} 6 | 7 | {- | 8 | A progress bar in the terminal. 9 | 10 | A progress bar conveys the progress of a task. Use a progress bar to 11 | provide a visual cue that processing is underway. 12 | -} 13 | module System.ProgressBar 14 | ( -- * Getting started 15 | -- $start 16 | 17 | -- * Example 18 | -- $example 19 | 20 | -- * Progress bars 21 | ProgressBar 22 | , newProgressBar 23 | , hNewProgressBar 24 | , renderProgressBar 25 | , updateProgress 26 | , incProgress 27 | -- * Options 28 | , Style(..) 29 | , EscapeCode 30 | , OnComplete(..) 31 | , defStyle 32 | , ProgressBarWidth(..) 33 | -- * Progress 34 | , Progress(..) 35 | -- * Labels 36 | , Label(..) 37 | , Timing(..) 38 | , msg 39 | , percentage 40 | , exact 41 | , elapsedTime 42 | , remainingTime 43 | , totalTime 44 | , renderDuration 45 | ) where 46 | 47 | import "base" Control.Concurrent.MVar ( MVar, newMVar, modifyMVar_) 48 | import "base" Control.Monad ( when ) 49 | import "base" Data.Int ( Int64 ) 50 | import "base" Data.Monoid ( Monoid, mempty ) 51 | import "base" Data.Ratio ( Ratio, (%) ) 52 | import "base" Data.Semigroup ( Semigroup, (<>) ) 53 | import "base" Data.String ( IsString, fromString ) 54 | import "base" GHC.Generics ( Generic ) 55 | import "base" System.IO ( Handle, stderr, hFlush ) 56 | import "deepseq" Control.DeepSeq ( NFData, rnf ) 57 | import qualified "terminal-size" System.Console.Terminal.Size as TS 58 | import qualified "text" Data.Text.Lazy as TL 59 | import qualified "text" Data.Text.Lazy.Builder as TLB 60 | import qualified "text" Data.Text.Lazy.Builder.Int as TLB 61 | import qualified "text" Data.Text.Lazy.IO as TL 62 | import "time" Data.Time.Clock ( UTCTime, NominalDiffTime, diffUTCTime, getCurrentTime ) 63 | 64 | -------------------------------------------------------------------------------- 65 | 66 | -- | A terminal progress bar. 67 | -- 68 | -- A 'ProgressBar' value contains the state of a progress bar. 69 | -- 70 | -- Create a progress bar with 'newProgressBar' or 'hNewProgressBar'. 71 | -- Update a progress bar with 'updateProgress' or 'incProgress'. 72 | data ProgressBar s 73 | = ProgressBar 74 | { pbStyle :: !(Style s) 75 | , pbStateMv :: !(MVar (State s)) 76 | , pbRefreshDelay :: !Double 77 | , pbStartTime :: !UTCTime 78 | , pbHandle :: !Handle 79 | } 80 | 81 | instance (NFData s) => NFData (ProgressBar s) where 82 | rnf pb = pbStyle pb 83 | `seq` pbStateMv pb 84 | `seq` pbRefreshDelay pb 85 | `seq` pbStartTime pb 86 | -- pbHandle is ignored 87 | `seq` () 88 | 89 | -- | State of a progress bar. 90 | data State s 91 | = State 92 | { stProgress :: !(Progress s) 93 | -- ^ Current progress. 94 | , stRenderTime :: !UTCTime 95 | -- ^ Moment in time of last render. 96 | } 97 | 98 | -- | An amount of progress. 99 | data Progress s 100 | = Progress 101 | { progressDone :: !Int 102 | -- ^ Amount of work completed. 103 | , progressTodo :: !Int 104 | -- ^ Total amount of work. 105 | , progressCustom :: !s 106 | -- ^ A value which is used by custom labels. The builtin labels 107 | -- do not care about this field. You can ignore it by using the 108 | -- unit value '()'. 109 | } 110 | 111 | progressFinished :: Progress s -> Bool 112 | progressFinished p = progressDone p >= progressTodo p 113 | 114 | -- | Creates a progress bar. 115 | -- 116 | -- The progress bar is drawn immediately. Update the progress bar with 117 | -- 'updateProgress' or 'incProgress'. Do not output anything to your 118 | -- terminal between updates. It will mess up the animation. 119 | -- 120 | -- The progress bar is written to 'stderr'. Write to another handle 121 | -- with 'hNewProgressBar'. 122 | newProgressBar 123 | :: Style s -- ^ Visual style of the progress bar. 124 | -> Double -- ^ Maximum refresh rate in Hertz. 125 | -> Progress s -- ^ Initial progress. 126 | -> IO (ProgressBar s) 127 | newProgressBar = hNewProgressBar stderr 128 | 129 | -- | Creates a progress bar which outputs to the given handle. 130 | -- 131 | -- See 'newProgressBar'. 132 | hNewProgressBar 133 | :: Handle 134 | -- ^ File handle on which the progress bar is drawn. Usually 135 | -- you select a standard stream like 'stderr' or 'stdout'. 136 | -> Style s -- ^ Visual style of the progress bar. 137 | -> Double -- ^ Maximum refresh rate in Hertz. 138 | -> Progress s -- ^ Initial progress. 139 | -> IO (ProgressBar s) 140 | hNewProgressBar hndl style maxRefreshRate initProgress = do 141 | style' <- updateWidth style 142 | 143 | startTime <- getCurrentTime 144 | hPutProgressBar hndl style' initProgress (Timing startTime startTime) 145 | 146 | stateMv <- newMVar 147 | State 148 | { stProgress = initProgress 149 | , stRenderTime = startTime 150 | } 151 | pure ProgressBar 152 | { pbStyle = style' 153 | , pbStateMv = stateMv 154 | , pbRefreshDelay = recip maxRefreshRate 155 | , pbStartTime = startTime 156 | , pbHandle = hndl 157 | } 158 | 159 | -- | Update the width based on the current terminal. 160 | updateWidth :: Style s -> IO (Style s) 161 | updateWidth style = 162 | case styleWidth style of 163 | ConstantWidth {} -> pure style 164 | TerminalWidth {} -> do 165 | mbWindow <- TS.size 166 | pure $ case mbWindow of 167 | Nothing -> style 168 | Just window -> style{ styleWidth = TerminalWidth (TS.width window) } 169 | 170 | -- | Change the progress of a progress bar. 171 | -- 172 | -- This function is thread safe. Multiple threads may update a single 173 | -- progress bar at the same time. 174 | -- 175 | -- There is a maximum refresh rate. This means that some updates might not be drawn. 176 | updateProgress 177 | :: forall s 178 | . ProgressBar s -- ^ Progress bar to update. 179 | -> (Progress s -> Progress s) -- ^ Function to change the progress. 180 | -> IO () 181 | updateProgress progressBar f = do 182 | updateTime <- getCurrentTime 183 | modifyMVar_ (pbStateMv progressBar) $ renderAndUpdate updateTime 184 | where 185 | renderAndUpdate :: UTCTime -> State s -> IO (State s) 186 | renderAndUpdate updateTime state = do 187 | when shouldRender $ 188 | hPutProgressBar hndl (pbStyle progressBar) newProgress timing 189 | pure State 190 | { stProgress = newProgress 191 | , stRenderTime = if shouldRender then updateTime else stRenderTime state 192 | } 193 | where 194 | timing = Timing 195 | { timingStart = pbStartTime progressBar 196 | , timingLastUpdate = updateTime 197 | } 198 | 199 | shouldRender = not tooFast || finished 200 | tooFast = secSinceLastRender <= pbRefreshDelay progressBar 201 | finished = progressFinished newProgress 202 | 203 | newProgress = f $ stProgress state 204 | 205 | -- Amount of time that passed since last render, in seconds. 206 | secSinceLastRender :: Double 207 | secSinceLastRender = realToFrac $ diffUTCTime updateTime (stRenderTime state) 208 | 209 | hndl = pbHandle progressBar 210 | 211 | -- | Increment the progress of an existing progress bar. 212 | -- 213 | -- See 'updateProgress' for more information. 214 | incProgress 215 | :: ProgressBar s -- ^ Progress bar which needs an update. 216 | -> Int -- ^ Amount by which to increment the progress. 217 | -> IO () 218 | incProgress pb n = updateProgress pb $ \p -> p{ progressDone = progressDone p + n } 219 | 220 | hPutProgressBar :: Handle -> Style s -> Progress s -> Timing -> IO () 221 | hPutProgressBar hndl style progress timing = do 222 | TL.hPutStr hndl $ renderProgressBar style progress timing 223 | TL.hPutStr hndl $ 224 | if progressFinished progress 225 | then case styleOnComplete style of 226 | WriteNewline -> "\n" 227 | -- Move to beginning of line and then clear everything to 228 | -- the right of the cursor. 229 | Clear -> "\r\ESC[K" 230 | else "\r" 231 | hFlush hndl 232 | 233 | -- | Renders a progress bar. 234 | -- 235 | -- >>> let t = UTCTime (ModifiedJulianDay 0) 0 236 | -- >>> renderProgressBar defStyle (Progress 30 100 ()) (Timing t t) 237 | -- "[============>..............................] 30%" 238 | -- 239 | -- Note that this function can not use 'TerminalWidth' because it 240 | -- doesn't use 'IO'. Use 'newProgressBar' or 'hNewProgressBar' to get 241 | -- automatic width. 242 | renderProgressBar 243 | :: Style s 244 | -> Progress s -- ^ Current progress. 245 | -> Timing -- ^ Timing information. 246 | -> TL.Text -- ^ Textual representation of the 'Progress' in the given 'Style'. 247 | renderProgressBar style progress timing = TL.concat 248 | [ styleEscapePrefix style progress 249 | , prefixLabel 250 | , prefixPad 251 | , styleEscapeOpen style progress 252 | , styleOpen style 253 | , styleEscapeDone style progress 254 | , TL.replicate completed $ TL.singleton $ styleDone style 255 | , styleEscapeCurrent style progress 256 | , if remaining /= 0 && completed /= 0 257 | then TL.singleton $ styleCurrent style 258 | else "" 259 | , styleEscapeTodo style progress 260 | , TL.replicate 261 | (remaining - if completed /= 0 then 1 else 0) 262 | (TL.singleton $ styleTodo style) 263 | , styleEscapeClose style progress 264 | , styleClose style 265 | , styleEscapePostfix style progress 266 | , postfixPad 267 | , postfixLabel 268 | ] 269 | where 270 | todo = fromIntegral $ progressTodo progress 271 | done = fromIntegral $ progressDone progress 272 | -- Amount of (visible) characters that should be used to display to progress bar. 273 | width = fromIntegral $ getProgressBarWidth $ styleWidth style 274 | 275 | -- Amount of work completed. 276 | fraction :: Ratio Int64 277 | fraction | todo /= 0 = done % todo 278 | | otherwise = 0 % 1 279 | 280 | -- Amount of characters available to visualize the progress. 281 | effectiveWidth = max 0 $ width - usedSpace 282 | -- Amount of printing characters needed to visualize everything except the bar . 283 | usedSpace = TL.length (styleOpen style) 284 | + TL.length (styleClose style) 285 | + TL.length prefixLabel 286 | + TL.length postfixLabel 287 | + TL.length prefixPad 288 | + TL.length postfixPad 289 | 290 | -- Number of characters needed to represent the amount of work 291 | -- that is completed. Note that this can not always be represented 292 | -- by an integer. 293 | numCompletedChars :: Ratio Int64 294 | numCompletedChars = fraction * (effectiveWidth % 1) 295 | 296 | completed, remaining :: Int64 297 | completed = min effectiveWidth $ floor numCompletedChars 298 | remaining = effectiveWidth - completed 299 | 300 | prefixLabel, postfixLabel :: TL.Text 301 | prefixLabel = runLabel (stylePrefix style) progress timing 302 | postfixLabel = runLabel (stylePostfix style) progress timing 303 | 304 | prefixPad, postfixPad :: TL.Text 305 | prefixPad = pad prefixLabel 306 | postfixPad = pad postfixLabel 307 | 308 | pad :: TL.Text -> TL.Text 309 | pad s | TL.null s = TL.empty 310 | | otherwise = TL.singleton ' ' 311 | 312 | -- | Width of progress bar in characters. 313 | data ProgressBarWidth 314 | = ConstantWidth !Int 315 | -- ^ A constant width. 316 | | TerminalWidth !Int 317 | -- ^ Use the entire width of the terminal. 318 | -- 319 | -- Identical to 'ConstantWidth' if the width of the terminal can 320 | -- not be determined. 321 | deriving (Generic) 322 | 323 | instance NFData ProgressBarWidth 324 | 325 | getProgressBarWidth :: ProgressBarWidth -> Int 326 | getProgressBarWidth (ConstantWidth n) = n 327 | getProgressBarWidth (TerminalWidth n) = n 328 | 329 | {- | Visual style of a progress bar. 330 | 331 | The style determines how a progress bar is rendered to text. 332 | 333 | The textual representation of a progress bar follows the following template: 334 | 335 | \<__prefix__>\<__open__>\<__done__>\<__current__>\<__todo__>\<__close__>\<__postfix__> 336 | 337 | Where \<__done__> and \<__todo__> are repeated as often as necessary. 338 | 339 | Consider the following progress bar 340 | 341 | > "Working [=======>.................] 30%" 342 | 343 | This bar can be specified using the following style: 344 | 345 | @ 346 | 'Style' 347 | { 'styleOpen' = \"[" 348 | , 'styleClose' = \"]" 349 | , 'styleDone' = \'=' 350 | , 'styleCurrent' = \'>' 351 | , 'styleTodo' = \'.' 352 | , 'stylePrefix' = 'msg' \"Working" 353 | , 'stylePostfix' = 'percentage' 354 | , 'styleWidth' = 'ConstantWidth' 40 355 | , 'styleEscapeOpen' = const 'TL.empty' 356 | , 'styleEscapeClose' = const 'TL.empty' 357 | , 'styleEscapeDone' = const 'TL.empty' 358 | , 'styleEscapeCurrent' = const 'TL.empty' 359 | , 'styleEscapeTodo' = const 'TL.empty' 360 | , 'styleEscapePrefix' = const 'TL.empty' 361 | , 'styleEscapePostfix' = const 'TL.empty' 362 | , 'styleOnComplete' = 'WriteNewline' 363 | } 364 | @ 365 | -} 366 | data Style s 367 | = Style 368 | { styleOpen :: !TL.Text 369 | -- ^ Bar opening symbol. 370 | , styleClose :: !TL.Text 371 | -- ^ Bar closing symbol 372 | , styleDone :: !Char 373 | -- ^ Completed work. 374 | , styleCurrent :: !Char 375 | -- ^ Symbol used to denote the current amount of work that has been done. 376 | , styleTodo :: !Char 377 | -- ^ Work not yet completed. 378 | , stylePrefix :: Label s 379 | -- ^ Prefixed label. 380 | , stylePostfix :: Label s 381 | -- ^ Postfixed label. 382 | , styleWidth :: !ProgressBarWidth 383 | -- ^ Total width of the progress bar. 384 | , styleEscapeOpen :: EscapeCode s 385 | -- ^ Escape code printed just before the 'styleOpen' symbol. 386 | , styleEscapeClose :: EscapeCode s 387 | -- ^ Escape code printed just before the 'styleClose' symbol. 388 | , styleEscapeDone :: EscapeCode s 389 | -- ^ Escape code printed just before the first 'styleDone' character. 390 | , styleEscapeCurrent :: EscapeCode s 391 | -- ^ Escape code printed just before the 'styleCurrent' character. 392 | , styleEscapeTodo :: EscapeCode s 393 | -- ^ Escape code printed just before the first 'styleTodo' character. 394 | , styleEscapePrefix :: EscapeCode s 395 | -- ^ Escape code printed just before the 'stylePrefix' label. 396 | , styleEscapePostfix :: EscapeCode s 397 | -- ^ Escape code printed just before the 'stylePostfix' label. 398 | , styleOnComplete :: !OnComplete 399 | -- ^ What happens when progress is finished. 400 | } deriving (Generic) 401 | 402 | instance (NFData s) => NFData (Style s) 403 | 404 | -- | An escape code is a sequence of bytes which the terminal looks 405 | -- for and interprets as commands, not as character codes. 406 | -- 407 | -- It is vital that the output of this function, when send to the 408 | -- terminal, does not result in characters being drawn. 409 | type EscapeCode s 410 | = Progress s -- ^ Current progress bar state. 411 | -> TL.Text -- ^ Resulting escape code. Must be non-printable. 412 | 413 | -- | What happens when a progress bar is finished. 414 | data OnComplete 415 | = WriteNewline 416 | -- ^ Write a new line when the progress bar is finished. The 417 | -- completed progress bar will remain visible. 418 | | Clear -- ^ Clear the progress bar once it is finished. 419 | deriving (Generic) 420 | 421 | instance NFData OnComplete 422 | 423 | -- | The default style. 424 | -- 425 | -- This style shows the progress as a percentage. It does not use any 426 | -- escape sequences. 427 | -- 428 | -- Override some fields of the default instead of specifying all the 429 | -- fields of a 'Style' record. 430 | defStyle :: Style s 431 | defStyle = 432 | Style 433 | { styleOpen = "[" 434 | , styleClose = "]" 435 | , styleDone = '=' 436 | , styleCurrent = '>' 437 | , styleTodo = '.' 438 | , stylePrefix = mempty 439 | , stylePostfix = percentage 440 | , styleWidth = TerminalWidth 50 441 | , styleEscapeOpen = const TL.empty 442 | , styleEscapeClose = const TL.empty 443 | , styleEscapeDone = const TL.empty 444 | , styleEscapeCurrent = const TL.empty 445 | , styleEscapeTodo = const TL.empty 446 | , styleEscapePrefix = const TL.empty 447 | , styleEscapePostfix = const TL.empty 448 | , styleOnComplete = WriteNewline 449 | } 450 | 451 | -- | A label is a part of a progress bar that changes based on the progress. 452 | -- 453 | -- Labels can be at the front (prefix) or at the back (postfix) of a progress bar. 454 | -- 455 | -- Labels can use both the current amount of progress and the timing 456 | -- information to generate some text. 457 | newtype Label s = Label{ runLabel :: Progress s -> Timing -> TL.Text } deriving (NFData) 458 | 459 | -- | Combining labels combines their output. 460 | instance Semigroup (Label s) where 461 | Label f <> Label g = Label $ \p t -> f p t <> g p t 462 | 463 | -- | The mempty label always outputs an empty text. 464 | instance Monoid (Label s) where 465 | mempty = msg TL.empty 466 | mappend = (<>) 467 | 468 | -- | Every string is a label which ignores its input and just outputs 469 | -- that string. 470 | instance IsString (Label s) where 471 | fromString = msg . TL.pack 472 | 473 | -- | Timing information about a 'ProgressBar'. 474 | -- 475 | -- This information is used by 'Label's to calculate elapsed time, remaining time, total time, etc. 476 | -- 477 | -- See 'elapsedTime', 'remainingTime' and 'totalTime'. 478 | data Timing 479 | = Timing 480 | { timingStart :: !UTCTime 481 | -- ^ Moment in time when a progress bar was created. See 482 | -- 'newProgressBar'. 483 | , timingLastUpdate :: !UTCTime 484 | -- ^ Moment in time of the most recent progress update. 485 | } 486 | 487 | -- | Static text. 488 | -- 489 | -- The output does not depend on the input. 490 | -- 491 | -- >>> msg "foo" st 492 | -- "foo" 493 | msg :: TL.Text -> Label s 494 | msg s = Label $ \_ _ -> s 495 | 496 | -- | Progress as a percentage. 497 | -- 498 | -- >>> runLabel $ percentage (Progress 30 100 ()) someTiming 499 | -- " 30%" 500 | -- 501 | -- __Note__: if no work is to be done (todo == 0) the percentage will 502 | -- be shown as 100%. 503 | percentage :: Label s 504 | percentage = Label render 505 | where 506 | render progress _timing 507 | | todo == 0 = "100%" 508 | | otherwise = TL.justifyRight 4 ' ' $ TLB.toLazyText $ 509 | TLB.decimal (round (done % todo * 100) :: Int) 510 | <> TLB.singleton '%' 511 | where 512 | done = progressDone progress 513 | todo = progressTodo progress 514 | 515 | -- | Progress as a fraction of the total amount of work. 516 | -- 517 | -- >>> runLabel $ exact (Progress 30 100 ()) someTiming 518 | -- " 30/100" 519 | exact :: Label s 520 | exact = Label render 521 | where 522 | render progress _timing = 523 | TL.justifyRight (TL.length todoStr) ' ' doneStr <> "/" <> todoStr 524 | where 525 | todoStr = TLB.toLazyText $ TLB.decimal todo 526 | doneStr = TLB.toLazyText $ TLB.decimal done 527 | 528 | done = progressDone progress 529 | todo = progressTodo progress 530 | 531 | -- | Amount of time that has elapsed. 532 | -- 533 | -- Time starts when a progress bar is created. 534 | -- 535 | -- The user must supply a function which actually renders the amount 536 | -- of time that has elapsed. You can use 'renderDuration' or 537 | -- @formatTime@ from time >= 1.9. 538 | elapsedTime 539 | :: (NominalDiffTime -> TL.Text) 540 | -> Label s 541 | elapsedTime formatNDT = Label render 542 | where 543 | render _progress timing = formatNDT dt 544 | where 545 | dt :: NominalDiffTime 546 | dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) 547 | 548 | -- | Estimated remaining time. 549 | -- 550 | -- Tells you how much longer some task is expected to take. 551 | -- 552 | -- This label uses a simple estimation algorithm. It assumes progress 553 | -- is linear. To prevent nonsense results it won't estimate remaining 554 | -- time until at least 1 second of work has been done. 555 | -- 556 | -- When it refuses to estimate the remaining time it will show an 557 | -- alternative message instead. 558 | -- 559 | -- The user must supply a function which actually renders the amount 560 | -- of time that has elapsed. Use 'renderDuration' or @formatTime@ from 561 | -- the time >= 1.9 package. 562 | remainingTime 563 | :: (NominalDiffTime -> TL.Text) 564 | -> TL.Text 565 | -- ^ Alternative message when remaining time can't be 566 | -- calculated (yet). 567 | -> Label s 568 | remainingTime formatNDT altMsg = Label render 569 | where 570 | render progress timing 571 | | progressDone progress <= 0 = altMsg 572 | | dt > 1 = formatNDT estimatedRemainingTime 573 | | otherwise = altMsg 574 | where 575 | estimatedRemainingTime = estimatedTotalTime - dt 576 | estimatedTotalTime = dt * recip progressFraction 577 | 578 | progressFraction :: NominalDiffTime 579 | progressFraction 580 | | progressTodo progress <= 0 = 1 581 | | otherwise = fromIntegral (progressDone progress) 582 | / fromIntegral (progressTodo progress) 583 | 584 | dt :: NominalDiffTime 585 | dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) 586 | 587 | -- | Estimated total time. 588 | -- 589 | -- This label uses a simple estimation algorithm. It assumes progress 590 | -- is linear. To prevent nonsense results it won't estimate the total 591 | -- time until at least 1 second of work has been done. 592 | -- 593 | -- When it refuses to estimate the total time it will show an 594 | -- alternative message instead. 595 | -- 596 | -- The user must supply a function which actually renders the total 597 | -- amount of time that a task will take. You can use 'renderDuration' 598 | -- or @formatTime@ from the time >= 1.9 package. 599 | totalTime 600 | :: (NominalDiffTime -> TL.Text) 601 | -> TL.Text 602 | -- ^ Alternative message when total time can't be calculated 603 | -- (yet). 604 | -> Label s 605 | totalTime formatNDT altMsg = Label render 606 | where 607 | render progress timing 608 | | dt > 1 = formatNDT estimatedTotalTime 609 | | progressDone progress <= 0 = altMsg 610 | | otherwise = altMsg 611 | where 612 | estimatedTotalTime = dt * recip progressFraction 613 | 614 | progressFraction :: NominalDiffTime 615 | progressFraction 616 | | progressTodo progress <= 0 = 1 617 | | otherwise = fromIntegral (progressDone progress) 618 | / fromIntegral (progressTodo progress) 619 | 620 | dt :: NominalDiffTime 621 | dt = diffUTCTime (timingLastUpdate timing) (timingStart timing) 622 | 623 | -- | Show amount of time. 624 | -- 625 | -- > renderDuration (fromInteger 42) 626 | -- 42 627 | -- 628 | -- > renderDuration (fromInteger $ 5 * 60 + 42) 629 | -- 05:42 630 | -- 631 | -- > renderDuration (fromInteger $ 8 * 60 * 60 + 5 * 60 + 42) 632 | -- 08:05:42 633 | -- 634 | -- Use the time >= 1.9 package to get a formatTime function which 635 | -- accepts 'NominalDiffTime'. 636 | renderDuration :: NominalDiffTime -> TL.Text 637 | renderDuration dt = hTxt <> mTxt <> sTxt 638 | where 639 | hTxt | h == 0 = mempty 640 | | otherwise = renderDecimal h <> ":" 641 | mTxt | m == 0 = mempty 642 | | otherwise = renderDecimal m <> ":" 643 | sTxt = renderDecimal s 644 | 645 | (h, hRem) = ts `quotRem` 3600 646 | (m, s ) = hRem `quotRem` 60 647 | 648 | -- Total amount of seconds 649 | ts :: Int 650 | ts = round dt 651 | 652 | renderDecimal n = TL.justifyRight 2 '0' $ TLB.toLazyText $ TLB.decimal n 653 | 654 | {- $start 655 | 656 | You want to perform some task which will take some time. You wish to 657 | show the progress of this task in the terminal. 658 | 659 | 1. Determine the total amount of work 660 | 661 | 2. Create a progress bar with 'newProgressBar' 662 | 663 | 3. For each unit of work: 664 | 665 | 3a. Perform the work 666 | 667 | 3b. Update the progress bar with 'incProgress' 668 | 669 | Explore the 'Style' and the 'Label' types to see various ways in which 670 | you can customize the progress bar. 671 | 672 | You do not have to close the progress bar, or even finish the task. It 673 | is perfectly fine to stop half way (maybe your task throws an 674 | exception). 675 | 676 | Just remember to avoid outputting text to the terminal while a 677 | progress bar is active. It will mess up the output a bit. 678 | -} 679 | 680 | {- $example 681 | 682 | Write a function which represents a unit of work. This could be a file 683 | copy operation, a network operation or some other expensive 684 | calculation. This example simply waits 1 second. 685 | 686 | @ 687 | work :: IO () 688 | work = threadDelay 1000000 -- 1 second 689 | @ 690 | 691 | And you define some work to be done. This could be a list of files to 692 | process or some jobs that need to be processed. 693 | 694 | @ 695 | toBeDone :: [()] 696 | toBeDone = replicate 20 () 697 | @ 698 | 699 | Now create the progress bar. Use the default style and choose a 700 | maximum refresh rate of 10 Hz. The initial progress is 0 work done out 701 | of 20. 702 | 703 | @ 704 | pb <- 'newProgressBar' 'defStyle' 10 ('Progress' 0 20 ()) 705 | @ 706 | 707 | Start performing the work while keeping the user informed of the progress: 708 | 709 | @ 710 | for_ toBeDone $ \() -> do 711 | work -- perform 1 unit of work 712 | 'incProgress' pb 1 -- increment progress by 1 713 | @ 714 | 715 | That's it! You get a nice animated progress bar in your terminal. It 716 | will look like this: 717 | 718 | @ 719 | [==========>................................] 25% 720 | @ 721 | -} 722 | --------------------------------------------------------------------------------