module Development.Shake.Progress(
Progress(..),
progressSimple, progressDisplay, progressTitlebar, progressProgram,
progressDisplayTester
) where
import Control.Arrow
import Control.Applicative
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.Environment
import System.Directory
import System.Process
import Data.Char
import Data.Data
import Data.IORef
import Data.List
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
{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 Nothing 0 0 0 0 0 0 0 (0,0)
mappend a b = Progress
{isFailure = isFailure a `mplus` 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..."
catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop $ message sample idStream) (const $ disp "Finished")
where
loop :: Stream Progress String -> IO ()
loop stream = do
when sleep $ threadDelay $ ceiling $ sample * 1000000
p <- prog
(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" `isPrefixOf`) $ 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
progressProgram :: IO (String -> IO ())
progressProgram = do
exe <- findExecutable "shake-progress"
case exe of
Nothing -> return $ const $ return ()
Just exe -> do
ref <- newIORef Nothing
return $ \msg -> do
let failure = " Failure! " `isInfixOf` msg
let perc = let (a,b) = break (== '%') msg
in if null b then "" else reverse $ takeWhile isDigit $ reverse a
let key = (failure, perc)
same <- atomicModifyIORef ref $ \old -> (Just key, old == Just key)
let state = if perc == "" then "NoProgress" else if failure then "Error" else "Normal"
rawSystem exe $ ["--title=" ++ msg, "--state=" ++ state] ++ ["--value=" ++ perc | perc /= ""]
return ()
progressSimple :: IO Progress -> IO ()
progressSimple p = do
program <- progressProgram
progressDisplay 5 (\s -> progressTitlebar s >> program s) p