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 General.Base
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 = timeBuilt <$> progress
donePerSec = iff ((==) 0 <$> done) (pure 1) perSecStable
where perSecStable = latch $ liftA2 (,) (uncurry (==) <$> oldMealy 0 done) perSecRaw
perSecRaw = decay 1.2 done secs
secs = ((*) sample . fromInt) <$> posMealy
ruleTime = liftA2 weightedAverage
(f (decay 10) timeBuilt countBuilt)
(f (liftA2 (/)) (fst . timeTodo) (\Progress{..} -> countTodo snd timeTodo))
where
weightedAverage (w1,x1) (w2,x2)
| w1 == 0 && w2 == 0 = 0
| otherwise = ((fromInt w1 * x1) + (fromInt w2 * x2)) / fromInt (w1+w2)
f divide time count = let xs = count <$> progress in liftA2 (,) xs $ divide (time <$> progress) (fromInt <$> xs)
todo = f <$> progress <*> ruleTime
where f Progress{..} ruleTime = fst timeTodo + (fromIntegral (snd timeTodo) * ruleTime)
time = flip fmap (liftA2 (/) todo donePerSec) $ \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") $
liftA2' done todo $ \done todo -> show (floor (100 * done / (done + todo)) :: Int)
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