shake 0.10.6 → 0.10.7
raw patch · 41 files changed
+1097/−483 lines, 41 filesdep +utf8-stringdep ~processdep ~unixdep ~unordered-containers
Dependencies added: utf8-string
Dependency ranges changed: process, unix, unordered-containers
Files
- Development/Make/Rules.hs +8/−8
- Development/Ninja/All.hs +15/−4
- Development/Ninja/Parse.hs +12/−7
- Development/Shake.hs +31/−8
- Development/Shake/Args.hs +6/−2
- Development/Shake/Command.hs +16/−9
- Development/Shake/Core.hs +129/−22
- Development/Shake/Database.hs +27/−48
- Development/Shake/Directory.hs +13/−10
- Development/Shake/Errors.hs +27/−17
- Development/Shake/File.hs +29/−16
- Development/Shake/FilePattern.hs +5/−3
- Development/Shake/FileTime.hs +55/−45
- Development/Shake/Files.hs +20/−12
- Development/Shake/Intern.hs +2/−1
- Development/Shake/Locks.hs +0/−156
- Development/Shake/Oracle.hs +1/−1
- Development/Shake/Pool.hs +13/−8
- Development/Shake/Progress.hs +52/−21
- Development/Shake/Rerun.hs +3/−3
- Development/Shake/Resource.hs +169/−0
- Development/Shake/Special.hs +2/−3
- Development/Shake/Storage.hs +14/−9
- Development/Shake/Types.hs +3/−30
- Development/Shake/Util.hs +209/−0
- Examples/Ninja/Main.hs +7/−0
- Examples/Ninja/test4.ninja +9/−0
- Examples/Ninja/test5.ninja +5/−0
- Examples/Self/Main.hs +3/−3
- Examples/Test/Basic.hs +21/−0
- Examples/Test/Command.hs +6/−0
- Examples/Test/Docs.hs +10/−4
- Examples/Test/Errors.hs +7/−0
- Examples/Test/Files.hs +14/−6
- Examples/Test/Lint.hs +11/−3
- Examples/Test/Progress.hs +10/−2
- Examples/Test/Throttle.hs +34/−0
- Examples/Test/Unicode.hs +55/−0
- Examples/Util.hs +17/−6
- Test.hs +9/−4
- shake.cabal +18/−12
Development/Make/Rules.hs view
@@ -11,7 +11,7 @@ import System.Directory import Development.Shake.Core-import Development.Shake.Types+import Development.Shake.Util import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.FileTime@@ -24,25 +24,25 @@ -- Which matches the (insane) semantics of make -- If a file is not produced, it will rebuild forever -newtype File_Q = File_Q BS+newtype File_Q = File_Q BSU deriving (Typeable,Eq,Hashable,Binary,NFData) -instance Show File_Q where show (File_Q x) = unpack x+instance Show File_Q where show (File_Q x) = unpackU x newtype File_A = File_A (Maybe FileTime) deriving (Typeable,Eq,Hashable,Binary,Show,NFData) instance Rule File_Q File_A where- storedValue (File_Q x) = fmap (fmap (File_A . Just)) $ getModTimeMaybe $ unpack_ x+ storedValue (File_Q x) = fmap (fmap (File_A . Just)) $ getModTimeMaybe x defaultRuleFile_ :: Rules () defaultRuleFile_ = defaultRule $ \(File_Q x) -> Just $- liftIO $ fmap (File_A . Just) $ getModTimeError "Error, file does not exist and no rule available:" $ unpack_ x+ liftIO $ fmap (File_A . Just) $ getModTimeError "Error, file does not exist and no rule available:" x need_ :: [FilePath] -> Action ()-need_ xs = (apply $ map (File_Q . pack) xs :: Action [File_A]) >> return ()+need_ xs = (apply $ map (File_Q . packU) xs :: Action [File_A]) >> return () want_ :: [FilePath] -> Rules () want_ = action . need_@@ -50,10 +50,10 @@ data Phony = Phony | NotPhony deriving Eq (??>) :: (FilePath -> Bool) -> (FilePath -> Action Phony) -> Rules ()-(??>) test act = rule $ \(File_Q x_) -> let x = unpack x_ in+(??>) test act = rule $ \(File_Q x_) -> let x = unpackU x_ in if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x res <- act x liftIO $ fmap File_A $ if res == Phony then return Nothing- else getModTimeMaybe $ unpack_ x_+ else getModTimeMaybe x_
Development/Ninja/All.hs view
@@ -12,6 +12,7 @@ import System.Directory import qualified Data.HashMap.Strict as Map +import Control.Arrow import Control.Monad import Data.List import Data.Char @@ -23,8 +24,8 @@ ninja@Ninja{..} <- parse file return $ do phonys <- return $ Map.fromList phonys - singles <- return $ Map.fromList singles - multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- multiples, x <- xs] + singles <- return $ Map.fromList $ map (first norm) singles + multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map norm) multiples, x <- xs] rules <- return $ Map.fromList rules pools <- fmap Map.fromList $ forM pools $ \(name,depth) -> fmap ((,) name) $ newResource (BS.unpack name) depth @@ -41,6 +42,11 @@ build phonys rules pools [out2] $ singles Map.! out2 +-- Normalise the LHS of build rules, so that normalised RHS still match +norm :: Str -> Str +norm = BS.pack . normalise . BS.unpack + + resolvePhony :: Map.HashMap Str [Str] -> Str -> [Str] resolvePhony mp = f $ Left 100 where @@ -51,6 +57,11 @@ Just xs -> concatMap (f $ either (Left . subtract 1) (Right . (x:)) a) xs +quote :: Str -> Str +quote x | BS.any isSpace x = let q = BS.singleton '\"' in BS.concat [q,x,q] + | otherwise = x + + build :: Map.HashMap Str [Str] -> Map.HashMap Str Rule -> Map.HashMap Str Resource -> [Str] -> Build -> Action () build phonys rules pools out Build{..} = do need $ map (normalise . BS.unpack) $ concatMap (resolvePhony phonys) $ depsNormal ++ depsImplicit ++ depsOrderOnly @@ -60,8 +71,8 @@ env <- liftIO $ scopeEnv env liftIO $ do -- the order of adding new environment variables matters - addEnv env (BS.pack "out") (BS.unwords out) - addEnv env (BS.pack "in") (BS.unwords depsNormal) + addEnv env (BS.pack "out") (BS.unwords $ map quote out) + addEnv env (BS.pack "in") (BS.unwords $ map quote depsNormal) addEnv env (BS.pack "in_newline") (BS.unlines depsNormal) addBinds env buildBind addBinds env ruleBind
Development/Ninja/Parse.hs view
@@ -20,14 +20,18 @@ startsSpace :: Str -> Bool startsSpace = BS.isPrefixOf (BS.pack " ") +-- | This is a hot-spot, so optimised linesCR :: Str -> [Str] -linesCR x | BS.null x = [] - | otherwise = case BS.elemIndex '\n' x of - Nothing -> [x] - Just i | i >= 1 && BS.index x (i-1) == '\r' -> BS.take (i-1) x : linesCR (BS.drop (i+1) x) - | otherwise -> BS.take i x : linesCR (BS.drop (i+1) x) +linesCR x = case BS.split '\n' x of + x:xs | Just ('\r',x) <- unsnoc x -> x : map (\x -> case unsnoc x of Just ('\r',x) -> x; _ -> x) xs + xs -> xs + where + -- the ByteString unsnoc was introduced in a newer version + unsnoc x | BS.null x = Nothing + | otherwise = Just (BS.last x, BS.init x) + word1 :: Str -> (Str, Str) word1 x = (a, dropSpace b) where (a,b) = BS.break isSpace x @@ -122,8 +126,9 @@ exprs [x] = x exprs xs = Exprs xs - f x = Lit a : g (BS.drop 1 b) - where (a,b) = BS.break (== '$') x + f x = case BS.elemIndex '$' x of + Nothing -> [Lit x] + Just i -> Lit (BS.take i x) : g (BS.drop (i+1) x) g x = case BS.uncons x of Nothing -> []
Development/Shake.hs view
@@ -28,6 +28,12 @@ -- Finally we call the @tar@ program. If either @result.txt@ changes, or any of the files listed by @result.txt@ -- change, then @result.tar@ will be rebuilt. --+-- 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>.+--+-- /== WRITING A BUILD SYSTEM ==============================/+-- -- When writing a Shake build system, start by defining what you 'want', then write rules -- with '*>' to produce the results. Before calling 'cmd' you should ensure that any files the command -- requires are demanded with calls to 'need'. We offer the following advice to Shake users:@@ -40,8 +46,7 @@ -- * Put all result files in a distinguished directory, for example @_make@. You can implement a @clean@ -- command by removing that directory, using @'removeFilesAfter' \"_make\" [\"\/\/\*\"]@. ----- * To obtain parallel builds set 'shakeThreads' to a number greater than 1. You may also need to--- compile with @-threaded@.+-- * To obtain parallel builds set 'shakeThreads' to a number greater than 1. -- -- * Lots of compilers produce @.o@ files. To avoid overlapping rules, use @.c.o@ for C compilers, -- @.hs.o@ for Haskell compilers etc.@@ -54,10 +59,26 @@ -- that you suspect will change regularly (perhaps @ghc@ version number), either write the information to -- a file with 'alwaysRerun' and 'writeFileChanged', or use 'addOracle'. ----- 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>.+-- /== GHC BUILD FLAGS ==============================/ --+-- For large build systems the choice of GHC flags can have a significant impact. We recommend:+--+-- > ghc --make MyBuildSystem -rtsopts "-with-rtsopts=-I0 -qg -qb"+--+-- * Compile without @-threaded@: In GHC 7.6 and earlier bug 7646 <http://ghc.haskell.org/trac/ghc/ticket/7646>+-- can cause a race condition in build systems that write files then read them. Omitting @-threaded@ will+-- still allow your 'cmd' actions to run in parallel, so most build systems will still run in parallel.+--+-- * Compile with @-rtsopts@: Allow the setting of further GHC options at runtime.+--+-- * Run with @-I0@: Disable idle garbage collection. In a build system regularly running many system+-- commands the program appears \"idle\" very often, triggering regular unnecessary garbage collection, stealing+-- resources from the program doing actual work.+--+-- * Run with @-qg -qb@: Disable parallel garbage collection. Parallel garbage collection in Shake+-- programs typically goes slower than sequential garbage collection, while occupying many cores that+-- can be used for running system commands.+-- -- /Acknowledgements/: Thanks to Austin Seipp for properly integrating the profiling code. module Development.Shake( -- * Core@@ -75,7 +96,7 @@ -- ** Command line shakeArgs, shakeArgsWith, shakeOptDescrs, -- ** Progress reporting- Progress(..), progressSimple, progressDisplay, progressTitlebar,+ Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram, -- ** Verbosity Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, quietly, -- * Running commands@@ -86,7 +107,7 @@ module Development.Shake.Derived, removeFiles, removeFilesAfter, -- * File rules- need, want, (*>), (**>), (?>), phony,+ need, want, (*>), (**>), (?>), phony, (~>), module Development.Shake.Files, FilePattern, (?==), -- * Directory rules@@ -97,8 +118,10 @@ addOracle, askOracle, askOracleWith, -- * Special rules alwaysRerun,- -- * Finite resources+ -- * Resources Resource, newResource, newResourceIO, withResource, withResources,+ newThrottle, newThrottleIO,+ unsafeExtraThread, -- * Cached file contents newCache, newCacheIO ) where
Development/Shake/Args.hs view
@@ -112,7 +112,7 @@ assumeOld = [x | AssumeOld x <- flagsExtra] changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra] printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra]- shakeOpts = foldl (flip ($)) baseOpts flagsShake+ shakeOpts = foldl' (flip ($)) baseOpts flagsShake -- error if you pass some clean and some dirty with specific flags errs <- return $ errs ++ flagsError ++ ["cannot mix " ++ a ++ " and " ++ b | a:b:_ <-@@ -248,7 +248,7 @@ ,no $ Option "" ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building." ,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k." ,yes $ Option "" ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log."- ,yes $ Option "p" ["progress"] (optIntArg "progress" "N" (\i s -> s{shakeProgress=progressDisplay (fromMaybe 5 i) progressTitlebar})) "Show progress messages [every N seconds, default 5]."+ ,yes $ Option "p" ["progress"] (optIntArg "progress" "N" (\i s -> s{shakeProgress=prog $ fromMaybe 5 i})) "Show progress messages [every N seconds, default 5]." ,yes $ Option " " ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages." ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much." ,no $ Option "" ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time."@@ -286,3 +286,7 @@ appendFile file $ unescape msg outputColor output v msg = output v $ escape "34" msg++ prog i p = do+ program <- progressProgram+ progressDisplay i (\s -> progressTitlebar s >> program s) p
Development/Shake/Command.hs view
@@ -75,22 +75,26 @@ bin inh; bin outh; bin errh -- fork off a thread to start consuming stdout- (out,waitOut) <- case outh of- Nothing -> return ("", return ())+ (out,waitOut,waitOutEcho) <- case outh of+ Nothing -> return ("", return (), return ()) Just outh -> do out <- hGetContents outh waitOut <- forkWait $ C.evaluate $ rnf out- when stdoutEcho $ forkIO (hPutStr stdout out) >> return ()- return (out,waitOut)+ waitOutEcho <- if stdoutEcho+ then forkWait (hPutStr stdout out)+ else return (return ())+ return (out,waitOut,waitOutEcho) -- fork off a thread to start consuming stderr- (err,waitErr) <- case errh of- Nothing -> return ("", return ())+ (err,waitErr,waitErrEcho) <- case errh of+ Nothing -> return ("", return (), return ()) Just errh -> do err <- hGetContents errh waitErr <- forkWait $ C.evaluate $ rnf err- when stderrEcho $ forkIO (hPutStr stderr err) >> return ()- return (err,waitErr)+ waitErrEcho <- if stderrEcho+ then forkWait (hPutStr stderr err)+ else return (return ())+ return (err,waitErr,waitErrEcho) -- now write and flush any input let writeInput = do@@ -111,6 +115,9 @@ waitOut waitErr + waitOutEcho+ waitErrEcho+ close outh close errh @@ -217,7 +224,7 @@ cmdResult = ([], \[] -> ()) instance (CmdResult x1, CmdResult x2) => CmdResult (x1,x2) where- cmdResult = (a1++a2, \rs -> let (r1,r2) = splitAt (length a2) rs in (b1 r1, b2 r2))+ cmdResult = (a1++a2, \rs -> let (r1,r2) = splitAt (length a1) rs in (b1 r1, b2 r2)) where (a1,b1) = cmdResult (a2,b2) = cmdResult
Development/Shake/Core.hs view
@@ -14,7 +14,8 @@ Rule(..), Rules, defaultRule, rule, action, withoutActions, Action, actionOnException, actionFinally, apply, apply1, traced, getVerbosity, putLoud, putNormal, putQuiet, quietly,- Resource, newResource, newResourceIO, withResource, withResources,+ Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO,+ unsafeExtraThread, -- Internal stuff rulesIO, runAfter ) where@@ -39,12 +40,13 @@ import Development.Shake.Classes import Development.Shake.Pool import Development.Shake.Database-import Development.Shake.Locks+import Development.Shake.Resource import Development.Shake.Value import Development.Shake.Report import Development.Shake.Types import Development.Shake.Errors import Development.Shake.Timing+import Development.Shake.Util ---------------------------------------------------------------------@@ -178,6 +180,20 @@ -- | Run an action, usually used for specifying top-level requirements.+--+-- @+-- main = 'Development.Shake.shake' 'shakeOptions' $ do+-- 'action' $ do+-- b <- 'Development.Shake.doesFileExist' \"file.src\"+-- when b $ 'Development.Shake.need' [\"file.out\"]+-- @+--+-- This 'action' builds @file.out@, but only if @file.src@ exists. The 'action'+-- will be run in every build execution (unless 'withoutActions' is used), so only cheap+-- operations should be performed.+--+-- For the standard requirement of only 'Development.Shake.need'ing a fixed list of files in the 'action',+-- see 'Development.Shake.want'. action :: Action a -> Rules () action a = newRules mempty{actions=[a >> return ()]} @@ -214,6 +230,7 @@ ,depends :: [Depends] -- built up in reverse ,discount :: !Duration ,traces :: [Trace] -- in reverse+ ,blockapply :: Maybe String -- reason to block apply, or Nothing to allow } -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files.@@ -242,7 +259,7 @@ -- | Internal main function (not exported publicly) run :: ShakeOptions -> Rules () -> IO () run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id) $ do- start <- startTime+ start <- offsetTime rs <- getRules rs registerWitnesses rs @@ -269,27 +286,33 @@ dir <- getCurrentDirectory return $ \msg -> do now <- getCurrentDirectory- when (dir /= now) $ error $- "Lint checking failed, current directory has changed\n" ++- "When: " ++ msg ++ "\n" ++- "Wanted: " ++ dir ++ "\n" ++- "Got: " ++ now+ when (dir /= now) $ errorStructured+ "Lint checking error - current directory has changed"+ [("When", Just msg)+ ,("Wanted",Just dir)+ ,("Got",Just now)]+ "" - let ruleinfo = createRuleinfo rs- running <- newIORef True+ progressThread <- newIORef Nothing after <- newIORef []- flip finally (writeIORef running False >> if shakeTimings then printTimings else resetTimings) $+ let cleanup = do+ flip whenJust killThread =<< readIORef progressThread+ when shakeTimings printTimings+ resetTimings -- so we don't leak memory+ flip finally cleanup $ withCapabilities shakeThreads $ do withDatabase opts diagnostic $ \database -> do- forkIO $ shakeProgress $ do- running <- readIORef running+ tid <- forkIO $ shakeProgress $ do failure <- fmap (fmap fst) $ readIORef except stats <- progress database- return stats{isRunning=running, isFailure=failure}+ return stats{isFailure=failure}+ writeIORef progressThread $ Just tid+ let ruleinfo = createRuleinfo rs addTiming "Running rules" runPool (shakeThreads == 1) shakeThreads $ \pool -> do- let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 []+ let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 [] Nothing mapM_ (addPool pool . staunch . runAction s0) (actions rs)+ when shakeLint $ do addTiming "Lint checking" checkValid database (runStored ruleinfo)@@ -396,9 +419,11 @@ -- We don't want the forall in the Haddock docs f :: forall key value . Rule key value => [key] -> Action [value] f ks = do- ruleinfo <- Action $ State.gets ruleinfo let tk = typeOf (err "apply key" :: key) tv = typeOf (err "apply type" :: value)+ ruleinfo <- Action $ State.gets ruleinfo+ block <- Action $ State.gets blockapply+ whenJust block $ errorNoApply tk (fmap show $ listToMaybe ks) case Map.lookup tk ruleinfo of Nothing -> errorNoRuleToBuildType tk (fmap show $ listToMaybe ks) (Just tv) Just RuleInfo{resultType=tv2} | tv /= tv2 -> errorRuleTypeMismatch tk (fmap show $ listToMaybe ks) tv2 tv@@ -411,11 +436,12 @@ let exec stack k = try $ wrapStack (showStack (database s) stack) $ do evaluate $ rnf k let s2 = s{depends=[], stack=stack, discount=0, traces=[]}- lint s "before building"+ let top = topStack stack+ lint s $ "before building " ++ top (dur,(res,s2)) <- duration $ runAction s2 $ do putWhen Chatty $ "# " ++ show k runExecute (ruleinfo s) k- lint s "after building"+ lint s $ "after building " ++ top let ans = (res, reverse $ depends s2, dur - discount s2, reverse $ traces s2) evaluate $ rnf ans return ans@@ -486,13 +512,83 @@ quietly = withVerbosity Quiet --- | Create a new finite resource, given a name (for error messages) and a quantity of the resource that exists.--- For an example see 'Resource'.+-- | Create a finite resource, given a name (for error messages) and a quantity of the resource that exists.+-- Shake will ensure that actions using the same finite resource do not execute in parallel.+-- 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:+--+-- @+-- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=2} $ do+-- 'Development.Shake.want' [\"a.xls\",\"b.xls\"]+-- excel <- 'Development.Shake.newResource' \"Excel\" 1+-- \"*.xls\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.withResource' excel 1 $+-- 'Development.Shake.cmd' \"excel\" out ...+-- @+--+-- Now the two calls to @excel@ will not happen in parallel.+--+-- 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:+--+-- @+-- disk <- 'Development.Shake.newResource' \"Disk\" 4+-- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]+-- \"*.exe\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.withResource' disk 1 $+-- 'Development.Shake.cmd' \"ld -o\" [out] ...+-- \"*.o\" 'Development.Shake.*>' \\out ->+-- 'Development.Shake.cmd' \"cl -o\" [out] ...+-- @ newResource :: String -> Int -> Rules Resource newResource name mx = rulesIO $ newResourceIO name mx --- | Run an action which uses part of a finite resource. For an example see 'Resource'.+-- | Create a throttled resource, given a name (for error messages) and a number of resources (the 'Int') that can be+-- used per time period (the 'Double' in seconds). Shake will ensure that actions using the same throttled resource+-- do not exceed the limits. As an example, let us assume that making more than 1 request every 5 seconds to+-- Google results in our client being blacklisted, we can write:+--+-- @+-- google <- 'Development.Shake.newThrottle' \"Google\" 1 5+-- \"*.url\" 'Development.Shake.*>' \\out -> do+-- 'Development.Shake.withResource' google 1 $+-- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]+-- @+--+-- Now we will wait at least 5 seconds after querying Google before performing another query. If Google change the rules to+-- allow 12 requests per minute we can instead use @'Development.Shake.newThrottle' \"Google\" 12 60@, which would allow+-- greater parallelisation, and avoid throttling entirely if only a small number of requests are necessary.+--+-- In the original example we never make a fresh request until 5 seconds after the previous request has /completed/. If we instead+-- want to throttle requests since the previous request /started/ we can write:+--+-- @+-- google <- 'Development.Shake.newThrottle' \"Google\" 1 5+-- \"*.url\" 'Development.Shake.*>' \\out -> do+-- 'Development.Shake.withResource' google 1 $ return ()+-- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]+-- @+--+-- However, the rule may not continue running immediately after 'Development.Shake.withResource' completes, so while+-- we will never exceed an average of 1 request every 5 seconds, we may end up running an unbounded number of+-- requests simultaneously. If this limitation causes a problem in practice it can be fixed.+newThrottle :: String -> Int -> Double -> Rules Resource+newThrottle name count period = rulesIO $ newThrottleIO name count period+++blockApply :: String -> Action a -> Action a+blockApply msg act = do+ s0 <- Action State.get+ Action $ State.put s0{blockapply=Just msg}+ res <- act+ Action $ State.modify $ \s -> s{blockapply=blockapply s0}+ return res+++-- | Run an action which uses part of a finite resource. For more details see 'Resource'.+-- You cannot call 'apply' / 'need' while the resource is acquired. withResource :: Resource -> Int -> Action a -> Action a withResource r i act = do s <- Action State.get@@ -506,7 +602,7 @@ diagnostic s $ show r ++ " acquired " ++ show i ++ " after waiting") (do releaseResource r i diagnostic s $ show r ++ " released " ++ show i)- (runAction s act)+ (runAction s $ blockApply ("Within withResource using " ++ show r) act) Action $ State.put s return res @@ -521,3 +617,14 @@ where f [] = act f (r:rs) = withResource (fst $ head r) (sum $ map snd r) $ f rs+++-- | Run an action without counting to the thread limit, typically used for actions that execute+-- on remote machines using barely any local CPU resources. Unsafe as it allows the 'shakeThreads' limit to be exceeded.+-- You cannot call 'apply' / 'Development.Shake.need' while the extra thread is executing.+unsafeExtraThread :: Action a -> Action a+unsafeExtraThread act = do+ s <- Action State.get+ (res,s) <- liftIO $ blockPool (pool s) $ fmap ((,) False) $ runAction s act+ Action $ State.put s+ return res
Development/Shake/Database.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Development.Shake.Database(- Time, startTime, Duration, duration, Trace,+ Time, offsetTime, Duration, duration, Trace, Database, withDatabase, Ops(..), build, Depends, progress,@@ -16,10 +16,10 @@ import Development.Shake.Pool import Development.Shake.Value import Development.Shake.Errors-import Development.Shake.Locks import Development.Shake.Storage import Development.Shake.Types import Development.Shake.Special+import Development.Shake.Util import Development.Shake.Intern as Intern import Control.Exception@@ -30,7 +30,6 @@ import Data.Maybe import Data.List import Data.Monoid-import Data.Time type Map = Map.HashMap @@ -43,54 +42,29 @@ incStep (Step i) = Step $ i + 1 -type Duration = Double -- duration in seconds--duration :: IO a -> IO (Duration, a)-duration act = do- start <- getCurrentTime- res <- act- end <- getCurrentTime- return (fromRational $ toRational $ end `diffUTCTime` start, res)---type Time = Double -- how far you are through this run, in seconds---- | Call once at the start, then call repeatedly to get Time values out-startTime :: IO (IO Time)-startTime = do- start <- getCurrentTime- return $ do- end <- getCurrentTime- return $ fromRational $ toRational $ end `diffUTCTime` start--whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()-whenJust (Just a) f = f a-whenJust Nothing f = return ()-- --------------------------------------------------------------------- -- CALL STACK -data Stack = Stack (Maybe Key) [Id]+data Stack = Stack (Maybe Key) [Id] !(Set.HashSet Id) showStack :: Database -> Stack -> IO [String]-showStack Database{..} (Stack _ xs) = do+showStack Database{..} (Stack _ xs _) = do status <- withLock lock $ readIORef status return $ reverse $ map (maybe "<unknown>" (show . fst) . flip Map.lookup status) xs addStack :: Id -> Key -> Stack -> Stack-addStack x key (Stack _ xs) = Stack (Just key) $ x : xs+addStack x key (Stack _ xs set) = Stack (Just key) (x:xs) (Set.insert x set) topStack :: Stack -> String-topStack (Stack key _) = maybe "<unknown>" show key+topStack (Stack key _ _) = maybe "<unknown>" show key checkStack :: [Id] -> Stack -> Maybe Id-checkStack new (Stack _ old)- | bad:_ <- old `intersect` new = Just bad+checkStack new (Stack _ old set)+ | bad:_ <- filter (`Set.member` set) new = Just bad | otherwise = Nothing emptyStack :: Stack-emptyStack = Stack Nothing []+emptyStack = Stack Nothing [] Set.empty ---------------------------------------------------------------------@@ -148,7 +122,7 @@ type Waiting = Status afterWaiting :: Waiting -> IO () -> IO ()-afterWaiting (Waiting (Pending p) _) act = modifyIORef p (>> act)+afterWaiting (Waiting (Pending p) _) act = modifyIORef'' p (>> act) newWaiting :: Maybe Result -> IO Waiting newWaiting r = do ref <- newIORef $ return (); return $ Waiting (Pending ref) r@@ -166,7 +140,7 @@ t <- readIORef todo when (t /= 0) $ do b <- act (t == 1) k- writeIORef todo $ if b then 0 else t - 1+ writeIORef'' todo $ if b then 0 else t - 1 getResult :: Status -> Maybe Result@@ -200,8 +174,8 @@ Just i -> return i Nothing -> do (is, i) <- return $ Intern.add k is- writeIORef intern is- modifyIORef status $ Map.insert i (k,Missing)+ writeIORef'' intern is+ modifyIORef'' status $ Map.insert i (k,Missing) return i whenJust (checkStack is stack) $ \bad -> do@@ -234,7 +208,7 @@ (#=) :: Id -> (Key, Status) -> IO Status i #= (k,v) = do s <- readIORef status- writeIORef status $ Map.insert i (k,v) s+ writeIORef'' status $ Map.insert i (k,v) s diagnostic $ maybe "Missing" (statusType . snd) (Map.lookup i s) ++ " -> " ++ statusType v ++ ", " ++ maybe "<unknown>" (show . fst) (Map.lookup i s) return v @@ -417,16 +391,21 @@ checkValid Database{..} stored = do status <- readIORef status diagnostic "Starting validity/lint checking"- bad <- fmap concat $ forM (Map.toList status) $ \(i,v) -> case v of+ -- Do not use a forM here as you use too much stack space+ bad <- (\f -> foldM f [] (Map.toList status)) $ \seen (i,v) -> case v of (key, Ready Result{..}) -> do- good <- fmap (== Just result) $ stored key+ now <- stored key+ let good = now == Just result diagnostic $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if good then "passed" else "FAILED"- return [show key ++ " is no longer " ++ show result | not good && not (specialAlwaysRebuilds result)]- _ -> return []- if null bad- then diagnostic "Validity/lint check passed"- else error $ unlines $ "Error: Dependencies have changed since being built:" : bad-+ return $ [(key, result, now) | not good && not (specialAlwaysRebuilds result)] ++ seen+ _ -> return seen+ if null bad then diagnostic "Validity/lint check passed" else do+ let n = length bad+ errorStructured+ ("Lint checking error - " ++ (if n == 1 then "value has" else show n ++ " values have") ++ " changed since being depended upon")+ (intercalate [("",Just "")] [ [("Key", Just $ show key),("Old", Just $ show result),("New", Just $ maybe "<missing>" show now)]+ | (key, result, now) <- bad])+ "" --------------------------------------------------------------------- -- STORAGE
Development/Shake/Directory.hs view
@@ -15,7 +15,6 @@ import System.IO.Error import Data.Binary import Data.List-import Data.Maybe import qualified System.Directory as IO import qualified System.Environment as IO @@ -23,13 +22,14 @@ import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.FilePattern+import Development.Shake.Util newtype DoesFileExistQ = DoesFileExistQ FilePath deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show DoesFileExistQ where- show (DoesFileExistQ a) = "Exists? " ++ a+ show (DoesFileExistQ a) = "doesFileExist " ++ showQuote a newtype DoesFileExistA = DoesFileExistA Bool deriving (Typeable,Eq,Hashable,Binary,NFData)@@ -42,7 +42,7 @@ deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show DoesDirectoryExistQ where- show (DoesDirectoryExistQ a) = "Exists dir? " ++ a+ show (DoesDirectoryExistQ a) = "doesDirectoryExist " ++ showQuote a newtype DoesDirectoryExistA = DoesDirectoryExistA Bool deriving (Typeable,Eq,Hashable,Binary,NFData)@@ -55,13 +55,13 @@ deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show GetEnvQ where- show (GetEnvQ a) = "getEnv " ++ a+ show (GetEnvQ a) = "getEnv " ++ showQuote a newtype GetEnvA = GetEnvA (Maybe String) deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show GetEnvA where- show (GetEnvA a) = fromMaybe "<unset>" a+ show (GetEnvA a) = maybe "<unset>" showQuote a data GetDirectoryQ@@ -69,14 +69,17 @@ | GetDirFiles {dir :: FilePath, pat :: [FilePattern]} | GetDirDirs {dir :: FilePath} deriving (Typeable,Eq)+ newtype GetDirectoryA = GetDirectoryA [FilePath]- deriving (Typeable,Show,Eq,Hashable,Binary,NFData)+ deriving (Typeable,Eq,Hashable,Binary,NFData) instance Show GetDirectoryQ where- show (GetDir x) = "Listing " ++ x- show (GetDirFiles a b) = "Files " ++ a </> ['{'|m] ++ unwords b ++ ['}'|m]- where m = length b > 1- show (GetDirDirs x) = "Dirs " ++ x+ show (GetDir x) = "getDirectoryContents " ++ showQuote x+ show (GetDirFiles a b) = "getDirectoryFiles " ++ showQuote a ++ " [" ++ unwords (map showQuote b) ++ "]"+ show (GetDirDirs x) = "getDirectoryDirs " ++ showQuote x++instance Show GetDirectoryA where+ show (GetDirectoryA xs) = unwords $ map showQuote xs instance NFData GetDirectoryQ where rnf (GetDir a) = rnf a
Development/Shake/Errors.hs view
@@ -3,9 +3,9 @@ -- | Errors seen by the user module Development.Shake.Errors( ShakeException(..),+ errorStructured, err, errorNoRuleToBuildType, errorRuleTypeMismatch, errorIncompatibleRules,- errorMultipleRulesMatch, errorRuleRecursion,- err+ errorMultipleRulesMatch, errorRuleRecursion, errorNoApply, ) where import Control.Arrow@@ -27,25 +27,27 @@ ,"_rule/defaultRule_" * "addOracle" ,"_apply_" * "askOracle"] ++errorStructured :: String -> [(String, Maybe String)] -> String -> a+errorStructured msg args hint = error $ unlines $+ [msg ++ ":"] +++ [" " ++ a ++ [':' | a /= ""] ++ replicate (as - length a + 2) ' ' ++ b | (a,b) <- args2] +++ [hint | hint /= ""]+ where+ as = maximum $ 0 : map (length . fst) args2+ args2 = [(a,b) | (a,Just b) <- args]+++ structured :: Bool -> String -> [(String, Maybe String)] -> String -> a-structured alt msg args hint = structured_ (f msg) (map (first f) args) (f hint)+structured alt msg args hint = errorStructured (f msg) (map (first f) args) (f hint) where f = filter (/= '_') . (if alt then g else id) g xs | (a,b):_ <- filter (\(a,b) -> a `isPrefixOf` xs) alternatives = b ++ g (drop (length a) xs) g (x:xs) = x : g xs g [] = [] -structured_ :: String -> [(String, Maybe String)] -> String -> a-structured_ msg args hint = error $- msg ++ ":\n" ++ unlines [" " ++ a ++ ":" ++ replicate (as - length a + 2) ' ' ++ drp b | (a,b) <- args2] ++ hint- where- drp x | "OracleA " `isPrefixOf` x = drop 8 x- | "OracleQ " `isPrefixOf` x = drop 8 x- | otherwise = x- as = maximum $ 0 : map (length . fst) args2- args2 = [(a,b) | (a,Just b) <- args] - errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> a errorNoRuleToBuildType tk k tv = structured (specialIsOracleKey tk) "Build system error - no _rule_ matches the _key_ type"@@ -64,7 +66,7 @@ "Either the function passed to _rule/defaultRule_ has the wrong _result_ type, or the result of _apply_ is used at the wrong type" errorIncompatibleRules :: TypeRep -> TypeRep -> TypeRep -> a-errorIncompatibleRules tk tv1 tv2 = if specialIsOracleKey tk then errorDuplicateOracle tk Nothing [tv1,tv2] else structured_+errorIncompatibleRules tk tv1 tv2 = if specialIsOracleKey tk then errorDuplicateOracle tk Nothing [tv1,tv2] else errorStructured "Build system error - rule has multiple result types" [("Key type", Just $ show tk) ,("First result type", Just $ show tv1)@@ -74,7 +76,7 @@ errorMultipleRulesMatch :: TypeRep -> String -> Int -> a errorMultipleRulesMatch tk k count | specialIsOracleKey tk = if count == 0 then err $ "no oracle match for " ++ show tk else errorDuplicateOracle tk (Just k) []- | otherwise = structured_+ | otherwise = errorStructured ("Build system error - key matches " ++ (if count == 0 then "no" else "multiple") ++ " rules") [("Key type",Just $ show tk) ,("Key value",Just k)@@ -83,19 +85,27 @@ else "Modify your rules/defaultRules so only one can produce the above key") errorRuleRecursion :: Maybe TypeRep -> Maybe String -> a-errorRuleRecursion tk k = structured_ -- may involve both rules and oracle, so report as a rule+errorRuleRecursion tk k = errorStructured -- may involve both rules and oracle, so report as a rule "Build system error - recursion detected" [("Key type",fmap show tk) ,("Key value",k)] "Rules may not be recursive" errorDuplicateOracle :: TypeRep -> Maybe String -> [TypeRep] -> a-errorDuplicateOracle tk k tvs = structured_+errorDuplicateOracle tk k tvs = errorStructured "Build system error - duplicate oracles for the same question type" ([("Question type",Just $ show tk) ,("Question value",k)] ++ [("Answer type " ++ show i, Just $ show tv) | (i,tv) <- zip [1..] tvs]) "Only one call to addOracle is allowed per question type"++errorNoApply :: TypeRep -> Maybe String -> String -> a+errorNoApply tk k msg = structured (specialIsOracleKey tk)+ ("Build system error - cannot currently call _apply_")+ [("Reason", Just msg)+ ,("_Key_ type", Just $ show tk)+ ,("_Key_ value", k)]+ "Move the _apply_ call earlier/later" -- Should be in Special, but then we get an import cycle
Development/Shake/File.hs view
@@ -3,7 +3,7 @@ module Development.Shake.File( need, want, defaultRuleFile,- (*>), (**>), (?>), phony,+ (*>), (**>), (?>), phony, (~>), newCache, newCacheIO ) where @@ -14,28 +14,31 @@ import System.Directory import Development.Shake.Core-import Development.Shake.Types+import Development.Shake.Util import Development.Shake.Classes import Development.Shake.FilePattern import Development.Shake.FileTime-import Development.Shake.Locks import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong -infix 1 *>, ?>, **>+infix 1 *>, ?>, **>, ~> -newtype FileQ = FileQ BS+newtype FileQ = FileQ BSU deriving (Typeable,Eq,Hashable,Binary,NFData) -instance Show FileQ where show (FileQ x) = unpack x+instance Show FileQ where show (FileQ x) = unpackU x newtype FileA = FileA FileTime- deriving (Typeable,Eq,Hashable,Binary,Show,NFData)+ deriving (Typeable,Hashable,Binary,NFData) +instance Eq FileA where FileA x == FileA y = x /= fileTimeNone && x == y++instance Show FileA where show (FileA x) = "FileTimeHash " ++ show x+ instance Rule FileQ FileA where- storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe $ unpack_ x+ storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x {- observed act = do@@ -95,7 +98,7 @@ -- | This function is not actually exported, but Haddock is buggy. Please ignore. defaultRuleFile :: Rules () defaultRuleFile = defaultRule $ \(FileQ x) -> Just $- liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" $ unpack_ x+ liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" x -- | Require that the following files are built before continuing. Particularly@@ -108,7 +111,7 @@ -- 'Development.Shake.cmd' \"rot13\" [src] \"-o\" [out] -- @ need :: [FilePath] -> Action ()-need xs = (apply $ map (FileQ . pack) xs :: Action [FileA]) >> return ()+need xs = (apply $ map (FileQ . packU) xs :: Action [FileA]) >> return () -- | Require that the following are built by the rules, used to specify the target. --@@ -119,28 +122,38 @@ -- @ -- -- This program will build @Main.exe@, given sufficient rules.+--+-- This function is defined in terms of 'action' and 'need', use 'action' if you need more complex+-- targets than 'want' allows. want :: [FilePath] -> Rules () want = action . need root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-root help test act = rule $ \(FileQ x_) -> let x = unpack x_ in+root help test act = rule $ \(FileQ x_) -> let x = unpackU x_ in if not $ test x then Nothing else Just $ do liftIO $ createDirectoryIfMissing True $ takeDirectory x act x- liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") $ unpack_ x_+ liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") x_ --- | Declare a phony action, this is an action that does not produce a file, and will be rerun+-- | Declare a phony action -- an action that does not produce a file, and will be rerun -- in every execution that requires it. You can demand 'phony' rules using 'want' \/ 'need'.+-- Phony actions are never executed more than once in a single build run. ----- Phony actions are intended to define command-line abbreviations. You should not 'need' phony actions--- as dependencies of rules, as that will cause excessive rebuilding.+-- Phony actions are intended to define command-line abbreviations. If you 'need' a phony action+-- in a rule then every execution where that rule is required will rerun both the rule and the phony+-- action. phony :: String -> Action () -> Rules ()-phony name act = rule $ \(FileQ x_) -> let x = unpack x_ in+phony name act = rule $ \(FileQ x_) -> let x = unpackU x_ in if name /= x then Nothing else Just $ do act return $ FileA fileTimeNone++-- | Infix operator alias for 'phony', for sake of consistency with normal+-- rules.+(~>) :: String -> Action () -> Rules ()+(~>) = phony -- | Define a rule to build files. If the first argument returns 'True' for a given file,
Development/Shake/FilePattern.hs view
@@ -9,6 +9,7 @@ import System.FilePath(pathSeparators) import Data.List import Control.Arrow+import Development.Shake.Util ---------------------------------------------------------------------@@ -97,8 +98,9 @@ -- \"foo\/bar\" '?==' \"foo\\\\bar\" -- @ (?==) :: FilePattern -> FilePath -> Bool-(?==) p x = not $ null $ match (pattern $ lexer p) (True, x)-+(?==) "//*" = const True+(?==) p = \x -> not $ null $ match pat (True, x)+ where pat = pattern $ lexer p --------------------------------------------------------------------- -- DIRECTORY PATTERNS@@ -130,7 +132,7 @@ directories :: [FilePattern] -> [(FilePath,Bool)] directories ps = foldl f xs xs where- xs = nub $ map directories1 ps + xs = fastNub $ map directories1 ps -- Eliminate anything which is a strict subset f xs (x,True) = filter (\y -> not $ (x,False) == y || (x ++ "/") `isPrefixOf` fst y) xs
Development/Shake/FileTime.hs view
@@ -6,41 +6,34 @@ ) where import Development.Shake.Classes+import Development.Shake.Util+import Data.Char import Data.Int+import Data.Word import qualified Data.ByteString.Char8 as BS--#ifdef PORTABLE- import System.IO.Error import Control.Exception-import System.Directory+import Numeric -#if __GLASGOW_HASKELL__ >= 706+-- Required for Portable+import System.Directory import Data.Time-#else import System.Time-#endif -#elif defined mingw32_HOST_OS-+-- Required for non-portable Windows+#if defined(mingw32_HOST_OS) import Foreign import Foreign.C.Types- type WIN32_FILE_ATTRIBUTE_DATA = Ptr () type LPCSTR = Ptr CChar- foreign import stdcall unsafe "Windows.h GetFileAttributesExA" c_getFileAttributesEx :: LPCSTR -> Int32 -> WIN32_FILE_ATTRIBUTE_DATA -> IO Bool- size_WIN32_FILE_ATTRIBUTE_DATA = 36- index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20--#else+#endif -import System.IO.Error-import Control.Exception+-- Required for non-portable Unix (since it requires a non-standard library, only require if not portable)+#if !defined(PORTABLE) && !defined(mingw32_HOST_OS) import System.Posix.Files.ByteString- #endif @@ -48,8 +41,11 @@ -- or maxBound to indicate there is no valid time. The moral type is @Maybe Datetime@ -- but it needs to be more efficient. newtype FileTime = FileTime Int32- deriving (Typeable,Eq,Hashable,Binary,Show,NFData)+ deriving (Typeable,Eq,Hashable,Binary,NFData) +instance Show FileTime where+ show (FileTime x) = "0x" ++ replicate (length s - 8) '0' ++ map toUpper s+ where s = showHex (fromIntegral x :: Word32) "" fileTime :: Int32 -> FileTime fileTime x = FileTime $ if x == maxBound then maxBound - 1 else x@@ -58,45 +54,59 @@ fileTimeNone = FileTime maxBound -getModTimeMaybe :: BS.ByteString -> IO (Maybe FileTime)+getModTimeError :: String -> BSU -> IO FileTime+getModTimeError msg x = do+ res <- getModTimeMaybe x+ case res of+ -- Make sure you raise an error in IO, not return a value which will error later+ Nothing -> error $ msg ++ "\n " ++ unpackU x+ Just x -> return x -#ifdef PORTABLE --- Portable fallback-getModTimeMaybe x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do- time <- getModificationTime $ BS.unpack x-#if __GLASGOW_HASKELL__ >= 706- return $ Just $ fileTime $ floor $ utctDayTime time+getModTimeMaybe :: BSU -> IO (Maybe FileTime)+#if defined(PORTABLE)+getModTimeMaybe x = getModTimeMaybePortable x+#elif defined(mingw32_HOST_OS)+getModTimeMaybe x = getModTimeMaybeWindows x #else- let TOD t _ = time- return $ Just $ fileTime $ fromIntegral t+getModTimeMaybe x = getModTimeMaybeUnix x #endif -#elif defined mingw32_HOST_OS ++-- Portable fallback+getModTimeMaybePortable :: BSU -> IO (Maybe FileTime)+getModTimeMaybePortable x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do+ time <- getModificationTime $ unpackU x+ return $ Just $ extractFileTime time++-- deal with difference in return type of getModificationTime between directory versions+class ExtractFileTime a where extractFileTime :: a -> FileTime+instance ExtractFileTime ClockTime where extractFileTime (TOD t _) = fileTime $ fromIntegral t+instance ExtractFileTime UTCTime where extractFileTime = fileTime . floor . fromRational . toRational . utctDayTime++ -- Directly against the Win32 API, twice as fast as the portable version-getModTimeMaybe x = BS.useAsCString x $ \file ->+#if defined(mingw32_HOST_OS)+getModTimeMaybeWindows :: BSU -> IO (Maybe FileTime)+getModTimeMaybeWindows x = BS.useAsCString (unpackU_ x) $ \file -> allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do res <- c_getFileAttributesEx file 0 info- if not res then return Nothing else do+ if res then do -- Technically a Word32, but we can treak it as an Int32 for peek dword <- peekByteOff info index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: IO Int32 return $ Just $ fileTime dword+ else if requireU x then+ getModTimeMaybePortable x+ else+ return Nothing+#endif -#else --- Directly against the unix library-getModTimeMaybe x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do- t <- fmap modificationTime $ getFileStatus x+-- Unix version+#if !defined(PORTABLE) && !defined(mingw32_HOST_OS)+getModTimeMaybeUnix :: BSU -> IO (Maybe FileTime)+getModTimeMaybeUnix x = handleJust (\e -> if isDoesNotExistError e then Just () else Nothing) (const $ return Nothing) $ do+ t <- fmap modificationTime $ getFileStatus $ unpackU_ x return $ Just $ fileTime $ fromIntegral $ fromEnum t- #endif---getModTimeError :: String -> BS.ByteString -> IO FileTime-getModTimeError msg x = do- res <- getModTimeMaybe x- case res of- -- Make sure you raise an error in IO, not return a value which will error later- Nothing -> error $ msg ++ "\n " ++ BS.unpack x- Just x -> return x
Development/Shake/Files.hs view
@@ -7,28 +7,34 @@ import Control.Monad import Control.Monad.IO.Class import Data.Maybe+import System.Directory import Development.Shake.Core-import Development.Shake.Types+import Development.Shake.Util import Development.Shake.Classes import Development.Shake.File import Development.Shake.FilePattern import Development.Shake.FileTime +import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong++ infix 1 ?>>, *>> -newtype FilesQ = FilesQ [BS]+newtype FilesQ = FilesQ [BSU] deriving (Typeable,Eq,Hashable,Binary,NFData) newtype FilesA = FilesA [FileTime]- deriving (Typeable,Show,Eq,Hashable,Binary,NFData)+ deriving (Typeable,Eq,Hashable,Binary,NFData) -instance Show FilesQ where show (FilesQ xs) = unwords $ map unpack xs+instance Show FilesA where show (FilesA xs) = unwords $ "FileTimeHashes" : map show xs +instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . unpackU) xs + instance Rule FilesQ FilesA where- storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe $ map unpack_ xs+ storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs -- | Define a rule for building multiple files at the same time.@@ -52,10 +58,11 @@ | otherwise = do forM_ ps $ \p -> p *> \file -> do- _ :: FilesA <- apply1 $ FilesQ $ map (pack . substitute (extract p file)) ps+ _ :: FilesA <- apply1 $ FilesQ $ map (packU . substitute (extract p file)) ps return ()- rule $ \(FilesQ xs_) -> let xs = map unpack xs_ in+ rule $ \(FilesQ xs_) -> let xs = map unpackU xs_ in if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do+ liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs act xs liftIO $ getFileTimes "*>>" xs_ @@ -86,25 +93,26 @@ | otherwise -> error $ "Invariant broken in ?>> when trying on " ++ x isJust . checkedTest ?> \x -> do- _ :: FilesA <- apply1 $ FilesQ $ map pack $ fromJust $ test x+ _ :: FilesA <- apply1 $ FilesQ $ map packU $ fromJust $ test x return () - rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpack xs_ in+ rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpackU xs_ in case checkedTest x of Just ys | ys == xs -> Just $ do+ liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs act xs liftIO $ getFileTimes "?>>" xs_ Just ys -> error $ "Error, ?>> is incompatible with " ++ show xs ++ " vs " ++ show ys Nothing -> Nothing -getFileTimes :: String -> [BS] -> IO FilesA+getFileTimes :: String -> [BSU] -> IO FilesA getFileTimes name xs = do- ys <- mapM (getModTimeMaybe . unpack_) xs+ ys <- mapM getModTimeMaybe xs case sequence ys of Just ys -> return $ FilesA ys Nothing -> do let missing = length $ filter isNothing ys error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++ " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++- concat ["\n " ++ unpack x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]+ concat ["\n " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]
Development/Shake/Intern.hs view
@@ -9,6 +9,7 @@ import Development.Shake.Classes import Prelude hiding (lookup) import qualified Data.HashMap.Strict as Map+import Data.List(foldl') -- Invariant: The first field is the highest value in the Map@@ -44,4 +45,4 @@ fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a-fromList xs = Intern (maximum $ 0 : [i | (_, Id i) <- xs]) (Map.fromList xs)+fromList xs = Intern (foldl' max 0 [i | (_, Id i) <- xs]) (Map.fromList xs)
− Development/Shake/Locks.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Development.Shake.Locks(- Lock, newLock, withLock,- Var, newVar, readVar, modifyVar, modifyVar_, withVar,- Barrier, newBarrier, signalBarrier, waitBarrier,- Resource, newResourceIO, acquireResource, releaseResource- ) where--import Control.Concurrent-import Control.Monad-import Data.Function-import System.IO.Unsafe--------------------------------------------------------------------------- LOCK---- | Like an MVar, but has no value-newtype Lock = Lock (MVar ())-instance Show Lock where show _ = "Lock"--newLock :: IO Lock-newLock = fmap Lock $ newMVar ()--withLock :: Lock -> IO a -> IO a-withLock (Lock x) = withMVar x . const--------------------------------------------------------------------------- VAR---- | Like an MVar, but must always be full-newtype Var a = Var (MVar a)-instance Show (Var a) where show _ = "Var"--newVar :: a -> IO (Var a)-newVar = fmap Var . newMVar--readVar :: Var a -> IO a-readVar (Var x) = readMVar x--modifyVar :: Var a -> (a -> IO (a, b)) -> IO b-modifyVar (Var x) f = modifyMVar x f--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--------------------------------------------------------------------------- BARRIER---- | Starts out empty, then is filled exactly once-newtype Barrier a = Barrier (MVar a)-instance Show (Barrier a) where show _ = "Barrier"--newBarrier :: IO (Barrier a)-newBarrier = fmap Barrier newEmptyMVar--signalBarrier :: Barrier a -> a -> IO ()-signalBarrier (Barrier x) = putMVar x--waitBarrier :: Barrier a -> IO a-waitBarrier (Barrier x) = readMVar x--------------------------------------------------------------------------- RESOURCE--{-# NOINLINE resourceIds #-}-resourceIds :: Var Int-resourceIds = unsafePerformIO $ newVar 0--resourceId :: IO Int-resourceId = modifyVar resourceIds $ \i -> let j = i + 1 in j `seq` return (j, j)----- | A type representing a finite resource, which multiple build actions should respect.--- Created with 'Development.Shake.newResource' and used with 'Development.Shake.withResource'--- 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:------ @--- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=2} $ do--- 'Development.Shake.want' [\"a.xls\",\"b.xls\"]--- excel <- 'Development.Shake.newResource' \"Excel\" 1--- \"*.xls\" 'Development.Shake.*>' \\out ->--- 'Development.Shake.withResource' excel 1 $--- 'Development.Shake.cmd' \"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. Be careful that the--- actions run within 'Development.Shake.withResource' do not themselves require further quantities of this resource, or--- you may get a \"thread blocked indefinitely in an MVar operation\" exception. Typically only--- system commands (such as 'Development.Shake.cmd') should be run inside 'Development.Shake.withResource',--- not commands such as 'Development.Shake.need'. If an action requires multiple resources, use--- 'Development.Shake.withResources' to avoid deadlock.------ 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:------ @--- disk <- 'Development.Shake.newResource' \"Disk\" 4--- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]--- \"*.exe\" 'Development.Shake.*>' \\out ->--- 'Development.Shake.withResource' disk 1 $--- 'Development.Shake.cmd' \"ld -o\" [out] ...--- \"*.o\" 'Development.Shake.*>' \\out ->--- 'Development.Shake.cmd' \"cl -o\" [out] ...--- @-data Resource = Resource {resourceKey :: Int, resourceName :: String, resourceMax :: Int, resourceVar :: Var (Int,[(Int,IO ())])}-instance Show Resource where show Resource{..} = "Resource " ++ resourceName--instance Eq Resource where (==) = (==) `on` resourceKey-instance Ord Resource where compare = compare `on` resourceKey----- | A version of 'newResource' that runs in IO, and can be called before calling 'Development.Shake.shake'.--- Most people should use 'Development.Shake.newResource' instead.-newResourceIO :: String -> Int -> IO Resource-newResourceIO name mx = do- when (mx < 0) $- error $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx- key <- resourceId- var <- newVar (mx, [])- return $ Resource key 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{..} want- | want < 0 = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show want- | want > resourceMax = error $ "You cannot acquire more than " ++ show resourceMax ++ " of " ++ show r ++ ", requested " ++ show want- | otherwise = modifyVar resourceVar $ \(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{..} i = modifyVar_ resourceVar $ \(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
@@ -39,7 +39,7 @@ -- @ -- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData) -- rules = do--- 'addOracle' $ \\(GhcVersion _) -> fmap (last . words . 'Development.Shake.fromStdout') $ 'Development.Shake.cmd' \"ghc --version\"+-- 'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\" -- ... rules ... -- @ --
Development/Shake/Pool.hs view
@@ -4,7 +4,8 @@ import Control.Concurrent import Control.Exception hiding (blocked)-import Development.Shake.Locks+import Development.Shake.Util+import Development.Shake.Timing import qualified Data.HashSet as Set import System.IO.Unsafe import System.Random@@ -72,10 +73,12 @@ If any worker throws an exception, must signal to all the other workers -} -data Pool = Pool {-# UNPACK #-} !Int !(Var (Maybe S)) !(Barrier (Maybe SomeException))+data Pool = Pool {-# UNPACK #-} !Int !(Var (Maybe S)) !(Barrier (Either SomeException S)) data S = S {threads :: !(Set.HashSet ThreadId) -- IMPORTANT: Must be strict or we leak thread stackssss+ ,threadsMax :: {-# UNPACK #-} !Int -- high water mark of Set.size threads+ ,threadsSum :: {-# UNPACK #-} !Int -- number of threads we have been through ,working :: {-# UNPACK #-} !Int -- threads which are actively working ,blocked :: {-# UNPACK #-} !Int -- threads which are blocked ,todo :: !(Queue (IO ()))@@ -83,7 +86,7 @@ emptyS :: Bool -> S-emptyS deterministic = S Set.empty 0 0 $ newQueue deterministic+emptyS deterministic = S Set.empty 0 0 0 0 $ newQueue deterministic -- | Given a pool, and a function that breaks the S invariants, restore them@@ -103,12 +106,14 @@ case res of Left e -> onVar $ \s -> do mapM_ killThread $ Set.toList $ Set.delete t $ threads s- signalBarrier done $ Just e+ signalBarrier done $ Left e return Nothing Right _ -> step pool $ \s -> return s{working = working s - 1, threads = Set.delete t $ threads s}- return $ Just s{working = working s + 1, todo = todo2, threads = Set.insert t $ threads s}+ let threads2 = Set.insert t $ threads s+ return $ Just s{working = working s + 1, todo = todo2, threads = threads2+ ,threadsSum = threadsSum s + 1, threadsMax = threadsMax s `max` Set.size threads2} Nothing | working s == 0 && blocked s == 0 -> do- signalBarrier done Nothing+ signalBarrier done $ Right s return Nothing _ -> return $ Just s @@ -160,5 +165,5 @@ addPool pool $ act pool res <- waitBarrier res case res of- Nothing -> return ()- Just e -> throw e+ Left e -> throw e+ Right s -> addTiming $ "Pool finished (" ++ show (threadsSum s) ++ " threads, " ++ show (threadsMax s) ++ " max)"
Development/Shake/Progress.hs view
@@ -3,7 +3,7 @@ -- | Progress tracking module Development.Shake.Progress( Progress(..),- progressSimple, progressDisplay, progressTitlebar,+ progressSimple, progressDisplay, progressTitlebar, progressProgram, progressDisplayTester -- INTERNAL FOR TESTING ONLY ) where @@ -13,7 +13,12 @@ import Control.Exception import Control.Monad import System.Environment+import System.Directory+import System.Process+import Data.Char import Data.Data+import Data.IORef+import Data.List import Data.Maybe import Data.Monoid import qualified Data.ByteString.Char8 as BS@@ -38,8 +43,7 @@ -- to 'Development.Shake.shakeProgress'. Typically a program will use 'progressDisplay' to poll this value and produce -- status messages, which is implemented using this data type. data Progress = Progress- {isRunning :: !Bool -- ^ Starts out 'True', becomes 'False' once the build has completed.- ,isFailure :: !(Maybe String) -- ^ Starts out 'Nothing', becomes 'Just' if a rule fails.+ {isFailure :: !(Maybe String) -- ^ Starts out 'Nothing', becomes 'Just' a target name if a rule fails. ,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.@@ -52,10 +56,9 @@ deriving (Eq,Ord,Show,Data,Typeable) instance Monoid Progress where- mempty = Progress True Nothing 0 0 0 0 0 0 0 (0,0)+ mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0) mappend a b = Progress- {isRunning = isRunning a && isRunning b- ,isFailure = isFailure a `mappend` isFailure b+ {isFailure = isFailure a `mplus` isFailure b ,countSkipped = countSkipped a + countSkipped b ,countBuilt = countBuilt a + countBuilt b ,countUnknown = countUnknown a + countUnknown b@@ -197,24 +200,22 @@ progressDisplayer :: Bool -> Double -> (String -> IO ()) -> IO Progress -> IO () progressDisplayer sleep sample disp prog = do disp "Starting..." -- no useful info at this stage- loop $ message sample idStream+ catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop $ message sample idStream) (const $ disp "Finished") where loop :: Stream Progress String -> IO () loop stream = do when sleep $ threadDelay $ ceiling $ sample * 1000000 p <- prog- if not $ isRunning p then- disp "Finished"- else do- (msg, stream) <- return $ runStream stream p- disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)- loop stream+ (msg, stream) <- return $ runStream stream p+ disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)+ loop stream {-# NOINLINE xterm #-} xterm :: Bool xterm = System.IO.Unsafe.unsafePerformIO $- Control.Exception.catch (fmap (== "xterm") $ getEnv "TERM") $+ -- Terminal.app uses "xterm-256color" as its env variable+ Control.Exception.catch (fmap ("xterm" `isPrefixOf`) $ getEnv "TERM") $ \(e :: SomeException) -> return False @@ -231,12 +232,42 @@ #endif --- | A simple method for displaying progress messages, suitable for using as--- 'Development.Shake.shakeProgress'. This function writes the current progress to--- the titlebar every five seconds. The function is defined as:+-- | Call the program @shake-progress@ if it is on the @$PATH@. The program is called with+-- the following arguments: ----- @---progressSimple = 'progressDisplay' 5 'progressTitlebar'--- @+-- * @--title=string@ - the string passed to @progressProgram@.+--+-- * @--state=Normal@, or one of @NoProgress@, @Normal@, or @Error@ to indicate+-- what state the progress bar should be in.+--+-- * @--value=25@ - the percent of the build that has completed, if not in @NoProgress@ state.+--+-- The program will not be called consecutively with the same @--state@ and @--value@ options.+--+-- Windows 7 or higher users can get taskbar progress notifications by placing the following+-- program in their @$PATH@: <https://github.com/ndmitchell/shake/releases>.+progressProgram :: IO (String -> IO ())+progressProgram = do+ exe <- findExecutable "shake-progress"+ case exe of+ Nothing -> return $ const $ return ()+ Just exe -> do+ ref <- newIORef Nothing+ return $ \msg -> do+ let failure = " Failure! " `isInfixOf` msg+ let perc = let (a,b) = break (== '%') msg+ in if null b then "" else reverse $ takeWhile isDigit $ reverse a+ let key = (failure, perc)+ same <- atomicModifyIORef ref $ \old -> (Just key, old == Just key)+ let state = if perc == "" then "NoProgress" else if failure then "Error" else "Normal"+ rawSystem exe $ ["--title=" ++ msg, "--state=" ++ state] ++ ["--value=" ++ perc | perc /= ""]+ return ()+++-- | A simple method for displaying progress messages, suitable for using as 'Development.Shake.shakeProgress'.+-- This function writes the current progress to the titlebar every five seconds using 'progressTitlebar',+-- and calls any @shake-progress@ program on the @$PATH@ using 'progressProgram'. progressSimple :: IO Progress -> IO ()-progressSimple = progressDisplay 5 progressTitlebar+progressSimple p = do+ program <- progressProgram+ progressDisplay 5 (\s -> progressTitlebar s >> program s) p
Development/Shake/Rerun.hs view
@@ -10,11 +10,11 @@ newtype AlwaysRerunQ = AlwaysRerunQ () deriving (Typeable,Eq,Hashable,Binary,NFData)-instance Show AlwaysRerunQ where show _ = "AlwaysRerunQ"+instance Show AlwaysRerunQ where show _ = "alwaysRerun" newtype AlwaysRerunA = AlwaysRerunA () deriving (Typeable,Hashable,Binary,NFData)-instance Show AlwaysRerunA where show _ = "AlwaysRerunA"+instance Show AlwaysRerunA where show _ = "<none>" instance Eq AlwaysRerunA where a == b = False instance Rule AlwaysRerunQ AlwaysRerunA where@@ -27,7 +27,7 @@ -- @ -- \"ghcVersion.txt\" 'Development.Shake.*>' \\out -> do -- 'alwaysRerun'--- Stdout stdout <- 'Development.Shake.cmd' \"ghc --version\"+-- 'Development.Shake.Stdout' stdout <- 'Development.Shake.cmd' \"ghc --numeric-version\" -- 'Development.Shake.writeFileChanged' out stdout -- @ alwaysRerun :: Action ()
+ Development/Shake/Resource.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE RecordWildCards #-}++module Development.Shake.Resource(+ Resource, newResourceIO, newThrottleIO, acquireResource, releaseResource+ ) where++import Development.Shake.Errors+import Development.Shake.Util+import Data.Function+import System.IO.Unsafe+import Control.Arrow+import Control.Monad+++{-# NOINLINE resourceIds #-}+resourceIds :: Var Int+resourceIds = unsafePerformIO $ newVar 0++resourceId :: IO Int+resourceId = modifyVar resourceIds $ \i -> let j = i + 1 in j `seq` return (j, j)+++-- | A type representing an external resource which the build system should respect. There+-- are two ways to create 'Resource's in Shake:+--+-- * 'Development.Shake.newResource' creates a finite resource, stopping too many actions running+-- simultaneously.+--+-- * 'Development.Shake.newThrottle' creates a throttled resource, stopping too many actions running+-- over a short time period.+--+-- These resources are used with 'Development.Shake.withResource' when defining rules. Typically only+-- system commands (such as 'Development.Shake.cmd') should be run inside 'Development.Shake.withResource',+-- not commands such as 'Development.Shake.need'.+--+-- Be careful that the actions run within 'Development.Shake.withResource' do not themselves require further+-- resources, or you may get a \"thread blocked indefinitely in an MVar operation\" exception.+-- If an action requires multiple resources, use 'Development.Shake.withResources' to avoid deadlock.+data Resource = Resource+ {resourceOrd :: Int+ -- ^ Key used for Eq/Ord operations. To make withResources work, we require newResourceIO < newThrottleIO+ ,resourceShow :: String+ -- ^ String used for Show+ ,acquireResource :: Int -> IO (Maybe (IO ()))+ -- ^ 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.+ ,releaseResource :: Int -> IO ()+ -- ^ You should only ever releaseResource that you obtained with acquireResource.+ }++instance Show Resource where show = resourceShow+instance Eq Resource where (==) = (==) `on` resourceOrd+instance Ord Resource where compare = compare `on` resourceOrd+++---------------------------------------------------------------------+-- FINITE RESOURCES++-- | (number available, queue of people with how much they want and a barrier to signal when it is allocated to them)+type Finite = Var (Int, [(Int,Barrier ())])++-- | A version of 'Development.Shake.newResource' that runs in IO, and can be called before calling 'Development.Shake.shake'.+-- Most people should use 'Development.Shake.newResource' instead.+newResourceIO :: String -> Int -> IO Resource+newResourceIO name mx = do+ when (mx < 0) $+ error $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx+ key <- resourceId+ var <- newVar (mx, [])+ return $ Resource (negate key) shw (acquire var) (release var)+ where+ shw = "Resource " ++ name++ acquire :: Finite -> Int -> IO (Maybe (IO ()))+ acquire var want+ | want < 0 = error $ "You cannot acquire a negative quantity of " ++ shw ++ ", requested " ++ show want+ | want > mx = error $ "You cannot acquire more than " ++ show mx ++ " of " ++ shw ++ ", 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,bar)]), Just $ waitBarrier bar)++ release :: Finite -> Int -> IO ()+ release var i = modifyVar_ var $ \(available,waiting) -> f (available+i) waiting+ where+ f i ((wi,wa):ws) | wi <= i = signalBarrier wa () >> f (i-wi) ws+ | otherwise = do (i,ws) <- f i ws; return (i,(wi,wa):ws)+ f i [] = return (i, [])+++---------------------------------------------------------------------+-- THROTTLE RESOURCES++data Throttle = Throttle+ {throttleLock :: Lock+ -- people queue up to grab from replenish, full means no one is queued+ ,throttleVal :: Var (Either (Barrier ()) [(Time, Int)])+ -- either someone waiting for resources, or the time to wait until before N resources become available+ -- anyone who puts a Barrier in the Left must be holding the Lock+ ,throttleTime :: IO Time+ }++-- | A version of 'Development.Shake.newThrottle' that runs in IO, and can be called before calling 'Development.Shake.shake'.+-- Most people should use 'Development.Shake.newResource' instead.+newThrottleIO :: String -> Int -> Double -> IO Resource+newThrottleIO name count period = do+ when (count < 0) $+ error $ "You cannot create a throttle named " ++ name ++ " with a negative quantity, you used " ++ show count+ key <- resourceId+ lock <- newLock+ time <- offsetTime+ rep <- newVar $ Right [(0, count)]+ let s = Throttle lock rep time+ return $ Resource key shw (acquire s) (release s)+ where+ shw = "Throttle " ++ name++ release :: Throttle -> Int -> IO ()+ release Throttle{..} n = do+ t <- throttleTime+ modifyVar_ throttleVal $ \v -> case v of+ Left b -> signalBarrier b () >> return (Right [(t+period, n)])+ Right ts -> return $ Right $ ts ++ [(t+period, n)]++ acquire :: Throttle -> Int -> IO (Maybe (IO ()))+ acquire Throttle{..} want+ | want < 0 = error $ "You cannot acquire a negative quantity of " ++ shw ++ ", requested " ++ show want+ | want > count = error $ "You cannot acquire more than " ++ show count ++ " of " ++ shw ++ ", requested " ++ show want+ | otherwise = do+ let grab t vs = do+ let (a,b) = span ((<= t) . fst) vs+ -- renormalise for clock skew, nothing can ever be > t+period away+ return (sum $ map snd a, map (first $ min $ t+period) b)+ let push i vs = [(0,i) | i > 0] ++ vs++ -- attempt to grab without locking+ res <- withLockTry throttleLock $ do+ modifyVar throttleVal $ \v -> case v of+ Right vs -> do+ t <- throttleTime+ (got,vs) <- grab t vs+ if got >= want then+ return (Right $ push (got - want) vs, True)+ else+ return (Right $ push got vs, False)+ _ -> return (v, False)+ if res == Just True then+ return Nothing+ else+ return $ Just $ withLock throttleLock $ do+ -- keep trying to acquire more resources until you have everything you need+ let f want = join $ modifyVar throttleVal $ \v -> case v of+ Left _ -> err "newThrottle, invariant failed, Left while holding throttleLock"+ Right vs -> do+ t <- throttleTime+ (got,vs) <- grab t vs+ case vs of+ _ | got >= want -> return (Right $ push (got - want) vs, return ())+ [] -> do+ b <- newBarrier+ return (Left b, waitBarrier b >> f (want - got))+ (t2,n):vs -> do+ -- be robust to clock skew - only ever sleep for 'period' at most and always mark the next as good.+ return $ (,) (Right $ (0,n):vs) $ do+ sleep $ min period (t2-t)+ f $ want - got+ f want
Development/Shake/Special.hs view
@@ -7,13 +7,12 @@ ) where import Development.Shake.Value-import Data.List import Data.Typeable specialAlwaysRebuilds :: Value -> Bool-specialAlwaysRebuilds v = sv == "AlwaysRerunA" || "OracleA " `isPrefixOf` sv || sv == "FileA (FileTime 2147483647)"- where sv = show v+specialAlwaysRebuilds v = con `elem` ["AlwaysRerunA","OracleA"] || (con == "FileA" && show v == "FileTimeHash 0x7FFFFFFF")+ where con = show $ fst $ splitTyConApp $ typeValue v specialIsFileKey :: TypeRep -> Bool
Development/Shake/Storage.hs view
@@ -10,7 +10,7 @@ ) where import Development.Shake.Binary-import Development.Shake.Locks+import Development.Shake.Util import Development.Shake.Types import Development.Shake.Timing @@ -36,9 +36,14 @@ type Map = Map.HashMap -- Increment every time the on-disk format/semantics change,--- @i@ is for the users version number+-- @x@ is for the users version number databaseVersion :: String -> String-databaseVersion x = "SHAKE-DATABASE-8-" ++ tail (init $ show x) ++ "\r\n"+-- THINGS I WANT TO DO ON THE NEXT CHANGE+-- * Change FileTime to be a Word32, not an Int32, with maxBound for fileNone+-- * Change filepaths to store a 1 byte prefix saying 8bit ASCII or UTF8+databaseVersion x = "SHAKE-DATABASE-8-" ++ s ++ "\r\n"+ where s = tail $ init $ show x -- call show, then take off the leading/trailing quotes+ -- ensures we do not get \r or \n in the user portion withStorage@@ -70,13 +75,13 @@ if not $ ver `LBS.isPrefixOf` src then do unless (LBS.null src) $ do- let good x = isAlphaNum x || x `elem` "-_ "- let bad = LBS.takeWhile good $ LBS.take 50 src+ let limit x = let (a,b) = splitAt 200 x in a ++ (if null b then "" else "...")+ let disp = map (\x -> if isPrint x && isAscii x then x else '?') . takeWhile (`notElem` "\r\n") outputErr $ unlines- ["Error when reading Shake database " ++ dbfile- ," Invalid version stamp detected"- ," Expected: " ++ takeWhile good (LBS.unpack ver)- ," Found : " ++ LBS.unpack bad+ ["Error when reading Shake database - invalid version stamp detected:"+ ," File: " ++ dbfile+ ," Expected: " ++ disp (LBS.unpack ver)+ ," Found: " ++ disp (limit $ LBS.unpack src) ,"All rules will be rebuilt"] continue h Map.empty else
Development/Shake/Types.hs view
@@ -3,14 +3,12 @@ -- | Types exposed to the user module Development.Shake.Types( Progress(..), Verbosity(..), Assume(..),- ShakeOptions(..), shakeOptions,- BS, pack, unpack, pack_, unpack_+ ShakeOptions(..), shakeOptions ) where import Data.Data import Data.List import Development.Shake.Progress-import Development.Shake.Classes import qualified Data.ByteString.Char8 as BS @@ -51,7 +49,6 @@ -- 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 :: String@@ -89,7 +86,8 @@ ,shakeTimings :: Bool -- ^ Default to 'False'. Print timing information for each stage at the end. ,shakeProgress :: IO Progress -> IO ()- -- ^ Defaults to no action. A function called on a separate thread when the build starts, allowing progress to be reported.+ -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported.+ -- The function is called on a separate thread, and that thread is killed when the build completes. -- For applications that want to display progress messages, 'progressSimple' is often sufficient, but more advanced -- users should look at the 'Progress' data type. ,shakeOutput :: Verbosity -> String -> IO ()@@ -162,28 +160,3 @@ | Chatty -- ^ Print errors, full command line and status messages when starting a rule. | Diagnostic -- ^ Print messages for virtually everything (mostly for debugging). deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data)--------------------------------------------------------------------------- BYTESTRING WRAPPER--- Only purpose is because ByteString does not have an NFData instance in older GHC--newtype BS = BS BS.ByteString- deriving (Hashable, Binary, Eq)--instance NFData BS where- -- some versions of ByteString do not have NFData instances, but seq is equivalent- -- for a strict bytestring. Therefore, we write our own instance.- rnf (BS x) = x `seq` ()--pack :: String -> BS-pack = pack_ . BS.pack--unpack :: BS -> String-unpack = BS.unpack . unpack_--pack_ :: BS.ByteString -> BS-pack_ = BS--unpack_ :: BS -> BS.ByteString-unpack_ (BS x) = x
+ Development/Shake/Util.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-}++module Development.Shake.Util(+ Lock, newLock, withLock, withLockTry,+ Var, newVar, readVar, modifyVar, modifyVar_, withVar,+ Barrier, newBarrier, signalBarrier, waitBarrier,+ Duration, duration, Time, offsetTime, sleep,+ modifyIORef'', writeIORef'',+ whenJust, loop,+ fastNub, showQuote,+ BS, pack, unpack, pack_, unpack_,+ BSU, packU, unpackU, packU_, unpackU_, requireU+ ) where++import Control.Concurrent+import Control.Exception+import Data.Char+import Data.IORef+import Data.Time+import qualified Data.ByteString as BS (any)+import qualified Data.ByteString.Char8 as BS hiding (any)+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.HashSet as Set+import Development.Shake.Classes+++---------------------------------------------------------------------+-- LOCK++-- | Like an MVar, but has no value+newtype Lock = Lock (MVar ())+instance Show Lock where show _ = "Lock"++newLock :: IO Lock+newLock = fmap Lock $ newMVar ()++withLock :: Lock -> IO a -> IO a+withLock (Lock x) = withMVar x . const++withLockTry :: Lock -> IO a -> IO (Maybe a)+withLockTry (Lock m) act =+ mask $ \restore -> do+ a <- tryTakeMVar m+ case a of+ Nothing -> return Nothing+ Just _ -> restore (fmap Just act) `finally` putMVar m ()+++---------------------------------------------------------------------+-- VAR++-- | Like an MVar, but must always be full+newtype Var a = Var (MVar a)+instance Show (Var a) where show _ = "Var"++newVar :: a -> IO (Var a)+newVar = fmap Var . newMVar++readVar :: Var a -> IO a+readVar (Var x) = readMVar x++modifyVar :: Var a -> (a -> IO (a, b)) -> IO b+modifyVar (Var x) f = modifyMVar x f++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+++---------------------------------------------------------------------+-- BARRIER++-- | Starts out empty, then is filled exactly once+newtype Barrier a = Barrier (MVar a)+instance Show (Barrier a) where show _ = "Barrier"++newBarrier :: IO (Barrier a)+newBarrier = fmap Barrier newEmptyMVar++signalBarrier :: Barrier a -> a -> IO ()+signalBarrier (Barrier x) = putMVar x++waitBarrier :: Barrier a -> IO a+waitBarrier (Barrier x) = readMVar x+++---------------------------------------------------------------------+-- Data.Time++type Time = Double -- how far you are through this run, in seconds++-- | Call once at the start, then call repeatedly to get Time values out+offsetTime :: IO (IO Time)+offsetTime = do+ start <- getCurrentTime+ return $ do+ end <- getCurrentTime+ return $ fromRational $ toRational $ end `diffUTCTime` start+++type Duration = Double -- duration in seconds++duration :: IO a -> IO (Duration, a)+duration act = do+ time <- offsetTime+ res <- act+ time <- time+ return (time, res)+++sleep :: Duration -> IO ()+sleep x = threadDelay $ ceiling $ x * 1000000+++---------------------------------------------------------------------+-- Data.IORef++-- Two 's because GHC 7.6 has a strict modifyIORef+modifyIORef'' :: IORef a -> (a -> a) -> IO ()+modifyIORef'' ref f = do+ x <- readIORef ref+ writeIORef'' ref $ f x++writeIORef'' :: IORef a -> a -> IO ()+writeIORef'' ref !x = writeIORef ref x+++---------------------------------------------------------------------+-- Data.List++-- | Like 'nub', but the results may be in any order.+fastNub :: (Eq a, Hashable a) => [a] -> [a]+fastNub = f Set.empty+ where f seen [] = []+ f seen (x:xs) | x `Set.member` seen = f seen xs+ | otherwise = x : f (Set.insert x seen) xs+++showQuote :: String -> String+showQuote xs | any isSpace xs = "\"" ++ concatMap (\x -> if x == '\"' then "\"\"" else [x]) xs ++ "\""+ | otherwise = xs+++---------------------------------------------------------------------+-- Control.Monad++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust (Just a) f = f a+whenJust Nothing f = return ()++loop :: Monad m => (a -> m (Either a b)) -> a -> m b+loop act x = do+ res <- act x+ case res of+ Left x -> loop act x+ Right v -> return v+++---------------------------------------------------------------------+-- Data.ByteString+-- Mostly because ByteString does not have an NFData instance in older GHC++-- | ASCII ByteString+newtype BS = BS BS.ByteString+ deriving (Hashable, Binary, Eq)++instance NFData BS where+ -- some versions of ByteString do not have NFData instances, but seq is equivalent+ -- for a strict bytestring. Therefore, we write our own instance.+ rnf (BS x) = x `seq` ()+++-- | UTF8 ByteString+newtype BSU = BSU BS.ByteString+ deriving (Hashable, Binary, Eq)++instance NFData BSU where+ rnf (BSU x) = x `seq` ()++++pack :: String -> BS+pack = pack_ . BS.pack++unpack :: BS -> String+unpack = BS.unpack . unpack_++pack_ :: BS.ByteString -> BS+pack_ = BS++unpack_ :: BS -> BS.ByteString+unpack_ (BS x) = x++packU :: String -> BSU+packU = packU_ . UTF8.fromString++unpackU :: BSU -> String+unpackU = UTF8.toString . unpackU_++unpackU_ :: BSU -> BS.ByteString+unpackU_ (BSU x) = x++packU_ :: BS.ByteString -> BSU+packU_ = BSU++requireU :: BSU -> Bool+requireU = BS.any (>= 0x80) . unpackU_
Examples/Ninja/Main.hs view
@@ -39,3 +39,10 @@ assertNonSpace (obj "out3.2") "g4++++i1" assertNonSpace (obj "out3.3") "g4++++i1" assertNonSpace (obj "out3.4") "g4+++s1+s2"++ run "-f../../Examples/Ninja/test4.ninja out"+ assertExists $ obj "out.txt"+ assertExists $ obj "out2.txt"++ run "-f../../Examples/Ninja/test5.ninja"+ assertExists $ obj "output file"
+ Examples/Ninja/test4.ninja view
@@ -0,0 +1,9 @@+ +rule run + command = touch $out + +build ./out.txt: run + +build dir/../out2.txt: run + +build out: phony ./out.txt out2.txt
+ Examples/Ninja/test5.ninja view
@@ -0,0 +1,5 @@+ +rule run + command = touch $out + +build output$ file: run
Examples/Self/Main.hs view
@@ -19,7 +19,7 @@ main = shaken noTest $ \args obj -> do let moduleToFile ext xs = map (\x -> if x == '.' then '/' else x) xs <.> ext- want $ if null args then [obj "Main.exe"] else args+ want $ if null args then [obj "Main" <.> exe] else args -- fixup to cope with Cabal's generated files let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x@@ -38,7 +38,7 @@ flags <- ghcFlags $ GhcFlags () cmd "ghc" flags args - obj "/*.exe" *> \out -> do+ obj "Main" <.> exe *> \out -> do src <- readFileLines $ out -<.> "deps" let os = map (obj . moduleToFile "o") $ "Main":src need os@@ -85,4 +85,4 @@ packages = words $ "base transformers binary unordered-containers hashable time old-time bytestring " ++- "filepath directory process deepseq random"+ "filepath directory process deepseq random utf8-string"
Examples/Test/Basic.hs view
@@ -39,7 +39,14 @@ need [obj "configure",obj "once.txt"] liftIO $ appendFile (obj "install") "1" + phony "dummy" $ do+ liftIO $ appendFile (obj "dummy") "1" + obj "dummer.txt" *> \out -> do+ need ["dummy","dummy"]+ need ["dummy"]+ liftIO $ appendFile out "1"+ test build obj = do writeFile (obj "A.txt") "AAA" writeFile (obj "B.txt") "BBB"@@ -82,3 +89,17 @@ build ["!install"] assertContents (obj "configure") "111" assertContents (obj "install") "11"++ writeFile (obj "dummy.txt") ""+ build ["!dummy"]+ assertContents (obj "dummy") "1"+ build ["!dummy"]+ assertContents (obj "dummy") "11"+ build ["!dummy","!dummy"]+ assertContents (obj "dummy") "111"++ writeFile (obj "dummer.txt") ""+ build ["dummer.txt"]+ assertContents (obj "dummer.txt") "1"+ build ["dummer.txt"]+ assertContents (obj "dummer.txt") "11"
Examples/Test/Command.hs view
@@ -26,6 +26,10 @@ () <- cmd (EchoStderr False) "ghc --random" return "" + "triple" !> do+ (Exit exit, Stdout stdout, Stderr stderr) <- cmd "ghc --random"+ return $ show (exit, stdout, stderr) -- must force all three parts+ "pwd" !> do writeFileLines (obj "pwd space.hs") ["import System.Directory","main = putStrLn =<< getCurrentDirectory"] Stdout out <- cmd (Cwd $ obj "") "runhaskell" ["pwd space.hs"]@@ -58,3 +62,5 @@ build ["env"] assertContentsInfix (obj "env") "HELLO SHAKE"++ build ["triple"]
Examples/Test/Docs.hs view
@@ -29,7 +29,8 @@ obj "Part_*.hs" *> \out -> do need ["Examples/Test/Docs.hs"] -- so much of the generator is in this module src <- readFile' $ "dist/doc/html/shake/" ++ reps '_' '-' (drop 5 $ takeBaseName out) ++ ".html"- let f i (Stmt x) = restmt i $ map undefDots x+ let f i (Stmt x) | all whitelist x = []+ | otherwise = restmt i $ map undefDots x f i (Expr x) | x `elem` types = ["type Expr_" ++ show i ++ " = " ++ x] | otherwise = ["expr_" ++ show i ++ " = (" ++ undefDots x2 ++ ")" | let x2 = trim $ dropComment x, not $ whitelist x2] code = concat $ zipWith f [1..] (nub $ findCode src)@@ -38,6 +39,7 @@ ["{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, ExtendedDefaultRules, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}" ,"module " ++ takeBaseName out ++ "() where" ,"import Control.Concurrent"+ ,"import Control.Monad" ,"import Data.Char" ,"import Data.Data" ,"import Data.List"@@ -148,20 +150,24 @@ "newtype do MyFile.txt.digits excel a q value key gcc make contents tar ghc cabal clean _make distcc ghc " ++ ".. /./ /.. ./ // \\ ../ " ++ "ConstraintKinds GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " ++- ".make/i586-linux-gcc/output _make/.database foo/.. " ++- "-threaded Function extension $OUT $PATH xterm $TERM main opts result flagValues argValues "+ "NoProgress Error " +++ ".make/i586-linux-gcc/output _make/.database foo/.. file.src file.out " +++ "-threaded -rtsopts -I0 Function extension $OUT $PATH xterm $TERM main opts result flagValues argValues " = True whitelist x = x `elem` ["[Foo.hi, Foo.o]"+ ,"shake-progress" ,"main -j6" ,"main clean" ,"1m25s (15%)" ,"getPkgVersion $ GhcPkgVersion \"shake\"" ,"# command-name file-name"+ ,"ghc --make MyBuildSystem -rtsopts \"-with-rtsopts=-I0 -qg -qb\""+ ,"-qg -qb" ] types = words $ "MVar IO Monad Monoid String FilePath Data [String] Eq Typeable Char ExitCode " ++- "Action Resource Assume FilePattern Verbosity Rules Rule CmdOption CmdResult"+ "Action Resource Assume FilePattern Verbosity Rules Rule CmdOption CmdResult Int Double" dupes = words "main progressSimple rules"
Examples/Test/Errors.hs view
@@ -45,7 +45,12 @@ catcher "exception1" actionOnException True catcher "exception2" actionOnException False + res <- newResource "resource_name" 1+ obj "resource" *> \out -> do+ withResource res 1 $+ need ["resource-dep"] + test build obj = do let crash args parts = do res <- try $ build $ "--quiet" : args@@ -78,3 +83,5 @@ assertContents (obj "exception1") "1" build ["exception2"] assertContents (obj "exception2") "0"++ crash ["resource"] ["cannot currently call apply","withResource","resource_name"]
Examples/Test/Files.hs view
@@ -8,23 +8,31 @@ main = shaken test $ \args obj -> do- want $ map obj ["even.txt","odd.txt"]+ let fun = "@" `elem` args+ let rest = delete "@" args+ want $ map obj $ if null rest then ["even.txt","odd.txt"] else rest - let deps = map obj ["even.txt","odd.txt"]- let def | "fun" `elem` args = (?>>) (\x -> if x `elem` deps then Just deps else Nothing)- | otherwise = (*>>) deps+ -- Since ?>> and *>> are implemented separately we test everything in both modes+ let deps ?*>> act | fun = (\x -> if x `elem` deps then Just deps else Nothing) ?>> act+ | otherwise = deps *>> act - def $ \[evens,odds] -> do+ map obj ["even.txt","odd.txt"] ?*>> \[evens,odds] -> do src <- readFileLines $ obj "numbers.txt" let (es,os) = partition even $ map read src writeFileLines evens $ map show es writeFileLines odds $ map show os + map obj ["dir1/out.txt","dir2/out.txt"] ?*>> \[a,b] -> do+ writeFile' a "a"+ writeFile' b "b" + test build obj = do- forM_ [[],["fun"]] $ \args -> do+ forM_ [[],["@"]] $ \args -> do let nums = unlines . map show writeFile (obj "numbers.txt") $ nums [1,2,4,5,2,3,1] build ("--sleep":args) assertContents (obj "even.txt") $ nums [2,4,2] assertContents (obj "odd.txt" ) $ nums [1,5,3,1]+ build ["clean"]+ build ["dir1/out.txt"]
Examples/Test/Lint.hs view
@@ -46,6 +46,12 @@ writeFile' (obj "createonce") "Y" writeFile' out "" + obj "listing" *> \out -> do+ writeFile' (out <.> "ls1") ""+ getDirectoryFiles (obj "") ["//*.ls*"]+ writeFile' (out <.> "ls2") ""+ writeFile' out ""+ obj "existance" *> \out -> do Development.Shake.doesFileExist $ obj "exists" writeFile' (obj "exists") ""@@ -64,6 +70,8 @@ crash ["changedir"] ["current directory has changed"] build ["cdir.1","cdir.2","-j1"] build ["--clean","cdir.1","pause.2","-j1"]- crash ["--clean","cdir.1","pause.2","-j2"] ["current directory has changed"]- crash ["existance"] ["changed since being built"]- crash ["createtwice"] ["changed since being built"]+ crash ["--clean","cdir.1","pause.2","-j2"] ["before building output/lint/","current directory has changed"]+ crash ["existance"] ["changed since being depended upon"]+ crash ["createtwice"] ["changed since being depended upon"]+ crash ["listing"] ["changed since being depended upon","output/lint"]+ crash ["--clean","listing","existance"] ["changed since being depended upon"]
Examples/Test/Progress.hs view
@@ -1,8 +1,11 @@+{-# LANGUAGE DeriveDataTypeable #-} module Examples.Test.Progress(main) where import Development.Shake.Progress+import Development.Shake.Classes import Examples.Util+import qualified Control.Exception as E import Data.IORef import Data.Monoid import Data.Char@@ -14,6 +17,10 @@ -- | Given a list of todo times, get out a list of how long is predicted prog = progEx 10000000000000000 +data MyException = MyException deriving (Show, Typeable)+instance E.Exception MyException++ progEx :: Double -> [Double] -> IO [Double] progEx mxDone todo = do let resolution = 10000 -- Use resolution to get extra detail on the numbers@@ -21,14 +28,15 @@ pile <- newIORef $ tail $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done let get = do a <- readIORef pile case a of- [] -> return mempty{isRunning=False}+ [] -> E.throw MyException x:xs -> do writeIORef pile xs; return x out <- newIORef [] let put x = do let (mins,secs) = break (== 'm') $ takeWhile (/= '(') x let f x = let y = filter isDigit x in if null y then 0/0 else read y modifyIORef out (++ [(if null secs then f mins else f mins * 60 + f secs) / resolution])- progressDisplayTester resolution put get+ -- we abort by killing the thread, but then catch the abort and resume normally+ E.catch (progressDisplayTester resolution put get) $ \MyException -> return () fmap (take $ length todo) $ readIORef out
+ Examples/Test/Throttle.hs view
@@ -0,0 +1,34 @@++module Examples.Test.Throttle(main) where++import Development.Shake+import Development.Shake.Util+import Development.Shake.FilePath+import Examples.Util+import Control.Monad+++main = shaken test $ \args obj -> do+ res <- newThrottle "test" 2 0.2+ want $ map obj ["file1.1","file2.1","file3.2","file4.1","file5.2"]+ obj "*.*" *> \out -> do+ withResource res (read $ drop 1 $ takeExtension out) $ return ()+ writeFile' out ""++test build obj = do+ forM_ [[],["-j8"]] $ \flags -> do+ -- we are sometimes over the window if the machine is "a bit loaded" at some particular time+ -- therefore we rerun the test three times, and only fail if it fails on all of them+ flip loop 3 $ \i -> do+ build ["clean"]+ (s, _) <- duration $ build []+ -- the 0.1s cap is a guess at an upper bound for how long everything else should take+ -- and should be raised on slower machines+ let good = s >= 0.6 && s < 0.7+ if good then return $ Right ()+ else if i > 1 then do+ putStrLn $ "Throttle failed (took " ++ show s ++ "s), retrying"+ return $ Left (i-1)+ else do+ assert False $ "Bad throttling, expected to take 0.6s + computation time (cap of 0.1s), took " ++ show s ++ "s (three times in a row)"+ return $ Right ()
+ Examples/Test/Unicode.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Examples.Test.Unicode(main) where++import Development.Shake+import Development.Shake.FilePath+import Examples.Util+import Control.Monad+import System.Directory(createDirectoryIfMissing)+++-- | Decode a dull ASCII string to certain unicode points, necessary because+-- withArgs (even the UTF8 version) throws an encoding error on the > 256 code points+decode :: String -> String+decode ('e':'^':xs) = '\xEA' : decode xs -- Latin Small Letter E With Circumflex+decode (':':')':xs) = '\x263A' : decode xs -- White Smiling Face+decode (x:xs) = x : decode xs+decode [] = []+++main = shaken test $ \xs obj -> do+ let pre:args = map decode xs+ want $ map obj args++ obj (pre ++ "dir/*") *> \out -> do+ let src = takeDirectory (takeDirectory out) </> takeFileName out+ copyFile' src out++ obj (pre ++ ".out") *> \out -> do+ a <- readFile' $ obj $ pre ++ "dir" </> pre <.> "source"+ b <- readFile' $ obj pre <.> "multi1"+ writeFile' out $ a ++ b++ map obj ["*.multi1","*.multi2"] *>> \[m1,m2] -> do+ b <- doesFileExist $ m1 -<.> "exist"+ writeFile' m1 $ show b+ writeFile' m2 $ show b+++test build obj = {- handle (\e -> print (e :: SomeException) >> error "dead") $ -} do+ build ["clean"]+ -- IO.hSetEncoding IO.stdout IO.char8+ -- IO.hSetEncoding IO.stderr IO.char8+ forM_ ["normal","e^",":)","e^-:)"] $ \pre -> do+ createDirectoryIfMissing True $ obj ""+ let ext x = obj $ decode pre <.> x+ writeFile (ext "source") "x"+ build [pre,pre <.> "out","--sleep"]+ assertContents (ext "out") $ "x" ++ "False"+ writeFile (ext "source") "y"+ build [pre,pre <.> "out","--sleep"]+ assertContents (ext "out") $ "y" ++ "False"+ writeFile (ext "exist") ""+ build [pre,pre <.> "out"]+ assertContents (ext "out") $ "y" ++ "True"
Examples/Util.hs view
@@ -1,10 +1,10 @@ -module Examples.Util(module Examples.Util) where+module Examples.Util(sleep, module Examples.Util) where import Development.Shake+import Development.Shake.Util import Development.Shake.FilePath -import Control.Concurrent import Control.Monad import Data.Char import Data.List@@ -119,13 +119,24 @@ build [] -sleep :: Double -> IO ()-sleep x = threadDelay $ ceiling $ x * 1000000-- -- | Sleep long enough for the modification time resolution to catch up sleepFileTime :: IO () sleepFileTime = sleep 1+++sleepFileTimeCalibrate :: IO (IO ())+sleepFileTimeCalibrate = do+ let file = "output/calibrate"+ createDirectoryIfMissing True $ takeDirectory file+ mtime <- fmap maximum $ forM [1..3] $ \i -> fmap fst $ duration $ do+ writeFile file $ show i+ t1 <- getModificationTime file+ flip loop 0 $ \j -> do+ writeFile file $ show (i,j)+ t2 <- getModificationTime file+ return $ if t1 == t2 then Left $ j+1 else Right ()+ putStrLn $ "Longest file modification time lag was " ++ show mtime ++ "s"+ return $ sleep $ min 1 $ mtime * 2 removeFilesRandom :: FilePath -> IO Int
Test.hs view
@@ -10,8 +10,9 @@ import Development.Shake.Pool import Development.Shake.Timing import Development.Shake.FileTime+import Development.Shake.Util import qualified Data.ByteString.Char8 as BS-import Examples.Util(sleepFileTime)+import Examples.Util(sleepFileTime, sleepFileTimeCalibrate) import Control.Concurrent import qualified Examples.Tar.Main as Tar@@ -37,6 +38,8 @@ import qualified Examples.Test.Progress as Progress import qualified Examples.Test.Random as Random import qualified Examples.Test.Resources as Resources+import qualified Examples.Test.Throttle as Throttle+import qualified Examples.Test.Unicode as Unicode import qualified Start as Start @@ -51,7 +54,8 @@ ,"journal" * Journal.main, "lint" * Lint.main, "makefile" * Makefile.main ,"pool" * Pool.main, "random" * Random.main, "ninja" * Ninja.main ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main- ,"oracle" * Oracle.main, "progress" * Progress.main]+ ,"oracle" * Oracle.main, "progress" * Progress.main, "unicode" * Unicode.main+ ,"throttle" * Throttle.main] where (*) = (,) @@ -100,7 +104,7 @@ vars <- forM [a,b,c,d] $ \xs -> do mvar <- newEmptyMVar forkIO $ do- mapM_ getModTimeMaybe xs+ mapM_ (getModTimeMaybe . packU_) xs putMVar mvar () return $ takeMVar mvar sequence_ vars@@ -116,8 +120,9 @@ args <- getArgs let tests = filter ((/= "random") . fst) mains let (priority,normal) = partition (flip elem ["assume","journal"] . fst) tests+ yield <- sleepFileTimeCalibrate flip onException (putStrLn "TESTS FAILED") $- execute sleepFileTime [\pause -> withArgs (name:"test":drop 1 args) $ test pause | (name,test) <- priority ++ normal]+ execute yield [\pause -> withArgs (name:"test":drop 1 args) $ test pause | (name,test) <- priority ++ normal] -- | Execute each item in the list. They may yield (call the first parameter) in which case
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.8 build-type: Simple name: shake-version: 0.10.6+version: 0.10.7 license: BSD3 license-file: LICENSE category: Development@@ -82,8 +82,9 @@ binary, filepath, process >= 1.1,- unordered-containers (>= 0.1.4.3 && < 0.2) || (>= 0.2.1 && < 0.3),+ unordered-containers >= 0.2.1 && < 0.3, bytestring,+ utf8-string >= 0.3, time, random, transformers >= 0.2 && < 0.4,@@ -93,7 +94,7 @@ cpp-options: -DPORTABLE else if !os(windows)- build-depends: unix >= 2.5.1+ build-depends: unix >= 2.6 exposed-modules: Development.Shake@@ -115,24 +116,25 @@ Development.Shake.Files Development.Shake.FileTime Development.Shake.Intern- Development.Shake.Locks Development.Shake.Oracle Development.Shake.Pool Development.Shake.Progress Development.Shake.Report Development.Shake.Rerun+ Development.Shake.Resource Development.Shake.Shake Development.Shake.Special Development.Shake.Storage Development.Shake.Timing Development.Shake.Types+ Development.Shake.Util Development.Shake.Value Paths_shake executable shake main-is: Main.hs- ghc-options: -threaded+ ghc-options: -threaded -rtsopts "-with-rtsopts=-I0 -qg -qb" build-depends: base == 4.*, old-time,@@ -140,9 +142,10 @@ hashable >= 1.1.2.3 && < 1.3, binary, filepath,- process,- unordered-containers (>= 0.1.4.3 && < 0.2) || (>= 0.2.1 && < 0.3),+ process >= 1.1,+ unordered-containers >= 0.2.1 && < 0.3, bytestring,+ utf8-string >= 0.3, time, random, transformers >= 0.2 && < 0.4,@@ -152,7 +155,7 @@ cpp-options: -DPORTABLE else if !os(windows)- build-depends: unix >= 2.5.1+ build-depends: unix >= 2.6 other-modules: Development.Make.All@@ -173,7 +176,7 @@ buildable: True else buildable: False- ghc-options: -threaded+ ghc-options: -threaded -rtsopts build-depends: base == 4.*, old-time,@@ -181,9 +184,10 @@ hashable >= 1.1.2.3 && < 1.3, binary, filepath,- process,- unordered-containers (>= 0.1.4.3 && < 0.2) || (>= 0.2.1 && < 0.3),+ process >= 1.1,+ unordered-containers >= 0.2.1 && < 0.3, bytestring,+ utf8-string >= 0.3, time, random, transformers >= 0.2 && < 0.4,@@ -193,7 +197,7 @@ cpp-options: -DPORTABLE else if !os(windows)- build-depends: unix >= 2.5.1+ build-depends: unix >= 2.6 other-modules: Development.Make.All@@ -228,4 +232,6 @@ Examples.Test.Progress Examples.Test.Random Examples.Test.Resources+ Examples.Test.Throttle+ Examples.Test.Unicode Start