diff --git a/Development/Shake/Args.hs b/Development/Shake/Args.hs --- a/Development/Shake/Args.hs +++ b/Development/Shake/Args.hs @@ -224,7 +224,6 @@ ,no $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything." ,yes $ Option "" ["color","colour"] (NoArg $ Right ([Color], \s -> s{shakeOutput=outputColor (shakeOutput s)})) "Colorize the output." ,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information." - ,yes $ Option "" ["deterministic"] (noArg $ \s -> s{shakeDeterministic=True}) "Build rules in a fixed order." ,yes $ Option "" ["flush"] (intArg "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds." ,yes $ Option "" ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata." ,no $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit." diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs --- a/Development/Shake/Core.hs +++ b/Development/Shake/Core.hs @@ -287,7 +287,7 @@ stats <- progress database return stats{isRunning=running, isFailure=failure} addTiming "Running rules" - runPool (shakeDeterministic || shakeThreads == 1) shakeThreads $ \pool -> do + runPool (shakeThreads == 1) shakeThreads $ \pool -> do let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 [] mapM_ (addPool pool . staunch . runAction s0) (actions rs) when shakeLint $ do diff --git a/Development/Shake/Directory.hs b/Development/Shake/Directory.hs --- a/Development/Shake/Directory.hs +++ b/Development/Shake/Directory.hs @@ -249,7 +249,7 @@ (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir x) xs noDirs <- fmap and $ mapM f dirs let (del,keep) = partition test files - mapM_ IO.removeFile del + mapM_ IO.removeFile $ map (dir ) del let die = noDirs && null keep when die $ IO.removeDirectory $ dir dir2 return die diff --git a/Development/Shake/Progress.hs b/Development/Shake/Progress.hs --- a/Development/Shake/Progress.hs +++ b/Development/Shake/Progress.hs @@ -7,11 +7,14 @@ progressDisplayTester -- INTERNAL FOR TESTING ONLY ) 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 @@ -28,6 +31,9 @@ #endif +--------------------------------------------------------------------- +-- PROGRESS TYPES - exposed to the user + -- | Information about the current state of the build, obtained by passing a callback function -- to 'Development.Shake.shakeProgress'. Typically a program will use 'progressDisplay' to poll this value and produce -- status messages, which is implemented using this data type. @@ -62,21 +68,108 @@ in x1 `seq` x2 `seq` (x1,x2) } --- Including timeSkipped gives a more truthful percent, but it drops more sharply --- which isn't what users probably want -progressDone :: Progress -> Double -progressDone Progress{..} = timeBuilt +--------------------------------------------------------------------- +-- STREAM TYPES - for writing the progress functions --- | Make a guess at the number of seconds to go, ignoring multiple threads -progressTodo :: Progress -> Double -progressTodo Progress{..} = - fst timeTodo + (if avgSamples == 0 || snd timeTodo == 0 then 0 else fromIntegral (snd timeTodo) * avgTime) +-- | A stream of values +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'd division, compute a/b, with a decay of f +-- r' is the new result, r is the last result +-- r ~= a / b +-- r' = r*b + f*(a'-a) +-- ------------- +-- b + f*(b'-b) +-- when f == 1, r == r' +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 GENERATOR + +message :: Double -> Stream Progress Progress -> Stream Progress String +message sample progress = (\time perc -> time ++ " (" ++ perc ++ "%)") <$> time <*> perc where - avgTime = (timeBuilt + fst timeTodo) / fromIntegral avgSamples - avgSamples = countBuilt + countTodo - snd timeTodo + -- Number of seconds work completed + -- Ignores timeSkipped which would be more truthful, but it makes the % drop sharply + -- which isn't what users want + done = fmap timeBuilt progress + -- Predicted build time for a rule that has never been built before + -- The high decay means if a build goes in "phases" - lots of source files, then lots of compiling + -- we reach a reasonable number fairly quickly, without bouncing too much + 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 + -- Number of seconds work remaining, ignoring multiple threads + todo = f <$> progress <*> guess + where f Progress{..} guess = fst timeTodo + (fromIntegral (snd timeTodo) * guess) + + -- Number of seconds we have been going + step = fmap ((*) sample . fromInt) posStream + work = decay 1.2 done step + + -- Work value to use, don't divide by 0 and don't update work if done doesn't change + realWork = iff ((==) 0 <$> done) (pure 1) $ + latch $ (,) <$> (uncurry (==) <$> oldStream 0 done) <*> work + + -- Display information + 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 + + +--------------------------------------------------------------------- +-- EXPOSED FUNCTIONS + -- | Given a sampling interval (in seconds) and a way to display the status message, -- produce a function suitable for using as 'Development.Shake.shakeProgress'. -- This function polls the progress information every /n/ seconds, produces a status @@ -104,55 +197,18 @@ progressDisplayer :: Bool -> Double -> (String -> IO ()) -> IO Progress -> IO () progressDisplayer sleep sample disp prog = do disp "Starting..." -- no useful info at this stage - loop $ tick0 sample + loop $ message sample idStream where - loop :: Tick -> IO () - loop t = do + 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 - (t, msg) <- return $ tick p t + (msg, stream) <- return $ runStream stream p disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p) - loop $! t - - --- work_ and done_ are both as recorded at step_ -data Tick = Tick - {sample :: {-# UNPACK #-} !Double - ,step :: {-# UNPACK #-} !Double - ,work_ :: {-# UNPACK #-} !Double - ,done_ :: {-# UNPACK #-} !Double - ,step_ :: {-# UNPACK #-} !Double - } deriving Show - -tick0 :: Double -> Tick -tick0 sample = Tick sample 0 0 0 0 - --- How much additional weight to give to the latest work values -factor :: Double -factor = 1.2 - -tick :: Progress -> Tick -> (Tick, String) -tick p tickOld@Tick{..} - | done == 0 = (tick, display 1) -- no scaling, or we'd divide by zero - | done == done_ = (tick, display work_) -- use the last work rate - | otherwise = (tick{work_=newWork, done_=done, step_=step'}, display newWork) - where - step' = step+sample - tick = tickOld{step=step'} - done = progressDone p - todo = progressTodo p - - newWork = ((step_ * work_) + ((done - done_) * factor)) / - ((step_ + ((step' - step_) * factor))) - - display work = time ++ "s (" ++ perc ++ "%)" - where guess = todo / work - (mins,secs) = divMod (ceiling guess) (60 :: Int) - time = (if mins == 0 then "" else show mins ++ "m" ++ ['0' | secs < 10]) ++ show secs - perc = show (floor (if done == 0 then 0 else 100 * done / (done + todo)) :: Int) + loop stream {-# NOINLINE xterm #-} diff --git a/Development/Shake/Types.hs b/Development/Shake/Types.hs --- a/Development/Shake/Types.hs +++ b/Development/Shake/Types.hs @@ -71,10 +71,6 @@ -- ^ Defaults to 'False'. Perform basic sanity checks during building, checking the current directory -- is not modified and that output files are not modified by multiple rules. -- These sanity checks do not check for missing or redundant dependencies. - ,shakeDeterministic :: Bool - -- ^ Defaults to 'False'. Run rules in a deterministic order, as far as possible. Typically used in conjunction - -- with @'shakeThreads'=1@ for reproducing a build. If this field is set to 'False', Shake will run rules - -- in a random order, which typically decreases contention for resources and speeds up the build. ,shakeFlush :: Maybe Double -- ^ Defaults to @'Just' 10@. How often to flush Shake metadata files in seconds, or 'Nothing' to never flush explicitly. -- It is possible that on abnormal termination (not Haskell exceptions) any rules that completed in the last @@ -105,22 +101,22 @@ -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions -shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False False (Just 10) Nothing [] False True False +shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False (Just 10) Nothing [] False True False (const $ return ()) (const $ BS.putStrLn . BS.pack) -- try and output atomically using BS fieldsShakeOptions = ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport" - ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog" + ,"shakeLint", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog" ,"shakeLineBuffering", "shakeTimings", "shakeProgress", "shakeOutput"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix -unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 (fromFunction x15) (fromFunction x16) +unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 (fromFunction x14) (fromFunction x15) instance Data ShakeOptions where - gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16) = - z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` x12 `k` x13 `k` x14 `k` Function x15 `k` Function x16 - gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide + gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15) = + z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` x12 `k` x13 `k` Function x14 `k` Function x15 + gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions diff --git a/Examples/Test/Basic.hs b/Examples/Test/Basic.hs --- a/Examples/Test/Basic.hs +++ b/Examples/Test/Basic.hs @@ -26,6 +26,9 @@ src <- readFile' $ obj "zero.txt" writeFile' out src + phony "halfclean" $ do + removeFilesAfter (obj "") ["//*e.txt"] + phony "cleaner" $ do removeFilesAfter (obj "") ["//*"] @@ -64,9 +67,13 @@ show shakeOptions === show shakeOptions + build ["!halfclean"] + b <- IO.doesDirectoryExist (obj "") + assert b "Directory should exist, cleaner should not have removed it" + build ["!cleaner"] b <- IO.doesDirectoryExist (obj "") - assert (not b) "Directory should exist, cleaner should have removed it" + assert (not b) "Directory should not exist, cleaner should have removed it" IO.createDirectory $ obj "" writeFile (obj "zero.txt") "" diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Simple name: shake -version: 0.10.4 +version: 0.10.5 license: BSD3 license-file: LICENSE category: Development