module Development.Shake.Progress(
Progress(..),
progressSimple, progressDisplay, progressTitlebar,
progressDisplayTester
) where
import Control.Arrow
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.Environment
import Data.Data
import Data.Maybe
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)
}
newtype Stream a b = Stream {runStream :: a -> (b, Stream a b)}
instance Functor (Stream a) where
fmap f (Stream op) = Stream $ (f *** fmap f) . op
instance Applicative (Stream a) where
pure x = Stream $ const (x, pure x)
Stream ff <*> Stream xx = Stream $ \a ->
let (f1,f2) = ff a
(x1,x2) = xx a
in (f1 x1, f2 <*> x2)
idStream :: Stream a a
idStream = Stream $ \a -> (a, idStream)
oldStream :: b -> Stream a b -> Stream a (b,b)
oldStream old (Stream f) = Stream $ \a ->
let (new, f2) = f a
in ((old,new), oldStream new f2)
iff :: Stream a Bool -> Stream a b -> Stream a b -> Stream a b
iff c t f = (\c t f -> if c then t else f) <$> c <*> t <*> f
foldStream :: (a -> b -> a) -> a -> Stream i b -> Stream i a
foldStream f z (Stream op) = Stream $ \a ->
let (o1,o2) = op a
z2 = f z o1
in (z2, foldStream f z2 o2)
posStream :: Stream a Int
posStream = foldStream (+) 0 $ pure 1
fromInt :: Int -> Double
fromInt = fromInteger . toInteger
decay :: Double -> Stream i Double -> Stream i Double -> Stream i Double
decay f a b = foldStream step 0 $ (,) <$> oldStream 0 a <*> oldStream 0 b
where step r ((a,a'),(b,b')) =((r*b) + f*(a'a)) / (b + f*(b'b))
latch :: Stream i (Bool, a) -> Stream i a
latch = f Nothing
where f old (Stream op) = Stream $ \x -> let ((b,v),s) = op x
v2 = if b then fromMaybe v old else v
in (v2, f (Just v2) s)
message :: Double -> Stream Progress Progress -> Stream Progress String
message sample progress = (\time perc -> time ++ " (" ++ perc ++ "%)") <$> time <*> perc
where
done = fmap timeBuilt progress
guess = iff ((==) 0 <$> samples) (pure 0) $ decay 10 time $ fmap fromInt samples
where
time = flip fmap progress $ \Progress{..} -> timeBuilt + fst timeTodo
samples = flip fmap progress $ \Progress{..} -> countBuilt + countTodo snd timeTodo
todo = f <$> progress <*> guess
where f Progress{..} guess = fst timeTodo + (fromIntegral (snd timeTodo) * guess)
step = fmap ((*) sample . fromInt) posStream
work = decay 1.2 done step
realWork = iff ((==) 0 <$> done) (pure 1) $
latch $ (,) <$> (uncurry (==) <$> oldStream 0 done) <*> work
time = flip fmap ((/) <$> todo <*> realWork) $ \guess ->
let (mins,secs) = divMod (ceiling guess) (60 :: Int)
in (if mins == 0 then "" else show mins ++ "m" ++ ['0' | secs < 10]) ++ show secs ++ "s"
perc = iff ((==) 0 <$> done) (pure "0") $
(\done todo -> show (floor (100 * done / (done + todo)) :: Int)) <$> done <*> todo
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 $ message sample idStream
where
loop :: Stream Progress String -> IO ()
loop stream = do
when sleep $ threadDelay $ ceiling $ sample * 1000000
p <- prog
if not $ isRunning p then
disp "Finished"
else do
(msg, stream) <- return $ runStream stream p
disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)
loop stream
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