-- |
-- 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
    , 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, unless, 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 System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,
                   hSetBuffering, hIsTerminalDevice,
                   Handle, BufferMode(LineBuffering) )
import System.IO.Unsafe ( unsafePerformIO )

import Darcs.Util.Global ( withDebugMode, debugMessage, putTiming )


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 -> String -> IO ()
myput String
output String
output
  where
    output :: String
output = 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 -> String -> IO ()
myput (String
k String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l) String
k
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 -> String -> IO ()
myput (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
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)
printProgress String
k (ProgressData {sofar :: ProgressData -> Int
sofar=Int
s}) =
    String -> String -> IO ()
myput (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
k


myput :: String -> String -> IO ()
myput :: String -> String -> IO ()
myput String
l String
s = (Bool -> IO ()) -> IO ()
forall a. (Bool -> IO a) -> IO a
withDebugMode ((Bool -> IO ()) -> IO ()) -> (Bool -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
debugMode ->
    if Bool
debugMode
      then IO ()
putTiming IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
l
      else
        if Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
l
          then String -> String -> IO ()
myput ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
l) String
s
          else IO ()
putTiming IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> if String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
80
                              then String -> IO ()
simpleput String
l
                              else String -> IO ()
simpleput (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
80 String
s)


simpleput :: String -> IO ()
simpleput :: String -> IO ()
simpleput = IO (String -> IO ()) -> String -> IO ()
forall a. IO a -> a
unsafePerformIO (IO (String -> IO ()) -> String -> IO ())
-> IO (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO (String -> IO ())
mkhPutCr Handle
stderr
{-# NOINLINE simpleput #-}


-- | @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 :: Int -> Maybe String -> Maybe Int -> ProgressData
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 (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 ()
debugMessage (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Done " 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


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
seq Int
ts (ProgressData -> ProgressData) -> ProgressData -> ProgressData
forall a b. (a -> b) -> a -> b
$ ProgressData
p { total :: Maybe Int
total = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
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 :: Maybe Int
total = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
s }


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


progressList :: String
             -> [a]
             -> [a]
progressList :: 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 (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 (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 (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 :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


progressIO :: String -> IO ()
progressIO :: String -> IO ()
progressIO String
"" = () -> IO ()
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 :: Int
sofar = ProgressData -> Int
sofar ProgressData
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, latest :: Maybe String
latest = Maybe String
forall a. Maybe a
Nothing }
    String -> String -> IO ()
putDebug String
k String
""


progressKeepLatest :: String
                   -> a
                   -> a
progressKeepLatest :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a


progressKeepLatestIO :: String -> IO ()
progressKeepLatestIO :: String -> IO ()
progressKeepLatestIO String
"" = () -> IO ()
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 :: Int
sofar = ProgressData -> Int
sofar ProgressData
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1})
    String -> String -> IO ()
putDebug String
k String
""


finishedOne :: String -> String -> a -> a
finishedOne :: 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 (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 :: Int
sofar = ProgressData -> Int
sofar ProgressData
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
                                    latest :: Maybe String
latest = String -> Maybe String
forall a. a -> Maybe a
Just String
l })
    String -> String -> IO ()
putDebug String
k String
l


putDebug :: String
         -> String
         -> IO ()
putDebug :: String -> String -> IO ()
putDebug String
_ String
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
--putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k
--putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++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
$ do
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
    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 #-}

mkhPutCr :: Handle
         -> IO (String -> IO ())
mkhPutCr :: Handle -> IO (String -> IO ())
mkhPutCr Handle
fe = do
    Bool
isTerm <- Handle -> IO Bool
hIsTerminalDevice Handle
fe
    Bool
stdoutIsTerm <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
    (String -> IO ()) -> IO (String -> IO ())
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
$
        if Bool
isTerm
          then \String
s -> do
              Handle -> String -> IO ()
hPutStr Handle
fe (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Char
'\r'Char -> String -> String
forall a. a -> [a] -> [a]
:String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"
              Handle -> IO ()
hFlush Handle
fe
              let spaces :: String
spaces = Char
'\r'Char -> String -> String
forall a. a -> [a] -> [a]
:Int -> Char -> String
forall a. Int -> a -> [a]
replicate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r"
              Handle -> String -> IO ()
hPutStr Handle
fe String
spaces
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stdoutIsTerm (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
spaces
          else \String
s -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Handle -> String -> IO ()
hPutStrLn Handle
fe String
s
                                          Handle -> IO ()
hFlush Handle
fe

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 :: 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 (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 (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 (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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return String
""

whenProgressMode :: IO a -> IO ()
whenProgressMode :: 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 :: (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO a
job