shake 0.2.5 → 0.2.6
raw patch · 10 files changed
+169/−36 lines, 10 files
Files
- Development/Shake.hs +4/−2
- Development/Shake/Core.hs +27/−7
- Development/Shake/File.hs +15/−15
- Development/Shake/Files.hs +6/−4
- Development/Shake/Locks.hs +76/−0
- Development/Shake/Oracle.hs +2/−2
- Development/Shake/Rerun.hs +4/−4
- Examples/Test/Resources.hs +31/−0
- Main.hs +2/−1
- shake.cabal +2/−1
Development/Shake.hs view
@@ -9,7 +9,7 @@ --main = 'shake' 'shakeOptions' $ do -- 'want' [\"result.tar\"] -- \"*.tar\" '*>' \\out -> do--- contents <- 'readFileLines' $ replaceExtension out \"txt\"+-- contents <- 'readFileLines' $ 'Development.Shake.FilePath.replaceExtension' out \"txt\" -- 'need' contents -- 'system'' \"tar\" $ [\"-cf\",out] ++ contents -- @@@ -76,7 +76,9 @@ doesFileExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs, -- * Additional rules addOracle, askOracle,- alwaysRerun+ alwaysRerun,+ -- * Finite resources+ Resource, newResource, withResource ) where -- I would love to use module export in the above export list, but alas Haddock
Development/Shake/Core.hs view
@@ -5,7 +5,8 @@ ShakeOptions(..), shakeOptions, run, Rule(..), Rules, defaultRule, rule, action, Action, apply, apply1, traced,- Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet+ Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet,+ Resource, newResource, withResource ) where import Prelude hiding (catch)@@ -22,7 +23,6 @@ import qualified Data.HashMap.Strict as Map import Data.Maybe import Data.Monoid-import Data.Typeable import Development.Shake.Pool import Development.Shake.Database@@ -36,7 +36,7 @@ -- | Options to control the execution of Shake, usually specified by overriding fields in -- 'shakeOptions': ----- @'shakeOptions'{'shakeThreads'=4, 'shakeDump'=True}@+-- @ 'shakeOptions'{'shakeThreads'=4, 'shakeDump'=True}@ 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@).@@ -71,7 +71,7 @@ [show inner] --- | The verbosity data type, specified in 'shakeVerbosity'.+-- | The verbosity data type, used by 'shakeVerbosity'. data Verbosity = Silent -- ^ Don't print any messages. | Quiet -- ^ Only print essential messages (typically errors).@@ -202,6 +202,7 @@ ,execute :: Key -> Action Value ,output :: String -> IO () ,verbosity :: Verbosity+ ,logger :: String -> IO () -- stack variables ,stack :: [Key] -- in reverse -- local variables@@ -243,7 +244,7 @@ let execute = createExecute rs withDatabase logger shakeFiles shakeVersion $ \database -> do runPool shakeThreads $ \pool -> do- let s0 = S database pool start stored execute output shakeVerbosity [] [] 0 []+ let s0 = S database pool start stored execute output shakeVerbosity logger [] [] 0 [] mapM_ (addPool pool . staunch . wrapStack [] . runAction s0) (actions rs) when shakeLint $ do checkValid database stored@@ -342,7 +343,7 @@ -- | Write an action to the trace list, along with the start/end time of running the IO action.--- The 'system'' command automatically calls 'traced'. The trace list is used for profile reports+-- The 'Develoment.Shake.system'' command automatically calls 'traced'. The trace list is used for profile reports -- (see 'shakeDump'). traced :: String -> IO a -> Action a traced msg act = Action $ do@@ -361,7 +362,7 @@ liftIO $ output s msg --- | Write a message to the output when the verbosity is appropriate.+-- | Write a message to the output when the verbosity ('shakeVerbosity') is appropriate. -- The output will not be interleaved with any other Shake messages -- (other than those generated by system commands). putLoud, putNormal, putQuiet :: String -> Action ()@@ -376,3 +377,22 @@ -- not interleaved. getVerbosity :: Action Verbosity getVerbosity = Action $ gets verbosity+++-- | Run an action which uses part of a finite resource. For an example see 'Resource'.+withResource :: Resource -> Int -> Action a -> Action a+withResource r i act = Action $ do+ s <- get+ (res,s) <- liftIO $ bracket_+ (do res <- acquireResource r i+ case res of+ Nothing -> logger s $ show r ++ " acquired " ++ show i ++ " with no wait"+ Just wait -> do+ logger s $ show r ++ " waiting to acquire " ++ show i+ blockPool (pool s) wait+ logger s $ show r ++ " acquired " ++ show i ++ " after waiting")+ (do releaseResource r i+ logger s $ show r ++ " released " ++ show i)+ (runAction s act)+ put s+ return res
Development/Shake/File.hs view
@@ -92,13 +92,13 @@ -- | Require that the following files are built before continuing. Particularly--- necessary when calling 'system''. As an example:+-- necessary when calling 'Development.Shake.system''. As an example: -- -- @--- \"//*.rot13\" '*>' \out -> do--- let src = dropExtension out--- 'need' [src]--- 'system'' [\"rot13\",src,\"-o\",out]+-- \"//*.rot13\" '*>' \\out -> do+-- let src = 'Development.Shake.FilePath.dropExtension' out+-- 'need' [src]+-- 'Development.Shake.system'' [\"rot13\",src,\"-o\",out] -- @ need :: [FilePath] -> Action () need xs = (apply $ map File xs :: Action [FileTime]) >> return ()@@ -106,9 +106,9 @@ -- | Require that the following are built by the rules, used to specify the target. -- -- @--- main = 'shake' 'shakeOptions' $ do--- 'want' [\"Main.exe\"]--- ...+-- main = 'Development.Shake.shake' 'shakeOptions' $ do+-- 'want' [\"Main.exe\"]+-- ... -- @ -- -- This program will build @Main.exe@, given sufficient rules.@@ -121,9 +121,9 @@ -- additional power. For any file used by the build system, only one rule should return 'True'. -- -- @--- (all isUpper . takeBaseName) '*>' \out -> do--- let src = replaceBaseName out $ map toLower $ takeBaseName out--- 'writeFile'' . map toUpper =<< 'readFile'' src+-- (all isUpper . 'Development.Shake.FilePath.takeBaseName') '?>' \\out -> do+-- let src = 'Development.Shake.FilePath.replaceBaseName' out $ map toLower $ takeBaseName out+-- 'Development.Shake.writeFile'' . map toUpper =<< 'Development.Shake.readFile'' src -- @ (?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules () (?>) test act = rule $ \(File x) ->@@ -141,10 +141,10 @@ -- matched by more than one pattern. For the pattern rules, see '?=='. -- -- @--- \"*.asm.o\" '*>' \out -> do--- let src = dropExtension out--- 'need' [src]--- 'system'' [\"as\",src,\"-o\",out]+-- \"*.asm.o\" '*>' \\out -> do+-- let src = 'Development.Shake.FilePath.dropExtension' out+-- 'need' [src]+-- 'Development.Shake.system'' [\"as\",src,\"-o\",out] -- @ -- -- To define a build system for multiple compiled languages, we recommend using @.asm.o@,
Development/Shake/Files.hs view
@@ -35,10 +35,12 @@ -- | Define a rule for building multiple files at the same time. -- As an example, a single invokation of GHC produces both @.hi@ and @.o@ files: ----- > ["*.o","*.hi"] *>> \[o,hi] -> do--- > let hs = replaceExtension o "hs"--- > need ... -- all files the .hs import--- > system' "ghc" ["-c",hs]+-- @+-- [\"*.o\",\"*.hi\"] '*>>' \\[o,hi] -> do+-- let hs = 'Development.Shake.FilePath.replaceExtension' o \"hs\"+-- 'Development.Shake.need' ... -- all files the .hs import+-- 'Development.Shake.system'' \"ghc\" [\"-c\",hs]+-- @ -- -- However, in practice, it's usually easier to define rules with '*>' and make the @.hi@ depend -- on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must
Development/Shake/Locks.hs view
@@ -3,9 +3,11 @@ Lock, newLock, withLock, Var, newVar, readVar, modifyVar, modifyVar_, Barrier, newBarrier, signalBarrier, waitBarrier,+ Resource, newResource, acquireResource, releaseResource ) where import Control.Concurrent+import Control.Monad ---------------------------------------------------------------------@@ -57,3 +59,77 @@ waitBarrier :: Barrier a -> IO a waitBarrier (Barrier x) = readMVar x+++---------------------------------------------------------------------+-- RESOURCE++-- | The type representing a finite resource, which multiple build actions should respect.+-- Created with 'newResource' in the 'IO' monad before calling 'Development.Shake.shake',+-- and used with 'Development.Shake.withResource' in the 'Development.Shake.Action' monad+-- when defining rules.+--+-- As an example, only one set of calls to the Excel API can occur at one time, therefore+-- Excel is a finite resource of quantity 1. You can write:+--+-- @+-- do excel <- 'newResource' \"Excel\" 1+-- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=2} $ do+-- 'Development.Shake.want' [\"a.xls\",\"b.xls\"]+-- \"*.xls\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.withResource' excel 1 $+-- 'Development.Shake.system'' \"excel\" [out,...]+-- @+--+-- Now the two calls to @excel@ will not happen in parallel. Using 'Resource'+-- is better than 'MVar' as it will not block any other threads from executing.+--+-- As another example, calls to compilers are usually CPU bound but calls to linkers are usually+-- disk bound. Running 8 linkers will often cause an 8 CPU system to grid to a halt. We can limit+-- ourselves to 4 linkers with:+--+-- @+-- do disk <- 'newResource' \"Disk\" 4+-- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=8} $ do+-- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]+-- \"*.exe\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.withResource' disk 1 $+-- 'Development.Shake.system'' \"ld\" [\"-o\",out,...]+-- \"*.o\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.system'' \"cl\" [\"-o\",out,...]+-- @+data Resource = Resource String Int (Var (Int,[(Int,IO ())]))+instance Show Resource where show (Resource name _ _) = "Resource " ++ name+++-- | Create a new finite resource, given a name (for error messages) and a quantity of the resource that exists.+-- For an example see 'Resource'.+newResource :: String -> Int -> IO Resource+newResource name mx = do+ when (mx < 0) $+ error $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx+ var <- newVar (mx, [])+ return $ Resource name mx var+++-- | Try to acquire a resource. Returns Nothing to indicate you have acquired with no blocking, or Just act to+-- say after act completes (which will block) then you will have the resource.+acquireResource :: Resource -> Int -> IO (Maybe (IO ()))+acquireResource r@(Resource name mx var) want+ | want < 0 = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show want+ | want > mx = error $ "You cannot acquire more than " ++ show mx ++ " of " ++ show r ++ ", requested " ++ show want+ | otherwise = modifyVar var $ \(available,waiting) ->+ if want <= available then+ return ((available - want, waiting), Nothing)+ else do+ bar <- newBarrier+ return ((available, waiting ++ [(want,signalBarrier bar ())]), Just $ waitBarrier bar)+++-- | You should only ever releaseResource that you obtained with acquireResource.+releaseResource :: Resource -> Int -> IO ()+releaseResource (Resource name mx var) i = modifyVar_ var $ \(available,waiting) -> f (available+i) waiting+ where+ f i ((wi,wa):ws) | wi <= i = wa >> f (i-wi) ws+ | otherwise = do (i,ws) <- f i ws; return (i,(wi,wa):ws)+ f i [] = return (i, [])
Development/Shake/Oracle.hs view
@@ -29,7 +29,7 @@ -- > addOracle ["ghc"] $ return ["7.2.1"] -- > addOracle ["ghc-pkg","shake"] $ return ["1.0"] ----- If a rule depends on the GHC version, it can then use @'getOracle' [\"ghc\"]@, and+-- If a rule depends on the GHC version, it can then use @'askOracle' [\"ghc\"]@, and -- if the GHC version changes, the rule will rebuild. It is common for the value returned -- by 'askOracle' to be ignored. --@@ -41,7 +41,7 @@ -- -- Actions passed to 'addOracle' will be run in every Shake execution they are required, -- their value will not be kept between runs. To get a similar behaviour using files, see--- 'alwaysRerun'.+-- 'Development.Shake.alwaysRerun'. addOracle :: [String] -> Action [String] -> Rules () addOracle question act = rule $ \(Question q) -> if q == question then Just $ fmap Answer act else Nothing
Development/Shake/Rerun.hs view
@@ -29,10 +29,10 @@ -- the environment. For example: -- -- @--- \"ghcVersion.txt\" '*>' \out -> do--- 'alwaysRerun'--- (stdout,_) <- 'systemOutput' \"ghc\" [\"--version\"]--- 'writeFileChanged' out stdout+-- \"ghcVersion.txt\" 'Development.Shake.*>' \\out -> do+-- 'alwaysRerun'+-- (stdout,_) <- 'Development.Shake.systemOutput' \"ghc\" [\"--version\"]+-- 'Development.Shake.writeFileChanged' out stdout -- @ alwaysRerun :: Action () alwaysRerun = do Dirty _ <- apply1 $ AlwaysRerun (); return ()
+ Examples/Test/Resources.hs view
@@ -0,0 +1,31 @@++module Examples.Test.Resources(main) where++import Development.Shake+import Examples.Util+import Control.Monad+import Data.IORef+++main = do+ let cap = 2++ ref <- newIORef 0+ res <- newResource "test" cap+ shaken test $ \args obj -> do+ want $ map obj ["file1.txt","file2.txt","file3.txt","file4.txt"]+ obj "*.txt" *> \out ->+ withResource res 1 $ do+ old <- liftIO $ atomicModifyIORef ref $ \i -> (i+1,i)+ when (old >= cap) $ error "Too many resources in use at one time"+ liftIO $ sleep 0.1+ liftIO $ atomicModifyIORef ref $ \i -> (i-1,i)+ writeFile' out ""++test build obj = do+ build ["clean"]+ build ["--threads2"]+ build ["clean"]+ build ["--threads4"]+ build ["clean"]+ build ["--threads10"]
Main.hs view
@@ -14,6 +14,7 @@ import qualified Examples.Test.Files as Files import qualified Examples.Test.FilePath as FilePath import qualified Examples.Test.Pool as Pool+import qualified Examples.Test.Resources as Resources fakes = ["clean" * clean, "test" * test]@@ -21,7 +22,7 @@ mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main ,"basic1" * Basic1.main, "directory" * Directory.main, "errors" * Errors.main- ,"filepath" * FilePath.main, "files" * Files.main, "pool" * Pool.main]+ ,"filepath" * FilePath.main, "files" * Files.main, "pool" * Pool.main, "resources" * Resources.main] where (*) = (,)
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: shake-version: 0.2.5+version: 0.2.6 license: BSD3 license-file: LICENSE category: Development@@ -102,3 +102,4 @@ Examples.Test.FilePath Examples.Test.Files Examples.Test.Pool+ Examples.Test.Resources