diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,7 @@ Changelog for Shake +0.13.4 + #171, fix the --demo mode on Linux 0.13.3 Ensure you wait until the progress thread cleans up Add --demo mode diff --git a/Development/Shake/Args.hs b/Development/Shake/Args.hs --- a/Development/Shake/Args.hs +++ b/Development/Shake/Args.hs @@ -134,7 +134,7 @@ else if NumericVersion `elem` flagsExtra then putStrLn $ showVersion version else if Demo `elem` flagsExtra then - demo + demo $ shakeStaunch shakeOpts else if not $ null progressReplays then do dat <- forM progressReplays $ \file -> do src <- readFile file diff --git a/Development/Shake/Command.hs b/Development/Shake/Command.hs --- a/Development/Shake/Command.hs +++ b/Development/Shake/Command.hs @@ -50,7 +50,7 @@ = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory. | Env [(String,String)] -- ^ Change the environment variables in the spawned process. By default uses this processes environment. -- Use 'addPath' to modify the @$PATH@ variable, or 'addEnv' to modify other variables. - | Stdin String -- ^ Given as the @stdin@ of the spawned process. By default no @stdin@ is given. + | Stdin String -- ^ Given as the @stdin@ of the spawned process. By default the @stdin@ is inherited. | Shell -- ^ Pass the command to the shell without escaping - any arguments will be joined with spaces. By default arguments are escaped properly. | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default streams use text encoding. | Traced String -- ^ Name to use with 'traced', or @\"\"@ for no tracing. By default traces using the name of the executable. diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs --- a/Development/Shake/Core.hs +++ b/Development/Shake/Core.hs @@ -510,7 +510,7 @@ putNormal $ "# " ++ msg ++ " (for " ++ showTopStack stack ++ ")" res <- liftIO act stop <- liftIO globalTimestamp - Action $ modifyRW $ \s -> s{localTraces = Trace (pack msg) start stop : localTraces s} + Action $ modifyRW $ \s -> s{localTraces = Trace (pack msg) (doubleToFloat start) (doubleToFloat stop) : localTraces s} return res diff --git a/Development/Shake/Database.hs b/Development/Shake/Database.hs --- a/Development/Shake/Database.hs +++ b/Development/Shake/Database.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-} +{-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards, ViewPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Development.Shake.Database( - Time, offsetTime, Duration, duration, Trace(..), + Trace(..), Database, withDatabase, listDepends, lookupDependencies, Ops(..), build, Depends, @@ -79,7 +79,7 @@ --------------------------------------------------------------------- -- CENTRAL TYPES -data Trace = Trace BS Time Time -- (message, start, end) +data Trace = Trace BS Float Float -- (message, start, end) deriving Show instance NFData Trace where @@ -109,7 +109,7 @@ ,built :: {-# UNPACK #-} !Step -- when it was actually run ,changed :: {-# UNPACK #-} !Step -- the step for deciding if it's valid ,depends :: [[Id]] -- dependencies - ,execution :: {-# UNPACK #-} !Duration -- how long it took when it was last run (seconds) + ,execution :: {-# UNPACK #-} !Float -- how long it took when it was last run (seconds) ,traces :: [Trace] -- a trace of the expensive operations (start/end in seconds since beginning of run) } deriving Show @@ -284,7 +284,7 @@ let norm = execute (addStack i k stack) k $ \res -> reply $ case res of Left err -> Error err - Right (v,deps,execution,traces) -> + Right (v,deps,(doubleToFloat -> execution),traces) -> let c | Just r <- r, result r == v = changed r | otherwise = step in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..} @@ -338,7 +338,7 @@ s <- readIORef status return $ foldl' f mempty $ map snd $ Map.elems s where - g = fromRational . toRational + g = floatToDouble f s (Ready Result{..}) = if step == built then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + g execution} @@ -410,12 +410,11 @@ ,prfBuilt = fromStep built ,prfChanged = fromStep changed ,prfDepends = mapMaybe (`Map.lookup` ids) (concat depends) - ,prfExecution = fromFloat execution + ,prfExecution = floatToDouble execution ,prfTraces = map fromTrace traces } where fromStep i = fromJust $ Map.lookup i steps - fromTrace (Trace a b c) = ProfileTrace (unpack a) (fromFloat b) (fromFloat c) - fromFloat = fromRational . toRational + fromTrace (Trace a b c) = ProfileTrace (unpack a) (floatToDouble b) (floatToDouble c) return [maybe (err "toReport") f $ Map.lookup i status | i <- order] diff --git a/Development/Shake/Demo.hs b/Development/Shake/Demo.hs --- a/Development/Shake/Demo.hs +++ b/Development/Shake/Demo.hs @@ -20,8 +20,8 @@ import System.IO -demo :: IO () -demo = do +demo :: Bool -> IO () +demo auto = do hSetBuffering stdout NoBuffering putStrLn $ "% Welcome to the Shake v" ++ showVersion version ++ " demo mode!" putStr $ "% Detecting machine configuration... " @@ -57,16 +57,21 @@ putStrLn $ "% The Shake demo uses an empty directory, OK to use:" putStrLn $ "% " ++ dir - b <- yesNo + b <- yesNo auto require b "% Please create an empty directory to run the demo from, then run 'shake --demo' again." putStr "% Copying files... " createDirectoryIfMissing True dir forM_ ["Build.hs","main.c","constants.c","constants.h","build" <.> if isWindows then "bat" else "sh"] $ \file -> copyFile (manual file) (dir file) + when (not isWindows) $ do + p <- getPermissions $ dir "build.sh" + setPermissions (dir "build.sh") p{executable=True} putStrLn "done" - let pause = putStr "% Press ENTER to continue: " >> getLine + let pause = do + putStr "% Press ENTER to continue: " + if auto then putLine "" else getLine let execute x = do putStrLn $ "% RUNNING: " ++ x cmd (Cwd dir) Shell x :: IO () @@ -105,16 +110,19 @@ -- | Require the user to press @y@ before continuing. -yesNo :: IO Bool -yesNo = do +yesNo :: Bool -> IO Bool +yesNo auto = do putStr $ "% [Y/N] (then ENTER): " - x <- fmap (map toLower) getLine + x <- if auto then putLine "y" else fmap (map toLower) getLine if "y" `isPrefixOf` x then return True else if "n" `isPrefixOf` x then return False else - yesNo + yesNo auto + +putLine :: String -> IO String +putLine x = putStrLn x >> return x -- | Replace exceptions with 'False'. diff --git a/Development/Shake/Progress.hs b/Development/Shake/Progress.hs --- a/Development/Shake/Progress.hs +++ b/Development/Shake/Progress.hs @@ -130,10 +130,6 @@ where step r ((a,a'),(b,b')) =((r*b) + f*(a'-a)) / (b + f*(b'-b)) -fromInt :: Int -> Double -fromInt = fromInteger . toInteger - - --------------------------------------------------------------------- -- MESSAGE GENERATOR @@ -180,10 +176,10 @@ where weightedAverage (w1,x1) (w2,x2) | w1 == 0 && w2 == 0 = 0 - | otherwise = ((w1 *. x1) + (w2 *. x2)) / fromInt (w1+w2) - where i *. d = if i == 0 then 0 else fromInt i * d -- since d might be NaN + | otherwise = ((w1 *. x1) + (w2 *. x2)) / intToDouble (w1+w2) + where i *. d = if i == 0 then 0 else intToDouble i * d -- since d might be NaN - f divide time count = let xs = count <$> progress in liftA2 (,) xs $ divide (time <$> progress) (fromInt <$> xs) + f divide time count = let xs = count <$> progress in liftA2 (,) xs $ divide (time <$> progress) (intToDouble <$> xs) -- Number of seconds work remaining, ignoring multiple threads todo = f <$> progress <*> ruleTime @@ -216,12 +212,12 @@ progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO () progressDisplay sample disp prog = do disp "Starting..." -- no useful info at this stage - time <- fmap (fromRational . toRational) <$> offsetTime + time <- offsetTime catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop time $ message echoMealy) (const $ disp "Finished") where loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO () loop time mealy = do - sleep $ fromRational $ toRational sample + sleep sample p <- prog t <- time ((secs,perc,debug), mealy) <- return $ runMealy mealy (t, p) diff --git a/Development/Shake/Resource.hs b/Development/Shake/Resource.hs --- a/Development/Shake/Resource.hs +++ b/Development/Shake/Resource.hs @@ -104,9 +104,9 @@ -- call a function after a certain delay -waiter :: Double -> IO () -> IO () +waiter :: Duration -> IO () -> IO () waiter period act = void $ forkIO $ do - sleep $ fromRational $ toRational period + sleep period act -- Make sure the pool cannot run try until after you have finished with it diff --git a/General/Base.hs b/General/Base.hs --- a/General/Base.hs +++ b/General/Base.hs @@ -1,7 +1,8 @@ {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} module General.Base( - Duration, duration, Time, offsetTime, offsetTimeIncrease, sleep, + Duration, duration, Time, diffTime, offsetTime, offsetTimeIncrease, sleep, + intToDouble, floatToDouble, doubleToFloat, isWindows, getProcessorCount, readFileStrict, readFileUCS2, getEnvMaybe, captureOutput, getExePath, randomElem, @@ -41,15 +42,18 @@ --------------------------------------------------------------------- -- Data.Time -type Time = Float -- how far you are through this run, in seconds +type Time = Double -- how far you are through this run, in seconds +diffTime :: UTCTime -> UTCTime -> Duration +diffTime end start = fromRational $ toRational $ end `diffUTCTime` start + -- | Call once at the start, then call repeatedly to get Time values out offsetTime :: IO (IO Time) offsetTime = do start <- getCurrentTime return $ do end <- getCurrentTime - return $ fromRational $ toRational $ end `diffUTCTime` start + return $ diffTime end start -- | Like offsetTime, but results will never decrease (though they may stay the same) offsetTimeIncrease :: IO (IO Time) @@ -61,7 +65,7 @@ atomicModifyIORef ref $ \o -> let m = max t o in m `seq` (m, m) -type Duration = Float -- duration in seconds +type Duration = Double -- duration in seconds duration :: IO a -> IO (Duration, a) duration act = do @@ -73,6 +77,19 @@ sleep :: Duration -> IO () sleep x = threadDelay $ ceiling $ x * 1000000 + + +--------------------------------------------------------------------- +-- Numeric + +intToDouble :: Int -> Double +intToDouble = fromInteger . toInteger + +floatToDouble :: Float -> Double +floatToDouble = fromRational . toRational + +doubleToFloat :: Double -> Float +doubleToFloat = fromRational . toRational --------------------------------------------------------------------- diff --git a/General/Timing.hs b/General/Timing.hs --- a/General/Timing.hs +++ b/General/Timing.hs @@ -43,7 +43,7 @@ progress x = let i = floor $ x * 25 // mx in replicate i '=' ++ replicate (25-i) ' ' mx = maximum $ map snd xs sm = sum $ map snd xs - xs = [ (name, fromRational $ toRational $ stop `diffUTCTime` start) + xs = [ (name, stop `diffTime` start) | ((start, name), stop) <- zip times $ map fst (drop 1 times) ++ [stop]] diff --git a/Test/Random.hs b/Test/Random.hs --- a/Test/Random.hs +++ b/Test/Random.hs @@ -8,7 +8,6 @@ import Control.Monad import Data.List import Data.Maybe -import Data.Time import System.Environment import System.Exit import System.Random @@ -35,7 +34,7 @@ let randomSleep = liftIO $ do i <- randomRIO (0, 25) - sleep $ fromInteger i / 100 + sleep $ intToDouble i / 100 forM_ (map read $ filter (isNothing . asDuration) args) $ \x -> case x of Want xs -> want $ map (toFile . Output) xs @@ -59,10 +58,10 @@ limit <- do args <- getArgs let bound = listToMaybe $ reverse $ mapMaybe asDuration args - start <- getCurrentTime + time <- offsetTime return $ when (isJust bound) $ do - now <- getCurrentTime - when (fromRational (toRational $ now `diffUTCTime` start) > fromJust bound) exitSuccess + now <- time + when (now > fromJust bound) exitSuccess forM_ [1..] $ \count -> do limit diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: shake -version: 0.13.3 +version: 0.13.4 license: BSD3 license-file: LICENSE category: Development @@ -51,12 +51,6 @@ docs/Ninja.md docs/Why.md docs/shake-progress.png - docs/manual/build.bat - docs/manual/Build.hs - docs/manual/build.sh - docs/manual/constants.c - docs/manual/constants.h - docs/manual/main.c js-src/jquery-1.8.3.js js-src/flot-0.8.0.zip @@ -71,6 +65,12 @@ html/shake-progress.js html/shake-ui.js html/shake-util.js + docs/manual/build.bat + docs/manual/Build.hs + docs/manual/build.sh + docs/manual/constants.c + docs/manual/constants.h + docs/manual/main.c source-repository head type: git