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