1-- |
2-- Module      : Darcs.Util.Progress
3-- Copyright   : 2008 David Roundy
4-- License     : GPL
5-- Maintainer  : darcs-devel@darcs.net
6-- Stability   : experimental
7-- Portability : portable
8--
9-- Utility functions for tracking progress of long-running actions.
10
11module Darcs.Util.Progress
12    (
13      beginTedious
14    , endTedious
15    , tediousSize
16    , debugMessage
17    , withoutProgress
18    , progress
19    , progressKeepLatest
20    , finishedOne
21    , finishedOneIO
22    , progressList
23    , minlist
24    , setProgressMode
25    ) where
26
27
28import Darcs.Prelude
29
30import Control.Arrow ( second )
31import Control.Exception ( bracket )
32import Control.Monad ( when, unless, void )
33import Control.Concurrent ( forkIO, threadDelay )
34
35import Data.Char ( toLower )
36import Data.Map ( Map, empty, adjust, insert, delete, lookup )
37import Data.Maybe ( isJust )
38import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
39
40import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,
41                   hSetBuffering, hIsTerminalDevice,
42                   Handle, BufferMode(LineBuffering) )
43import System.IO.Unsafe ( unsafePerformIO )
44
45import Darcs.Util.Global ( withDebugMode, debugMessage, putTiming )
46
47
48data ProgressData = ProgressData
49    { sofar   :: !Int
50    , latest  :: !(Maybe String)
51    , total   :: !(Maybe Int)
52    }
53
54progressRate :: Int
55progressRate = 1000000
56
57handleProgress :: IO ()
58handleProgress = do
59    threadDelay progressRate
60    handleMoreProgress "" 0
61
62
63handleMoreProgress :: String -> Int -> IO ()
64handleMoreProgress k n = withProgressMode $ \m ->
65    if m then do s <- getProgressLast
66                 mp <- getProgressData s
67                 case mp of
68                   Nothing -> do
69                      threadDelay progressRate
70                      handleMoreProgress k n
71                   Just p -> do
72                      when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p
73                      threadDelay progressRate
74                      handleMoreProgress s (sofar p)
75         else do threadDelay progressRate
76                 handleMoreProgress k n
77
78
79printProgress :: String
80              -> ProgressData
81              -> IO ()
82printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =
83    myput output output
84  where
85    output = k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l
86printProgress k (ProgressData {latest=Just l}) =
87    myput (k ++ " " ++ l) k
88printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =
89    myput (k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued")
90          (k ++ " " ++ show s)
91printProgress k (ProgressData {sofar=s}) =
92    myput (k ++ " " ++ show s) k
93
94
95myput :: String -> String -> IO ()
96myput l s = withDebugMode $ \debugMode ->
97    if debugMode
98      then putTiming >> hPutStrLn stderr l
99      else
100        if '\n' `elem` l
101          then myput (takeWhile (/= '\n') l) s
102          else putTiming >> if length l < 80
103                              then simpleput l
104                              else simpleput (take 80 s)
105
106
107simpleput :: String -> IO ()
108simpleput = unsafePerformIO $ mkhPutCr stderr
109{-# NOINLINE simpleput #-}
110
111
112-- | @beginTedious k@ starts a tedious process and registers it in
113-- '_progressData' with the key @k@. A tedious process is one for which we want
114-- a progress indicator.
115--
116-- Wouldn't it be safer if it had type String -> IO ProgressDataKey, so that we
117-- can ensure there is no collision? What happens if you call beginTedious twice
118-- with the same string, without calling endTedious in the meantime?
119beginTedious :: String -> IO ()
120beginTedious k = do
121    debugMessage $ "Beginning " ++ map toLower k
122    setProgressData k ProgressData
123                        { sofar = 0
124                        , latest = Nothing
125                        , total = Nothing
126                        }
127
128
129-- | @endTedious k@ unregisters the tedious process with key @k@, printing
130-- "Done" if such a tedious process exists.
131endTedious :: String -> IO ()
132endTedious k = whenProgressMode $ do
133    p <- getProgressData k
134    modifyIORef _progressData (second $ delete k)
135    when (isJust p) $ debugMessage $ "Done " ++ map toLower k
136
137
138tediousSize :: String
139            -> Int
140            -> IO ()
141tediousSize k s = updateProgressData k uptot
142  where
143    uptot p = case total p of
144                  Just t -> seq ts $ p { total = Just ts }
145                    where ts = t + s
146                  Nothing -> p { total = Just s }
147
148
149-- | XXX: document this constant
150minlist :: Int
151minlist = 4
152
153
154progressList :: String
155             -> [a]
156             -> [a]
157progressList _ [] = []
158progressList k (x:xs) = if l < minlist
159                          then x:xs
160                          else startit x : pl xs
161  where
162    l = length (x:xs)
163
164    startit y = unsafePerformIO $ do
165        beginTedious k
166        tediousSize k l
167        return y
168
169    pl [] = []
170    pl [y] = unsafePerformIO $ do
171        endTedious k
172        return [y]
173    pl (y:ys) = progress k y : pl ys
174
175
176progress :: String
177         -> a
178         -> a
179progress k a = unsafePerformIO $ progressIO k >> return a
180
181
182progressIO :: String -> IO ()
183progressIO "" = return ()
184progressIO k = do
185    updateProgressData k $ \p ->
186        p { sofar = sofar p + 1, latest = Nothing }
187    putDebug k ""
188
189
190progressKeepLatest :: String
191                   -> a
192                   -> a
193progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a
194
195
196progressKeepLatestIO :: String -> IO ()
197progressKeepLatestIO "" = return ()
198progressKeepLatestIO k = do
199    updateProgressData k (\p -> p {sofar = sofar p + 1})
200    putDebug k ""
201
202
203finishedOne :: String -> String -> a -> a
204finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a
205
206
207finishedOneIO :: String -> String -> IO ()
208finishedOneIO "" _ = return ()
209finishedOneIO k l = do
210    updateProgressData k (\p -> p { sofar = sofar p + 1,
211                                    latest = Just l })
212    putDebug k l
213
214
215putDebug :: String
216         -> String
217         -> IO ()
218putDebug _ _ = return ()
219--putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k
220--putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l
221
222
223_progressMode :: IORef Bool
224_progressMode = unsafePerformIO $ do
225    hSetBuffering stderr LineBuffering
226    newIORef True
227{-# NOINLINE _progressMode #-}
228
229_progressData :: IORef (String, Map String ProgressData)
230_progressData = unsafePerformIO $ do
231    _ <- forkIO handleProgress
232    newIORef ("", empty)
233{-# NOINLINE _progressData #-}
234
235mkhPutCr :: Handle
236         -> IO (String -> IO ())
237mkhPutCr fe = do
238    isTerm <- hIsTerminalDevice fe
239    stdoutIsTerm <- hIsTerminalDevice stdout
240    return $
241        if isTerm
242          then \s -> do
243              hPutStr fe $ '\r':s ++ "\r"
244              hFlush fe
245              let spaces = '\r':replicate (length s) ' ' ++ "\r"
246              hPutStr fe spaces
247              when stdoutIsTerm $ putStr spaces
248          else \s -> unless (null s) $ do hPutStrLn fe s
249                                          hFlush fe
250
251setProgressMode :: Bool -> IO ()
252setProgressMode = writeIORef _progressMode
253
254withoutProgress :: IO a -> IO a
255withoutProgress job = bracket off restore (const job) where
256  off = withProgressMode $ \m -> do
257    debugMessage "Disabling progress reports..."
258    setProgressMode False
259    return m
260  restore m = do
261    if m then debugMessage "Reenabling progress reports."
262    else debugMessage "Leaving progress reports off."
263    setProgressMode m
264
265updateProgressData :: String
266                   -> (ProgressData -> ProgressData)
267                   -> IO ()
268updateProgressData k f =
269    whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m))
270
271setProgressData :: String
272                -> ProgressData
273                -> IO ()
274setProgressData k p =
275    whenProgressMode $ modifyIORef _progressData (second $ insert k p)
276
277getProgressData :: String -> IO (Maybe ProgressData)
278getProgressData k = withProgressMode $ \p ->
279    if p
280      then (lookup k . snd) `fmap` readIORef _progressData
281      else return Nothing
282
283getProgressLast :: IO String
284getProgressLast = withProgressMode $ \p ->
285    if p
286      then fst `fmap` readIORef _progressData
287      else return ""
288
289whenProgressMode :: IO a -> IO ()
290whenProgressMode j = withProgressMode $ const $ void j
291
292withProgressMode :: (Bool -> IO a) -> IO a
293withProgressMode job = (readIORef _progressMode) >>= job
294