shake 0.3.10 → 0.4
raw patch · 18 files changed
+479/−149 lines, 18 files
Files
- Development/Shake.hs +3/−2
- Development/Shake/Core.hs +62/−95
- Development/Shake/Database.hs +35/−9
- Development/Shake/Directory.hs +2/−2
- Development/Shake/File.hs +1/−1
- Development/Shake/Files.hs +4/−4
- Development/Shake/Locks.hs +4/−1
- Development/Shake/Oracle.hs +1/−1
- Development/Shake/Pool.hs +5/−5
- Development/Shake/Rerun.hs +1/−1
- Development/Shake/Storage.hs +40/−6
- Development/Shake/Types.hs +191/−0
- Development/Shake/Value.hs +17/−7
- Examples/Test/Assume.hs +49/−0
- Examples/Test/Benchmark.hs +21/−0
- Examples/Util.hs +21/−5
- Main.hs +6/−2
- shake.cabal +16/−8
Development/Shake.hs view
@@ -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
Development/Shake/Core.hs view
@@ -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
Development/Shake/Database.hs view
@@ -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{..}
Development/Shake/Directory.hs view
@@ -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
Development/Shake/File.hs view
@@ -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
Development/Shake/Files.hs view
@@ -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.
Development/Shake/Locks.hs view
@@ -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 ---------------------------------------------------------------------
Development/Shake/Oracle.hs view
@@ -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:
Development/Shake/Pool.hs view
@@ -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 ())) }
Development/Shake/Rerun.hs view
@@ -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
Development/Shake/Storage.hs view
@@ -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
+ Development/Shake/Types.hs view
@@ -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 _ = "<function>"++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)+
Development/Shake/Value.hs view
@@ -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
+ Examples/Test/Assume.hs view
@@ -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"
+ Examples/Test/Benchmark.hs view
@@ -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 ""
Examples/Util.hs view
@@ -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
Main.hs view
@@ -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"]
shake.cabal view
@@ -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 <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-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- <http://vimeo.com/15465133>, 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+ <http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf>.+ The associated talk forms a short overview of Shake+ <http://www.youtube.com/watch?v=xYCPpXVlqFM>. 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