module Development.Shake.Progress(
Progress(..),
progressSimple, progressDisplay, progressTitlebar, progressProgram,
progressDisplayTester
) where
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 Mealy i a = Mealy {runMealy :: i -> (a, Mealy i a)}
instance Functor (Mealy i) where
fmap f (Mealy m) = Mealy $ \i -> case m i of
(x, m) -> (f x, fmap f m)
instance Applicative (Mealy i) where
pure x = let r = Mealy (const (x, r)) in r
Mealy mf <*> Mealy mx = Mealy $ \i -> case mf i of
(f, mf) -> case mx i of
(x, mx) -> (f x, mf <*> mx)
echoMealy :: Mealy i i
echoMealy = Mealy $ \i -> (i, echoMealy)
scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a
scanMealy f z (Mealy m) = Mealy $ \i -> case m i of
(x, m) -> let z2 = f z x in (z2, scanMealy f z2 m)
oldMealy :: a -> Mealy i a -> Mealy i (a,a)
oldMealy old = scanMealy (\(_,old) new -> (old,new)) (old,old)
latch :: Mealy i (Bool, a) -> Mealy i a
latch s = fromJust <$> scanMealy f Nothing s
where f old (b,v) = Just $ if b then fromMaybe v old else v
iff :: Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a
iff c t f = (\c t f -> if c then t else f) <$> c <*> t <*> f
posMealy :: Mealy i Int
posMealy = scanMealy (+) 0 $ pure 1
decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double
decay f a b = scanMealy step 0 $ (,) <$> oldMealy 0 a <*> oldMealy 0 b
where step r ((a,a'),(b,b')) =((r*b) + f*(a'a)) / (b + f*(b'b))
fromInt :: Int -> Double
fromInt = fromInteger . toInteger
message :: Double -> Mealy Progress Progress -> Mealy 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) posMealy
work = decay 1.2 done step
realWork = iff ((==) 0 <$> done) (pure 1) $
latch $ (,) <$> (uncurry (==) <$> oldMealy 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 echoMealy) (const $ disp "Finished")
where
loop :: Mealy Progress String -> IO ()
loop mealy = do
when sleep $ threadDelay $ ceiling $ sample * 1000000
p <- prog
(msg, mealy) <- return $ runMealy mealy p
disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)
loop mealy
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