shake 0.10.4 → 0.10.5

raw patch · 7 files changed

+125/−67 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Development/Shake/Args.hs +0/−1
• Development/Shake/Core.hs +1/−1
• Development/Shake/Directory.hs +1/−1
• Development/Shake/Progress.hs +108/−52
• Development/Shake/Types.hs +6/−10
• Examples/Test/Basic.hs +8/−1
• shake.cabal +1/−1

@@ -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."

@@ -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

@@ -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

@@ -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 #-}

@@ -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 

@@ -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") ""

@@ -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