{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
module System.Console.AsciiProgress.Internal
where
import Control.Concurrent (Chan, MVar, newChan, newEmptyMVar, newMVar,
readMVar, tryPutMVar, tryTakeMVar)
import Data.Default (Default (..))
import Data.Time.Clock
import Text.Printf
data Options = Options { Options -> String
pgFormat :: String
, Options -> Char
pgCompletedChar :: Char
, Options -> Char
pgPendingChar :: Char
, Options -> Integer
pgTotal :: Integer
, Options -> Int
pgWidth :: Int
, Options -> Maybe String
pgOnCompletion :: Maybe String
, Options -> Options -> Stats -> String
pgGetProgressStr :: Options -> Stats -> String
}
instance Default Options where
def :: Options
def = Options :: String
-> Char
-> Char
-> Integer
-> Int
-> Maybe String
-> (Options -> Stats -> String)
-> Options
Options { pgFormat :: String
pgFormat = String
"Working :percent [:bar] :current/:total " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"(for :elapsed, :eta remaining)"
, pgCompletedChar :: Char
pgCompletedChar = Char
'='
, pgPendingChar :: Char
pgPendingChar = Char
' '
, pgTotal :: Integer
pgTotal = Integer
20
, pgWidth :: Int
pgWidth = Int
80
, pgOnCompletion :: Maybe String
pgOnCompletion = Maybe String
forall a. Maybe a
Nothing
, pgGetProgressStr :: Options -> Stats -> String
pgGetProgressStr = Options -> Stats -> String
getProgressStr
}
data ProgressBarInfo = ProgressBarInfo { ProgressBarInfo -> Options
pgOptions :: Options
, ProgressBarInfo -> Chan Integer
pgChannel :: Chan Integer
, ProgressBarInfo -> MVar Integer
pgCompleted :: MVar Integer
, ProgressBarInfo -> MVar UTCTime
pgFirstTick :: MVar UTCTime
}
data Stats = Stats { Stats -> Integer
stTotal :: Integer
, Stats -> Integer
stCompleted :: Integer
, Stats -> Integer
stRemaining :: Integer
, Stats -> Double
stElapsed :: Double
, Stats -> Double
stPercent :: Double
, Stats -> Double
stEta :: Double
}
newProgressBarInfo :: Options -> IO ProgressBarInfo
newProgressBarInfo :: Options -> IO ProgressBarInfo
newProgressBarInfo Options
opts = do
Chan Integer
chan <- IO (Chan Integer)
forall a. IO (Chan a)
newChan
MVar Integer
mcompleted <- Integer -> IO (MVar Integer)
forall a. a -> IO (MVar a)
newMVar Integer
0
MVar UTCTime
mfirstTick <- IO (MVar UTCTime)
forall a. IO (MVar a)
newEmptyMVar
ProgressBarInfo -> IO ProgressBarInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressBarInfo -> IO ProgressBarInfo)
-> ProgressBarInfo -> IO ProgressBarInfo
forall a b. (a -> b) -> a -> b
$ Options
-> Chan Integer -> MVar Integer -> MVar UTCTime -> ProgressBarInfo
ProgressBarInfo Options
opts Chan Integer
chan MVar Integer
mcompleted MVar UTCTime
mfirstTick
getProgressStr :: Options -> Stats -> String
getProgressStr :: Options -> Stats -> String
getProgressStr Options{Char
Int
Integer
String
Maybe String
Options -> Stats -> String
pgGetProgressStr :: Options -> Stats -> String
pgOnCompletion :: Maybe String
pgWidth :: Int
pgTotal :: Integer
pgPendingChar :: Char
pgCompletedChar :: Char
pgFormat :: String
pgGetProgressStr :: Options -> Options -> Stats -> String
pgOnCompletion :: Options -> Maybe String
pgWidth :: Options -> Int
pgTotal :: Options -> Integer
pgPendingChar :: Options -> Char
pgCompletedChar :: Options -> Char
pgFormat :: Options -> String
..} Stats{Double
Integer
stEta :: Double
stPercent :: Double
stElapsed :: Double
stRemaining :: Integer
stCompleted :: Integer
stTotal :: Integer
stEta :: Stats -> Double
stPercent :: Stats -> Double
stElapsed :: Stats -> Double
stRemaining :: Stats -> Integer
stCompleted :: Stats -> Integer
stTotal :: Stats -> Integer
..} = String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
":bar" String
barStr String
statsStr
where
statsStr :: String
statsStr = [(String, String)] -> String -> String
forall a. Eq a => [([a], [a])] -> [a] -> [a]
replaceMany
[ (String
":elapsed", String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%5.1f" Double
stElapsed)
, (String
":current", String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%3d" Integer
stCompleted)
, (String
":total" , String -> Integer -> String
forall r. PrintfType r => String -> r
printf String
"%3d" Integer
stTotal)
, (String
":percent", String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%3d%%" (Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
100 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
stPercent) :: Int))
, (String
":eta" , String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"%5.1f" Double
stEta)
]
String
pgFormat
barWidth :: Int
barWidth = Int
pgWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> String -> String -> String
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace String
":bar" String
"" String
statsStr)
barStr :: String
barStr = Char -> Char -> Int -> Double -> String
getBar Char
pgCompletedChar Char
pgPendingChar Int
barWidth Double
stPercent
getInfoStats :: ProgressBarInfo -> IO Stats
getInfoStats :: ProgressBarInfo -> IO Stats
getInfoStats ProgressBarInfo
info = do
Integer
completed <- MVar Integer -> IO Integer
forall a. MVar a -> IO a
readMVar (ProgressBarInfo -> MVar Integer
pgCompleted ProgressBarInfo
info)
UTCTime
currentTime <- IO UTCTime
getCurrentTime
UTCTime
initTime <- MVar UTCTime -> UTCTime -> IO UTCTime
forall a. MVar a -> a -> IO a
forceReadMVar (ProgressBarInfo -> MVar UTCTime
pgFirstTick ProgressBarInfo
info) UTCTime
currentTime
let total :: Integer
total = Options -> Integer
pgTotal (ProgressBarInfo -> Options
pgOptions ProgressBarInfo
info)
remaining :: Integer
remaining = Integer
total Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
completed
elapsed :: Double
elapsed = UTCTime -> UTCTime -> Double
getElapsed UTCTime
initTime UTCTime
currentTime
percent :: Double
percent = Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
completed Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
total
eta :: Double
eta = Integer -> Integer -> Double -> Double
getEta Integer
completed Integer
remaining Double
elapsed
Stats -> IO Stats
forall (m :: * -> *) a. Monad m => a -> m a
return (Stats -> IO Stats) -> Stats -> IO Stats
forall a b. (a -> b) -> a -> b
$ Integer
-> Integer -> Integer -> Double -> Double -> Double -> Stats
Stats Integer
total Integer
completed Integer
remaining Double
elapsed Double
percent Double
eta
getBar :: Char -> Char -> Int -> Double -> String
getBar :: Char -> Char -> Int -> Double -> String
getBar Char
completedChar Char
pendingChar Int
width Double
percent =
Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
bcompleted Char
completedChar String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
bremaining Char
pendingChar
where
fwidth :: Double
fwidth = Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
width
bcompleted :: Int
bcompleted = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
fwidth Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
percent
bremaining :: Int
bremaining = Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bcompleted
getElapsed :: UTCTime -> UTCTime -> Double
getElapsed :: UTCTime -> UTCTime -> Double
getElapsed UTCTime
initTime UTCTime
currentTime = NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
currentTime UTCTime
initTime)
getEta :: Integer -> Integer -> Double -> Double
getEta :: Integer -> Integer -> Double -> Double
getEta Integer
0 Integer
_ Double
_ = Double
0
getEta Integer
completed Integer
remaining Double
elapsed = Double
averageSecsPerTick Double -> Double -> Double
forall a. Num a => a -> a -> a
* Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
remaining
where
averageSecsPerTick :: Double
averageSecsPerTick = Double
elapsed Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
completed
replaceMany :: Eq a => [([a], [a])] -> [a] -> [a]
replaceMany :: [([a], [a])] -> [a] -> [a]
replaceMany [([a], [a])]
pairs [a]
target = (([a], [a]) -> [a] -> [a]) -> [a] -> [([a], [a])] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (([a] -> [a] -> [a] -> [a]) -> ([a], [a]) -> [a] -> [a]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace) [a]
target [([a], [a])]
pairs
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace :: [a] -> [a] -> [a] -> [a]
replace [a]
_ [a]
_ [] = []
replace [] [a]
new [a]
target = [a]
new [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
target
replace [a]
old [a]
new target :: [a]
target@(a
t:[a]
ts) =
if Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
len [a]
target [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
old
then [a]
new [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
old [a]
new (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
len [a]
target)
else a
t a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [a]
old [a]
new [a]
ts
where len :: Int
len = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
old
forceReadMVar :: MVar a -> a -> IO a
forceReadMVar :: MVar a -> a -> IO a
forceReadMVar MVar a
mv a
v = MVar a -> IO (Maybe a)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar a
mv IO (Maybe a) -> (Maybe a -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe a
m -> case Maybe a
m of
Maybe a
Nothing -> do
Bool
success <- MVar a -> a -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
mv a
v
if Bool
success
then a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v
else MVar a -> IO a
forall a. MVar a -> IO a
readMVar MVar a
mv
Just a
o -> do
Bool
_ <- MVar a -> a -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
mv a
o
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
o