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

-- |
-- The progress bar's options.
data Options = Options { Options -> String
pgFormat         :: String
                       -- ^ A format string for the progress bar. Currently the
                       -- following format strings are supported:
                       -- - ":eta" (ETA displayed in seconds)
                       -- - ":current" (current tick)
                       -- - ":total" (total number of ticks)
                       -- - ":percent" (percentage completed)
                       -- - ":elapsed" (elapsed time in seconds)
                       -- - ":bar" (the actual progress bar)
                       , Options -> Char
pgCompletedChar  :: Char
                       -- ^ Character to be used on the completed part of the
                       -- bar
                       , Options -> Char
pgPendingChar    :: Char
                       -- ^ Character to be used on the pending part of the bar
                       , Options -> Integer
pgTotal          :: Integer
                       -- ^ Total amount of ticks expected
                       , Options -> Int
pgWidth          :: Int
                       -- ^ The progress bar's width
                       , Options -> Maybe String
pgOnCompletion   :: Maybe String
                       -- ^ What to output when the progress bar is done. The same format placeholders used
                       -- in `pgFormat` may be used.
                       , 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
                  }

-- |
-- The progress bar's state object. Contains all but the printing thread's
-- @Async@ object.
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
                                       }

-- |
-- Represents a point in time for the progress bar.
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
                   }

-- |
-- Creates a new empty progress bar info object.
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

-- |
-- Gets the string to be printed given the options object and a certain stats
-- object representing the rendering moment.
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

-- |
-- Creates a stats object for a given @ProgressBarInfo@ node. This is the core
-- logic, isolated, and may be used to make the same analysis code to be used
-- by different progress renderers.
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

-- |
-- Generates the actual progress bar string, with its completed/pending
-- characters, width and a completeness percentage.
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

-- |
-- Gets the amount of seconds elapsed between two @UTCTime@s as a double.
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)

-- |
-- Gets the ETA, given the elapsed time and the amount of completed and
-- remaining ticks.
--
-- >>> getEta 50 50 10.0
-- 10.0
-- >>> getEta 30 70 23.3
-- 54.366666666666674
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

-- |
-- Replaces each pair in a list of replacement pairs in a list with replace.
-- The idea is to call @(\(old, new) target -> replace old new target)@ on each
-- of the pairs, accumulating the resulting modified list.
--
-- >>> replaceMany [] "foobar"
-- "foobar"
-- >>> replaceMany [("bar", "biz")] "foobar"
-- "foobiz"
-- >>> replaceMany [("foo", "baz"), ("bar", "biz")] "foobar"
-- "bazbiz"
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

-- |
-- Replaces a subsequence by another in a sequence
--
-- Taken from http://bluebones.net/2007/01/replace-in-haskell/
--
-- >>> replace "foo" "baz" "foobar"
-- "bazbar"
-- >>> replace "some" "thing" "something something"
-- "thingthing thingthing"
-- >>> replace "not" "" "something"
-- "something"
-- >>> replace "" "here" "something"
-- "heresomething"
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

-- |
-- Forces an MVar's contents to be read or swaped by a default value, even if
-- it's currently empty. Will discard the default value write to the MVar if it
-- becomes full in the middle of the operation and return its value. It's
-- assumed that once the MVar becomes full, it won't ever be left emptied. This
-- code may deadlock if that's the case.
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