src/Darcs/Progress.lhs

   1 % Various utility functions that do not belong anywhere else.
   2
   3 \begin{code}
   4 {-# OPTIONS_GHC -cpp #-}
   5 {-# LANGUAGE CPP #-}
   6
   7 #include "gadts.h"
   8
   9 module Darcs.Progress ( beginTedious, endTedious, tediousSize,
  10                         debugMessage, debugFail, withoutProgress,
  11                         progress, finishedOne, finishedOneIO,
  12                         progressList, progressFL, progressRL,
  13                         setProgressMode ) where
  14
  15 import Prelude hiding (lookup, catch)
  16
  17 import Control.Exception ( catch, throw )
  18 import Control.Monad ( when )
  19 import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,
  20                    hSetBuffering, hIsTerminalDevice,
  21                    Handle, BufferMode(LineBuffering) )
  22 import System.IO.Unsafe ( unsafePerformIO )
  23 import Data.Char ( toLower )
  24 import Data.Map ( Map, empty, adjust, insert, delete, lookup )
  25 import Data.Maybe ( isJust )
  26 import Control.Concurrent ( forkIO, threadDelay )
  27 import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
  28
  29 import Darcs.Ordered ( FL(..), RL(..), lengthRL, lengthFL )
  30 import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail )
  31
  32 handleProgress :: IO ()
  33 handleProgress = do threadDelay 1000000
  34                     handleMoreProgress "" 0
  35
  36 handleMoreProgress :: String -> Int -> IO ()
  37 handleMoreProgress k n = withProgressMode $ \m ->
  38     if m then do s <- getProgressLast
  39                  mp <- getProgressData s
  40                  case mp of
  41                    Nothing -> do threadDelay 1000000
  42                                  handleMoreProgress k n
  43                    Just p -> do when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p
  44                                 threadDelay 1000000
  45                                 handleMoreProgress s (sofar p)
  46          else do threadDelay 1000000
  47                  handleMoreProgress k n
  48
  49 printProgress :: String -> ProgressData -> IO ()
  50 printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =
  51     myput (k++" "++show s++"/"++show t++" : "++l) (k++" "++show s++"/"++show t)
  52 printProgress k (ProgressData {latest=Just l}) =
  53     myput (k++" "++l) k
  54 printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =
  55     myput (k++" "++show s++"/"++show t) (k++" "++show s)
  56 printProgress k (ProgressData {sofar=s}) =
  57     myput (k++" "++show s) k
  58
  59 myput :: String -> String -> IO ()
  60 myput l s = withDebugMode $ \debugMode ->
  61             if debugMode
  62             then putTiming >> hPutStrLn stderr l
  63             else if '\n' `elem` l
  64                  then myput (takeWhile (/= '\n') l) s
  65                  else if length l < 80 then putTiming >> simpleput l
  66                                        else putTiming >> simpleput (take 80 s)
  67
  68 {-# NOINLINE simpleput #-}
  69 simpleput :: String -> IO ()
  70 simpleput = unsafePerformIO $ mkhPutCr stderr
  71
  72 beginTedious :: String -> IO ()
  73 beginTedious k = do debugMessage $ "Beginning " ++ lower k
  74                     setProgressData k $ ProgressData { sofar = 0,
  75                                                        latest = Nothing,
  76                                                        total = Nothing }
  77
  78 endTedious :: String -> IO ()
  79 endTedious k = whenProgressMode $ do p <- getProgressData k
  80                                      modifyIORef _progressData (\(a,m) -> (a,delete k m))
  81                                      when (isJust p) $ debugMessage $ "Done "++lower k
  82
  83 lower :: String -> String
  84 lower (x:xs) = toLower x:xs
  85 lower "" = ""
  86
  87 beginOrEndTedious :: String -> Int -> IO ()
  88 beginOrEndTedious k l = do mp <- getProgressData k
  89                            case mp of
  90                              Nothing -> do beginTedious k
  91                                            tediousSize k l
  92                              Just p -> if total p == Just l
  93                                        then endTedious k
  94                                        else return ()
  95
  96 tediousSize :: String -> Int -> IO ()
  97 tediousSize k s = updateProgressData k uptot
  98     where uptot p = case total p of Just t -> seq ts $ p { total = Just ts }
  99                                         where ts = t + s
 100                                     Nothing -> p { total = Just s }
 101
 102 minlist :: Int
 103 minlist = 4
 104
 105 progressList :: String -> [a] -> [a]
 106 progressList _ [] = []
 107 progressList k (x:xs) = if l < minlist then x:xs
 108                                        else startit x : pl xs
 109     where l = length (x:xs)
 110           startit y = unsafePerformIO $ do beginOrEndTedious k l
 111                                            return y
 112           pl [y] = [startit y]
 113           pl [] = []
 114           pl (y:ys) = progress k y : pl ys
 115
 116 progressFL :: String -> FL a C(x y) -> FL a C(x y)
 117 progressFL _ NilFL = NilFL
 118 progressFL k (x:>:xs) = if l < minlist then x:>:xs
 119                                        else startit x :>: pl xs
 120     where l = lengthFL (x:>:xs)
 121           startit y = unsafePerformIO $ do beginOrEndTedious k l
 122                                            return y
 123           pl :: FL a C(x y) -> FL a C(x y)
 124           pl (y:>:NilFL) = (startit y) :>: NilFL
 125           pl NilFL = NilFL
 126           pl (y:>:ys) = progress k y :>: pl ys
 127
 128 progressRL :: String -> RL a C(x y) -> RL a C(x y)
 129 progressRL _ NilRL = NilRL
 130 progressRL k (x:<:xs) = if l < minlist then x:<:xs
 131                                        else startit x :<: pl xs
 132     where l = lengthRL (x:<:xs)
 133           startit y = unsafePerformIO $ do beginOrEndTedious k l
 134                                            return y
 135           pl :: RL a C(x y) -> RL a C(x y)
 136           pl (y:<:NilRL) = (startit y) :<: NilRL
 137           pl NilRL = NilRL
 138           pl (y:<:ys) = progress k y :<: pl ys
 139
 140 progress :: String -> a -> a
 141 progress k a = unsafePerformIO $ progressIO k >> return a
 142
 143 progressIO :: String -> IO ()
 144 progressIO "" = return ()
 145 progressIO k = do updateProgressData k (\p -> p { sofar = sofar p + 1,
 146                                                   latest = Nothing })
 147                   putDebug k ""
 148
 149 finishedOne :: String -> String -> a -> a
 150 finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a
 151
 152 finishedOneIO :: String -> String -> IO ()
 153 finishedOneIO "" _ = return ()
 154 finishedOneIO k l = do updateProgressData k (\p -> p { sofar = sofar p + 1,
 155                                                        latest = Just l })
 156                        putDebug k l
 157
 158 putDebug :: String -> String -> IO ()
 159 putDebug _ _ = return ()
 160 --putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k
 161 --putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l
 162
 163 {-# NOINLINE _progressMode #-}
 164 _progressMode :: IORef Bool
 165 _progressMode = unsafePerformIO $ do hSetBuffering stderr LineBuffering
 166                                      newIORef True
 167
 168 {-# NOINLINE _progressData #-}
 169 _progressData :: IORef (String, Map String ProgressData)
 170 _progressData = unsafePerformIO $ do forkIO handleProgress
 171                                      newIORef ("", empty)
 172
 173 mkhPutCr :: Handle -> IO (String -> IO ())
 174 mkhPutCr fe = do
 175   isTerm <- hIsTerminalDevice fe
 176   stdoutIsTerm <- hIsTerminalDevice stdout
 177   return $ if isTerm then \s -> do hPutStr fe $ '\r':s++"\r"
 178                                    hFlush fe
 179                                    let spaces = '\r':take (length s) (repeat ' ')++"\r"
 180                                    hPutStr fe spaces
 181                                    when stdoutIsTerm $ hPutStr stdout spaces
 182                      else \s -> when (not $ null s) $ do hPutStrLn fe s
 183                                                          hFlush fe
 184
 185 setProgressMode :: Bool -> IO ()
 186 setProgressMode m = writeIORef _progressMode m
 187
 188 withoutProgress :: IO a -> IO a
 189 withoutProgress j = withProgressMode $ \m -> do debugMessage "Disabling progress reports..."
 190                                                 setProgressMode False
 191                                                 a <- j `catch` \e -> setProgressMode m >> throw e
 192                                                 if m then debugMessage "Reenabling progress reports."
 193                                                      else debugMessage "Leaving progress reports off."
 194                                                 setProgressMode m
 195                                                 return a
 196
 197 updateProgressData :: String -> (ProgressData -> ProgressData) -> IO ()
 198 updateProgressData k f = whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m))
 199
 200 setProgressData :: String -> ProgressData -> IO ()
 201 setProgressData k p = whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m))
 202
 203 getProgressData :: String -> IO (Maybe ProgressData)
 204 getProgressData k = withProgressMode $ \p -> if p then (lookup k . snd) `fmap` readIORef _progressData
 205                                                   else return Nothing
 206
 207 getProgressLast :: IO String
 208 getProgressLast = withProgressMode $ \p -> if p then fst `fmap` readIORef _progressData
 209                                                 else return ""
 210
 211 whenProgressMode :: IO a -> IO ()
 212 whenProgressMode j = withProgressMode $ const $ j >> return ()
 213
 214 withProgressMode :: (Bool -> IO a) -> IO a
 215 withProgressMode j = readIORef _progressMode >>= j
 216
 217 data ProgressData = ProgressData { sofar :: !Int,
 218                                    latest :: !(Maybe String),
 219                                    total :: !(Maybe Int)}
 220
 221 \end{code}