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 = forall a. (Bool -> IO a) -> IO a
withProgressMode 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
k forall a. Eq a => a -> a -> Bool
/= String
s Bool -> Bool -> Bool
|| Int
n forall a. Ord a => a -> a -> Bool
< ProgressData -> Int
sofar ProgressData
p) forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO ()
whenProgressMode 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 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
s forall a. [a] -> [a] -> [a]
++ String
" done, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
t forall a. Num a => a -> a -> a
- Int
s) forall a. [a] -> [a] -> [a]
++ String
" queued. " 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 forall a. [a] -> [a] -> [a]
++ 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 forall a. Ord a => a -> a -> Bool
>= Int
s =
String -> String -> IO ()
myput (String
k forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
s forall a. [a] -> [a] -> [a]
++ String
" done, " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int
t forall a. Num a => a -> a -> a
- Int
s) forall a. [a] -> [a] -> [a]
++ String
" queued")
(String
k forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ 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 forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
s) String
k
myput :: String -> String -> IO ()
myput :: String -> String -> IO ()
myput String
l String
s = forall a. (Bool -> IO a) -> IO a
withDebugMode forall a b. (a -> b) -> a -> b
$ \Bool
debugMode ->
if Bool
debugMode
then IO ()
putTiming forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> String -> IO ()
hPutStrLn Handle
stderr String
l
else
if Char
'\n' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
l
then String -> String -> IO ()
myput (forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
l) String
s
else IO ()
putTiming forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> if forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l forall a. Ord a => a -> a -> Bool
< Int
80
then String -> IO ()
simpleput String
l
else String -> IO ()
simpleput (forall a. Int -> [a] -> [a]
take Int
80 String
s)
simpleput :: String -> IO ()
simpleput :: String -> IO ()
simpleput = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ Handle -> IO (String -> IO ())
mkhPutCr Handle
stderr
{-# NOINLINE simpleput #-}
beginTedious :: String -> IO ()
beginTedious :: String -> IO ()
beginTedious String
k = do
String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Beginning " forall a. [a] -> [a] -> [a]
++ 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 = forall a. Maybe a
Nothing
, total :: Maybe Int
total = forall a. Maybe a
Nothing
}
endTedious :: String -> IO ()
endTedious :: String -> IO ()
endTedious String
k = forall a. IO a -> IO ()
whenProgressMode forall a b. (a -> b) -> a -> b
$ do
Maybe ProgressData
p <- String -> IO (Maybe ProgressData)
getProgressData String
k
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (String, Map String ProgressData)
_progressData (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
delete String
k)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe ProgressData
p) forall a b. (a -> b) -> a -> b
$ String -> IO ()
debugMessage forall a b. (a -> b) -> a -> b
$ String
"Done " forall a. [a] -> [a] -> [a]
++ 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 -> seq :: forall a b. a -> b -> b
seq Int
ts forall a b. (a -> b) -> a -> b
$ ProgressData
p { total :: Maybe Int
total = forall a. a -> Maybe a
Just Int
ts }
where ts :: Int
ts = Int
t forall a. Num a => a -> a -> a
+ Int
s
Maybe Int
Nothing -> ProgressData
p { total :: Maybe Int
total = forall a. a -> Maybe a
Just Int
s }
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 forall a. Ord a => a -> a -> Bool
< Int
minlist
then a
xforall a. a -> [a] -> [a]
:[a]
xs
else forall {a}. a -> a
startit a
x forall a. a -> [a] -> [a]
: forall {a}. [a] -> [a]
pl [a]
xs
where
l :: Int
l = forall (t :: * -> *) a. Foldable t => t a -> Int
length (a
xforall a. a -> [a] -> [a]
:[a]
xs)
startit :: a -> a
startit a
y = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
beginTedious String
k
String -> Int -> IO ()
tediousSize String
k Int
l
forall (m :: * -> *) a. Monad m => a -> m a
return a
y
pl :: [a] -> [a]
pl [] = []
pl [a
y] = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
endTedious String
k
forall (m :: * -> *) a. Monad m => a -> m a
return [a
y]
pl (a
y:[a]
ys) = forall a. String -> a -> a
progress String
k a
y 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
progressIO String
k forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
progressIO :: String -> IO ()
progressIO :: String -> IO ()
progressIO String
"" = forall (m :: * -> *) a. Monad m => a -> m a
return ()
progressIO String
k = do
String -> (ProgressData -> ProgressData) -> IO ()
updateProgressData String
k forall a b. (a -> b) -> a -> b
$ \ProgressData
p ->
ProgressData
p { sofar :: Int
sofar = ProgressData -> Int
sofar ProgressData
p forall a. Num a => a -> a -> a
+ Int
1, latest :: Maybe String
latest = forall a. Maybe a
Nothing }
String -> String -> IO ()
putDebug String
k String
""
progressKeepLatest :: String
-> a
-> a
progressKeepLatest :: forall a. String -> a -> a
progressKeepLatest String
k a
a = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
progressKeepLatestIO String
k forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
progressKeepLatestIO :: String -> IO ()
progressKeepLatestIO :: String -> IO ()
progressKeepLatestIO String
"" = 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 forall a. Num a => a -> a -> a
+ Int
1})
String -> String -> IO ()
putDebug String
k String
""
finishedOne :: String -> String -> a -> a
finishedOne :: forall a. String -> String -> a -> a
finishedOne String
k String
l a
a = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
finishedOneIO String
k String
l forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
finishedOneIO :: String -> String -> IO ()
finishedOneIO :: String -> String -> IO ()
finishedOneIO String
"" String
_ = 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 forall a. Num a => a -> a -> a
+ Int
1,
latest :: Maybe String
latest = 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
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
_progressMode :: IORef Bool
_progressMode :: IORef Bool
_progressMode = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
forall a. a -> IO (IORef a)
newIORef Bool
True
{-# NOINLINE _progressMode #-}
_progressData :: IORef (String, Map String ProgressData)
_progressData :: IORef (String, Map String ProgressData)
_progressData = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
ThreadId
_ <- IO () -> IO ThreadId
forkIO IO ()
handleProgress
forall a. a -> IO (IORef a)
newIORef (String
"", 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
if Bool
isTerm
then \String
s -> do
Handle -> String -> IO ()
hPutStr Handle
fe forall a b. (a -> b) -> a -> b
$ Char
'\r'forall a. a -> [a] -> [a]
:String
s forall a. [a] -> [a] -> [a]
++ String
"\r"
Handle -> IO ()
hFlush Handle
fe
let spaces :: String
spaces = Char
'\r'forall a. a -> [a] -> [a]
:forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Char
' ' forall a. [a] -> [a] -> [a]
++ String
"\r"
Handle -> String -> IO ()
hPutStr Handle
fe String
spaces
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
stdoutIsTerm forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
spaces
else \String
s -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
s) 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 = 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 = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO Bool
off Bool -> IO ()
restore (forall a b. a -> b -> a
const IO a
job) where
off :: IO Bool
off = forall a. (Bool -> IO a) -> IO a
withProgressMode forall a b. (a -> b) -> a -> b
$ \Bool
m -> do
String -> IO ()
debugMessage String
"Disabling progress reports..."
Bool -> IO ()
setProgressMode Bool
False
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 =
forall a. IO a -> IO ()
whenProgressMode forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (String, Map String ProgressData)
_progressData (\(String
_,Map String ProgressData
m) -> (String
k,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 =
forall a. IO a -> IO ()
whenProgressMode forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (String, Map String ProgressData)
_progressData (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a b. (a -> b) -> a -> b
$ 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 = forall a. (Bool -> IO a) -> IO a
withProgressMode forall a b. (a -> b) -> a -> b
$ \Bool
p ->
if Bool
p
then (forall k a. Ord k => k -> Map k a -> Maybe a
lookup String
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. IORef a -> IO a
readIORef IORef (String, Map String ProgressData)
_progressData
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
getProgressLast :: IO String
getProgressLast :: IO String
getProgressLast = forall a. (Bool -> IO a) -> IO a
withProgressMode forall a b. (a -> b) -> a -> b
$ \Bool
p ->
if Bool
p
then forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. IORef a -> IO a
readIORef IORef (String, Map String ProgressData)
_progressData
else forall (m :: * -> *) a. Monad m => a -> m a
return String
""
whenProgressMode :: IO a -> IO ()
whenProgressMode :: forall a. IO a -> IO ()
whenProgressMode IO a
j = forall a. (Bool -> IO a) -> IO a
withProgressMode forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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 = (forall a. IORef a -> IO a
readIORef IORef Bool
_progressMode) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> IO a
job