-- |
-- Module      : Darcs.Util.Progress
-- Copyright   : 2008 David Roundy
-- License     : GPL
-- Maintainer  : darcs-devel@darcs.net
-- Stability   : experimental
-- Portability : portable
--
-- Utility functions for tracking progress of long-running actions.

module Darcs.Util.Progress
    (
      beginTedious
    , endTedious
    , tediousSize
    , withProgress
    , withSizedProgress
    , debugMessage
    , withoutProgress
    , progress
    , progressKeepLatest
    , finishedOne
    , finishedOneIO
    , progressList
    , minlist
    , setProgressMode
    ) where


import Darcs.Prelude

import Control.Arrow ( second )
import Control.Exception ( bracket )
import Control.Monad ( when, void )
import Control.Concurrent ( forkIO, threadDelay )

import Data.Char ( toLower )
import Data.Map ( Map, empty, adjust, insert, delete, lookup )
import Data.Maybe ( isJust )
import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )

import qualified System.Console.Terminal.Size as TS ( size, width )
import System.IO ( hFlush, stdout )
import System.IO.Unsafe ( unsafePerformIO )

import Darcs.Util.Global ( debugMessage )


data ProgressData = ProgressData
    { ProgressData -> Int
sofar   :: !Int
    , ProgressData -> Maybe String
latest  :: !(Maybe String)
    , ProgressData -> Maybe Int
total   :: !(Maybe Int)
    }

progressRate :: Int
progressRate :: Int
progressRate = Int
1000000

handleProgress :: IO ()
handleProgress :: IO ()
handleProgress = do
    Int -> IO ()
threadDelay Int
progressRate
    String -> Int -> IO ()
handleMoreProgress String
"" Int
0


handleMoreProgress :: String -> Int -> IO ()
handleMoreProgress :: String -> Int -> IO ()
handleMoreProgress String
k Int
n = (Bool -> IO ()) -> IO ()
forall a. (Bool -> IO a) -> IO a
withProgressMode ((Bool -> IO ()) -> IO ()) -> (Bool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
m ->
    if Bool
m then do String
s <- IO String
getProgressLast
                 Maybe ProgressData
mp <- String -> IO (Maybe ProgressData)
getProgressData String
s
                 case Maybe ProgressData
mp of
                   Maybe ProgressData
Nothing -> do
                      Int -> IO ()
threadDelay Int
progressRate
                      String -> Int -> IO ()
handleMoreProgress String
k Int
n
                   Just ProgressData
p -> do
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
k String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
s Bool -> Bool -> Bool
|| Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< ProgressData -> Int
sofar ProgressData
p) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO ()
whenProgressMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ProgressData -> IO ()
printProgress String
s ProgressData
p
                      Int -> IO ()
threadDelay Int
progressRate
                      String -> Int -> IO ()
handleMoreProgress String
s (ProgressData -> Int
sofar ProgressData
p)
         else do Int -> IO ()
threadDelay Int
progressRate
                 String -> Int -> IO ()
handleMoreProgress String
k Int
n


printProgress :: String
              -> ProgressData
              -> IO ()
printProgress :: String -> ProgressData -> IO ()
printProgress String
k (ProgressData {sofar :: ProgressData -> Int
sofar=Int
s, total :: ProgressData -> Maybe Int
total=Just Int
t, latest :: ProgressData -> Maybe String
latest=Just String
l}) =
    String -> IO ()
putCr (String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ... " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" done, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" queued. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l)
printProgress String
k (ProgressData {latest :: ProgressData -> Maybe String
latest=Just String
l}) =
    String -> IO ()
putCr (String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ... " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l)
printProgress String
k (ProgressData {sofar :: ProgressData -> Int
sofar=Int
s, total :: ProgressData -> Maybe Int
total=Just Int
t}) | Int
t Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
s =
    String -> IO ()
putCr (String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ... " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" done, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" queued")
printProgress String
k (ProgressData {sofar :: ProgressData -> Int
sofar=Int
s}) =
    String -> IO ()
putCr (String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ... " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
s)

putCr :: String -> IO ()
putCr :: String -> IO ()
putCr = IO (String -> IO ()) -> String -> IO ()
forall a. IO a -> a
unsafePerformIO IO (String -> IO ())
mkPutCr
{-# NOINLINE putCr #-}

withProgress :: String -> (String -> IO a) -> IO a
withProgress :: forall a. String -> (String -> IO a) -> IO a
withProgress String
k = IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO ()
beginTedious String
k IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
k) String -> IO ()
endTedious

withSizedProgress :: String -> Int -> (String -> IO a) -> IO a
withSizedProgress :: forall a. String -> Int -> (String -> IO a) -> IO a
withSizedProgress String
k Int
n =
  IO String -> (String -> IO ()) -> (String -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (String -> IO ()
beginTedious String
k IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Int -> IO ()
tediousSize String
k Int
n IO () -> IO String -> IO String
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
k) String -> IO ()
endTedious

-- | @beginTedious k@ starts a tedious process and registers it in
-- '_progressData' with the key @k@. A tedious process is one for which we want
-- a progress indicator.
--
-- Wouldn't it be safer if it had type String -> IO ProgressDataKey, so that we
-- can ensure there is no collision? What happens if you call beginTedious twice
-- with the same string, without calling endTedious in the meantime?
beginTedious :: String -> IO ()
beginTedious :: String -> IO ()
beginTedious String
k = do
    String -> IO ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Beginning " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
k
    String -> ProgressData -> IO ()
setProgressData String
k ProgressData
                        { sofar :: Int
sofar = Int
0
                        , latest :: Maybe String
latest = Maybe String
forall a. Maybe a
Nothing
                        , total :: Maybe Int
total = Maybe Int
forall a. Maybe a
Nothing
                        }


-- | @endTedious k@ unregisters the tedious process with key @k@, printing
-- "Done" if such a tedious process exists.
endTedious :: String -> IO ()
endTedious :: String -> IO ()
endTedious String
k = IO () -> IO ()
forall a. IO a -> IO ()
whenProgressMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe ProgressData
p <- String -> IO (Maybe ProgressData)
getProgressData String
k
    IORef (String, Map String ProgressData)
-> ((String, Map String ProgressData)
    -> (String, Map String ProgressData))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (String, Map String ProgressData)
_progressData ((Map String ProgressData -> Map String ProgressData)
-> (String, Map String ProgressData)
-> (String, Map String ProgressData)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Map String ProgressData -> Map String ProgressData)
 -> (String, Map String ProgressData)
 -> (String, Map String ProgressData))
-> (Map String ProgressData -> Map String ProgressData)
-> (String, Map String ProgressData)
-> (String, Map String ProgressData)
forall a b. (a -> b) -> a -> b
$ String -> Map String ProgressData -> Map String ProgressData
forall k a. Ord k => k -> Map k a -> Map k a
delete String
k)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ProgressData -> Bool
forall a. Maybe a -> Bool
isJust Maybe ProgressData
p) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putCr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ... done"


tediousSize :: String
            -> Int
            -> IO ()
tediousSize :: String -> Int -> IO ()
tediousSize String
k Int
s = String -> (ProgressData -> ProgressData) -> IO ()
updateProgressData String
k ProgressData -> ProgressData
uptot
  where
    uptot :: ProgressData -> ProgressData
uptot ProgressData
p = case ProgressData -> Maybe Int
total ProgressData
p of
                  Just Int
t -> Int -> ProgressData -> ProgressData
forall a b. a -> b -> b
seq Int
ts (ProgressData -> ProgressData) -> ProgressData -> ProgressData
forall a b. (a -> b) -> a -> b
$ ProgressData
p { total = Just ts }
                    where ts :: Int
ts = Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s
                  Maybe Int
Nothing -> ProgressData
p { total = Just s }


-- | XXX: document this constant
minlist :: Int
minlist :: Int
minlist = Int
4


progressList :: String
             -> [a]
             -> [a]
progressList :: forall a. String -> [a] -> [a]
progressList String
_ [] = []
progressList String
k (a
x:[a]
xs) = if Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
minlist
                          then a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs
                          else a -> a
forall {a}. a -> a
startit a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
forall {a}. [a] -> [a]
pl [a]
xs
  where
    l :: Int
l = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

    startit :: a -> a
startit a
y = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
beginTedious String
k
        String -> Int -> IO ()
tediousSize String
k Int
l
        a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
y

    pl :: [a] -> [a]
pl [] = []
    pl [a
y] = IO [a] -> [a]
forall a. IO a -> a
unsafePerformIO (IO [a] -> [a]) -> IO [a] -> [a]
forall a b. (a -> b) -> a -> b
$ do
        String -> IO ()
endTedious String
k
        [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [a
y]
    pl (a
y:[a]
ys) = String -> a -> a
forall a. String -> a -> a
progress String
k a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
pl [a]
ys


progress :: String
         -> a
         -> a
progress :: forall a. String -> a -> a
progress String
k a
a = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ String -> IO ()
progressIO String
k IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


progressIO :: String -> IO ()
progressIO :: String -> IO ()
progressIO String
"" = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
progressIO String
k = do
    String -> (ProgressData -> ProgressData) -> IO ()
updateProgressData String
k ((ProgressData -> ProgressData) -> IO ())
-> (ProgressData -> ProgressData) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ProgressData
p ->
        ProgressData
p { sofar = sofar p + 1, latest = Nothing }

progressKeepLatest :: String
                   -> a
                   -> a
progressKeepLatest :: forall a. String -> a -> a
progressKeepLatest String
k a
a = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ String -> IO ()
progressKeepLatestIO String
k IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


progressKeepLatestIO :: String -> IO ()
progressKeepLatestIO :: String -> IO ()
progressKeepLatestIO String
"" = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
progressKeepLatestIO String
k = do
    String -> (ProgressData -> ProgressData) -> IO ()
updateProgressData String
k (\ProgressData
p -> ProgressData
p {sofar = sofar p + 1})

finishedOne :: String -> String -> a -> a
finishedOne :: forall a. String -> String -> a -> a
finishedOne String
k String
l a
a = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
finishedOneIO String
k String
l IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


finishedOneIO :: String -> String -> IO ()
finishedOneIO :: String -> String -> IO ()
finishedOneIO String
"" String
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
finishedOneIO String
k String
l = do
    String -> (ProgressData -> ProgressData) -> IO ()
updateProgressData String
k (\ProgressData
p -> ProgressData
p { sofar = sofar p + 1,
                                    latest = Just l })


_progressMode :: IORef Bool
_progressMode :: IORef Bool
_progressMode = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
True
{-# NOINLINE _progressMode #-}

_progressData :: IORef (String, Map String ProgressData)
_progressData :: IORef (String, Map String ProgressData)
_progressData = IO (IORef (String, Map String ProgressData))
-> IORef (String, Map String ProgressData)
forall a. IO a -> a
unsafePerformIO (IO (IORef (String, Map String ProgressData))
 -> IORef (String, Map String ProgressData))
-> IO (IORef (String, Map String ProgressData))
-> IORef (String, Map String ProgressData)
forall a b. (a -> b) -> a -> b
$ do
    ThreadId
_ <- IO () -> IO ThreadId
forkIO IO ()
handleProgress
    (String, Map String ProgressData)
-> IO (IORef (String, Map String ProgressData))
forall a. a -> IO (IORef a)
newIORef (String
"", Map String ProgressData
forall k a. Map k a
empty)
{-# NOINLINE _progressData #-}

mkPutCr :: IO (String -> IO ())
mkPutCr :: IO (String -> IO ())
mkPutCr =
  IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
TS.size IO (Maybe (Window Int))
-> (Maybe (Window Int) -> IO (String -> IO ()))
-> IO (String -> IO ())
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe (Window Int)
Nothing ->
      -- stdout is not a terminal
      (String -> IO ()) -> IO (String -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> IO ()) -> IO (String -> IO ()))
-> (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ \String
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Window Int
window -> do
      let limitToWidth :: [a] -> [a]
limitToWidth = Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Window Int -> Int
forall a. Window a -> a
TS.width Window Int
window Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      (String -> IO ()) -> IO (String -> IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> IO ()) -> IO (String -> IO ()))
-> (String -> IO ()) -> IO (String -> IO ())
forall a b. (a -> b) -> a -> b
$ \String
s -> do
        String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
'\r'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
forall {a}. [a] -> [a]
limitToWidth String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"
        Handle -> IO ()
hFlush Handle
stdout
        String -> IO ()
putStr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
'\r'Char -> String -> String
forall a. a -> [a] -> [a]
:String -> String
forall {a}. [a] -> [a]
limitToWidth ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s)) Char
' ') String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"

setProgressMode :: Bool -> IO ()
setProgressMode :: Bool -> IO ()
setProgressMode = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
_progressMode

withoutProgress :: IO a -> IO a
withoutProgress :: forall a. IO a -> IO a
withoutProgress IO a
job = IO Bool -> (Bool -> IO ()) -> (Bool -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Bool
off Bool -> IO ()
restore (IO a -> Bool -> IO a
forall a b. a -> b -> a
const IO a
job) where
  off :: IO Bool
off = (Bool -> IO Bool) -> IO Bool
forall a. (Bool -> IO a) -> IO a
withProgressMode ((Bool -> IO Bool) -> IO Bool) -> (Bool -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Bool
m -> do
    String -> IO ()
debugMessage String
"Disabling progress reports..."
    Bool -> IO ()
setProgressMode Bool
False
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
m
  restore :: Bool -> IO ()
restore Bool
m = do
    if Bool
m then String -> IO ()
debugMessage String
"Reenabling progress reports."
    else String -> IO ()
debugMessage String
"Leaving progress reports off."
    Bool -> IO ()
setProgressMode Bool
m

updateProgressData :: String
                   -> (ProgressData -> ProgressData)
                   -> IO ()
updateProgressData :: String -> (ProgressData -> ProgressData) -> IO ()
updateProgressData String
k ProgressData -> ProgressData
f =
    IO () -> IO ()
forall a. IO a -> IO ()
whenProgressMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (String, Map String ProgressData)
-> ((String, Map String ProgressData)
    -> (String, Map String ProgressData))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (String, Map String ProgressData)
_progressData (\(String
_,Map String ProgressData
m) -> (String
k,(ProgressData -> ProgressData)
-> String -> Map String ProgressData -> Map String ProgressData
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
adjust ProgressData -> ProgressData
f String
k Map String ProgressData
m))

setProgressData :: String
                -> ProgressData
                -> IO ()
setProgressData :: String -> ProgressData -> IO ()
setProgressData String
k ProgressData
p =
    IO () -> IO ()
forall a. IO a -> IO ()
whenProgressMode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef (String, Map String ProgressData)
-> ((String, Map String ProgressData)
    -> (String, Map String ProgressData))
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (String, Map String ProgressData)
_progressData ((Map String ProgressData -> Map String ProgressData)
-> (String, Map String ProgressData)
-> (String, Map String ProgressData)
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ((Map String ProgressData -> Map String ProgressData)
 -> (String, Map String ProgressData)
 -> (String, Map String ProgressData))
-> (Map String ProgressData -> Map String ProgressData)
-> (String, Map String ProgressData)
-> (String, Map String ProgressData)
forall a b. (a -> b) -> a -> b
$ String
-> ProgressData
-> Map String ProgressData
-> Map String ProgressData
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert String
k ProgressData
p)

getProgressData :: String -> IO (Maybe ProgressData)
getProgressData :: String -> IO (Maybe ProgressData)
getProgressData String
k = (Bool -> IO (Maybe ProgressData)) -> IO (Maybe ProgressData)
forall a. (Bool -> IO a) -> IO a
withProgressMode ((Bool -> IO (Maybe ProgressData)) -> IO (Maybe ProgressData))
-> (Bool -> IO (Maybe ProgressData)) -> IO (Maybe ProgressData)
forall a b. (a -> b) -> a -> b
$ \Bool
p ->
    if Bool
p
      then (String -> Map String ProgressData -> Maybe ProgressData
forall k a. Ord k => k -> Map k a -> Maybe a
lookup String
k (Map String ProgressData -> Maybe ProgressData)
-> ((String, Map String ProgressData) -> Map String ProgressData)
-> (String, Map String ProgressData)
-> Maybe ProgressData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Map String ProgressData) -> Map String ProgressData
forall a b. (a, b) -> b
snd) ((String, Map String ProgressData) -> Maybe ProgressData)
-> IO (String, Map String ProgressData) -> IO (Maybe ProgressData)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IORef (String, Map String ProgressData)
-> IO (String, Map String ProgressData)
forall a. IORef a -> IO a
readIORef IORef (String, Map String ProgressData)
_progressData
      else Maybe ProgressData -> IO (Maybe ProgressData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ProgressData
forall a. Maybe a
Nothing

getProgressLast :: IO String
getProgressLast :: IO String
getProgressLast = (Bool -> IO String) -> IO String
forall a. (Bool -> IO a) -> IO a
withProgressMode ((Bool -> IO String) -> IO String)
-> (Bool -> IO String) -> IO String
forall a b. (a -> b) -> a -> b
$ \Bool
p ->
    if Bool
p
      then (String, Map String ProgressData) -> String
forall a b. (a, b) -> a
fst ((String, Map String ProgressData) -> String)
-> IO (String, Map String ProgressData) -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IORef (String, Map String ProgressData)
-> IO (String, Map String ProgressData)
forall a. IORef a -> IO a
readIORef IORef (String, Map String ProgressData)
_progressData
      else String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""

whenProgressMode :: IO a -> IO ()
whenProgressMode :: forall a. IO a -> IO ()
whenProgressMode IO a
j = (Bool -> IO ()) -> IO ()
forall a. (Bool -> IO a) -> IO a
withProgressMode ((Bool -> IO ()) -> IO ()) -> (Bool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> Bool -> IO ()
forall a b. a -> b -> a
const (IO () -> Bool -> IO ()) -> IO () -> Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ IO a -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO a
j

withProgressMode :: (Bool -> IO a) -> IO a
withProgressMode :: forall a. (Bool -> IO a) -> IO a
withProgressMode Bool -> IO a
job = (IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
_progressMode) IO Bool -> (Bool -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO a
job