shake 0.13.2 → 0.13.3
raw patch · 160 files changed
+4407/−3411 lines, 160 files
Files
- CHANGES.txt +25/−0
- Development/Make/All.hs +3/−7
- Development/Ninja/All.hs +14/−12
- Development/Ninja/Lexer.hs +5/−5
- Development/Ninja/Parse.hs +4/−2
- Development/Shake.hs +1/−1
- Development/Shake/Args.hs +43/−3
- Development/Shake/ByteString.hs +14/−5
- Development/Shake/Classes.hs +0/−1
- Development/Shake/Command.hs +5/−3
- Development/Shake/Config.hs +10/−2
- Development/Shake/Core.hs +89/−63
- Development/Shake/Database.hs +75/−69
- Development/Shake/Demo.hs +127/−0
- Development/Shake/Derived.hs +18/−1
- Development/Shake/FilePath.hs +7/−7
- Development/Shake/Monad.hs +121/−0
- Development/Shake/Pool.hs +39/−44
- Development/Shake/Profile.hs +90/−0
- Development/Shake/Progress.hs +105/−30
- Development/Shake/Report.hs +0/−115
- Development/Shake/Resource.hs +77/−85
- Development/Shake/Rules/File.hs +10/−2
- Development/Shake/Storage.hs +1/−0
- Development/Shake/Types.hs +14/−8
- Examples/C/Main.hs +0/−28
- Examples/C/constants.c +0/−7
- Examples/C/constants.h +0/−1
- Examples/C/main.c +0/−8
- Examples/MakeTutor/Makefile +0/−17
- Examples/MakeTutor/hellofunc.c +0/−9
- Examples/MakeTutor/hellomake.c +0/−8
- Examples/MakeTutor/hellomake.h +0/−5
- Examples/Ninja/Main.hs +0/−72
- Examples/Ninja/compdb.ninja +0/−45
- Examples/Ninja/compdb.output +0/−17
- Examples/Ninja/lint.ninja +0/−13
- Examples/Ninja/nocreate.ninja +0/−5
- Examples/Ninja/test1.ninja +0/−5
- Examples/Ninja/test2.ninja +0/−8
- Examples/Ninja/test3-inc.ninja +0/−3
- Examples/Ninja/test3-sub.ninja +0/−6
- Examples/Ninja/test3-unix.ninja +0/−3
- Examples/Ninja/test3-win.ninja +0/−3
- Examples/Ninja/test3.ninja +0/−21
- Examples/Ninja/test4.ninja +0/−9
- Examples/Ninja/test5.ninja +0/−5
- Examples/Self/Main.hs +0/−86
- Examples/Tar/Main.hs +0/−13
- Examples/Tar/list.txt +0/−3
- Examples/Test/Assume.hs +0/−45
- Examples/Test/Basic.hs +0/−124
- Examples/Test/Benchmark.hs +0/−21
- Examples/Test/Cache.hs +0/−39
- Examples/Test/Command.hs +0/−60
- Examples/Test/Config.hs +0/−41
- Examples/Test/Digest.hs +0/−78
- Examples/Test/Directory.hs +0/−109
- Examples/Test/Docs.hs +0/−264
- Examples/Test/Errors.hs +0/−96
- Examples/Test/FilePath.hs +0/−96
- Examples/Test/FilePattern.hs +0/−61
- Examples/Test/Files.hs +0/−39
- Examples/Test/Journal.hs +0/−44
- Examples/Test/Lint.hs +0/−119
- Examples/Test/Makefile.hs +0/−24
- Examples/Test/Manual.hs +0/−24
- Examples/Test/Oracle.hs +0/−76
- Examples/Test/OrderOnly.hs +0/−41
- Examples/Test/Pool.hs +0/−81
- Examples/Test/Progress.hs +0/−75
- Examples/Test/Random.hs +0/−149
- Examples/Test/Resources.hs +0/−33
- Examples/Test/Throttle.hs +0/−34
- Examples/Test/Unicode.hs +0/−61
- Examples/Test/Util.hs +0/−18
- Examples/Test/Verbosity.hs +0/−39
- Examples/Util.hs +0/−202
- General/Base.hs +97/−85
- General/Bilist.hs +33/−0
- General/Cleanup.hs +35/−0
- General/Concurrent.hs +106/−0
- General/RAW.hs +0/−96
- General/Template.hs +30/−0
- README.md +14/−1
- Test.hs +38/−40
- Test/Assume.hs +45/−0
- Test/Basic.hs +132/−0
- Test/Benchmark.hs +21/−0
- Test/C.hs +28/−0
- Test/C/constants.c +7/−0
- Test/C/constants.h +1/−0
- Test/C/main.c +8/−0
- Test/Cache.hs +39/−0
- Test/Command.hs +60/−0
- Test/Config.hs +57/−0
- Test/Digest.hs +78/−0
- Test/Directory.hs +109/−0
- Test/Docs.hs +266/−0
- Test/Errors.hs +120/−0
- Test/FilePath.hs +96/−0
- Test/FilePattern.hs +61/−0
- Test/Files.hs +39/−0
- Test/Journal.hs +44/−0
- Test/Lint.hs +119/−0
- Test/Live.hs +29/−0
- Test/MakeTutor/Makefile +17/−0
- Test/MakeTutor/hellofunc.c +9/−0
- Test/MakeTutor/hellomake.c +8/−0
- Test/MakeTutor/hellomake.h +5/−0
- Test/Makefile.hs +24/−0
- Test/Manual.hs +24/−0
- Test/Monad.hs +89/−0
- Test/Ninja.hs +87/−0
- Test/Ninja/compdb.ninja +45/−0
- Test/Ninja/compdb.output +17/−0
- Test/Ninja/lint.ninja +13/−0
- Test/Ninja/nocreate.ninja +5/−0
- Test/Ninja/test1.ninja +5/−0
- Test/Ninja/test2.ninja +8/−0
- Test/Ninja/test3-inc.ninja +3/−0
- Test/Ninja/test3-sub.ninja +6/−0
- Test/Ninja/test3-unix.ninja +3/−0
- Test/Ninja/test3-win.ninja +3/−0
- Test/Ninja/test3.ninja +21/−0
- Test/Ninja/test4.ninja +9/−0
- Test/Ninja/test5.ninja +5/−0
- Test/Ninja/test6-inc.ninja +1/−0
- Test/Ninja/test6-sub.ninja +1/−0
- Test/Ninja/test6.ninja +3/−0
- Test/Oracle.hs +76/−0
- Test/OrderOnly.hs +41/−0
- Test/Pool.hs +68/−0
- Test/Progress.hs +63/−0
- Test/Progress/self-clean-j2.prog +62/−0
- Test/Progress/self-rebuild-j2.prog +56/−0
- Test/Progress/self-zero-j2.prog +57/−0
- Test/Random.hs +139/−0
- Test/Resources.hs +33/−0
- Test/Self.hs +86/−0
- Test/Tar.hs +13/−0
- Test/Tar/list.txt +3/−0
- Test/Throttle.hs +29/−0
- Test/Type.hs +211/−0
- Test/Unicode.hs +61/−0
- Test/Util.hs +20/−0
- Test/Verbosity.hs +39/−0
- docs/Manual.md +7/−7
- docs/Ninja.md +1/−1
- docs/Why.md +2/−2
- docs/manual/Build.hs +1/−0
- docs/manual/constants.c +1/−1
- docs/manual/main.c +2/−2
- html/profile.html +169/−0
- html/progress.html +47/−0
- html/report.html +0/−170
- html/shake-logic.js +1/−1
- html/shake-progress.js +41/−0
- html/shake-ui.js +1/−0
- shake.cabal +57/−47
CHANGES.txt view
@@ -1,5 +1,30 @@ Changelog for Shake +0.13.3+ Ensure you wait until the progress thread cleans up+ Add --demo mode+ Add --progress=record and --progress=replay+ Add -j to run with one thread per processor+ Fix progress reporting to work even on the first run+ Apply abbreviations to staunch failure messages+ Fix failure progress messages during staunch mode+ #165, make |*> matching with simple files much faster+ Add toStandard to the FilePath module+ #130, support msvc_deps_prefix in Ninja+ #157, allow variable substitution in include/subninja statements+ #147, add the version in the profile reports+ #147, add --numeric-version flag+ #28, switch to continuation passing style, uses far less threads+ #156, add readConfigFileWithEnv for configs with an initial env+ #129, fix processor count detection on Mac with -threaded+ #155, add --live and shakeLiveFiles+ #153, handle escaped spaces in parseMakefile+ #152, fix typo in the manual+ Add copyFileChanged+ Fix the leaf column in profile reports+ Add Maybe instances for cmd arguments+ Add a --profile flag (alias for --report)+ Switch to an underlying continuation monad 0.13.2 #95, ensure progress never gets corrupted #124, add a profile report demo
Development/Make/All.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, PatternGuards, CPP #-} +{-# LANGUAGE RecordWildCards, PatternGuards #-} module Development.Make.All(runMakefile) where @@ -10,6 +10,7 @@ import Development.Make.Rules import Development.Make.Type import qualified System.Directory as IO +import General.Base import Data.List import Data.Maybe import Control.Arrow @@ -120,12 +121,7 @@ defaultEnv :: IO Env defaultEnv = do -#if __GLASGOW_HASKELL__ >= 706 - exePath <- getExecutablePath -#else - exePath <- getProgName -#endif - + exePath <- getExePath env <- getEnvironment cur <- IO.getCurrentDirectory return $ newEnv $
Development/Ninja/All.hs view
@@ -53,13 +53,13 @@ return $ Just $ do needDeps <- return $ needDeps ninja -- partial application phonys <- return $ Map.fromList phonys - singles <- return $ Map.fromList $ map (first normalise) singles - multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map normalise) multiples, x <- xs] + singles <- return $ Map.fromList $ map (first filepathNormalise) singles + multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map filepathNormalise) multiples, x <- xs] rules <- return $ Map.fromList rules pools <- fmap Map.fromList $ forM ((BS.pack "console",1):pools) $ \(name,depth) -> fmap ((,) name) $ newResource (BS.unpack name) depth - action $ needBS $ map normalise $ concatMap (resolvePhony phonys) $ + action $ needBS $ map filepathNormalise $ concatMap (resolvePhony phonys) $ if not $ null args then map BS.pack args else if not $ null defaults then defaults else Map.keys singles ++ Map.keys multiples @@ -88,8 +88,8 @@ build :: (Build -> [Str] -> Action ()) -> Map.HashMap Str [Str] -> Map.HashMap Str Rule -> Map.HashMap Str Resource -> [Str] -> Build -> Action () build needDeps phonys rules pools out build@Build{..} = do - needBS $ map normalise $ concatMap (resolvePhony phonys) $ depsNormal ++ depsImplicit - orderOnlyBS $ map normalise $ concatMap (resolvePhony phonys) depsOrderOnly + needBS $ map filepathNormalise $ concatMap (resolvePhony phonys) $ depsNormal ++ depsImplicit + orderOnlyBS $ map filepathNormalise $ concatMap (resolvePhony phonys) depsOrderOnly case Map.lookup ruleName rules of Nothing -> error $ "Ninja rule named " ++ BS.unpack ruleName ++ " is missing, required to build " ++ BS.unpack (BS.unwords out) Just Rule{..} -> do @@ -118,7 +118,9 @@ let (cmdOpts, cmdProg, cmdArgs) = toCommand commandline if deps == "msvc" then do Stdout stdout <- withPool $ command cmdOpts cmdProg cmdArgs - needDeps build $ map normalise $ parseShowIncludes $ BS.pack stdout + prefix <- liftIO $ fmap (fromMaybe $ BS.pack "Note: including file: ") $ + askEnv env $ BS.pack "msvc_deps_prefix" + needDeps build $ map filepathNormalise $ parseShowIncludes prefix $ BS.pack stdout else withPool $ command_ cmdOpts cmdProg cmdArgs when (depfile /= "") $ do @@ -164,7 +166,7 @@ allDependencies rule = f Set.empty [] [rule] where f seen [] [] = [] - f seen [] (x:xs) = f seen (map normalise $ depsNormal x ++ depsImplicit x ++ depsOrderOnly x) xs + f seen [] (x:xs) = f seen (map filepathNormalise $ depsNormal x ++ depsImplicit x ++ depsOrderOnly x) xs f seen (x:xs) rest | x `Set.member` seen = f seen xs rest | otherwise = x : f (Set.insert x seen) xs (maybeToList (Map.lookup x builds) ++ rest) @@ -182,10 +184,11 @@ return res -parseShowIncludes :: Str -> [FileStr] -parseShowIncludes out = [y | x <- BS.lines out, bsNote `BS.isPrefixOf` x - , let y = BS.dropWhile isSpace $ BS.drop (BS.length bsNote) x - , not $ isSystemInclude y] +parseShowIncludes :: Str -> Str -> [FileStr] +parseShowIncludes prefix out = + [y | x <- BS.lines out, prefix `BS.isPrefixOf` x + , let y = BS.dropWhile isSpace $ BS.drop (BS.length prefix) x + , not $ isSystemInclude y] -- Dodgy, but ported over from the original Ninja isSystemInclude :: FileStr -> Bool @@ -193,7 +196,6 @@ where tx = BS8.map (\c -> if c >= 97 then c - 32 else c) x -- optimised toUpper that only cares about letters and spaces -bsNote = BS.pack "Note: including file:" bsProgFiles = BS.pack "PROGRAM FILES" bsVisStudio = BS.pack "MICROSOFT VISUAL STUDIO"
Development/Ninja/Lexer.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, CPP #-}+{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -O2 #-} -- {-# OPTIONS_GHC -ddump-simpl #-} @@ -81,8 +81,8 @@ data Lexeme = LexBind Str Expr -- [indent]foo = bar | LexBuild [Expr] Str [Expr] -- build foo: bar | baz || qux (| and || are represented as Expr)- | LexInclude Str -- include file- | LexSubninja Str -- include file+ | LexInclude Expr -- include file+ | LexSubninja Expr -- include file | LexRule Str -- rule name | LexPool Str -- pool name | LexDefault [Expr] -- default foo bar@@ -158,8 +158,8 @@ lexxBind _ x = error $ show ("parse failed when parsing binding", take0 100 x) lexxFile ctor x- | (file,rest) <- splitLineCont x- = ctor file : lexerLoop rest+ | (exp,rest) <- lexxExpr False False $ dropSpace x+ = ctor exp : lexerLoop rest lexxName ctor x | (name,rest) <- splitLineCont x
Development/Ninja/Parse.hs view
@@ -46,9 +46,11 @@ LexPool name -> do depth <- getDepth env binds return ninja{pools = (name, depth) : pools} - LexInclude file -> + LexInclude expr -> do + file <- askExpr env expr parseFile (BS.unpack file) env ninja - LexSubninja file -> do + LexSubninja expr -> do + file <- askExpr env expr e <- scopeEnv env parseFile (BS.unpack file) e ninja LexDefine a b -> do
Development/Shake.hs view
@@ -110,7 +110,7 @@ CmdResult, CmdOption(..), addPath, addEnv, -- * Utility functions- copyFile',+ copyFile', copyFileChanged, readFile', readFileLines, writeFile', writeFileLines, writeFileChanged, removeFiles, removeFilesAfter,
Development/Shake/Args.hs view
@@ -5,10 +5,12 @@ import Paths_shake import Development.Shake.Types import Development.Shake.Core+import Development.Shake.Demo import Development.Shake.Rules.File import Development.Shake.FilePath import Development.Shake.Progress import Development.Shake.Shake+import General.Base import General.Timing import Control.Arrow@@ -110,6 +112,8 @@ (flagsExtra,flagsShake) = first concat $ unzip self assumeNew = [x | AssumeNew x <- flagsExtra] assumeOld = [x | AssumeOld x <- flagsExtra]+ progressReplays = [x | ProgressReplay x <- flagsExtra]+ progressRecords = [x | ProgressRecord x <- flagsExtra] changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra] printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra] shakeOpts = foldl' (flip ($)) baseOpts flagsShake@@ -127,6 +131,17 @@ showHelp else if Version `elem` flagsExtra then putStrLn $ "Shake build system, version " ++ showVersion version+ else if NumericVersion `elem` flagsExtra then+ putStrLn $ showVersion version+ else if Demo `elem` flagsExtra then+ demo+ else if not $ null progressReplays then do+ dat <- forM progressReplays $ \file -> do+ src <- readFile file+ return (file, map read $ lines src)+ forM_ (if null $ shakeReport shakeOpts then ["-"] else shakeReport shakeOpts) $ \file -> do+ putStrLn $ "Writing report to " ++ file+ writeProgressReport file dat else do when (Sleep `elem` flagsExtra) $ threadDelay 1000000 start <- getCurrentTime@@ -136,6 +151,19 @@ -- get the "html" directory so it caches with the current directory -- required only for debug code Just d -> bracket_ (getDataFileName "html" >> setCurrentDirectory d) (setCurrentDirectory curdir)+ shakeOpts <- if null progressRecords then return shakeOpts else do+ t <- offsetTime+ return shakeOpts{shakeProgress = \p -> do+ bracket+ (forkIO $ shakeProgress shakeOpts p)+ killThread+ $ const $ progressDisplay 1 (const $ return ()) $ do+ p <- p+ t <- t+ forM_ progressRecords $ \file -> do+ appendFile file $ show (t,p) ++ "\n"+ return p+ } (ran,res) <- redir $ do when printDirectory $ putStrLn $ "shake: In directory `" ++ curdir ++ "'" rules <- rules user files@@ -202,6 +230,7 @@ data Extra = ChangeDirectory FilePath | Version+ | NumericVersion | AssumeNew FilePath | AssumeOld FilePath | PrintDirectory Bool@@ -211,6 +240,9 @@ | NoTime | Exception | NoBuild+ | ProgressRecord FilePath+ | ProgressReplay FilePath+ | Demo deriving Eq @@ -232,6 +264,7 @@ ,no $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything." ,yes $ Option "" ["color","colour"] (NoArg $ Right ([Color], \s -> s{shakeOutput=outputColor (shakeOutput s)})) "Colorize the output." ,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information."+ ,no $ Option "" ["demo"] (NoArg $ Right ([Demo], id)) "Run in demo mode." ,yes $ Option "" ["digest"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeDigest})) "Files change when digest changes." ,yes $ Option "" ["digest-and"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigest})) "Files change when modtime and digest change." ,yes $ Option "" ["digest-and-input"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigestInput})) "Files change on modtime (and digest for inputs)."@@ -240,24 +273,26 @@ ,yes $ Option "" ["flush"] (intArg 1 "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds." ,yes $ Option "" ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata." ,no $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit."- ,yes $ Option "j" ["jobs"] (intArg 0 "jobs" "N" $ \i s -> s{shakeThreads=i}) "Allow N jobs/threads at once."+ ,yes $ Option "j" ["jobs"] (optIntArg 0 "jobs" "N" $ \i s -> s{shakeThreads=fromMaybe 0 i}) "Allow N jobs/threads at once [default CPUs]." ,yes $ Option "k" ["keep-going"] (noArg $ \s -> s{shakeStaunch=True}) "Keep going when some targets can't be made." ,yes $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=Just LintBasic}) "Perform limited validation after the run." ,yes $ Option "" ["lint-tracker"] (noArg $ \s -> s{shakeLint=Just LintTracker}) "Use tracker.exe to do validation." ,yes $ Option "" ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."+ ,yes $ Option "" ["live"] (OptArg (\x -> Right ([], \s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]})) "FILE") "List the files that are live [to live.txt]." ,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."+ ,no $ Option "" ["numeric-version"] (NoArg $ Right ([NumericVersion],id)) "Print just the version number and exit." ,no $ Option "o" ["old-file","assume-old"] (ReqArg (\x -> Right ([AssumeOld x],id)) "FILE") "Consider FILE to be very old and don't remake it." ,yes $ Option "" ["old-all"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Don't remake any files." ,yes $ Option "" ["assume-skip"] (noArg $ \s -> s{shakeAssume=Just AssumeSkip}) "Don't remake any files this run." ,yes $ Option "" ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."- ,yes $ Option "r" ["report"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]."+ ,yes $ Option "r" ["report","profile"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]." ,yes $ Option "" ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report." ,yes $ Option "" ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules." ,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything." ,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 1 "progress" "N" (\i s -> s{shakeProgress=prog $ fromMaybe 5 i})) "Show progress messages [every N secs, default 5]."+ ,yes $ Option "p" ["progress"] (progress $ optIntArg 1 "progress" "N" $ \i s -> s{shakeProgress=prog $ fromMaybe 5 i}) "Show progress messages [every N secs, 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."@@ -288,6 +323,11 @@ pairArg flag a f = flip ReqArg a $ \x -> case break (== '=') x of (a,'=':b) -> Right ([],f (a,b)) _ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument"++ progress (OptArg func msg) = flip OptArg msg $ \x -> case break (== '=') `fmap` x of+ Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id)+ Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id)+ _ -> func x outputDebug output Nothing = output outputDebug output (Just file) = \v msg -> do
Development/Shake/ByteString.hs view
@@ -1,15 +1,23 @@ -module Development.Shake.ByteString(parseMakefile, normalise, linesCR) where+module Development.Shake.ByteString(parseMakefile, filepathNormalise, linesCR) where import qualified Data.ByteString.Char8 as BS import qualified System.FilePath as Native import General.Base+import Data.Char import Data.List endsSlash :: BS.ByteString -> Bool endsSlash = BS.isSuffixOf (BS.singleton '\\') +wordsMakefile :: BS.ByteString -> [BS.ByteString]+wordsMakefile = f . BS.splitWith isSpace+ where+ f (x:xs) | BS.null x = f xs+ f (x:y:xs) | endsSlash x = BS.concat [BS.init x, BS.singleton ' ', y] : f xs+ f (x:xs) = x : f xs+ f [] = [] parseMakefile :: BS.ByteString -> [(BS.ByteString, [BS.ByteString])] parseMakefile = concatMap f . join . linesCR@@ -20,7 +28,7 @@ ([], y:ys) -> y : join ys (xs, y:ys) -> BS.unwords (map BS.init xs ++ [y]) : join ys - f x = [(a, BS.words $ BS.drop 1 b) | a <- BS.words a]+ f x = [(a, wordsMakefile $ BS.drop 1 b) | a <- wordsMakefile a] where (a,b) = BS.break (== ':') $ BS.takeWhile (/= '#') x @@ -35,9 +43,10 @@ | otherwise = Just (BS.last x, BS.init x) -normalise :: BS.ByteString -> BS.ByteString-normalise xs | isWindows, Just (a,xs) <- BS.uncons xs, sep a, Just (b,_) <- BS.uncons xs, sep b = '/' `BS.cons` f xs- | otherwise = f xs+filepathNormalise :: BS.ByteString -> BS.ByteString+filepathNormalise xs+ | isWindows, Just (a,xs) <- BS.uncons xs, sep a, Just (b,_) <- BS.uncons xs, sep b = '/' `BS.cons` f xs+ | otherwise = f xs where sep = Native.isPathSeparator f o = deslash o $ BS.concat $ (slash:) $ intersperse slash $ reverse $ (BS.empty:) $ g 0 $ reverse $ split $ o
Development/Shake/Classes.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | This module reexports the six necessary type classes that every 'Rule' type must support. -- You can use this module to define new rules without depending on the @binary@, @deepseq@ and @hashable@ packages.
Development/Shake/Command.hs view
@@ -10,7 +10,7 @@ -- The functions from this module are now available directly from "Development.Shake". -- You should only need to import this module if you are using the 'cmd' function in the 'IO' monad. module Development.Shake.Command(- command, command_, cmd,+ command, command_, cmd, CmdArguments, Stdout(..), Stderr(..), Exit(..), CmdResult, CmdOption(..), addPath, addEnv,@@ -317,10 +317,10 @@ cmdResult :: ([Result], [Result] -> a) instance CmdResult Exit where- cmdResult = ([ResultCode $ ExitSuccess], \[ResultCode x] -> Exit x)+ cmdResult = ([ResultCode ExitSuccess], \[ResultCode x] -> Exit x) instance CmdResult ExitCode where- cmdResult = ([ResultCode $ ExitSuccess], \[ResultCode x] -> x)+ cmdResult = ([ResultCode ExitSuccess], \[ResultCode x] -> x) instance CmdResult Stdout where cmdResult = ([ResultStdout ""], \[ResultStdout x] -> Stdout x)@@ -423,5 +423,7 @@ class Arg a where arg :: a -> [Either CmdOption String] instance Arg String where arg = map Right . words instance Arg [String] where arg = map Right+instance Arg (Maybe String) where arg = map Right . maybe [] words instance Arg CmdOption where arg = return . Left instance Arg [CmdOption] where arg = map Left+instance Arg (Maybe CmdOption) where arg = map Left . maybeToList
Development/Shake/Config.hs view
@@ -18,7 +18,7 @@ -- and use the values directly, or 'usingConfigFile' and 'getConfig' to track the configuration -- values, so they become build dependencies. module Development.Shake.Config(- readConfigFile,+ readConfigFile, readConfigFileWithEnv, usingConfigFile, usingConfig, getConfig ) where@@ -37,8 +37,16 @@ -- Config files use the Ninja lexical syntax: -- <http://martine.github.io/ninja/manual.html#_lexical_syntax> readConfigFile :: FilePath -> IO (Map.HashMap String String)-readConfigFile file = do+readConfigFile = readConfigFileWithEnv []+++-- | Read a config file with an initial environment, returning a list of the variables and their bindings.+-- Config files use the Ninja lexical syntax:+-- <http://martine.github.io/ninja/manual.html#_lexical_syntax>+readConfigFileWithEnv :: [(String, String)] -> FilePath -> IO (Map.HashMap String String)+readConfigFileWithEnv vars file = do env <- Ninja.newEnv+ mapM_ (uncurry (Ninja.addEnv env) . (UTF8.fromString *** UTF8.fromString)) vars Ninja.parse file env mp <- Ninja.fromEnv env return $ Map.fromList $ map (UTF8.toString *** UTF8.toString) $ Map.toList mp
Development/Shake/Core.hs view
@@ -42,15 +42,18 @@ import Development.Shake.Classes import Development.Shake.Pool import Development.Shake.Database+import Development.Shake.Monad import Development.Shake.Resource import Development.Shake.Value-import Development.Shake.Report+import Development.Shake.Profile import Development.Shake.Types import Development.Shake.Errors+import Development.Shake.Special import General.Timing import General.Base+import General.Concurrent+import General.Cleanup import General.String-import General.RAW ---------------------------------------------------------------------@@ -259,6 +262,7 @@ data Global = Global {globalDatabase :: Database ,globalPool :: Pool+ ,globalCleanup :: Cleanup ,globalTimestamp :: IO Time ,globalRules :: Map.HashMap TypeRep (RuleInfo Action) ,globalOutput :: Verbosity -> String -> IO ()@@ -291,18 +295,21 @@ deriving (Functor, Applicative, Monad, MonadIO) +actionBoom :: Bool -> Action a -> IO b -> Action a+actionBoom runOnSuccess act clean = do+ cleanup <- Action $ getsRO globalCleanup+ clean <- liftIO $ addCleanup cleanup $ void clean+ res <- Action $ catchRAW (fromAction act) $ \(e :: SomeException) -> liftIO (clean True) >> throwRAW e+ liftIO $ clean runOnSuccess+ return res+ -- | If an exception is raised by the 'Action', perform some 'IO'. actionOnException :: Action a -> IO b -> Action a-actionOnException act clean = Action $- catchRAW (fromAction act) (\(e :: SomeException) -> liftIO clean >> throwRAW e)-+actionOnException = actionBoom False -- | After an 'Action', perform some 'IO', even if there is an exception. actionFinally :: Action a -> IO b -> Action a-actionFinally act clean = do- res <- actionOnException act clean- liftIO clean- return res+actionFinally = actionBoom True -- | Internal main function (not exported publicly)@@ -325,7 +332,7 @@ res <- try act case res of Left err -> do- let named = maybe "unknown rule" shakeExceptionTarget . cast+ let named = maybe "" (abbreviate shakeAbbreviations . shakeExceptionTarget) . fromException atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ()) let msg = show err ++ "Continuing due to staunch mode, this error will be repeated later" when (shakeVerbosity >= Quiet) $ output Quiet msg@@ -342,28 +349,35 @@ ,("Got",Just now)] "" - progressThread <- newIORef Nothing+ progressAbort <- newIORef $ return () after <- newIORef [] absent <- newIORef []- let cleanup = do- flip whenJust killThread =<< readIORef progressThread+ shakeThreads <- if shakeThreads == 0 then getProcessorCount else return shakeThreads+ withCleanup $ \cleanup -> do+ _ <- addCleanup cleanup $ do+ join $ readIORef progressAbort when shakeTimings printTimings resetTimings -- so we don't leak memory- shakeThreads <- if shakeThreads == 0 then getProcessorCount else return shakeThreads- flip finally cleanup $ withCapabilities shakeThreads $ do withDatabase opts diagnostic $ \database -> do- tid <- forkIO $ shakeProgress $ do- failure <- fmap (fmap fst) $ readIORef except- stats <- progress database- return stats{isFailure=failure}- writeIORef progressThread $ Just tid+ wait <- newBarrier+ tid <- forkIO $ flip finally (signalBarrier wait ()) $+ shakeProgress $ do+ failure <- fmap (fmap fst) $ readIORef except+ stats <- progress database+ return stats{isFailure=failure}+ writeIORef progressAbort $ do+ forkIO $ sleep 1 >> signalBarrier wait ()+ killThread tid+ waitBarrier wait+ let ruleinfo = createRuleinfo opts rs addTiming "Running rules" runPool (shakeThreads == 1) shakeThreads $ \pool -> do- let s0 = Global database pool start ruleinfo output opts diagnostic lint after absent+ let s0 = Global database pool cleanup start ruleinfo output opts diagnostic lint after absent let s1 = Local emptyStack shakeVerbosity Nothing [] 0 [] [] []- mapM_ (addPool pool . staunch . runAction s0 s1) (actions rs)+ forM_ (actions rs) $ \act -> do+ addPool pool $ runAction s0 s1 act $ \x -> staunch $ either throwIO return x when (isJust shakeLint) $ do addTiming "Lint checking"@@ -376,7 +390,15 @@ forM_ shakeReport $ \file -> do when (shakeVerbosity >= Normal) $ output Normal $ "Writing report to " ++ file- buildReport file report+ writeProfile file report+ when (shakeLiveFiles /= []) $ do+ addTiming "Listing live"+ live <- listLive database+ let liveFiles = [show k | k <- live, specialIsFileKey $ typeKey k]+ forM_ shakeLiveFiles $ \file -> do+ when (shakeVerbosity >= Normal) $+ output Normal $ "Writing live list to " ++ file+ (if file == "-" then putStr else writeFile file) $ unlines liveFiles maybe (return ()) (throwIO . snd) =<< readIORef except sequence_ . reverse =<< readIORef after @@ -406,8 +428,8 @@ else throwIO $ ShakeException (last stk) stk $ SomeException e -runAction :: Global -> Local -> Action a -> IO a-runAction g l (Action x) = runRAW g l x+runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)+runAction g l (Action x) k = runRAW g l x k runAfter :: IO () -> Action ()@@ -440,29 +462,30 @@ applyKeyValue [] = return [] applyKeyValue ks = do global@Global{..} <- Action getRO- let exec stack k = try $ wrapStack (showStack globalDatabase stack) $ do- evaluate $ rnf k+ let exec stack k continue = do let s = Local {localVerbosity=shakeVerbosity globalOptions, localDepends=[], localStack=stack, localBlockApply=Nothing ,localDiscount=0, localTraces=[], localTrackAllows=[], localTrackUsed=[]} let top = showTopStack stack- globalLint $ "before building " ++ top- (dur,(res,Local{..})) <- duration $ runAction global s $ do+ time <- offsetTime+ runAction global s (do+ liftIO $ evaluate $ rnf k+ liftIO $ globalLint $ "before building " ++ top putWhen Chatty $ "# " ++ show k res <- runExecute globalRules k when (shakeLint globalOptions == Just LintTracker) trackCheckUsed- Action $ fmap ((,) res) getRW- globalLint $ "after building " ++ top- let ans = (res, reverse localDepends, dur - localDiscount, reverse localTraces)- evaluate $ rnf ans- return ans+ Action $ fmap ((,) res) getRW) $ \x -> case x of+ Left e -> (continue =<<) $ try $ wrapStack (showStack globalDatabase stack) $ throwIO e+ Right (res, Local{..}) -> do+ dur <- time+ globalLint $ "after building " ++ top+ let ans = (res, reverse localDepends, dur - localDiscount, reverse localTraces)+ evaluate $ rnf ans+ continue $ Right ans stack <- Action $ getsRW localStack- res <- liftIO $ build globalPool globalDatabase (Ops (runStored globalRules) (runEqual globalRules) exec) stack ks- case res of- Left err -> throw err- Right (dur, dep, vs) -> do- Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}- return vs+ (dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (Ops (runStored globalRules) (runEqual globalRules) exec) stack ks+ Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}+ return vs -- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,@@ -712,20 +735,16 @@ -- | Run an action which uses part of a finite resource. For more details see 'Resource'. -- You cannot depend on a rule (e.g. 'need') while a resource is held. withResource :: Resource -> Int -> Action a -> Action a-withResource r i act = Action $ do- Global{..} <- getRO- act <- evalRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) act- join $ liftIO $ bracket_- (do res <- acquireResource r i- case res of- Nothing -> globalDiagnostic $ show r ++ " acquired " ++ show i ++ " with no wait"- Just wait -> do- globalDiagnostic $ show r ++ " waiting to acquire " ++ show i- blockPool globalPool $ fmap ((,) False) wait- globalDiagnostic $ show r ++ " acquired " ++ show i ++ " after waiting")- (do releaseResource r i- globalDiagnostic $ show r ++ " released " ++ show i)- act+withResource r i act = do+ Global{..} <- Action getRO+ liftIO $ globalDiagnostic $ show r ++ " waiting to acquire " ++ show i+ Action $ captureRAW $ \continue -> acquireResource r globalPool i $ do+ globalDiagnostic $ show r ++ " acquired " ++ show i+ continue $ Right ()+ res <- Action $ tryRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) act+ liftIO $ releaseResource r globalPool i+ liftIO $ globalDiagnostic $ show r ++ " released " ++ show i+ Action $ either throwRAW return res -- | Run an action which uses part of several finite resources. Acquires the resources in a stable@@ -744,32 +763,35 @@ -- Most people should use 'newCache' instead. newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v) newCacheIO act = do- var {- :: Var (Map k (Barrier (Either SomeException ([Depends],v)))) -} <- newVar Map.empty+ var {- :: Var (Map k (Fence (Either SomeException ([Depends],v)))) -} <- newVar Map.empty return $ \key -> do join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of Just bar -> return $ (,) mp $ do- res <- liftIO $ waitBarrierMaybe bar+ res <- liftIO $ testFence bar res <- case res of- Nothing -> do pool <- Action $ getsRO globalPool; liftIO $ blockPool pool $ fmap ((,) False) $ waitBarrier bar Just res -> return res+ Nothing -> do+ pool <- Action $ getsRO globalPool+ Action $ captureRAW $ \k -> waitFence bar $ \v ->+ addPool pool $ k $ Right v case res of Left err -> Action $ throwRAW err Right (deps,v) -> do Action $ modifyRW $ \s -> s{localDepends = deps ++ localDepends s} return v Nothing -> do- bar <- newBarrier+ bar <- newFence return $ (,) (Map.insert key bar mp) $ do pre <- Action $ getsRW localDepends res <- Action $ tryRAW $ fromAction $ act key case res of Left err -> do- liftIO $ signalBarrier bar $ Left (err :: SomeException)+ liftIO $ signalFence bar $ Left (err :: SomeException) Action $ throwRAW err Right v -> do post <- Action $ getsRW localDepends let deps = take (length post - length pre) post- liftIO $ signalBarrier bar (Right (deps, v))+ liftIO $ signalFence bar $ Right (deps, v) return v -- | Given an action on a key, produce a cached version that will execute the action at most once per key.@@ -799,8 +821,12 @@ -- | 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 depend on a rule (e.g. 'need') while the extra thread is executing.+-- If the rule blocks (e.g. calls 'withResource') then the extra thread may be used by some other action.+-- Only really suitable for calling 'cmd'/'command'. unsafeExtraThread :: Action a -> Action a unsafeExtraThread act = Action $ do- Global{..} <- getRO- act <- evalRAW $ fromAction act- join $ liftIO $ blockPool globalPool $ fmap ((,) False) act+ global@Global{..} <- getRO+ stop <- liftIO $ increasePool globalPool+ res <- tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act+ liftIO stop+ captureRAW $ \continue -> (if isLeft_ res then addPoolPriority else addPool) globalPool $ continue res
Development/Shake/Database.hs view
@@ -9,7 +9,7 @@ Ops(..), build, Depends, progress, Stack, emptyStack, topStack, showStack, showTopStack,- toReport, checkValid,+ toReport, checkValid, listLive ) where import Development.Shake.Classes@@ -20,8 +20,10 @@ import Development.Shake.Storage import Development.Shake.Types import Development.Shake.Special-import Development.Shake.Report+import Development.Shake.Profile+import Development.Shake.Monad import General.Base+import General.Concurrent import General.String import General.Intern as Intern @@ -83,7 +85,7 @@ instance NFData Trace where rnf (Trace a b c) = rnf a `seq` rnf b `seq` rnf c --- | Invariant: The database does not have any cycles when a Key depends on itself+-- | Invariant: The database does not have any cycles where a Key depends on itself data Database = Database {lock :: Lock ,intern :: IORef (Intern Key)@@ -168,35 +170,20 @@ newtype Depends = Depends {fromDepends :: [Id]} deriving (NFData) -listDepends :: Database -> Depends -> IO [Key]-listDepends Database{..} (Depends xs) =- withLock lock $ do- status <- readIORef status- return $ map (fst . fromJust . flip Map.lookup status) xs -lookupDependencies :: Database -> Key -> IO [Key]-lookupDependencies Database{..} k = do- withLock lock $ do- intern <- readIORef intern- status <- readIORef status- let Just i = Intern.lookup k intern- let Just (_, Ready r) = Map.lookup i status- return $ map (fst . fromJust . flip Map.lookup status) $ concat $ depends r-- data Ops = Ops {stored :: Key -> IO (Maybe Value)- -- ^ Given a Key and a Value from the database, check it still matches the value stored on disk+ -- ^ Given a Key, find the value stored on disk ,equal :: Key -> Value -> Value -> EqualCost -- ^ Given both Values, see if they are equal and how expensive that check was- ,execute :: Stack -> Key -> IO (Either SomeException (Value, [Depends], Duration, [Trace]))- -- ^ Given a chunk of stack (bottom element first), and a key, either raise an exception or successfully build it+ ,execute :: Stack -> Key -> Capture (Either SomeException (Value, [Depends], Duration, [Trace]))+ -- ^ Given a stack and a key, either raise an exception or successfully build it } -- | Return either an exception (crash), or (how much time you spent waiting, the value)-build :: Pool -> Database -> Ops -> Stack -> [Key] -> IO (Either SomeException (Duration,Depends,[Value]))-build pool Database{..} Ops{..} stack ks = do+build :: Pool -> Database -> Ops -> Stack -> [Key] -> Capture (Either SomeException (Duration,Depends,[Value]))+build pool Database{..} Ops{..} stack ks continue = do join $ withLock lock $ do is <- forM ks $ \k -> do is <- readIORef intern@@ -217,23 +204,23 @@ vs <- mapM (reduce stack) is let errs = [e | Error e <- vs] if all isReady vs then- return $ return $ Right (0, Depends is, [result r | Ready r <- vs])+ return $ continue $ Right (0, Depends is, [result r | Ready r <- vs]) else if not $ null errs then- return $ return $ Left $ head errs+ return $ continue $ Left $ head errs else do- wait <- newBarrier+ time <- offsetTime+ let done x = do+ case x of+ Left e -> addPoolPriority pool $ continue $ Left e+ Right v -> addPool pool $ do dur <- time; continue $ Right (dur, Depends is, v)+ return True waitFor (filter (isWaiting . snd) $ zip is vs) $ \finish i -> do s <- readIORef status- let done x = do signalBarrier wait x; return True case Map.lookup i s of- Just (_, Error e) -> done (True, Left e) -- on error make sure we immediately kick off our parent- Just (_, Ready{}) | finish -> done (False, Right [result r | i <- is, let Ready r = snd $ fromJust $ Map.lookup i s])+ Just (_, Error e) -> done $ Left e -- on error make sure we immediately kick off our parent+ Just (_, Ready{}) | finish -> done $ Right [result r | i <- is, let Ready r = snd $ fromJust $ Map.lookup i s] | otherwise -> return False- return $ do- (dur,res) <- duration $ blockPool pool $ waitBarrier wait- return $ case res of- Left e -> Left e- Right v -> Right (dur,Depends is,v)+ return $ return () where (#=) :: Id -> (Key, Status) -> IO Status i #= (k,v) = do@@ -281,34 +268,34 @@ run stack i k r = do w <- newWaiting r addPool pool $ do- let norm = do- res <- execute (addStack i k stack) k- return $ case res of+ let reply res = do+ ans <- withLock lock $ do+ ans <- i #= (k, res)+ runWaiting w+ return ans+ case ans of+ Ready r -> do+ diagnostic $ "result " ++ atom k ++ " = " ++ atom (result r)+ journal i (k, Loaded r) -- leave the DB lock before appending+ Error _ -> do+ diagnostic $ "result " ++ atom k ++ " = error"+ journal i (k, Missing)+ _ -> return ()+ let norm = execute (addStack i k stack) k $ \res ->+ reply $ case res of Left err -> Error err Right (v,deps,execution,traces) -> let c | Just r <- r, result r == v = changed r | otherwise = step in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..}- res <- case r of++ case r of Just r | assume == Just AssumeClean -> do- v <- stored k- case v of- Just v -> return $ Ready r{result=v}- Nothing -> norm+ v <- stored k+ case v of+ Just v -> reply $ Ready r{result=v}+ Nothing -> norm _ -> norm-- ans <- withLock lock $ do- ans <- i #= (k, res)- runWaiting w- return ans- case ans of- Ready r -> do- diagnostic $ "result " ++ atom k ++ " = " ++ atom (result r)- journal i (k, Loaded r) -- leave the DB lock before appending- Error _ -> do- diagnostic $ "result " ++ atom k ++ " = error"- journal i (k, Missing)- _ -> return () i #= (k, w) check :: Stack -> Id -> Key -> Result -> [[Id]] -> IO Status@@ -408,7 +395,7 @@ removeStep :: Map Id (Key, Result) -> Map Id (Key, Result) removeStep = Map.filter (\(k,_) -> k /= stepKey) -toReport :: Database -> IO [ReportEntry]+toReport :: Database -> IO [ProfileEntry] toReport Database{..} = do status <- fmap (removeStep . resultsOnly) $ readIORef status let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status@@ -418,18 +405,18 @@ steps = let xs = Set.toList $ Set.fromList $ concat [[changed, built] | (_,Result{..}) <- Map.elems status] in Map.fromList $ zip (sortBy (flip compare) xs) [0..] - f (k, Result{..}) = ReportEntry- {repName = show k- ,repBuilt = fromStep built- ,repChanged = fromStep changed- ,repDepends = mapMaybe (`Map.lookup` ids) (concat depends)- ,repExecution = fromFloat execution- ,repTraces = map fromTrace traces+ f (k, Result{..}) = ProfileEntry+ {prfName = show k+ ,prfBuilt = fromStep built+ ,prfChanged = fromStep changed+ ,prfDepends = mapMaybe (`Map.lookup` ids) (concat depends)+ ,prfExecution = fromFloat execution+ ,prfTraces = map fromTrace traces } where fromStep i = fromJust $ Map.lookup i steps- fromTrace (Trace a b c) = ReportTrace (unpack a) (fromFloat b) (fromFloat c)+ fromTrace (Trace a b c) = ProfileTrace (unpack a) (fromFloat b) (fromFloat c) fromFloat = fromRational . toRational- return $ [maybe (err "toReport") f $ Map.lookup i status | i <- order]+ return [maybe (err "toReport") f $ Map.lookup i status | i <- order] checkValid :: Database -> (Key -> IO (Maybe Value)) -> (Key -> Value -> Value -> EqualCost) -> [(Key, Key)] -> IO ()@@ -465,6 +452,29 @@ diagnostic "Validity/lint check passed" +listLive :: Database -> IO [Key]+listLive Database{..} = do+ diagnostic "Listing live keys"+ status <- readIORef status+ return [k | (k, Ready{}) <- Map.elems status]+++listDepends :: Database -> Depends -> IO [Key]+listDepends Database{..} (Depends xs) =+ withLock lock $ do+ status <- readIORef status+ return $ map (fst . fromJust . flip Map.lookup status) xs++lookupDependencies :: Database -> Key -> IO [Key]+lookupDependencies Database{..} k = do+ withLock lock $ do+ intern <- readIORef intern+ status <- readIORef status+ let Just i = Intern.lookup k intern+ let Just (_, Ready r) = Map.lookup i status+ return $ map (fst . fromJust . flip Map.lookup status) $ concat $ depends r++ --------------------------------------------------------------------- -- STORAGE @@ -505,10 +515,6 @@ lock <- newLock act Database{assume=shakeAssume opts,..} --instance BinaryWith Witness Step where- putWith _ x = put x- getWith _ = get instance BinaryWith Witness Result where putWith ws (Result x1 x2 x3 x4 x5 x6) = putWith ws x1 >> put x2 >> put x3 >> put (BinList $ map BinList x4) >> put (BinFloat x5) >> put (BinList x6)
+ Development/Shake/Demo.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | Demo tutorial, accessed with --demo+module Development.Shake.Demo(demo) where++import Paths_shake+import Development.Shake.Command+import General.Base++import Control.Exception as E+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Data.Version(showVersion)+import System.Directory+import System.Exit+import System.FilePath+import Development.Shake.FilePath(exe)+import System.IO+++demo :: IO ()+demo = do+ hSetBuffering stdout NoBuffering+ putStrLn $ "% Welcome to the Shake v" ++ showVersion version ++ " demo mode!"+ putStr $ "% Detecting machine configuration... "++ -- CONFIGURE++ manual <- getDataFileName "docs/manual"+ hasManual <- wrap $ doesDirectoryExist manual+ ghc <- findExecutable "ghc"+ gcc <- do+ v <- findExecutable "gcc"+ case v of+ Nothing | isWindows, Just ghc <- ghc -> do+ let dir = takeDirectory (takeDirectory ghc) </> "bin/mingw/gcc.exe"+ b <- wrap $ doesFileExist dir+ return $ if b then Just dir else Nothing+ _ -> return v+ shakeLib <- wrap $ fmap (not . null . words . fromStdout) (cmd "ghc-pkg list --simple-output shake")+ ninja <- findExecutable "ninja"+ putStrLn "done\n"++ let path = if isWindows then "%PATH%" else "$PATH"+ require (isJust ghc) $ "% You don't have 'ghc' on your " ++ path ++ ", which is required to run the demo."+ require (isJust gcc) $ "% You don't have 'gcc' on your " ++ path ++ ", which is required to run the demo."+ require shakeLib "% You don't have the 'shake' library installed with GHC, which is required to run the demo."+ require hasManual "% You don't have the Shake data files installed, which are required to run the demo."++ empty <- fmap (null . filter (not . all (== '.'))) $ getDirectoryContents "."+ dir <- if empty then getCurrentDirectory else do+ home <- getHomeDirectory+ dir <- getDirectoryContents home+ return $ home </> head (map ("shake-demo" ++) ("":map show [2..]) \\ dir)++ putStrLn $ "% The Shake demo uses an empty directory, OK to use:"+ putStrLn $ "% " ++ dir+ b <- yesNo+ require b "% Please create an empty directory to run the demo from, then run 'shake --demo' again."++ putStr "% Copying files... "+ createDirectoryIfMissing True dir+ forM_ ["Build.hs","main.c","constants.c","constants.h","build" <.> if isWindows then "bat" else "sh"] $ \file ->+ copyFile (manual </> file) (dir </> file)+ putStrLn "done"++ let pause = putStr "% Press ENTER to continue: " >> getLine+ let execute x = do+ putStrLn $ "% RUNNING: " ++ x+ cmd (Cwd dir) Shell x :: IO ()+ let build = if isWindows then "build" else "./build.sh"++ putStrLn "\n% [1/5] Building an example project with Shake."+ pause+ putStrLn $ "% RUNNING: cd " ++ dir+ execute build++ putStrLn "\n% [2/5] Running the produced example."+ pause+ execute $ "_build" </> "run" <.> exe++ putStrLn "\n% [3/5] Rebuilding an example project with Shake (nothing should change)."+ pause+ execute build++ putStrLn "\n% [4/5] Cleaning the build."+ pause+ execute $ build ++ " clean"++ putStrLn "\n% [5/5] Rebuilding with 2 threads and profiling."+ pause+ execute $ build ++ " -j2 --report --report=-"+ putStrLn "\n% See the profiling summary above, or look at the HTML profile report in"+ putStrLn $ "% " ++ dir </> "report.html"++ putStrLn "\n% Demo complete - all the examples can be run from:"+ putStrLn $ "% " ++ dir+ putStrLn "% For more info see http://www.shakebuild.com/"+ when (isJust ninja) $ do+ putStrLn "\n% PS. Shake can also execute Ninja build files"+ putStrLn "% For more info see http://www.shakebuild.com/ninja"++++-- | Require the user to press @y@ before continuing.+yesNo :: IO Bool+yesNo = do+ putStr $ "% [Y/N] (then ENTER): "+ x <- fmap (map toLower) getLine+ if "y" `isPrefixOf` x then+ return True+ else if "n" `isPrefixOf` x then+ return False+ else+ yesNo+++-- | Replace exceptions with 'False'.+wrap :: IO Bool -> IO Bool+wrap act = act `E.catch` \(_ :: SomeException) -> return False+++-- | Require a condition to be true, or exit with a message.+require :: Bool -> String -> IO ()+require b msg = unless b $ putStrLn msg >> exitFailure
Development/Shake/Derived.hs view
@@ -1,7 +1,7 @@ module Development.Shake.Derived( system', systemCwd, systemOutput,- copyFile',+ copyFile', copyFileChanged, readFile', readFileLines, writeFile', writeFileLines, writeFileChanged ) where@@ -17,6 +17,8 @@ import Development.Shake.Rules.File import Development.Shake.FilePath import Development.Shake.Types+import General.Base+import qualified Data.ByteString as BS checkExitCode :: String -> ExitCode -> Action ()@@ -88,6 +90,21 @@ need [old] putLoud $ "Copying from " ++ old ++ " to " ++ new liftIO $ copyFile old new+++-- | @copyFile' old new@ copies the existing file from @old@ to @new@, if the contents have changed.+-- The @old@ file will be tracked as a dependency.+copyFileChanged :: FilePath -> FilePath -> Action ()+copyFileChanged old new = do+ need [old]+ eq <- liftIO $ doesFileExist new &&^ do+ withBinaryFile old ReadMode $ \h1 -> withBinaryFile new ReadMode $ \h2 ->+ liftM2 (==) (hFileSize h1) (hFileSize h2) &&^+ liftM2 (==) (BS.hGetContents h1) (BS.hGetContents h2)+ when (not eq) $ do+ putLoud $ "Copying from " ++ old ++ " to " ++ new+ -- copyFile does a lot of clever stuff with permissions etc, so make sure we just reuse it+ liftIO $ copyFile old new -- | Read a file, after calling 'need'. The argument file will be tracked as a dependency.
Development/Shake/FilePath.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- | A module for 'FilePath' operations, to be used instead of "System.FilePath" -- when writing build systems. In build systems, when using the file name@@ -13,7 +12,7 @@ module System.FilePath, -- only search-path stuff dropDirectory1, takeDirectory1, normalise, (-<.>),- toNative, (</>), combine,+ toNative, toStandard, (</>), combine, exe ) where @@ -93,7 +92,12 @@ toNative :: FilePath -> FilePath toNative = map (\x -> if Native.isPathSeparator x then Native.pathSeparator else x) +-- | Convert all path separators to @/@, even on Windows.+toStandard :: FilePath -> FilePath+toStandard | Native.pathSeparators == [pathSeparator] = id+ | otherwise = map (\x -> if Native.isPathSeparator x then pathSeparator else x) + -- | Combine two file paths, an alias for 'combine'. (</>) :: FilePath -> FilePath -> FilePath (</>) = combine@@ -114,8 +118,4 @@ -- | The extension of executables, @\"exe\"@ on Windows and @\"\"@ otherwise. exe :: String-#ifdef mingw32_HOST_OS-exe = "exe"-#else-exe = ""-#endif+exe = if isWindows then "exe" else ""
+ Development/Shake/Monad.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Development.Shake.Monad(+ RAW, Capture, runRAW,+ getRO, getRW, getsRO, getsRW, putRW, modifyRW,+ withRO, withRW,+ catchRAW, tryRAW, throwRAW,+ unmodifyRW, captureRAW,+ ) where++import Control.Applicative+import Control.Exception as E+import Control.Monad.IO.Class+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Reader+import Data.IORef+++data S ro rw = S+ {handler :: IORef (SomeException -> IO ())+ ,ro :: ro+ ,rww :: IORef rw -- Read/Write Writeable var (rww)+ }++newtype RAW ro rw a = RAW {fromRAW :: ReaderT (S ro rw) (ContT () IO) a}+ deriving (Functor, Applicative, Monad, MonadIO)++type Capture a = (a -> IO ()) -> IO ()+++-- | Run and then call a continuation.+runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)+runRAW ro rw m k = do+ rww <- newIORef rw+ handler <- newIORef $ k . Left+ fromRAW m `runReaderT` S handler ro rww `runContT` (k . Right)+ `E.catch` \e -> ($ e) =<< readIORef handler+++---------------------------------------------------------------------+-- STANDARD++getRO :: RAW ro rw ro+getRO = RAW $ asks ro++getRW :: RAW ro rw rw+getRW = RAW $ liftIO . readIORef =<< asks rww++getsRO :: (ro -> a) -> RAW ro rw a+getsRO f = fmap f getRO++getsRW :: (rw -> a) -> RAW ro rw a+getsRW f = fmap f getRW++-- | Strict version+putRW :: rw -> RAW ro rw ()+putRW rw = rw `seq` RAW $ liftIO . flip writeIORef rw =<< asks rww++withRAW :: (S ro rw -> S ro2 rw2) -> RAW ro2 rw2 a -> RAW ro rw a+withRAW f m = RAW $ withReaderT f $ fromRAW m++modifyRW :: (rw -> rw) -> RAW ro rw ()+modifyRW f = do x <- getRW; putRW $ f x++withRO :: (ro -> ro2) -> RAW ro2 rw a -> RAW ro rw a+withRO f = withRAW $ \s -> s{ro=f $ ro s}++withRW :: (rw -> rw2) -> RAW ro rw2 a -> RAW ro rw a+withRW f m = do+ rw <- getRW+ rww <- liftIO $ newIORef $ f rw+ withRAW (\s -> s{rww=rww}) m+++---------------------------------------------------------------------+-- EXCEPTIONS++catchRAW :: RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a+catchRAW m hdl = RAW $ ReaderT $ \s -> ContT $ \k -> do+ old <- readIORef $ handler s+ writeIORef (handler s) $ \e -> do+ writeIORef (handler s) old+ fromRAW (hdl e) `runReaderT` s `runContT` k `E.catch`+ \e -> ($ e) =<< readIORef (handler s)+ fromRAW m `runReaderT` s `runContT` \v -> do+ writeIORef (handler s) old+ k v+++tryRAW :: RAW ro rw a -> RAW ro rw (Either SomeException a)+tryRAW m = catchRAW (fmap Right m) (return . Left)++throwRAW :: Exception e => e -> RAW ro rw a+throwRAW = liftIO . throwIO+++---------------------------------------------------------------------+-- WEIRD STUFF++-- | Apply a modification, run an action, then undo the changes after.+unmodifyRW :: (rw -> (rw, rw -> rw)) -> RAW ro rw a -> RAW ro rw a+unmodifyRW f m = do+ (s2,undo) <- fmap f getRW+ putRW s2+ res <- m+ modifyRW undo+ return res+++-- | Capture a continuation. The continuation should be called at most once.+-- Calling the same continuation, multiple times, in parallel, results in incorrect behaviour.+captureRAW :: Capture (Either SomeException a) -> RAW ro rw a+captureRAW f = RAW $ ReaderT $ \s -> ContT $ \k -> do+ old <- readIORef (handler s)+ writeIORef (handler s) throwIO+ f $ \x -> case x of+ Left e -> old e+ Right v -> do+ writeIORef (handler s) old+ k v `E.catch` \e -> ($ e) =<< readIORef (handler s)+ writeIORef (handler s) throwIO
Development/Shake/Pool.hs view
@@ -1,11 +1,15 @@ -- | Thread pool implementation.-module Development.Shake.Pool(Pool, addPool, blockPool, runPool) where+module Development.Shake.Pool(+ Pool, runPool,+ addPool, addPoolPriority,+ increasePool+ ) where import Control.Concurrent-import Control.Exception hiding (blocked)+import Control.Exception import Control.Monad-import General.Base+import General.Concurrent import General.Timing import qualified Data.HashSet as Set import System.IO.Unsafe@@ -64,42 +68,41 @@ (x, Nothing) -> (x, Just y) (x, Just z) -> (x, Just $ Branch y z) - --------------------------------------------------------------------- -- THREAD POOL {- Must keep a list of active threads, so can raise exceptions in a timely manner-Must spawn a fresh thread to do blockPool If any worker throws an exception, must signal to all the other workers -} -data Pool = Pool {-# UNPACK #-} !Int !(Var (Maybe S)) !(Barrier (Either SomeException S))+data Pool = Pool+ !(Var (Maybe S)) -- Current state, 'Nothing' to say we are aborting+ !(Barrier (Either SomeException S)) -- Barrier to signal that we are 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 ()))+ {threads :: !(Set.HashSet ThreadId) -- IMPORTANT: Must be strict or we leak thread stacks+ ,threadsLimit :: {-# UNPACK #-} !Int -- user supplied thread limit, Set.size threads <= threadsLimit+ ,threadsMax :: {-# UNPACK #-} !Int -- high water mark of Set.size threads (accounting only)+ ,threadsSum :: {-# UNPACK #-} !Int -- number of threads we have been through (accounting only)+ ,todo :: !(Queue (IO ())) -- operations waiting a thread } -emptyS :: Bool -> S-emptyS deterministic = S Set.empty 0 0 0 0 $ newQueue deterministic+emptyS :: Int -> Bool -> S+emptyS n deterministic = S Set.empty n 0 0 $ newQueue deterministic -- | Given a pool, and a function that breaks the S invariants, restore them--- They are only allowed to touch working or todo+-- They are only allowed to touch threadsLimit or todo step :: Pool -> (S -> NonDet S) -> IO ()-step pool@(Pool n var done) op = do+step pool@(Pool var done) op = do let onVar act = modifyVar_ var $ maybe (return Nothing) act onVar $ \s -> do s <- op s res <- maybe (return Nothing) (fmap Just) $ dequeue $ todo s case res of- Just (now, todo2) | working s < n -> do+ Just (now, todo2) | Set.size (threads s) < threadsLimit s -> do -- spawn a new worker t <- forkIO $ do t <- myThreadId@@ -109,51 +112,43 @@ mapM_ killThread $ Set.toList $ Set.delete t $ threads s signalBarrier done $ Left e return Nothing- Right _ -> step pool $ \s -> return s{working = working s - 1, threads = Set.delete t $ threads s}+ Right _ -> step pool $ \s -> return s{threads = Set.delete t $ threads s} let threads2 = Set.insert t $ threads s- return $ Just s{working = working s + 1, todo = todo2, threads = threads2+ return $ Just s{todo = todo2, threads = threads2 ,threadsSum = threadsSum s + 1, threadsMax = threadsMax s `max` Set.size threads2}- Nothing | working s == 0 && blocked s == 0 -> do+ Nothing | Set.null $ threads s -> do signalBarrier done $ Right s return Nothing _ -> return $ Just s --- | Add a new task to the pool+-- | Add a new task to the pool, may be cancelled by sending it an exception addPool :: Pool -> IO a -> IO () addPool pool act = step pool $ \s -> do todo <- enqueue (void act) (todo s) return s{todo = todo} +-- | Add a new task to the pool, may be cancelled by sending it an exception.+-- Takes priority over everything else.+addPoolPriority :: Pool -> IO a -> IO ()+addPoolPriority pool act = step pool $ \s -> do+ todo <- return $ enqueuePriority (void act) (todo s)+ return s{todo = todo} --- | A blocking action is being run while on the pool, yield your thread.--- Should only be called by an action under addPool.------ If the first part of the result is True then the result is sufficiently high--- priority that you may exceed the pool limit to get it done immediately.--- Always the result of a child thread raising an error, which will probably--- raise an error in the parent.-blockPool :: Pool -> IO (Bool, a) -> IO a-blockPool pool act = do- step pool $ \s -> return s{working = working s - 1, blocked = blocked s + 1}- (urgent,res) <- act- var <- newBarrier- let act = do- step pool $ \s -> return s{working = working s + 1, blocked = blocked s - 1}- signalBarrier var ()- if urgent then- act -- may exceed the pool count- else- step pool $ \s -> return s{todo = enqueuePriority act $ todo s}- waitBarrier var- return res +-- | Temporarily increase the pool by 1 thread. Call the cleanup action to restore the value.+-- After calling cleanup you should requeue onto a new thread.+increasePool :: Pool -> IO (IO ())+increasePool pool = do+ step pool $ \s -> return s{threadsLimit = threadsLimit s + 1}+ return $ step pool $ \s -> return s{threadsLimit = threadsLimit s - 1} + -- | Run all the tasks in the pool on the given number of works. -- If any thread throws an exception, the exception will be reraised. runPool :: Bool -> Int -> (Pool -> IO ()) -> IO () -- run all tasks in the pool runPool deterministic n act = do- s <- newVar $ Just $ emptyS deterministic+ s <- newVar $ Just $ emptyS n deterministic let cleanup = modifyVar_ s $ \s -> do -- if someone kills our thread, make sure we kill our child threads case s of@@ -162,7 +157,7 @@ return Nothing flip onException cleanup $ do res <- newBarrier- let pool = Pool n s res+ let pool = Pool s res addPool pool $ act pool res <- waitBarrier res case res of
+ Development/Shake/Profile.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE PatternGuards, RecordWildCards #-}++module Development.Shake.Profile(ProfileEntry(..), ProfileTrace(..), writeProfile) where++import General.Base+import General.Template+import Control.Arrow+import Data.Function+import Data.List+import Data.Version+import System.FilePath+import Paths_shake+import qualified Data.ByteString.Lazy.Char8 as LBS+++data ProfileEntry = ProfileEntry+ {prfName :: String, prfBuilt :: Int, prfChanged :: Int, prfDepends :: [Int], prfExecution :: Double, prfTraces :: [ProfileTrace]}+data ProfileTrace = ProfileTrace+ {prfCommand :: String, prfStart :: Double, prfStop :: Double}+prfTime ProfileTrace{..} = prfStop - prfStart+++-- | Generates an report given some build system profiling data.+writeProfile :: FilePath -> [ProfileEntry] -> IO ()+writeProfile out xs+ | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ generateJSON xs+ | takeExtension out == ".json" = writeFile out $ generateJSON xs+ | takeExtension out == ".trace" = writeFile out $ generateTrace xs+ | out == "-" = putStr $ unlines $ generateSummary xs+ | otherwise = LBS.writeFile out =<< generateHTML xs+++generateSummary :: [ProfileEntry] -> [String]+generateSummary xs =+ ["* This database has tracked " ++ show (maximum (0 : map prfChanged xs) + 1) ++ " runs."+ ,let f = show . length in "* There are " ++ f xs ++ " rules (" ++ f ls ++ " rebuilt in the last run)."+ ,let f = show . sum . map (length . prfTraces) in "* Building required " ++ f xs ++ " traced commands (" ++ f ls ++ " in the last run)."+ ,"* The total (unparallelised) time is " ++ showTime (sum $ map prfExecution xs) +++ " of which " ++ showTime (sum $ map prfTime $ concatMap prfTraces xs) ++ " is traced commands."+ ,let f xs = if null xs then "0s" else (\(a,b) -> showTime a ++ " (" ++ b ++ ")") $ maximumBy (compare `on` fst) xs in+ "* The longest rule takes " ++ f (map (prfExecution &&& prfName) xs) +++ ", and the longest traced command takes " ++ f (map (prfTime &&& prfCommand) $ concatMap prfTraces xs) ++ "."+ ,let sumLast = sum $ map prfTime $ concatMap prfTraces ls+ maxStop = maximum $ 0 : map prfStop (concatMap prfTraces ls) in+ "* Last run gave an average parallelism of " ++ showDP 2 (if maxStop == 0 then 0 else sumLast / maxStop) +++ " times over " ++ showTime(maxStop) ++ "."+ ]+ where ls = filter ((==) 0 . prfBuilt) xs+++generateHTML :: [ProfileEntry] -> IO LBS.ByteString+generateHTML xs = do+ htmlDir <- getDataFileName "html"+ report <- LBS.readFile $ htmlDir </> "profile.html"+ let f name | name == "profile-data.js" = return $ LBS.pack $ "var shake =\n" ++ generateJSON xs+ | name == "version.js" = return $ LBS.pack $ "var version = " ++ show (showVersion version)+ | otherwise = LBS.readFile $ htmlDir </> name+ runTemplate f report+++generateTrace :: [ProfileEntry] -> String+generateTrace xs = jsonListLines $+ showEntries 0 [y{prfCommand=prfName x} | x <- xs, y <- prfTraces x] +++ showEntries 1 (concatMap prfTraces xs)+ where+ showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortBy (compare `on` prfStart) xs+ alloc as r | (a1,an:a2) <- break (\a -> prfStop a <= prfStart r) as = (a1++r:a2, (length a1,r))+ | otherwise = (as++[r], (length as,r))+ showEntry pid (tid, ProfileTrace{..}) = jsonObject+ [("args","{}"), ("ph",show "X"), ("cat",show "target")+ ,("name",show prfCommand), ("tid",show tid), ("pid",show pid)+ ,("ts",show $ 1000000*prfStart), ("dur",show $ 1000000*(prfStop-prfStart))]+++generateJSON :: [ProfileEntry] -> String+generateJSON = jsonListLines . map showEntry+ where+ showEntry ProfileEntry{..} = jsonObject $+ [("name", show prfName)+ ,("built", show prfBuilt)+ ,("changed", show prfChanged)+ ,("depends", show prfDepends)+ ,("execution", show prfExecution)] +++ [("traces", jsonList $ map showTrace prfTraces) | not $ null prfTraces]+ showTrace ProfileTrace{..} = jsonObject+ [("command",show prfCommand), ("start",show prfStart), ("stop",show prfStop)]++jsonListLines xs = "[" ++ intercalate "\n," xs ++ "\n]"+jsonList xs = "[" ++ intercalate "," xs ++ "]"+jsonObject xs = "{" ++ intercalate ", " [show a ++ ":" ++ b | (a,b) <- xs] ++ "}"
Development/Shake/Progress.hs view
@@ -1,28 +1,34 @@ {-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP, ForeignFunctionInterface, ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} -- | Progress tracking module Development.Shake.Progress( Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram,- progressDisplayTester -- INTERNAL FOR TESTING ONLY+ ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY ) where import Control.Applicative-import Control.Concurrent+import Control.Arrow import Control.Exception import Control.Monad import System.Environment import System.Directory import System.Process+import System.FilePath import Data.Char import Data.Data import Data.IORef import Data.List import Data.Maybe import Data.Monoid+import Data.Version import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS import General.Base+import General.Template import System.IO.Unsafe+import Paths_shake #ifdef mingw32_HOST_OS @@ -53,7 +59,7 @@ ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs. ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before). }- deriving (Eq,Ord,Show,Data,Typeable)+ deriving (Eq,Ord,Show,Read,Data,Typeable) instance Monoid Progress where mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0)@@ -110,9 +116,6 @@ iff :: Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a iff c t f = (\c t f -> if c then t else f) <$> c <*> t <*> f -posMealy :: Mealy i Int-posMealy = scanMealy (+) 0 $ pure 1- -- decay'd division, compute a/b, with a decay of f -- r' is the new result, r is the last result -- r ~= a / b@@ -134,9 +137,29 @@ --------------------------------------------------------------------- -- MESSAGE GENERATOR -message :: Double -> Mealy Progress Progress -> Mealy Progress String-message sample progress = (\time perc -> time ++ " (" ++ perc ++ "%)") <$> time <*> perc+formatMessage :: Double -> Double -> String+formatMessage secs perc =+ (if isNaN secs || secs < 0 then "??s" else showMinSec $ ceiling secs) ++ " (" +++ (if isNaN perc || perc < 0 || perc > 100 then "??" else show $ floor perc) ++ "%)"++showMinSec :: Int -> String+showMinSec secs = (if m == 0 then "" else show m ++ "m" ++ ['0' | s < 10]) ++ show s ++ "s"+ where (m,s) = divMod secs 60+++-- | return (number of seconds, percentage, explanation)+message :: Mealy (Double, Progress) (Double, Progress) -> Mealy (Double, Progress) (Double, Double, String)+message input = liftA3 (,,) time perc debug where+ progress = snd <$> input+ secs = fst <$> input+ debug = (\donePerSec ruleTime (todoKnown,todoUnknown) ->+ "Progress: " +++ "((known=" ++ showDP 2 todoKnown ++ "s) + " +++ "(unknown=" ++ show todoUnknown ++ " * time=" ++ showDP 2 ruleTime ++ "s)) " +++ "(rate=" ++ showDP 2 donePerSec ++ "))")+ <$> donePerSec <*> ruleTime <*> (timeTodo <$> progress)+ -- Number of seconds work completed in this build run -- Ignores timeSkipped which would be more truthful, but it makes the % drop sharply -- which isn't what users want@@ -146,7 +169,6 @@ donePerSec = iff ((==) 0 <$> done) (pure 1) perSecStable where perSecStable = latch $ liftA2 (,) (uncurry (==) <$> oldMealy 0 done) perSecRaw perSecRaw = decay 1.2 done secs- secs = ((*) sample . fromInt) <$> posMealy -- Predicted build time for a rule that has never been built before -- The high decay means if a build goes in "phases" - lots of source files, then lots of compiling@@ -158,7 +180,8 @@ where weightedAverage (w1,x1) (w2,x2) | w1 == 0 && w2 == 0 = 0- | otherwise = ((fromInt w1 * x1) + (fromInt w2 * x2)) / fromInt (w1+w2)+ | otherwise = ((w1 *. x1) + (w2 *. x2)) / fromInt (w1+w2)+ where i *. d = if i == 0 then 0 else fromInt i * d -- since d might be NaN f divide time count = let xs = count <$> progress in liftA2 (,) xs $ divide (time <$> progress) (fromInt <$> xs) @@ -167,11 +190,9 @@ where f Progress{..} ruleTime = fst timeTodo + (fromIntegral (snd timeTodo) * ruleTime) -- Display information- time = flip fmap (liftA2 (/) todo donePerSec) $ \guess ->- let (mins,secs) = divMod (ceiling guess) (60 :: Int)- in (if mins == 0 then "" else show mins ++ "m" ++ ['0' | secs < 10]) ++ show secs ++ "s"- perc = iff ((==) 0 <$> done) (pure "0") $- liftA2' done todo $ \done todo -> show (floor (100 * done / (done + todo)) :: Int)+ time = liftA2 (/) todo donePerSec+ perc = iff ((==) 0 <$> done) (pure 0) $+ liftA2' done todo $ \done todo -> 100 * done / (done + todo) ---------------------------------------------------------------------@@ -193,26 +214,80 @@ -- while time left is calculated by scaling @remaining@ by the observed work rate in this build, -- roughly @done / time_elapsed@. progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()-progressDisplay = progressDisplayer True+progressDisplay sample disp prog = do+ disp "Starting..." -- no useful info at this stage+ time <- fmap (fromRational . toRational) <$> offsetTime+ catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop time $ message echoMealy) (const $ disp "Finished")+ where+ loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()+ loop time mealy = do+ sleep $ fromRational $ toRational sample+ p <- prog+ t <- time+ ((secs,perc,debug), mealy) <- return $ runMealy mealy (t, p)+ -- putStrLn debug+ disp $ formatMessage secs perc ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)+ loop time mealy --- | Version of 'progressDisplay' that omits the sleep-progressDisplayTester :: Double -> (String -> IO ()) -> IO Progress -> IO ()-progressDisplayTester = progressDisplayer False+data ProgressEntry = ProgressEntry+ {idealSecs :: Double, idealPerc :: Double+ ,actualSecs :: Double, actualPerc :: Double+ } +-- | Given a list of progress inputs, what would you have suggested (seconds, percentage)+progressReplay :: [(Double, Progress)] -> [ProgressEntry]+progressReplay [] = []+progressReplay ps = snd $ mapAccumL f (message echoMealy) ps+ where+ end = fst $ last ps+ f a (time,p) = (a2, ProgressEntry (end - time) (time * 100 / end) secs perc)+ where ((secs,perc,_),a2) = runMealy a (time,p) -progressDisplayer :: Bool -> Double -> (String -> IO ()) -> IO Progress -> IO ()-progressDisplayer sleep sample disp prog = do- disp "Starting..." -- no useful info at this stage- catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop $ message sample echoMealy) (const $ disp "Finished")++-- | Given a trace, display information about how well we did+writeProgressReport :: FilePath -> [(FilePath, [(Double, Progress)])] -> IO ()+writeProgressReport out (map (second progressReplay) -> xs)+ | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ generateJSON xs+ | takeExtension out == ".json" = writeFile out $ generateJSON xs+ | out == "-" = putStr $ unlines $ generateSummary xs+ | otherwise = LBS.writeFile out =<< generateHTML xs+++generateSummary :: [(FilePath, [ProgressEntry])] -> [String]+generateSummary xs = flip concatMap xs $ \(file,xs) ->+ ["# " ++ file, f xs "Seconds" idealSecs actualSecs, f xs "Percent" idealPerc actualPerc] where- loop :: Mealy Progress String -> IO ()- loop mealy = do- when sleep $ threadDelay $ ceiling $ sample * 1000000- p <- prog- (msg, mealy) <- return $ runMealy mealy p- disp $ msg ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)- loop mealy+ levels = [100,90,80,50]+ f xs lbl ideal actual = lbl ++ ": " ++ intercalate ", "+ [show l ++ "% within " ++ show (ceiling $ maximum $ 0 : take ((length xs * l) `div` 100) diff) | l <- levels]+ where diff = sort [abs $ ideal x - actual x | x <- xs]+++generateHTML :: [(FilePath, [ProgressEntry])] -> IO LBS.ByteString+generateHTML xs = do+ htmlDir <- getDataFileName "html"+ report <- LBS.readFile $ htmlDir </> "progress.html"+ let f name | name == "progress-data.js" = return $ LBS.pack $ "var shake =\n" ++ generateJSON xs+ | name == "version.js" = return $ LBS.pack $ "var version = " ++ show (showVersion version)+ | otherwise = LBS.readFile $ htmlDir </> name+ runTemplate f report++generateJSON :: [(FilePath, [ProgressEntry])] -> String+generateJSON = concat . jsonList . map ((++"}") . unlines . f)+ where+ f (file,ps) =+ ("{\"name\":" ++ show (takeFileName file) ++ ", \"values\":") :+ indent (jsonList $ map g ps)++ shw = showDP 1+ g ProgressEntry{..} = jsonObject+ [("idealSecs",shw idealSecs),("idealPerc",shw idealPerc)+ ,("actualSecs",shw actualSecs),("actualPerc",shw actualPerc)]++indent = map (" "++)+jsonList xs = zipWith (:) ('[':repeat ',') xs ++ ["]"]+jsonObject xs = "{" ++ intercalate ", " [show a ++ ":" ++ b | (a,b) <- xs] ++ "}" {-# NOINLINE xterm #-}
− Development/Shake/Report.hs
@@ -1,115 +0,0 @@-{-# LANGUAGE PatternGuards, RecordWildCards #-}--module Development.Shake.Report(ReportEntry(..), ReportTrace(..), buildReport) where--import General.Base-import Control.Arrow-import Control.Monad-import Data.Char-import Data.Function-import Data.List-import System.FilePath-import Paths_shake-import qualified Data.ByteString.Lazy.Char8 as LBS---data ReportEntry = ReportEntry- {repName :: String, repBuilt :: Int, repChanged :: Int, repDepends :: [Int], repExecution :: Double, repTraces :: [ReportTrace]}-data ReportTrace = ReportTrace- {repCommand :: String, repStart :: Double, repStop :: Double}-repTime ReportTrace{..} = repStop - repStart----- | Generates an report given some build system profiling data.-buildReport :: FilePath -> [ReportEntry] -> IO ()-buildReport out xs- | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ reportJSON xs- | takeExtension out == ".json" = writeFile out $ reportJSON xs- | takeExtension out == ".trace" = writeFile out $ reportTrace xs- | out == "-" = putStr $ unlines $ reportSummary xs- | otherwise = LBS.writeFile out =<< reportHTML xs---reportSummary :: [ReportEntry] -> [String]-reportSummary xs =- ["* This database has tracked " ++ show (maximum (0 : map repChanged xs) + 1) ++ " runs."- ,let f = show . length in "* There are " ++ f xs ++ " rules (" ++ f ls ++ " rebuilt in the last run)."- ,let f = show . sum . map (length . repTraces) in "* Building required " ++ f xs ++ " traced commands (" ++ f ls ++ " in the last run)."- ,"* The total (unparallelised) build time is " ++ showTime (sum $ map repExecution xs) ++- " of which " ++ showTime (sum $ map repTime $ concatMap repTraces xs) ++ " is traced commands."- ,let f xs = if null xs then "0s" else (\(a,b) -> showTime a ++ " (" ++ b ++ ")") $ maximumBy (compare `on` fst) xs in- "* The longest rule takes " ++ f (map (repExecution &&& repName) xs) ++- ", and the longest traced command takes " ++ f (map (repTime &&& repCommand) $ concatMap repTraces xs) ++ "."- ,let sumLast = sum $ map repTime $ concatMap repTraces ls- maxStop = maximum $ 0 : map repStop (concatMap repTraces ls) in- "* Last run gave an average parallelism of " ++ showDP 2 (if maxStop == 0 then 0 else sumLast / maxStop) ++- " times over " ++ showTime(maxStop) ++ "."- ]- where ls = filter ((==) 0 . repBuilt) xs---reportHTML :: [ReportEntry] -> IO LBS.ByteString-reportHTML xs = do- htmlDir <- getDataFileName "html"- report <- LBS.readFile $ htmlDir </> "report.html"- let f name | name == "data.js" = return $ LBS.pack $ "var shake = \n" ++ reportJSON xs- | otherwise = LBS.readFile $ htmlDir </> name- runTemplate f report---reportTrace :: [ReportEntry] -> String-reportTrace xs = jsonListLines $- showEntries 0 [y{repCommand=repName x} | x <- xs, y <- repTraces x] ++- showEntries 1 (concatMap repTraces xs)- where- showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortBy (compare `on` repStart) xs- alloc as r | (a1,an:a2) <- break (\a -> repStop a <= repStart r) as = (a1++r:a2, (length a1,r))- | otherwise = (as++[r], (length as,r))- showEntry pid (tid, ReportTrace{..}) = jsonObject- [("args","{}"), ("ph",show "X"), ("cat",show "target")- ,("name",show repCommand), ("tid",show tid), ("pid",show pid)- ,("ts",show $ 1000000*repStart), ("dur",show $ 1000000*(repStop-repStart))]---reportJSON :: [ReportEntry] -> String-reportJSON = jsonListLines . map showEntry- where- showEntry ReportEntry{..} = jsonObject $- [("name", show repName)- ,("built", show repBuilt)- ,("changed", show repChanged)- ,("depends", show repDepends)- ,("execution", show repExecution)] ++- [("traces", jsonList $ map showTrace repTraces) | not $ null repTraces]- showTrace ReportTrace{..} = jsonObject- [("command",show repCommand), ("start",show repStart), ("stop",show repStop)]--jsonListLines xs = "[" ++ intercalate "\n," xs ++ "\n]"-jsonList xs = "[" ++ intercalate "," xs ++ "]"-jsonObject xs = "{" ++ intercalate ", " [show a ++ ":" ++ b | (a,b) <- xs] ++ "}"-------------------------------------------------------------------------- TEMPLATE ENGINE---- | Template Engine. Perform the following replacements on a line basis:------ * <script src="foo"></script> ==> <script>[[foo]]</script>------ * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>-runTemplate :: Monad m => (FilePath -> m LBS.ByteString) -> LBS.ByteString -> m LBS.ByteString-runTemplate ask = liftM LBS.unlines . mapM f . LBS.lines- where- link = LBS.pack "<link href=\""- script = LBS.pack "<script src=\""-- f x | Just file <- lbs_stripPrefix script y = do res <- grab file; return $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"- | Just file <- lbs_stripPrefix link y = do res <- grab file; return $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"- | otherwise = return x- where- y = LBS.dropWhile isSpace x- grab = ask . takeWhile (/= '\"') . LBS.unpack---lbs_stripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString-lbs_stripPrefix prefix text = if a == prefix then Just b else Nothing- where (a,b) = LBS.splitAt (LBS.length prefix) text
Development/Shake/Resource.hs view
@@ -1,15 +1,19 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, ViewPatterns #-} module Development.Shake.Resource( Resource, newResourceIO, newThrottleIO, acquireResource, releaseResource ) where -import Development.Shake.Errors import General.Base+import General.Concurrent import Data.Function+import Data.Monoid import System.IO.Unsafe+import Control.Concurrent import Control.Arrow import Control.Monad+import General.Bilist+import Development.Shake.Pool {-# NOINLINE resourceIds #-}@@ -41,10 +45,10 @@ -- ^ 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 ()+ ,acquireResource :: Pool -> Int -> IO () -> IO ()+ -- ^ Acquire the resource and call the function. Passes 'False' to indicate you have acquired with no blocking,+ -- or 'True' to say there was waiting and you must not do significant computation on that thread.+ ,releaseResource :: Pool -> Int -> IO () -- ^ You should only ever releaseResource that you obtained with acquireResource. } @@ -56,8 +60,12 @@ --------------------------------------------------------------------- -- 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 ())])+data Finite = Finite+ {finiteAvailable :: !Int+ -- ^ number of currently available resources+ ,finiteWaiting :: Bilist (Int, IO ())+ -- ^ queue of people with how much they want and the action when it is allocated to them+ } -- | 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.@@ -66,105 +74,89 @@ when (mx < 0) $ error $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx key <- resourceId- var <- newVar (mx, [])+ var <- newVar $ Finite mx mempty return $ Resource (negate key) shw (acquire var) (release var) where shw = "Resource " ++ name - acquire :: Finite -> Int -> IO (Maybe (IO ()))- acquire var want+ acquire :: Var Finite -> Pool -> Int -> IO () -> IO ()+ acquire var pool want continue | 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)+ | otherwise = join $ modifyVar var $ \x@Finite{..} -> return $+ if want <= finiteAvailable then+ (x{finiteAvailable = finiteAvailable - want}, continue)+ else+ (x{finiteWaiting = finiteWaiting `snoc` (want, addPool pool continue)}, return ()) - release :: Finite -> Int -> IO ()- release var i = modifyVar_ var $ \(available,waiting) -> f (available+i) waiting+ release :: Var Finite -> Pool -> Int -> IO ()+ release var _ i = join $ modifyVar var $ \x -> return $ f x{finiteAvailable = finiteAvailable x + i} 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, [])+ f (Finite i (uncons -> Just ((wi,wa),ws)))+ | wi <= i = second (wa >>) $ f $ Finite (i-wi) ws+ | otherwise = first (add (wi,wa)) $ f $ Finite i ws+ f (Finite i _) = (Finite i mempty, return ())+ add a s = s{finiteWaiting = a `cons` finiteWaiting s} --------------------------------------------------------------------- -- 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- } +-- call a function after a certain delay+waiter :: Double -> IO () -> IO ()+waiter period act = void $ forkIO $ do+ sleep $ fromRational $ toRational period+ act++-- Make sure the pool cannot run try until after you have finished with it+blockPool :: Pool -> IO (IO ())+blockPool pool = do+ bar <- newBarrier+ addPool pool $ do+ cancel <- increasePool pool+ waitBarrier bar+ cancel+ return $ signalBarrier bar ()+++data Throttle+ -- | Some number of resources are available+ = ThrottleAvailable !Int+ -- | Some users are blocked (non-empty), plus an action to call once we go back to Available+ | ThrottleWaiting (IO ()) (Bilist (Int, IO ()))++ -- | 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.+-- Most people should use 'Development.Shake.newThrottle' instead. newThrottleIO :: String -> Int -> Double -> IO Resource-newThrottleIO name count period_ = do+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)+ var <- newVar $ ThrottleAvailable count+ return $ Resource key shw (acquire var) (release var) where- period = fromRational $ toRational period_ 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+ acquire :: Var Throttle -> Pool -> Int -> IO () -> IO ()+ acquire var pool want continue | 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+ | otherwise = join $ modifyVar var $ \x -> case x of+ ThrottleAvailable i+ | i >= want -> return (ThrottleAvailable $ i - want, continue)+ | otherwise -> do+ stop <- blockPool pool+ return (ThrottleWaiting stop $ (want - i, addPool pool continue) `cons` mempty, return ())+ ThrottleWaiting stop xs -> return (ThrottleWaiting stop $ xs `snoc` (want, addPool pool continue), return ()) - -- 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+ release :: Var Throttle -> Pool -> Int -> IO ()+ release var pool n = waiter period $ join $ modifyVar var $ \x -> return $ case x of+ ThrottleAvailable i -> (ThrottleAvailable $ i+n, return ())+ ThrottleWaiting stop xs -> f stop n xs+ where+ f stop i (uncons -> Just ((wi,wa),ws))+ | i >= wi = second (wa >>) $ f stop (i-wi) ws+ | otherwise = (ThrottleWaiting stop $ (wi-i,wa) `cons` ws, return ())+ f stop i _ = (ThrottleAvailable i, stop)
Development/Shake/Rules/File.hs view
@@ -14,11 +14,13 @@ import Control.Monad.IO.Class import System.Directory import qualified Data.ByteString.Char8 as BS+import qualified Data.HashSet as Set import Development.Shake.Core hiding (trackAllow) import qualified Development.Shake.Core as S import General.String import Development.Shake.Classes+import Development.Shake.FilePath(toStandard) import Development.Shake.FilePattern import Development.Shake.FileInfo import Development.Shake.Types@@ -225,8 +227,14 @@ -- | Define a set of patterns, and if any of them match, run the associated rule. Defined in terms of '*>'. -- Think of it as the OR (@||@) equivalent of '*>'. (|*>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()-(|*>) pats act = let (simp,other) = partition simple pats in f simp >> priority 0.5 (f other)- where f ps = let ps2 = map (?==) ps in unless (null ps2) $ root "with |*>" (\x -> any ($ x) ps2) act+(|*>) pats act = do+ let (simp,other) = partition simple pats+ case simp of+ [] -> return ()+ [p] -> root "with |*>" (\x -> toStandard x == p) act+ ps -> let ps = Set.fromList pats in root "with |*>" (flip Set.member ps . toStandard) act+ unless (null other) $+ let ps = map (?==) other in priority 0.5 $ root "with |*>" (\x -> any ($ x) ps) act -- | Define a rule that matches a 'FilePattern', see '?==' for the pattern rules. -- Patterns with no wildcards have higher priority than those with wildcards, and no file
Development/Shake/Storage.hs view
@@ -11,6 +11,7 @@ import General.Binary import General.Base+import General.Concurrent import Development.Shake.Types import General.Timing
Development/Shake/Types.hs view
@@ -128,6 +128,9 @@ ,shakeCreationCheck :: Bool -- ^ Default to 'True'. After running a rule to create a file, is it an error if the file does not exist. -- Provided for compatibility with @make@ and @ninja@ (which have ugly file creation semantics).+ ,shakeLiveFiles :: [FilePath]+ -- ^ Default to '[]'. After the build system completes, write a list of all files which were /live/ in that run,+ -- i.e. those which Shake checked were valid or rebuilt. Produces best answers if nothing rebuilds. ,shakeProgress :: IO Progress -> IO () -- ^ 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.@@ -142,7 +145,9 @@ -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 "1" Normal False [] Nothing (Just 10) Nothing [] False True False True ChangeModtime True+shakeOptions = ShakeOptions+ ".shake" 1 "1" Normal False [] Nothing (Just 10) Nothing [] False True False+ True ChangeModtime True [] (const $ return ()) (const $ BS.putStrLn . BS.pack) -- try and output atomically using BS @@ -150,17 +155,18 @@ ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport" ,"shakeLint", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog" ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"- ,"shakeProgress", "shakeOutput"]+ ,"shakeLiveFiles","shakeProgress", "shakeOutput"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix-unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 =- ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 (fromFunction x17) (fromFunction x18)+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 =+ ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 (fromFunction x18) (fromFunction x19) instance Data ShakeOptions where- gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18) =- z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k` x12 `k` x13 `k` x14 `k` x15 `k` x16 `k`- Function x17 `k` Function x18- gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide+ gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19) =+ z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k`+ x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k`+ Function x18 `k` Function x19+ gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions
− Examples/C/Main.hs
@@ -1,28 +0,0 @@--module Examples.C.Main(main) where--import Development.Shake-import Development.Shake.FilePath-import Examples.Util--main = shaken noTest $ \args obj -> do- let src = "Examples/C"- want [obj "Main.exe"]-- obj "Main.exe" *> \out -> do- cs <- getDirectoryFiles src ["*.c"]- let os = map (obj . (<.> "o")) cs- need os- cmd "gcc -o" [out] os-- obj "*.c.o" *> \out -> do- let c = src </> takeBaseName out- need [c]- headers <- cIncludes c- need $ map ((</>) src . takeFileName) headers- cmd "gcc -o" [out] "-c" [c]--cIncludes :: FilePath -> Action [FilePath]-cIncludes x = do- Stdout stdout <- cmd "gcc" ["-MM",x]- return $ drop 2 $ words stdout
− Examples/C/constants.c
@@ -1,7 +0,0 @@--char msg[] = "Hello Shake Users!";--char* message()-{- return msg;-}
− Examples/C/constants.h
@@ -1,1 +0,0 @@-char* message();
− Examples/C/main.c
@@ -1,8 +0,0 @@-#include <stdio.h>-#include "constants.h"--int main()-{- printf("%s\n", message());- return 0;-}
− Examples/MakeTutor/Makefile
@@ -1,17 +0,0 @@-# From http://www.cs.colby.edu/maxwell/courses/tutorials/maketutor/, Makefile 4--CC=gcc-CFLAGS=-I.-DEPS = hellomake.h-OBJ = hellomake.o hellofunc.o --hellomake$(EXE): $(OBJ)- $(CC) -o $@ $^ $(CFLAGS)--%.o: %.c $(DEPS)- $(CC) -c -o $@ $< $(CFLAGS)--.PHONY: clean-clean:- rm hellomake$(EXE)- rm *.o
− Examples/MakeTutor/hellofunc.c
@@ -1,9 +0,0 @@-#include <stdio.h>-#include <hellomake.h>--void myPrintHelloMake(void) {-- printf("Hello makefiles!\n");-- return;-}
− Examples/MakeTutor/hellomake.c
@@ -1,8 +0,0 @@-#include <hellomake.h>--int main() {- // call a function in another file- myPrintHelloMake();-- return(0);-}
− Examples/MakeTutor/hellomake.h
@@ -1,5 +0,0 @@-/*-example include file-*/--void myPrintHelloMake(void);
− Examples/Ninja/Main.hs
@@ -1,72 +0,0 @@--module Examples.Ninja.Main(main) where--import Development.Shake-import Development.Shake.FilePath-import System.Directory(copyFile)-import Control.Monad-import General.Base-import Examples.Util-import Data.List-import qualified Start-import System.Environment---main = shaken test $ \args obj -> do- let args2 = ("-C" ++ obj "") : map tail (filter ("@" `isPrefixOf`) args)- let real = "real" `elem` args- action $- if real then cmd "ninja" args2 else liftIO $ withArgs args2 Start.main---test build obj = do- let run xs = build $ "--exception" : map ('@':) (words xs)- let runFail xs bad = assertException [bad] $ run $ xs ++ " --quiet"-- build ["clean"]- run "-f../../Examples/Ninja/test1.ninja"- assertExists $ obj "out1.txt"-- run "-f../../Examples/Ninja/test2.ninja"- assertExists $ obj "out2.2"- assertMissing $ obj "out2.1"- build ["clean"]- run "-f../../Examples/Ninja/test2.ninja out2.1"- assertExists $ obj "out2.1"- assertMissing $ obj "out2.2"-- copyFile "Examples/Ninja/test3-sub.ninja" $ obj "test3-sub.ninja"- copyFile "Examples/Ninja/test3-inc.ninja" $ obj "test3-inc.ninja"- copyFile ("Examples/Ninja/" ++ if null exe then "test3-unix.ninja" else "test3-win.ninja") $ obj "test3-platform.ninja"- run "-f../../Examples/Ninja/test3.ninja"- assertNonSpace (obj "out3.1") "g4+b1+++i1"- 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"-- writeFile (obj "nocreate.log") ""- writeFile (obj "nocreate.in") ""- run "-f../../Examples/Ninja/nocreate.ninja"- assertNonSpace (obj "nocreate.log") "x"- run "-f../../Examples/Ninja/nocreate.ninja"- run "-f../../Examples/Ninja/nocreate.ninja"- assertNonSpace (obj "nocreate.log") "xxx"-- writeFile (obj "input") ""- runFail "-f../../Examples/Ninja/lint.ninja bad --lint" "'needed' file required rebuilding"- run "-f../../Examples/Ninja/lint.ninja good --lint"- runFail "-f../../Examples/Ninja/lint.ninja bad --lint" "not a pre-dependency"-- res <- fmap (reverse . drop 2 . reverse . drop 1 . lines) $ captureOutput $ run "-f../../Examples/Ninja/compdb.ninja -t compdb cxx"- want <- fmap lines $ readFile "Examples/Ninja/compdb.output"- let eq a b | (a1,'*':a2) <- break (== '*') a = unless (a1 `isPrefixOf` b && a2 `isSuffixOf` b) $ a === b- | otherwise = a === b- length want === length res- zipWithM_ eq want res
− Examples/Ninja/compdb.ninja
@@ -1,45 +0,0 @@-# Copied from the Ninja repo--ninja_required_version = 1.3--builddir = build-cxx = g++-ar = ar-cflags = -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti $- -fno-exceptions -pipe -Wno-missing-field-initializers $- -DNINJA_PYTHON="python.exe" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501-ldflags = -L$builddir -static--rule cxx- command = $cxx -MMD -MT $out -MF $out.d $cflags -c $in -o $out- description = CXX $out- depfile = $out.d- deps = gcc--rule ar- command = cmd /c $ar cqs $out.tmp $in && move /Y $out.tmp $out- description = AR $out--rule link- command = $cxx $ldflags -o $out $in $libs- description = LINK $out--# the depfile parser and ninja lexers are generated using re2c.--# Core source files all build into ninja library.-build $builddir\build.o: cxx src\build.cc-build $builddir\build_log.o: cxx src\build_log.cc-build $builddir\clean.o: cxx src\clean.cc--rule doxygen- command = doxygen $in- description = DOXYGEN $in-doxygen_mainpage_generator = src\gen_doxygen_mainpage.sh-rule doxygen_mainpage- command = $doxygen_mainpage_generator $in > $out- description = DOXYGEN_MAINPAGE $out-build $builddir\doxygen_mainpage: doxygen_mainpage README COPYING | $- $doxygen_mainpage_generator-build doxygen: doxygen doc\doxygen.config | $builddir\doxygen_mainpage--default ninja.exe
− Examples/Ninja/compdb.output
@@ -1,17 +0,0 @@-[- {- "directory": "*",- "command": "g++ -MMD -MT build\\build.o -MF build\\build.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\build.cc -o build\\build.o",- "file": "src\\build.cc"- },- {- "directory": "*",- "command": "g++ -MMD -MT build\\build_log.o -MF build\\build_log.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\build_log.cc -o build\\build_log.o",- "file": "src\\build_log.cc"- },- {- "directory": "*",- "command": "g++ -MMD -MT build\\clean.o -MF build\\clean.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\clean.cc -o build\\clean.o",- "file": "src\\clean.cc"- }-]
− Examples/Ninja/lint.ninja
@@ -1,13 +0,0 @@- -rule gen - command = echo $out > $out - -rule run - command = (echo $out : $out.gen > $out.d) && (echo $out > $out) - depfile = $out.d - -build good: run || good.gen bad.gen -build good.gen: gen - -build bad: run | input -build bad.gen: gen
− Examples/Ninja/nocreate.ninja
@@ -1,5 +0,0 @@--rule gen- command = echo x >> nocreate.log--build nocreate.out: gen nocreate.in
− Examples/Ninja/test1.ninja
@@ -1,5 +0,0 @@--rule run- command = touch $out--build out1.txt: run
− Examples/Ninja/test2.ninja
@@ -1,8 +0,0 @@- -rule run - command = touch $out - -build out2.1: run -build out2.2: run - -default out2.2
− Examples/Ninja/test3-inc.ninja
@@ -1,3 +0,0 @@-v5 = i1 - -build out3.3: dump
− Examples/Ninja/test3-sub.ninja
@@ -1,6 +0,0 @@-v4 = s1 -v5 = s1 - -build out3.4: dump - -v5 = s2
− Examples/Ninja/test3-unix.ninja
@@ -1,3 +0,0 @@- -rule dump - command = echo "$v1+$v2+$v3+$v4+$v5" > $out
− Examples/Ninja/test3-win.ninja
@@ -1,3 +0,0 @@- -rule dump - command = cmd /c "echo $v1+$v2+$v3+$v4+$v5 > $out"
− Examples/Ninja/test3.ninja
@@ -1,21 +0,0 @@- - -v1 = g1 -v5 = g1 - -include test3-platform.ninja - -v1 = g2 - -build out3.1: dump - v2 = b1 - -v1 = g3 - -subninja test3-sub.ninja - -include test3-inc.ninja - -build out3.2: dump - -v1 = g4
− Examples/Ninja/test4.ninja
@@ -1,9 +0,0 @@- -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
@@ -1,5 +0,0 @@- -rule run - command = touch $out - -build output$ file: run
− Examples/Self/Main.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}--module Examples.Self.Main(main) where--import Development.Shake-import Development.Shake.Classes-import Development.Shake.FilePath-import Examples.Util--import Control.Monad-import Data.Char-import Data.List-import System.Info---newtype GhcPkg = GhcPkg () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)-newtype GhcFlags = GhcFlags () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)---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-- -- fixup to cope with Cabal's generated files- let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x-- ghcPkg <- addOracle $ \GhcPkg{} -> do- Stdout out <- quietly $ cmd "ghc-pkg list --simple-output"- return $ words out-- ghcFlags <- addOracle $ \GhcFlags{} -> do- pkgs <- readFileLines $ obj ".pkgs"- return $ map ("-package=" ++) pkgs-- let ghc args = do- -- since ghc-pkg includes the ghc package, it changes if the version does- ghcPkg $ GhcPkg ()- flags <- ghcFlags $ GhcFlags ()- cmd "ghc" flags args-- obj "Main" <.> exe *> \out -> do- src <- readFileLines $ out -<.> "deps"- let os = map (obj . moduleToFile "o") $ "Main":src- need os- ghc $ ["-o",out] ++ os-- obj "/*.deps" *> \out -> do- dep <- readFileLines $ out -<.> "dep"- let xs = map (obj . moduleToFile "deps") dep- need xs- ds <- fmap (nub . sort . (++) dep . concat) $ mapM readFileLines xs- writeFileLines out ds-- obj "/*.dep" *> \out -> do- src <- readFile' $ fixPaths $ unobj $ out -<.> "hs"- let xs = hsImports src- xs <- filterM (doesFileExist . fixPaths . moduleToFile "hs") xs- writeFileLines out xs-- [obj "/*.o",obj "/*.hi"] &*> \[out,_] -> do- deps <- readFileLines $ out -<.> "deps"- let hs = fixPaths $ unobj $ out -<.> "hs"- need $ hs : map (obj . moduleToFile "hi") deps- ghc $ ["-c",hs,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"] ++- ["-DPORTABLE","-fwarn-unused-imports","-Werror"] -- to test one CPP branch-- obj ".pkgs" *> \out -> do- src <- readFile' "shake.cabal"- writeFileLines out $ sort $ cabalBuildDepends src--------------------------------------------------------------------------- GRAB INFORMATION FROM FILES--hsImports :: String -> [String]-hsImports xs = [ takeWhile (\x -> isAlphaNum x || x `elem` "._") $ dropWhile (not . isUpper) x- | x <- lines xs, "import " `isPrefixOf` x]----- FIXME: Should actually parse the list from the contents of the .cabal file-cabalBuildDepends :: String -> [String]-cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]--packages = words $- "base transformers binary unordered-containers hashable time old-time bytestring " ++- "filepath directory process deepseq random utf8-string"
− Examples/Tar/Main.hs
@@ -1,13 +0,0 @@--module Examples.Tar.Main(main) where--import Development.Shake-import Examples.Util---main = shaken noTest $ \args obj -> do- want [obj "result.tar"]- obj "result.tar" *> \out -> do- contents <- readFileLines "Examples/Tar/list.txt"- need contents- cmd "tar -cf" [out] contents
− Examples/Tar/list.txt
@@ -1,3 +0,0 @@-Examples/Tar/Main.hs-Main.hs-Examples/Tar/list.txt
− Examples/Test/Assume.hs
@@ -1,45 +0,0 @@--module Examples.Test.Assume(main) where--import Development.Shake-import Examples.Util-import Control.Monad-import Development.Shake.FilePath---main = shaken test $ \args obj -> do- want $ map obj args- obj "*.out" *> \out -> do- cs <- mapM (readFile' . obj . (:".src")) $ takeBaseName out- writeFile' out $ concat cs---test build obj = do- let set file c = writeFile (obj $ file : ".src") [c]- let ask file c = do src <- readFile (obj $ file ++ ".out"); src === c-- forM_ ['a'..'f'] $ \c -> set c c- build ["--sleep","abc.out"]- ask "abc" "abc"-- set 'b' 'd'- build ["--sleep","abc.out"]- ask "abc" "adc"- set 'b' 'p'- build ["--sleep","abc.out","--touch"]- build ["abc.out"]- ask "abc" "adc"- set 'c' 'z'- build ["--sleep","abc.out"]- ask "abc" "apz"-- build ["bc.out","c.out"]- ask "bc" "pz"- set 'b' 'r'- set 'c' 'n'- build ["--sleep","abc.out","--touch"]- ask "abc" "apz"- build ["ab.out","--always-make"]- ask "ab" "ar"- build ["c.out"]- ask "c" "z"
− Examples/Test/Basic.hs
@@ -1,124 +0,0 @@--module Examples.Test.Basic(main) where--import Development.Shake-import Development.Shake.FilePath-import Examples.Util-import System.Directory as IO-import Data.List-import Data.Maybe---main = shaken test $ \args obj -> do- want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args-- obj "AB.txt" *> \out -> do- need [obj "A.txt", obj "B.txt"]- text1 <- readFile' $ obj "A.txt"- text2 <- readFile' $ obj "B.txt"- writeFile' out $ text1 ++ text2-- obj "twice.txt" *> \out -> do- let src = obj "once.txt"- need [src, src]- copyFile' src out-- obj "once.txt" *> \out -> do- src <- readFile' $ obj "zero.txt"- writeFile' out src-- phony "halfclean" $ do- removeFilesAfter (obj "") ["//*e.txt"]-- phony "cleaner" $ do- removeFilesAfter (obj "") ["//*"]-- phony (obj "configure") $ do- liftIO $ appendFile (obj "configure") "1"-- phony "install" $ do- 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"-- r <- newResource ".log file" 1- obj "*.par" *> \out -> do- let trace x = withResource r 1 $ liftIO $ appendFile (takeDirectory out </> ".log") x- trace "["- liftIO $ sleep 0.1- trace "]"- writeFile' out out--test build obj = do- writeFile (obj "A.txt") "AAA"- writeFile (obj "B.txt") "BBB"- build ["AB.txt","--sleep"]- assertContents (obj "AB.txt") "AAABBB"- appendFile (obj "A.txt") "aaa"- build ["AB.txt"]- assertContents (obj "AB.txt") "AAAaaaBBB"-- writeFile (obj "zero.txt") "xxx"- build ["twice.txt","--sleep"]- assertContents (obj "twice.txt") "xxx"- writeFile (obj "zero.txt") "yyy"- build ["once.txt","--sleep"]- assertContents (obj "twice.txt") "xxx"- assertContents (obj "once.txt") "yyy"- writeFile (obj "zero.txt") "zzz"- build ["once.txt","twice.txt","--sleep"]- assertContents (obj "twice.txt") "zzz"- assertContents (obj "once.txt") "zzz"-- removeFile $ obj "twice.txt"- build ["twice.txt"]- assertContents (obj "twice.txt") "zzz"-- show shakeOptions === show shakeOptions-- build ["!halfclean"]- b <- IO.doesDirectoryExist (obj "")- assert b "Directory should exist, cleaner should not have removed it"-- build ["!cleaner"]- sleep 1 -- sometimes takes a while for the file system to notice- b <- IO.doesDirectoryExist (obj "")- assert (not b) "Directory should not exist, cleaner should have removed it"-- IO.createDirectory $ obj ""- writeFile (obj "zero.txt") ""- build ["configure"]- build ["!install"]- 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"-- build ["1.par","2.par","-j1"]- assertContents (obj ".log") "[][]"- writeFile (obj ".log") ""- build ["3.par","4.par","-j2"]- assertContents (obj ".log") "[[]]"- writeFile (obj ".log") ""- build ["5.par","6.par","-j0"] -- all machines have at least 2 processors nowadays- assertContents (obj ".log") "[[]]"
− Examples/Test/Benchmark.hs
@@ -1,21 +0,0 @@--module Examples.Test.Benchmark(main) where--import Development.Shake-import Examples.Util-import Data.List-import Development.Shake.FilePath----- | Given a breadth and depth come up with a set of build files-main = shaken (\_ _ -> return ()) $ \args obj -> do- let get ty = head $ [read $ drop (length ty + 1) a | a <- args, (ty ++ "=") `isPrefixOf` a] ++- error ("Could not find argument, expected " ++ ty ++ "=Number")- depth = get "depth"- breadth = get "breadth"-- want [obj $ "0." ++ show i | i <- [1..breadth]]- obj "*" *> \out -> do- let d = read $ takeBaseName out- need [obj $ show (d + 1) ++ "." ++ show i | d < depth, i <- [1..breadth]]- writeFile' out ""
− Examples/Test/Cache.hs
@@ -1,39 +0,0 @@--module Examples.Test.Cache(main) where--import Development.Shake-import Development.Shake.FilePath-import Data.Char-import Examples.Util---main = shaken test $ \args obj -> do- want $ map obj args- vowels <- newCache $ \file -> do- src <- readFile' file- liftIO $ appendFile (obj "trace.txt") "1"- return $ length $ filter isDigit src- obj "*.out*" *> \x ->- writeFile' x . show =<< vowels (dropExtension x <.> "txt")---test build obj = do- writeFile (obj "trace.txt") ""- writeFile (obj "vowels.txt") "abc123a"- build ["vowels.out1","vowels.out2","-j3","--sleep"]- assertContents (obj "trace.txt") "1"- assertContents (obj "vowels.out1") "3"- assertContents (obj "vowels.out2") "3"-- build ["vowels.out2","-j3"]- assertContents (obj "trace.txt") "1"- assertContents (obj "vowels.out1") "3"-- writeFile (obj "vowels.txt") "12xyz34"- build ["vowels.out2","-j3","--sleep"]- assertContents (obj "trace.txt") "11"- assertContents (obj "vowels.out2") "4"-- build ["vowels.out1","-j3","--sleep"]- assertContents (obj "trace.txt") "111"- assertContents (obj "vowels.out1") "4"
− Examples/Test/Command.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Examples.Test.Command(main) where--import Development.Shake-import Examples.Util---main = shaken test $ \args obj -> do- want $ map obj args-- let a !> b = obj a *> \out -> do alwaysRerun; res <- b; writeFile' out res-- "ghc-version" !> do- Stdout stdout <- cmd "ghc --version"- return stdout-- "ghc-random" !> do- (Stderr stderr, Exit _) <- cmd "ghc --random"- return stderr-- "ghc-random2" !> do- () <- cmd (EchoStderr False) (Cwd $ obj "") "ghc --random"- return ""-- "triple" !> do- (Exit exit, Stdout stdout, Stderr stderr) <- cmd "ghc --random"- return $ show (exit, stdout, stderr) -- must force all three parts-- obj "pwd space.hs" *> \out -> writeFileLines out ["import System.Directory","main = putStrLn =<< getCurrentDirectory"]- "pwd" !> do- need [obj "pwd space.hs"]- Stdout out <- cmd (Cwd $ obj "") "runhaskell" ["pwd space.hs"]- return out-- "env" !> do- (Exit _, Stdout out1) <- cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo %FOO%"- (Exit _, Stdout out2) <- liftIO $ cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo $FOO"- return $ unlines [out1, out2]---test build obj = do- let crash args parts = assertException parts (build $ "--quiet" : args)-- build ["ghc-version"]- assertContentsInfix (obj "ghc-version") "The Glorious Glasgow Haskell Compilation System"-- build ["ghc-random"]- assertContentsInfix (obj "ghc-random") "unrecognised flag"- assertContentsInfix (obj "ghc-random") "--random"-- crash ["ghc-random2"] [obj "","unrecognised flag","--random"]-- build ["pwd"]- assertContentsInfix (obj "pwd") "command"-- build ["env","--no-lint"] -- since it blows away the $PATH, which is necessary for lint-tracker- assertContentsInfix (obj "env") "HELLO SHAKE"-- build ["triple"]
− Examples/Test/Config.hs
@@ -1,41 +0,0 @@--module Examples.Test.Config(main) where--import Development.Shake-import Development.Shake.FilePath-import Development.Shake.Config-import Examples.Util-import Data.Char-import Data.Maybe-import System.Directory---main = shaken test $ \args obj -> do- want $ map obj ["hsflags.var","cflags.var","none.var"]- usingConfigFile $ obj "config"- obj "*.var" *> \out -> do- cfg <- getConfig $ map toUpper $ takeBaseName out- liftIO $ appendFile (out -<.> "times") "X"- writeFile' out $ fromMaybe "" cfg---test build obj = do- build ["clean"]- createDirectoryIfMissing True $ obj ""- writeFile (obj "config") $ unlines- ["HEADERS_DIR = /path/to/dir"- ,"CFLAGS = -O2 -I${HEADERS_DIR} -g"- ,"HSFLAGS = -O2"]- build []- assertContents (obj "cflags.var") "-O2 -I/path/to/dir -g"- assertContents (obj "hsflags.var") "-O2"- assertContents (obj "none.var") ""-- appendFile (obj "config") $ unlines- ["CFLAGS = $CFLAGS -w"]- build []- assertContents (obj "cflags.var") "-O2 -I/path/to/dir -g -w"- assertContents (obj "hsflags.var") "-O2"- assertContents (obj "cflags.times") "XX"- assertContents (obj "hsflags.times") "X"- assertContents (obj "none.times") "X"
− Examples/Test/Digest.hs
@@ -1,78 +0,0 @@--module Examples.Test.Digest(main) where--import Control.Monad-import Development.Shake-import Examples.Util---main = shaken test $ \args obj -> do- want [obj "Out.txt",obj "Out2.txt"]-- obj "Out.txt" *> \out -> do- txt <- readFile' $ obj "In.txt"- liftIO $ appendFile out txt-- [obj "Out1.txt",obj "Out2.txt"] &*> \[out1,out2] -> do- txt <- readFile' $ obj "In.txt"- liftIO $ appendFile out1 txt- liftIO $ appendFile out2 txt---test build obj = do- let outs = take 1 $ map obj ["Out.txt","Out1.txt","Out2.txt"]- let writeOut x = forM_ outs $ \out -> writeFile out x- let writeIn x = writeFile (obj "In.txt") x- let assertOut x = forM_ outs $ \out -> assertContents out x-- writeOut ""- writeIn "X"- build ["--sleep","--digest-and"]- assertOut "X"-- -- should not involve a hash calculation (sadly no way to test that)- build ["--sleep","--digest-and"]- assertOut "X"-- writeIn "X"- build ["--sleep","--digest-and"]- assertOut "X"-- writeIn "X"- build ["--sleep","--digest-or"]- assertOut "XX"-- writeIn "X"- build ["--sleep","--digest-and"]- assertOut "XX"-- build ["--sleep","--digest-and"]- writeOut "XX"- build ["--sleep","--digest-and"]- assertOut "XX"-- build ["--sleep","--digest-and"]- writeOut "Y"- build ["--sleep","--digest-and"]- assertOut "YX"-- writeIn "X"- build ["--sleep","--digest"]- assertOut "YX"-- writeIn "Z"- build ["--sleep","--digest-and-input"]- assertOut "YXZ"-- build ["--sleep","--digest-and-input"]- writeOut "YXZ"- build ["--sleep","--digest-and-input"]- assertOut "YXZZ"-- writeIn "Q"- build ["--sleep","--digest-and-input"]- assertOut "YXZZQ"-- writeIn "Q"- build ["--sleep","--digest-and-input"]- assertOut "YXZZQ"
− Examples/Test/Directory.hs
@@ -1,109 +0,0 @@--module Examples.Test.Directory(main) where--import Development.Shake-import Development.Shake.FilePath-import Examples.Util-import Data.List-import Control.Monad-import System.Directory(getCurrentDirectory, setCurrentDirectory, createDirectory, createDirectoryIfMissing)-import qualified System.Directory as IO----- Use escape characters, _o=* _l=/ __=<space>-readEsc ('_':'o':xs) = '*' : readEsc xs-readEsc ('_':'l':xs) = '/' : readEsc xs-readEsc ('_':'_':xs) = ' ' : readEsc xs-readEsc (x:xs) = x : readEsc xs-readEsc [] = []--showEsc = concatMap f- where f '*' = "_o"- f '/' = "_l"- f ' ' = "__"- f x = [x]---main = shaken test $ \args obj -> do- want $ map obj args- obj "*.contents" *> \out ->- writeFileLines out =<< getDirectoryContents (obj $ readEsc $ dropExtension $ unobj out)- obj "*.dirs" *> \out ->- writeFileLines out =<< getDirectoryDirs (obj $ readEsc $ dropExtension $ unobj out)- obj "*.files" *> \out -> do- let pats = readEsc $ dropExtension $ unobj out- let (x:xs) = ["" | " " `isPrefixOf` pats] ++ words pats- writeFileLines out =<< getDirectoryFiles (obj x) xs-- obj "*.exist" *> \out -> do- let xs = map obj $ words $ readEsc $ dropExtension $ unobj out- fs <- mapM doesFileExist xs- ds <- mapM doesDirectoryExist xs- let bool x = if x then "1" else "0"- writeFileLines out $ zipWith (\a b -> bool a ++ bool b) fs ds-- obj "dots" *> \out -> do- cwd <- liftIO getCurrentDirectory- liftIO $ setCurrentDirectory $ obj ""- b1 <- liftM2 (==) (getDirectoryContents ".") (getDirectoryContents "")- b2 <- liftM2 (==) (getDirectoryDirs ".") (getDirectoryDirs "")- b3 <- liftM2 (==) (getDirectoryFiles "." ["*.txt"]) (getDirectoryFiles "" ["*.txt"])- b4 <- liftM2 (==) (getDirectoryFiles "." ["C.txt/*.txt"]) (getDirectoryFiles "" ["C.txt/*.txt"])- b5 <- liftM2 (==) (getDirectoryFiles "." ["//*.txt"]) (getDirectoryFiles "" ["//*.txt"])- liftIO $ setCurrentDirectory cwd- writeFileLines out $ map show [b1,b2,b3,b4,b5]--test build obj = do- let demand x ys = let f = showEsc x in do build [f]; assertContents (obj f) $ unlines $ words ys- build ["clean"]- demand " *.txt.files" ""- demand " //*.txt.files" ""- demand ".dirs" ""- demand "A.txt B.txt C.txt.exist" "00 00 00"-- writeFile (obj "A.txt") ""- writeFile (obj "B.txt") ""- createDirectory (obj "C.txt")- writeFile (obj "C.txt/D.txt") ""- writeFile (obj "C.txt/E.xtx") ""- demand " *.txt.files" "A.txt B.txt"- demand ".dirs" "C.txt"- demand "A.txt B.txt C.txt.exist" "10 10 01"- demand " //*.txt.files" "A.txt B.txt C.txt/D.txt"- demand "C.txt *.txt.files" "D.txt"- demand " *.txt //*.xtx.files" "A.txt B.txt C.txt/E.xtx"- demand " C.txt/*.files" "C.txt/D.txt C.txt/E.xtx"-- build ["dots","--no-lint"]- assertContents (obj "dots") $ unlines $ words "True True True True True"-- let removeTest pat del keep = do- withTemporaryDirectory $ \dir -> do- forM_ (del ++ keep) $ \s -> do- createDirectoryIfMissing True $ dir </> takeDirectory s- when (not $ hasTrailingPathSeparator s) $- writeFile (dir </> s) ""- removeFiles dir pat- createDirectoryIfMissing True dir- forM_ (map ((,) False) del ++ map ((,) True) keep) $ \(b,s) -> do- b2 <- (if hasTrailingPathSeparator s then IO.doesDirectoryExist else IO.doesFileExist) $ dir </> s- when (b /= b2) $ do- let f b = if b then "present" else "missing"- error $ "removeFiles mismatch: with pattern " ++ show pat ++ ", " ++ s ++- " should be " ++ f b ++ " but is " ++ f b2-- removeTest ["//bob"] ["test/bob","more/bob"] ["extra/obo"]- removeTest ["bob"] ["bob/"] ["bar/"]- removeTest ["*.hs"] ["test.hs"] ["extra/more.hs","new.txt"]- removeTest ["baz"] ["baz"] ["foo","bar/bob"]- removeTest ["baz"] ["baz/bob","baz/"] ["foo","bar/bob"]- removeTest ["Foo//*"] ["Foo/bar","Foo/Quux/bar","Foo/Quux/"] []- removeTest ["Foo//*"] ["Foo/"] ["bar"]- removeTest ["baz"] [] ["test.hs","bar/","foo/"]- removeTest ["bob//*"] [] ["test/bob/"]- removeTest ["//bob"] ["test/bob/","test/"] []- removeTest ["//*.txt"] ["more/","more/a.txt"] []- removeTest ["//*.txt"] ["more/","more/a.txt/"] []- removeTest ["//*.txt"] ["more/","more/a.txt/","more/b.txt"] []- removeTest ["//*.txt"] [] ["more/"]- removeTest ["a//b"] ["a/c/b"] []
− Examples/Test/Docs.hs
@@ -1,264 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module Examples.Test.Docs(main) where--import Development.Shake-import Development.Shake.FilePath-import Examples.Util-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import System.Directory-import System.Exit---reps from to = map (\x -> if x == from then to else x)--main = shaken noTest $ \args obj -> do- let index = "dist/doc/html/shake/index.html"- want [obj "Success.txt"]-- want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args-- let needSource = need =<< getDirectoryFiles "." ["Development/Shake.hs","Development/Shake//*.hs","Development/Ninja/*.hs","General//*.hs"]-- index *> \_ -> do- needSource- need ["shake.cabal"]- trackAllow ["dist//*"]- res <- liftIO $ findExecutable "cabal"- if isJust res then cmd "cabal haddock" else do- Exit exit <- cmd "runhaskell Setup.hs haddock"- when (exit /= ExitSuccess) $ do- () <- cmd "runhaskell Setup.hs configure"- cmd "runhaskell Setup.hs haddock"-- obj "Paths_shake.hs" *> \out -> do- copyFile' "Paths.hs" out-- obj "Part_*.hs" *> \out -> do- need ["Examples/Test/Docs.hs"] -- so much of the generator is in this module- src <- if "_md" `isSuffixOf` takeBaseName out then- fmap (findCodeMarkdown . lines) $ readFile' $ "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md"- else- fmap findCodeHaddock $ readFile' $ "dist/doc/html/shake/" ++ reps '_' '-' (drop 5 $ takeBaseName out) ++ ".html"- let f i (Stmt x) | whitelist $ head x = []- | otherwise = restmt i $ map undefDots $ trims x- f i (Expr x) | takeWhile (not . isSpace) x `elem` types = ["type Expr_" ++ show i ++ " = " ++ x]- | "import " `isPrefixOf` x = [x]- | otherwise = ["expr_" ++ show i ++ " = (" ++ undefDots x2 ++ ")" | let x2 = trim $ dropComment x, not $ whitelist x2]- code = concat $ zipWith f [1..] (nub src)- (imports,rest) = partition ("import " `isPrefixOf`) code- writeFileLines out $- ["{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, ExtendedDefaultRules, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}"- ,"{-# OPTIONS_GHC -w #-}"- ,"module " ++ takeBaseName out ++ "() where"- ,"import Control.Concurrent"- ,"import Control.Monad"- ,"import Data.Char"- ,"import Data.Data"- ,"import Data.List"- ,"import Data.Maybe"- ,"import Data.Monoid"- ,"import Development.Shake"- ,"import Development.Shake.Classes"- ,"import Development.Shake.Rule"- ,"import Development.Shake.Util"- ,"import Development.Shake.FilePath"- ,"import System.Console.GetOpt"- ,"import System.Exit"- ,"import System.IO"] ++- ["import " ++ reps '_' '.' (drop 5 $ takeBaseName out) | not $ "_md.hs" `isSuffixOf` out] ++- imports ++- ["(==>) :: Bool -> Bool -> Bool"- ,"(==>) = undefined"- ,"infix 1 ==>"- ,"forAll f = f undefined"- ,"remaining = 1.1"- ,"done = 1.1"- ,"time_elapsed = 1.1"- ,"old = \"\""- ,"new = \"\""- ,"myfile = \"\""- ,"inputs = [\"\"]"- ,"files = [\"\"]"- ,"input = \"\""- ,"output = \"\""- ,"opts = shakeOptions"- ,"result = undefined :: IO (Maybe (Rules ()))"- ,"launchMissiles = undefined :: Bool -> IO ()"- ,"myVariable = ()"- ,"instance Eq (OptDescr a)"- ,"(foo,bar,baz) = undefined"- ,"str1 = \"\""- ,"str2 = \"\""- ,"str = \"\""- ,"((/./),(/../),(//)) = undefined"] ++- rest-- obj "Files.lst" *> \out -> do- need ["Examples/Test/Docs.hs"] -- so much of the generator is in this module- need [index,obj "Paths_shake.hs"]- filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"]- filesMd <- getDirectoryFiles "docs" ["*.md"]- writeFileChanged out $ unlines $- ["Part_" ++ reps '-' '_' (takeBaseName x) | x <- filesHs, not $ "-Classes.html" `isSuffixOf` x] ++- ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd]-- let needModules = do mods <- readFileLines $ obj "Files.lst"; need [obj m <.> "hs" | m <- mods]; return mods-- obj "Main.hs" *> \out -> do- mods <- needModules- writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m | m <- mods] ++ ["main = return ()"]-- obj "Success.txt" *> \out -> do- needModules- need [obj "Main.hs", obj "Paths_shake.hs"]- needSource- () <- cmd "runhaskell -ignore-package=hashmap" ["-i" ++ obj "", obj "Main.hs"]- writeFile' out ""---data Code = Stmt [String] | Expr String deriving (Show,Eq)--findCodeHaddock :: String -> [Code]-findCodeHaddock x | Just x <- stripPrefix "<pre>" x = f (Stmt . shift . lines . strip) "</pre>" x- | Just x <- stripPrefix "<code>" x = f (Expr . strip) "</code>" x- where- f ctor end x | Just x <- stripPrefix end x = ctor "" : findCodeHaddock x- f ctor end (x:xs) = f (ctor . (x:)) end xs-findCodeHaddock (x:xs) = findCodeHaddock xs-findCodeHaddock [] = []--findCodeMarkdown :: [String] -> [Code]-findCodeMarkdown (x:xs) | indented x && not (blank x) =- let (a,b) = span (\x -> indented x || blank x) (x:xs)- in Stmt (map (drop 4) a) : findCodeMarkdown b- where- indented x = length (takeWhile isSpace x) >= 4- blank x = all isSpace x-findCodeMarkdown (x:xs) = f x ++ findCodeMarkdown xs- where- f ('`':xs) = let (a,b) = break (== '`') xs in Expr a : f (drop 1 b)- f (x:xs) = f xs- f [] = []-findCodeMarkdown [] = []--trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace-trims = reverse . dropWhile (all isSpace) . reverse . dropWhile (all isSpace)--restmt i ("":xs) = restmt i xs-restmt i (x:xs) | " ?== " `isInfixOf` x || " == " `isInfixOf` x =- zipWith (\j x -> "hack_" ++ show i ++ "_" ++ show j ++ " = " ++ x) [1..] (x:xs)-restmt i (x:xs) |- not ("let" `isPrefixOf` x) && not ("[" `isPrefixOf` x) && (" = " `isInfixOf` x || " | " `isInfixOf` x) ||- "import " `isPrefixOf` x || "infix" `isPrefixOf` x || "instance " `isPrefixOf` x = map f $ x:xs- where f x = if takeWhile (not . isSpace) x `elem` dupes then "_" ++ show i ++ "_" ++ x else x-restmt i xs = ("stmt_" ++ show i ++ " = do") : map (" " ++) xs ++- [" undefined" | length xs == 1 && ("let" `isPrefixOf` (head xs) || "<-" `isInfixOf` (head xs))]---shift :: [String] -> [String]-shift xs | all null xs = xs- | all (\x -> null x || " " `isPrefixOf` x) xs = shift $ map (drop 1) xs- | otherwise = xs---dropComment ('-':'-':_) = []-dropComment xs = onTail dropComment xs---undefDots o = f o- where- f ('.':'.':'.':xs) =- (if "cmd" `elem` words o then "[\"\"]" else "undefined") ++- (if "..." `isSuffixOf` xs then "" else undefDots xs)- f xs = onTail f xs--strip :: String -> String-strip x- | Just x <- stripPrefix "<em>" x- , (a,b) <- break (== '<') x- , not $ ("</em>" `isPrefixOf` b) && a `elem` italics- = error $ "Unexpected italics in code block: " ++ a ++ take 5 b ++ "..."-strip ('<':xs) = strip $ drop 1 $ dropWhile (/= '>') xs-strip ('&':xs)- | Just xs <- stripPrefix "quot;" xs = '\"' : strip xs- | Just xs <- stripPrefix "lt;" xs = '<' : strip xs- | Just xs <- stripPrefix "gt;" xs = '>' : strip xs- | Just xs <- stripPrefix "amp;" xs = '&' : strip xs-strip xs = onTail strip xs--onTail f (x:xs) = x : f xs-onTail f [] = []---italics :: [String]-italics = words "extension command-name file-name"--whitelist :: String -> Bool-whitelist x | all (not . isSpace) x && takeExtension x `elem` words ".txt .hi .hs .o .exe .tar .cpp .cfg .dep .deps .h .c .html" = True-whitelist x | elem x $ words $- "newtype do MyFile.txt.digits excel a q m c x value key gcc cl os make contents tar ghc cabal clean _make distcc ghc " ++- ".. /./ /.. ./ // \\ ../ " ++- "ConstraintKinds GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " ++- "Data.List System.Directory Development.Shake.FilePath main.m run .rot13 " ++- "NoProgress Error src rot13 .js .json .trace about://tracing " ++- ".make/i586-linux-gcc/output _make/.database foo/.. file.src file.out build " ++- "/usr/special /usr/special/userbinary $CFLAGS %PATH% -O2 -j8 -j -j1 " ++- "-threaded -rtsopts -I0 Function extension $OUT $C_LINK_FLAGS $PATH xterm $TERM main opts result flagValues argValues " ++- "HEADERS_DIR /path/to/dir CFLAGS let -showincludes -MMD gcc.version linkFlags temp pwd touch code out err " ++- "_metadata/.database _shake _shake/build ./build.sh build.sh build.bat //* [out] manual/examples.zip manual " ++- "docs/manual _build _build/run ninja depfile build.ninja "- = True-whitelist x = x `elem`- ["[Foo.hi, Foo.o]"- ,"shake-progress"- ,"main -j6"- ,"main clean"- ,"1m25s (15%)"- ,"3m12s (82%)"- ,"getPkgVersion $ GhcPkgVersion \"shake\""- ,"# command-name (for file-name)"- ,"ghc --make MyBuildSystem -rtsopts -with-rtsopts=-I0"- ,"-with-rtsopts"- ,"-qg -qb"- ,"gcc -MM"- ,"# This is my Config file"- ,"-g -I/path/to/dir -O2"- ,"main _make/henry.txt"- ,"<i>build rules</i>"- ,"<i>actions</i>"- ,"() <- cmd ..."- ,"x <- inputs"- ,"shakeFiles=\"_build/\""- ,"#include \""- ,"pattern *> actions = (pattern ?==) ?> actions" -- because it overlaps- ,"buildDir = \"_build\""- ,"-MMD -MF"- ,"#!/bin/sh"- ,"build _build/main.o"- ,"build clean"- ,"build -j8"- ,"runhaskell _build/run"- ,"runhaskell _build/run clean"- ,"gcc -c main.c -o main.o -MMD -MF main.m"- ,"\"_build\" </> x -<.> \"o\""- ,"cmd \"gcc -o\" [out] os"- ,"rot13 file.txt -o file.rot13"- ,"file.rot13"- ,"out -<.> \"txt\""- ,"[item1,item2,item2]"- ,"runhaskell Build.hs"- ,"cabal update"- ,"cabal install shake"- ,"shake -j4"- ,"cmd \"gcc -o _make/run _build/main.o _build/constants.o\""- ]--types = words $- "MVar IO Monad Monoid String FilePath Data Maybe [String] Eq Typeable Char ExitCode Change " ++- "Action Resource Assume FilePattern Lint Verbosity Rules Rule CmdOption CmdResult Int Double"--dupes = words "main progressSimple rules"
− Examples/Test/Errors.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Examples.Test.Errors(main) where--import Development.Shake-import Examples.Util-import Control.Monad-import System.Directory as IO---main = shaken test $ \args obj -> do- want $ map obj args-- obj "norule" *> \_ ->- need [obj "norule_isavailable"]-- obj "failcreate" *> \_ ->- return ()-- [obj "failcreates", obj "failcreates2"] &*> \_ ->- writeFile' (obj "failcreates") ""-- obj "recursive" *> \out ->- need [out]-- obj "systemcmd" *> \_ ->- cmd "random_missing_command"-- obj "stack1" *> \_ -> need [obj "stack2"]- obj "stack2" *> \_ -> need [obj "stack3"]- obj "stack3" *> \_ -> error "crash"-- obj "staunch1" *> \out -> do- liftIO $ sleep 0.1- writeFile' out "test"- obj "staunch2" *> \_ -> error "crash"-- let catcher out op die = obj out *> \out -> do- writeFile' out "0"- op (when die $ error "die") (writeFile out "1")- catcher "finally1" actionFinally True- catcher "finally2" actionFinally False- catcher "exception1" actionOnException True- catcher "exception2" actionOnException False-- res <- newResource "resource_name" 1- obj "resource" *> \out -> do- withResource res 1 $- need ["resource-dep"]-- obj "overlap.txt" *> \out -> writeFile' out "overlap.txt"- obj "overlap.t*" *> \out -> writeFile' out "overlap.t*"- obj "overlap.*" *> \out -> writeFile' out "overlap.*"- alternatives $ do- obj "alternative.t*" *> \out -> writeFile' out "alternative.txt"- obj "alternative.*" *> \out -> writeFile' out "alternative.*"---test build obj = do- let crash args parts = assertException parts (build $ "--quiet" : args)-- crash ["norule"] ["norule_isavailable"]- crash ["failcreate"] ["failcreate"]- crash ["failcreates"] ["failcreates"]- crash ["recursive"] ["recursive"]- crash ["systemcmd"] ["systemcmd","random_missing_command"]- crash ["stack1"] ["stack1","stack2","stack3","crash"]-- b <- IO.doesFileExist $ obj "staunch1"- when b $ removeFile $ obj "staunch1"- crash ["staunch1","staunch2","-j2"] ["crash"]- b <- IO.doesFileExist $ obj "staunch1"- assert (not b) "File should not exist, should have crashed first"- crash ["staunch1","staunch2","-j2","--keep-going","--silent"] ["crash"]- b <- IO.doesFileExist $ obj "staunch1"- assert b "File should exist, staunch should have let it be created"-- crash ["finally1"] ["die"]- assertContents (obj "finally1") "1"- build ["finally2"]- assertContents (obj "finally2") "1"- crash ["exception1"] ["die"]- assertContents (obj "exception1") "1"- build ["exception2"]- assertContents (obj "exception2") "0"-- crash ["resource"] ["cannot currently call apply","withResource","resource_name"]-- build ["overlap.foo"]- assertContents (obj "overlap.foo") "overlap.*"- build ["overlap.txt"]- assertContents (obj "overlap.txt") "overlap.txt"- crash ["overlap.txx"] ["key matches multiple rules","overlap.txx"]- build ["alternative.foo","alternative.txt"]- assertContents (obj "alternative.foo") "alternative.*"- assertContents (obj "alternative.txt") "alternative.txt"
− Examples/Test/FilePath.hs
@@ -1,96 +0,0 @@--module Examples.Test.FilePath(main) where--import Development.Shake.FilePath-import qualified System.FilePath as Native-import qualified System.FilePath.Posix as Posix-import General.Base-import Examples.Util-import Test.QuickCheck-import Control.Monad-import Data.List-import qualified Data.ByteString.Char8 as BS-import qualified Development.Shake.ByteString as BS---main = shaken test $ \args obj -> return ()---newtype File = File String deriving Show--instance Arbitrary File where- arbitrary = fmap File $ listOf $ oneof $ map return "abc /\\:."---test build obj = do- let a === b = a Examples.Util.=== b -- duplicate definition in QuickCheck 2.7 and above-- let norm x =- let s = normalise x- b = BS.unpack (BS.normalise $ BS.pack x)- in if s == b then s else error $ show ("Normalise functions differ",x,s,b)- -- basic examples- norm "" === "."- norm "." === "."- norm "/" === "/"- norm "./" === "./"- norm "/." === "/."- norm "/./" === "/"- norm "a/." === "a"- norm "./a" === "a"- norm "./a/." === "a"- norm "./a/./" === "a/"- norm "a/.." === "."- norm "a/./.." === "."- norm "a/../" === "./"- norm "/a/../" === "/"- norm "/a/./../" === "/"- norm "../a" === "../a"- norm "/../a/" === "/../a/"-- -- more realistic examples- norm "neil//./test/moo/../bar/bob/../foo" === "neil/test/bar/foo"- norm "bar/foo" === "bar/foo"- norm "bar/foo/" === "bar/foo/"- norm "../../foo" === "../../foo"- norm "foo/../..///" === "../"- norm "foo/bar/../../neil" === "neil"- norm "foo/../bar/../neil" === "neil"- norm "/foo/bar" === "/foo/bar"- norm "//./" === (if isWindows then "//" else "/")- norm "//foo/./bar" === (if isWindows then "//foo/bar" else "/foo/bar")- when isWindows $ norm "c:\\foo\\bar" === "c:/foo/bar"- Success{} <- quickCheckWithResult stdArgs{maxSuccess=1000} $ \(File x) ->- let y = norm x- sep = Native.isPathSeparator- noDrive = if isWindows then drop 1 else id- ps = [length y >= 1- ,null x || (sep (head x) == sep (head y) && sep (last x) == sep (last y))- ,not $ "/./" `isInfixOf` y- ,not isWindows || '\\' `notElem` y- ,not $ "//" `isInfixOf` noDrive y- ,".." `notElem` dropWhile (== "..") (splitDirectories $ dropWhile sep y)- ,norm y == y]- in if and ps then True else error $ show (x, y, ps)-- dropDirectory1 "aaa/bbb" === "bbb"- dropDirectory1 "aaa/" === ""- dropDirectory1 "aaa" === ""- dropDirectory1 "" === ""-- takeDirectory1 "aaa/bbb" === "aaa"- takeDirectory1 "aaa/" === "aaa"- takeDirectory1 "aaa" === "aaa"-- combine "." "ccc" === "ccc"- combine "aaa/bbb" "ccc" === "aaa/bbb/ccc"- combine "aaa/bbb" "./ccc" === "aaa/bbb/ccc"- combine "aaa/bbb" "../ccc" === "aaa/ccc"- combine "aaa/bbb" "../../ccc" === "ccc"- combine ".." "aaa" === "../aaa"- combine "../.." "aaa" === "../../aaa"- combine "./a" "../aaa" === "aaa"- combine ".." "../aaa" === "../../aaa"-- searchPathSeparator === Native.searchPathSeparator- pathSeparators === Posix.pathSeparators
− Examples/Test/FilePattern.hs
@@ -1,61 +0,0 @@--module Examples.Test.FilePattern(main) where--import Development.Shake.FilePattern-import Examples.Util--main = shaken test $ \args obj -> return ()---test build obj = do- let f b pat file = assert (b == (pat ?== file)) $ show pat ++ " ?== " ++ show file ++ "\nEXPECTED: " ++ show b- f True "//*.c" "foo/bar/baz.c"- f True "*.c" "baz.c"- f True "//*.c" "baz.c"- f True "test.c" "test.c"- f False "*.c" "foor/bar.c"- f False "*/*.c" "foo/bar/baz.c"- f False "foo//bar" "foobar"- f False "foo//bar" "foobar/bar"- f False "foo//bar" "foo/foobar"- f True "foo//bar" "foo/bar"-- assert (compatible []) "compatible"- assert (compatible ["//*a.txt","foo//a*.txt"]) "compatible"- assert (not $ compatible ["//*a.txt","foo//a*.*txt"]) "compatible"- extract "//*a.txt" "foo/bar/testa.txt" === ["foo/bar/","test"]- extract "//*a.txt" "testa.txt" === ["","test"]- extract "//*a*.txt" "testada.txt" === ["","test","da"]- substitute ["","test","da"] "//*a*.txt" === "testada.txt"- substitute ["foo/bar/","test"] "//*a.txt" === "foo/bar/testa.txt"-- directories1 "*.xml" === ("",False)- directories1 "//*.xml" === ("",True)- directories1 "foo//*.xml" === ("foo",True)- directories1 "foo/bar/*.xml" === ("foo/bar",False)- directories1 "*/bar/*.xml" === ("",True)- directories ["*.xml","//*.c"] === [("",True)]- directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]- directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]--------------------------------------------------------------------------- LAZY SMALLCHECK PROPERTIES--{--newtype Pattern = Pattern FilePattern deriving (Show,Eq)-newtype Path = Path FilePath deriving (Show,Eq)---- Since / and * are the only "interesting" elements, just add ab to round out the set--instance Serial Pattern where- series = cons Pattern >< f- where f = cons [] \/ cons (:) >< const (drawnFrom "/*ab") >< f--instance Serial Path where- series = cons Path >< f- where f = cons [] \/ cons (:) >< const (drawnFrom "/ab") >< f--testSmallCheck = do- smallCheck 10 $ \(Pattern p) (Path x) -> p ?== x ==> substitute (extract p x) p == x--}
− Examples/Test/Files.hs
@@ -1,39 +0,0 @@--module Examples.Test.Files(main) where--import Development.Shake-import Examples.Util-import Control.Monad-import Data.List---main = shaken test $ \args obj -> do- let fun = "@" `elem` args- let rest = delete "@" args- want $ map obj $ if null rest then ["even.txt","odd.txt"] else rest-- -- 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-- 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_ [[],["@"]] $ \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 ["--no-build","--report=-"]- build ["dir1/out.txt"]
− Examples/Test/Journal.hs
@@ -1,44 +0,0 @@--module Examples.Test.Journal(main) where--import Control.Monad-import Data.IORef-import Development.Shake-import Development.Shake.FilePath-import Examples.Util-import System.IO.Unsafe---{-# NOINLINE rebuilt #-}-rebuilt :: IORef Int-rebuilt = unsafePerformIO $ newIORef 0---main = shaken test $ \args obj -> do- want $ map obj ["a.out","b.out","c.out"]- obj "*.out" *> \out -> do- liftIO $ atomicModifyIORef rebuilt $ \a -> (a+1,())- copyFile' (out -<.> "in") out---test build obj = do- - let change x = writeFile (obj $ x <.> "in") x- let count x = do- before <- readIORef rebuilt- build ["--sleep"]- after <- readIORef rebuilt- x === after - before-- change "a"- change "b"- change "c"- count 3-- -- test that compressing the database doesn't corrupt anything- replicateM_ 4 $ do- change "a"- count 1- change "a"- change "c"- count 2
− Examples/Test/Lint.hs
@@ -1,119 +0,0 @@--module Examples.Test.Lint(main) where--import Development.Shake-import Development.Shake.FilePath-import Examples.Util-import Control.Exception hiding (assert)-import System.Directory as IO-import Control.Monad-import Data.Maybe---main = shaken test $ \args obj -> do- want $ map obj args-- addOracle $ \() -> do- liftIO $ createDirectoryIfMissing True $ obj "dir"- liftIO $ setCurrentDirectory $ obj "dir"- return ()-- obj "changedir" *> \out -> do- () <- askOracle ()- writeFile' out ""-- obj "pause.*" *> \out -> do- liftIO $ sleep 0.1- need [obj "cdir" <.> takeExtension out]- writeFile' out ""-- obj "cdir.*" *> \out -> do- pwd <- liftIO getCurrentDirectory- let dir2 = obj $ "dir" ++ takeExtension out- liftIO $ createDirectoryIfMissing True dir2- liftIO $ setCurrentDirectory dir2- liftIO $ sleep 0.2- liftIO $ setCurrentDirectory pwd- writeFile' out ""-- obj "createonce" *> \out -> do- writeFile' out "X"-- obj "createtwice" *> \out -> do- need [obj "createonce"]- liftIO sleepFileTime- 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") ""- writeFile' out ""-- obj "gen*" *> \out -> do- writeFile' out out-- obj "needed1" *> \out -> do- needed [obj "gen1"]- writeFile' out ""-- obj "needed2" *> \out -> do- orderOnly [obj "gen2"]- needed [obj "gen2"]- writeFile' out ""-- obj "tracker-write1" *> \out -> do- () <- cmd "cmd /c" ["echo x > " ++ out <.> "txt"]- need [out <.> "txt"]- writeFile' out ""-- obj "tracker-write2" *> \out -> do- () <- cmd "cmd /c" ["echo x > " ++ out <.> "txt"]- writeFile' out ""-- obj "tracker-source2" *> \out -> copyFile' (obj "tracker-source1") out- obj "tracker-read1" *> \out -> do- () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source1") ++ " > nul"]- writeFile' out ""- obj "tracker-read2" *> \out -> do- () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source1") ++ " > nul"]- need [obj "tracker-source1"]- writeFile' out ""- obj "tracker-read3" *> \out -> do- () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source2") ++ " > nul"]- need [obj "tracker-source2"]- writeFile' out ""---test build obj = do- dir <- getCurrentDirectory- let crash args parts = do- assertException parts (build $ "--quiet" : args)- `finally` setCurrentDirectory dir-- 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"] ["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"]- crash ["needed1"] ["'needed' file required rebuilding"]- build ["needed2"]-- tracker <- findExecutable "tracker.exe"- when (isJust tracker) $ do- writeFile (obj "tracker-source1") ""- writeFile (obj "tracker-source2") ""- crash ["tracker-write1"] ["not have its creation tracked","lint/tracker-write1","lint/tracker-write1.txt"]- build ["tracker-write2"]- crash ["tracker-read1"] ["used but not depended upon","lint/tracker-source1"]- build ["tracker-read2"]- crash ["tracker-read3"] ["depended upon after being used","lint/tracker-source2"]
− Examples/Test/Makefile.hs
@@ -1,24 +0,0 @@--module Examples.Test.Makefile(main) where--import Development.Shake(action, liftIO)-import qualified Start as Makefile-import System.Environment-import Examples.Util-import Control.Monad-import Data.List-import Data.Maybe---main = shaken test $ \args obj ->- action $ liftIO $ do- unless (["@@"] `isPrefixOf` args) $- error "The 'makefile' example should only be used in test mode, to test using a makefile use the 'make' example."- withArgs [fromMaybe x $ stripPrefix "@" x | x <- drop 1 args] Makefile.main---test build obj = do- copyDirectoryChanged "Examples/MakeTutor" $ obj "MakeTutor"- build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]- build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]- build ["@@","--directory=" ++ obj "MakeTutor","@clean","--no-report"]
− Examples/Test/Manual.hs
@@ -1,24 +0,0 @@--module Examples.Test.Manual(main) where--import Development.Shake-import Development.Shake.FilePath-import Examples.Util-import General.Base---main = shaken test $ \args obj ->- action $ liftIO $ error "The 'manual' example should only be used in test mode"--test build obj = do- copyDirectoryChanged "docs/manual" $ obj "manual"- copyDirectoryChanged "Development" $ obj "manual/Development"- copyDirectoryChanged "General" $ obj "manual/General"- copyFileChanged "Paths.hs" $ obj "manual/Paths_shake.hs"- let cmdline = if isWindows then "build.bat" else "/bin/sh build.sh"- () <- cmd [Cwd $ obj "manual", Shell] cmdline "-j2"- assertExists $ obj "manual/_build/run" <.> exe- () <- cmd [Cwd $ obj "manual", Shell] cmdline- () <- cmd [Cwd $ obj "manual", Shell] [cmdline,"clean"]- assertMissing $ obj "manual/_build/run" <.> exe- return ()
− Examples/Test/Oracle.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}--module Examples.Test.Oracle(main) where--import Development.Shake-import Examples.Util-import Control.Monad---main = shaken test $ \args obj -> do- let f name lhs rhs = (,) name $- (do addOracle $ \k -> let _ = k `asTypeOf` lhs in return rhs; return ()- ,let o = obj name ++ ".txt" in do want [o]; o *> \_ -> do v <- askOracleWith lhs rhs; writeFile' o $ show v)- let tbl = [f "str-bool" "" True- ,f "str-int" "" (0::Int)- ,f "bool-str" True ""- ,f "int-str" (0::Int) ""]-- forM_ args $ \a -> case a of- '+':x | Just (add,_) <- lookup x tbl -> add- '*':x | Just (_,use) <- lookup x tbl -> use- '@':key -> do addOracle $ \() -> return key; return ()- '%':name -> let o = obj "unit.txt" in do want [o]; o *> \_ -> do {askOracleWith () ""; writeFile' o name}- '!':name -> do want [obj "rerun"]; obj "rerun" *> \out -> do alwaysRerun; writeFile' out name--test build obj = do- build ["clean"]-- -- check it rebuilds when it should- build ["@key","%name"]- assertContents (obj "unit.txt") "name"- build ["@key","%test"]- assertContents (obj "unit.txt") "name"- build ["@foo","%test"]- assertContents (obj "unit.txt") "test"-- -- check adding/removing redundant oracles does not trigger a rebuild- build ["@foo","%newer","+str-bool"]- assertContents (obj "unit.txt") "test"- build ["@foo","%newer","+str-int"]- assertContents (obj "unit.txt") "test"- build ["@foo","%newer"]- assertContents (obj "unit.txt") "test"-- -- check always run works- build ["!foo"]- assertContents (obj "rerun") "foo"- build ["!bar"]- assertContents (obj "rerun") "bar"-- -- check error messages are good- let errors args err = assertException [err] $ build $ "--quiet" : args-- build ["+str-int","*str-int"]- errors ["*str-int"] -- Building with an an Oracle that has been removed- "missing a call to addOracle"-- errors ["*str-bool"] -- Building with an Oracle that I know nothing about- "missing a call to addOracle"-- build ["+str-int","*str-int"]- errors ["+str-bool","*str-int"] -- Building with an Oracle that has changed type- "askOracle is used at the wrong type"-- errors ["+str-int","+str-bool"] -- Two Oracles with the same question type- "Only one call to addOracle is allowed"-- errors ["+str-int","*str-bool"] -- Using an Oracle at the wrong answer type- "askOracle is used at the wrong type"-- build ["+str-int","+str-int"] -- Two Oracles work if they aren't used- errors ["+str-int","+str-int","*str-int"] -- Two Oracles fail if they are used- "Only one call to addOracle is allowed"-- errors ["+str-int","+str-bool"] -- Two Oracles with the same answer type- "Only one call to addOracle is allowed"
− Examples/Test/OrderOnly.hs
@@ -1,41 +0,0 @@--module Examples.Test.OrderOnly(main) where--import Development.Shake-import Examples.Util---main = shaken test $ \args obj -> do- want $ map obj args-- obj "bar.txt" *> \out -> do- alwaysRerun- writeFile' out =<< liftIO (readFile $ obj "bar.in")-- obj "foo.txt" *> \out -> do- let src = obj "bar.txt"- orderOnly [src]- writeFile' out =<< liftIO (readFile src)- need [src]-- obj "baz.txt" *> \out -> do- let src = obj "bar.txt"- orderOnly [src]- liftIO $ appendFile out "x"---test build obj = do- writeFile (obj "bar.in") "in"- build ["foo.txt","--sleep"]- assertContents (obj "foo.txt") "in"- writeFile (obj "bar.in") "out"- build ["foo.txt","--sleep"]- assertContents (obj "foo.txt") "out"-- writeFile (obj "baz.txt") ""- writeFile (obj "bar.in") "in"- build ["baz.txt","--sleep"]- assertContents (obj "baz.txt") "x"- writeFile (obj "bar.in") "out"- build ["baz.txt"]- assertContents (obj "baz.txt") "x"
− Examples/Test/Pool.hs
@@ -1,81 +0,0 @@--module Examples.Test.Pool(main) where--import Examples.Util-import Development.Shake.Pool--import Control.Concurrent-import Control.Exception hiding (assert)-import Control.Monad---main = shaken test $ \args obj -> return ()---test build obj = do- let wait = sleep 0.01- forM_ [False,True] $ \deterministic -> do-- -- check that it aims for exactly the limit- forM_ [1..6] $ \n -> do- var <- newMVar (0,0) -- (maximum, current)- runPool deterministic n $ \pool ->- forM_ [1..5] $ \i ->- addPool pool $ do- modifyMVar_ var $ \(mx,now) -> return (max (now+1) mx, now+1)- wait- modifyMVar_ var $ \(mx,now) -> return (mx,now-1)- res <- takeMVar var- res === (min n 5, 0)-- -- check that exceptions are immediate- self <- myThreadId- handle (\(ErrorCall msg) -> msg === "pass") $- runPool deterministic 3 $ \pool -> do- addPool pool $ do- wait- error "pass"- addPool pool $ do- wait >> wait- throwTo self $ ErrorCall "fail" - wait >> wait -- give chance for a delayed exception-- -- check blocking works- done <- newMVar False- runPool deterministic 1 $ \pool -> do- var <- newEmptyMVar- addPool pool $ do- addPool pool $ do- wait- putMVar var ()- blockPool pool $ fmap ((,) False) $ takeMVar var- modifyMVar_ done $ const $ return True- done <- readMVar done- assert done "Blocking"-- -- check someone spawned when at zero todo still gets run- done <- newMVar False- runPool deterministic 1 $ \pool ->- addPool pool $ do- wait- addPool pool $ do- wait- modifyMVar_ done $ const $ return True- done <- readMVar done- assert done "Waiting on someone"-- -- check that killing a thread pool stops the tasks, bug 545- thread <- newEmptyMVar- done <- newEmptyMVar- res <- newMVar True- t <- forkIO $ finally (putMVar done ()) $ runPool deterministic 1 $ \pool ->- addPool pool $ do- t <- takeMVar thread- killThread t- wait -- allow the thread to die first- modifyMVar_ res (const $ return False)- putMVar thread t- takeMVar done- wait >> wait >> wait -- allow the bad thread to continue- res <- readMVar res- assert res "Early termination"
− Examples/Test/Progress.hs
@@ -1,75 +0,0 @@-{-# 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---main = shaken test $ \args obj -> return ()----- | 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- let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)- 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- [] -> 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])- -- 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---test build obj = do- -- perfect functions should match perfectly- xs <- prog [10,9..1]- drop 2 xs === [8,7..1]- xs <- prog $ map (*5) [10,9..1]- drop 2 xs === [8,7..1]- xs <- prog $ map (*0.2) [10,9..1]- let dp3 x = fromIntegral (round $ x * 1000 :: Int) / 1000- map dp3 (drop 2 xs) === [8,7..1]-- -- The properties below this line could be weakened-- -- increasing functions can't match- xs <- prog [5,6,7]- last xs === 7-- -- the first value must be plausible, or missing- xs <- prog [187]- assert (isNaN $ head xs) "No first value"-- -- desirable properties, could be weakened- xs <- progEx 2 $ 100:map (*2) [10,9..1]- drop 5 xs === [6,5..1]- xs <- progEx 1 $ [10,9,100,8,7,6,5,4,3,2,1]- assert (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close"-- -- if no progress is made, don't keep the time going up- xs <- prog [10,9,8,7,7,7,7,7]- drop 5 xs === [7,7,7]-- -- if the work rate changes, should somewhat reflect that- xs <- prog [10,9,8,7,6.5,6,5.5,5]- assert (last xs > 7.1) "Some discounting (factor=0 would give 7)"
− Examples/Test/Random.hs
@@ -1,149 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module Examples.Test.Random(main) where--import Development.Shake-import Examples.Util-import Control.Exception-import Control.Monad-import Data.List-import Data.Maybe-import Data.Time-import System.Environment-import System.Exit-import System.Random-import qualified Data.ByteString.Char8 as BS---inputRange = [1..10]--data Value = Single Int | Multiple [[Value]]- deriving (Read,Show,Eq)--data Source = Input Int | Output Int | Bang- deriving (Read,Show)--data Logic = Logic Int [[Source]]- | Want [Int]- deriving (Read,Show)---main = shaken test $ \args obj -> do- let toFile (Input i) = obj $ "input-" ++ show i ++ ".txt"- toFile (Output i) = obj $ "output-" ++ show i ++ ".txt"- toFile Bang = error "BANG"-- let randomSleep = liftIO $ do- i <- randomRIO (0, 25)- sleep $ fromInteger i / 100-- forM_ (map read $ filter (isNothing . asDuration) args) $ \x -> case x of- Want xs -> want $ map (toFile . Output) xs- Logic out srcs -> toFile (Output out) *> \out -> do- res <- fmap (show . Multiple) $ forM srcs $ \src -> do- randomSleep- need $ map toFile src- mapM (liftIO . fmap read . readFileStrict . toFile) src- randomSleep- writeFileChanged out res---asDuration :: String -> Maybe Double-asDuration x- | "s" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just i- | "m" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just $ i * 60- | otherwise = Nothing---test build obj = do- limit <- do- args <- getArgs- let bound = listToMaybe $ reverse $ mapMaybe asDuration args- start <- getCurrentTime- return $ when (isJust bound) $ do- now <- getCurrentTime- when (fromRational (toRational $ now `diffUTCTime` start) > fromJust bound) exitSuccess-- forM_ [1..] $ \count -> do- limit- putStrLn $ "* PERFORMING RANDOM TEST " ++ show count- build ["clean"]- build [] -- to create the directory- forM_ inputRange $ \i ->- writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i- logic <- randomLogic- runLogic [] logic- chng <- filterM (const randomIO) inputRange - forM_ chng $ \i ->- writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single $ negate i- runLogic chng logic- forM_ inputRange $ \i ->- writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i- logicBang <- addBang =<< addBang logic- j <- randomRIO (1::Int,8)- res <- try $ build $ "--exception" : ("-j" ++ show j) : map show (logicBang ++ [Want [i | Logic i _ <- logicBang]])- case res of- Left err- | "BANG" `isInfixOf` show (err :: SomeException) -> return () -- error I expected- | otherwise -> error $ "UNEXPECTED ERROR: " ++ show err- _ -> return () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt- runLogic [] $ logic ++ [Want [i | Logic i _ <- logic]]- where- runLogic :: [Int] -> [Logic] -> IO ()- runLogic negated xs = do- let poss = [i | Logic i _ <- xs]- i <- randomRIO (0, 7)- wants <- replicateM i $ do- i <- randomRIO (0, 5)- replicateM i $ randomElem poss- sleepFileTime- j <- randomRIO (1::Int,8)- build $ ("-j" ++ show j) : map show (xs ++ map Want wants)-- let value i = case [ys | Logic j ys <- xs, j == i] of- [ys] -> Multiple $ flip map ys $ map $ \i -> case i of- Input i -> Single $ if i `elem` negated then negate i else i- Output i -> value i- forM_ (concat wants) $ \i -> do- let wanted = value i- got <- fmap read $ readFileStrict $ obj $ "output-" ++ show i ++ ".txt"- when (wanted /= got) $- error $ "INCORRECT VALUE for " ++ show i---addBang :: [Logic] -> IO [Logic]-addBang xs = do- i <- randomRIO (0, length xs - 1)- let (before,now:after) = splitAt i xs- now <- f now- return $ before ++ now : after- where- f (Logic log xs) = do- i <- randomRIO (0, length xs)- let (before,after) = splitAt i xs- return $ Logic log $ before ++ [Bang] : after---randomLogic :: IO [Logic] -- only Logic constructors-randomLogic = do- rules <- randomRIO (1,100)- f rules $ map Input inputRange- where- f 0 avail = return []- f i avail = do- needs <- randomRIO (0,3)- xs <- replicateM needs $ do- ns <- randomRIO (0,3)- replicateM ns $ randomElem avail- let r = Logic i xs- fmap (r:) $ f (i-1) (Output i:avail)---randomElem :: [a] -> IO a-randomElem xs = do- i <- randomRIO (0, length xs - 1)- return $ xs !! i---readFileStrict :: FilePath -> IO String-readFileStrict = fmap BS.unpack . BS.readFile
− Examples/Test/Resources.hs
@@ -1,33 +0,0 @@--module Examples.Test.Resources(main) where--import Development.Shake-import Examples.Util-import Control.Monad-import Data.IORef---main extra = do- let cap = 2-- ref <- newIORef 0- flip (shaken test) extra $ \args obj -> do- want $ map obj ["file1.txt","file2.txt","file3.txt","file4.txt"]- res <- newResource "test" cap- res2 <- newResource "test" cap- unless (res < res2 || res2 < res) $ error "Resources should have a good ordering"- obj "*.txt" *> \out ->- withResource res 1 $ do- old <- liftIO $ atomicModifyIORef ref $ \i -> (i+1,i)- when (old >= cap) $ error "Too many resources in use at one time"- liftIO $ sleep 0.1- liftIO $ atomicModifyIORef ref $ \i -> (i-1,i)- writeFile' out ""--test build obj = do- build ["clean"]- build ["-j2"]- build ["clean"]- build ["-j4"]- build ["clean"]- build ["-j10"]
− Examples/Test/Throttle.hs
@@ -1,34 +0,0 @@--module Examples.Test.Throttle(main) where--import Development.Shake-import General.Base-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 loopM 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
@@ -1,61 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Examples.Test.Unicode(main) where--import Development.Shake-import Development.Shake.FilePath-import Examples.Util-import Control.Exception-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 = do- build ["clean"]- -- Useful, if the error message starts crashing...- -- 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- res <- try $ writeFile (ext "source") "x"- case res of- Left (err :: SomeException) ->- putStrLn $ "WARNING: Failed to write file " ++ pre ++ ", skipping unicode test (LANG=C ?)"- Right _ -> do- 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/Test/Util.hs
@@ -1,18 +0,0 @@--module Examples.Test.Util(main) where--import Development.Shake.Util-import Examples.Util---main = shaken test $ \args obj -> return ()---test build obj = do- parseMakefile "" === []- parseMakefile "a:b c\ndef : ee" === [("a",["b","c"]),("def",["ee"])]- parseMakefile "a: #comment\n#comment : b\nc : d" === [("a",[]),("c",["d"])]- parseMakefile "a \\\n\t:b" === [("a",["b"])]- parseMakefile "#comment\\ a : b" === []- parseMakefile "a: b c \\\n d e\n\nf:g" === [("a",["b","c","d","e"]),("f",["g"])]- parseMakefile "foo/bar: \\\r\n c:/a1 \\\r\n x\r\n" === [("foo/bar",["c:/a1","x"])]
− Examples/Test/Verbosity.hs
@@ -1,39 +0,0 @@--module Examples.Test.Verbosity(main) where--import Development.Shake-import Examples.Util---main = shaken test $ \args obj -> do- want $ map obj args-- obj "in.txt" *> \out -> do- a <- getVerbosity- b <- withVerbosity Normal $ getVerbosity- writeFile' out $ unwords $ map show [a,b]-- obj "out.txt" *> \out -> do- x <- getVerbosity- ys <- withVerbosity Loud $ do- a <- getVerbosity- need [obj "in.txt"] -- make sure the inherited verbosity does not get passed along- b <- getVerbosity- c <- quietly getVerbosity- d <- fmap shakeVerbosity getShakeOptions- return [a,b,c,d]- z <- getVerbosity- writeFile' out $ unwords $ map show $ [x] ++ ys ++ [z]--test build obj = do- build ["out.txt","--clean"]- assertContents (obj "in.txt") "Normal Normal"- assertContents (obj "out.txt") "Normal Loud Loud Quiet Normal Normal"-- build ["out.txt","--clean","--verbose"]- assertContents (obj "in.txt") "Loud Normal"- assertContents (obj "out.txt") "Loud Loud Loud Quiet Loud Loud"-- build ["out.txt","--clean","--quiet"]- assertContents (obj "in.txt") "Quiet Normal"- assertContents (obj "out.txt") "Quiet Loud Loud Quiet Quiet Quiet"
− Examples/Util.hs
@@ -1,202 +0,0 @@--module Examples.Util(sleep, module Examples.Util) where--import Development.Shake-import Development.Shake.Rule() -- ensure the module gets imported, and thus tested-import General.Base-import General.String-import Development.Shake.FileInfo-import Development.Shake.FilePath--import Control.Exception hiding (assert)-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import qualified Data.ByteString as BS-import System.Directory as IO-import System.Environment-import System.Random-import System.Console.GetOpt-import System.IO---shaken- :: (([String] -> IO ()) -> (String -> String) -> IO ())- -> ([String] -> (String -> String) -> Rules ())- -> IO ()- -> IO ()-shaken test rules sleeper = do- name:args <- getArgs- when ("--sleep" `elem` args) sleeper- putStrLn $ "## BUILD " ++ unwords (name:args)- args <- return $ delete "--sleep" args- let out = "output/" ++ name ++ "/"- createDirectoryIfMissing True out- case args of- "test":extra -> do- putStrLn $ "## TESTING " ++ name- -- if the extra arguments are not --quiet/--loud it's probably going to go wrong- let obj x = if "/" `isPrefixOf` x then init out ++ x else out ++ x- test (\args -> withArgs (name:args ++ extra) $ shaken test rules sleeper) obj- putStrLn $ "## FINISHED TESTING " ++ name- "clean":_ -> removeDirectoryRecursive out-{-- "lint":args -> do- let dbfile = out ++ ".database"- tempfile = "output/" ++ name ++ ".database"- b <- IO.doesFileExist dbfile- when b $ renameFile dbfile tempfile- removeDirectoryRecursive out- createDirectoryIfMissing True out- when b $ renameFile tempfile dbfile- shake shakeOptions{shakeFiles=out, shakeLint=True} $ rules args (out++)--}-- "perturb":args -> forever $ do- del <- removeFilesRandom out- threads <- randomRIO (1,4)- putStrLn $ "## TESTING PERTURBATION (" ++ show del ++ " files, " ++ show threads ++ " threads)"- shake shakeOptions{shakeFiles=out, shakeThreads=threads, shakeVerbosity=Quiet} $ rules args (out++)-- args -> do- let (_,files,_) = getOpt Permute [] args- tracker <- findExecutable "tracker.exe"- withArgs (args \\ files) $- shakeWithClean- (removeDirectoryRecursive out) - (shakeOptions{shakeFiles=out, shakeReport=["output/" ++ name ++ "/report.html"], shakeLint=Just $ if isJust tracker then LintTracker else LintBasic})- (rules files (out++))---shakeWithClean :: IO () -> ShakeOptions -> Rules () -> IO ()-shakeWithClean clean opts rules = shakeArgsWith opts [cleanOpt] f- where- cleanOpt = Option "c" ["clean"] (NoArg $ Right ()) "Clean before building."-- f extra files = do- when (extra /= []) clean- if "clean" `elem` files then- clean >> return Nothing- else- return $ Just $ if null files then rules else want files >> withoutActions rules---unobj :: FilePath -> FilePath-unobj = dropDirectory1 . dropDirectory1--assert :: Bool -> String -> IO ()-assert b msg = unless b $ error $ "ASSERTION FAILED: " ++ msg--infix 4 ===--(===) :: (Show a, Eq a) => a -> a -> IO ()-a === b = assert (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b---assertExists :: FilePath -> IO ()-assertExists file = do- b <- IO.doesFileExist file- assert b $ "File was expected to exist, but is missing: " ++ file--assertMissing :: FilePath -> IO ()-assertMissing file = do- b <- IO.doesFileExist file- assert (not b) $ "File was expected to be missing, but exists: " ++ file--assertContents :: FilePath -> String -> IO ()-assertContents file want = do- got <- readFile file- assert (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got--assertNonSpace :: FilePath -> String -> IO ()-assertNonSpace file want = do- got <- readFile file- let f = filter (not . isSpace)- assert (f want == f got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got--assertContentsInfix :: FilePath -> String -> IO ()-assertContentsInfix file want = do- got <- readFile file- assert (want `isInfixOf` got) $ "File contents are wrong: " ++ file ++ "\nWANT (anywhere): " ++ want ++ "\nGOT: " ++ got--assertException :: [String] -> IO () -> IO ()-assertException parts act = do- res <- try act- case res of- Left err -> let s = show (err :: SomeException) in forM_ parts $ \p ->- assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p- Right _ -> error "Expected an exception but succeeded"---noTest :: ([String] -> IO ()) -> (String -> String) -> IO ()-noTest build obj = do- build ["--abbrev=output=$OUT","-j3"]- build ["--no-build","--report=-"]- build []----- | 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- mtimes <- forM [1..10] $ \i -> fmap fst $ duration $ do- writeFile file $ show i- let time = fmap (fst . fromMaybe (error "File missing during sleepFileTimeCalibrate")) $ getFileInfo $ packU file- t1 <- time- flip loopM 0 $ \j -> do- writeFile file $ show (i,j)- t2 <- time- return $ if t1 == t2 then Left $ j+1 else Right ()- putStrLn $ "Longest file modification time lag was " ++ show (ceiling (maximum mtimes * 1000)) ++ "ms"- return $ sleep $ min 1 $ maximum mtimes * 2---removeFilesRandom :: FilePath -> IO Int-removeFilesRandom x = do- files <- getDirectoryContentsRecursive x- n <- randomRIO (0,length files)- rs <- replicateM (length files) (randomIO :: IO Double)- mapM_ (removeFile . snd) $ sort $ zip rs files- return n---getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive dir = do- xs <- IO.getDirectoryContents dir- (dirs,files) <- partitionM IO.doesDirectoryExist [dir </> x | x <- xs, not $ "." `isPrefixOf` x]- rest <- concatMapM getDirectoryContentsRecursive dirs- return $ files++rest---copyDirectoryChanged :: FilePath -> FilePath -> IO ()-copyDirectoryChanged old new = do- xs <- getDirectoryContentsRecursive old- forM_ xs $ \from -> do- let to = new </> drop (length $ addTrailingPathSeparator old) from- createDirectoryIfMissing True $ takeDirectory to- copyFileChanged from to---copyFileChanged :: FilePath -> FilePath -> IO ()-copyFileChanged old new = do- good <- IO.doesFileExist new- good <- if not good then return False else liftM2 (==) (BS.readFile old) (BS.readFile new)- when (not good) $ copyFile old new---withTemporaryDirectory :: (FilePath -> IO ()) -> IO ()-withTemporaryDirectory act = do- tdir <- getTemporaryDirectory- bracket- (openTempFile tdir "shake.hs")- (removeFile . fst)- $ \(file,h) -> do- hClose h- let dir = file ++ "_"- bracket_ (createDirectory dir) (removeDirectoryRecursive dir) (act dir)
General/Base.hs view
@@ -1,15 +1,16 @@ {-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} module General.Base(- Lock, newLock, withLock, withLockTry,- Var, newVar, readVar, modifyVar, modifyVar_, withVar,- Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe,- Duration, duration, Time, offsetTime, sleep,+ Duration, duration, Time, offsetTime, offsetTimeIncrease, sleep, isWindows, getProcessorCount,- readFileUCS2, getEnvMaybe, captureOutput,+ readFileStrict, readFileUCS2, getEnvMaybe, captureOutput, getExePath,+ randomElem, showDP, showTime, modifyIORef'', writeIORef'',- whenJust, loopM, whileM, partitionM, concatMapM, mapMaybeM, liftA2',+ isLeft_, isRight_,+ swap,+ whenJust, loopM, whileM, partitionM, concatMapM, mapMaybeM, liftA2', retry,+ ifM, notM, (&&^), (||^), fastNub, showQuote, word1, withBufferMode, withCapabilities ) where@@ -17,7 +18,7 @@ import Control.Applicative import Control.Arrow import Control.Concurrent-import Control.Exception+import Control.Exception as E import Control.Monad import Data.Char import Data.IORef@@ -31,76 +32,10 @@ import System.IO import System.IO.Error import System.IO.Unsafe+import System.Random import GHC.IO.Handle(hDuplicate,hDuplicateTo) 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--waitBarrierMaybe :: Barrier a -> IO (Maybe a)-waitBarrierMaybe (Barrier x) = do- res <- tryTakeMVar x- whenJust res $ putMVar x- return res+import Foreign.C.Types ---------------------------------------------------------------------@@ -116,7 +51,16 @@ end <- getCurrentTime return $ fromRational $ toRational $ end `diffUTCTime` start +-- | Like offsetTime, but results will never decrease (though they may stay the same)+offsetTimeIncrease :: IO (IO Time)+offsetTimeIncrease = do+ t <- offsetTime+ ref <- newIORef 0+ return $ do+ t <- t+ atomicModifyIORef ref $ \o -> let m = max t o in m `seq` (m, m) + type Duration = Float -- duration in seconds duration :: IO a -> IO (Duration, a)@@ -167,8 +111,8 @@ --------------------------------------------------------------------- -- Data.String -showDP :: Int -> Double -> String-showDP n x = a ++ "." ++ b ++ replicate (n - length b) '0'+showDP :: RealFloat a => Int -> a -> String+showDP n x = a ++ (if n > 0 then "." else "") ++ b ++ replicate (n - length b) '0' where (a,b) = second (drop 1) $ break (== '.') $ showFFloat (Just n) x "" showTime :: Double -> String@@ -181,6 +125,21 @@ ---------------------------------------------------------------------+-- Data.Either++isLeft_, isRight_ :: Either a b -> Bool+isLeft_ Left{} = True; isLeft_ Right{} = False+isRight_ = not . isLeft_+++---------------------------------------------------------------------+-- Data.Tuple++swap :: (a, b) -> (b, a)+swap (a, b) = (b, a)+++--------------------------------------------------------------------- -- Control.Monad whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()@@ -215,7 +174,28 @@ liftA2' :: Applicative m => m a -> m b -> (a -> b -> c) -> m c liftA2' a b f = liftA2 f a b +ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM b t f = do b <- b; if b then t else f +notM :: Functor m => m Bool -> m Bool+notM = fmap not++(||^), (&&^) :: Monad m => m Bool -> m Bool -> m Bool+(||^) a b = do a <- a; if a then return True else b+(&&^) a b = do a <- a; if a then b else return False++retry :: Int -> IO a -> IO a+retry i x | i <= 0 = error "retry count must be 1 or more"+retry 1 x = x+retry i x = do+ res <- E.try x+ case res of+ Left (e :: SomeException) -> do+ putStrLn $ "Retrying after exception: " ++ show e+ retry (i-1) x+ Right v -> return v++ --------------------------------------------------------------------- -- System.Info @@ -226,23 +206,38 @@ isWindows = False #endif --- Could be written better in C, but sticking to Haskell for laziness++-- Use the underlying GHC function+foreign import ccall getNumberOfProcessors :: IO CInt+++{-# NOINLINE getProcessorCount #-} getProcessorCount :: IO Int -- unsafePefromIO so we cache the result and only compute it once getProcessorCount = let res = unsafePerformIO act in return res where- act = handle (\(_ :: SomeException) -> return 1) $ do- env <- getEnvMaybe "NUMBER_OF_PROCESSORS"- case env of- Just s | [(i,"")] <- reads s -> return i- _ -> do- src <- readFile "/proc/cpuinfo"- return $ length [() | x <- lines src, "processor" `isPrefixOf` x]+ act =+ if rtsSupportsBoundThreads then+ fromIntegral <$> getNumberOfProcessors+ else+ handle (\(_ :: SomeException) -> return 1) $ do+ env <- getEnvMaybe "NUMBER_OF_PROCESSORS"+ case env of+ Just s | [(i,"")] <- reads s -> return i+ _ -> do+ src <- readFile "/proc/cpuinfo"+ return $ length [() | x <- lines src, "processor" `isPrefixOf` x] --------------------------------------------------------------------- -- System.IO +readFileStrict :: FilePath -> IO String+readFileStrict file = withFile file ReadMode $ \h -> do+ src <- hGetContents h+ evaluate $ length src+ return src+ readFileUCS2 :: FilePath -> IO String readFileUCS2 name = openFile name ReadMode >>= \h -> do hSetEncoding h utf16@@ -281,3 +276,20 @@ withBufferMode h b act = bracket (hGetBuffering h) (hSetBuffering h) $ const $ do hSetBuffering h LineBuffering act+++getExePath :: IO FilePath+#if __GLASGOW_HASKELL__ >= 706+getExePath = getExecutablePath+#else+getExePath = getProgName+#endif+++---------------------------------------------------------------------+-- System.Random++randomElem :: [a] -> IO a+randomElem xs = do+ i <- randomRIO (0, length xs - 1)+ return $ xs !! i
+ General/Bilist.hs view
@@ -0,0 +1,33 @@++module General.Bilist(+ Bilist, cons, snoc, uncons, toList, isEmpty+ ) where++import Data.Monoid+++data Bilist a = Bilist [a] [a]++toList :: Bilist a -> [a]+toList (Bilist as bs) = as ++ reverse bs++isEmpty :: Bilist a -> Bool+isEmpty (Bilist as bs) = null as && null bs++instance Eq a => Eq (Bilist a) where+ a == b = toList a == toList b++instance Monoid (Bilist a) where+ mempty = Bilist [] []+ mappend a b = Bilist (toList a ++ toList b) []++cons :: a -> Bilist a -> Bilist a+cons x (Bilist as bs) = Bilist (x:as) bs++snoc :: Bilist a -> a -> Bilist a+snoc (Bilist as bs) x = Bilist as (x:bs)++uncons :: Bilist a -> Maybe (a, Bilist a)+uncons (Bilist [] []) = Nothing+uncons (Bilist (a:as) bs) = Just (a, Bilist as bs)+uncons (Bilist [] bs) = uncons $ Bilist (reverse bs) []
+ General/Cleanup.hs view
@@ -0,0 +1,35 @@++-- | Code for ensuring cleanup actions are run.+module General.Cleanup(+ Cleanup, withCleanup, addCleanup+ ) where++import Control.Exception as E+import Control.Monad+import qualified Data.HashMap.Strict as Map+import Data.IORef+++data S = S {unique :: !Int, items :: Map.HashMap Int (IO ())}++newtype Cleanup = Cleanup (IORef S)+++-- | Run with some cleanup scope. Regardless of exceptions/threads, all 'addCleanup' actions+-- will be run by the time it exits.+withCleanup :: (Cleanup -> IO a) -> IO a+withCleanup act = do+ ref <- newIORef $ S 0 Map.empty+ act (Cleanup ref) `finally` do+ join $ atomicModifyIORef ref $ \s -> (s{items=Map.empty}, sequence_ $ Map.elems $ items s)+++-- | Add a cleanup action to a 'Cleanup' scope. If the return action is not run by the time+-- 'withCleanup' terminates then it will be run then. The argument 'Bool' is 'True' to say+-- run the action, 'False' to say ignore the action (and never run it).+addCleanup :: Cleanup -> IO () -> IO (Bool -> IO ())+addCleanup (Cleanup ref) act = atomicModifyIORef ref $ \s -> let i = unique s in+ (,) (S (unique s + 1) (Map.insert i act $ items s)) $ \b -> do+ join $ atomicModifyIORef ref $ \s -> case Map.lookup i $ items s of+ Nothing -> (s, return ())+ Just act -> (s{items = Map.delete i $ items s}, when b act)
+ General/Concurrent.hs view
@@ -0,0 +1,106 @@++module General.Concurrent(+ Lock, newLock, withLock, withLockTry,+ Var, newVar, readVar, modifyVar, modifyVar_, withVar,+ Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe,+ Fence, newFence, signalFence, waitFence, testFence,+ ) where++import Control.Applicative+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.IORef+import General.Base+++---------------------------------------------------------------------+-- 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) = void . tryPutMVar x++waitBarrier :: Barrier a -> IO a+waitBarrier (Barrier x) = readMVar x++waitBarrierMaybe :: Barrier a -> IO (Maybe a)+waitBarrierMaybe (Barrier x) = do+ res <- tryTakeMVar x+ whenJust res $ void . tryPutMVar x+ return res+++---------------------------------------------------------------------+-- FENCE++-- | Like a barrier, but based on callbacks+newtype Fence a = Fence (IORef (Either [a -> IO ()] a))+instance Show (Fence a) where show _ = "Fence"++newFence :: IO (Fence a)+newFence = Fence <$> newIORef (Left [])++signalFence :: Fence a -> a -> IO ()+signalFence (Fence ref) v = join $ atomicModifyIORef ref $ \x -> case x of+ Left queue -> (Right v, mapM_ ($ v) $ reverse queue)+ Right v -> error "Shake internal error, signalFence called twice on one Fence"++waitFence :: Fence a -> (a -> IO ()) -> IO ()+waitFence (Fence ref) call = join $ atomicModifyIORef ref $ \x -> case x of+ Left queue -> (Left (call:queue), return ())+ Right v -> (Right v, call v)++testFence :: Fence a -> IO (Maybe a)+testFence (Fence x) = either (const Nothing) Just <$> readIORef x
− General/RAW.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module General.RAW(- RAW, runRAW,- getRO, getRW, getsRO, getsRW, putRW, modifyRW,- withRO, withRW,- catchRAW, tryRAW, throwRAW,- evalRAW, unmodifyRW- ) where--import Control.Exception as E-import Control.Applicative-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import Data.IORef---newtype RAW ro rw a = RAW {fromRAW :: ReaderT (ro, IORef rw) IO a}- deriving (Functor, Applicative, Monad, MonadIO)--runRAW :: ro -> rw -> RAW ro rw a -> IO a-runRAW ro rw (RAW m) = do- ref <- newIORef rw- runReaderT m (ro, ref)--------------------------------------------------------------------------- STANDARD--getRO :: RAW ro rw ro-getRO = RAW $ asks fst--getRW :: RAW ro rw rw-getRW = RAW $ liftIO . readIORef =<< asks snd--getsRO :: (ro -> a) -> RAW ro rw a-getsRO f = fmap f getRO--getsRW :: (rw -> a) -> RAW ro rw a-getsRW f = fmap f getRW---- | Strict version-putRW :: rw -> RAW ro rw ()-putRW rw = rw `seq` RAW $ liftIO . flip writeIORef rw =<< asks snd--modifyRW :: (rw -> rw) -> RAW ro rw ()-modifyRW f = do x <- getRW; putRW $ f x--withRO :: (ro -> ro2) -> RAW ro2 rw a -> RAW ro rw a-withRO f m = RAW $ withReaderT (\(ro,rw) -> (f ro, rw)) $ fromRAW m--withRW :: (rw -> rw2) -> RAW ro rw2 a -> RAW ro rw a-withRW f m = RAW $ do- rw <- asks snd- ref <- liftIO $ newIORef . f =<< readIORef rw- withReaderT (\(ro,_) -> (ro,ref)) $ fromRAW m--------------------------------------------------------------------------- EXCEPTIONS--catchRAW :: Exception e => RAW ro rw a -> (e -> RAW ro rw a) -> RAW ro rw a-catchRAW m handle = RAW $ liftCatch E.catch (fromRAW m) (fromRAW . handle)--tryRAW :: Exception e => RAW ro rw a -> RAW ro rw (Either e a)-tryRAW m = catchRAW (fmap Right m) (return . Left)--throwRAW :: Exception e => e -> RAW ro rw a-throwRAW = liftIO . throwIO--------------------------------------------------------------------------- WEIRD STUFF---- | Given an action, produce a 'RAW' that runs fast, containing--- an 'IO' that runs slowly (the bulk of the work) and a 'RAW'--- that runs fast.-evalRAW :: RAW ro rw a -> RAW ro rw (IO (RAW ro rw a))-evalRAW m = RAW $ do- (ro,rw) <- ask- return $ do- ref <- newIORef =<< readIORef rw- res <- runReaderT (fromRAW m) (ro,ref)- return $ RAW $ do- (ro,rw) <- ask- liftIO $ writeIORef rw =<< readIORef ref- return res---- | Apply a modification, run an action, then undo the changes after.-unmodifyRW :: (rw -> (rw, rw -> rw)) -> RAW ro rw a -> RAW ro rw a-unmodifyRW f m = do- (s2,undo) <- fmap f getRW- putRW s2- res <- m- modifyRW undo- return res
+ General/Template.hs view
@@ -0,0 +1,30 @@++module General.Template(runTemplate) where++import Control.Monad+import Data.Char+import qualified Data.ByteString.Lazy.Char8 as LBS+++-- | Template Engine. Perform the following replacements on a line basis:+--+-- * <script src="foo"></script> ==> <script>[[foo]]</script>+--+-- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>+runTemplate :: Monad m => (FilePath -> m LBS.ByteString) -> LBS.ByteString -> m LBS.ByteString+runTemplate ask = liftM LBS.unlines . mapM f . LBS.lines+ where+ link = LBS.pack "<link href=\""+ script = LBS.pack "<script src=\""++ f x | Just file <- lbs_stripPrefix script y = do res <- grab file; return $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"+ | Just file <- lbs_stripPrefix link y = do res <- grab file; return $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"+ | otherwise = return x+ where+ y = LBS.dropWhile isSpace x+ grab = ask . takeWhile (/= '\"') . LBS.unpack+++lbs_stripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString+lbs_stripPrefix prefix text = if a == prefix then Just b else Nothing+ where (a,b) = LBS.splitAt (LBS.length prefix) text
README.md view
@@ -1,4 +1,4 @@-# Shake [](https://travis-ci.org/ndmitchell/shake)+# Shake [](http://hackage.haskell.org/package/shake) [](https://travis-ci.org/ndmitchell/shake) Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. @@ -21,3 +21,16 @@ * [Bugs](https://github.com/ndmitchell/shake/issues) can be reported on the GitHub issue tracker. * [Source code](http://github.com/ndmitchell/shake) in a git repo, stored at GitHub. * Continuous integration with [Travis](https://travis-ci.org/ndmitchell/shake) and [Hydra](http://hydra.cryp.to/jobset/shake/master).++#### Companies using Shake++* [Standard Chartered](http://www.standardchartered.com/) have been using Shake since 2009, as described in the section 6 of the [academic paper](http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf).+* [factis research GmbH](http://www.factisresearch.com/), as described in their [blog post](http://funktionale-programmierung.de/2014/01/16/build-system-haskell.html).+* [Samplecount](http://samplecount.com/) have been using Shake since 2012, as mentioned in their [tweet](https://twitter.com/samplecount/status/491581551730511872).+* At least 10 other companies are using Shake internally.++Is your company using Shake? Write something public (even just a [tweet to `@ndm_haskell`](https://twitter.com/ndm_haskell)) and I'll include a link.++#### Projects using Shake++* [Kansas Lava build rules](https://github.com/gergoerdi/kansas-lava-shake).
Test.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Main(main) where @@ -6,44 +5,47 @@ import Control.Monad import Data.Maybe import System.Environment+import General.Base import General.Timing import Development.Shake.FileInfo import General.String import qualified Data.ByteString.Char8 as BS-import Examples.Util(sleepFileTimeCalibrate)+import Test.Type(sleepFileTimeCalibrate) import Control.Concurrent -import qualified Examples.Tar.Main as Tar-import qualified Examples.Self.Main as Self-import qualified Examples.C.Main as C-import qualified Examples.Ninja.Main as Ninja-import qualified Examples.Test.Assume as Assume-import qualified Examples.Test.Basic as Basic-import qualified Examples.Test.Benchmark as Benchmark-import qualified Examples.Test.Cache as Cache-import qualified Examples.Test.Command as Command-import qualified Examples.Test.Config as Config-import qualified Examples.Test.Digest as Digest-import qualified Examples.Test.Directory as Directory-import qualified Examples.Test.Docs as Docs-import qualified Examples.Test.Errors as Errors-import qualified Examples.Test.Files as Files-import qualified Examples.Test.FilePath as FilePath-import qualified Examples.Test.FilePattern as FilePattern-import qualified Examples.Test.Journal as Journal-import qualified Examples.Test.Lint as Lint-import qualified Examples.Test.Makefile as Makefile-import qualified Examples.Test.Manual as Manual-import qualified Examples.Test.Oracle as Oracle-import qualified Examples.Test.OrderOnly as OrderOnly-import qualified Examples.Test.Pool as Pool-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 Examples.Test.Util as Util-import qualified Examples.Test.Verbosity as Verbosity+import qualified Test.Assume as Assume+import qualified Test.Basic as Basic+import qualified Test.Benchmark as Benchmark+import qualified Test.C as C+import qualified Test.Cache as Cache+import qualified Test.Command as Command+import qualified Test.Config as Config+import qualified Test.Digest as Digest+import qualified Test.Directory as Directory+import qualified Test.Docs as Docs+import qualified Test.Errors as Errors+import qualified Test.Files as Files+import qualified Test.FilePath as FilePath+import qualified Test.FilePattern as FilePattern+import qualified Test.Journal as Journal+import qualified Test.Lint as Lint+import qualified Test.Live as Live+import qualified Test.Makefile as Makefile+import qualified Test.Manual as Manual+import qualified Test.Monad as Monad+import qualified Test.Ninja as Ninja+import qualified Test.Oracle as Oracle+import qualified Test.OrderOnly as OrderOnly+import qualified Test.Pool as Pool+import qualified Test.Progress as Progress+import qualified Test.Random as Random+import qualified Test.Resources as Resources+import qualified Test.Self as Self+import qualified Test.Tar as Tar+import qualified Test.Throttle as Throttle+import qualified Test.Unicode as Unicode+import qualified Test.Util as Util+import qualified Test.Verbosity as Verbosity import qualified Start as Start @@ -56,8 +58,8 @@ ,"config" * Config.main, "digest" * Digest.main, "directory" * Directory.main ,"docs" * Docs.main, "errors" * Errors.main, "orderonly" * OrderOnly.main ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main- ,"journal" * Journal.main, "lint" * Lint.main, "makefile" * Makefile.main, "manual" * Manual.main- ,"pool" * Pool.main, "random" * Random.main, "ninja" * Ninja.main+ ,"journal" * Journal.main, "lint" * Lint.main, "live" * Live.main, "makefile" * Makefile.main, "manual" * Manual.main+ ,"monad" * Monad.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, "unicode" * Unicode.main, "util" * Util.main ,"throttle" * Throttle.main, "verbosity" * Verbosity.main]@@ -68,11 +70,7 @@ main = do resetTimings xs <- getArgs-#if __GLASGOW_HASKELL__ >= 706- exePath <- getExecutablePath-#else- exePath <- getProgName-#endif+ exePath <- getExePath case flip lookup (fakes ++ mains) =<< listToMaybe xs of _ | null xs -> do putStrLn "******************************************************************"
+ Test/Assume.hs view
@@ -0,0 +1,45 @@++module Test.Assume(main) where++import Development.Shake+import Test.Type+import Control.Monad+import Development.Shake.FilePath+++main = shaken test $ \args obj -> do+ want $ map obj args+ obj "*.out" *> \out -> do+ cs <- mapM (readFile' . obj . (:".src")) $ takeBaseName out+ writeFile' out $ concat cs+++test build obj = do+ let set file c = writeFile (obj $ file : ".src") [c]+ let ask file c = do src <- readFile (obj $ file ++ ".out"); src === c++ forM_ ['a'..'f'] $ \c -> set c c+ build ["--sleep","abc.out"]+ ask "abc" "abc"++ set 'b' 'd'+ build ["--sleep","abc.out"]+ ask "abc" "adc"+ set 'b' 'p'+ build ["--sleep","abc.out","--touch"]+ build ["abc.out"]+ ask "abc" "adc"+ set 'c' 'z'+ build ["--sleep","abc.out"]+ ask "abc" "apz"++ build ["bc.out","c.out"]+ ask "bc" "pz"+ set 'b' 'r'+ set 'c' 'n'+ build ["--sleep","abc.out","--touch"]+ ask "abc" "apz"+ build ["ab.out","--always-make"]+ ask "ab" "ar"+ build ["c.out"]+ ask "c" "z"
+ Test/Basic.hs view
@@ -0,0 +1,132 @@++module Test.Basic(main) where++import Development.Shake+import Test.Type+import System.Directory as IO+import Data.List+import Data.Maybe+import Control.Monad+import General.Base+++main = shaken test $ \args obj -> do+ want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args++ obj "AB.txt" *> \out -> do+ need [obj "A.txt", obj "B.txt"]+ text1 <- readFile' $ obj "A.txt"+ text2 <- readFile' $ obj "B.txt"+ writeFile' out $ text1 ++ text2++ obj "twice.txt" *> \out -> do+ let src = obj "once.txt"+ need [src, src]+ copyFile' src out++ obj "once.txt" *> \out -> do+ src <- readFile' $ obj "zero.txt"+ writeFile' out src++ phony "halfclean" $ do+ removeFilesAfter (obj "") ["//*e.txt"]++ phony "cleaner" $ do+ removeFilesAfter (obj "") ["//*"]++ phony (obj "configure") $ do+ liftIO $ appendFile (obj "configure") "1"++ phony "install" $ do+ 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"++ r <- newResource ".log file" 1+ let trace x = withResource r 1 $ liftIO $ appendFile (obj ".log") x+ obj "*.par" *> \out -> do+ trace "["+ (if "unsafe" `isInfixOf` out then unsafeExtraThread else id) $ liftIO $ sleep 0.1+ trace "]"+ writeFile' out out++test build obj = do+ writeFile (obj "A.txt") "AAA"+ writeFile (obj "B.txt") "BBB"+ build ["AB.txt","--sleep"]+ assertContents (obj "AB.txt") "AAABBB"+ appendFile (obj "A.txt") "aaa"+ build ["AB.txt"]+ assertContents (obj "AB.txt") "AAAaaaBBB"++ writeFile (obj "zero.txt") "xxx"+ build ["twice.txt","--sleep"]+ assertContents (obj "twice.txt") "xxx"+ writeFile (obj "zero.txt") "yyy"+ build ["once.txt","--sleep"]+ assertContents (obj "twice.txt") "xxx"+ assertContents (obj "once.txt") "yyy"+ writeFile (obj "zero.txt") "zzz"+ build ["once.txt","twice.txt","--sleep"]+ assertContents (obj "twice.txt") "zzz"+ assertContents (obj "once.txt") "zzz"++ removeFile $ obj "twice.txt"+ build ["twice.txt"]+ assertContents (obj "twice.txt") "zzz"++ show shakeOptions === show shakeOptions++ build ["!halfclean"]+ b <- IO.doesDirectoryExist (obj "")+ assert b "Directory should exist, cleaner should not have removed it"++ build ["!cleaner"]+ sleep 1 -- sometimes takes a while for the file system to notice+ b <- IO.doesDirectoryExist (obj "")+ assert (not b) "Directory should not exist, cleaner should have removed it"++ IO.createDirectory $ obj ""+ writeFile (obj "zero.txt") ""+ build ["configure"]+ build ["!install"]+ 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"++ build ["1.par","2.par","-j1"]+ assertContents (obj ".log") "[][]"+ writeFile (obj ".log") ""+ build ["3.par","4.par","-j2"]+ assertContents (obj ".log") "[[]]"+ writeFile (obj ".log") ""+ i <- getProcessorCount+ putStrLn $ "getProcessorCount returned " ++ show i+ when (i > 1) $ do+ build ["5.par","6.par","-j0"]+ assertContents (obj ".log") "[[]]"++ writeFile (obj ".log") ""+ build ["unsafe1.par","unsafe2.par","-j2"]+ assertContents (obj ".log") "[[]]"
+ Test/Benchmark.hs view
@@ -0,0 +1,21 @@++module Test.Benchmark(main) where++import Development.Shake+import Test.Type+import Data.List+import Development.Shake.FilePath+++-- | Given a breadth and depth come up with a set of build files+main = shaken (\_ _ -> return ()) $ \args obj -> do+ let get ty = head $ [read $ drop (length ty + 1) a | a <- args, (ty ++ "=") `isPrefixOf` a] +++ error ("Could not find argument, expected " ++ ty ++ "=Number")+ depth = get "depth"+ breadth = get "breadth"++ want [obj $ "0." ++ show i | i <- [1..breadth]]+ obj "*" *> \out -> do+ let d = read $ takeBaseName out+ need [obj $ show (d + 1) ++ "." ++ show i | d < depth, i <- [1..breadth]]+ writeFile' out ""
+ Test/C.hs view
@@ -0,0 +1,28 @@++module Test.C(main) where++import Development.Shake+import Development.Shake.FilePath+import Test.Type++main = shaken noTest $ \args obj -> do+ let src = "Test/C"+ want [obj "Main.exe"]++ obj "Main.exe" *> \out -> do+ cs <- getDirectoryFiles src ["*.c"]+ let os = map (obj . (<.> "o")) cs+ need os+ cmd "gcc -o" [out] os++ obj "*.c.o" *> \out -> do+ let c = src </> takeBaseName out+ need [c]+ headers <- cIncludes c+ need $ map ((</>) src . takeFileName) headers+ cmd "gcc -o" [out] "-c" [c]++cIncludes :: FilePath -> Action [FilePath]+cIncludes x = do+ Stdout stdout <- cmd "gcc" ["-MM",x]+ return $ drop 2 $ words stdout
+ Test/C/constants.c view
@@ -0,0 +1,7 @@++char msg[] = "Hello Shake Users!";++char* message()+{+ return msg;+}
+ Test/C/constants.h view
@@ -0,0 +1,1 @@+char* message();
+ Test/C/main.c view
@@ -0,0 +1,8 @@+#include <stdio.h>+#include "constants.h"++int main()+{+ printf("%s\n", message());+ return 0;+}
+ Test/Cache.hs view
@@ -0,0 +1,39 @@++module Test.Cache(main) where++import Development.Shake+import Development.Shake.FilePath+import Data.Char+import Test.Type+++main = shaken test $ \args obj -> do+ want $ map obj args+ vowels <- newCache $ \file -> do+ src <- readFile' file+ liftIO $ appendFile (obj "trace.txt") "1"+ return $ length $ filter isDigit src+ obj "*.out*" *> \x ->+ writeFile' x . show =<< vowels (dropExtension x <.> "txt")+++test build obj = do+ writeFile (obj "trace.txt") ""+ writeFile (obj "vowels.txt") "abc123a"+ build ["vowels.out1","vowels.out2","-j3","--sleep"]+ assertContents (obj "trace.txt") "1"+ assertContents (obj "vowels.out1") "3"+ assertContents (obj "vowels.out2") "3"++ build ["vowels.out2","-j3"]+ assertContents (obj "trace.txt") "1"+ assertContents (obj "vowels.out1") "3"++ writeFile (obj "vowels.txt") "12xyz34"+ build ["vowels.out2","-j3","--sleep"]+ assertContents (obj "trace.txt") "11"+ assertContents (obj "vowels.out2") "4"++ build ["vowels.out1","-j3","--sleep"]+ assertContents (obj "trace.txt") "111"+ assertContents (obj "vowels.out1") "4"
+ Test/Command.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Command(main) where++import Development.Shake+import Test.Type+++main = shaken test $ \args obj -> do+ want $ map obj args++ let a !> b = obj a *> \out -> do alwaysRerun; res <- b; writeFile' out res++ "ghc-version" !> do+ Stdout stdout <- cmd "ghc --version"+ return stdout++ "ghc-random" !> do+ (Stderr stderr, Exit _) <- cmd "ghc --random"+ return stderr++ "ghc-random2" !> do+ () <- cmd (EchoStderr False) (Cwd $ obj "") "ghc --random"+ return ""++ "triple" !> do+ (Exit exit, Stdout stdout, Stderr stderr) <- cmd "ghc --random"+ return $ show (exit, stdout, stderr) -- must force all three parts++ obj "pwd space.hs" *> \out -> writeFileLines out ["import System.Directory","main = putStrLn =<< getCurrentDirectory"]+ "pwd" !> do+ need [obj "pwd space.hs"]+ Stdout out <- cmd (Cwd $ obj "") "runhaskell" ["pwd space.hs"]+ return out++ "env" !> do+ (Exit _, Stdout out1) <- cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo %FOO%"+ (Exit _, Stdout out2) <- liftIO $ cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo $FOO"+ return $ unlines [out1, out2]+++test build obj = do+ let crash args parts = assertException parts (build $ "--quiet" : args)++ build ["ghc-version"]+ assertContentsInfix (obj "ghc-version") "The Glorious Glasgow Haskell Compilation System"++ build ["ghc-random"]+ assertContentsInfix (obj "ghc-random") "unrecognised flag"+ assertContentsInfix (obj "ghc-random") "--random"++ crash ["ghc-random2"] [obj "","unrecognised flag","--random"]++ build ["pwd"]+ assertContentsInfix (obj "pwd") "command"++ build ["env","--no-lint"] -- since it blows away the $PATH, which is necessary for lint-tracker+ assertContentsInfix (obj "env") "HELLO SHAKE"++ build ["triple"]
+ Test/Config.hs view
@@ -0,0 +1,57 @@++module Test.Config(main) where++import Development.Shake+import Development.Shake.FilePath+import Development.Shake.Config+import Test.Type+import Data.Char+import qualified Data.HashMap.Strict as Map+import Data.Maybe+import System.Directory+++main = shaken test $ \args obj -> do+ want $ map obj ["hsflags.var","cflags.var","none.var"]+ usingConfigFile $ obj "config"+ obj "*.var" *> \out -> do+ cfg <- getConfig $ map toUpper $ takeBaseName out+ liftIO $ appendFile (out -<.> "times") "X"+ writeFile' out $ fromMaybe "" cfg+++test build obj = do+ build ["clean"]+ createDirectoryIfMissing True $ obj ""+ writeFile (obj "config") $ unlines+ ["HEADERS_DIR = /path/to/dir"+ ,"CFLAGS = -O2 -I${HEADERS_DIR} -g"+ ,"HSFLAGS = -O2"]+ build []+ assertContents (obj "cflags.var") "-O2 -I/path/to/dir -g"+ assertContents (obj "hsflags.var") "-O2"+ assertContents (obj "none.var") ""++ appendFile (obj "config") $ unlines+ ["CFLAGS = $CFLAGS -w"]+ build []+ assertContents (obj "cflags.var") "-O2 -I/path/to/dir -g -w"+ assertContents (obj "hsflags.var") "-O2"+ assertContents (obj "cflags.times") "XX"+ assertContents (obj "hsflags.times") "X"+ assertContents (obj "none.times") "X"++ -- Test readConfigFileWithEnv+ writeFile (obj "config") $ unlines+ ["HEADERS_DIR = ${SOURCE_DIR}/path/to/dir"+ ,"CFLAGS = -O2 -I${HEADERS_DIR} -g"]+ vars <- readConfigFileWithEnv [("SOURCE_DIR", "/path/to/src")]+ (obj "config")+ assert (Map.lookup "HEADERS_DIR" vars == Just "/path/to/src/path/to/dir")+ $ "readConfigFileWithEnv:"+ ++ " Expected: " ++ show (Just "/path/to/src/path/to/dir")+ ++ " Got: " ++ show (Map.lookup "HEADERS_DIR" vars)+ assert (Map.lookup "CFLAGS" vars == Just "-O2 -I/path/to/src/path/to/dir -g")+ $ "readConfigFileWithEnv:"+ ++ " Expected: " ++ show (Just "-O2 -I/path/to/src/path/to/dir -g")+ ++ " Got: " ++ show (Map.lookup "CFLAGS" vars)
+ Test/Digest.hs view
@@ -0,0 +1,78 @@++module Test.Digest(main) where++import Control.Monad+import Development.Shake+import Test.Type+++main = shaken test $ \args obj -> do+ want [obj "Out.txt",obj "Out2.txt"]++ obj "Out.txt" *> \out -> do+ txt <- readFile' $ obj "In.txt"+ liftIO $ appendFile out txt++ [obj "Out1.txt",obj "Out2.txt"] &*> \[out1,out2] -> do+ txt <- readFile' $ obj "In.txt"+ liftIO $ appendFile out1 txt+ liftIO $ appendFile out2 txt+++test build obj = do+ let outs = take 1 $ map obj ["Out.txt","Out1.txt","Out2.txt"]+ let writeOut x = forM_ outs $ \out -> writeFile out x+ let writeIn x = writeFile (obj "In.txt") x+ let assertOut x = forM_ outs $ \out -> assertContents out x++ writeOut ""+ writeIn "X"+ build ["--sleep","--digest-and"]+ assertOut "X"++ -- should not involve a hash calculation (sadly no way to test that)+ build ["--sleep","--digest-and"]+ assertOut "X"++ writeIn "X"+ build ["--sleep","--digest-and"]+ assertOut "X"++ writeIn "X"+ build ["--sleep","--digest-or"]+ assertOut "XX"++ writeIn "X"+ build ["--sleep","--digest-and"]+ assertOut "XX"++ build ["--sleep","--digest-and"]+ writeOut "XX"+ build ["--sleep","--digest-and"]+ assertOut "XX"++ build ["--sleep","--digest-and"]+ writeOut "Y"+ build ["--sleep","--digest-and"]+ assertOut "YX"++ writeIn "X"+ build ["--sleep","--digest"]+ assertOut "YX"++ writeIn "Z"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZ"++ build ["--sleep","--digest-and-input"]+ writeOut "YXZ"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZZ"++ writeIn "Q"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZZQ"++ writeIn "Q"+ build ["--sleep","--digest-and-input"]+ assertOut "YXZZQ"
+ Test/Directory.hs view
@@ -0,0 +1,109 @@++module Test.Directory(main) where++import Development.Shake+import Development.Shake.FilePath+import Test.Type+import Data.List+import Control.Monad+import System.Directory(getCurrentDirectory, setCurrentDirectory, createDirectory, createDirectoryIfMissing)+import qualified System.Directory as IO+++-- Use escape characters, _o=* _l=/ __=<space>+readEsc ('_':'o':xs) = '*' : readEsc xs+readEsc ('_':'l':xs) = '/' : readEsc xs+readEsc ('_':'_':xs) = ' ' : readEsc xs+readEsc (x:xs) = x : readEsc xs+readEsc [] = []++showEsc = concatMap f+ where f '*' = "_o"+ f '/' = "_l"+ f ' ' = "__"+ f x = [x]+++main = shaken test $ \args obj -> do+ want $ map obj args+ obj "*.contents" *> \out ->+ writeFileLines out =<< getDirectoryContents (obj $ readEsc $ dropExtension $ unobj out)+ obj "*.dirs" *> \out ->+ writeFileLines out =<< getDirectoryDirs (obj $ readEsc $ dropExtension $ unobj out)+ obj "*.files" *> \out -> do+ let pats = readEsc $ dropExtension $ unobj out+ let (x:xs) = ["" | " " `isPrefixOf` pats] ++ words pats+ writeFileLines out =<< getDirectoryFiles (obj x) xs++ obj "*.exist" *> \out -> do+ let xs = map obj $ words $ readEsc $ dropExtension $ unobj out+ fs <- mapM doesFileExist xs+ ds <- mapM doesDirectoryExist xs+ let bool x = if x then "1" else "0"+ writeFileLines out $ zipWith (\a b -> bool a ++ bool b) fs ds++ obj "dots" *> \out -> do+ cwd <- liftIO getCurrentDirectory+ liftIO $ setCurrentDirectory $ obj ""+ b1 <- liftM2 (==) (getDirectoryContents ".") (getDirectoryContents "")+ b2 <- liftM2 (==) (getDirectoryDirs ".") (getDirectoryDirs "")+ b3 <- liftM2 (==) (getDirectoryFiles "." ["*.txt"]) (getDirectoryFiles "" ["*.txt"])+ b4 <- liftM2 (==) (getDirectoryFiles "." ["C.txt/*.txt"]) (getDirectoryFiles "" ["C.txt/*.txt"])+ b5 <- liftM2 (==) (getDirectoryFiles "." ["//*.txt"]) (getDirectoryFiles "" ["//*.txt"])+ liftIO $ setCurrentDirectory cwd+ writeFileLines out $ map show [b1,b2,b3,b4,b5]++test build obj = do+ let demand x ys = let f = showEsc x in do build [f]; assertContents (obj f) $ unlines $ words ys+ build ["clean"]+ demand " *.txt.files" ""+ demand " //*.txt.files" ""+ demand ".dirs" ""+ demand "A.txt B.txt C.txt.exist" "00 00 00"++ writeFile (obj "A.txt") ""+ writeFile (obj "B.txt") ""+ createDirectory (obj "C.txt")+ writeFile (obj "C.txt/D.txt") ""+ writeFile (obj "C.txt/E.xtx") ""+ demand " *.txt.files" "A.txt B.txt"+ demand ".dirs" "C.txt"+ demand "A.txt B.txt C.txt.exist" "10 10 01"+ demand " //*.txt.files" "A.txt B.txt C.txt/D.txt"+ demand "C.txt *.txt.files" "D.txt"+ demand " *.txt //*.xtx.files" "A.txt B.txt C.txt/E.xtx"+ demand " C.txt/*.files" "C.txt/D.txt C.txt/E.xtx"++ build ["dots","--no-lint"]+ assertContents (obj "dots") $ unlines $ words "True True True True True"++ let removeTest pat del keep = do+ withTemporaryDirectory $ \dir -> do+ forM_ (del ++ keep) $ \s -> do+ createDirectoryIfMissing True $ dir </> takeDirectory s+ when (not $ hasTrailingPathSeparator s) $+ writeFile (dir </> s) ""+ removeFiles dir pat+ createDirectoryIfMissing True dir+ forM_ (map ((,) False) del ++ map ((,) True) keep) $ \(b,s) -> do+ b2 <- (if hasTrailingPathSeparator s then IO.doesDirectoryExist else IO.doesFileExist) $ dir </> s+ when (b /= b2) $ do+ let f b = if b then "present" else "missing"+ error $ "removeFiles mismatch: with pattern " ++ show pat ++ ", " ++ s +++ " should be " ++ f b ++ " but is " ++ f b2++ removeTest ["//bob"] ["test/bob","more/bob"] ["extra/obo"]+ removeTest ["bob"] ["bob/"] ["bar/"]+ removeTest ["*.hs"] ["test.hs"] ["extra/more.hs","new.txt"]+ removeTest ["baz"] ["baz"] ["foo","bar/bob"]+ removeTest ["baz"] ["baz/bob","baz/"] ["foo","bar/bob"]+ removeTest ["Foo//*"] ["Foo/bar","Foo/Quux/bar","Foo/Quux/"] []+ removeTest ["Foo//*"] ["Foo/"] ["bar"]+ removeTest ["baz"] [] ["test.hs","bar/","foo/"]+ removeTest ["bob//*"] [] ["test/bob/"]+ removeTest ["//bob"] ["test/bob/","test/"] []+ removeTest ["//*.txt"] ["more/","more/a.txt"] []+ removeTest ["//*.txt"] ["more/","more/a.txt/"] []+ removeTest ["//*.txt"] ["more/","more/a.txt/","more/b.txt"] []+ removeTest ["//*.txt"] [] ["more/"]+ removeTest ["a//b"] ["a/c/b"] []
+ Test/Docs.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE PatternGuards #-}++module Test.Docs(main) where++import Development.Shake+import Development.Shake.FilePath+import Test.Type+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import System.Directory+import System.Exit+++reps from to = map (\x -> if x == from then to else x)++main = shaken noTest $ \args obj -> do+ let index = "dist/doc/html/shake/index.html"+ want [obj "Success.txt"]++ want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args++ let needSource = need =<< getDirectoryFiles "." ["Development/Shake.hs","Development/Shake//*.hs","Development/Ninja/*.hs","General//*.hs"]++ index *> \_ -> do+ needSource+ need ["shake.cabal"]+ trackAllow ["dist//*"]+ res <- liftIO $ findExecutable "cabal"+ if isJust res then cmd "cabal haddock" else do+ Exit exit <- cmd "runhaskell Setup.hs haddock"+ when (exit /= ExitSuccess) $ do+ () <- cmd "runhaskell Setup.hs configure"+ cmd "runhaskell Setup.hs haddock"++ obj "Paths_shake.hs" *> \out -> do+ copyFile' "Paths.hs" out++ obj "Part_*.hs" *> \out -> do+ need ["Test/Docs.hs"] -- so much of the generator is in this module+ src <- if "_md" `isSuffixOf` takeBaseName out then+ fmap (findCodeMarkdown . lines) $ readFile' $ "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md"+ else+ fmap findCodeHaddock $ readFile' $ "dist/doc/html/shake/" ++ reps '_' '-' (drop 5 $ takeBaseName out) ++ ".html"+ let f i (Stmt x) | whitelist $ head x = []+ | otherwise = restmt i $ map undefDots $ trims x+ f i (Expr x) | takeWhile (not . isSpace) x `elem` types = ["type Expr_" ++ show i ++ " = " ++ x]+ | "import " `isPrefixOf` x = [x]+ | otherwise = ["expr_" ++ show i ++ " = (" ++ undefDots x2 ++ ")" | let x2 = trim $ dropComment x, not $ whitelist x2]+ code = concat $ zipWith f [1..] (nub src)+ (imports,rest) = partition ("import " `isPrefixOf`) code+ writeFileLines out $+ ["{-# LANGUAGE ConstraintKinds, DeriveDataTypeable, ExtendedDefaultRules, GeneralizedNewtypeDeriving, NoMonomorphismRestriction #-}"+ ,"{-# OPTIONS_GHC -w #-}"+ ,"module " ++ takeBaseName out ++ "() where"+ ,"import Control.Concurrent"+ ,"import Control.Monad"+ ,"import Data.Char"+ ,"import Data.Data"+ ,"import Data.List"+ ,"import Data.Maybe"+ ,"import Data.Monoid"+ ,"import Development.Shake"+ ,"import Development.Shake.Classes"+ ,"import Development.Shake.Rule"+ ,"import Development.Shake.Util"+ ,"import Development.Shake.FilePath"+ ,"import System.Console.GetOpt"+ ,"import System.Exit"+ ,"import System.IO"] +++ ["import " ++ reps '_' '.' (drop 5 $ takeBaseName out) | not $ "_md.hs" `isSuffixOf` out] +++ imports +++ ["(==>) :: Bool -> Bool -> Bool"+ ,"(==>) = undefined"+ ,"infix 1 ==>"+ ,"forAll f = f undefined"+ ,"remaining = 1.1"+ ,"done = 1.1"+ ,"time_elapsed = 1.1"+ ,"old = \"\""+ ,"new = \"\""+ ,"myfile = \"\""+ ,"inputs = [\"\"]"+ ,"files = [\"\"]"+ ,"input = \"\""+ ,"output = \"\""+ ,"opts = shakeOptions"+ ,"result = undefined :: IO (Maybe (Rules ()))"+ ,"launchMissiles = undefined :: Bool -> IO ()"+ ,"myVariable = ()"+ ,"instance Eq (OptDescr a)"+ ,"(foo,bar,baz) = undefined"+ ,"str1 = \"\""+ ,"str2 = \"\""+ ,"str = \"\""+ ,"((/./),(/../),(//)) = undefined"] +++ rest++ obj "Files.lst" *> \out -> do+ need ["Test/Docs.hs"] -- so much of the generator is in this module+ need [index,obj "Paths_shake.hs"]+ filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"]+ filesMd <- getDirectoryFiles "docs" ["*.md"]+ writeFileChanged out $ unlines $+ ["Part_" ++ reps '-' '_' (takeBaseName x) | x <- filesHs, not $ "-Classes.html" `isSuffixOf` x] +++ ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd, takeBaseName x /= "Developing"]++ let needModules = do mods <- readFileLines $ obj "Files.lst"; need [obj m <.> "hs" | m <- mods]; return mods++ obj "Main.hs" *> \out -> do+ mods <- needModules+ writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m | m <- mods] ++ ["main = return ()"]++ obj "Success.txt" *> \out -> do+ needModules+ need [obj "Main.hs", obj "Paths_shake.hs"]+ needSource+ () <- cmd "runhaskell -ignore-package=hashmap" ["-i" ++ obj "", obj "Main.hs"]+ writeFile' out ""+++data Code = Stmt [String] | Expr String deriving (Show,Eq)++findCodeHaddock :: String -> [Code]+findCodeHaddock x | Just x <- stripPrefix "<pre>" x = f (Stmt . shift . lines . strip) "</pre>" x+ | Just x <- stripPrefix "<code>" x = f (Expr . strip) "</code>" x+ where+ f ctor end x | Just x <- stripPrefix end x = ctor "" : findCodeHaddock x+ f ctor end (x:xs) = f (ctor . (x:)) end xs+findCodeHaddock (x:xs) = findCodeHaddock xs+findCodeHaddock [] = []++findCodeMarkdown :: [String] -> [Code]+findCodeMarkdown (x:xs) | indented x && not (blank x) =+ let (a,b) = span (\x -> indented x || blank x) (x:xs)+ in Stmt (map (drop 4) a) : findCodeMarkdown b+ where+ indented x = length (takeWhile isSpace x) >= 4+ blank x = all isSpace x+findCodeMarkdown (x:xs) = f x ++ findCodeMarkdown xs+ where+ f ('`':xs) = let (a,b) = break (== '`') xs in Expr a : f (drop 1 b)+ f (x:xs) = f xs+ f [] = []+findCodeMarkdown [] = []++trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace+trims = reverse . dropWhile (all isSpace) . reverse . dropWhile (all isSpace)++restmt i ("":xs) = restmt i xs+restmt i (x:xs) | " ?== " `isInfixOf` x || " == " `isInfixOf` x =+ zipWith (\j x -> "hack_" ++ show i ++ "_" ++ show j ++ " = " ++ x) [1..] (x:xs)+restmt i (x:xs) |+ not ("let" `isPrefixOf` x) && not ("[" `isPrefixOf` x) && (" = " `isInfixOf` x || " | " `isInfixOf` x) ||+ "import " `isPrefixOf` x || "infix" `isPrefixOf` x || "instance " `isPrefixOf` x = map f $ x:xs+ where f x = if takeWhile (not . isSpace) x `elem` dupes then "_" ++ show i ++ "_" ++ x else x+restmt i xs = ("stmt_" ++ show i ++ " = do") : map (" " ++) xs +++ [" undefined" | length xs == 1 && ("let" `isPrefixOf` (head xs) || "<-" `isInfixOf` (head xs))]+++shift :: [String] -> [String]+shift xs | all null xs = xs+ | all (\x -> null x || " " `isPrefixOf` x) xs = shift $ map (drop 1) xs+ | otherwise = xs+++dropComment ('-':'-':_) = []+dropComment xs = onTail dropComment xs+++undefDots o = f o+ where+ f ('.':'.':'.':xs) =+ (if "cmd" `elem` words o then "[\"\"]" else "undefined") +++ (if "..." `isSuffixOf` xs then "" else undefDots xs)+ f xs = onTail f xs++strip :: String -> String+strip x+ | Just x <- stripPrefix "<em>" x+ , (a,b) <- break (== '<') x+ , not $ ("</em>" `isPrefixOf` b) && a `elem` italics+ = error $ "Unexpected italics in code block: " ++ a ++ take 5 b ++ "..."+strip ('<':xs) = strip $ drop 1 $ dropWhile (/= '>') xs+strip ('&':xs)+ | Just xs <- stripPrefix "quot;" xs = '\"' : strip xs+ | Just xs <- stripPrefix "lt;" xs = '<' : strip xs+ | Just xs <- stripPrefix "gt;" xs = '>' : strip xs+ | Just xs <- stripPrefix "amp;" xs = '&' : strip xs+strip xs = onTail strip xs++onTail f (x:xs) = x : f xs+onTail f [] = []+++italics :: [String]+italics = words "extension command-name file-name"++whitelist :: String -> Bool+whitelist x | all (not . isSpace) x && takeExtension x `elem` words ".txt .hi .hs .o .exe .tar .cpp .cfg .dep .deps .h .c .html" = True+whitelist x | elem x $ words $+ "newtype do MyFile.txt.digits excel a q m c x value key gcc cl os make contents tar ghc cabal clean _make distcc ghc " +++ ".. /./ /.. ./ // \\ ../ " +++ "ConstraintKinds GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " +++ "Data.List System.Directory Development.Shake.FilePath main.m run .rot13 " +++ "NoProgress Error src rot13 .js .json .trace about://tracing " +++ ".make/i586-linux-gcc/output _make/.database foo/.. file.src file.out build " +++ "/usr/special /usr/special/userbinary $CFLAGS %PATH% -O2 -j8 -j -j1 " +++ "-threaded -rtsopts -I0 Function extension $OUT $C_LINK_FLAGS $PATH xterm $TERM main opts result flagValues argValues " +++ "HEADERS_DIR /path/to/dir CFLAGS let -showincludes -MMD gcc.version linkFlags temp pwd touch code out err " +++ "_metadata/.database _shake _shake/build ./build.sh build.sh build.bat //* [out] manual/examples.zip manual " +++ "docs/manual _build _build/run ninja depfile build.ninja "+ = True+whitelist x = x `elem`+ ["[Foo.hi, Foo.o]"+ ,"shake-progress"+ ,"main -j6"+ ,"main clean"+ ,"1m25s (15%)"+ ,"3m12s (82%)"+ ,"getPkgVersion $ GhcPkgVersion \"shake\""+ ,"# command-name (for file-name)"+ ,"ghc --make MyBuildSystem -rtsopts -with-rtsopts=-I0"+ ,"-with-rtsopts"+ ,"-qg -qb"+ ,"gcc -MM"+ ,"# This is my Config file"+ ,"-g -I/path/to/dir -O2"+ ,"main _make/henry.txt"+ ,"<i>build rules</i>"+ ,"<i>actions</i>"+ ,"() <- cmd ..."+ ,"x <- inputs"+ ,"shakeFiles=\"_build/\""+ ,"#include \""+ ,"pattern *> actions = (pattern ?==) ?> actions" -- because it overlaps+ ,"buildDir = \"_build\""+ ,"-MMD -MF"+ ,"#!/bin/sh"+ ,"build _build/main.o"+ ,"build clean"+ ,"build -j8"+ ,"cabal update && cabal install shake"+ ,"shake-build-system"+ ,"runhaskell _build/run"+ ,"runhaskell _build/run clean"+ ,"gcc -c main.c -o main.o -MMD -MF main.m"+ ,"\"_build\" </> x -<.> \"o\""+ ,"cmd \"gcc -o\" [out] os"+ ,"rot13 file.txt -o file.rot13"+ ,"file.rot13"+ ,"out -<.> \"txt\""+ ,"[item1,item2,item2]"+ ,"runhaskell Build.hs"+ ,"cabal update"+ ,"cabal install shake"+ ,"shake -j4"+ ,"cmd \"gcc -o _make/run _build/main.o _build/constants.o\""+ ]++types = words $+ "MVar IO Monad Monoid String FilePath Data Maybe [String] Eq Typeable Char ExitCode Change " +++ "Action Resource Assume FilePattern Lint Verbosity Rules Rule CmdOption CmdResult Int Double"++dupes = words "main progressSimple rules"
+ Test/Errors.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Errors(main) where++import Development.Shake+import Test.Type+import Control.Monad+import General.Base+import Control.Concurrent+import Control.Exception as E hiding (assert)+import System.Directory as IO+++main = shaken test $ \args obj -> do+ want $ map obj args++ obj "norule" *> \_ ->+ need [obj "norule_isavailable"]++ obj "failcreate" *> \_ ->+ return ()++ [obj "failcreates", obj "failcreates2"] &*> \_ ->+ writeFile' (obj "failcreates") ""++ obj "recursive" *> \out ->+ need [out]++ obj "systemcmd" *> \_ ->+ cmd "random_missing_command"++ obj "stack1" *> \_ -> need [obj "stack2"]+ obj "stack2" *> \_ -> need [obj "stack3"]+ obj "stack3" *> \_ -> error "crash"++ obj "staunch1" *> \out -> do+ liftIO $ sleep 0.1+ writeFile' out "test"+ obj "staunch2" *> \_ -> error "crash"++ let catcher out op = obj out *> \out -> do+ writeFile' out "0"+ op $ do src <- readFileStrict out; writeFile out $ show (read src + 1 :: Int)+ catcher "finally1" $ actionFinally $ fail "die"+ catcher "finally2" $ actionFinally $ return ()+ catcher "finally3" $ actionFinally $ liftIO $ sleep 10+ catcher "finally4" $ actionFinally $ need ["wait"]+ "wait" ~> do liftIO $ sleep 10+ catcher "exception1" $ actionOnException $ fail "die"+ catcher "exception2" $ actionOnException $ return ()++ res <- newResource "resource_name" 1+ obj "resource" *> \out -> do+ withResource res 1 $+ need ["resource-dep"]++ obj "overlap.txt" *> \out -> writeFile' out "overlap.txt"+ obj "overlap.t*" *> \out -> writeFile' out "overlap.t*"+ obj "overlap.*" *> \out -> writeFile' out "overlap.*"+ alternatives $ do+ obj "alternative.t*" *> \out -> writeFile' out "alternative.txt"+ obj "alternative.*" *> \out -> writeFile' out "alternative.*"++ obj "chain.2" *> \out -> do+ src <- readFile' $ obj "chain.1"+ if src == "err" then error "err_chain" else writeFileChanged out src+ obj "chain.3" *> \out -> copyFile' (obj "chain.2") out+++test build obj = do+ let crash args parts = assertException parts (build $ "--quiet" : args)+ build ["clean"]+ build ["--sleep"]++ writeFile (obj "chain.1") "x"+ build ["chain.3","--sleep"]+ writeFile (obj "chain.1") "err"+ crash ["chain.3"] ["err_chain"]++ crash ["norule"] ["norule_isavailable"]+ crash ["failcreate"] ["failcreate"]+ crash ["failcreates"] ["failcreates"]+ crash ["recursive"] ["recursive"]+ crash ["systemcmd"] ["systemcmd","random_missing_command"]+ crash ["stack1"] ["stack1","stack2","stack3","crash"]++ b <- IO.doesFileExist $ obj "staunch1"+ when b $ removeFile $ obj "staunch1"+ crash ["staunch1","staunch2","-j2"] ["crash"]+ b <- IO.doesFileExist $ obj "staunch1"+ assert (not b) "File should not exist, should have crashed first"+ crash ["staunch1","staunch2","-j2","--keep-going","--silent"] ["crash"]+ b <- IO.doesFileExist $ obj "staunch1"+ assert b "File should exist, staunch should have let it be created"++ crash ["finally1"] ["die"]+ assertContents (obj "finally1") "1"+ build ["finally2"]+ assertContents (obj "finally2") "1"+ crash ["exception1"] ["die"]+ assertContents (obj "exception1") "1"+ build ["exception2"]+ assertContents (obj "exception2") "0"++ forM_ ["finally3","finally4"] $ \name -> do+ t <- forkIO $ build [name,"--exception"] `E.catch` \(_ :: SomeException) -> return ()+ retry 10 $ sleep 0.1 >> assertContents (obj name) "0"+ throwTo t (IndexOutOfBounds "test")+ retry 10 $ sleep 0.1 >> assertContents (obj name) "1"++ crash ["resource"] ["cannot currently call apply","withResource","resource_name"]++ build ["overlap.foo"]+ assertContents (obj "overlap.foo") "overlap.*"+ build ["overlap.txt"]+ assertContents (obj "overlap.txt") "overlap.txt"+ crash ["overlap.txx"] ["key matches multiple rules","overlap.txx"]+ build ["alternative.foo","alternative.txt"]+ assertContents (obj "alternative.foo") "alternative.*"+ assertContents (obj "alternative.txt") "alternative.txt"
+ Test/FilePath.hs view
@@ -0,0 +1,96 @@++module Test.FilePath(main) where++import Development.Shake.FilePath+import qualified System.FilePath as Native+import qualified System.FilePath.Posix as Posix+import General.Base+import Test.Type+import Test.QuickCheck+import Control.Monad+import Data.List+import qualified Data.ByteString.Char8 as BS+import qualified Development.Shake.ByteString as BS+++main = shaken test $ \args obj -> return ()+++newtype File = File String deriving Show++instance Arbitrary File where+ arbitrary = fmap File $ listOf $ oneof $ map return "abc /\\:."+++test build obj = do+ let a === b = a Test.Type.=== b -- duplicate definition in QuickCheck 2.7 and above++ let norm x =+ let s = normalise x+ b = BS.unpack (BS.filepathNormalise $ BS.pack x)+ in if s == b then s else error $ show ("Normalise functions differ",x,s,b)+ -- basic examples+ norm "" === "."+ norm "." === "."+ norm "/" === "/"+ norm "./" === "./"+ norm "/." === "/."+ norm "/./" === "/"+ norm "a/." === "a"+ norm "./a" === "a"+ norm "./a/." === "a"+ norm "./a/./" === "a/"+ norm "a/.." === "."+ norm "a/./.." === "."+ norm "a/../" === "./"+ norm "/a/../" === "/"+ norm "/a/./../" === "/"+ norm "../a" === "../a"+ norm "/../a/" === "/../a/"++ -- more realistic examples+ norm "neil//./test/moo/../bar/bob/../foo" === "neil/test/bar/foo"+ norm "bar/foo" === "bar/foo"+ norm "bar/foo/" === "bar/foo/"+ norm "../../foo" === "../../foo"+ norm "foo/../..///" === "../"+ norm "foo/bar/../../neil" === "neil"+ norm "foo/../bar/../neil" === "neil"+ norm "/foo/bar" === "/foo/bar"+ norm "//./" === (if isWindows then "//" else "/")+ norm "//foo/./bar" === (if isWindows then "//foo/bar" else "/foo/bar")+ when isWindows $ norm "c:\\foo\\bar" === "c:/foo/bar"+ Success{} <- quickCheckWithResult stdArgs{maxSuccess=1000} $ \(File x) ->+ let y = norm x+ sep = Native.isPathSeparator+ noDrive = if isWindows then drop 1 else id+ ps = [length y >= 1+ ,null x || (sep (head x) == sep (head y) && sep (last x) == sep (last y))+ ,not $ "/./" `isInfixOf` y+ ,not isWindows || '\\' `notElem` y+ ,not $ "//" `isInfixOf` noDrive y+ ,".." `notElem` dropWhile (== "..") (splitDirectories $ dropWhile sep y)+ ,norm y == y]+ in if and ps then True else error $ show (x, y, ps)++ dropDirectory1 "aaa/bbb" === "bbb"+ dropDirectory1 "aaa/" === ""+ dropDirectory1 "aaa" === ""+ dropDirectory1 "" === ""++ takeDirectory1 "aaa/bbb" === "aaa"+ takeDirectory1 "aaa/" === "aaa"+ takeDirectory1 "aaa" === "aaa"++ combine "." "ccc" === "ccc"+ combine "aaa/bbb" "ccc" === "aaa/bbb/ccc"+ combine "aaa/bbb" "./ccc" === "aaa/bbb/ccc"+ combine "aaa/bbb" "../ccc" === "aaa/ccc"+ combine "aaa/bbb" "../../ccc" === "ccc"+ combine ".." "aaa" === "../aaa"+ combine "../.." "aaa" === "../../aaa"+ combine "./a" "../aaa" === "aaa"+ combine ".." "../aaa" === "../../aaa"++ searchPathSeparator === Native.searchPathSeparator+ pathSeparators === Posix.pathSeparators
+ Test/FilePattern.hs view
@@ -0,0 +1,61 @@++module Test.FilePattern(main) where++import Development.Shake.FilePattern+import Test.Type++main = shaken test $ \args obj -> return ()+++test build obj = do+ let f b pat file = assert (b == (pat ?== file)) $ show pat ++ " ?== " ++ show file ++ "\nEXPECTED: " ++ show b+ f True "//*.c" "foo/bar/baz.c"+ f True "*.c" "baz.c"+ f True "//*.c" "baz.c"+ f True "test.c" "test.c"+ f False "*.c" "foor/bar.c"+ f False "*/*.c" "foo/bar/baz.c"+ f False "foo//bar" "foobar"+ f False "foo//bar" "foobar/bar"+ f False "foo//bar" "foo/foobar"+ f True "foo//bar" "foo/bar"++ assert (compatible []) "compatible"+ assert (compatible ["//*a.txt","foo//a*.txt"]) "compatible"+ assert (not $ compatible ["//*a.txt","foo//a*.*txt"]) "compatible"+ extract "//*a.txt" "foo/bar/testa.txt" === ["foo/bar/","test"]+ extract "//*a.txt" "testa.txt" === ["","test"]+ extract "//*a*.txt" "testada.txt" === ["","test","da"]+ substitute ["","test","da"] "//*a*.txt" === "testada.txt"+ substitute ["foo/bar/","test"] "//*a.txt" === "foo/bar/testa.txt"++ directories1 "*.xml" === ("",False)+ directories1 "//*.xml" === ("",True)+ directories1 "foo//*.xml" === ("foo",True)+ directories1 "foo/bar/*.xml" === ("foo/bar",False)+ directories1 "*/bar/*.xml" === ("",True)+ directories ["*.xml","//*.c"] === [("",True)]+ directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]+ directories ["bar/*.xml","baz//*.c"] === [("bar",False),("baz",True)]+++---------------------------------------------------------------------+-- LAZY SMALLCHECK PROPERTIES++{-+newtype Pattern = Pattern FilePattern deriving (Show,Eq)+newtype Path = Path FilePath deriving (Show,Eq)++-- Since / and * are the only "interesting" elements, just add ab to round out the set++instance Serial Pattern where+ series = cons Pattern >< f+ where f = cons [] \/ cons (:) >< const (drawnFrom "/*ab") >< f++instance Serial Path where+ series = cons Path >< f+ where f = cons [] \/ cons (:) >< const (drawnFrom "/ab") >< f++testSmallCheck = do+ smallCheck 10 $ \(Pattern p) (Path x) -> p ?== x ==> substitute (extract p x) p == x+-}
+ Test/Files.hs view
@@ -0,0 +1,39 @@++module Test.Files(main) where++import Development.Shake+import Test.Type+import Control.Monad+import Data.List+++main = shaken test $ \args obj -> do+ let fun = "@" `elem` args+ let rest = delete "@" args+ want $ map obj $ if null rest then ["even.txt","odd.txt"] else rest++ -- 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++ 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_ [[],["@"]] $ \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 ["--no-build","--report=-"]+ build ["dir1/out.txt"]
+ Test/Journal.hs view
@@ -0,0 +1,44 @@++module Test.Journal(main) where++import Control.Monad+import Data.IORef+import Development.Shake+import Development.Shake.FilePath+import Test.Type+import System.IO.Unsafe+++{-# NOINLINE rebuilt #-}+rebuilt :: IORef Int+rebuilt = unsafePerformIO $ newIORef 0+++main = shaken test $ \args obj -> do+ want $ map obj ["a.out","b.out","c.out"]+ obj "*.out" *> \out -> do+ liftIO $ atomicModifyIORef rebuilt $ \a -> (a+1,())+ copyFile' (out -<.> "in") out+++test build obj = do+ + let change x = writeFile (obj $ x <.> "in") x+ let count x = do+ before <- readIORef rebuilt+ build ["--sleep"]+ after <- readIORef rebuilt+ x === after - before++ change "a"+ change "b"+ change "c"+ count 3++ -- test that compressing the database doesn't corrupt anything+ replicateM_ 4 $ do+ change "a"+ count 1+ change "a"+ change "c"+ count 2
+ Test/Lint.hs view
@@ -0,0 +1,119 @@++module Test.Lint(main) where++import Development.Shake+import Development.Shake.FilePath+import Test.Type+import Control.Exception hiding (assert)+import System.Directory as IO+import Control.Monad+import Data.Maybe+++main = shaken test $ \args obj -> do+ want $ map obj args++ addOracle $ \() -> do+ liftIO $ createDirectoryIfMissing True $ obj "dir"+ liftIO $ setCurrentDirectory $ obj "dir"+ return ()++ obj "changedir" *> \out -> do+ () <- askOracle ()+ writeFile' out ""++ obj "pause.*" *> \out -> do+ liftIO $ sleep 0.1+ need [obj "cdir" <.> takeExtension out]+ writeFile' out ""++ obj "cdir.*" *> \out -> do+ pwd <- liftIO getCurrentDirectory+ let dir2 = obj $ "dir" ++ takeExtension out+ liftIO $ createDirectoryIfMissing True dir2+ liftIO $ setCurrentDirectory dir2+ liftIO $ sleep 0.2+ liftIO $ setCurrentDirectory pwd+ writeFile' out ""++ obj "createonce" *> \out -> do+ writeFile' out "X"++ obj "createtwice" *> \out -> do+ need [obj "createonce"]+ liftIO sleepFileTime+ 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") ""+ writeFile' out ""++ obj "gen*" *> \out -> do+ writeFile' out out++ obj "needed1" *> \out -> do+ needed [obj "gen1"]+ writeFile' out ""++ obj "needed2" *> \out -> do+ orderOnly [obj "gen2"]+ needed [obj "gen2"]+ writeFile' out ""++ obj "tracker-write1" *> \out -> do+ () <- cmd "cmd /c" ["echo x > " ++ out <.> "txt"]+ need [out <.> "txt"]+ writeFile' out ""++ obj "tracker-write2" *> \out -> do+ () <- cmd "cmd /c" ["echo x > " ++ out <.> "txt"]+ writeFile' out ""++ obj "tracker-source2" *> \out -> copyFile' (obj "tracker-source1") out+ obj "tracker-read1" *> \out -> do+ () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source1") ++ " > nul"]+ writeFile' out ""+ obj "tracker-read2" *> \out -> do+ () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source1") ++ " > nul"]+ need [obj "tracker-source1"]+ writeFile' out ""+ obj "tracker-read3" *> \out -> do+ () <- cmd "cmd /c" ["type " ++ toNative (obj "tracker-source2") ++ " > nul"]+ need [obj "tracker-source2"]+ writeFile' out ""+++test build obj = do+ dir <- getCurrentDirectory+ let crash args parts = do+ assertException parts (build $ "--quiet" : args)+ `finally` setCurrentDirectory dir++ 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"] ["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"]+ crash ["needed1"] ["'needed' file required rebuilding"]+ build ["needed2"]++ tracker <- findExecutable "tracker.exe"+ when (isJust tracker) $ do+ writeFile (obj "tracker-source1") ""+ writeFile (obj "tracker-source2") ""+ crash ["tracker-write1"] ["not have its creation tracked","lint/tracker-write1","lint/tracker-write1.txt"]+ build ["tracker-write2"]+ crash ["tracker-read1"] ["used but not depended upon","lint/tracker-source1"]+ build ["tracker-read2"]+ crash ["tracker-read3"] ["depended upon after being used","lint/tracker-source2"]
+ Test/Live.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Live(main) where++import Development.Shake+import Test.Type+++main = shaken test $ \args obj -> do+ want $ map obj args++ obj "foo" *> \ out -> do+ need [obj "bar"]+ writeFile' out ""++ obj "bar" *> \out -> writeFile' out ""+ obj "baz" *> \out -> writeFile' out ""+++test build obj = do+ build ["clean"]+ build ["foo","baz","--live=" ++ obj "live.txt"]+ assertContentsUnordered (obj "live.txt") $ map obj $ words "foo bar baz"+ build ["foo","baz","--live=" ++ obj "live.txt"]+ assertContentsUnordered (obj "live.txt") $ map obj $ words "foo bar baz"+ build ["foo","--live=" ++ obj "live.txt"]+ assertContentsUnordered (obj "live.txt") $ map obj $ words "foo bar"+ build ["bar","--live=" ++ obj "live.txt"]+ assertContentsUnordered (obj "live.txt") $ map obj $ words "bar"
+ Test/MakeTutor/Makefile view
@@ -0,0 +1,17 @@+# From http://www.cs.colby.edu/maxwell/courses/tutorials/maketutor/, Makefile 4++CC=gcc+CFLAGS=-I.+DEPS = hellomake.h+OBJ = hellomake.o hellofunc.o ++hellomake$(EXE): $(OBJ)+ $(CC) -o $@ $^ $(CFLAGS)++%.o: %.c $(DEPS)+ $(CC) -c -o $@ $< $(CFLAGS)++.PHONY: clean+clean:+ rm hellomake$(EXE)+ rm *.o
+ Test/MakeTutor/hellofunc.c view
@@ -0,0 +1,9 @@+#include <stdio.h>+#include <hellomake.h>++void myPrintHelloMake(void) {++ printf("Hello makefiles!\n");++ return;+}
+ Test/MakeTutor/hellomake.c view
@@ -0,0 +1,8 @@+#include <hellomake.h>++int main() {+ // call a function in another file+ myPrintHelloMake();++ return(0);+}
+ Test/MakeTutor/hellomake.h view
@@ -0,0 +1,5 @@+/*+example include file+*/++void myPrintHelloMake(void);
+ Test/Makefile.hs view
@@ -0,0 +1,24 @@++module Test.Makefile(main) where++import Development.Shake(action, liftIO)+import qualified Start as Makefile+import System.Environment+import Test.Type+import Control.Monad+import Data.List+import Data.Maybe+++main = shaken test $ \args obj ->+ action $ liftIO $ do+ unless (["@@"] `isPrefixOf` args) $+ error "The 'makefile' example should only be used in test mode, to test using a makefile use the 'make' example."+ withArgs [fromMaybe x $ stripPrefix "@" x | x <- drop 1 args] Makefile.main+++test build obj = do+ copyDirectoryChanged "Test/MakeTutor" $ obj "MakeTutor"+ build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]+ build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]+ build ["@@","--directory=" ++ obj "MakeTutor","@clean","--no-report"]
+ Test/Manual.hs view
@@ -0,0 +1,24 @@++module Test.Manual(main) where++import Development.Shake hiding (copyFileChanged)+import Development.Shake.FilePath+import Test.Type+import General.Base+++main = shaken test $ \args obj ->+ action $ liftIO $ error "The 'manual' example should only be used in test mode"++test build obj = do+ copyDirectoryChanged "docs/manual" $ obj "manual"+ copyDirectoryChanged "Development" $ obj "manual/Development"+ copyDirectoryChanged "General" $ obj "manual/General"+ copyFileChanged "Paths.hs" $ obj "manual/Paths_shake.hs"+ let cmdline = if isWindows then "build.bat" else "/bin/sh build.sh"+ () <- cmd [Cwd $ obj "manual", Shell] cmdline "-j2"+ assertExists $ obj "manual/_build/run" <.> exe+ () <- cmd [Cwd $ obj "manual", Shell] cmdline+ () <- cmd [Cwd $ obj "manual", Shell] [cmdline,"clean"]+ assertMissing $ obj "manual/_build/run" <.> exe+ return ()
+ Test/Monad.hs view
@@ -0,0 +1,89 @@++module Test.Monad(main) where++import Test.Type+import Development.Shake.Monad++import Data.IORef+import Control.Concurrent+import Control.Exception hiding (assert)+import Control.Monad+import Control.Monad.IO.Class+++main = shaken test $ \args obj -> return ()+++run :: ro -> rw -> RAW ro rw a -> IO a+run ro rw m = do+ res <- newEmptyMVar+ runRAW ro rw m $ void . tryPutMVar res+ either throwIO return =<< readMVar res+++test build obj = do+ let conv x = either (Left . fromException) Right x :: Either (Maybe ArithException) Int+ let dump ro rw = do liftIO . (=== ro) =<< getRO; liftIO . (=== rw) =<< getRW++ -- test the basics plus exception handling+ run 1 "test" $ do+ dump 1 "test"+ putRW "more"+ dump 1 "more"+ res <- tryRAW $ withRO (+3) $ do+ dump 4 "more"+ withRW (++ "x") $ do+ dump 4 "morex"+ dump 4 "more"+ return 100+ liftIO $ conv res === Right 100+ dump 1 "more"+ putRW "new"+ dump 1 "new"+ res <- tryRAW $ withRO (+2) $ do+ dump 3 "new"+ withRW (++ "x") $ do+ dump 3 "newx"+ throwRAW Overflow+ error "Should not have reached here"+ return 9+ liftIO $ conv res === Left (Just Overflow)+ dump 1 "new"+ catchRAW (catchRAW (throwRAW Overflow) $ \_ -> modifyRW (++ "x")) $+ \_ -> modifyRW (++ "y")+ dump 1 "newx"+ catchRAW (catchRAW (throwRAW Overflow) $ \e -> modifyRW (++ "x") >> throwRAW e) $+ \_ -> modifyRW (++ "y")+ dump 1 "newxxy"++ -- test capture+ run 1 "test" $ do+ i <- captureRAW $ \k -> k $ Right 1+ liftIO $ i === 1+ i <- tryRAW $ captureRAW $ \k -> k $ Left $ toException Overflow+ liftIO $ conv i === Left (Just Overflow)+ captureRAW $ \k -> k $ Right ()+ i <- tryRAW $ throwRAW Underflow+ liftIO $ conv i === Left (Just Underflow)++ -- catch does not scope too far+ res <- try $ run 1 "test" $+ fmap (either show id) $ tryRAW $ captureRAW $ \k -> throwIO Overflow+ res === Left Overflow+ res <- try $ run 1 "test" $ do+ captureRAW $ \k -> throwIO Overflow+ return "x"+ res === Left Overflow++ -- catch works properly if continuation called multiple times+ ref <- newIORef []+ run 1 "test" $+ flip catchRAW (const $ liftIO $ modifyIORef ref ('x':)) $ do+ captureRAW $ \k -> do+ k $ Right ()+ k $ Right ()+ k $ Left $ toException Overflow+ k $ Right ()+ k $ Left $ toException Overflow+ flip catchRAW (const $ liftIO $ modifyIORef ref ('y':)) $ throwRAW $ toException Overflow+ (===) "xyxyy" =<< readIORef ref
+ Test/Ninja.hs view
@@ -0,0 +1,87 @@++module Test.Ninja(main) where++import Development.Shake+import Development.Shake.FilePath+import qualified Development.Shake.Config as Config+import System.Directory(copyFile)+import Control.Monad+import General.Base+import Test.Type+import qualified Data.HashMap.Strict as Map+import Data.List+import Data.Maybe+import qualified Start+import System.Environment+++main = shaken test $ \args obj -> do+ let args2 = ("-C" ++ obj "") : map tail (filter ("@" `isPrefixOf`) args)+ let real = "real" `elem` args+ action $+ if real then cmd "ninja" args2 else liftIO $ withArgs args2 Start.main+++test build obj = do+ -- when calling run anything with a leading @ gets given to Shake, anything without gets given to Ninja+ let run xs = build $ "--exception" : map (\x -> fromMaybe ('@':x) $ stripPrefix "@" x) (words xs)+ let runFail xs bad = assertException [bad] $ run $ xs ++ " --quiet"++ build ["clean"]+ run "-f../../Test/Ninja/test1.ninja"+ assertExists $ obj "out1.txt"++ run "-f../../Test/Ninja/test2.ninja"+ assertExists $ obj "out2.2"+ assertMissing $ obj "out2.1"+ build ["clean"]+ run "-f../../Test/Ninja/test2.ninja out2.1"+ assertExists $ obj "out2.1"+ assertMissing $ obj "out2.2"++ copyFile "Test/Ninja/test3-sub.ninja" $ obj "test3-sub.ninja"+ copyFile "Test/Ninja/test3-inc.ninja" $ obj "test3-inc.ninja"+ copyFile ("Test/Ninja/" ++ if null exe then "test3-unix.ninja" else "test3-win.ninja") $ obj "test3-platform.ninja"+ run "-f../../Test/Ninja/test3.ninja"+ assertNonSpace (obj "out3.1") "g4+b1+++i1"+ assertNonSpace (obj "out3.2") "g4++++i1"+ assertNonSpace (obj "out3.3") "g4++++i1"+ assertNonSpace (obj "out3.4") "g4+++s1+s2"++ run "-f../../Test/Ninja/test4.ninja out"+ assertExists $ obj "out.txt"+ assertExists $ obj "out2.txt"++ run "-f../../Test/Ninja/test5.ninja"+ assertExists $ obj "output file"++ writeFile (obj "nocreate.log") ""+ writeFile (obj "nocreate.in") ""+ run "-f../../Test/Ninja/nocreate.ninja"+ assertNonSpace (obj "nocreate.log") "x"+ run "-f../../Test/Ninja/nocreate.ninja"+ run "-f../../Test/Ninja/nocreate.ninja"+ assertNonSpace (obj "nocreate.log") "xxx"++ writeFile (obj "input") ""+ runFail "-f../../Test/Ninja/lint.ninja bad --lint" "'needed' file required rebuilding"+ run "-f../../Test/Ninja/lint.ninja good --lint"+ runFail "-f../../Test/Ninja/lint.ninja bad --lint" "not a pre-dependency"++ res <- fmap (drop 1 . lines) $ captureOutput $ run "-f../../Test/Ninja/compdb.ninja -t compdb cxx @--no-report @--quiet"+ want <- fmap lines $ readFile "Test/Ninja/compdb.output"+ let eq a b | (a1,'*':a2) <- break (== '*') a = unless (a1 `isPrefixOf` b && a2 `isSuffixOf` b) $ a === b+ | otherwise = a === b+ length want === length res+ zipWithM_ eq want res++ -- Test initial variable bindings and variables in include/subninja statements+ let test6 = obj "test6"++ copyFile "Test/Ninja/test6-sub.ninja" $ test6 ++ "-sub.ninja"+ copyFile "Test/Ninja/test6-inc.ninja" $ test6 ++ "-inc.ninja"+ copyFile "Test/Ninja/test6.ninja" $ test6 ++ ".ninja"++ config <- Config.readConfigFileWithEnv [("v1", test6)] $ test6 ++ ".ninja"+ -- The file included by subninja should have a separate variable scope+ Map.lookup "v2" config === Just "g2"
+ Test/Ninja/compdb.ninja view
@@ -0,0 +1,45 @@+# Copied from the Ninja repo++ninja_required_version = 1.3++builddir = build+cxx = g+++ar = ar+cflags = -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti $+ -fno-exceptions -pipe -Wno-missing-field-initializers $+ -DNINJA_PYTHON="python.exe" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501+ldflags = -L$builddir -static++rule cxx+ command = $cxx -MMD -MT $out -MF $out.d $cflags -c $in -o $out+ description = CXX $out+ depfile = $out.d+ deps = gcc++rule ar+ command = cmd /c $ar cqs $out.tmp $in && move /Y $out.tmp $out+ description = AR $out++rule link+ command = $cxx $ldflags -o $out $in $libs+ description = LINK $out++# the depfile parser and ninja lexers are generated using re2c.++# Core source files all build into ninja library.+build $builddir\build.o: cxx src\build.cc+build $builddir\build_log.o: cxx src\build_log.cc+build $builddir\clean.o: cxx src\clean.cc++rule doxygen+ command = doxygen $in+ description = DOXYGEN $in+doxygen_mainpage_generator = src\gen_doxygen_mainpage.sh+rule doxygen_mainpage+ command = $doxygen_mainpage_generator $in > $out+ description = DOXYGEN_MAINPAGE $out+build $builddir\doxygen_mainpage: doxygen_mainpage README COPYING | $+ $doxygen_mainpage_generator+build doxygen: doxygen doc\doxygen.config | $builddir\doxygen_mainpage++default ninja.exe
+ Test/Ninja/compdb.output view
@@ -0,0 +1,17 @@+[+ {+ "directory": "*",+ "command": "g++ -MMD -MT build\\build.o -MF build\\build.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\build.cc -o build\\build.o",+ "file": "src\\build.cc"+ },+ {+ "directory": "*",+ "command": "g++ -MMD -MT build\\build_log.o -MF build\\build_log.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\build_log.cc -o build\\build_log.o",+ "file": "src\\build_log.cc"+ },+ {+ "directory": "*",+ "command": "g++ -MMD -MT build\\clean.o -MF build\\clean.o.d -g -Wall -Wextra -Wno-deprecated -Wno-unused-parameter -fno-rtti -fno-exceptions -pipe -Wno-missing-field-initializers -DNINJA_PYTHON=\"python.exe\" -O2 -DNDEBUG -D_WIN32_WINNT=0x0501 -c src\\clean.cc -o build\\clean.o",+ "file": "src\\clean.cc"+ }+]
+ Test/Ninja/lint.ninja view
@@ -0,0 +1,13 @@+ +rule gen + command = echo $out > $out + +rule run + command = (echo $out : $out.gen > $out.d) && (echo $out > $out) + depfile = $out.d + +build good: run || good.gen bad.gen +build good.gen: gen + +build bad: run | input +build bad.gen: gen
+ Test/Ninja/nocreate.ninja view
@@ -0,0 +1,5 @@++rule gen+ command = echo x >> nocreate.log++build nocreate.out: gen nocreate.in
+ Test/Ninja/test1.ninja view
@@ -0,0 +1,5 @@++rule run+ command = touch $out++build out1.txt: run
+ Test/Ninja/test2.ninja view
@@ -0,0 +1,8 @@+ +rule run + command = touch $out + +build out2.1: run +build out2.2: run + +default out2.2
+ Test/Ninja/test3-inc.ninja view
@@ -0,0 +1,3 @@+v5 = i1 + +build out3.3: dump
+ Test/Ninja/test3-sub.ninja view
@@ -0,0 +1,6 @@+v4 = s1 +v5 = s1 + +build out3.4: dump + +v5 = s2
+ Test/Ninja/test3-unix.ninja view
@@ -0,0 +1,3 @@+ +rule dump + command = echo "$v1+$v2+$v3+$v4+$v5" > $out
+ Test/Ninja/test3-win.ninja view
@@ -0,0 +1,3 @@+ +rule dump + command = cmd /c "echo $v1+$v2+$v3+$v4+$v5 > $out"
+ Test/Ninja/test3.ninja view
@@ -0,0 +1,21 @@+ + +v1 = g1 +v5 = g1 + +include test3-platform.ninja + +v1 = g2 + +build out3.1: dump + v2 = b1 + +v1 = g3 + +subninja test3-sub.ninja + +include test3-inc.ninja + +build out3.2: dump + +v1 = g4
+ Test/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
+ Test/Ninja/test5.ninja view
@@ -0,0 +1,5 @@+ +rule run + command = touch $out + +build output$ file: run
+ Test/Ninja/test6-inc.ninja view
@@ -0,0 +1,1 @@+v2 = g2
+ Test/Ninja/test6-sub.ninja view
@@ -0,0 +1,1 @@+v2 = g3
+ Test/Ninja/test6.ninja view
@@ -0,0 +1,3 @@+v2 = g1+include ${v1}-inc.ninja+subninja ${v1}-sub.ninja
+ Test/Oracle.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}++module Test.Oracle(main) where++import Development.Shake+import Test.Type+import Control.Monad+++main = shaken test $ \args obj -> do+ let f name lhs rhs = (,) name $+ (do addOracle $ \k -> let _ = k `asTypeOf` lhs in return rhs; return ()+ ,let o = obj name ++ ".txt" in do want [o]; o *> \_ -> do v <- askOracleWith lhs rhs; writeFile' o $ show v)+ let tbl = [f "str-bool" "" True+ ,f "str-int" "" (0::Int)+ ,f "bool-str" True ""+ ,f "int-str" (0::Int) ""]++ forM_ args $ \a -> case a of+ '+':x | Just (add,_) <- lookup x tbl -> add+ '*':x | Just (_,use) <- lookup x tbl -> use+ '@':key -> do addOracle $ \() -> return key; return ()+ '%':name -> let o = obj "unit.txt" in do want [o]; o *> \_ -> do {askOracleWith () ""; writeFile' o name}+ '!':name -> do want [obj "rerun"]; obj "rerun" *> \out -> do alwaysRerun; writeFile' out name++test build obj = do+ build ["clean"]++ -- check it rebuilds when it should+ build ["@key","%name"]+ assertContents (obj "unit.txt") "name"+ build ["@key","%test"]+ assertContents (obj "unit.txt") "name"+ build ["@foo","%test"]+ assertContents (obj "unit.txt") "test"++ -- check adding/removing redundant oracles does not trigger a rebuild+ build ["@foo","%newer","+str-bool"]+ assertContents (obj "unit.txt") "test"+ build ["@foo","%newer","+str-int"]+ assertContents (obj "unit.txt") "test"+ build ["@foo","%newer"]+ assertContents (obj "unit.txt") "test"++ -- check always run works+ build ["!foo"]+ assertContents (obj "rerun") "foo"+ build ["!bar"]+ assertContents (obj "rerun") "bar"++ -- check error messages are good+ let errors args err = assertException [err] $ build $ "--quiet" : args++ build ["+str-int","*str-int"]+ errors ["*str-int"] -- Building with an an Oracle that has been removed+ "missing a call to addOracle"++ errors ["*str-bool"] -- Building with an Oracle that I know nothing about+ "missing a call to addOracle"++ build ["+str-int","*str-int"]+ errors ["+str-bool","*str-int"] -- Building with an Oracle that has changed type+ "askOracle is used at the wrong type"++ errors ["+str-int","+str-bool"] -- Two Oracles with the same question type+ "Only one call to addOracle is allowed"++ errors ["+str-int","*str-bool"] -- Using an Oracle at the wrong answer type+ "askOracle is used at the wrong type"++ build ["+str-int","+str-int"] -- Two Oracles work if they aren't used+ errors ["+str-int","+str-int","*str-int"] -- Two Oracles fail if they are used+ "Only one call to addOracle is allowed"++ errors ["+str-int","+str-bool"] -- Two Oracles with the same answer type+ "Only one call to addOracle is allowed"
+ Test/OrderOnly.hs view
@@ -0,0 +1,41 @@++module Test.OrderOnly(main) where++import Development.Shake+import Test.Type+++main = shaken test $ \args obj -> do+ want $ map obj args++ obj "bar.txt" *> \out -> do+ alwaysRerun+ writeFile' out =<< liftIO (readFile $ obj "bar.in")++ obj "foo.txt" *> \out -> do+ let src = obj "bar.txt"+ orderOnly [src]+ writeFile' out =<< liftIO (readFile src)+ need [src]++ obj "baz.txt" *> \out -> do+ let src = obj "bar.txt"+ orderOnly [src]+ liftIO $ appendFile out "x"+++test build obj = do+ writeFile (obj "bar.in") "in"+ build ["foo.txt","--sleep"]+ assertContents (obj "foo.txt") "in"+ writeFile (obj "bar.in") "out"+ build ["foo.txt","--sleep"]+ assertContents (obj "foo.txt") "out"++ writeFile (obj "baz.txt") ""+ writeFile (obj "bar.in") "in"+ build ["baz.txt","--sleep"]+ assertContents (obj "baz.txt") "x"+ writeFile (obj "bar.in") "out"+ build ["baz.txt"]+ assertContents (obj "baz.txt") "x"
+ Test/Pool.hs view
@@ -0,0 +1,68 @@++module Test.Pool(main) where++import Test.Type+import Development.Shake.Pool++import Control.Concurrent+import Control.Exception hiding (assert)+import Control.Monad+++main = shaken test $ \args obj -> return ()+++test build obj = do+ let wait = sleep 0.01+ forM_ [False,True] $ \deterministic -> do++ -- check that it aims for exactly the limit+ forM_ [1..6] $ \n -> do+ var <- newMVar (0,0) -- (maximum, current)+ runPool deterministic n $ \pool ->+ forM_ [1..5] $ \i ->+ addPool pool $ do+ modifyMVar_ var $ \(mx,now) -> return (max (now+1) mx, now+1)+ wait+ modifyMVar_ var $ \(mx,now) -> return (mx,now-1)+ res <- takeMVar var+ res === (min n 5, 0)++ -- check that exceptions are immediate+ self <- myThreadId+ handle (\(ErrorCall msg) -> msg === "pass") $+ runPool deterministic 3 $ \pool -> do+ addPool pool $ do+ wait+ error "pass"+ addPool pool $ do+ wait >> wait+ throwTo self $ ErrorCall "fail" + wait >> wait -- give chance for a delayed exception++ -- check someone spawned when at zero todo still gets run+ done <- newMVar False+ runPool deterministic 1 $ \pool ->+ addPool pool $ do+ wait+ addPool pool $ do+ wait+ modifyMVar_ done $ const $ return True+ done <- readMVar done+ assert done "Waiting on someone"++ -- check that killing a thread pool stops the tasks, bug 545+ thread <- newEmptyMVar+ done <- newEmptyMVar+ res <- newMVar True+ t <- forkIO $ finally (putMVar done ()) $ runPool deterministic 1 $ \pool ->+ addPool pool $ do+ t <- takeMVar thread+ killThread t+ wait -- allow the thread to die first+ modifyMVar_ res (const $ return False)+ putMVar thread t+ takeMVar done+ wait >> wait >> wait -- allow the bad thread to continue+ res <- readMVar res+ assert res "Early termination"
+ Test/Progress.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Test.Progress(main) where++import Development.Shake.Progress+import Test.Type+import Data.Monoid+import System.Directory+import System.FilePath+++main = shaken test $ \args obj -> return ()+++-- | Given a list of todo times, get out a list of how long is predicted+prog = progEx 10000000000000000+++progEx :: Double -> [Double] -> IO [Double]+progEx mxDone todo = do+ let resolution = 10000 -- Use resolution to get extra detail on the numbers+ let done = scanl (+) 0 $ map (min mxDone . max 0) $ zipWith (-) todo (tail todo)+ let res = progressReplay $ zip (map (*resolution) [1..]) $ tail $ zipWith (\t d -> mempty{timeBuilt=d*resolution,timeTodo=(t*resolution,0)}) todo done+ return $ (0/0) : map ((/ resolution) . actualSecs) res+++test build obj = do+ -- perfect functions should match perfectly+ xs <- prog [10,9..1]+ drop 2 xs === [8,7..1]+ xs <- prog $ map (*5) [10,9..1]+ drop 2 xs === [8,7..1]+ xs <- prog $ map (*0.2) [10,9..1]+ let dp3 x = fromIntegral (round $ x * 1000 :: Int) / 1000+ map dp3 (drop 2 xs) === [8,7..1]++ -- The properties below this line could be weakened++ -- increasing functions can't match+ xs <- prog [5,6,7]+ last xs === 7++ -- the first value must be plausible, or missing+ xs <- prog [187]+ assert (isNaN $ head xs) "No first value"++ -- desirable properties, could be weakened+ xs <- progEx 2 $ 100:map (*2) [10,9..1]+ drop 5 xs === [6,5..1]+ xs <- progEx 1 $ [10,9,100,8,7,6,5,4,3,2,1]+ assert (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close"++ -- if no progress is made, don't keep the time going up+ xs <- prog [10,9,8,7,7,7,7,7]+ drop 5 xs === [7,7,7]++ -- if the work rate changes, should somewhat reflect that+ xs <- prog [10,9,8,7,6.5,6,5.5,5]+ assert (last xs > 7.1) "Some discounting (factor=0 would give 7)"++ xs <- getDirectoryContents "Test/Progress"+ build $ ["--progress=replay=Test/Progress/" ++ x | x <- xs, takeExtension x == ".prog"] +++ ["--no-report","--report=-","--report=" ++ obj "progress.html"]
+ Test/Progress/self-clean-j2.prog view
@@ -0,0 +1,62 @@+(1.120224,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 254, countUnknown = 0, countTodo = 145, timeSkipped = 0.0, timeBuilt = 0.8861771221272647, timeUnknown = 0.0, timeTodo = (0.0,145)}) +(2.4994998,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 258, countUnknown = 0, countTodo = 147, timeSkipped = 0.0, timeBuilt = 1.259251721901819, timeUnknown = 0.0, timeTodo = (0.0,147)}) +(5.156031,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 259, countUnknown = 0, countTodo = 146, timeSkipped = 0.0, timeBuilt = 3.8557707152795047, timeUnknown = 0.0, timeTodo = (0.0,146)}) +(6.4472423,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 261, countUnknown = 0, countTodo = 144, timeSkipped = 0.0, timeBuilt = 6.519303449196741, timeUnknown = 0.0, timeTodo = (0.0,144)}) +(7.737371,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 262, countUnknown = 0, countTodo = 143, timeSkipped = 0.0, timeBuilt = 9.126777537865564, timeUnknown = 0.0, timeTodo = (0.0,143)}) +(9.061503,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 267, countUnknown = 0, countTodo = 138, timeSkipped = 0.0, timeBuilt = 11.739121564431116, timeUnknown = 0.0, timeTodo = (0.0,138)}) +(10.368634,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 268, countUnknown = 0, countTodo = 137, timeSkipped = 0.0, timeBuilt = 14.354383119149134, timeUnknown = 0.0, timeTodo = (0.0,137)}) +(11.658763,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 272, countUnknown = 0, countTodo = 133, timeSkipped = 0.0, timeBuilt = 16.976646550698206, timeUnknown = 0.0, timeTodo = (0.0,133)}) +(12.941892,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 274, countUnknown = 0, countTodo = 131, timeSkipped = 0.0, timeBuilt = 19.57990659098141, timeUnknown = 0.0, timeTodo = (0.0,131)}) +(14.22602,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 279, countUnknown = 0, countTodo = 126, timeSkipped = 0.0, timeBuilt = 22.17116750101559, timeUnknown = 0.0, timeTodo = (0.0,126)}) +(15.511148,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 282, countUnknown = 0, countTodo = 123, timeSkipped = 0.0, timeBuilt = 24.74242699961178, timeUnknown = 0.0, timeTodo = (0.0,123)}) +(16.794277,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 283, countUnknown = 0, countTodo = 122, timeSkipped = 0.0, timeBuilt = 27.31368459085934, timeUnknown = 0.0, timeTodo = (0.0,122)}) +(18.085405,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 288, countUnknown = 0, countTodo = 117, timeSkipped = 0.0, timeBuilt = 29.8999453864526, timeUnknown = 0.0, timeTodo = (0.0,117)}) +(19.398537,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 294, countUnknown = 0, countTodo = 111, timeSkipped = 0.0, timeBuilt = 32.487208493752405, timeUnknown = 0.0, timeTodo = (0.0,111)}) +(21.451742,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 295, countUnknown = 0, countTodo = 110, timeSkipped = 0.0, timeBuilt = 35.872547277016565, timeUnknown = 0.0, timeTodo = (0.0,110)}) +(22.761873,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 297, countUnknown = 0, countTodo = 108, timeSkipped = 0.0, timeBuilt = 39.24288571695797, timeUnknown = 0.0, timeTodo = (0.0,108)}) +(24.060003,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 298, countUnknown = 0, countTodo = 107, timeSkipped = 0.0, timeBuilt = 41.825143941445276, timeUnknown = 0.0, timeTodo = (0.0,107)}) +(25.555153,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 304, countUnknown = 0, countTodo = 101, timeSkipped = 0.0, timeBuilt = 44.66642964701168, timeUnknown = 0.0, timeTodo = (0.0,101)}) +(26.868284,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 305, countUnknown = 0, countTodo = 100, timeSkipped = 0.0, timeBuilt = 47.460708745522425, timeUnknown = 0.0, timeTodo = (0.0,100)}) +(28.22642,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 306, countUnknown = 0, countTodo = 99, timeSkipped = 0.0, timeBuilt = 50.111974843544886, timeUnknown = 0.0, timeTodo = (0.0,99)}) +(29.52355,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 308, countUnknown = 0, countTodo = 97, timeSkipped = 0.0, timeBuilt = 52.788244374794886, timeUnknown = 0.0, timeTodo = (0.0,97)}) +(30.82868,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 309, countUnknown = 0, countTodo = 96, timeSkipped = 0.0, timeBuilt = 55.38850606302731, timeUnknown = 0.0, timeTodo = (0.0,96)}) +(31.83378,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 309, countUnknown = 0, countTodo = 96, timeSkipped = 0.0, timeBuilt = 55.38850606302731, timeUnknown = 0.0, timeTodo = (0.0,96)}) +(33.099907,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 311, countUnknown = 0, countTodo = 94, timeSkipped = 0.0, timeBuilt = 57.70873845438473, timeUnknown = 0.0, timeTodo = (0.0,94)}) +(34.455044,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 312, countUnknown = 0, countTodo = 93, timeSkipped = 0.0, timeBuilt = 62.583227284951136, timeUnknown = 0.0, timeTodo = (0.0,93)}) +(35.775173,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 323, countUnknown = 0, countTodo = 82, timeSkipped = 0.0, timeBuilt = 65.22149098734371, timeUnknown = 0.0, timeTodo = (0.0,82)}) +(37.087307,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 324, countUnknown = 0, countTodo = 81, timeSkipped = 0.0, timeBuilt = 67.89576161722653, timeUnknown = 0.0, timeTodo = (0.0,81)}) +(38.39644,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 332, countUnknown = 0, countTodo = 73, timeSkipped = 0.0, timeBuilt = 70.54603017191403, timeUnknown = 0.0, timeTodo = (0.0,73)}) +(39.705566,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 336, countUnknown = 0, countTodo = 69, timeSkipped = 0.0, timeBuilt = 73.18129933695309, timeUnknown = 0.0, timeTodo = (0.0,69)}) +(41.676765,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 339, countUnknown = 0, countTodo = 66, timeSkipped = 0.0, timeBuilt = 76.48663152079098, timeUnknown = 0.0, timeTodo = (0.0,66)}) +(42.969894,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 342, countUnknown = 0, countTodo = 63, timeSkipped = 0.0, timeBuilt = 79.77195943216793, timeUnknown = 0.0, timeTodo = (0.0,63)}) +(44.364033,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 345, countUnknown = 0, countTodo = 60, timeSkipped = 0.0, timeBuilt = 82.46222890238278, timeUnknown = 0.0, timeTodo = (0.0,60)}) +(45.367134,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 348, countUnknown = 0, countTodo = 57, timeSkipped = 0.0, timeBuilt = 85.15849507669918, timeUnknown = 0.0, timeTodo = (0.0,57)}) +(47.0483,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 351, countUnknown = 0, countTodo = 54, timeSkipped = 0.0, timeBuilt = 87.8587666831445, timeUnknown = 0.0, timeTodo = (0.0,54)}) +(48.052402,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 351, countUnknown = 0, countTodo = 54, timeSkipped = 0.0, timeBuilt = 87.8587666831445, timeUnknown = 0.0, timeTodo = (0.0,54)}) +(49.890587,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 354, countUnknown = 0, countTodo = 51, timeSkipped = 0.0, timeBuilt = 90.69304478983395, timeUnknown = 0.0, timeTodo = (0.0,51)}) +(50.894688,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 354, countUnknown = 0, countTodo = 51, timeSkipped = 0.0, timeBuilt = 90.69304478983395, timeUnknown = 0.0, timeTodo = (0.0,51)}) +(51.897785,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 354, countUnknown = 0, countTodo = 51, timeSkipped = 0.0, timeBuilt = 90.69304478983395, timeUnknown = 0.0, timeTodo = (0.0,51)}) +(54.92909,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 357, countUnknown = 0, countTodo = 48, timeSkipped = 0.0, timeBuilt = 94.47342885355465, timeUnknown = 0.0, timeTodo = (0.0,48)}) +(56.23222,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 358, countUnknown = 0, countTodo = 47, timeSkipped = 0.0, timeBuilt = 97.04368794779293, timeUnknown = 0.0, timeTodo = (0.0,47)}) +(57.53035,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 360, countUnknown = 0, countTodo = 45, timeSkipped = 0.0, timeBuilt = 100.92107594828121, timeUnknown = 0.0, timeTodo = (0.0,45)}) +(58.82748,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 361, countUnknown = 0, countTodo = 44, timeSkipped = 0.0, timeBuilt = 103.52433598856442, timeUnknown = 0.0, timeTodo = (0.0,44)}) +(60.104607,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 368, countUnknown = 0, countTodo = 37, timeSkipped = 0.0, timeBuilt = 106.14560521463864, timeUnknown = 0.0, timeTodo = (0.0,37)}) +(62.0268,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 369, countUnknown = 0, countTodo = 36, timeSkipped = 0.0, timeBuilt = 109.38093007425778, timeUnknown = 0.0, timeTodo = (0.0,36)}) +(63.33293,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 372, countUnknown = 0, countTodo = 33, timeSkipped = 0.0, timeBuilt = 112.58624852518551, timeUnknown = 0.0, timeTodo = (0.0,33)}) +(64.62606,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 374, countUnknown = 0, countTodo = 31, timeSkipped = 0.0, timeBuilt = 115.16150487284176, timeUnknown = 0.0, timeTodo = (0.0,31)}) +(65.925186,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 379, countUnknown = 0, countTodo = 26, timeSkipped = 0.0, timeBuilt = 117.77476704935543, timeUnknown = 0.0, timeTodo = (0.0,26)}) +(68.11641,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 387, countUnknown = 0, countTodo = 18, timeSkipped = 0.0, timeBuilt = 122.62825597147457, timeUnknown = 0.0, timeTodo = (0.0,18)}) +(69.121506,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 387, countUnknown = 0, countTodo = 18, timeSkipped = 0.0, timeBuilt = 122.62825597147457, timeUnknown = 0.0, timeTodo = (0.0,18)}) +(70.77867,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 390, countUnknown = 0, countTodo = 15, timeSkipped = 0.0, timeBuilt = 125.30251897196285, timeUnknown = 0.0, timeTodo = (0.0,15)}) +(74.353035,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 393, countUnknown = 0, countTodo = 12, timeSkipped = 0.0, timeBuilt = 127.54874242166989, timeUnknown = 0.0, timeTodo = (0.0,12)}) +(75.35613,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 396, countUnknown = 0, countTodo = 9, timeSkipped = 0.0, timeBuilt = 130.15401280741207, timeUnknown = 0.0, timeTodo = (0.0,9)}) +(76.85028,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 399, countUnknown = 0, countTodo = 6, timeSkipped = 0.0, timeBuilt = 133.99539006571285, timeUnknown = 0.0, timeTodo = (0.0,6)}) +(79.081505,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 402, countUnknown = 0, countTodo = 3, timeSkipped = 0.0, timeBuilt = 136.22862065653317, timeUnknown = 0.0, timeTodo = (0.0,3)}) +(81.25272,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)}) +(82.260826,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)}) +(83.26492,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)}) +(84.27003,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)}) +(85.274124,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)}) +(86.28023,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)}) +(87.284325,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)}) +(88.28843,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 0, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.41584599833004, timeUnknown = 0.0, timeTodo = (0.0,1)})
+ Test/Progress/self-rebuild-j2.prog view
@@ -0,0 +1,56 @@+(3.6053605,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 258, countUnknown = 1, countTodo = 147, timeSkipped = 0.0, timeBuilt = 1.054105345858261, timeUnknown = 0.0, timeTodo = (135.01951599121094,0)}) +(4.8964896,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 259, countUnknown = 1, countTodo = 146, timeSkipped = 0.0, timeBuilt = 3.6373634978663176, timeUnknown = 0.0, timeTodo = (132.3802523612976,0)}) +(6.189619,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 260, countUnknown = 1, countTodo = 145, timeSkipped = 0.0, timeBuilt = 6.2686262771021575, timeUnknown = 0.0, timeTodo = (129.85099935531616,0)}) +(7.4677467,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 262, countUnknown = 1, countTodo = 143, timeSkipped = 0.0, timeBuilt = 8.854884450091049, timeUnknown = 0.0, timeTodo = (127.25373983383179,0)}) +(8.742874,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 268, countUnknown = 1, countTodo = 137, timeSkipped = 0.0, timeBuilt = 11.444143597735092, timeUnknown = 0.0, timeTodo = (124.70048475265503,0)}) +(10.016002,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 271, countUnknown = 1, countTodo = 134, timeSkipped = 0.0, timeBuilt = 16.5466540500056, timeUnknown = 0.0, timeTodo = (119.64597797393799,0)}) +(11.30813,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 271, countUnknown = 1, countTodo = 134, timeSkipped = 0.0, timeBuilt = 16.5466540500056, timeUnknown = 0.0, timeTodo = (119.64597797393799,0)}) +(12.59526,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 276, countUnknown = 1, countTodo = 129, timeSkipped = 0.0, timeBuilt = 19.123910252703354, timeUnknown = 0.0, timeTodo = (117.0657205581665,0)}) +(13.876388,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 278, countUnknown = 1, countTodo = 127, timeSkipped = 0.0, timeBuilt = 21.708168332232162, timeUnknown = 0.0, timeTodo = (114.43845868110657,0)}) +(15.173517,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 280, countUnknown = 1, countTodo = 125, timeSkipped = 0.0, timeBuilt = 24.27642471040599, timeUnknown = 0.0, timeTodo = (111.89620327949524,0)}) +(16.456646,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 282, countUnknown = 1, countTodo = 123, timeSkipped = 0.0, timeBuilt = 26.85868198121898, timeUnknown = 0.0, timeTodo = (109.3659496307373,0)}) +(17.726772,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 284, countUnknown = 1, countTodo = 121, timeSkipped = 0.0, timeBuilt = 29.442940060747787, timeUnknown = 0.0, timeTodo = (106.83069705963135,0)}) +(19.027903,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 288, countUnknown = 1, countTodo = 117, timeSkipped = 0.0, timeBuilt = 32.00519592012279, timeUnknown = 0.0, timeTodo = (104.28944301605225,0)}) +(20.345034,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 292, countUnknown = 1, countTodo = 113, timeSkipped = 0.0, timeBuilt = 34.586452786577865, timeUnknown = 0.0, timeTodo = (101.74619007110596,0)}) +(21.648165,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 300, countUnknown = 1, countTodo = 105, timeSkipped = 0.0, timeBuilt = 37.32872611726634, timeUnknown = 0.0, timeTodo = (99.18993377685547,0)}) +(23.717371,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 301, countUnknown = 1, countTodo = 104, timeSkipped = 0.0, timeBuilt = 40.75507003511302, timeUnknown = 0.0, timeTodo = (96.41965675354004,0)}) +(25.022503,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 303, countUnknown = 1, countTodo = 102, timeSkipped = 0.0, timeBuilt = 44.12840873445384, timeUnknown = 0.0, timeTodo = (93.89340400695801,0)}) +(26.289629,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 304, countUnknown = 1, countTodo = 101, timeSkipped = 0.0, timeBuilt = 46.6976664706599, timeUnknown = 0.0, timeTodo = (91.36415100097656,0)}) +(27.576757,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 305, countUnknown = 1, countTodo = 100, timeSkipped = 0.0, timeBuilt = 49.27292472566478, timeUnknown = 0.0, timeTodo = (88.50186347961426,0)}) +(29.49495,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 308, countUnknown = 1, countTodo = 97, timeSkipped = 0.0, timeBuilt = 52.47924644197337, timeUnknown = 0.0, timeTodo = (84.93850708007813,0)}) +(31.11511,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 311, countUnknown = 1, countTodo = 94, timeSkipped = 0.0, timeBuilt = 56.04560119356029, timeUnknown = 0.0, timeTodo = (81.36915397644043,0)}) +(32.42124,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 313, countUnknown = 1, countTodo = 92, timeSkipped = 0.0, timeBuilt = 58.938888852251694, timeUnknown = 0.0, timeTodo = (78.84289932250977,0)}) +(33.68837,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 315, countUnknown = 1, countTodo = 90, timeSkipped = 0.0, timeBuilt = 61.51514465059154, timeUnknown = 0.0, timeTodo = (75.96561431884766,0)}) +(34.961494,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 322, countUnknown = 1, countTodo = 83, timeSkipped = 0.0, timeBuilt = 64.10740501130931, timeUnknown = 0.0, timeTodo = (73.41636085510254,0)}) +(36.245625,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 330, countUnknown = 1, countTodo = 75, timeSkipped = 0.0, timeBuilt = 66.67165786470287, timeUnknown = 0.0, timeTodo = (70.8551082611084,0)}) +(37.545753,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 331, countUnknown = 1, countTodo = 74, timeSkipped = 0.0, timeBuilt = 69.22791320527904, timeUnknown = 0.0, timeTodo = (68.3188533782959,0)}) +(38.944893,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 336, countUnknown = 1, countTodo = 69, timeSkipped = 0.0, timeBuilt = 71.91318160737865, timeUnknown = 0.0, timeTodo = (65.60857582092285,0)}) +(40.345036,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 337, countUnknown = 1, countTodo = 68, timeSkipped = 0.0, timeBuilt = 74.72146255220287, timeUnknown = 0.0, timeTodo = (62.849300384521484,0)}) +(41.651165,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 340, countUnknown = 1, countTodo = 65, timeSkipped = 0.0, timeBuilt = 77.43573409761302, timeUnknown = 0.0, timeTodo = (60.147029876708984,0)}) +(42.9913,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 345, countUnknown = 1, countTodo = 60, timeSkipped = 0.0, timeBuilt = 80.11199981416576, timeUnknown = 0.0, timeTodo = (57.615779876708984,0)}) +(44.28843,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 347, countUnknown = 1, countTodo = 58, timeSkipped = 0.0, timeBuilt = 82.76326781953685, timeUnknown = 0.0, timeTodo = (55.096527099609375,0)}) +(45.844585,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 350, countUnknown = 1, countTodo = 55, timeSkipped = 0.0, timeBuilt = 85.57555038179271, timeUnknown = 0.0, timeTodo = (53.285343170166016,0)}) +(46.848686,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 354, countUnknown = 1, countTodo = 51, timeSkipped = 0.0, timeBuilt = 88.44083816255443, timeUnknown = 0.0, timeTodo = (50.76008987426758,0)}) +(47.852783,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 354, countUnknown = 1, countTodo = 51, timeSkipped = 0.0, timeBuilt = 88.44083816255443, timeUnknown = 0.0, timeTodo = (50.76008987426758,0)}) +(50.848083,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 357, countUnknown = 1, countTodo = 48, timeSkipped = 0.0, timeBuilt = 92.16721374238841, timeUnknown = 0.0, timeTodo = (48.103824615478516,0)}) +(52.852283,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 358, countUnknown = 1, countTodo = 47, timeSkipped = 0.0, timeBuilt = 95.5145495578181, timeUnknown = 0.0, timeTodo = (45.494564056396484,0)}) +(54.130413,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 362, countUnknown = 1, countTodo = 43, timeSkipped = 0.0, timeBuilt = 100.13300735200755, timeUnknown = 0.0, timeTodo = (41.70818328857422,0)}) +(55.41054,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 363, countUnknown = 1, countTodo = 42, timeSkipped = 0.0, timeBuilt = 102.67526275361888, timeUnknown = 0.0, timeTodo = (39.17192840576172,0)}) +(56.414642,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 369, countUnknown = 1, countTodo = 36, timeSkipped = 0.0, timeBuilt = 105.25251800264232, timeUnknown = 0.0, timeTodo = (36.63368225097656,0)}) +(59.073906,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 372, countUnknown = 1, countTodo = 33, timeSkipped = 0.0, timeBuilt = 107.67676574434154, timeUnknown = 0.0, timeTodo = (34.10843276977539,0)}) +(60.356033,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 374, countUnknown = 1, countTodo = 31, timeSkipped = 0.0, timeBuilt = 110.21202117647044, timeUnknown = 0.0, timeTodo = (31.546173095703125,0)}) +(61.641163,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 375, countUnknown = 1, countTodo = 30, timeSkipped = 0.0, timeBuilt = 114.02240401948802, timeUnknown = 0.0, timeTodo = (28.913909912109375,0)}) +(62.92029,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 381, countUnknown = 1, countTodo = 24, timeSkipped = 0.0, timeBuilt = 116.60766250337474, timeUnknown = 0.0, timeTodo = (26.366653442382813,0)}) +(65.09751,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 387, countUnknown = 1, countTodo = 18, timeSkipped = 0.0, timeBuilt = 121.40914184297435, timeUnknown = 0.0, timeTodo = (22.06322479248047,0)}) +(66.10161,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 387, countUnknown = 1, countTodo = 18, timeSkipped = 0.0, timeBuilt = 121.40914184297435, timeUnknown = 0.0, timeTodo = (22.06322479248047,0)}) +(67.678764,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 390, countUnknown = 1, countTodo = 15, timeSkipped = 0.0, timeBuilt = 123.98239928926341, timeUnknown = 0.0, timeTodo = (19.453964233398438,0)}) +(71.20812,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 393, countUnknown = 1, countTodo = 12, timeSkipped = 0.0, timeBuilt = 126.19761687959544, timeUnknown = 0.0, timeTodo = (17.226730346679688,0)}) +(72.21122,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 396, countUnknown = 1, countTodo = 9, timeSkipped = 0.0, timeBuilt = 128.785888974322, timeUnknown = 0.0, timeTodo = (14.163421630859375,0)}) +(73.53935,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 399, countUnknown = 1, countTodo = 6, timeSkipped = 0.0, timeBuilt = 133.6913836642634, timeUnknown = 0.0, timeTodo = (11.642166137695313,0)}) +(75.757576,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 402, countUnknown = 1, countTodo = 3, timeSkipped = 0.0, timeBuilt = 135.9266131564509, timeUnknown = 0.0, timeTodo = (8.530860900878906,0)}) +(77.91779,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.08883697236888, timeUnknown = 0.0, timeTodo = (6.776679992675781,0)}) +(78.92289,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.08883697236888, timeUnknown = 0.0, timeTodo = (6.776679992675781,0)}) +(79.925995,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.08883697236888, timeUnknown = 0.0, timeTodo = (6.776679992675781,0)}) +(80.93109,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.08883697236888, timeUnknown = 0.0, timeTodo = (6.776679992675781,0)}) +(81.93419,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.08883697236888, timeUnknown = 0.0, timeTodo = (6.776679992675781,0)}) +(82.93929,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 138.08883697236888, timeUnknown = 0.0, timeTodo = (6.776679992675781,0)})
+ Test/Progress/self-zero-j2.prog view
@@ -0,0 +1,57 @@+(1.020102,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 254, countUnknown = 4, countTodo = 148, timeSkipped = 0.0, timeBuilt = 0.7620761110447347, timeUnknown = 2.0004000980407e-3, timeTodo = (146.13152742385864,0)}) +(3.7443745,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 258, countUnknown = 1, countTodo = 147, timeSkipped = 0.0, timeBuilt = 1.0521051175892353, timeUnknown = 0.0, timeTodo = (145.76045322418213,0)}) +(5.032503,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 260, countUnknown = 1, countTodo = 145, timeSkipped = 0.0, timeBuilt = 3.678367782384157, timeUnknown = 0.0, timeTodo = (143.16193342208862,0)}) +(6.339634,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 261, countUnknown = 1, countTodo = 144, timeSkipped = 0.0, timeBuilt = 6.317631412297487, timeUnknown = 0.0, timeTodo = (140.56067323684692,0)}) +(7.6067605,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 262, countUnknown = 1, countTodo = 143, timeSkipped = 0.0, timeBuilt = 8.911890674382448, timeUnknown = 0.0, timeTodo = (137.99141645431519,0)}) +(8.867887,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 265, countUnknown = 1, countTodo = 140, timeSkipped = 0.0, timeBuilt = 11.489148784428835, timeUnknown = 0.0, timeTodo = (135.31988191604614,0)}) +(10.124012,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 266, countUnknown = 1, countTodo = 139, timeSkipped = 0.0, timeBuilt = 14.01840179041028, timeUnknown = 0.0, timeTodo = (132.74862432479858,0)}) +(11.394139,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 270, countUnknown = 1, countTodo = 135, timeSkipped = 0.0, timeBuilt = 16.545654464513063, timeUnknown = 0.0, timeTodo = (130.13927960395813,0)}) +(12.661266,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 278, countUnknown = 1, countTodo = 127, timeSkipped = 0.0, timeBuilt = 19.09290998056531, timeUnknown = 0.0, timeTodo = (127.51380348205566,0)}) +(13.928392,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 280, countUnknown = 1, countTodo = 125, timeSkipped = 0.0, timeBuilt = 21.638164687901735, timeUnknown = 0.0, timeTodo = (124.94054412841797,0)}) +(15.19352,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 283, countUnknown = 1, countTodo = 122, timeSkipped = 0.0, timeBuilt = 24.176418472081423, timeUnknown = 0.0, timeTodo = (122.32628202438354,0)}) +(16.462646,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 284, countUnknown = 1, countTodo = 121, timeSkipped = 0.0, timeBuilt = 26.708671737462282, timeUnknown = 0.0, timeTodo = (119.71102046966553,0)}) +(17.723772,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 286, countUnknown = 1, countTodo = 119, timeSkipped = 0.0, timeBuilt = 29.24492471292615, timeUnknown = 0.0, timeTodo = (117.13076210021973,0)}) +(18.9989,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 290, countUnknown = 1, countTodo = 115, timeSkipped = 0.0, timeBuilt = 31.782178092747927, timeUnknown = 0.0, timeTodo = (114.32748413085938,0)}) +(20.265026,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 294, countUnknown = 1, countTodo = 111, timeSkipped = 0.0, timeBuilt = 34.328432250767946, timeUnknown = 0.0, timeTodo = (110.95114421844482,0)}) +(21.525152,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 296, countUnknown = 1, countTodo = 109, timeSkipped = 0.0, timeBuilt = 36.87168710306287, timeUnknown = 0.0, timeTodo = (108.3658857345581,0)}) +(22.792278,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 297, countUnknown = 1, countTodo = 108, timeSkipped = 0.0, timeBuilt = 39.39593904092908, timeUnknown = 0.0, timeTodo = (105.79362773895264,0)}) +(24.09941,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 301, countUnknown = 1, countTodo = 104, timeSkipped = 0.0, timeBuilt = 41.934190917760134, timeUnknown = 0.0, timeTodo = (103.46539211273193,0)}) +(25.552555,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 307, countUnknown = 1, countTodo = 98, timeSkipped = 0.0, timeBuilt = 44.71846978738904, timeUnknown = 0.0, timeTodo = (100.06105041503906,0)}) +(27.156715,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 310, countUnknown = 1, countTodo = 95, timeSkipped = 0.0, timeBuilt = 47.48474519327283, timeUnknown = 0.0, timeTodo = (97.22976875305176,0)}) +(28.427843,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 311, countUnknown = 1, countTodo = 94, timeSkipped = 0.0, timeBuilt = 50.347032714635134, timeUnknown = 0.0, timeTodo = (94.5565013885498,0)}) +(29.692968,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 312, countUnknown = 1, countTodo = 93, timeSkipped = 0.0, timeBuilt = 53.222318816930056, timeUnknown = 0.0, timeTodo = (91.93223762512207,0)}) +(30.960096,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 314, countUnknown = 1, countTodo = 91, timeSkipped = 0.0, timeBuilt = 55.76357476785779, timeUnknown = 0.0, timeTodo = (89.2559642791748,0)}) +(32.22322,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 317, countUnknown = 1, countTodo = 88, timeSkipped = 0.0, timeBuilt = 58.305828262120485, timeUnknown = 0.0, timeTodo = (86.59769439697266,0)}) +(33.50235,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 321, countUnknown = 1, countTodo = 84, timeSkipped = 0.0, timeBuilt = 60.847080398350954, timeUnknown = 0.0, timeTodo = (83.98942756652832,0)}) +(34.50545,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 321, countUnknown = 1, countTodo = 84, timeSkipped = 0.0, timeBuilt = 60.847080398350954, timeUnknown = 0.0, timeTodo = (83.98942756652832,0)}) +(35.778576,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 327, countUnknown = 1, countTodo = 78, timeSkipped = 0.0, timeBuilt = 64.42744653299451, timeUnknown = 0.0, timeTodo = (79.1019344329834,0)}) +(37.039703,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 331, countUnknown = 1, countTodo = 74, timeSkipped = 0.0, timeBuilt = 67.99280183389783, timeUnknown = 0.0, timeTodo = (75.79260063171387,0)}) +(38.30183,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 332, countUnknown = 1, countTodo = 73, timeSkipped = 0.0, timeBuilt = 70.5080529935658, timeUnknown = 0.0, timeTodo = (73.16133689880371,0)}) +(39.60196,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 337, countUnknown = 1, countTodo = 68, timeSkipped = 0.0, timeBuilt = 73.04030625894666, timeUnknown = 0.0, timeTodo = (70.54007148742676,0)}) +(40.9971,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 341, countUnknown = 1, countTodo = 64, timeSkipped = 0.0, timeBuilt = 75.7465783841908, timeUnknown = 0.0, timeTodo = (67.84580421447754,0)}) +(42.251225,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 343, countUnknown = 1, countTodo = 62, timeSkipped = 0.0, timeBuilt = 78.44684617593884, timeUnknown = 0.0, timeTodo = (64.56347465515137,0)}) +(43.51035,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 348, countUnknown = 1, countTodo = 57, timeSkipped = 0.0, timeBuilt = 80.97609345987439, timeUnknown = 0.0, timeTodo = (61.85720443725586,0)}) +(45.31053,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 354, countUnknown = 1, countTodo = 51, timeSkipped = 0.0, timeBuilt = 85.3115312345326, timeUnknown = 0.0, timeTodo = (56.32666015625,0)}) +(46.31663,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 354, countUnknown = 1, countTodo = 51, timeSkipped = 0.0, timeBuilt = 85.3115312345326, timeUnknown = 0.0, timeTodo = (56.32666015625,0)}) +(47.953796,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 357, countUnknown = 1, countTodo = 48, timeSkipped = 0.0, timeBuilt = 87.96779649332166, timeUnknown = 0.0, timeTodo = (52.5462760925293,0)}) +(49.22192,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 357, countUnknown = 1, countTodo = 48, timeSkipped = 0.0, timeBuilt = 87.96779649332166, timeUnknown = 0.0, timeTodo = (52.5462760925293,0)}) +(50.483047,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 358, countUnknown = 1, countTodo = 47, timeSkipped = 0.0, timeBuilt = 90.48504655435681, timeUnknown = 0.0, timeTodo = (49.943016052246094,0)}) +(51.742172,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 362, countUnknown = 1, countTodo = 43, timeSkipped = 0.0, timeBuilt = 94.27242677286267, timeUnknown = 0.0, timeTodo = (46.054622650146484,0)}) +(53.0143,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 364, countUnknown = 1, countTodo = 41, timeSkipped = 0.0, timeBuilt = 96.79567353799939, timeUnknown = 0.0, timeTodo = (43.455360412597656,0)}) +(54.279427,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 365, countUnknown = 1, countTodo = 40, timeSkipped = 0.0, timeBuilt = 99.32792680338025, timeUnknown = 0.0, timeTodo = (40.88410568237305,0)}) +(55.549553,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 368, countUnknown = 1, countTodo = 37, timeSkipped = 0.0, timeBuilt = 101.87118165567517, timeUnknown = 0.0, timeTodo = (38.3088493347168,0)}) +(56.90669,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 371, countUnknown = 1, countTodo = 34, timeSkipped = 0.0, timeBuilt = 104.48744599893689, timeUnknown = 0.0, timeTodo = (35.06652069091797,0)}) +(58.179817,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 372, countUnknown = 1, countTodo = 33, timeSkipped = 0.0, timeBuilt = 107.11970918253064, timeUnknown = 0.0, timeTodo = (32.46625900268555,0)}) +(59.453945,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 380, countUnknown = 1, countTodo = 25, timeSkipped = 0.0, timeBuilt = 109.69997041299939, timeUnknown = 0.0, timeTodo = (29.24193572998047,0)}) +(61.17312,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 387, countUnknown = 1, countTodo = 18, timeSkipped = 0.0, timeBuilt = 114.0083963163197, timeUnknown = 0.0, timeTodo = (24.391448974609375,0)}) +(62.17922,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 387, countUnknown = 1, countTodo = 18, timeSkipped = 0.0, timeBuilt = 114.0083963163197, timeUnknown = 0.0, timeTodo = (24.391448974609375,0)}) +(63.787376,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 390, countUnknown = 1, countTodo = 15, timeSkipped = 0.0, timeBuilt = 116.61765687540174, timeUnknown = 0.0, timeTodo = (21.717185974121094,0)}) +(67.25372,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 393, countUnknown = 1, countTodo = 12, timeSkipped = 0.0, timeBuilt = 118.84489076212049, timeUnknown = 0.0, timeTodo = (19.470962524414063,0)}) +(69.114914,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 399, countUnknown = 1, countTodo = 6, timeSkipped = 0.0, timeBuilt = 124.42945497110486, timeUnknown = 0.0, timeTodo = (13.024314880371094,0)}) +(70.91309,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 402, countUnknown = 1, countTodo = 3, timeSkipped = 0.0, timeBuilt = 127.54076020792127, timeUnknown = 0.0, timeTodo = (10.791084289550781,0)}) +(72.67527,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 129.2949411161244, timeUnknown = 0.0, timeTodo = (8.603858947753906,0)}) +(73.68037,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 129.2949411161244, timeUnknown = 0.0, timeTodo = (8.603858947753906,0)}) +(74.683464,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 129.2949411161244, timeUnknown = 0.0, timeTodo = (8.603858947753906,0)}) +(75.68657,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 129.2949411161244, timeUnknown = 0.0, timeTodo = (8.603858947753906,0)}) +(76.68967,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 129.2949411161244, timeUnknown = 0.0, timeTodo = (8.603858947753906,0)}) +(77.69477,Progress {isFailure = Nothing, countSkipped = 0, countBuilt = 404, countUnknown = 1, countTodo = 1, timeSkipped = 0.0, timeBuilt = 129.2949411161244, timeUnknown = 0.0, timeTodo = (8.603858947753906,0)})
+ Test/Random.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE PatternGuards #-}++module Test.Random(main) where++import Development.Shake+import Test.Type+import Control.Exception+import Control.Monad+import Data.List+import Data.Maybe+import Data.Time+import System.Environment+import System.Exit+import System.Random+import General.Base+++inputRange = [1..10]++data Value = Single Int | Multiple [[Value]]+ deriving (Read,Show,Eq)++data Source = Input Int | Output Int | Bang+ deriving (Read,Show)++data Logic = Logic Int [[Source]]+ | Want [Int]+ deriving (Read,Show)+++main = shaken test $ \args obj -> do+ let toFile (Input i) = obj $ "input-" ++ show i ++ ".txt"+ toFile (Output i) = obj $ "output-" ++ show i ++ ".txt"+ toFile Bang = error "BANG"++ let randomSleep = liftIO $ do+ i <- randomRIO (0, 25)+ sleep $ fromInteger i / 100++ forM_ (map read $ filter (isNothing . asDuration) args) $ \x -> case x of+ Want xs -> want $ map (toFile . Output) xs+ Logic out srcs -> toFile (Output out) *> \out -> do+ res <- fmap (show . Multiple) $ forM srcs $ \src -> do+ randomSleep+ need $ map toFile src+ mapM (liftIO . fmap read . readFileStrict . toFile) src+ randomSleep+ writeFileChanged out res+++asDuration :: String -> Maybe Double+asDuration x+ | "s" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just i+ | "m" `isSuffixOf` x, [(i,"")] <- reads $ init x = Just $ i * 60+ | otherwise = Nothing+++test build obj = do+ limit <- do+ args <- getArgs+ let bound = listToMaybe $ reverse $ mapMaybe asDuration args+ start <- getCurrentTime+ return $ when (isJust bound) $ do+ now <- getCurrentTime+ when (fromRational (toRational $ now `diffUTCTime` start) > fromJust bound) exitSuccess++ forM_ [1..] $ \count -> do+ limit+ putStrLn $ "* PERFORMING RANDOM TEST " ++ show count+ build ["clean"]+ build [] -- to create the directory+ forM_ inputRange $ \i ->+ writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i+ logic <- randomLogic+ runLogic [] logic+ chng <- filterM (const randomIO) inputRange + forM_ chng $ \i ->+ writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single $ negate i+ runLogic chng logic+ forM_ inputRange $ \i ->+ writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i+ logicBang <- addBang =<< addBang logic+ j <- randomRIO (1::Int,8)+ res <- try $ build $ "--exception" : ("-j" ++ show j) : map show (logicBang ++ [Want [i | Logic i _ <- logicBang]])+ case res of+ Left err+ | "BANG" `isInfixOf` show (err :: SomeException) -> return () -- error I expected+ | otherwise -> error $ "UNEXPECTED ERROR: " ++ show err+ _ -> return () -- occasionally we only put BANG in places with no dependenies that don't get rebuilt+ runLogic [] $ logic ++ [Want [i | Logic i _ <- logic]]+ where+ runLogic :: [Int] -> [Logic] -> IO ()+ runLogic negated xs = do+ let poss = [i | Logic i _ <- xs]+ i <- randomRIO (0, 7)+ wants <- replicateM i $ do+ i <- randomRIO (0, 5)+ replicateM i $ randomElem poss+ sleepFileTime+ j <- randomRIO (1::Int,8)+ build $ ("-j" ++ show j) : map show (xs ++ map Want wants)++ let value i = case [ys | Logic j ys <- xs, j == i] of+ [ys] -> Multiple $ flip map ys $ map $ \i -> case i of+ Input i -> Single $ if i `elem` negated then negate i else i+ Output i -> value i+ forM_ (concat wants) $ \i -> do+ let wanted = value i+ got <- fmap read $ readFileStrict $ obj $ "output-" ++ show i ++ ".txt"+ when (wanted /= got) $+ error $ "INCORRECT VALUE for " ++ show i+++addBang :: [Logic] -> IO [Logic]+addBang xs = do+ i <- randomRIO (0, length xs - 1)+ let (before,now:after) = splitAt i xs+ now <- f now+ return $ before ++ now : after+ where+ f (Logic log xs) = do+ i <- randomRIO (0, length xs)+ let (before,after) = splitAt i xs+ return $ Logic log $ before ++ [Bang] : after+++randomLogic :: IO [Logic] -- only Logic constructors+randomLogic = do+ rules <- randomRIO (1,100)+ f rules $ map Input inputRange+ where+ f 0 avail = return []+ f i avail = do+ needs <- randomRIO (0,3)+ xs <- replicateM needs $ do+ ns <- randomRIO (0,3)+ replicateM ns $ randomElem avail+ let r = Logic i xs+ fmap (r:) $ f (i-1) (Output i:avail)
+ Test/Resources.hs view
@@ -0,0 +1,33 @@++module Test.Resources(main) where++import Development.Shake+import Test.Type+import Control.Monad+import Data.IORef+++main extra = do+ let cap = 2++ ref <- newIORef 0+ flip (shaken test) extra $ \args obj -> do+ want $ map obj ["file1.txt","file2.txt","file3.txt","file4.txt"]+ res <- newResource "test" cap+ res2 <- newResource "test" cap+ unless (res < res2 || res2 < res) $ error "Resources should have a good ordering"+ obj "*.txt" *> \out ->+ withResource res 1 $ do+ old <- liftIO $ atomicModifyIORef ref $ \i -> (i+1,i)+ when (old >= cap) $ error "Too many resources in use at one time"+ liftIO $ sleep 0.1+ liftIO $ atomicModifyIORef ref $ \i -> (i-1,i)+ writeFile' out ""++test build obj = do+ build ["clean"]+ build ["-j2"]+ build ["clean"]+ build ["-j4"]+ build ["clean"]+ build ["-j10"]
+ Test/Self.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Test.Self(main) where++import Development.Shake+import Development.Shake.Classes+import Development.Shake.FilePath+import Test.Type++import Control.Monad+import Data.Char+import Data.List+import System.Info+++newtype GhcPkg = GhcPkg () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+newtype GhcFlags = GhcFlags () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+++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++ -- fixup to cope with Cabal's generated files+ let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x++ ghcPkg <- addOracle $ \GhcPkg{} -> do+ Stdout out <- quietly $ cmd "ghc-pkg list --simple-output"+ return $ words out++ ghcFlags <- addOracle $ \GhcFlags{} -> do+ pkgs <- readFileLines $ obj ".pkgs"+ return $ map ("-package=" ++) pkgs++ let ghc args = do+ -- since ghc-pkg includes the ghc package, it changes if the version does+ ghcPkg $ GhcPkg ()+ flags <- ghcFlags $ GhcFlags ()+ cmd "ghc" flags args++ obj "Main" <.> exe *> \out -> do+ src <- readFileLines $ out -<.> "deps"+ let os = map (obj . moduleToFile "o") $ "Main":src+ need os+ ghc $ ["-o",out] ++ os++ obj "/*.deps" *> \out -> do+ dep <- readFileLines $ out -<.> "dep"+ let xs = map (obj . moduleToFile "deps") dep+ need xs+ ds <- fmap (nub . sort . (++) dep . concat) $ mapM readFileLines xs+ writeFileLines out ds++ obj "/*.dep" *> \out -> do+ src <- readFile' $ fixPaths $ unobj $ out -<.> "hs"+ let xs = hsImports src+ xs <- filterM (doesFileExist . fixPaths . moduleToFile "hs") xs+ writeFileLines out xs++ [obj "/*.o",obj "/*.hi"] &*> \[out,_] -> do+ deps <- readFileLines $ out -<.> "deps"+ let hs = fixPaths $ unobj $ out -<.> "hs"+ need $ hs : map (obj . moduleToFile "hi") deps+ ghc $ ["-c",hs,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"] +++ ["-DPORTABLE","-fwarn-unused-imports","-Werror"] -- to test one CPP branch++ obj ".pkgs" *> \out -> do+ src <- readFile' "shake.cabal"+ writeFileLines out $ sort $ cabalBuildDepends src+++---------------------------------------------------------------------+-- GRAB INFORMATION FROM FILES++hsImports :: String -> [String]+hsImports xs = [ takeWhile (\x -> isAlphaNum x || x `elem` "._") $ dropWhile (not . isUpper) x+ | x <- lines xs, "import " `isPrefixOf` x]+++-- FIXME: Should actually parse the list from the contents of the .cabal file+cabalBuildDepends :: String -> [String]+cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]++packages = words $+ "base transformers binary unordered-containers hashable time old-time bytestring " +++ "filepath directory process deepseq random utf8-string"
+ Test/Tar.hs view
@@ -0,0 +1,13 @@++module Test.Tar(main) where++import Development.Shake+import Test.Type+++main = shaken noTest $ \args obj -> do+ want [obj "result.tar"]+ obj "result.tar" *> \out -> do+ contents <- readFileLines "Test/Tar/list.txt"+ need contents+ cmd "tar -cf" [out] contents
+ Test/Tar/list.txt view
@@ -0,0 +1,3 @@+Test/Tar.hs+Main.hs+Test/Tar/list.txt
+ Test/Throttle.hs view
@@ -0,0 +1,29 @@++module Test.Throttle(main) where++import Development.Shake+import General.Base+import Development.Shake.FilePath+import Test.Type+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) $+ when (takeBaseName out == "file3") $ liftIO $ sleep 0.1+ 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+ retry 3 $ 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+ assert (s >= 0.7 && s < 0.8) $+ "Bad throttling, expected to take 0.7s + computation time (cap of 0.1s), took " ++ show s ++ "s"
+ Test/Type.hs view
@@ -0,0 +1,211 @@++module Test.Type(sleep, module Test.Type) where++import Development.Shake hiding (copyFileChanged)+import Development.Shake.Rule() -- ensure the module gets imported, and thus tested+import General.Base+import General.String+import Development.Shake.FileInfo+import Development.Shake.FilePath++import Control.Exception hiding (assert)+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import qualified Data.ByteString as BS+import System.Directory as IO+import System.Environment+import System.Random+import System.Console.GetOpt+import System.IO+++shaken+ :: (([String] -> IO ()) -> (String -> String) -> IO ())+ -> ([String] -> (String -> String) -> Rules ())+ -> IO ()+ -> IO ()+shaken test rules sleeper = do+ name:args <- getArgs+ when ("--sleep" `elem` args) sleeper+ putStrLn $ "## BUILD " ++ unwords (name:args)+ args <- return $ delete "--sleep" args+ let out = "output/" ++ name ++ "/"+ createDirectoryIfMissing True out+ case args of+ "test":extra -> do+ putStrLn $ "## TESTING " ++ name+ -- if the extra arguments are not --quiet/--loud it's probably going to go wrong+ let obj x = if "/" `isPrefixOf` x then init out ++ x else out ++ x+ test (\args -> withArgs (name:args ++ extra) $ shaken test rules sleeper) obj+ putStrLn $ "## FINISHED TESTING " ++ name+ "clean":_ -> removeDirectoryRecursive out+{-+ "lint":args -> do+ let dbfile = out ++ ".database"+ tempfile = "output/" ++ name ++ ".database"+ b <- IO.doesFileExist dbfile+ when b $ renameFile dbfile tempfile+ removeDirectoryRecursive out+ createDirectoryIfMissing True out+ when b $ renameFile tempfile dbfile+ shake shakeOptions{shakeFiles=out, shakeLint=True} $ rules args (out++)+-}++ "perturb":args -> forever $ do+ del <- removeFilesRandom out+ threads <- randomRIO (1,4)+ putStrLn $ "## TESTING PERTURBATION (" ++ show del ++ " files, " ++ show threads ++ " threads)"+ shake shakeOptions{shakeFiles=out, shakeThreads=threads, shakeVerbosity=Quiet} $ rules args (out++)++ args -> do+ let (_,files,_) = getOpt Permute [] args+ tracker <- findExecutable "tracker.exe"+ withArgs (args \\ files) $+ shakeWithClean+ (removeDirectoryRecursive out) + (shakeOptions{shakeFiles=out, shakeReport=["output/" ++ name ++ "/report.html"], shakeLint=Just $ if isJust tracker then LintTracker else LintBasic})+ (rules files (out++))+++shakeWithClean :: IO () -> ShakeOptions -> Rules () -> IO ()+shakeWithClean clean opts rules = shakeArgsWith opts [cleanOpt] f+ where+ cleanOpt = Option "c" ["clean"] (NoArg $ Right ()) "Clean before building."++ f extra files = do+ when (extra /= []) clean+ if "clean" `elem` files then+ clean >> return Nothing+ else+ return $ Just $ if null files then rules else want files >> withoutActions rules+++unobj :: FilePath -> FilePath+unobj = dropDirectory1 . dropDirectory1++assert :: Bool -> String -> IO ()+assert b msg = unless b $ error $ "ASSERTION FAILED: " ++ msg++infix 4 ===++(===) :: (Show a, Eq a) => a -> a -> IO ()+a === b = assert (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b+++assertExists :: FilePath -> IO ()+assertExists file = do+ b <- IO.doesFileExist file+ assert b $ "File was expected to exist, but is missing: " ++ file++assertMissing :: FilePath -> IO ()+assertMissing file = do+ b <- IO.doesFileExist file+ assert (not b) $ "File was expected to be missing, but exists: " ++ file++assertContents :: FilePath -> String -> IO ()+assertContents file want = do+ got <- readFile file+ assert (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got++assertContentsOn :: (String -> String) -> FilePath -> String -> IO ()+assertContentsOn f file want = do+ got <- readFile file+ assert (f want == f got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got +++ "\nWANT (transformed): " ++ f want ++ "\nGOT (transformed): " ++ f got++assertNonSpace :: FilePath -> String -> IO ()+assertNonSpace = assertContentsOn $ filter (not . isSpace)++assertContentsInfix :: FilePath -> String -> IO ()+assertContentsInfix file want = do+ got <- readFile file+ assert (want `isInfixOf` got) $ "File contents are wrong: " ++ file ++ "\nWANT (anywhere): " ++ want ++ "\nGOT: " ++ got++assertContentsUnordered :: FilePath -> [String] -> IO ()+assertContentsUnordered file xs = assertContentsOn (unlines . sort . lines) file (unlines xs)++assertException :: [String] -> IO () -> IO ()+assertException parts act = do+ res <- try act+ case res of+ Left err -> let s = show (err :: SomeException) in forM_ parts $ \p ->+ assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p+ Right _ -> error "Expected an exception but succeeded"+++noTest :: ([String] -> IO ()) -> (String -> String) -> IO ()+noTest build obj = do+ build ["--abbrev=output=$OUT","-j3"]+ build ["--no-build","--report=-"]+ build []+++-- | 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+ mtimes <- forM [1..10] $ \i -> fmap fst $ duration $ do+ writeFile file $ show i+ let time = fmap (fst . fromMaybe (error "File missing during sleepFileTimeCalibrate")) $ getFileInfo $ packU file+ t1 <- time+ flip loopM 0 $ \j -> do+ writeFile file $ show (i,j)+ t2 <- time+ return $ if t1 == t2 then Left $ j+1 else Right ()+ putStrLn $ "Longest file modification time lag was " ++ show (ceiling (maximum mtimes * 1000)) ++ "ms"+ return $ sleep $ min 1 $ maximum mtimes * 2+++removeFilesRandom :: FilePath -> IO Int+removeFilesRandom x = do+ files <- getDirectoryContentsRecursive x+ n <- randomRIO (0,length files)+ rs <- replicateM (length files) (randomIO :: IO Double)+ mapM_ (removeFile . snd) $ sort $ zip rs files+ return n+++getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive dir = do+ xs <- IO.getDirectoryContents dir+ (dirs,files) <- partitionM IO.doesDirectoryExist [dir </> x | x <- xs, not $ "." `isPrefixOf` x]+ rest <- concatMapM getDirectoryContentsRecursive dirs+ return $ files++rest+++copyDirectoryChanged :: FilePath -> FilePath -> IO ()+copyDirectoryChanged old new = do+ xs <- getDirectoryContentsRecursive old+ forM_ xs $ \from -> do+ let to = new </> drop (length $ addTrailingPathSeparator old) from+ createDirectoryIfMissing True $ takeDirectory to+ copyFileChanged from to+++copyFileChanged :: FilePath -> FilePath -> IO ()+copyFileChanged old new = do+ good <- IO.doesFileExist new+ good <- if not good then return False else liftM2 (==) (BS.readFile old) (BS.readFile new)+ when (not good) $ copyFile old new+++withTemporaryDirectory :: (FilePath -> IO ()) -> IO ()+withTemporaryDirectory act = do+ tdir <- getTemporaryDirectory+ bracket+ (openTempFile tdir "shake.hs")+ (removeFile . fst)+ $ \(file,h) -> do+ hClose h+ let dir = file ++ "_"+ bracket_ (createDirectory dir) (removeDirectoryRecursive dir) (act dir)++skip :: Monad m => a -> m ()+skip x = return ()
+ Test/Unicode.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Unicode(main) where++import Development.Shake+import Development.Shake.FilePath+import Test.Type+import Control.Exception+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 = do+ build ["clean"]+ -- Useful, if the error message starts crashing...+ -- 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+ res <- try $ writeFile (ext "source") "x"+ case res of+ Left (err :: SomeException) ->+ putStrLn $ "WARNING: Failed to write file " ++ pre ++ ", skipping unicode test (LANG=C ?)"+ Right _ -> do+ 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"
+ Test/Util.hs view
@@ -0,0 +1,20 @@++module Test.Util(main) where++import Development.Shake.Util+import Test.Type+++main = shaken test $ \args obj -> return ()+++test build obj = do+ parseMakefile "" === []+ parseMakefile "a:b c\ndef : ee" === [("a",["b","c"]),("def",["ee"])]+ parseMakefile "a: #comment\n#comment : b\nc : d" === [("a",[]),("c",["d"])]+ parseMakefile "a \\\n\t:b" === [("a",["b"])]+ parseMakefile "#comment\\ a : b" === []+ parseMakefile "a: b c \\\n d e\n\nf:g" === [("a",["b","c","d","e"]),("f",["g"])]+ parseMakefile "foo/bar: \\\r\n c:/a1 \\\r\n x\r\n" === [("foo/bar",["c:/a1","x"])]+ parseMakefile "output.o: src/file/with\\ space.cpp" === [("output.o",["src/file/with space.cpp"])]+ parseMakefile "a: b\\ c" === [("a",["b ","c"])]
+ Test/Verbosity.hs view
@@ -0,0 +1,39 @@++module Test.Verbosity(main) where++import Development.Shake+import Test.Type+++main = shaken test $ \args obj -> do+ want $ map obj args++ obj "in.txt" *> \out -> do+ a <- getVerbosity+ b <- withVerbosity Normal $ getVerbosity+ writeFile' out $ unwords $ map show [a,b]++ obj "out.txt" *> \out -> do+ x <- getVerbosity+ ys <- withVerbosity Loud $ do+ a <- getVerbosity+ need [obj "in.txt"] -- make sure the inherited verbosity does not get passed along+ b <- getVerbosity+ c <- quietly getVerbosity+ d <- fmap shakeVerbosity getShakeOptions+ return [a,b,c,d]+ z <- getVerbosity+ writeFile' out $ unwords $ map show $ [x] ++ ys ++ [z]++test build obj = do+ build ["out.txt","--clean"]+ assertContents (obj "in.txt") "Normal Normal"+ assertContents (obj "out.txt") "Normal Loud Loud Quiet Normal Normal"++ build ["out.txt","--clean","--verbose"]+ assertContents (obj "in.txt") "Loud Normal"+ assertContents (obj "out.txt") "Loud Loud Loud Quiet Loud Loud"++ build ["out.txt","--clean","--quiet"]+ assertContents (obj "in.txt") "Quiet Normal"+ assertContents (obj "out.txt") "Quiet Loud Loud Quiet Quiet Quiet"
docs/Manual.md view
@@ -1,6 +1,6 @@ # Shake Manual -_See also: [Shake links](https://github.com/ndmitchell/shake#readme); [Why choose Shake](https://github.com/ndmitchell/shake/blob/master/docs/Why.md#readme); [Function documentation](http://hackage.haskell.org/packages/archive/shake/latest/doc/html/Development-Shake.html)_+_See also: [Shake links](https://github.com/ndmitchell/shake#readme); [Why choose Shake](Why.md#readme); [Function documentation](http://hackage.haskell.org/packages/archive/shake/latest/doc/html/Development-Shake.html)_ Shake is a Haskell library for writing build systems - designed as a replacement for `make`. This document describes how to get started with Shake, assuming no prior Haskell knowledge. First, let's take a look at a Shake build system: @@ -14,6 +14,7 @@ want ["_build/run" <.> exe] phony "clean" $ do+ putNormal "Cleaning files in _build" removeFilesAfter "_build" ["//*"] "_build/run" <.> exe *> \out -> do@@ -36,10 +37,8 @@ 1. Install the [Haskell Platform](http://www.haskell.org/platform/), which provides a Haskell compiler and standard libraries. 2. Type `cabal update`, to download information about the latest versions of all Haskell packages.-3. Type `cabal install shake --global --profile`, to build and install Shake and all its dependencies.-4. Grab a [tarball of the repo](https://github.com/ndmitchell/shake/archive/master.tar.gz) and move to the `docs/manual` directory, which includes the code at the beginning as `Build.hs`, along with some small sample C files.-5. In the directory of the example, type `runhaskell Build.hs`, which should produce an executable `_build/run`.-6. Run `_build/run` to confirm everything worked.+3. Type `cabal install shake`, to build and install Shake and all its dependencies. +4. Type `shake --demo`, which will create a directory containing a sample project, the above Shake script, and execute it. For more details see a [trace of `shake --demo`](Demo.md). ## Basic syntax @@ -182,7 +181,7 @@ * `str1 </> str2` - add the path components together with a slash, e.g. `"_build" </> "main.o"` equals `"_build/main.o"`. * `str1 <.> str2` - add an extension, e.g. `"main" <.> "o"` equals `"main.o"`.-* `str1 ++ str2` - append two strings together, e.g. `"hello" ++ "world"` equals `"hello world"`.+* `str1 ++ str2` - append two strings together, e.g. `"hello" ++ "world"` equals `"helloworld"`. * `str1 -<.> str2` - replace an extension, e.g. `"main.c" -<.> "o"` equals `"main.o"`. * `dropExtension str` - drop the final extension of a filepath if it has one, e.g. `dropExtension "main.o"` equals `"main"`, while `dropExtension "main"` equals `"main"`. * `takeFileName str` - drop the path component, e.g. `takeFileName "_build/src/main.o"` equals `"main.o"`.@@ -262,6 +261,7 @@ A standard clean command is defined as: phony "clean" $ do+ putNormal "Cleaning files in _build" removeFilesAfter "_build" ["//*"] Running the build system with the `clean` argument, e.g. `runhaskell _build/run clean` will remove all files under the `_build` directory. This clean command is formed from two separate pieces. Firstly, we can define `phony` commands as:@@ -273,7 +273,7 @@ Where <tt><i>name</i></tt> is the name used on the command line to invoke the actions, and <tt><i>actions</i></tt> are the list of things to do in response. These names are not dependency tracked and are simply run afresh each time they are requested. -The <tt><i>actions</i></tt> can be any standard build actions, although for a `clean` rule, `removeFilesAfter` is typical. This function waits until after any files have finished building (which will be none, if you do `runhaskell _build/run clean`) then deletes all files matching `//*` in the `_build` directory.+The <tt><i>actions</i></tt> can be any standard build actions, although for a `clean` rule, `removeFilesAfter` is typical. This function waits until after any files have finished building (which will be none, if you do `runhaskell _build/run clean`) then deletes all files matching `//*` in the `_build` directory. The `putNormal` function writes out a message to the console, as long as `--quiet` was not passed. ## Running
docs/Ninja.md view
@@ -1,6 +1,6 @@ # Running Ninja builds with Shake -_See also: [Shake links](https://github.com/ndmitchell/shake#readme); [Shake manual](https://github.com/ndmitchell/shake/blob/master/docs/Manual.md#readme)_+_See also: [Shake links](https://github.com/ndmitchell/shake#readme); [Shake manual](Manual.md#readme)_ Shake supports the .ninja file format used by the [Ninja tool](http://martine.github.io/ninja/). This document describes how to use Shake instead of Ninja, and why you might want to do so.
docs/Why.md view
@@ -1,13 +1,13 @@ # Why choose Shake? -_See also: [Shake links](https://github.com/ndmitchell/shake#readme); [Shake manual](https://github.com/ndmitchell/shake/blob/master/docs/Manual.md#readme)_+_See also: [Shake links](https://github.com/ndmitchell/shake#readme); [Shake manual](Manual.md#readme)_ Shake is a library for writing build systems. Most large projects have a custom-written build system, and developers working on the project are likely to run the build system many times a day, spending a noticeable amount of time [waiting for the build system](http://xkcd.com/303/). This document explains why you might pick Shake over alternative tools for writing build systems (e.g. make, Ant, Scons). Shake primarily benefits two groups of people: * **Developers running the build system** - Shake based build systems run quickly, require little manual intervention and report estimated completion time as they go. * **Developers writing the build system** - Shake provides a powerful language for writing build systems, has excellent support for writing large robust build systems, can express many types of build rules and provides profiling information to help speed up builds. -In the rest of this document we explain and justify the above claims. Shake combines [cutting edge research](http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf) with a [robust industrial-quality implementation](http://hackage.haskell.org/package/shake/). Shake is in constant use at many large organisations, including [a large investment bank](http://sc.com/), where is was originally developed and has been in use since 2009.+In the rest of this document we explain and justify the above claims. Shake combines [cutting edge research](http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf) with a [robust industrial-quality implementation](http://hackage.haskell.org/package/shake/). Shake is in constant use at many large organisations, including [a large investment bank](http://sc.com/), where it was originally developed and has been in use since 2009. #### Expresses many types of build rule
docs/manual/Build.hs view
@@ -8,6 +8,7 @@ want ["_build/run" <.> exe] phony "clean" $ do+ putNormal "Cleaning files in _build" removeFilesAfter "_build" ["//*"] "_build/run" <.> exe *> \out -> do
docs/manual/constants.c view
@@ -3,5 +3,5 @@ char* message() {- return msg;+ return msg; }
docs/manual/main.c view
@@ -3,6 +3,6 @@ int main() {- printf("%s\n", message());- return 0;+ printf("%s\n", message());+ return 0; }
+ html/profile.html view
@@ -0,0 +1,169 @@+<!DOCTYPE html>+<html lang="en">+<head>++<meta charset="utf-8" />+<title>Shake report</title>++<!-- Libraries -->+<script src="jquery.js"></script>+<script src="jquery.flot.js"></script>+<script src="jquery.flot.stack.js"></script>+<script src="viz.js"></script>+<!-- Profiling output -->+<script src="profile-data.js"></script>+<script src="version.js"></script>+<!-- Functions for creating info from Shake builds -->+<script src="shake-util.js"></script>+<script src="shake-logic.js"></script>+<script src="shake-ui.js"></script>++<style type="text/css">+body {font-family: sans-serif; font-size: 10pt;}+.data {font-size: 9pt; border-spacing: 0px; border-collapse: collapse;}+.data td {padding-left: 7px; padding-right: 7px;}+.header {font-weight: bold; background-color: #eee !important;}+.header td:hover {background-color: #ccc !important;}+.header td {border: 1px solid #ccc; cursor: pointer;}+.data tr:hover {background-color: #ddd !important; color: black !important;}+input, select {border: 1px solid #ccc;}+* {box-sizing: border-box;}+html, body {height: 100%; width:100%;}+#run {font-weight: bold;}+.sort {color: #aaa;}+#link:visited {color: rgb(0,0,238);}+ul.space > li {padding-top: 8px; padding-bottom: 8px;}+ul.space {padding-left: 20px;}+.version {color: gray; font-style: italic;}+.shake {+ text-decoration: none;+ font-family: monospace;+ color: black;+}+</style>++</head>+<body style="margin:0px;padding:0px;">++<table style="width:100%;height:100%;padding:8px;">+ <tr><td>+ <table width="100%"><tr>+ <td>+ <button id="run">Run</button>+ </td>+ <td>+ <select id="mode">+ <option value="summary">Summary</option>+ <option value="help">Help</option>+ <option value="cmd-plot">Command plot</option>+ <option value="cmd-table">Command table</option>+ <option value="rule-table">Rule table</option>+ <option value="rule-graph">Rule graph</option>+ </select>+ </td>+ <td width="100%">+ <input id="query" style="width:100%;" />+ </td>+ <td style="padding-left:10px;">+ <a title="A link to the currently typed query" id="link" target="_blank" href="">Link</a>+ </td>+ </tr></table>+ </td></tr>+ <tr><td>+ <hr style="border-top:1px solid #ccc;" />+ </td></tr>+ <tr style="height:100%;width:100%;"><td>+ <div style="height:100%;width:100%;min-width:150px;min-height:150px;overflow:auto;" id="output">Loading...</div>+ </td></tr>+</table>++<div id="welcome" style="display:none;">+ <p>+ <b>New to Shake reports?</b> Select 'Help' from the drop-down box (currently displaying 'Summary') then press 'Run'.+ </p>+</div>++<div id="error" style="display:none;">+ <h3 style="color:#d00;">Query <span class="name">parse</span> error</h3>+ <table>+ <tr><td><ul style="margin:0px;"><li>Error message:</li></ul></td><td><code><span class="message">message</span></code></td></tr>+ <tr><td><ul style="margin:0px;"><li>User query:</li></ul></td><td><code><span class="query">the query</span></code></td></tr>+ </table>+ <p>+ For information about the query language, see <a class="example" data-mode="help" data-query="">Help</a>.+ </p>+</div>++<div id="help" style="display:none;">+ <p>+ Shake reports provide a way of filtering, grouping and viewing the result of running a Shake build system. A query is entered at the top using the text box, run using the 'Run' button, and produces a report whose type is selected from the drop-down box. The 'Link' hyperlink provides a link to the currently entered query, which is useful for copying/sharing.+ </p>+ <h3>Report types</h3>+ <p>+ The drop-down box, currently displaying 'Help', let's you pick the type of report. The best way to learn about the report types is to try them out (all work with the empty query). The types are:+ </p>+ <ul class="space">+ <li><b>Summary:</b> Display summary statistics about the Shake database. The term 'rule' refers to any Shake rule, and there will be one rule for everything that gets built or tracked, including source files. The term 'traced command' refers to any call to <a class="shake">traced</a>, which is automatically inserted by the <a class="shake">command</a> function. The reported parallelism refers to the average number of traced commands executing during the last build - for example, a parallelism of 4.0 when using <a class="shake">shakeThreads</a>=4 would be a perfect speedup. The time spent not executing traced commands includes time when Shake was checking dependencies and any Haskell operations performed by the rules.</li>+ <li><b>Help:</b> This help document.</li>+ <li><b>Command plot:</b> This plot shows which traced commands were executing at any time. The Y axis is the number of simultaneous traced commands and the X axis is the progress through the last run of the build system that executed any rules. Some useful queries are:+ <ul>+ <li><a class="example" data-mode="cmd-plot" data-query="">by default</a> - display when each traced command was executing.</li>+ <li><a class="example" data-mode="cmd-plot">group("commands")</a> - display a the total parallelism, not grouped by command.</li>+ <li><a class="example" data-mode="cmd-plot">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display parallelism grouped by result extension.</li>+ </ul>+ </li>+ <li><b>Command table:</b> This table shows all traced commands. 'name' is the group name, by default the string passed to <a class="shake">trace</a>. 'count' is the number of commands that were grouped together. 'time' is the amount of time spent executing the commands, both in absolute terms and as a percentage of the time required to build everything (including rules which are not traced). Some useful queries are:+ <ul>+ <li><a class="example" data-mode="cmd-table" data-query="">by default</a> - display all traced commands.</li>+ <li><a class="example" data-mode="cmd-table">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display parallelism grouped by result extension.</li>+ <li><a class="example" data-mode="cmd-table">group(command() + " - " + name())</a> - the complete list of all commands by rule.</li>+ <li><a class="example" data-mode="cmd-table">name(/^(.*)\/[^\/]*/,"root") && group(command())</a> - commands grouped per directory.</li>+ <li><a class="example" data-mode="cmd-table">name(slowestRule())</a> - what commands did the slowest rule run.</li>+ </ul>+ </li>+ <li><b>Rule table:</b> This table shows all rules. 'name', 'count' and 'time' are the same as for the command table, with the default name being the rule result. 'cost' is the time to rebuild if all the files changed, where a higher cost is worse. 'leaf' is true if the rule has no dependencies, typically source files. 'runs' is the number of executions since the file was built, where 0 means it was built in the last run. 'unchanged' is true if the last time the rule built it did not change value, and thus rules depending on it did not rebuild. Some useful queries are:+ <ul>+ <li><a class="example" data-mode="rule-table" data-query="">by default</a> - display all rules.</li>+ <li><a class="example" data-mode="rule-table">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display rules grouped by result extension.</li>+ <li><a class="example" data-mode="rule-table">ancestorOf(slowestRule()) && leaf() && run() == 0</a> - while leaf nodes changed in the last run to cause a rebuild of a particular rule (replace <code>slowestRule()</code> with <code>"rule name"</code> to use a different rule.</li>+ <li><a class="example" data-mode="rule-table">parentOf(slowestRule()) && !unchanged()</a> - what immediate dependency caused a particular rule to rebuild most recently (sort by 'run' to see the answer first).</li>+ <li><a class="example" data-mode="rule-table">!name(/\.[a-zA-Z0-9_]+$/)</a> - which rules have no extension.</li>+ </ul>+ </li>+ <li><b>Rule graph:</b> This table shows the rules and their dependencies. An arrow from a child node to a parent node indicates that the child depends on the parent. A solid line is a direct dependency, a dashed line is an indirect dependency, through some hidden intermediate node. Some useful queries are:+ <ul>+ <li><a class="example" data-mode="rule-graph">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display rules grouped by result extension.</li>+ </ul>+ </li>+ </ul>+ <h3>Query language</h3>+ <p>+ The query language is a Javascript expression which produces <code>true</code> to include the row, and may call <code>group</code> to indicate grouping. You can use the standard Javascript operators (e.g. <code>==</code> and <code>&&</code>). Anything which takes a <code>RegExp</code> can also accept a <code>string</code>, which is then treated as a literal unanchored regular expression. The following functions are available:+ </p>+ <ul class="space">+ <li><code>group(x : string) : true</code> - assign this item the given group. Multiple calls to <code>group</code> result in a space-separated name. The group name can also be set using <code>name</code> or <code>command</code> with captured regular expressions.</li>+ <li><code>leaf() : bool</code> - does the rule a leaf, with no dependencies.</li>+ <li><code>run() : int</code> - when was the rule last run, with 0 for run in the last tracked build, and higher numbers for run longer ago.</li>+ <li><code>unchanged() : bool</code> - last time the rule was build, was the value detected as unchanged.</li>+ <li><code>slowestRule() : string</code> - the name of the rule which took longest to build.</li>+ <li><code>name() : string</code> - the name of the current rule.</li>+ <li><code>name(x : RegExp) : bool</code> - a regular expression to match against the name of the current rule. If the regular expression contains captured patterns, these will be used as the <code>group</code></li>+ <li><code>name(x : RegExp, def : string) : true</code> - a regular expression to match against the name of the current rule, including captured patterns for the <code>group</code>. If the regular expression does not match, the function will still return true but <code>def</code> will be used as the group.</li>+ <li><code>rename(from : string, to : string) : true</code> - change <code>name</code> so any string <code>from</code> is replaced with <code>to</code>, useful for replacing an object directory (which is uninteresting) with something like $OBJ.</li>+ <li><code>rename(from : string) : true</code> - rename using <code>""</code> as the replacement string.</li>+ <li><code>command() : string</code> - when matching rules this is the name of the first command the rule executed, or <code>""</code> if the rule ran no commands. When matching commands this is the name of each command in turn.</li>+ <li><code>command(x : RegExp) : bool</code> - a regular expression to match against any of the commands, including grouping as per <code>name</code>.</li>+ <li><code>command(x : RegExp, def : string) : true</code> - works the same as the <code>name</code> function which takes two arguments.</li>+ <li><code>childOf(x : RegExp) : bool</code> - is this rule a direct child of <code>x</code>, the rule for this item calls <a class="shake">need</a>/<a class="shake">apply</a> on <code>x</code>.</li>+ <li><code>descendantOf(x : RegExp) : bool</code> - is this rule a descendant of <code>x</code>, a change in <code>x</code> will cause this rule to rebuild (ignoring unchanging rules).</li>+ <li><code>parentOf(x : RegExp) : bool</code> - is this rule a direct parent of <code>x</code>, the rule for <code>x</code> calls <a class="shake">need</a>/<a class="shake">apply</a> on this item.</li>+ <li><code>ancestorOf(x : RegExp) : bool</code> - is this rule an ancestor of <code>x</code>, a change in this rule will cause <code>x</code> to rebuild (ignoring unchanging rules).</li>+ <li><code>textColor(c : color) : true</code> - set the color of this group to the given color, represented as a string - either the name of a color (<code>"red"</code>) or a hex value (<code>"#ff0000</code>). If multiple <code>textColor</code> calls are given in one query, the last one will be used. If multiple different <code>textColor</code> values are given to one group, the group will not be colored.</li>+ <li><code>textColor(c : color, b : bool) : true</code> - set the <code>textColor</code> of this group if the second argument is <code>true</code>.</li>+ <li><code>backColor(c : color) : true</code> - like <code>textColor</code> but to set the background color.</li>+ <li><code>backColor(c : color, b : bool) : true</code> - like <code>textColor</code> but to set the background color.</li>+ </ul>+</div>++</body>+</html>
+ html/progress.html view
@@ -0,0 +1,47 @@+<!DOCTYPE html>+<html lang="en">+<head>++<meta charset="utf-8" />+<title>Shake progress diagnostic</title>++<!-- Libraries -->+<script src="jquery.js"></script>+<script src="jquery.flot.js"></script>+<script src="jquery.flot.stack.js"></script>+<!-- Progress output -->+<script src="progress-data.js"></script>+<script src="version.js"></script>+<!-- Functions for creating info from progress info -->+<script src="shake-progress.js"></script>++<style type="text/css">+body {font-family: sans-serif; font-size: 10pt;}+h1 {font-size: 12pt;}+.version {color: gray; font-style: italic; clear: both; padding-top: 30px;}+.shake {+ text-decoration: none;+ font-family: monospace;+ color: black;+}+.plot {+ width: 300px;+ height: 200px;+ float: left;+}+</style>++</head>+<body>++<h1>Shake Progress Analysis</h1>+<p>+ The red line represents the real performance, with time to completion on the X axis and predicted time on the Y axis. A perfect progress prediction would follow the gray line.+</p>++<div id="output">Loading...</div>++<p class="version"></p>++</body>+</html>
− html/report.html
@@ -1,170 +0,0 @@-<!DOCTYPE html>-<html lang="en">-<head>--<meta charset="utf-8" />-<title>Shake report</title>--<!-- Libraries -->-<script src="jquery.js"></script>-<script src="jquery.flot.js"></script>-<script src="jquery.flot.stack.js"></script>-<script src="viz.js"></script>-<!-- Profiling output -->-<script src="data.js"></script>-<!-- Functions for creating info from Shake builds -->-<script src="shake-util.js"></script>-<script src="shake-logic.js"></script>-<script src="shake-ui.js"></script>--<style type="text/css">-body {font-family: sans-serif;}-body {font-size: 10pt;}-.data {font-size: 9pt; border-spacing: 0px; border-collapse: collapse;}-.data td {padding-left: 7px; padding-right: 7px;}-.header {font-weight: bold; background-color: #eee !important;}-.header td:hover {background-color: #ccc !important;}-.header td {border: 1px solid #ccc; cursor: pointer;}-.data tr:hover {background-color: #ddd !important; color: black !important;}-input, select {border: 1px solid #ccc;}-* {box-sizing: border-box;}-html, body {height: 100%; width:100%;}-#run {font-weight: bold;}-.sort {color: #aaa;}-.shake {font-family: monospace;}-#link:visited {color: rgb(0,0,238);}-ul.space > li {padding-top: 8px; padding-bottom: 8px;}-ul.space {padding-left: 20px;}--.shake {- text-decoration: none;- font-family: monospace;- color: black;-}-</style>--</head>-<body style="margin:0px;padding:0px;">--<table style="width:100%;height:100%;padding:8px;">- <tr><td>- <table width="100%"><tr>- <td>- <button id="run">Run</button>- </td>- <td>- <select id="mode">- <option value="summary">Summary</option>- <option value="help">Help</option>- <option value="cmd-plot">Command plot</option>- <option value="cmd-table">Command table</option>- <option value="rule-table">Rule table</option>- <option value="rule-graph">Rule graph</option>- </select>- </td>- <td width="100%">- <input id="query" style="width:100%;" />- </td>- <td style="padding-left:10px;">- <a title="A link to the currently typed query" id="link" target="_blank" href="">Link</a>- </td>- </tr></table>- </td></tr>- <tr><td>- <hr style="border-top:1px solid #ccc;" />- </td></tr>- <tr style="height:100%;width:100%;"><td>- <div style="height:100%;width:100%;min-width:150px;min-height:150px;overflow:auto;" id="output">Loading...</div>- </td></tr>-</table>--<div id="welcome" style="display:none;">- <p>- <b>New to Shake reports?</b> Select 'Help' from the drop-down box (currently displaying 'Summary') then press 'Run'.- </p>-</div>--<div id="error" style="display:none;">- <h3 style="color:#d00;">Query <span class="name">parse</span> error</h3>- <table>- <tr><td><ul style="margin:0px;"><li>Error message:</li></ul></td><td><code><span class="message">message</span></code></td></tr>- <tr><td><ul style="margin:0px;"><li>User query:</li></ul></td><td><code><span class="query">the query</span></code></td></tr>- </table>- <p>- For information about the query language, see <a class="example" data-mode="help" data-query="">Help</a>.- </p>-</div>--<div id="help" style="display:none;">- <p>- Shake reports provide a way of filtering, grouping and viewing the result of running a Shake build system. A query is entered at the top using the text box, run using the 'Run' button, and produces a report whose type is selected from the drop-down box. The 'Link' hyperlink provides a link to the currently entered query, which is useful for copying/sharing.- </p>- <h3>Report types</h3>- <p>- The drop-down box, currently displaying 'Help', let's you pick the type of report. The best way to learn about the report types is to try them out (all work with the empty query). The types are:- </p>- <ul class="space">- <li><b>Summary:</b> Display summary statistics about the Shake database. The term 'rule' refers to any Shake rule, and there will be one rule for everything that gets built or tracked, including source files. The term 'traced command' refers to any call to <a class="shake">traced</a>, which is automatically inserted by the <a class="shake">command</a> function. The reported parallelism refers to the average number of traced commands executing during the last build - for example, a parallelism of 4.0 when using <a class="shake">shakeThreads</a>=4 would be a perfect speedup. The time spent not executing traced commands includes time when Shake was checking dependencies and any Haskell operations performed by the rules.</li>- <li><b>Help:</b> This help document.</li>- <li><b>Command plot:</b> This plot shows which traced commands were executing at any time. The Y axis is the number of simultaneous traced commands and the X axis is the progress through the last run of the build system that executed any rules. Some useful queries are:- <ul>- <li><a class="example" data-mode="cmd-plot" data-query="">by default</a> - display when each traced command was executing.</li>- <li><a class="example" data-mode="cmd-plot">group("commands")</a> - display a the total parallelism, not grouped by command.</li>- <li><a class="example" data-mode="cmd-plot">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display parallelism grouped by result extension.</li>- </ul>- </li>- <li><b>Command table:</b> This table shows all traced commands. 'name' is the group name, by default the string passed to <a class="shake">trace</a>. 'count' is the number of commands that were grouped together. 'time' is the amount of time spent executing the commands, both in absolute terms and as a percentage of the time required to build everything (including rules which are not traced). Some useful queries are:- <ul>- <li><a class="example" data-mode="cmd-table" data-query="">by default</a> - display all traced commands.</li>- <li><a class="example" data-mode="cmd-table">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display parallelism grouped by result extension.</li>- <li><a class="example" data-mode="cmd-table">group(command() + " - " + name())</a> - the complete list of all commands by rule.</li>- <li><a class="example" data-mode="cmd-table">name(/^(.*)\/[^\/]*/,"root") && group(command())</a> - commands grouped per directory.</li>- <li><a class="example" data-mode="cmd-table">name(slowestRule())</a> - what commands did the slowest rule run.</li>- </ul>- </li>- <li><b>Rule table:</b> This table shows all rules. 'name', 'count' and 'time' are the same as for the command table, with the default name being the rule result. 'cost' is the time to rebuild if all the files changed, where a higher cost is worse. 'leaf' is true if the rule has no dependencies, typically source files. 'runs' is the number of executions since the file was built, where 0 means it was built in the last run. 'unchanged' is true if the last time the rule built it did not change value, and thus rules depending on it did not rebuild. Some useful queries are:- <ul>- <li><a class="example" data-mode="rule-table" data-query="">by default</a> - display all rules.</li>- <li><a class="example" data-mode="rule-table">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display rules grouped by result extension.</li>- <li><a class="example" data-mode="rule-table">ancestorOf(slowestRule()) && leaf() && run() == 0</a> - while leaf nodes changed in the last run to cause a rebuild of a particular rule (replace <code>slowestRule()</code> with <code>"rule name"</code> to use a different rule.</li>- <li><a class="example" data-mode="rule-table">parentOf(slowestRule()) && !unchanged()</a> - what immediate dependency caused a particular rule to rebuild most recently (sort by 'run' to see the answer first).</li>- <li><a class="example" data-mode="rule-table">!name(/\.[a-zA-Z0-9_]+$/)</a> - which rules have no extension.</li>- </ul>- </li>- <li><b>Rule graph:</b> This table shows the rules and their dependencies. An arrow from a child node to a parent node indicates that the child depends on the parent. A solid line is a direct dependency, a dashed line is an indirect dependency, through some hidden intermediate node. Some useful queries are:- <ul>- <li><a class="example" data-mode="rule-graph">name(/(\.[a-zA-Z0-9_]+)$/, "???")</a> - display rules grouped by result extension.</li>- </ul>- </li>- </ul>- <h3>Query language</h3>- <p>- The query language is a Javascript expression which produces <code>true</code> to include the row, and may call <code>group</code> to indicate grouping. You can use the standard Javascript operators (e.g. <code>==</code> and <code>&&</code>). Anything which takes a <code>RegExp</code> can also accept a <code>string</code>, which is then treated as a literal unanchored regular expression. The following functions are available:- </p>- <ul class="space">- <li><code>group(x : string) : true</code> - assign this item the given group. Multiple calls to <code>group</code> result in a space-separated name. The group name can also be set using <code>name</code> or <code>command</code> with captured regular expressions.</li>- <li><code>leaf() : bool</code> - does the rule a leaf, with no dependencies.</li>- <li><code>run() : int</code> - when was the rule last run, with 0 for run in the last tracked build, and higher numbers for run longer ago.</li>- <li><code>unchanged() : bool</code> - last time the rule was build, was the value detected as unchanged.</li>- <li><code>slowestRule() : string</code> - the name of the rule which took longest to build.</li>- <li><code>name() : string</code> - the name of the current rule.</li>- <li><code>name(x : RegExp) : bool</code> - a regular expression to match against the name of the current rule. If the regular expression contains captured patterns, these will be used as the <code>group</code></li>- <li><code>name(x : RegExp, def : string) : true</code> - a regular expression to match against the name of the current rule, including captured patterns for the <code>group</code>. If the regular expression does not match, the function will still return true but <code>def</code> will be used as the group.</li>- <li><code>rename(from : string, to : string) : true</code> - change <code>name</code> so any string <code>from</code> is replaced with <code>to</code>, useful for replacing an object directory (which is uninteresting) with something like $OBJ.</li>- <li><code>rename(from : string) : true</code> - rename using <code>""</code> as the replacement string.</li>- <li><code>command() : string</code> - when matching rules this is the name of the first command the rule executed, or <code>""</code> if the rule ran no commands. When matching commands this is the name of each command in turn.</li>- <li><code>command(x : RegExp) : bool</code> - a regular expression to match against any of the commands, including grouping as per <code>name</code>.</li>- <li><code>command(x : RegExp, def : string) : true</code> - works the same as the <code>name</code> function which takes two arguments.</li>- <li><code>childOf(x : RegExp) : bool</code> - is this rule a direct child of <code>x</code>, the rule for this item calls <a class="shake">need</a>/<a class="shake">apply</a> on <code>x</code>.</li>- <li><code>descendantOf(x : RegExp) : bool</code> - is this rule a descendant of <code>x</code>, a change in <code>x</code> will cause this rule to rebuild (ignoring unchanging rules).</li>- <li><code>parentOf(x : RegExp) : bool</code> - is this rule a direct parent of <code>x</code>, the rule for <code>x</code> calls <a class="shake">need</a>/<a class="shake">apply</a> on this item.</li>- <li><code>ancestorOf(x : RegExp) : bool</code> - is this rule an ancestor of <code>x</code>, a change in this rule will cause <code>x</code> to rebuild (ignoring unchanging rules).</li>- <li><code>textColor(c : color) : true</code> - set the color of this group to the given color, represented as a string - either the name of a color (<code>"red"</code>) or a hex value (<code>"#ff0000</code>). If multiple <code>textColor</code> calls are given in one query, the last one will be used. If multiple different <code>textColor</code> values are given to one group, the group will not be colored.</li>- <li><code>textColor(c : color, b : bool) : true</code> - set the <code>textColor</code> of this group if the second argument is <code>true</code>.</li>- <li><code>backColor(c : color) : true</code> - like <code>textColor</code> but to set the background color.</li>- <li><code>backColor(c : color, b : bool) : true</code> - like <code>textColor</code> but to set the background color.</li>- </ul>-</div>--</body>-</html>
html/shake-logic.js view
@@ -255,7 +255,7 @@ { var x = dat.original[xs[i]]; time += x.execution;- leaf = bools(leaf, x.depends === 0);+ leaf = bools(leaf, x.depends.length === 0); unchanged = bools(unchanged, x.changed !== x.built); run = Math.min(run,x.built); }
+ html/shake-progress.js view
@@ -0,0 +1,41 @@+/*jsl:option explicit*/+"use strict";++// Data+// {name :: String+// ,values :: [Progress]+// }+//+// Progress+// {idealSecs :: Double+// ,idealPerc :: Double+// ,actualSecs :: Double+// ,actualPerc :: Double+// }++$(function(){+ $(".version").html("Generated by <a href='https://github.com/ndmitchell/shake#readme'>Shake " + version + "</a>.");+ $("#output").html("");+ for (var i = 0; i < shake.length; i++)+ {+ var x = shake[i];+ var actual = [];+ var ideal = [];+ // Start at t = 5 seconds, since the early progress jumps a lot+ for (var t = 5; t < x.values.length; t++)+ {+ var y = x.values[t];+ actual.push([y.idealSecs, y.actualSecs]);+ ideal.push([y.idealSecs, y.idealSecs]);+ }+ var ys = [{data:ideal, color:"gray"}, {label:x.name, data:actual, color:"red"}];+ var div = $("<div class='plot'>");+ $("#output").append(div);+ $.plot(div, ys, {+ xaxis: {+ transform: function (v) { return -v; },+ inverseTransform: function (v) { return -v; }+ }+ });+ }+})
html/shake-ui.js view
@@ -204,6 +204,7 @@ for (var i = 0; i < res.length; i++) s += "<li>" + res[i] + "</li>"; s += "</ul>";+ s += "<p class='version'>Generated by <a href='https://github.com/ndmitchell/shake#readme'>Shake " + version + "</a>.</p>"; $("#output").html(s); break;
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: shake-version: 0.13.2+version: 0.13.3 license: BSD3 license-file: LICENSE category: Development@@ -29,20 +29,21 @@ Shake also provides more accurate dependency tracking, including seamless support for generated files, and dependencies on system information (e.g. compiler version).-homepage: https://github.com/ndmitchell/shake+homepage: https://github.com/ndmitchell/shake#readme bug-reports: https://github.com/ndmitchell/shake/issues tested-with: GHC==7.8.2, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 extra-source-files:- Examples/C/constants.c- Examples/C/constants.h- Examples/C/main.c- Examples/MakeTutor/Makefile- Examples/MakeTutor/hellofunc.c- Examples/MakeTutor/hellomake.c- Examples/MakeTutor/hellomake.h- Examples/Tar/list.txt- Examples/Ninja/*.ninja- Examples/Ninja/*.output+ Test/C/constants.c+ Test/C/constants.h+ Test/C/main.c+ Test/MakeTutor/Makefile+ Test/MakeTutor/hellofunc.c+ Test/MakeTutor/hellomake.c+ Test/MakeTutor/hellomake.h+ Test/Tar/list.txt+ Test/Ninja/*.ninja+ Test/Ninja/*.output+ Test/Progress/*.prog Paths.hs CHANGES.txt README.md@@ -64,8 +65,10 @@ html/jquery.flot.stack.js html/jquery.js html/viz.js- html/report.html+ html/profile.html+ html/progress.html html/shake-logic.js+ html/shake-progress.js html/shake-ui.js html/shake-util.js @@ -119,13 +122,15 @@ Development.Shake.ByteString Development.Shake.Core Development.Shake.Database+ Development.Shake.Demo Development.Shake.Derived Development.Shake.Errors Development.Shake.FileInfo Development.Shake.FilePattern+ Development.Shake.Monad Development.Shake.Pool+ Development.Shake.Profile Development.Shake.Progress- Development.Shake.Report Development.Shake.Resource Development.Shake.Rules.Directory Development.Shake.Rules.File@@ -139,10 +144,13 @@ Development.Shake.Types Development.Shake.Value General.Base+ General.Bilist General.Binary+ General.Cleanup+ General.Concurrent General.Intern- General.RAW General.String+ General.Template General.Timing Paths_shake @@ -220,36 +228,38 @@ Development.Ninja.All Development.Ninja.Parse Development.Ninja.Type- Examples.Util- Examples.C.Main- Examples.Ninja.Main- Examples.Self.Main- Examples.Tar.Main- Examples.Test.Assume- Examples.Test.Basic- Examples.Test.Benchmark- Examples.Test.Cache- Examples.Test.Command- Examples.Test.Config- Examples.Test.Digest- Examples.Test.Directory- Examples.Test.Docs- Examples.Test.Errors- Examples.Test.FilePath- Examples.Test.FilePattern- Examples.Test.Files- Examples.Test.Journal- Examples.Test.Lint- Examples.Test.Makefile- Examples.Test.Manual- Examples.Test.Oracle- Examples.Test.OrderOnly- Examples.Test.Pool- Examples.Test.Progress- Examples.Test.Random- Examples.Test.Resources- Examples.Test.Throttle- Examples.Test.Unicode- Examples.Test.Util- Examples.Test.Verbosity Start+ Test.Type+ Test.Assume+ Test.Basic+ Test.Benchmark+ Test.C+ Test.Cache+ Test.Command+ Test.Config+ Test.Digest+ Test.Directory+ Test.Docs+ Test.Errors+ Test.FilePath+ Test.FilePattern+ Test.Files+ Test.Journal+ Test.Lint+ Test.Live+ Test.Makefile+ Test.Manual+ Test.Monad+ Test.Ninja+ Test.Oracle+ Test.OrderOnly+ Test.Pool+ Test.Progress+ Test.Random+ Test.Resources+ Test.Self+ Test.Tar+ Test.Throttle+ Test.Unicode+ Test.Util+ Test.Verbosity