{-# LANGUAGE Safe #-}
module Data.Progress.Meter (
ProgressMeter,
simpleNewMeter,
newMeter,
setComponents,
addComponent,
removeComponent,
setWidth,
renderMeter,
displayMeter,
clearMeter,
writeMeterString,
autoDisplayMeter,
killAutoDisplayMeter
) where
import safe Data.Progress.Tracker
( ProgressStatuses(..),
Progress,
ProgressStatus(totalUnits, completedUnits, trackerName),
getSpeed,
getETR )
import safe Control.Concurrent
( modifyMVar_,
withMVar,
newMVar,
MVar,
threadDelay,
forkIO,
myThreadId,
yield,
ThreadId )
import Control.Monad (when)
import Data.String.Utils (join)
import System.Time.Utils (renderSecs)
import Data.Quantity (renderNums, binaryOpts)
import safe System.IO ( Handle, hFlush, hPutStr )
import Control.Monad (filterM)
data ProgressMeterR =
ProgressMeterR {ProgressMeterR -> Progress
masterP :: Progress,
ProgressMeterR -> [Progress]
components :: [Progress],
ProgressMeterR -> Int
width :: Int,
ProgressMeterR -> String
unit :: String,
ProgressMeterR -> [Integer] -> [String]
renderer :: [Integer] -> [String],
ProgressMeterR -> [ThreadId]
autoDisplayers :: [ThreadId]
}
type ProgressMeter = MVar ProgressMeterR
simpleNewMeter :: Progress -> IO ProgressMeter
simpleNewMeter :: Progress -> IO ProgressMeter
simpleNewMeter Progress
pt = Progress
-> String -> Int -> ([Integer] -> [String]) -> IO ProgressMeter
newMeter Progress
pt String
"B" Int
80 (SizeOpts -> Int -> [Integer] -> [String]
forall a. (Ord a, Real a) => SizeOpts -> Int -> [a] -> [String]
renderNums SizeOpts
binaryOpts Int
1)
newMeter :: Progress
-> String
-> Int
-> ([Integer] -> [String])
-> IO ProgressMeter
newMeter :: Progress
-> String -> Int -> ([Integer] -> [String]) -> IO ProgressMeter
newMeter Progress
tracker String
u Int
w [Integer] -> [String]
rfunc =
ProgressMeterR -> IO ProgressMeter
forall a. a -> IO (MVar a)
newMVar (ProgressMeterR -> IO ProgressMeter)
-> ProgressMeterR -> IO ProgressMeter
forall a b. (a -> b) -> a -> b
$ ProgressMeterR {masterP :: Progress
masterP = Progress
tracker, components :: [Progress]
components = [],
width :: Int
width = Int
w, renderer :: [Integer] -> [String]
renderer = [Integer] -> [String]
rfunc, autoDisplayers :: [ThreadId]
autoDisplayers = [],
unit :: String
unit = String
u}
setComponents :: ProgressMeter -> [Progress] -> IO ()
setComponents :: ProgressMeter -> [Progress] -> IO ()
setComponents ProgressMeter
meter [Progress]
componentlist = ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter (\ProgressMeterR
m -> ProgressMeterR -> IO ProgressMeterR
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressMeterR -> IO ProgressMeterR)
-> ProgressMeterR -> IO ProgressMeterR
forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {components = componentlist})
addComponent :: ProgressMeter -> Progress -> IO ()
addComponent :: ProgressMeter -> Progress -> IO ()
addComponent ProgressMeter
meter Progress
component =
ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter (\ProgressMeterR
m -> ProgressMeterR -> IO ProgressMeterR
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressMeterR -> IO ProgressMeterR)
-> ProgressMeterR -> IO ProgressMeterR
forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {components = component : components m})
removeComponent :: ProgressMeter -> String -> IO ()
removeComponent :: ProgressMeter -> String -> IO ()
removeComponent ProgressMeter
meter String
componentname = ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter ((ProgressMeterR -> IO ProgressMeterR) -> IO ())
-> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressMeterR
m ->
do [Progress]
newc <- (Progress -> IO Bool) -> [Progress] -> IO [Progress]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\Progress
x -> Progress -> (ProgressStatus -> IO Bool) -> IO Bool
forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus Progress
x (\ProgressStatus
y -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ ProgressStatus -> String
trackerName ProgressStatus
y String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
componentname))
(ProgressMeterR -> [Progress]
components ProgressMeterR
m)
ProgressMeterR -> IO ProgressMeterR
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressMeterR -> IO ProgressMeterR)
-> ProgressMeterR -> IO ProgressMeterR
forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {components = newc}
setWidth :: ProgressMeter -> Int -> IO ()
setWidth :: ProgressMeter -> Int -> IO ()
setWidth ProgressMeter
meter Int
w = ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter (\ProgressMeterR
m -> ProgressMeterR -> IO ProgressMeterR
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressMeterR -> IO ProgressMeterR)
-> ProgressMeterR -> IO ProgressMeterR
forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {width = w})
displayMeter :: Handle -> ProgressMeter -> IO ()
displayMeter :: Handle -> ProgressMeter -> IO ()
displayMeter Handle
h ProgressMeter
r = ProgressMeter -> (ProgressMeterR -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
r ((ProgressMeterR -> IO ()) -> IO ())
-> (ProgressMeterR -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressMeterR
meter ->
do String
s <- ProgressMeterR -> IO String
renderMeterR ProgressMeterR
meter
Handle -> String -> IO ()
hPutStr Handle
h (String
"\r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s)
Handle -> IO ()
hFlush Handle
h
clearMeter :: Handle -> ProgressMeter -> IO ()
clearMeter :: Handle -> ProgressMeter -> IO ()
clearMeter Handle
h ProgressMeter
pm = ProgressMeter -> (ProgressMeterR -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
pm ((ProgressMeterR -> IO ()) -> IO ())
-> (ProgressMeterR -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressMeterR
m ->
do Handle -> String -> IO ()
hPutStr Handle
h (ProgressMeterR -> String
clearmeterstr ProgressMeterR
m)
Handle -> IO ()
hFlush Handle
h
writeMeterString :: Handle -> ProgressMeter -> String -> IO ()
writeMeterString :: Handle -> ProgressMeter -> String -> IO ()
writeMeterString Handle
h ProgressMeter
pm String
msg = ProgressMeter -> (ProgressMeterR -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
pm ((ProgressMeterR -> IO ()) -> IO ())
-> (ProgressMeterR -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressMeterR
meter ->
do String
s <- ProgressMeterR -> IO String
renderMeterR ProgressMeterR
meter
Handle -> String -> IO ()
hPutStr Handle
h (ProgressMeterR -> String
clearmeterstr ProgressMeterR
meter)
Handle -> String -> IO ()
hPutStr Handle
h String
msg
Handle -> String -> IO ()
hPutStr Handle
h String
s
Handle -> IO ()
hFlush Handle
h
clearmeterstr :: ProgressMeterR -> String
clearmeterstr :: ProgressMeterR -> String
clearmeterstr ProgressMeterR
m = String
"\r" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (ProgressMeterR -> Int
width ProgressMeterR
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"
autoDisplayMeter :: ProgressMeter
-> Int
-> (ProgressMeter -> IO ())
-> IO ThreadId
autoDisplayMeter :: ProgressMeter -> Int -> (ProgressMeter -> IO ()) -> IO ThreadId
autoDisplayMeter ProgressMeter
pm Int
delay ProgressMeter -> IO ()
displayfunc =
do ThreadId
thread <- IO () -> IO ThreadId
forkIO IO ()
workerthread
ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
pm (\ProgressMeterR
p -> ProgressMeterR -> IO ProgressMeterR
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressMeterR -> IO ProgressMeterR)
-> ProgressMeterR -> IO ProgressMeterR
forall a b. (a -> b) -> a -> b
$ ProgressMeterR
p {autoDisplayers = thread : autoDisplayers p})
ThreadId -> IO ThreadId
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
thread
where workerthread :: IO ()
workerthread = do ThreadId
tid <- IO ThreadId
myThreadId
IO ()
yield
ThreadId -> IO ()
loop ThreadId
tid
loop :: ThreadId -> IO ()
loop ThreadId
tid = do ProgressMeter -> IO ()
displayfunc ProgressMeter
pm
Int -> IO ()
threadDelay (Int
delay Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000)
Bool
c <- ThreadId -> IO Bool
doIContinue ThreadId
tid
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c (ThreadId -> IO ()
loop ThreadId
tid)
doIContinue :: ThreadId -> IO Bool
doIContinue ThreadId
tid = ProgressMeter -> (ProgressMeterR -> IO Bool) -> IO Bool
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
pm ((ProgressMeterR -> IO Bool) -> IO Bool)
-> (ProgressMeterR -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \ProgressMeterR
p ->
if ThreadId
tid ThreadId -> [ThreadId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ProgressMeterR -> [ThreadId]
autoDisplayers ProgressMeterR
p
then Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO ()
killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO ()
killAutoDisplayMeter ProgressMeter
pm ThreadId
t =
ProgressMeter -> (ProgressMeterR -> IO ProgressMeterR) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
pm (\ProgressMeterR
p -> ProgressMeterR -> IO ProgressMeterR
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ProgressMeterR -> IO ProgressMeterR)
-> ProgressMeterR -> IO ProgressMeterR
forall a b. (a -> b) -> a -> b
$ ProgressMeterR
p {autoDisplayers = filter (/= t) (autoDisplayers p)})
renderMeter :: ProgressMeter -> IO String
renderMeter :: ProgressMeter -> IO String
renderMeter ProgressMeter
r = ProgressMeter -> (ProgressMeterR -> IO String) -> IO String
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
r ((ProgressMeterR -> IO String) -> IO String)
-> (ProgressMeterR -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ ProgressMeterR -> IO String
renderMeterR
renderMeterR :: ProgressMeterR -> IO String
renderMeterR :: ProgressMeterR -> IO String
renderMeterR ProgressMeterR
meter =
do String
overallpct <- Progress -> IO String
forall {a} {m :: * -> *}.
(ProgressStatuses a (m String), Monad m) =>
a -> m String
renderpct (Progress -> IO String) -> Progress -> IO String
forall a b. (a -> b) -> a -> b
$ ProgressMeterR -> Progress
masterP ProgressMeterR
meter
[String]
compnnts <- (Progress -> IO String) -> [Progress] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Integer] -> [String]) -> Progress -> IO String
rendercomponent (([Integer] -> [String]) -> Progress -> IO String)
-> ([Integer] -> [String]) -> Progress -> IO String
forall a b. (a -> b) -> a -> b
$ ProgressMeterR -> [Integer] -> [String]
renderer ProgressMeterR
meter)
(ProgressMeterR -> [Progress]
components ProgressMeterR
meter)
let componentstr :: String
componentstr = case String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
join String
" " [String]
compnnts of
[] -> String
""
String
x -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
String
rightpart <- ([Integer] -> [String]) -> Progress -> IO String
forall a.
ProgressStatuses a (IO String) =>
([Integer] -> [String]) -> a -> IO String
renderoverall (ProgressMeterR -> [Integer] -> [String]
renderer ProgressMeterR
meter) (ProgressMeterR -> Progress
masterP ProgressMeterR
meter)
let leftpart :: String
leftpart = String
overallpct String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
componentstr
let padwidth :: Int
padwidth = (ProgressMeterR -> Int
width ProgressMeterR
meter) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
leftpart) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rightpart)
if Int
padwidth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1
then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take (ProgressMeterR -> Int
width ProgressMeterR
meter Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
leftpart String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rightpart
else String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
leftpart String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
padwidth Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rightpart
where
u :: String
u = ProgressMeterR -> String
unit ProgressMeterR
meter
renderpct :: a -> m String
renderpct a
pt =
a -> (ProgressStatus -> m String) -> m String
forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus a
pt ProgressStatus -> m String
forall {m :: * -> *}. Monad m => ProgressStatus -> m String
renderpctpts
renderpctpts :: ProgressStatus -> m String
renderpctpts ProgressStatus
pts =
if (ProgressStatus -> Integer
totalUnits ProgressStatus
pts Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0)
then String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return String
"0%"
else String -> m String
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ Integer -> String
forall a. Show a => a -> String
show (((ProgressStatus -> Integer
completedUnits ProgressStatus
pts) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
100) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` (ProgressStatus -> Integer
totalUnits ProgressStatus
pts)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"%"
rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String
rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String
rendercomponent [Integer] -> [String]
rfunc Progress
pt = Progress -> (ProgressStatus -> IO String) -> IO String
forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus Progress
pt ((ProgressStatus -> IO String) -> IO String)
-> (ProgressStatus -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ProgressStatus
pts ->
do String
pct <- ProgressStatus -> IO String
forall {m :: * -> *}. Monad m => ProgressStatus -> m String
renderpctpts ProgressStatus
pts
let renders :: [String]
renders = [Integer] -> [String]
rfunc [ProgressStatus -> Integer
totalUnits ProgressStatus
pts, ProgressStatus -> Integer
completedUnits ProgressStatus
pts]
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ProgressStatus -> String
trackerName ProgressStatus
pts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++
([String]
renders [String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!! Int
1) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++
[String] -> String
forall a. HasCallStack => [a] -> a
head [String]
renders String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pct String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
renderoverall :: (ProgressStatuses a (IO [Char])) => ([Integer] -> [[Char]]) -> a -> IO [Char]
renderoverall :: forall a.
ProgressStatuses a (IO String) =>
([Integer] -> [String]) -> a -> IO String
renderoverall [Integer] -> [String]
rfunc a
pt = a -> (ProgressStatus -> IO String) -> IO String
forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus a
pt ((ProgressStatus -> IO String) -> IO String)
-> (ProgressStatus -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \ProgressStatus
pts ->
do Integer
etr <- ProgressStatus -> IO Integer
forall a.
(ProgressStatuses a (IO Integer),
ProgressStatuses a (IO Rational)) =>
a -> IO Integer
getETR ProgressStatus
pts
Double
speed <- ProgressStatus -> IO Double
forall a b. (ProgressStatuses a (IO b), Fractional b) => a -> IO b
getSpeed ProgressStatus
pts
String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. HasCallStack => [a] -> a
head ([Integer] -> [String]
rfunc [Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
speed :: Double)]) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
u String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"/s " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
renderSecs Integer
etr