{-# LANGUAGE Safe #-}

{-
Copyright (c) 2006-2011 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file LICENSE
-}

{- |
   Module     : Data.Progress.Meter
   Copyright  : Copyright (C) 2006-2011 John Goerzen
   SPDX-License-Identifier: BSD-3-Clause

   Stability  : stable
   Portability: portable

Tool for maintaining a status bar, supporting multiple simultaneous tasks,
as a layer atop "Data.Progress.Tracker".

Written by John Goerzen, jgoerzen\@complete.org -}

module Data.Progress.Meter (-- * Types
                               ProgressMeter,
                               -- * Creation and Configuration
                               simpleNewMeter,
                               newMeter,
                               setComponents,
                               addComponent,
                               removeComponent,
                               setWidth,

                               -- * Rendering and Output
                               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)

{- | The main data type for the progress meter. -}
data ProgressMeterR =
    ProgressMeterR {ProgressMeterR -> Progress
masterP :: Progress, -- ^ The master 'Progress' object for overall status
                    ProgressMeterR -> [Progress]
components :: [Progress], -- ^ Individual component statuses
                    ProgressMeterR -> Int
width :: Int, -- ^ Width of the meter
                    ProgressMeterR -> String
unit :: String, -- ^ Units of display
                    ProgressMeterR -> [Integer] -> [String]
renderer :: [Integer] -> [String], -- ^ Function to render numbers
                    ProgressMeterR -> [ThreadId]
autoDisplayers :: [ThreadId] -- ^ Auto-updating display
                   }

type ProgressMeter = MVar ProgressMeterR

{- | Set up a new status bar using defaults:

* The given tracker

* Width 80

* Data.Quantity.renderNums binaryOpts 1

* Unit inticator @"B"@

-}
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 (forall a. (Ord a, Real a) => SizeOpts -> Int -> [a] -> [String]
renderNums SizeOpts
binaryOpts Int
1)

{- | Set up a new status bar. -}
newMeter :: Progress           -- ^ The top-level 'Progress'
         -> String              -- ^ Unit indicator string
          -> Int                -- ^ Width of the terminal -- usually 80
          -> ([Integer] -> [String])-- ^ A function to render sizes
          -> IO ProgressMeter
newMeter :: Progress
-> String -> Int -> ([Integer] -> [String]) -> IO ProgressMeter
newMeter Progress
tracker String
u Int
w [Integer] -> [String]
rfunc =
    forall a. a -> IO (MVar a)
newMVar 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}

{- | Adjust the list of components of this 'ProgressMeter'. -}
setComponents :: ProgressMeter -> [Progress] -> IO ()
setComponents :: ProgressMeter -> [Progress] -> IO ()
setComponents ProgressMeter
meter [Progress]
componentlist = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter (\ProgressMeterR
m -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {components :: [Progress]
components = [Progress]
componentlist})

{- | Add a new component to the list of components. -}
addComponent :: ProgressMeter -> Progress -> IO ()
addComponent :: ProgressMeter -> Progress -> IO ()
addComponent ProgressMeter
meter Progress
component =
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter (\ProgressMeterR
m -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {components :: [Progress]
components = Progress
component forall a. a -> [a] -> [a]
: ProgressMeterR -> [Progress]
components ProgressMeterR
m})

{- | Remove a component by name. -}
removeComponent :: ProgressMeter -> String -> IO ()
removeComponent :: ProgressMeter -> String -> IO ()
removeComponent ProgressMeter
meter String
componentname = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter forall a b. (a -> b) -> a -> b
$ \ProgressMeterR
m ->
   do [Progress]
newc <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (\Progress
x -> forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus Progress
x (\ProgressStatus
y -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressStatus -> String
trackerName ProgressStatus
y forall a. Eq a => a -> a -> Bool
/= String
componentname))
              (ProgressMeterR -> [Progress]
components ProgressMeterR
m)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {components :: [Progress]
components = [Progress]
newc}

{- | Adjusts the width of this 'ProgressMeter'. -}
setWidth :: ProgressMeter -> Int -> IO ()
setWidth :: ProgressMeter -> Int -> IO ()
setWidth ProgressMeter
meter Int
w = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
meter (\ProgressMeterR
m -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressMeterR
m {width :: Int
width = Int
w})

{- | Like renderMeter, but prints it to the screen instead of returning it.

This function will output CR, then the meter.

Pass stdout as the handle for regular display to the screen. -}
displayMeter :: Handle -> ProgressMeter -> IO ()
displayMeter :: Handle -> ProgressMeter -> IO ()
displayMeter Handle
h ProgressMeter
r = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
r 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" forall a. [a] -> [a] -> [a]
++ String
s)
       Handle -> IO ()
hFlush Handle
h
       -- By placing this whole thing under withMVar, we can effectively
       -- lock the IO and prevent IO from stomping on each other.

{- | Clears the meter -- outputs CR, spaces equal to the width - 1,
then another CR.

Pass stdout as the handle for regular display to the screen. -}
clearMeter :: Handle -> ProgressMeter -> IO ()
clearMeter :: Handle -> ProgressMeter -> IO ()
clearMeter Handle
h ProgressMeter
pm = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
pm 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

{- | Clears the meter, writes the given string, then restores the meter.
The string is assumed to contain a trailing newline.

Pass stdout as the handle for regular display to the screen. -}
writeMeterString :: Handle -> ProgressMeter -> String -> IO ()
writeMeterString :: Handle -> ProgressMeter -> String -> IO ()
writeMeterString Handle
h ProgressMeter
pm String
msg = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
pm 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" forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (ProgressMeterR -> Int
width ProgressMeterR
m forall a. Num a => a -> a -> a
- Int
1) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"\r"

{- | Starts a thread that updates the meter every n seconds by calling
the specified function.  Note: @displayMeter stdout@
is an ideal function here.

Save this threadID and use it later to call 'stopAutoDisplayMeter'.
-}
autoDisplayMeter :: ProgressMeter -- ^ The meter to display
                 -> Int         -- ^ Update interval in seconds
                 -> (ProgressMeter -> IO ()) -- ^ Function to display it
                 -> IO ThreadId -- ^ Resulting thread id
autoDisplayMeter :: ProgressMeter -> Int -> (ProgressMeter -> IO ()) -> IO ThreadId
autoDisplayMeter ProgressMeter
pm Int
delay ProgressMeter -> IO ()
displayfunc =
    do ThreadId
thread <- IO () -> IO ThreadId
forkIO IO ()
workerthread
       forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
pm (\ProgressMeterR
p -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressMeterR
p {autoDisplayers :: [ThreadId]
autoDisplayers = ThreadId
thread forall a. a -> [a] -> [a]
: ProgressMeterR -> [ThreadId]
autoDisplayers ProgressMeterR
p})
       forall (m :: * -> *) a. Monad m => a -> m a
return ThreadId
thread
    where workerthread :: IO ()
workerthread = do ThreadId
tid <- IO ThreadId
myThreadId
                            -- Help fix a race condition so that the above
                            -- modifyMVar can run before a check ever does
                            IO ()
yield
                            ThreadId -> IO ()
loop ThreadId
tid
          loop :: ThreadId -> IO ()
loop ThreadId
tid = do ProgressMeter -> IO ()
displayfunc ProgressMeter
pm
                        Int -> IO ()
threadDelay (Int
delay forall a. Num a => a -> a -> a
* Int
1000000)
                        Bool
c <- ThreadId -> IO Bool
doIContinue ThreadId
tid
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
c (ThreadId -> IO ()
loop ThreadId
tid)
          doIContinue :: ThreadId -> IO Bool
doIContinue ThreadId
tid = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
pm forall a b. (a -> b) -> a -> b
$ \ProgressMeterR
p ->
                               if ThreadId
tid forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ProgressMeterR -> [ThreadId]
autoDisplayers ProgressMeterR
p
                                  then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                                  else forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

{- | Stops the specified meter from displaying.

You should probably call 'clearMeter' after a call to this. -}
killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO ()
killAutoDisplayMeter :: ProgressMeter -> ThreadId -> IO ()
killAutoDisplayMeter ProgressMeter
pm ThreadId
t =
    forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ ProgressMeter
pm (\ProgressMeterR
p -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProgressMeterR
p {autoDisplayers :: [ThreadId]
autoDisplayers = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= ThreadId
t) (ProgressMeterR -> [ThreadId]
autoDisplayers ProgressMeterR
p)})

{- | Render the current status. -}
renderMeter :: ProgressMeter -> IO String
renderMeter :: ProgressMeter -> IO String
renderMeter ProgressMeter
r = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar ProgressMeter
r 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 <- forall {a} {m :: * -> *}.
(ProgressStatuses a (m String), Monad m) =>
a -> m String
renderpct forall a b. (a -> b) -> a -> b
$ ProgressMeterR -> Progress
masterP ProgressMeterR
meter
       [String]
compnnts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([Integer] -> [String]) -> Progress -> IO String
rendercomponent forall a b. (a -> b) -> a -> b
$ ProgressMeterR -> [Integer] -> [String]
renderer ProgressMeterR
meter)
                     (ProgressMeterR -> [Progress]
components ProgressMeterR
meter)
       let componentstr :: String
componentstr = case forall a. [a] -> [[a]] -> [a]
join String
" " [String]
compnnts of
                            [] -> String
""
                            String
x -> String
x forall a. [a] -> [a] -> [a]
++ String
" "
       String
rightpart <- 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 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
componentstr
       let padwidth :: Int
padwidth = (ProgressMeterR -> Int
width ProgressMeterR
meter) forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
leftpart) forall a. Num a => a -> a -> a
- (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
rightpart)
       if Int
padwidth forall a. Ord a => a -> a -> Bool
< Int
1
          then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (ProgressMeterR -> Int
width ProgressMeterR
meter forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ String
leftpart forall a. [a] -> [a] -> [a]
++ String
rightpart
          else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
leftpart forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate Int
padwidth Char
' ' forall a. [a] -> [a] -> [a]
++ String
rightpart

    where
      u :: String
u = ProgressMeterR -> String
unit ProgressMeterR
meter
      renderpct :: a -> m String
renderpct a
pt =
              forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus a
pt forall {m :: * -> *}. Monad m => ProgressStatus -> m String
renderpctpts
      renderpctpts :: ProgressStatus -> m String
renderpctpts ProgressStatus
pts =
                  if (ProgressStatus -> Integer
totalUnits ProgressStatus
pts forall a. Eq a => a -> a -> Bool
== Integer
0)
                     then forall (m :: * -> *) a. Monad m => a -> m a
return String
"0%"
                     else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (((ProgressStatus -> Integer
completedUnits ProgressStatus
pts) forall a. Num a => a -> a -> a
* Integer
100) forall a. Integral a => a -> a -> a
`div` (ProgressStatus -> Integer
totalUnits ProgressStatus
pts)) forall a. [a] -> [a] -> [a]
++ String
"%"
      rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String
      rendercomponent :: ([Integer] -> [String]) -> Progress -> IO String
rendercomponent [Integer] -> [String]
rfunc Progress
pt = forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus Progress
pt forall a b. (a -> b) -> a -> b
$ \ProgressStatus
pts ->
              do String
pct <- 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]
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String
"[" forall a. [a] -> [a] -> [a]
++ ProgressStatus -> String
trackerName ProgressStatus
pts forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
                     ([String]
renders forall a. [a] -> Int -> a
!! Int
1) forall a. [a] -> [a] -> [a]
++ String
u forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++
                     forall a. [a] -> a
head [String]
renders forall a. [a] -> [a] -> [a]
++ String
u forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
pct 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 = forall a b. ProgressStatuses a b => a -> (ProgressStatus -> b) -> b
withStatus a
pt forall a b. (a -> b) -> a -> b
$ \ProgressStatus
pts ->
                                         do Integer
etr <- forall a.
(ProgressStatuses a (IO Integer),
 ProgressStatuses a (IO Rational)) =>
a -> IO Integer
getETR ProgressStatus
pts
                                            Double
speed <- forall a b. (ProgressStatuses a (IO b), Fractional b) => a -> IO b
getSpeed ProgressStatus
pts
                                            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head ([Integer] -> [String]
rfunc [forall a b. (RealFrac a, Integral b) => a -> b
floor (Double
speed :: Double)]) forall a. [a] -> [a] -> [a]
++ String
u forall a. [a] -> [a] -> [a]
++
                                                       String
"/s " forall a. [a] -> [a] -> [a]
++ Integer -> String
renderSecs Integer
etr