module Development.Shake.Progress(
Progress(..),
progressSimple, progressDisplay, progressTitlebar,
progressDisplayTester
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.Environment
import Data.Data
import Data.Monoid
import qualified Data.ByteString.Char8 as BS
import System.IO.Unsafe
#ifdef mingw32_HOST_OS
import Foreign
import Foreign.C.Types
type LPCSTR = Ptr CChar
foreign import stdcall "Windows.h SetConsoleTitleA" c_setConsoleTitle :: LPCSTR -> IO Bool
#endif
data Progress = Progress
{isRunning :: !Bool
,isFailure :: !(Maybe String)
,countSkipped :: !Int
,countBuilt :: !Int
,countUnknown :: !Int
,countTodo :: !Int
,timeSkipped :: !Double
,timeBuilt :: !Double
,timeUnknown :: !Double
,timeTodo :: !(Double,Int)
}
deriving (Eq,Ord,Show,Data,Typeable)
instance Monoid Progress where
mempty = Progress True Nothing 0 0 0 0 0 0 0 (0,0)
mappend a b = Progress
{isRunning = isRunning a && isRunning b
,isFailure = isFailure a `mappend` isFailure b
,countSkipped = countSkipped a + countSkipped b
,countBuilt = countBuilt a + countBuilt b
,countUnknown = countUnknown a + countUnknown b
,countTodo = countTodo a + countTodo b
,timeSkipped = timeSkipped a + timeSkipped b
,timeBuilt = timeBuilt a + timeBuilt b
,timeUnknown = timeUnknown a + timeUnknown b
,timeTodo = let (a1,a2) = timeTodo a; (b1,b2) = timeTodo b
x1 = a1 + b1; x2 = a2 + b2
in x1 `seq` x2 `seq` (x1,x2)
}
progressDone :: Progress -> Double
progressDone Progress{..} = timeBuilt
progressTodo :: Progress -> Double
progressTodo Progress{..} =
fst timeTodo + (if avgSamples == 0 || snd timeTodo == 0 then 0 else fromIntegral (snd timeTodo) * avgTime)
where
avgTime = (timeBuilt + fst timeTodo) / fromIntegral avgSamples
avgSamples = countBuilt + countTodo snd timeTodo
progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplay = progressDisplayer True
progressDisplayTester :: Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplayTester = progressDisplayer False
progressDisplayer :: Bool -> Double -> (String -> IO ()) -> IO Progress -> IO ()
progressDisplayer sleep sample disp prog = do
disp "Starting..."
loop $ tick0 sample
where
loop :: Tick -> IO ()
loop t = do
when sleep $ threadDelay $ ceiling $ sample * 1000000
p <- prog
if not $ isRunning p then
disp "Finished"
else do
(t, msg) <- return $ tick p t
disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)
loop $! t
data Tick = Tick
{sample :: !Double
,step :: !Double
,work_ :: !Double
,done_ :: !Double
,step_ :: !Double
} deriving Show
tick0 :: Double -> Tick
tick0 sample = Tick sample 0 0 0 0
factor :: Double
factor = 1.2
tick :: Progress -> Tick -> (Tick, String)
tick p tickOld@Tick{..}
| done == 0 = (tick, display 1)
| done == done_ = (tick, display work_)
| otherwise = (tick{work_=newWork, done_=done, step_=step'}, display newWork)
where
step' = step+sample
tick = tickOld{step=step'}
done = progressDone p
todo = progressTodo p
newWork = ((step_ * work_) + ((done done_) * factor)) /
((step_ + ((step' step_) * factor)))
display work = time ++ "s (" ++ perc ++ "%)"
where guess = todo / work
(mins,secs) = divMod (ceiling guess) (60 :: Int)
time = (if mins == 0 then "" else show mins ++ "m" ++ ['0' | secs < 10]) ++ show secs
perc = show (floor (if done == 0 then 0 else 100 * done / (done + todo)) :: Int)
xterm :: Bool
xterm = System.IO.Unsafe.unsafePerformIO $
Control.Exception.catch (fmap (== "xterm") $ getEnv "TERM") $
\(e :: SomeException) -> return False
progressTitlebar :: String -> IO ()
progressTitlebar x
| xterm = BS.putStr $ BS.pack $ "\ESC]0;" ++ x ++ "\BEL"
#ifdef mingw32_HOST_OS
| otherwise = BS.useAsCString (BS.pack x) $ \x -> c_setConsoleTitle x >> return ()
#else
| otherwise = return ()
#endif
progressSimple :: IO Progress -> IO ()
progressSimple = progressDisplay 5 progressTitlebar