{-# 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