diff --git a/Development/Shake.hs b/Development/Shake.hs --- a/Development/Shake.hs +++ b/Development/Shake.hs @@ -44,7 +44,7 @@ -- compile with @-threaded@. -- -- * Often the 'want' commands will be determined by command line arguments, to mirror the behaviour of @make@ --- targets. +-- targets. For a default set of 'want' commands that you later override, 'withoutActions' can be useful. -- -- * Lots of compilers produce @.o@ files. To avoid overlapping rules, use @.c.o@ for C compilers, -- @.hs.o@ for Haskell compilers etc. @@ -65,7 +65,7 @@ module Development.Shake( shake, -- * Core of Shake - ShakeOptions(..), shakeOptions, + ShakeOptions(..), shakeOptions, Assume(..), Progress(..), Rule(..), Rules, defaultRule, rule, action, withoutActions, Action, apply, apply1, traced, Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, @@ -89,6 +89,7 @@ -- then shows all the things that are hidden in the docs, which is terrible. import Control.Monad.IO.Class +import Development.Shake.Types import Development.Shake.Core import Development.Shake.Derived diff --git a/Development/Shake/Core.hs b/Development/Shake/Core.hs --- a/Development/Shake/Core.hs +++ b/Development/Shake/Core.hs @@ -2,10 +2,10 @@ {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, FunctionalDependencies #-} module Development.Shake.Core( - ShakeOptions(..), shakeOptions, run, + run, Rule(..), Rules, defaultRule, rule, action, withoutActions, Action, apply, apply1, traced, - Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, + getVerbosity, putLoud, putNormal, putQuiet, Resource, newResource, withResource ) where @@ -22,63 +22,14 @@ import qualified Data.HashMap.Strict as Map import Data.Maybe import Data.Monoid +import Data.IORef import Development.Shake.Pool import Development.Shake.Database import Development.Shake.Locks import Development.Shake.Value import Development.Shake.Report - ---------------------------------------------------------------------- --- OPTIONS - --- | Options to control the execution of Shake, usually specified by overriding fields in --- 'shakeOptions': --- --- @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=Just \"report.html\"} @ -data ShakeOptions = ShakeOptions - {shakeFiles :: FilePath -- ^ Where shall I store the database and journal files (defaults to @.shake@). - ,shakeThreads :: Int -- ^ What is the maximum number of rules I should run in parallel (defaults to @1@). - -- To enable parallelism you may need to compile with @-threaded@. - ,shakeVersion :: Int -- ^ What is the version of your build system, increment to force a complete rebuild (defaults to @1@). - ,shakeVerbosity :: Verbosity -- ^ What messages to print out (defaults to 'Normal'). - ,shakeStaunch :: Bool -- ^ Operate in staunch mode, where building continues even after errors (defaults to 'False'). - ,shakeReport :: Maybe FilePath -- ^ Produce an HTML profiling report (defaults to 'Nothing'). - ,shakeLint :: Bool -- ^ Perform basic sanity checks after building (defaults to 'False'). - ,shakeDeterministic :: Bool -- ^ Build files in a deterministic order, as far as possible - } - deriving (Show,Eq,Ord,Typeable,Data) - --- | The default set of 'ShakeOptions'. -shakeOptions :: ShakeOptions -shakeOptions = ShakeOptions ".shake" 1 1 Normal False Nothing False False - - --- | All foreseen exception conditions thrown by Shake, such problems with the rules or errors when executing --- rules, will be raised using this exception type. -data ShakeException = ShakeException - [String] -- Entries on the stack, starting at the top of the stack. - SomeException -- Inner exception that was raised. - -- If I make these Haddock comments, then Haddock dies - deriving Typeable - -instance Exception ShakeException - -instance Show ShakeException where - show (ShakeException stack inner) = unlines $ - "Error when running Shake build system:" : - map ("* " ++) stack ++ - [show inner] - - --- | The verbosity data type, used by 'shakeVerbosity'. -data Verbosity - = Silent -- ^ Don't print any messages. - | Quiet -- ^ Only print essential messages (typically errors). - | Normal -- ^ Print normal messages (typically errors and warnings). - | Loud -- ^ Print lots of messages (typically errors, warnings and status updates). - | Diagnostic -- ^ Print messages for virtually everything (for debugging a build system). - deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data) +import Development.Shake.Types --------------------------------------------------------------------- @@ -90,13 +41,12 @@ Show value, Typeable value, Eq value, Hashable value, Binary value, NFData value ) => Rule key value | key -> value where - -- | Given that the database contains @key@/@value@, does that still match the on-disk contents? + -- | Retrieve the @value@ associated with a @key@, if available. -- - -- As an example for filenames/timestamps, if the file exists and had the same timestamp, you - -- would return 'True', but otherwise return 'False'. For rule values which are not also stored - -- on disk, 'validStored' should always return 'True'. - validStored :: key -> value -> IO Bool - validStored _ _ = return True + -- As an example for filenames/timestamps, if the file exists you should return 'Just' + -- the timestamp, but otherwise return 'Nothing'. For rules whose values are not + -- stored externally, 'storedValue' should always return 'Nothing'. + storedValue :: key -> IO (Maybe value) {- -- | Return 'True' if the value should not be changed by the build system. Defaults to returning @@ -139,10 +89,7 @@ ruleValue :: Rule key value => (key -> Maybe (Action value)) -> value ruleValue = undefined -ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> value -> IO Bool) -ruleStored _ = validStored - -- | Define a set of rules. Rules can be created with calls to 'rule', 'defaultRule' or 'action'. Rules are combined -- with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation. data Rules a = Rules @@ -211,6 +158,7 @@ ,output :: String -> IO () ,verbosity :: Verbosity ,logger :: String -> IO () + ,assume :: Maybe Assume -- stack variables ,stack :: Stack -- local variables @@ -248,22 +196,25 @@ when (shakeVerbosity >= Quiet) $ output msg Right _ -> return () - let stored = createStored rs - let execute = createExecute rs - withDatabase logger shakeFiles shakeVersion $ \database -> do - runPool shakeDeterministic shakeThreads $ \pool -> do - let s0 = S database pool start stored execute output shakeVerbosity logger emptyStack [] 0 [] - mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs) - when shakeLint $ do - checkValid database stored - when (shakeVerbosity >= Loud) $ output "Lint checking succeeded" - when (isJust shakeReport) $ do - let file = fromJust shakeReport - json <- showJSON database - when (shakeVerbosity >= Normal) $ - putStrLn $ "Writing HTML report to " ++ file - buildReport json file - maybe (return ()) throwIO =<< readVar except + let stored = createStored shakeAssume rs + let execute = createExecute shakeAssume rs + running <- newIORef True + flip finally (writeIORef running False) $ do + withDatabase logger shakeFiles shakeVersion shakeFlush $ \database -> do + shakeProgress $ do running <- readIORef running; stats <- progress database; return stats{isRunning=running} + runPool shakeDeterministic shakeThreads $ \pool -> do + let s0 = S database pool start stored execute output shakeVerbosity logger shakeAssume emptyStack [] 0 [] + mapM_ (addPool pool . staunch . wrapStack (return []) . runAction s0) (actions rs) + when shakeLint $ do + checkValid database stored + when (shakeVerbosity >= Loud) $ output "Lint checking succeeded" + when (isJust shakeReport) $ do + let file = fromJust shakeReport + json <- showJSON database + when (shakeVerbosity >= Normal) $ + putStrLn $ "Writing HTML report to " ++ file + buildReport json file + maybe (return ()) throwIO =<< readVar except wrapStack :: IO [String] -> IO a -> IO a @@ -281,8 +232,8 @@ registerWitness $ ruleValue r -createStored :: Rules () -> (Key -> Value -> IO Bool) -createStored Rules{..} = \k v -> +createStored :: Maybe Assume -> Rules () -> (Key -> Value -> IO Bool) +createStored assume Rules{..} = \k v -> let (tk,tv) = (typeKey k, typeValue v) in case Map.lookup tk mp of Nothing -> error $ @@ -294,28 +245,44 @@ ", perhaps you have the types wrong in your call to apply?" Just (_, r) -> r k v where - mp = flip Map.map rules $ \(k,v,(_,ARule r):_) -> (v, \kx vx -> ruleStored r (fromKey kx) (fromValue vx)) + mp = flip Map.map rules $ \(_,v,(_,ARule r):_) -> (v, \kx vx -> ruleStored r (fromKey kx) (fromValue vx)) + -- NOTE: We change the storedValue type so that we always pass in both key and value, rather than having + -- value as a return param. That allows us to give better error messages (see createStored) + ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> value -> IO Bool) + ruleStored _ = if assume == Just AssumeDirty + then \k v -> return False + else \k v -> fmap (== Just v) $ storedValue k -createExecute :: Rules () -> (Key -> Action Value) -createExecute Rules{..} = \k -> - let tk = typeKey k in - case Map.lookup tk mp of - Nothing -> error $ - "Error: couldn't find any rules to build " ++ show k ++ " of type " ++ show tk ++ - ", perhaps you are missing a call to defaultRule/rule?" - Just rs -> case filter (not . null) $ map (mapMaybe ($ k)) rs of - [r]:_ -> r - rs -> - let s = if null rs then "no" else show (length $ head rs) - in error $ "Error: " ++ s ++ " rules match for Rule " ++ show k ++ " of type " ++ show tk + +createExecute :: Maybe Assume -> Rules () -> (Key -> Action Value) +createExecute assume Rules{..} = \k -> + let tk = typeKey k + norm = case Map.lookup tk mp of + Nothing -> error $ + "Error: couldn't find any rules to build " ++ show k ++ " of type " ++ show tk ++ + ", perhaps you are missing a call to defaultRule/rule?" + Just rs -> case filter (not . null) $ map (mapMaybe ($ k)) rs of + [r]:_ -> r + rs -> + let s = if null rs then "no" else show (length $ head rs) + in error $ "Error: " ++ s ++ " rules match for Rule " ++ show k ++ " of type " ++ show tk + clean = case Map.lookup tk mpClean of + Nothing -> norm -- should reraise an error + Just stored -> do res <- liftIO $ stored k; maybe norm return res + in if assume == Just AssumeClean then clean else norm where mp = flip Map.map rules $ \(_,_,rs) -> sets [(i, \k -> fmap (fmap newValue) $ r (fromKey k)) | (i,ARule r) <- rs] - sets :: Ord a => [(a, b)] -> [[b]] + sets :: Ord a => [(a, b)] -> [[b]] -- highest to lowest sets = map (map snd) . reverse . groupBy ((==) `on` fst) . sortBy (compare `on` fst) + mpClean = flip Map.map rules $ \(_,_,(_,ARule r):_) -> \k -> fmap (fmap newValue) $ ruleStored r $ fromKey k + ruleStored :: Rule key value => (key -> Maybe (Action value)) -> (key -> IO (Maybe value)) + ruleStored _ = storedValue + + runAction :: S -> Action a -> IO (a, S) runAction s (Action x) = runStateT x s @@ -337,7 +304,7 @@ let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2) evaluate $ rnf ans return ans - res <- liftIO $ build (pool s) (database s) (Ops (stored s) exec) (stack s) ks + res <- liftIO $ build (pool s) (database s) (Ops (stored s) exec) (assume s) (stack s) ks case res of Left err -> throw err Right (dur, dep, vs) -> do diff --git a/Development/Shake/Database.hs b/Development/Shake/Database.hs --- a/Development/Shake/Database.hs +++ b/Development/Shake/Database.hs @@ -6,6 +6,7 @@ Time, startTime, Duration, duration, Trace, Database, withDatabase, Ops(..), build, Depends, + progress, Stack, emptyStack, showStack, showJSON, checkValid, ) where @@ -15,6 +16,7 @@ import Development.Shake.Value import Development.Shake.Locks import Development.Shake.Storage +import Development.Shake.Types import Development.Shake.Intern as Intern import Control.DeepSeq @@ -181,8 +183,8 @@ -- | Return either an exception (crash), or (how much time you spent waiting, the value) -build :: Pool -> Database -> Ops -> Stack -> [Key] -> IO (Either SomeException (Duration,Depends,[Value])) -build pool Database{..} Ops{..} stack ks = do +build :: Pool -> Database -> Ops -> Maybe Assume -> Stack -> [Key] -> IO (Either SomeException (Duration,Depends,[Value])) +build pool Database{..} Ops{..} assume stack ks = do join $ withLock lock $ do is <- forM ks $ \k -> do is <- readIORef intern @@ -255,9 +257,11 @@ ans <- i #= (k, case res of Left err -> Error err Right (v,deps,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,..}) + case assume of + Just AssumeClean | Just r <- r -> Ready r{result=v} + _ -> 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,..}) runWaiting w return ans case ans of @@ -303,6 +307,28 @@ --------------------------------------------------------------------- +-- PROGRESS + +-- Does not need to set shakeRunning, done by something further up +progress :: Database -> IO Progress +progress Database{..} = do + s <- readIORef status + let zero = Progress False 0 0 0 0 0 0 0 (0,0) + return $ foldl' f zero $ map snd $ Map.elems s + where + f s (Ready Result{..}) = if step == built + then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + execution} + else s{countSkipped = countSkipped s + 1, timeSkipped = timeSkipped s + execution} + f s (Loaded Result{..}) = s{countUnknown = countUnknown s + 1, timeUnknown = timeUnknown s + execution} + f s (Waiting _ r) = + let (d,c) = timeTodo s + t | Just Result{..} <- r = let d2 = d + execution in d2 `seq` (d2,c) + | otherwise = let c2 = c + 1 in c2 `seq` (d,c2) + in s{countTodo = countTodo s + 1, timeTodo = t} + f s _ = s + + +--------------------------------------------------------------------- -- QUERY DATABASE -- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such @@ -403,12 +429,12 @@ fromStepResult = fromValue . result -withDatabase :: (String -> IO ()) -> FilePath -> Int -> (Database -> IO a) -> IO a -withDatabase logger filename version act = do +withDatabase :: (String -> IO ()) -> FilePath -> Int -> Maybe Double -> (Database -> IO a) -> IO a +withDatabase logger filename version flush act = do registerWitness $ StepKey () registerWitness $ Step 0 witness <- currentWitness - withStorage logger filename version witness $ \mp2 journal -> do + withStorage logger filename version flush witness $ \mp2 journal -> do let mp1 = Intern.fromList [(k, i) | (i, (k,_)) <- Map.toList mp2] (mp1, stepId) <- case Intern.lookup stepKey mp1 of @@ -422,7 +448,7 @@ let step = case Map.lookup stepId mp2 of Just (_, Loaded r) -> incStep $ fromStepResult r _ -> Step 1 - journal stepId $ (stepKey, Loaded $ toStepResult step) + journal stepId (stepKey, Loaded $ toStepResult step) lock <- newLock act Database{..} diff --git a/Development/Shake/Directory.hs b/Development/Shake/Directory.hs --- a/Development/Shake/Directory.hs +++ b/Development/Shake/Directory.hs @@ -65,11 +65,11 @@ instance Rule Exist Bool where - validStored (Exist x) b = fmap (== b) $ IO.doesFileExist x + storedValue (Exist x) = fmap Just $ IO.doesFileExist x -- invariant _ = True instance Rule GetDir GetDir_ where - validStored x y = fmap (== y) $ getDir x + storedValue x = fmap Just $ getDir x -- invariant _ = True diff --git a/Development/Shake/File.hs b/Development/Shake/File.hs --- a/Development/Shake/File.hs +++ b/Development/Shake/File.hs @@ -32,7 +32,7 @@ instance Rule File FileTime where - validStored (File x) t = fmap (== Just t) $ getModTimeMaybe x + storedValue (File x) = getModTimeMaybe x {- observed act = do diff --git a/Development/Shake/Files.hs b/Development/Shake/Files.hs --- a/Development/Shake/Files.hs +++ b/Development/Shake/Files.hs @@ -25,9 +25,9 @@ deriving (Typeable,Eq,Hashable,Binary) instance NFData Files where - rnf (Files xs) = f xs - where f [] = () - f (x:xs) = x `seq` f xs + -- some versions of ByteString do not have NFData instances, but seq is equivalent + -- for a strict bytestring. Therefore, we write our own instance. + rnf (Files xs) = rnf $ map (`seq` ()) xs newtype FileTimes = FileTimes [FileTime] deriving (Typeable,Show,Eq,Hashable,Binary,NFData) @@ -36,7 +36,7 @@ instance Rule Files FileTimes where - validStored (Files xs) (FileTimes ts) = fmap (== map Just ts) $ mapM getModTimeMaybe xs + storedValue (Files xs) = fmap (fmap FileTimes . sequence) $ mapM getModTimeMaybe xs -- | Define a rule for building multiple files at the same time. diff --git a/Development/Shake/Locks.hs b/Development/Shake/Locks.hs --- a/Development/Shake/Locks.hs +++ b/Development/Shake/Locks.hs @@ -1,7 +1,7 @@ module Development.Shake.Locks( Lock, newLock, withLock, - Var, newVar, readVar, modifyVar, modifyVar_, + Var, newVar, readVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, Resource, newResource, acquireResource, releaseResource ) where @@ -42,6 +42,9 @@ modifyVar_ :: Var a -> (a -> IO a) -> IO () modifyVar_ (Var x) f = modifyMVar_ x f + +withVar :: Var a -> (a -> IO b) -> IO b +withVar (Var x) f = withMVar x f --------------------------------------------------------------------- diff --git a/Development/Shake/Oracle.hs b/Development/Shake/Oracle.hs --- a/Development/Shake/Oracle.hs +++ b/Development/Shake/Oracle.hs @@ -22,7 +22,7 @@ show (Question xs) = "Oracle " ++ unwords xs instance Rule Question Answer where - validStored _ _ = return False + storedValue _ = return Nothing -- | Add extra information which your build should depend on. For example: diff --git a/Development/Shake/Pool.hs b/Development/Shake/Pool.hs --- a/Development/Shake/Pool.hs +++ b/Development/Shake/Pool.hs @@ -72,13 +72,13 @@ If any worker throws an exception, must signal to all the other workers -} -data Pool = Pool Int (Var (Maybe S)) (Barrier (Maybe SomeException)) +data Pool = Pool {-# UNPACK #-} !Int !(Var (Maybe S)) !(Barrier (Maybe SomeException)) data S = S - {threads :: Set.HashSet ThreadId - ,working :: Int -- threads which are actively working - ,blocked :: Int -- threads which are blocked - ,todo :: Queue (IO ()) + {threads :: !(Set.HashSet ThreadId) -- IMPORTANT: Must be strict or we leak thread stackssss + ,working :: {-# UNPACK #-} !Int -- threads which are actively working + ,blocked :: {-# UNPACK #-} !Int -- threads which are blocked + ,todo :: !(Queue (IO ())) } diff --git a/Development/Shake/Rerun.hs b/Development/Shake/Rerun.hs --- a/Development/Shake/Rerun.hs +++ b/Development/Shake/Rerun.hs @@ -22,7 +22,7 @@ instance Eq Dirty where a == b = False instance Rule AlwaysRerun Dirty where - validStored _ _ = return False + storedValue _ = return Nothing -- | Always rerun the associated action. Useful for defining rules that query diff --git a/Development/Shake/Storage.hs b/Development/Shake/Storage.hs --- a/Development/Shake/Storage.hs +++ b/Development/Shake/Storage.hs @@ -16,6 +16,7 @@ import Control.DeepSeq import Control.Exception as E import Control.Monad +import Control.Concurrent import Data.Binary.Get import Data.Binary.Put import Data.Char @@ -43,10 +44,11 @@ => (String -> IO ()) -- ^ Logging function -> FilePath -- ^ File prefix to use -> Int -- ^ User supplied version number + -> Maybe Double -- ^ How often to flush (Nothing = never, Just = seconds) -> w -- ^ Witness -> (Map k v -> (k -> v -> IO ()) -> IO a) -- ^ Execute -> IO a -withStorage logger file version witness act = do +withStorage logger file version flush witness act = do let dbfile = file <.> "database" bupfile = file <.> "bup" createDirectoryIfMissing True $ takeDirectory file @@ -138,11 +140,43 @@ when (Map.null mp) $ reset h mp -- might as well, no data to lose, and need to ensure a good witness table lock <- newLock - act mp $ \k v -> do - -- QUESTION: Should the logging be on a different thread? Does that reduce blocking? - withLock lock $ writeChunk h $ runPut $ putWith witness (k, v) - hFlush h - logger "Flush" + flushThread flush h $ \out -> + act mp $ \k v -> out $ toChunk $ runPut $ putWith witness (k, v) + + +-- We avoid calling flush too often on SSD drives, as that can be slow +-- Do not move writes to a separate thread, as then we'd have to marshal exceptions back which is tricky +flushThread :: Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a +flushThread flush h act = do + alive <- newVar True + kick <- newEmptyMVar + + case flush of + Nothing -> return () + Just flush -> do + let delay = ceiling $ flush * 1000000 + let loop = do + takeMVar kick + threadDelay delay + b <- withVar alive $ \b -> do + when b $ do + tryTakeMVar kick + hFlush h + return b + when b loop + forkIO $ do + let msg = "Warning: Flushing Shake journal failed, on abnormal termination you may lose some data, " + (loop >> return ()) `E.catch` \(e :: SomeException) -> putStrLn $ msg ++ show e + return () + + lock <- newLock + (act $ \s -> do + withLock lock $ LBS.hPut h s + tryPutMVar kick () + return ()) + `finally` do + tryPutMVar kick () + modifyVar_ alive $ const $ return False -- Return the amount of junk at the end, along with all the chunk diff --git a/Development/Shake/Types.hs b/Development/Shake/Types.hs new file mode 100644 --- /dev/null +++ b/Development/Shake/Types.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DeriveDataTypeable, RecordWildCards, PatternGuards #-} + +-- | Types exposed to the user +module Development.Shake.Types( + Progress(..), Verbosity(..), Assume(..), + ShakeOptions(..), shakeOptions, + ShakeException(..) + ) where + +import Control.Exception +import Data.Data +import Data.List + + +-- | Information about the current state of the build, obtained by passing a callback function +-- to 'shakeProgress'. Typically a program will poll this value to provide progress messages. +-- The following example displays the approximate single-threaded time remaining +-- as the console title. +-- +-- > showProgress :: IO Progress -> IO () +-- > showProgress progress = void $ forkIO loop +-- > where loop = do +-- > current <- progress +-- > when (isRunning current) $ do +-- > let (s,c) = timeTodo current +-- > setTitle $ "Todo = " ++ show (ceiling s) ++ "s (+ " ++ show c ++ " unknown)" +-- > threadDelay $ 5 * 1000000 +-- > loop +-- > +-- > setTitle :: String -> IO () +-- > setTitle s = putStr $ "\ESC]0;" ++ s ++ "\BEL" +data Progress = Progress + {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed. + ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state. + ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run. + ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required. + ,countTodo :: {-# UNPACK #-} !Int -- ^ Number of rules which are currently required (ignoring dependencies that do not change), but not built. + ,timeSkipped :: {-# UNPACK #-} !Double -- ^ Time spent building 'countSkipped' rules in previous runs. + ,timeBuilt :: {-# UNPACK #-} !Double -- ^ Time spent building 'countBuilt' rules. + ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs. + ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before). + } + deriving (Eq,Ord,Show,Data,Typeable) + + +-- | The current assumptions made by the build system, used by 'shakeAssume'. These options +-- allow the end user to specify that any rules run are either to be treated as clean, or as +-- dirty, regardless of what the build system thinks. +-- +-- These assumptions only operate on files reached by the current 'action' commands. Any +-- other files in the database are left unchanged. +data Assume + = AssumeDirty + -- ^ Assume that all rules reached are dirty and require rebuilding, equivalent to 'storedValue' always + -- returning 'Nothing'. Useful to undo the results of 'AssumeClean', for benchmarking rebuild speed and + -- for rebuilding if untracked dependencies have changed. This assumption is safe, but may cause + -- more rebuilding than necessary. + | AssumeClean + -- ^ /This assumption is unsafe, and may lead to incorrect build results/. + -- Assume that all rules reached are clean and do not require rebuilding, provided the rule + -- has a 'storedValue' and has been built before. Useful if you have modified a file in some + -- inconsequential way, such as only the comments or whitespace, and wish to avoid a rebuild. + deriving (Eq,Ord,Show,Data,Typeable,Bounded,Enum) + + +-- | Options to control the execution of Shake, usually specified by overriding fields in +-- 'shakeOptions': +-- +-- @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=Just \"report.html\"} @ +-- +-- The 'Data' instance for this type reports the 'shakeProgress' field as having the abstract type 'ShakeProgress', +-- because 'Data' cannot be defined for functions. +data ShakeOptions = ShakeOptions + {shakeFiles :: FilePath + -- ^ Defaults to @.shake@. The prefix of the filename used for storing Shake metadata files. + -- All metadata files will be named @'shakeFiles'./extension/@, for some @/extension/@. + ,shakeThreads :: Int + -- ^ Defaults to @1@. Maximum number of rules to run in parallel, similar to @make --jobs=/N/@. + -- To enable parallelism you may need to compile with @-threaded@. + -- For many build systems, a number equal to or slightly less than the number of physical processors + -- works well. + ,shakeVersion :: Int + -- ^ Defaults to @1@. The version number of your build rules. + -- Increment the version number to force a complete rebuild, such as when making + -- significant changes to the rules that require a wipe. The version number should be + -- set in the source code, and not passed on the command line. + ,shakeVerbosity :: Verbosity + -- ^ Defaults to 'Normal'. What level of messages should be printed out. + ,shakeStaunch :: Bool + -- ^ Defaults to 'False'. Operate in staunch mode, where building continues even after errors, + -- similar to @make --keep-going@. + ,shakeReport :: Maybe FilePath + -- ^ Defaults to 'Nothing'. Write an HTML profiling report to a file, showing which + -- rules rebuilt, why, and how much time they took. Useful for improving the speed of your build systems. + ,shakeLint :: Bool + -- ^ Defaults to 'False'. Perform basic sanity checks after building, checking files have not been modified + -- several times during the build. These sanity checks fail to catch most interesting errors. + ,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 + -- 'shakeFlush' seconds will be lost. + ,shakeAssume :: Maybe Assume + -- ^ Defaults to 'Nothing'. Assume all build objects are clean/dirty, see 'Assume' for details. + -- Can be used to implement @make --touch@. + ,shakeProgress :: IO Progress -> IO () + -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported, + -- see 'Progress' for details. + } + deriving Typeable + +-- | The default set of 'ShakeOptions'. +shakeOptions :: ShakeOptions +shakeOptions = ShakeOptions ".shake" 1 1 Normal False Nothing False False (Just 10) Nothing (const $ return ()) + +fieldsShakeOptions = + ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport" + ,"shakeLint", "shakeDeterministic", "shakeFlush", "shakeAssume", "shakeProgress"] +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 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 (fromProgress x11) + +instance Data ShakeOptions where + gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11) = + z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` ShakeProgress x11 + gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide + toConstr ShakeOptions{} = conShakeOptions + dataTypeOf _ = tyShakeOptions + +instance Show ShakeOptions where + show x = "ShakeOptions {" ++ intercalate ", " inner ++ "}" + where + inner = zipWith (\x y -> x ++ " = " ++ y) fieldsShakeOptions $ gmapQ f x + + f x | Just x <- cast x = show (x :: Int) + | Just x <- cast x = show (x :: FilePath) + | Just x <- cast x = show (x :: Verbosity) + | Just x <- cast x = show (x :: Bool) + | Just x <- cast x = show (x :: Maybe FilePath) + | Just x <- cast x = show (x :: Maybe Assume) + | Just x <- cast x = show (x :: Maybe Double) + | Just x <- cast x = show (x :: ShakeProgress) + | otherwise = error $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x) + + +-- | Internal type, copied from Hide in Uniplate +newtype ShakeProgress = ShakeProgress {fromProgress :: IO Progress -> IO ()} + deriving Typeable + +instance Show ShakeProgress where show _ = "" + +instance Data ShakeProgress where + gfoldl k z x = z x + gunfold k z c = error "Development.Shake.Types.ShakeProgress: gunfold not implemented - data type has no constructors" + toConstr _ = error "Development.Shake.Types.ShakeProgress: toConstr not implemented - data type has no constructors" + dataTypeOf _ = tyShakeProgress + +tyShakeProgress = mkDataType "Development.Shake.Types.ShakeProgress" [] + + + +-- NOTE: Not currently public, to avoid pinning down the API yet +-- | All foreseen exception conditions thrown by Shake, such problems with the rules or errors when executing +-- rules, will be raised using this exception type. +data ShakeException = ShakeException + [String] -- Entries on the stack, starting at the top of the stack. + SomeException -- Inner exception that was raised. + -- If I make these Haddock comments, then Haddock dies + deriving Typeable + +instance Exception ShakeException + +instance Show ShakeException where + show (ShakeException stack inner) = unlines $ + "Error when running Shake build system:" : + map ("* " ++) stack ++ + [show inner] + + +-- | The verbosity data type, used by 'shakeVerbosity'. +data Verbosity + = Silent -- ^ Don't print any messages. + | Quiet -- ^ Only print essential messages (typically errors). + | Normal -- ^ Print normal messages (typically errors and warnings). + | Loud -- ^ Print lots of messages (typically errors, warnings and status updates). + | Diagnostic -- ^ Print messages for virtually everything (for debugging a build system). + deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data) + diff --git a/Development/Shake/Value.hs b/Development/Shake/Value.hs --- a/Development/Shake/Value.hs +++ b/Development/Shake/Value.hs @@ -76,12 +76,17 @@ witness = unsafePerformIO $ newIORef Map.empty registerWitness :: (Eq a, Show a, Typeable a, Hashable a, Binary a, NFData a) => a -> IO () -registerWitness x = modifyIORef witness $ Map.insert (typeOf x) (Value $ undefined `asTypeOf` x) +registerWitness x = atomicModifyIORef witness $ \mp -> (Map.insert (typeOf x) (Value $ error msg `asTypeOf` x) mp, ()) + where msg = "Development.Shake.Value.registerWitness, witness of type " ++ show (typeOf x) ++ " demanded" -toAscList :: Show k => Map.HashMap k v -> [(k,v)] -toAscList = sortBy (compare `on` show . fst) . Map.toList +-- Produce a list in a predictable order from a Map TypeRep, which should be consistent regardless of the order +-- elements were added and stable between program executions. +-- Cannot rely on hash (not pure in hashable-1.2) or compare (not available before 7.2) +toStableList :: Map.HashMap TypeRep v -> [(TypeRep,v)] +toStableList = sortBy (compare `on` show . fst) . Map.toList + data Witness = Witness {typeNames :: [String] -- the canonical data, the names of the types ,witnessIn :: Map.HashMap Word16 Value -- for reading in, the find the values (some may be missing) @@ -89,14 +94,14 @@ } instance Eq Witness where - -- type names are ordered by TypeRep values, so should to remain reasonably consistent - -- regardless of the order of registerWitness calls + -- Type names are produced by toStableList so should to remain consistent + -- regardless of the order of registerWitness calls. a == b = typeNames a == typeNames b currentWitness :: IO Witness currentWitness = do ws <- readIORef witness - let (ks,vs) = unzip $ toAscList ws + let (ks,vs) = unzip $ toStableList ws return $ Witness (map show ks) (Map.fromList $ zip [0..] vs) (Map.fromList $ zip ks [0..]) @@ -104,9 +109,14 @@ put (Witness ts _ _) = put ts get = do ts <- get - let ws = toAscList $ unsafePerformIO $ readIORef witness + let ws = toStableList $ unsafePerformIO $ readIORefAfter ts witness let (is,ks,vs) = unzip3 [(i,k,v) | (i,t) <- zip [0..] ts, (k,v):_ <- [filter ((==) t . show . fst) ws]] return $ Witness ts (Map.fromList $ zip is vs) (Map.fromList $ zip ks is) + where + -- Read an IORef after examining a variable, used to avoid GHC over-optimisation + {-# NOINLINE readIORefAfter #-} + readIORefAfter :: a -> IORef b -> IO b + readIORefAfter v ref = v `seq` readIORef ref instance BinaryWith Witness Value where diff --git a/Examples/Test/Assume.hs b/Examples/Test/Assume.hs new file mode 100644 --- /dev/null +++ b/Examples/Test/Assume.hs @@ -0,0 +1,49 @@ + +module Examples.Test.Assume(main) where + +import Development.Shake +import Examples.Util +import Control.Monad +import Development.Shake.FilePath + + +main = shaken test $ \args obj -> do + want $ map obj args + obj "*.out" *> \out -> do + cs <- mapM (readFile' . obj . (:".src")) $ takeBaseName out + writeFile' out $ concat cs + + +test build obj = do + let set file c = writeFile (obj $ file : ".src") [c] + let ask file c = do src <- readFile (obj $ file ++ ".out"); src === c + + forM_ ['a'..'f'] $ \c -> set c c + build ["abc.out"] + ask "abc" "abc" + + set 'b' 'd' + sleepFileTime + build ["abc.out"] + ask "abc" "adc" + set 'b' 'p' + sleepFileTime + build ["abc.out","--assume-clean"] + build ["abc.out"] + ask "abc" "adc" + set 'c' 'z' + sleepFileTime + build ["abc.out"] + ask "abc" "apz" + + build ["bc.out","c.out"] + ask "bc" "pz" + set 'b' 'r' + set 'c' 'n' + sleepFileTime + build ["abc.out","--assume-clean"] + ask "abc" "apz" + build ["ab.out","--assume-dirty"] + ask "ab" "ar" + build ["c.out"] + ask "c" "z" diff --git a/Examples/Test/Benchmark.hs b/Examples/Test/Benchmark.hs new file mode 100644 --- /dev/null +++ b/Examples/Test/Benchmark.hs @@ -0,0 +1,21 @@ + +module Examples.Test.Benchmark(main) where + +import Development.Shake +import Examples.Util +import Data.List +import Development.Shake.FilePath + + +-- | Given a breadth and depth come up with a set of build files +main = shaken (\_ _ -> return ()) $ \args obj -> do + let get ty = head $ [read $ drop (length ty + 1) a | a <- args, (ty ++ "=") `isPrefixOf` a] ++ + error ("Could not find argument, expected " ++ ty ++ "=Number") + depth = get "depth" + breadth = get "breadth" + + want [obj $ "0." ++ show i | i <- [1..breadth]] + obj "*" *> \out -> do + let d = read $ takeBaseName out + need [obj $ show (d + 1) ++ "." ++ show i | d < depth, i <- [1..breadth]] + writeFile' out "" diff --git a/Examples/Util.hs b/Examples/Util.hs --- a/Examples/Util.hs +++ b/Examples/Util.hs @@ -22,9 +22,10 @@ let out = "output/" ++ name ++ "/" createDirectoryIfMissing True out case args of - "test":_ -> do + "test":extra -> do putStrLn $ "## TESTING " ++ name - test (\args -> withArgs (name:args) $ shaken test rules) (out++) + -- if the extra arguments are not --quiet/--loud it's probably going to go wrong + test (\args -> withArgs (name:args ++ extra) $ shaken test rules) (out++) putStrLn $ "## FINISHED TESTING " ++ name "clean":_ -> removeDirectoryRecursive out {- @@ -47,16 +48,19 @@ args -> do (flags,args) <- return $ partition ("-" `isPrefixOf`) args - let f o x = let x2 = dropWhile (== '-') x in case lookup x2 flagList of + flags <- return $ map (dropWhile (== '-')) flags + let f o x = case lookup x flagList of Just op -> op o - Nothing | "threads" `isPrefixOf` x2 -> o{shakeThreads=read $ drop 7 x2} + Nothing | "threads" `isPrefixOf` x -> o{shakeThreads=read $ drop 7 x} + | x == "clean" -> o -- handled elsewhere | otherwise -> error $ "Don't know how to deal with flag: " ++ x + when ("clean" `elem` flags) $ removeDirectoryRecursive out let opts = foldl' f shakeOptions{shakeFiles=out, shakeReport=Just $ "output/" ++ name ++ "/report.html"} flags shake opts $ rules args (out++) flags :: [String] -flags = "threads#" : map fst flagList +flags = "threads#" : map fst flagList ++ ["clean"] flagList :: [(String, ShakeOptions -> ShakeOptions)] @@ -70,7 +74,19 @@ ,"staunch" * \o -> o{shakeStaunch=True} ,"deterministic" * \o -> o{shakeDeterministic=True} ,"lint" * \o -> o{shakeLint=True} + ,"stats" * \o -> o{shakeProgress=showProgress} + ,"assume-clean" * \o -> o{shakeAssume=Just AssumeClean} + ,"assume-dirty" * \o -> o{shakeAssume=Just AssumeDirty} ] + +showProgress s = forkIO loop >> return () + where loop = do + res <- s + when (isRunning res) $ do + let (s,c) = timeTodo res + putStrLn $ "PROGRESS: timeTodo = " ++ show (ceiling s) ++ "s (+ " ++ show c ++ " unknown)" + sleep 5 + loop unobj :: FilePath -> FilePath diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -7,7 +7,9 @@ import qualified Examples.Tar.Main as Tar import qualified Examples.Self.Main as Self import qualified Examples.C.Main as C +import qualified Examples.Test.Assume as Assume import qualified Examples.Test.Basic as Basic +import qualified Examples.Test.Benchmark as Benchmark import qualified Examples.Test.Directory as Directory import qualified Examples.Test.Errors as Errors import qualified Examples.Test.Files as Files @@ -26,7 +28,7 @@ ,"basic" * Basic.main, "directory" * Directory.main, "errors" * Errors.main ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main ,"journal" * Journal.main, "pool" * Pool.main, "random" * Random.main - ,"resources" * Resources.main] + ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main] where (*) = (,) @@ -54,4 +56,6 @@ test :: IO () -test = sequence_ [withArgs [name,"test"] main | (name,main) <- mains, name /= "random"] +test = do + args <- getArgs + sequence_ [withArgs (name:"test":drop 1 args) main | (name,main) <- mains, name /= "random"] diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,19 +1,23 @@ cabal-version: >= 1.8 build-type: Simple name: shake -version: 0.3.10 +version: 0.4 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2011-2012 +copyright: Neil Mitchell 2011-2013 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a - replacement for make. To use Shake the user writes a Haskell program + replacement for make. See "Development.Shake" for an introduction, + including an example. Further examples are included in the Cabal tarball, + under the @Examples@ directory. + . + To use Shake the user writes a Haskell program that imports the Shake library, defines some build rules, and calls - shake. Thanks to do notation and infix operators, a simple Shake program + 'shake'. Thanks to do notation and infix operators, a simple Shake program is not too dissimilar from a simple Makefile. However, as build systems get more complex, Shake is able to take advantage of the excellent abstraction facilities offered by Haskell and easily support much larger @@ -27,10 +31,11 @@ which files and take longest to build, and providing an analysis of the parallelism. . - The theory behind an old version of Shake is described in a video at - , and an example is given at the top of - "Development.Shake". Further examples are included in the Cabal tarball, - under the @Examples@ directory. + The theory behind Shake is described in an ICFP 2012 paper, + Shake Before Building -- Replacing Make with Haskell + . + The associated talk forms a short overview of Shake + . homepage: http://community.haskell.org/~ndm/shake/ stability: Beta extra-source-files: @@ -105,6 +110,7 @@ Development.Shake.Report Development.Shake.Rerun Development.Shake.Storage + Development.Shake.Types Development.Shake.Value Paths_shake @@ -140,7 +146,9 @@ Examples.C.Main Examples.Self.Main Examples.Tar.Main + Examples.Test.Assume Examples.Test.Basic + Examples.Test.Benchmark Examples.Test.Directory Examples.Test.Errors Examples.Test.FilePath