shake 0.10.8 → 0.10.9
raw patch · 58 files changed
+2232/−1373 lines, 58 filesdep +QuickCheck
Dependencies added: QuickCheck
Files
- CHANGES.txt +288/−0
- Development/Make/All.hs +1/−1
- Development/Make/Rules.hs +1/−1
- Development/Ninja/All.hs +60/−30
- Development/Ninja/Parse.hs +3/−12
- Development/Shake.hs +20/−9
- Development/Shake/Args.hs +8/−4
- Development/Shake/Binary.hs +0/−25
- Development/Shake/ByteString.hs +66/−0
- Development/Shake/Command.hs +68/−11
- Development/Shake/Core.hs +24/−12
- Development/Shake/Database.hs +5/−4
- Development/Shake/Derived.hs +9/−5
- Development/Shake/Directory.hs +0/−270
- Development/Shake/File.hs +0/−235
- Development/Shake/FilePath.hs +39/−14
- Development/Shake/FilePattern.hs +1/−1
- Development/Shake/FileTime.hs +1/−1
- Development/Shake/Files.hs +0/−118
- Development/Shake/Intern.hs +0/−48
- Development/Shake/Oracle.hs +0/−118
- Development/Shake/Pool.hs +2/−2
- Development/Shake/Rerun.hs +0/−37
- Development/Shake/Resource.hs +1/−1
- Development/Shake/Rules/Directory.hs +273/−0
- Development/Shake/Rules/File.hs +280/−0
- Development/Shake/Rules/Files.hs +121/−0
- Development/Shake/Rules/Oracle.hs +118/−0
- Development/Shake/Rules/OrderOnly.hs +55/−0
- Development/Shake/Rules/Rerun.hs +37/−0
- Development/Shake/Shake.hs +6/−4
- Development/Shake/Storage.hs +54/−41
- Development/Shake/Sys.hs +1/−1
- Development/Shake/Timing.hs +0/−58
- Development/Shake/Types.hs +13/−8
- Development/Shake/Util.hs +24/−199
- Development/Shake/Value.hs +2/−2
- Examples/Ninja/Main.hs +7/−1
- Examples/Ninja/lint.ninja +13/−0
- Examples/Test/Command.hs +2/−10
- Examples/Test/Docs.hs +14/−1
- Examples/Test/Errors.hs +1/−8
- Examples/Test/FilePath.hs +64/−6
- Examples/Test/Lint.hs +16/−9
- Examples/Test/Oracle.hs +1/−9
- Examples/Test/OrderOnly.hs +41/−0
- Examples/Test/Throttle.hs +1/−1
- Examples/Test/Unicode.hs +16/−10
- Examples/Test/Util.hs +18/−0
- Examples/Test/Verbosity.hs +39/−0
- Examples/Util.hs +10/−12
- General/Base.hs +241/−0
- General/Binary.hs +25/−0
- General/Intern.hs +48/−0
- General/Timing.hs +58/−0
- Start.hs +1/−1
- Test.hs +8/−5
- shake.cabal +27/−28
+ CHANGES.txt view
@@ -0,0 +1,288 @@+Changelog for Shake++0.10.9+ #76, add Ninja specific lint checking+ #75, add orderOnly dependencies+ #76, add needed, to assert a need doesn't rebuild+ #78, don't use cabal in the test suite+ #77, add shakeRunCommands and --skip-commands+ #67, add withVerbosity+ #51, add getShakeOptions+ Lots of Haddock improvements+ Deprecate system', use cmd or command instead+ #53, add addPath and addEnv to modify environment variables+ Make all search path things return the native separators+ #73, if Haskell can't write a unicode filename, skip the test+ Print out the entire database in diagnostics mode+ Rewrite database writes, old code could break metadata on error+ #25, optimise building with Ninja+ Fix many bugs in FilePath.normalise+ Require QuickCheck-2.0 or higher+ Change how the makefile parser treats \ characters+ Add a --no-build flag+ #74, allow cmd to be used with result IO+ Add a Util module, with Makefile parsing+0.10.8+ Allow unix-1.5.1 again+ Require Cabal 1.10 or above+ Convert to the cabal test compatible test suite+0.10.7+ Support time-1.2+ #71, fix a bug when requesting all three outputs from command+ #64, add progressProgram and use it in progressSimple+ Remove isRunning, kill the progress thread on completion+ #47, improve the performance of ?==, especially on "//*"+ #68, improve the docs for addOracle+ #55, ensure if you need phony targets you rebuild every time+ #52, ensure all command output is printed+ #20, document preferred compilation flags+ #20, speed up the Shake executable with GHC RTS flags+ #39, print out more of the version string on database change+ #41, require unix-2.6 or above+ #48, make it clear filetimes are hashes+ #43, improve the error messages on lint failures+ #45, avoid use of nub+ #45, avoid use of intersect which is O(n^2)+ #26, add newThrottle to create throttling resources+ #26, add unsafeExtraThread to run more than shakeThreads+ #32, add a check that withResources does not call need+ #614, support unicode filenames+ Require unordered-containers-0.2.1 or above+ Reduce stack usage when lint checking+ #24, create the output directories for the multiple file rule+ Improvements to match Ninja behaviour+0.10.6+ Include command/cmd in the default module+ #16, change the scoping in subninja+ #15, fix up the Ninja default targets+ Fix up --version output+0.10.5+ Improve progress prediction for the first build+ Fix removeFiles when there is a directory argument and a pattern+ Delete shakeDeterministic, shakeThreads=1 has the same effect+0.10.4+ Fix writeFileChanged for line endings on Windows+ Support arguments to --progress+ Set the number of capabilities based on -j flags+ Add shakeTimings, to time the separate stages+ Add AssumeSkip, mostly for benchmarking+ Normalise file arguments before calling want+ Expose ShakeException+ Add isFailure to ShakeProgress, and display in progressDisplay+ Add withResources+ Add -<.> alias for replaceExtension+ Add selectors on Stdout/Stdin/Exit+ Add CmdResult instance for ExitCode+0.10.3+ Upgrade to Flot-0.8+ Small documentation markup fixes+0.10.2+ Require process-1.1 or above+ Improve progress guesses (use exponential decay of work rate)+ Improve profiling report error messages+ Add a Command module, with alternatives to system' etc.+ #593, don't assume doesDirectoryExist = not . doesFileExist+ #594, swap how traced messages are printed out+ Add Chatty verbosity, for what was Loud+ Make repeated --verbose keep increasing the verbosity+ If shakeThreads==1 then always use a deterministic pool+ Add shakeLineBuffering, defaulting to True+ Improve the performance of profiling+ Documentation and corrections improvements+ Eliminate StepKey from the profiling output+ Add a --no-time flag+ Makefile improvements+ Avoid use of ghc-options in .cabal file+0.10.1+ Allow the shake executable to build+0.10+ Add phony, for writing phony actions+ Add removeFilesAfter+ Switch to the new profiling code+ Add actionOnException and actionFinally+ Add shakeArgsWith+ Rename shakeWithArgs to shakeArgs and change the clean argument+ Remove the -f alias for --flush+ Add a shake executable which runs Makefiles+ Rename shake to shake-test+ Change how progress messages are written+ Do not write a beep in progressDisplay, avoids a beep+ Add exe function to FilePath+0.9.1+ GHC head (7.7) compatibility by removing the Rules fundep+0.9+ Make the tests work on Linux+ Fix report generation on machines whose text format is not ASCII+ Make Directory functions work the same on Linux/Mac+ Change shakeVersion to be a String+ Stop alwaysRerun causing lint failures+ Make shakeLint check that the current directory does not change+ Add shakeOutput setting+ Add removeFiles function+ Add Sys module for writing consise system calls+ Add getEnv function+ Add shakeWithArgs and shakeOptDescrs+ Add newCache to cache the parsed contents of files+ Add newResourceIO and move newResource into the Rules monad+ Add shakeStorageLog, to help diagnosing obscure database errors+0.8+ Improve the Oracle documentation+ Allow getDirectoryFiles to operate recursively+0.7+ Change getDirectoryFiles to take a set of file patterns+ Add doesDirectoryExist function+ Add shakeAbbreviations feature+ Add a new Progress module for sensible progress messages+ Spawn shakeProgress on a separate thread, a safer default+ Improve the runtime error messages+ Add a quietly function, to hide traced commands+ Print main status messages when running a traced command+ Display the exit code when a system command fails+ Fix AssumeClean when the result exists but has never been built+ IMPORTANT: Incompatible on disk format change+ Change the storage to not write messages on --silent+ Add Applicative on Rules+ Add Applicative on Action+0.6+ Make addOracle return a result of askOracle+ Export the class bodies from Classes+ Don't export ShakeValue from Classes+0.5+ IMPORTANT: Incompatible on disk format change+ Add the ShakeValue constraint synonym+ Change the Oracle to be strongly typed+ Add a Classes module+0.4+ Add shakeFlush to control how often flush is called+ Fix a serious space leak in the thread pool+ #502, add shakeAssume to assume files are clean/dirty+ Remove validStored, replace with storedValue+ Remove the default validStored class, almost never right+ Remove Eq/Ord from ShakeOptions (now contains a func)+ #501, add statistics gathering functions to help report progress+ Ensure registering witnesses is thread safe+ Ensure GHC does not over-optimise type registration+0.3.10+ Add Paths.hs so you can run the tests from the tarball+0.3.9+ Don't rely on toList returning a consistent order+ Allow hashable-1.2+0.3.8+ Fix up FilePattern so "foo//bar" ?== "foo/bar"+0.3.7+ Update the cabal file+0.3.6+ Add addOracles, for implementing more advanced oracles+ Add withoutActions, for implementing command line arguments+0.3.5+ #571, vastly improve the correctness of FilePattern+ #574, documentation typos+ Expose rulePriority+0.3.4+ Update documentation with links to ICFP 2012 paper/talk+0.3.3+ Minor refactorings+0.3.2+ Fix cabal specification on non-Windows+0.3.1+ Don't use syntax also stolen by QuasiQuotes+ Avoid warnings about unused monadic values+ Fix up getModificationTime for GHC 7.6+ Don't assume catch is exported by Prelude (GHC 7.6 compat)+ Improve the error message when failing to build with *>> or ?>>+ Introduce a portable flag, to switch to portable FileTime ops+ Improve the error message when failing to build a file+ Ensure errors raised bubble up quickly+ Significant improvements to the profile output+ Only trace the program name by default, not the entire command+ Allow unordered-containers < 0.2 again+ Intern all keys, so they are only stored once+ Optimise modification time checking on Unix+ Optimise modification time checking on Windows+ Make some fields smaller on disk+ IMPORTANT: Incompatible on disk format change+ Switch to ByteString for storing File+ Add shakeDeterministic, along with a default random pool+ Make the Monad/Monoid instance for Rules strict+0.3+ #550, ensure the journal thread is locked+ #550, if your thread dies while reading the database then die+ #550, ensure you reset to before the slop before writing+ If the witness table is completely corrupt give a better error+ Make storage work with exceptions whose messages raise errors+ Journal error conditions, to ensure they don't repeat+ Better messages on invalid database versions+ Complete rewrite of the storage layer and journal design+ IMPORTANT: Incompatible on disk format change+0.2.11+ IMPORTANT: #546, don't save the database to where it was created+0.2.10+ Add systemCwd for running with a particular current directory+ Ensure the database is saved to where it was created+ #545, make sure if shake is killed, it kills its children+0.2.9+ Require unordered-containers 2.1 or higher, fixes bugs+ Allow transformers-0.3.*+ Add a random script generator and tester+ Improve the documentation for withResource+ Fix the unordered-containers constraint, was too loose+ Don't write report generation messages in Quiet mode+ Add ?>> operator, a generalisation of *>>+0.2.8+ Rename shakeDump to shakeReport+ Add profile report generator+0.2.7+ #530, require unordered-containers >= 0.1.4.3+0.2.6+ Improve the documentation code fragments (more links)+ Add support for managing finite resources+0.2.5+ Require hashable-1.1.2.3, which has a TypeRep instance+ Add Data/Typeable instances for ShakeOptions+ Add Data instance for Verbosity+0.2.4+ Include the C example source files+ Significant documentation improvements+0.2.3+ Create the shakeFiles directory if missing+0.2.2+ Allow deepseq-1.3.*+ Add a basic lint checking mode+ Remove the Dirty state entirely (was incorrect)+0.2.1+ Put diagnostics in more places+ Add a C example+0.2+ Add shakeStaunch+ Rename shakeParallel to shakeThreads+ Delete the lint support (never actually worked)+ Completely rewrite the central build algorithm+ Add verbosity Diagnostic+ Improve FilePath.normalise+ Add writeFileChanged+ Add systemOutput+ Add an Oracle module+ Add an explicit Verbosity type+ Change to lower precedence for *> etc+0.1.5+ Allow deepseq-1.2+0.1.4+ Don't export currentRule/currentStack+ Fix **>, was matching the wrong way round+ Fix FilePath normalise so it works properly on Windows+ Properly detect recursive rules, instead of looping+ Add *>> for building multiple files at once+0.1.3+ Fix a bug where a file rule could return with a lazy error+ Make sure all the files are stored in binary, not text+ Fix a pattern match error in getDirectoryFiles+0.1.2+ Add a warning in the description+0.1.1+ Significantly improved documentation+ system' now takes an initial argument for the program+0.1+ Many changes to signatures, some basic documentation+ Additional demo, to build shake itself+0.0+ Initial version, not ready for public use
Development/Make/All.hs view
@@ -3,7 +3,7 @@ module Development.Make.All(runMakefile) where import System.Environment -import Development.Shake +import Development.Shake hiding (addEnv) import Development.Shake.FilePath import Development.Make.Parse import Development.Make.Env
Development/Make/Rules.hs view
@@ -11,7 +11,7 @@ import System.Directory import Development.Shake.Core-import Development.Shake.Util+import General.Base import Development.Shake.Classes import Development.Shake.FilePath import Development.Shake.FileTime
Development/Ninja/All.hs view
@@ -5,13 +5,17 @@ import Development.Ninja.Env import Development.Ninja.Type import Development.Ninja.Parse -import Development.Shake hiding (Rule) -import Development.Shake.FilePath -import Development.Shake.Timing +import Development.Shake hiding (Rule, addEnv) +import Development.Shake.ByteString +import Development.Shake.Errors +import Development.Shake.Rules.File +import Development.Shake.Rules.OrderOnly +import General.Timing import qualified Data.ByteString.Char8 as BS import System.Directory import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import Control.Arrow import Control.Monad import Data.List @@ -23,28 +27,24 @@ addTiming "Ninja parse" ninja@Ninja{..} <- parse file return $ do + needDeps <- return $ needDeps ninja -- partial application phonys <- return $ Map.fromList phonys - singles <- return $ Map.fromList $ map (first norm) singles - multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map norm) multiples, x <- xs] + singles <- return $ Map.fromList $ map (first normalise) singles + multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map normalise) multiples, x <- xs] rules <- return $ Map.fromList rules pools <- fmap Map.fromList $ forM pools $ \(name,depth) -> fmap ((,) name) $ newResource (BS.unpack name) depth - want $ map (normalise . BS.unpack) $ concatMap (resolvePhony phonys) $ + want $ map (BS.unpack . normalise) $ 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 (\x -> fmap (map BS.unpack . fst) $ Map.lookup (BS.pack x) multiples) ?>> \out -> let out2 = map BS.pack out in - build phonys rules pools out2 $ snd $ multiples Map.! head out2 + build needDeps phonys rules pools out2 $ snd $ multiples Map.! head out2 (flip Map.member singles . BS.pack) ?> \out -> let out2 = BS.pack out in - build phonys rules pools [out2] $ singles Map.! out2 - - --- Normalise the LHS of build rules, so that normalised RHS still match -norm :: Str -> Str -norm = BS.pack . normalise . BS.unpack + build needDeps phonys rules pools [out2] $ singles Map.! out2 resolvePhony :: Map.HashMap Str [Str] -> Str -> [Str] @@ -62,9 +62,10 @@ | otherwise = x -build :: Map.HashMap Str [Str] -> Map.HashMap Str Rule -> Map.HashMap Str Resource -> [Str] -> Build -> Action () -build phonys rules pools out Build{..} = do - need $ map (normalise . BS.unpack) $ concatMap (resolvePhony phonys) $ depsNormal ++ depsImplicit ++ depsOrderOnly +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 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 @@ -92,16 +93,56 @@ when (description /= "") $ putNormal description if deps == "msvc" then do Stdout stdout <- withPool $ command [Shell, EchoStdout True] commandline [] - need $ map normalise $ parseShowIncludes stdout + needDeps build $ map (normalise . BS.pack) $ parseShowIncludes stdout else withPool $ command_ [Shell] commandline [] when (depfile /= "") $ do when (deps /= "gcc") $ need [depfile] - depsrc <- liftIO $ readFile depfile - need $ map normalise $ concatMap snd $ parseMakefile depsrc + depsrc <- liftIO $ BS.readFile depfile + needDeps build $ concatMap snd $ parseMakefile depsrc when (deps == "gcc") $ liftIO $ removeFile depfile +needDeps :: Ninja -> Build -> [Str] -> Action () +needDeps Ninja{..} = \build xs -> do -- eta reduced so 'builds' is shared + opts <- getShakeOptions + if not $ shakeLint opts then needBS xs else do + neededBS xs + -- now try and statically validate needed will never fail + -- first find which dependencies are generated files + xs <- return $ filter (`Map.member` builds) xs + -- now try and find them as dependencies + let bad = xs `difference` allDependencies build + case bad of + [] -> return () + x:_ -> errorStructured + "Lint checking error - file in deps is generated and not a pre-dependency" + [("File", Just $ BS.unpack x)] + "" + where + builds :: Map.HashMap FileStr Build + builds = Map.fromList $ singles ++ [(x,y) | (xs,y) <- multiples, x <- xs] + + -- do list difference, assuming a small initial set, most of which occurs early in the list + difference :: [Str] -> [Str] -> [Str] + difference [] ys = [] + difference xs ys = f (Set.fromList xs) ys + where + f xs [] = Set.toList xs + f xs (y:ys) | y `Set.member` xs = if Set.null xs2 then [] else f xs2 ys + where xs2 = Set.delete y xs + f xs (y:ys) = f xs ys + + -- find all dependencies of a rule, no duplicates, with all dependencies of this rule listed first + allDependencies :: Build -> [FileStr] + allDependencies rule = f Set.empty [] [rule] + where + f seen [] [] = [] + f seen [] (x:xs) = f seen (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 ((builds Map.! x) : rest) + + applyRspfile :: Env Str Str -> Action a -> Action a applyRspfile env act = do rspfile <- liftIO $ fmap BS.unpack $ askVar env $ BS.pack "rspfile" @@ -124,14 +165,3 @@ isSystemInclude :: String -> Bool isSystemInclude x = "program files" `isInfixOf` lx || "microsoft visual studio" `isInfixOf` lx where lx = map toLower x - - -parseMakefile :: String -> [(FilePath, [FilePath])] -parseMakefile = concatMap f . join . lines - where - join (x1:x2:xs) | "\\" `isSuffixOf` x1 = join $ (init x1 ++ x2) : xs - join (x:xs) = x : join xs - join [] = [] - - f x = [(a, words $ drop 1 b) | a <- words a] - where (a,b) = break (== ':') $ takeWhile (/= '#') x
Development/Ninja/Parse.hs view
@@ -4,6 +4,7 @@ module Development.Ninja.Parse(parse) where import qualified Data.ByteString.Char8 as BS +import Development.Shake.ByteString import Development.Ninja.Env import Development.Ninja.Type import Control.Monad @@ -12,23 +13,13 @@ endsDollar :: Str -> Bool -endsDollar = BS.isSuffixOf (BS.pack "$") +endsDollar = BS.isSuffixOf (BS.singleton '$') dropSpace :: Str -> Str dropSpace = BS.dropWhile isSpace startsSpace :: Str -> Bool -startsSpace = BS.isPrefixOf (BS.pack " ") - --- | This is a hot-spot, so optimised -linesCR :: Str -> [Str] -linesCR x = case BS.split '\n' x of - x:xs | Just ('\r',x) <- unsnoc x -> x : map (\x -> case unsnoc x of Just ('\r',x) -> x; _ -> x) xs - xs -> xs - where - -- the ByteString unsnoc was introduced in a newer version - unsnoc x | BS.null x = Nothing - | otherwise = Just (BS.last x, BS.init x) +startsSpace = BS.isPrefixOf (BS.singleton ' ')
Development/Shake.hs view
@@ -28,7 +28,15 @@ -- Finally we call the @tar@ program. If either @result.txt@ changes, or any of the files listed by @result.txt@ -- change, then @result.tar@ will be rebuilt. ----- The theory behind Shake is described in an ICFP 2012 paper, Shake Before Building -- Replacing Make with Haskell+-- To find out more:+--+-- * The user manual contains a longer example and background information on how to use Shake+-- <https://github.com/ndmitchell/shake/blob/master/docs/Manual.md#readme>.+--+-- * The home page has links to additional information <https://github.com/ndmitchell/shake#readme>, including+-- a mailing list.+--+-- * The theory behind Shake is described in an ICFP 2012 paper, /Shake Before Building -- Replacing Make with Haskell/ -- <http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf>. The associated talk -- forms a short overview of Shake <http://www.youtube.com/watch?v=xYCPpXVlqFM>. --@@ -92,23 +100,25 @@ liftIO, actionOnException, actionFinally, ShakeException(..), -- * Configuration- ShakeOptions(..), Assume(..),+ ShakeOptions(..), Assume(..), getShakeOptions, -- ** Command line shakeArgs, shakeArgsWith, shakeOptDescrs, -- ** Progress reporting Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram, -- ** Verbosity- Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, quietly,+ Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly, -- * Running commands command, command_, cmd, Stdout(..), Stderr(..), Exit(..), CmdResult, CmdOption(..),+ addPath, addEnv, -- * Utility functions module Development.Shake.Derived, removeFiles, removeFilesAfter, -- * File rules need, want, (*>), (**>), (?>), phony, (~>),- module Development.Shake.Files,+ module Development.Shake.Rules.Files,+ orderOnly, needed, FilePattern, (?==), -- * Directory rules doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs,@@ -139,9 +149,10 @@ import Development.Shake.Shake import Development.Shake.Command-import Development.Shake.Directory-import Development.Shake.File+import Development.Shake.Rules.Directory+import Development.Shake.Rules.File import Development.Shake.FilePattern-import Development.Shake.Files-import Development.Shake.Oracle-import Development.Shake.Rerun+import Development.Shake.Rules.Files+import Development.Shake.Rules.Oracle+import Development.Shake.Rules.OrderOnly+import Development.Shake.Rules.Rerun
Development/Shake/Args.hs view
@@ -5,11 +5,11 @@ import Paths_shake import Development.Shake.Types import Development.Shake.Core-import Development.Shake.File+import Development.Shake.Rules.File import Development.Shake.FilePath import Development.Shake.Progress import Development.Shake.Shake-import Development.Shake.Timing+import General.Timing import Control.Arrow import Control.Concurrent@@ -142,7 +142,8 @@ case rules of Nothing -> return (False,Right ()) Just rules -> do- res <- try $ shake shakeOpts rules+ res <- try $ shake shakeOpts $+ if NoBuild `elem` flagsExtra then withoutActions rules else rules return (True, res) if not ran || shakeVerbosity shakeOpts < Normal || NoTime `elem` flagsExtra then@@ -209,6 +210,7 @@ | Sleep | NoTime | Exception+ | NoBuild deriving Eq @@ -226,6 +228,7 @@ shakeOptsEx = [yes $ Option "a" ["abbrev"] (pairArg "abbrev" "FULL=SHORT" $ \a s -> s{shakeAbbreviations=shakeAbbreviations s ++ [a]}) "Use abbreviation in status messages." ,yes $ Option "B" ["always-make"] (noArg $ \s -> s{shakeAssume=Just AssumeDirty}) "Unconditionally make all targets."+ ,no $ Option "" ["no-build"] (NoArg $ Right ([NoBuild], id)) "Don't build anything." ,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."@@ -241,6 +244,7 @@ ,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=Just $ fromMaybe "report.html" x})) "FILE") "Write out profiling information [to report.html]." ,yes $ Option "" ["no-report"] (noArg $ \s -> s{shakeReport=Nothing}) "Turn off --report." ,yes $ Option "" ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."@@ -249,7 +253,7 @@ ,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k." ,yes $ Option "" ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log." ,yes $ Option "p" ["progress"] (optIntArg "progress" "N" (\i s -> s{shakeProgress=prog $ fromMaybe 5 i})) "Show progress messages [every N seconds, default 5]."- ,yes $ Option " " ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."+ ,yes $ Option "" ["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." ,yes $ Option "" ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."
− Development/Shake/Binary.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}--module Development.Shake.Binary(- BinaryWith(..), module Data.Binary- ) where--import Control.Monad-import Data.Binary--class BinaryWith ctx a where- putWith :: ctx -> a -> Put- getWith :: ctx -> Get a--instance (BinaryWith ctx a, BinaryWith ctx b) => BinaryWith ctx (a,b) where- putWith ctx (a,b) = putWith ctx a >> putWith ctx b- getWith ctx = do a <- getWith ctx; b <- getWith ctx; return (a,b)--instance BinaryWith ctx a => BinaryWith ctx [a] where- putWith ctx xs = put (length xs) >> mapM_ (putWith ctx) xs- getWith ctx = do n <- get; replicateM n $ getWith ctx--instance BinaryWith ctx a => BinaryWith ctx (Maybe a) where- putWith ctx Nothing = putWord8 0- putWith ctx (Just x) = putWord8 1 >> putWith ctx x- getWith ctx = do i <- getWord8; if i == 0 then return Nothing else fmap Just $ getWith ctx
+ Development/Shake/ByteString.hs view
@@ -0,0 +1,66 @@++module Development.Shake.ByteString(parseMakefile, normalise, linesCR) where++import qualified Data.ByteString.Char8 as BS+import qualified System.FilePath as Native+import General.Base+import Data.List+++endsSlash :: BS.ByteString -> Bool+endsSlash = BS.isSuffixOf (BS.singleton '\\')+++parseMakefile :: BS.ByteString -> [(BS.ByteString, [BS.ByteString])]+parseMakefile = concatMap f . join . linesCR+ where+ join xs = case span endsSlash xs of+ ([], []) -> []+ (xs, []) -> [BS.unwords $ map BS.init xs]+ ([], 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]+ where (a,b) = BS.break (== ':') $ BS.takeWhile (/= '#') x+++-- | This is a hot-spot, so optimised+linesCR :: BS.ByteString -> [BS.ByteString]+linesCR x = case BS.split '\n' x of+ x:xs | Just ('\r',x) <- unsnoc x -> x : map (\x -> case unsnoc x of Just ('\r',x) -> x; _ -> x) xs+ xs -> xs+ where+ -- the ByteString unsnoc was introduced in a newer version+ unsnoc x | BS.null x = Nothing+ | otherwise = Just (BS.last x, BS.init x)+++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+ where+ sep = Native.isPathSeparator+ f o = deslash o $ BS.concat $ (slash:) $ intersperse slash $ reverse $ (BS.empty:) $ g 0 $ reverse $ split $ o++ deslash o x+ | x == slash = case (pre,pos) of+ (True,True) -> slash+ (True,False) -> BS.pack "/."+ (False,True) -> BS.pack "./"+ (False,False) -> dot+ | otherwise = (if pre then id else BS.tail) $ (if pos then id else BS.init) x+ where pre = not (BS.null o) && sep (BS.head o)+ pos = not (BS.null o) && sep (BS.last o)++ g i [] = replicate i dotDot+ g i (x:xs) | BS.null x = g i xs+ g i (x:xs) | x == dotDot = g (i+1) xs+ g i (x:xs) | x == dot = g i xs+ g 0 (x:xs) = x : g 0 xs+ g i (x:xs) = g (i-1) xs++ split xs = BS.splitWith sep xs++dotDot = BS.pack ".."+dot = BS.singleton '.'+slash = BS.singleton '/'
Development/Shake/Command.hs view
@@ -6,6 +6,7 @@ command, command_, cmd, Stdout(..), Stderr(..), Exit(..), CmdResult, CmdOption(..),+ addPath, addEnv, ) where import Control.Arrow@@ -14,8 +15,11 @@ import Control.Exception as C import Control.Monad import Control.Monad.IO.Class+import Data.Char import Data.Either+import Data.List import Foreign.C.Error+import System.Environment import System.Exit import System.IO import System.Process@@ -23,6 +27,7 @@ import Development.Shake.Core import Development.Shake.FilePath import Development.Shake.Types+import General.Base import GHC.IO.Exception (IOErrorType(..), IOException(..)) @@ -34,6 +39,7 @@ data CmdOption = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory. | Env [(String,String)] -- ^ Change the environment variables in the spawned process. By default uses this processes environment.+ -- Use 'addPath' to modify the @$PATH@ variable, or 'addEnv' to modify other variables. | Stdin String -- ^ Given as the @stdin@ of the spawned process. By default no @stdin@ is given. | Shell -- ^ Pass the command to the shell without escaping - any arguments will be joined with spaces. By default arguments are escaped properly. | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default streams use text encoding.@@ -43,6 +49,42 @@ | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required. deriving (Eq,Ord,Show) ++-- | Produce a 'CmdOption' of value 'Env' that is the current environment, plus a+-- prefix and suffix to the @$PATH@ environment variable. For example:+--+-- @+-- opt <- 'addPath' [\"\/usr\/special\"] []+-- 'cmd' opt \"userbinary --version\"+-- @+--+-- Would prepend @\/usr\/special@ to the current @$PATH@, and the command would pick+-- @\/usr\/special\/userbinary@, if it exists. To add other variables see 'addEnv'.+addPath :: MonadIO m => [String] -> [String] -> m CmdOption+addPath pre post = do+ args <- liftIO getEnvironment+ let (path,other) = partition ((== "PATH") . (if isWindows then map toUpper else id) . fst) args+ return $ Env $+ [("PATH",intercalate [searchPathSeparator] $ pre ++ post) | null post] +++ [(a,intercalate [searchPathSeparator] $ pre ++ [b | b /= ""] ++ post) | (a,b) <- path] +++ other++-- | Produce a 'CmdOption' of value 'Env' that is the current environment, plus the argument+-- environment variables. For example:+--+-- @+-- opt <- 'addEnv' [(\"CFLAGS\",\"-O2\")]+-- 'cmd' opt \"gcc -c main.c\"+-- @+--+-- Would add the environment variable @$CFLAGS@ with value @-O2@. If the variable @$CFLAGS@+-- was already defined it would be overwritten. If you wish to modify @$PATH@ see 'addPath'.+addEnv :: MonadIO m => [(String, String)] -> m CmdOption+addEnv extra = do+ args <- liftIO getEnvironment+ return $ Env $ extra ++ filter (\(a,b) -> a `notElem` map fst extra) args++ data Result = ResultStdout String | ResultStderr String@@ -51,7 +93,23 @@ commandExplicit :: String -> [CmdOption] -> [Result] -> String -> [String] -> Action [Result]-commandExplicit funcName opts results exe args = verboser $ tracer $+commandExplicit funcName opts results exe args = skipper $ verboser $ tracer $ commandExplicitIO funcName opts results exe args+ where+ skipper act = do+ o <- getShakeOptions+ if null results && not (shakeRunCommands o) then return [] else act+ verboser act = do+ v <- getVerbosity+ putLoud $ saneCommandForUser exe args+ (if v >= Loud then quietly else id) act+ tracer = case reverse [x | Traced x <- opts] of+ "":_ -> liftIO+ msg:_ -> traced msg+ [] -> traced (takeFileName exe)+++commandExplicitIO :: String -> [CmdOption] -> [Result] -> String -> [String] -> IO [Result]+commandExplicitIO funcName opts results exe args = -- BEGIN COPIED -- Originally from readProcessWithExitCode with as few changes as possible mask $ \restore -> do@@ -140,14 +198,6 @@ ResultCode _ -> ResultCode ex where input = last $ "" : [x | Stdin x <- opts]- verboser act = do- v <- getVerbosity- putLoud $ saneCommandForUser exe args- (if v >= Loud then quietly else id) act- tracer = case reverse [x | Traced x <- opts] of- "":_ -> liftIO- msg:_ -> traced msg- [] -> traced (takeFileName exe) -- what should I do with these handles binary = BinaryPipes `elem` opts@@ -235,7 +285,7 @@ -- | Execute a system command. Before running 'command' make sure you 'Development.Shake.need' any files--- that are required by the command.+-- that are used by the command. -- -- This function takes a list of options (often just @[]@, see 'CmdOption' for the available -- options), the name of the executable (either a full name, or a program on the @$PATH@) and@@ -272,7 +322,8 @@ type a :-> t = a --- | A variable arity version of 'command'.+-- | Execute a system command. Before running 'cmd' make sure you 'Development.Shake.need' any files+-- that are used by the command. -- -- * @String@ arguments are treated as whitespace separated arguments. --@@ -294,6 +345,8 @@ -- -- If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being -- unable to deduce 'CmdResult'. To avoid this error, bind the result to @()@, or include a type signature.+--+-- The 'cmd' command can also be run in the 'IO' monad, but then 'Traced' is ignored and command lines are not echoed. cmd :: CmdArguments args => args :-> Action r cmd = cmdArguments [] @@ -303,6 +356,10 @@ instance CmdResult r => CmdArguments (Action r) where cmdArguments x = case partitionEithers x of (opts, x:xs) -> let (a,b) = cmdResult in fmap b $ commandExplicit "cmd" opts a x xs+ _ -> error "Error, no executable or arguments given to Development.Shake.cmd"+instance CmdResult r => CmdArguments (IO r) where+ cmdArguments x = case partitionEithers x of+ (opts, x:xs) -> let (a,b) = cmdResult in fmap b $ commandExplicitIO "cmd" opts a x xs _ -> error "Error, no executable or arguments given to Development.Shake.cmd" class Arg a where arg :: a -> [Either CmdOption String]
Development/Shake/Core.hs view
@@ -12,8 +12,8 @@ ShakeValue, #endif Rule(..), Rules, defaultRule, rule, action, withoutActions,- Action, actionOnException, actionFinally, apply, apply1, traced,- getVerbosity, putLoud, putNormal, putQuiet, quietly,+ Action, actionOnException, actionFinally, apply, apply1, traced, getShakeOptions,+ getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly, Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO, unsafeExtraThread, -- Internal stuff@@ -45,8 +45,8 @@ import Development.Shake.Report import Development.Shake.Types import Development.Shake.Errors-import Development.Shake.Timing-import Development.Shake.Util+import General.Timing+import General.Base ---------------------------------------------------------------------@@ -190,7 +190,7 @@ -- -- This 'action' builds @file.out@, but only if @file.src@ exists. The 'action' -- will be run in every build execution (unless 'withoutActions' is used), so only cheap--- operations should be performed.+-- operations should be performed. All arguments to 'action' may be run in parallel, in any order. -- -- For the standard requirement of only 'Development.Shake.need'ing a fixed list of files in the 'action', -- see 'Development.Shake.want'.@@ -220,13 +220,14 @@ ,timestamp :: IO Time ,ruleinfo :: Map.HashMap TypeRep RuleInfo ,output :: Verbosity -> String -> IO ()- ,verbosity :: Verbosity+ ,opts :: ShakeOptions ,diagnostic :: String -> IO () ,lint :: String -> IO () ,after :: IORef [IO ()] -- stack variables ,stack :: Stack -- local variables+ ,verbosity :: Verbosity ,depends :: [Depends] -- built up in reverse ,discount :: !Duration ,traces :: [Trace] -- in reverse@@ -234,7 +235,7 @@ } -- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files.--- Action values are used by 'rule' and 'action'.+-- Action values are used by 'rule' and 'action'. The 'Action' monad tracks the dependencies of a 'Rule'. newtype Action a = Action (StateT SAction IO a) deriving (Monad, MonadIO, Functor, Applicative) @@ -310,7 +311,7 @@ let ruleinfo = createRuleinfo rs addTiming "Running rules" runPool (shakeThreads == 1) shakeThreads $ \pool -> do- let s0 = SAction database pool start ruleinfo output shakeVerbosity diagnostic lint after emptyStack [] 0 [] Nothing+ let s0 = SAction database pool start ruleinfo output opts diagnostic lint after emptyStack shakeVerbosity [] 0 [] Nothing mapM_ (addPool pool . staunch . runAction s0) (actions rs) when shakeLint $ do@@ -413,6 +414,7 @@ -- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel. -- This function requires that appropriate rules have been added with 'rule' or 'defaultRule'.+-- All @key@ values passed to 'apply' become dependencies of the 'Action'. apply :: Rule key value => [key] -> Action [value] apply = f where@@ -435,7 +437,7 @@ s <- Action State.get let exec stack k = try $ wrapStack (showStack (database s) stack) $ do evaluate $ rnf k- let s2 = s{depends=[], stack=stack, discount=0, traces=[]}+ let s2 = s{verbosity=shakeVerbosity $ opts s, depends=[], stack=stack, discount=0, traces=[]} let top = topStack stack lint s $ "before building " ++ top (dur,(res,s2)) <- duration $ runAction s2 $ do@@ -459,8 +461,13 @@ apply1 = fmap head . apply . return +-- | Get the initial 'ShakeOptions', these will not change during the build process.+getShakeOptions :: Action ShakeOptions+getShakeOptions = Action $ gets opts++ -- | Write an action to the trace list, along with the start/end time of running the IO action.--- The 'Develoment.Shake.cmd' and 'Develoment.Shake.command' functions automatically call 'traced'.+-- The 'Development.Shake.cmd' and 'Development.Shake.command' functions automatically call 'traced'. -- The trace list is used for profile reports (see 'shakeReport'). traced :: String -> IO a -> Action a traced msg act = do@@ -489,14 +496,17 @@ putQuiet = putWhen Quiet --- | Get the current verbosity level, as set by 'shakeVerbosity'. If you+-- | Get the current verbosity level, originally set by 'shakeVerbosity'. If you -- want to output information to the console, you are recommended to use -- 'putLoud' \/ 'putNormal' \/ 'putQuiet', which ensures multiple messages are--- not interleaved.+-- not interleaved. The verbosity can be modified locally by 'withVerbosity'. getVerbosity :: Action Verbosity getVerbosity = Action $ gets verbosity + -- | Run an action with a particular verbosity level.+-- Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will+-- not have any impact on 'Diagnostic' tracing. withVerbosity :: Verbosity -> Action a -> Action a withVerbosity new act = do old <- Action $ State.gets verbosity@@ -508,6 +518,8 @@ -- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced' -- (including from 'Development.Shake.cmd' or 'Development.Shake.command') will not be printed to the screen.+-- Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will+-- not turn off any 'Diagnostic' tracing. quietly :: Action a -> Action a quietly = withVerbosity Quiet
Development/Shake/Database.hs view
@@ -12,15 +12,15 @@ ) where import Development.Shake.Classes-import Development.Shake.Binary+import General.Binary import Development.Shake.Pool import Development.Shake.Value import Development.Shake.Errors import Development.Shake.Storage import Development.Shake.Types import Development.Shake.Special-import Development.Shake.Util-import Development.Shake.Intern as Intern+import General.Base+import General.Intern as Intern import Control.Exception import Control.Monad@@ -89,6 +89,7 @@ | Loaded Result -- Loaded from the database | Waiting Pending (Maybe Result) -- Currently checking if I am valid or building | Missing -- I am only here because I got into the Intern table+ deriving Show data Result = Result {result :: Value -- the result associated with the Key@@ -97,7 +98,7 @@ ,depends :: [[Id]] -- dependencies ,execution :: {-# UNPACK #-} !Duration -- how long it took when it was last run (seconds) ,traces :: [Trace] -- a trace of the expensive operations (start/end in seconds since beginning of run)- }+ } deriving Show newtype Pending = Pending (IORef (IO ()))
Development/Shake/Derived.hs view
@@ -14,7 +14,7 @@ import System.IO import Development.Shake.Core-import Development.Shake.File+import Development.Shake.Rules.File import Development.Shake.FilePath import Development.Shake.Types @@ -23,7 +23,10 @@ checkExitCode cmd ExitSuccess = return () checkExitCode cmd (ExitFailure i) = error $ "System command failed (code " ++ show i ++ "):\n" ++ cmd --- | Execute a system command. This function will raise an error if the exit code is non-zero.+-- | /Deprecated:/ Please use 'command' or 'cmd' instead.+-- This function will be removed in a future version.+--+-- Execute a system command. This function will raise an error if the exit code is non-zero. -- Before running 'system'' make sure you 'need' any required files. system' :: FilePath -> [String] -> Action () system' path args = do@@ -74,13 +77,13 @@ return (stdout, stderr) --- | @copyFile' old new@ copies the existing file from @old@ to @new@. The @old@ file is has 'need' called on it--- before copying the file.+-- | @copyFile' old new@ copies the existing file from @old@ to @new@.+-- The @old@ file will be tracked as a dependency. copyFile' :: FilePath -> FilePath -> Action () copyFile' old new = need [old] >> liftIO (copyFile old new) --- | Read a file, after calling 'need'.+-- | Read a file, after calling 'need'. The argument file will be tracked as a dependency. readFile' :: FilePath -> Action String readFile' x = need [x] >> liftIO (readFile x) @@ -90,6 +93,7 @@ -- | A version of 'readFile'' which also splits the result into lines.+-- The argument file will be tracked as a dependency. readFileLines :: FilePath -> Action [String] readFileLines = fmap lines . readFile'
− Development/Shake/Directory.hs
@@ -1,270 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards #-}---- | Both System.Directory and System.Environment wrappers-module Development.Shake.Directory(- doesFileExist, doesDirectoryExist,- getDirectoryContents, getDirectoryFiles, getDirectoryDirs,- getEnv,- removeFiles, removeFilesAfter,- defaultRuleDirectory- ) where--import Control.Exception-import Control.Monad-import Control.Monad.IO.Class-import System.IO.Error-import Data.Binary-import Data.List-import qualified System.Directory as IO-import qualified System.Environment as IO--import Development.Shake.Core-import Development.Shake.Classes-import Development.Shake.FilePath-import Development.Shake.FilePattern-import Development.Shake.Util---newtype DoesFileExistQ = DoesFileExistQ FilePath- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesFileExistQ where- show (DoesFileExistQ a) = "doesFileExist " ++ showQuote a--newtype DoesFileExistA = DoesFileExistA Bool- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesFileExistA where- show (DoesFileExistA a) = show a---newtype DoesDirectoryExistQ = DoesDirectoryExistQ FilePath- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesDirectoryExistQ where- show (DoesDirectoryExistQ a) = "doesDirectoryExist " ++ showQuote a--newtype DoesDirectoryExistA = DoesDirectoryExistA Bool- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesDirectoryExistA where- show (DoesDirectoryExistA a) = show a---newtype GetEnvQ = GetEnvQ String- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show GetEnvQ where- show (GetEnvQ a) = "getEnv " ++ showQuote a--newtype GetEnvA = GetEnvA (Maybe String)- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show GetEnvA where- show (GetEnvA a) = maybe "<unset>" showQuote a---data GetDirectoryQ- = GetDir {dir :: FilePath}- | GetDirFiles {dir :: FilePath, pat :: [FilePattern]}- | GetDirDirs {dir :: FilePath}- deriving (Typeable,Eq)--newtype GetDirectoryA = GetDirectoryA [FilePath]- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show GetDirectoryQ where- show (GetDir x) = "getDirectoryContents " ++ showQuote x- show (GetDirFiles a b) = "getDirectoryFiles " ++ showQuote a ++ " [" ++ unwords (map showQuote b) ++ "]"- show (GetDirDirs x) = "getDirectoryDirs " ++ showQuote x--instance Show GetDirectoryA where- show (GetDirectoryA xs) = unwords $ map showQuote xs--instance NFData GetDirectoryQ where- rnf (GetDir a) = rnf a- rnf (GetDirFiles a b) = rnf a `seq` rnf b- rnf (GetDirDirs a) = rnf a--instance Hashable GetDirectoryQ where- hashWithSalt salt = hashWithSalt salt . f- where f (GetDir x) = (0 :: Int, x, [])- f (GetDirFiles x y) = (1, x, y)- f (GetDirDirs x) = (2, x, [])--instance Binary GetDirectoryQ where- get = do- i <- getWord8- case i of- 0 -> liftM GetDir get- 1 -> liftM2 GetDirFiles get get- 2 -> liftM GetDirDirs get-- put (GetDir x) = putWord8 0 >> put x- put (GetDirFiles x y) = putWord8 1 >> put x >> put y- put (GetDirDirs x) = putWord8 2 >> put x---instance Rule DoesFileExistQ DoesFileExistA where- storedValue (DoesFileExistQ x) = fmap (Just . DoesFileExistA) $ IO.doesFileExist x- -- invariant _ = True--instance Rule DoesDirectoryExistQ DoesDirectoryExistA where- storedValue (DoesDirectoryExistQ x) = fmap (Just . DoesDirectoryExistA) $ IO.doesDirectoryExist x- -- invariant _ = True--instance Rule GetEnvQ GetEnvA where- storedValue (GetEnvQ x) = fmap (Just . GetEnvA) $ getEnvIO x- -- invariant _ = True--instance Rule GetDirectoryQ GetDirectoryA where- storedValue x = fmap Just $ getDir x- -- invariant _ = True----- | This function is not actually exported, but Haddock is buggy. Please ignore.-defaultRuleDirectory :: Rules ()-defaultRuleDirectory = do- defaultRule $ \(DoesFileExistQ x) -> Just $- liftIO $ fmap DoesFileExistA $ IO.doesFileExist x- defaultRule $ \(DoesDirectoryExistQ x) -> Just $- liftIO $ fmap DoesDirectoryExistA $ IO.doesDirectoryExist x- defaultRule $ \(x :: GetDirectoryQ) -> Just $- liftIO $ getDir x- defaultRule $ \(GetEnvQ x) -> Just $- liftIO $ fmap GetEnvA $ getEnvIO x----- | Returns 'True' if the file exists.-doesFileExist :: FilePath -> Action Bool-doesFileExist file = do- DoesFileExistA res <- apply1 $ DoesFileExistQ file- return res---- | Returns 'True' if the directory exists.-doesDirectoryExist :: FilePath -> Action Bool-doesDirectoryExist file = do- DoesDirectoryExistA res <- apply1 $ DoesDirectoryExistQ file- return res---- | Return 'Just' the value of the environment variable, or 'Nothing'--- if the variable is not set.-getEnv :: String -> Action (Maybe String)-getEnv var = do- GetEnvA res <- apply1 $ GetEnvQ var- return res--getEnvIO :: String -> IO (Maybe String)-getEnvIO x = Control.Exception.catch (fmap Just $ IO.getEnv x) $- \e -> if isDoesNotExistError e then return Nothing else ioError e---- | Get the contents of a directory. The result will be sorted, and will not contain--- the entries @.@ or @..@ (unlike the standard Haskell version). The resulting paths will be relative--- to the first argument.------ It is usually simpler to call either 'getDirectoryFiles' or 'getDirectoryDirs'.-getDirectoryContents :: FilePath -> Action [FilePath]-getDirectoryContents x = getDirAction $ GetDir x---- | Get the files anywhere under a directory that match any of a set of patterns.--- For the interpretation of the patterns see '?=='. All results will be--- relative to the 'FilePath' argument. Some examples:------ > getDirectoryFiles "Config" ["//*.xml"]--- > -- All .xml files anywhere under the Config directory--- > -- If Config/foo/bar.xml exists it will return ["foo/bar.xml"]--- > getDirectoryFiles "Modules" ["*.hs","*.lhs"]--- > -- All .hs or .lhs in the Modules directory--- > -- If Modules/foo.hs and Modules/foo.lhs exist, it will return ["foo.hs","foo.lhs"]------ If you require a qualified file name it is often easier to use @\"\"@ as 'FilePath' argument,--- for example the following two expressions are equivalent:------ > fmap (map ("Config" </>)) (getDirectoryFiles "Config" ["//*.xml"])--- > getDirectoryFiles "" ["Config//*.xml"]-getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath]-getDirectoryFiles x f = getDirAction $ GetDirFiles x f---- | Get the directories in a directory, not including @.@ or @..@.--- All directories are relative to the argument directory.------ > getDirectoryDirs "/Users"--- > -- Return all directories in the /Users directory--- > -- e.g. ["Emily","Henry","Neil"]-getDirectoryDirs :: FilePath -> Action [FilePath]-getDirectoryDirs x = getDirAction $ GetDirDirs x--getDirAction x = do GetDirectoryA y <- apply1 x; return y--contents :: FilePath -> IO [FilePath]--- getDirectoryContents "" is equivalent to getDirectoryContents "." on Windows,--- but raises an error on Linux. We smooth out the difference.-contents x = fmap (filter $ not . all (== '.')) $ IO.getDirectoryContents $ if x == "" then "." else x---answer :: [FilePath] -> GetDirectoryA-answer = GetDirectoryA . sort--getDir :: GetDirectoryQ -> IO GetDirectoryA-getDir GetDir{..} = fmap answer $ contents dir--getDir GetDirDirs{..} = fmap answer $ filterM f =<< contents dir- where f x = IO.doesDirectoryExist $ dir </> x--getDir GetDirFiles{..} = fmap answer $ concatMapM f $ directories pat- where- test = let ps = map (?==) pat in \x -> any ($ x) ps-- f (dir2,False) = do- xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2- flip filterM xs $ \x -> if not $ test x then return False else fmap not $ IO.doesDirectoryExist $ dir </> x-- f (dir2,True) = do- xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2- (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs- rest <- concatMapM (\d -> f (d, True)) dirs- return $ filter test files ++ rest---concatMapM f xs = fmap concat $ mapM f xs--partitionM f [] = return ([], [])-partitionM f (x:xs) = do- t <- f x- (a,b) <- partitionM f xs- return $ if t then (x:a,b) else (a,x:b)----- | Remove all empty directories and files that match any of the patterns beneath a directory.--- Some examples:------ @--- 'removeFiles' \"output\" [\"\/\/*\"]--- 'removeFiles' \".\" [\"\/\/*.hi\",\"\/\/*.o\"]--- @------ This function is often useful when writing a @clean@ action for your build system,--- often as a 'phony' rule.-removeFiles :: FilePath -> [FilePattern] -> IO ()-removeFiles dir ["//*"] = IO.removeDirectoryRecursive dir -- optimisation-removeFiles dir pat = f "" >> return ()- where- test = let ps = map (?==) pat in \x -> any ($ x) ps-- -- dir </> dir2 is the part to operate on, return True if you cleaned everything- f :: FilePath -> IO Bool- f dir2 = do- xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2- (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs- noDirs <- fmap and $ mapM f dirs- let (del,keep) = partition test files- mapM_ IO.removeFile $ map (dir </>) del- let die = noDirs && null keep- when die $ IO.removeDirectory $ dir </> dir2- return die----- | Remove files, like 'removeFiles', but executed after the build completes successfully.--- Useful for implementing @clean@ actions that delete files Shake may have open for building.-removeFilesAfter :: FilePath -> [FilePattern] -> Action ()-removeFilesAfter a b = runAfter $ removeFiles a b
− Development/Shake/File.hs
@@ -1,235 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}--module Development.Shake.File(- need, want,- defaultRuleFile,- (*>), (**>), (?>), phony, (~>),- newCache, newCacheIO- ) where--import Control.Exception-import Control.Monad-import Control.Monad.IO.Class-import qualified Data.HashMap.Strict as Map-import System.Directory--import Development.Shake.Core-import Development.Shake.Util-import Development.Shake.Classes-import Development.Shake.FilePattern-import Development.Shake.FileTime--import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong---infix 1 *>, ?>, **>, ~>---newtype FileQ = FileQ BSU- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show FileQ where show (FileQ x) = unpackU x--newtype FileA = FileA FileTime- deriving (Typeable,Hashable,Binary,NFData)--instance Eq FileA where FileA x == FileA y = x /= fileTimeNone && x == y--instance Show FileA where show (FileA x) = "FileTimeHash " ++ show x--instance Rule FileQ FileA where- storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x--{-- observed act = do- src <- getCurrentDirectory- old <- listDir src- sleepFileTime- res <- act- new <- listDir src- let obs = compareItems old new- -- if we didn't find anything used, then most likely we aren't tracking access time close enough- obs2 = obs{used = if used obs == Just [] then Nothing else (used obs)}- return (obs2, res)---data Item = ItemDir [(String,Item)] -- sorted- | ItemFile (Maybe FileTime) (Maybe FileTime) -- mod time, access time- deriving Show--listDir :: FilePath -> IO Item-listDir root = do- xs <- getDirectoryContents root- xs <- return $ sort $ filter (not . all (== '.')) xs- fmap ItemDir $ forM xs $ \x -> fmap ((,) x) $ do- let s = root </> x- b <- doesFileExist s- if b then listFile s else listDir s--listFile :: FilePath -> IO Item-listFile x = do- let f x = Control.Exception.catch (fmap Just x) $ \(_ :: SomeException) -> return Nothing- mod <- f $ getModTime x- acc <- f $ getAccTime x- return $ ItemFile mod acc--compareItems :: Item -> Item -> Observed File-compareItems = f ""- where- f path (ItemFile mod1 acc1) (ItemFile mod2 acc2) =- Observed (Just [File path | mod1 /= mod2]) (Just [File path | acc1 /= acc2])- f path (ItemDir xs) (ItemDir ys) = mconcat $ map g $ zips xs ys- where g (name, Just x, Just y) = f (path </> name) x y- g (name, x, y) = Observed (Just $ concatMap (files path) $ catMaybes [x,y]) Nothing- f path _ _ = Observed (Just [File path]) Nothing-- files path (ItemDir xs) = concat [files (path </> a) b | (a,b) <- xs]- files path _ = [File path]-- zips :: Ord a => [(a,b)] -> [(a,b)] -> [(a, Maybe b, Maybe b)]- zips ((x1,x2):xs) ((y1,y2):ys)- | x1 == y1 = (x1,Just x2,Just y2):zips xs ys- | x1 < y1 = (x1,Just x2,Nothing):zips xs ((y1,y2):ys)- | otherwise = (y1,Nothing,Just y2):zips ((x1,x2):xs) ys- zips xs ys = [(a,Just b,Nothing) | (a,b) <- xs] ++ [(a,Nothing,Just b) | (a,b) <- ys]--}----- | This function is not actually exported, but Haddock is buggy. Please ignore.-defaultRuleFile :: Rules ()-defaultRuleFile = defaultRule $ \(FileQ x) -> Just $- liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" x----- | Require that the following files are built before continuing. Particularly--- necessary when calling 'Development.Shake.cmd' or 'Development.Shake.command'. As an example:------ @--- \"\/\/*.rot13\" '*>' \\out -> do--- let src = 'Development.Shake.FilePath.dropExtension' out--- 'need' [src]--- 'Development.Shake.cmd' \"rot13\" [src] \"-o\" [out]--- @-need :: [FilePath] -> Action ()-need xs = (apply $ map (FileQ . packU) xs :: Action [FileA]) >> return ()---- | Require that the following are built by the rules, used to specify the target.------ @--- main = 'Development.Shake.shake' 'shakeOptions' $ do--- 'want' [\"Main.exe\"]--- ...--- @------ This program will build @Main.exe@, given sufficient rules.------ This function is defined in terms of 'action' and 'need', use 'action' if you need more complex--- targets than 'want' allows.-want :: [FilePath] -> Rules ()-want = action . need---root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-root help test act = rule $ \(FileQ x_) -> let x = unpackU x_ in- if not $ test x then Nothing else Just $ do- liftIO $ createDirectoryIfMissing True $ takeDirectory x- act x- liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") x_----- | Declare a phony action -- an action that does not produce a file, and will be rerun--- in every execution that requires it. You can demand 'phony' rules using 'want' \/ 'need'.--- Phony actions are never executed more than once in a single build run.------ Phony actions are intended to define command-line abbreviations. If you 'need' a phony action--- in a rule then every execution where that rule is required will rerun both the rule and the phony--- action.-phony :: String -> Action () -> Rules ()-phony name act = rule $ \(FileQ x_) -> let x = unpackU x_ in- if name /= x then Nothing else Just $ do- act- return $ FileA fileTimeNone---- | Infix operator alias for 'phony', for sake of consistency with normal--- rules.-(~>) :: String -> Action () -> Rules ()-(~>) = phony ----- | Define a rule to build files. If the first argument returns 'True' for a given file,--- the second argument will be used to build it. Usually '*>' is sufficient, but '?>' gives--- additional power. For any file used by the build system, only one rule should return 'True'.------ @--- (all isUpper . 'Development.Shake.FilePath.takeBaseName') '?>' \\out -> do--- let src = 'Development.Shake.FilePath.replaceBaseName' out $ map toLower $ takeBaseName out--- 'Development.Shake.writeFile'' out . map toUpper =<< 'Development.Shake.readFile'' src--- @-(?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-(?>) = root "with ?>"----- | Define a set of patterns, and if any of them match, run the associated rule. See '*>'.-(**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()-(**>) test = root "with **>" (\x -> any (?== x) test)---- | Define a rule that matches a 'FilePattern'. No file required by the system must be--- matched by more than one pattern. For the pattern rules, see '?=='.------ @--- \"*.asm.o\" '*>' \\out -> do--- let src = 'Development.Shake.FilePath.dropExtension' out--- 'need' [src]--- 'Development.Shake.cmd' \"as\" [src] \"-o\" [out]--- @------ To define a build system for multiple compiled languages, we recommend using @.asm.o@,--- @.cpp.o@, @.hs.o@, to indicate which language produces an object file.--- I.e., the file @foo.cpp@ produces object file @foo.cpp.o@.------ Note that matching is case-sensitive, even on Windows.-(*>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()-(*>) test = root (show test) (test ?==)----- | A version of 'newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.--- Most people should use 'newCache' instead.-newCacheIO :: (FilePath -> IO a) -> IO (FilePath -> Action a)-newCacheIO act = do- var <- newVar Map.empty -- Var (Map FilePath (Barrier (Either SomeException a)))- let run = either (\e -> throwIO (e :: SomeException)) return- return $ \file -> do- need [file]- liftIO $ join $ modifyVar var $ \mp -> case Map.lookup file mp of- Just v -> return (mp, run =<< waitBarrier v)- Nothing -> do- v <- newBarrier- return $ (,) (Map.insert file v mp) $ do- res <- try $ act file- signalBarrier v res- run res----- | Given a way of loading information from a file, produce a cached version that will load each file at most once.--- Using the cached function will still result in a dependency on the original file.--- The argument function should not access any files other than the one passed as its argument.--- Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'.------ This function is useful when creating files that store intermediate values,--- to avoid the overhead of repeatedly reading from disk, particularly if the file requires expensive parsing.--- As an example:------ @--- digits \<- 'newCache' $ \\file -> do--- src \<- readFile file--- return $ length $ filter isDigit src--- \"*.digits\" '*>' \\x -> do--- v1 \<- digits ('dropExtension' x)--- v2 \<- digits ('dropExtension' x)--- 'Development.Shake.writeFile'' x $ show (v1,v2)--- @------ To create the result @MyFile.txt.digits@ the file @MyFile.txt@ will be read and counted, but only at most--- once per execution.-newCache :: (FilePath -> IO a) -> Rules (FilePath -> Action a)-newCache = rulesIO . newCacheIO
Development/Shake/FilePath.hs view
@@ -9,16 +9,20 @@ -- -- * When combining 'FilePath' values with '</>' we squash any @\/.\/@ components. module Development.Shake.FilePath(- module System.FilePath.Posix,+ module System.FilePath.Posix, -- apart from what I override and search path stuff+ module System.FilePath, -- only search-path stuff dropDirectory1, takeDirectory1, normalise, (-<.>), toNative, (</>), combine, exe ) where -import System.FilePath.Posix hiding (normalise, (</>), combine)+import System.FilePath.Posix hiding+ (normalise, (</>), combine+ ,searchPathSeparator, isSearchPathSeparator, splitSearchPath, getSearchPath)+import System.FilePath(searchPathSeparator, isSearchPathSeparator, splitSearchPath, getSearchPath)+import General.Base import qualified System.FilePath as Native-import Data.List infixr 5 </> infixr 7 -<.>@@ -45,20 +49,41 @@ takeDirectory1 = takeWhile (not . Native.isPathSeparator) --- | Normalise a 'FilePath', applying the standard 'FilePath' normalisation, plus--- translating any path separators to @\/@ and removing @foo\/..@ components where possible.+-- | Normalise a 'FilePath', trying to do:+--+-- * All 'pathSeparators' become @\/@+-- * @foo\/bar\/..\/baz@ becomes @foo\/baz@+-- * @foo\/.\/bar@ becomes @foo\/bar@+-- * @foo\/\/bar@ becomes @foo\/bar@+--+-- This function is not based on the normalise function from the filepath library, as that function+-- is quite broken. normalise :: FilePath -> FilePath-normalise = intercalate "/" . dropDots . split . Native.normalise+normalise xs | a:b:xs <- xs, isWindows && sep a && sep b = '/' : f ('/':xs) -- account for UNC paths being double //+ | otherwise = f xs where- dropDots = reverse . f 0 . reverse- where- f i ("..":xs) = f (i+1) xs- f 0 (x:xs) = x : f 0 xs- f i (x:xs) = f (i-1) xs- f i [] = replicate i ".."+ sep = Native.isPathSeparator+ f o = deslash o $ (++"/") $ concatMap ('/':) $ reverse $ g 0 $ reverse $ split o - split xs = a : if null b then [] else split $ tail b- where (a,b) = break Native.isPathSeparator xs+ deslash o x+ | x == "/" = case (pre,pos) of+ (True,True) -> "/"+ (True,False) -> "/."+ (False,True) -> "./"+ (False,False) -> "."+ | otherwise = (if pre then id else tail) $ (if pos then id else init) x+ where pre = sep $ head $ o ++ " "+ pos = sep $ last $ " " ++ o++ g i [] = replicate i ".."+ g i ("..":xs) = g (i+1) xs+ g i (".":xs) = g i xs+ g 0 (x:xs) = x : g 0 xs+ g i (x:xs) = g (i-1) xs++ split xs = if null ys then [] else a : split b+ where (a,b) = break sep $ ys+ ys = dropWhile sep xs -- | Convert to native path separators, namely @\\@ on Windows.
Development/Shake/FilePattern.hs view
@@ -9,7 +9,7 @@ import System.FilePath(pathSeparators) import Data.List import Control.Arrow-import Development.Shake.Util+import General.Base ---------------------------------------------------------------------
Development/Shake/FileTime.hs view
@@ -6,7 +6,7 @@ ) where import Development.Shake.Classes-import Development.Shake.Util+import General.Base import Data.Char import Data.Int import Data.Word
− Development/Shake/Files.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}--module Development.Shake.Files(- (?>>), (*>>)- ) where--import Control.Monad-import Control.Monad.IO.Class-import Data.Maybe-import System.Directory--import Development.Shake.Core-import Development.Shake.Util-import Development.Shake.Classes-import Development.Shake.File-import Development.Shake.FilePattern-import Development.Shake.FileTime--import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong---infix 1 ?>>, *>>---newtype FilesQ = FilesQ [BSU]- deriving (Typeable,Eq,Hashable,Binary,NFData)--newtype FilesA = FilesA [FileTime]- deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show FilesA where show (FilesA xs) = unwords $ "FileTimeHashes" : map show xs--instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . unpackU) xs---instance Rule FilesQ FilesA where- storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs----- | Define a rule for building multiple files at the same time.--- As an example, a single invokation of GHC produces both @.hi@ and @.o@ files:------ @--- [\"*.o\",\"*.hi\"] '*>>' \\[o,hi] -> do--- let hs = o 'Development.Shake.FilePath.-<.>' \"hs\"--- 'Development.Shake.need' ... -- all files the .hs import--- 'Development.Shake.cmd' \"ghc -c\" [hs]--- @------ However, in practice, it's usually easier to define rules with '*>' and make the @.hi@ depend--- on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must--- have the same sequence of @\/\/@ and @*@ wildcards in the same order.-(*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()-ps *>> act- | not $ compatible ps = error $- "All patterns to *>> must have the same number and position of // and * wildcards\n" ++- unwords ps- | otherwise = do- forM_ ps $ \p ->- p *> \file -> do- _ :: FilesA <- apply1 $ FilesQ $ map (packU . substitute (extract p file)) ps- return ()- rule $ \(FilesQ xs_) -> let xs = map unpackU xs_ in- if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do- liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs- act xs- liftIO $ getFileTimes "*>>" xs_----- | Define a rule for building multiple files at the same time, a more powerful--- and more dangerous version of '*>>'.------ Given an application @test ?>> ...@, @test@ should return @Just@ if the rule applies, and should--- return the list of files that will be produced. This list /must/ include the file passed as an argument and should--- obey the invariant:------ > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys------ As an example of a function satisfying the invariaint:------ @---test x | 'Development.Shake.FilePath.takeExtension' x \`elem\` [\".hi\",\".o\"]--- = Just ['Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"hi\", 'Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"o\"]---test _ = Nothing--- @------ Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.-(?>>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()-(?>>) test act = do- let checkedTest x = case test x of- Nothing -> Nothing- Just ys | x `elem` ys && all ((== Just ys) . test) ys -> Just ys- | otherwise -> error $ "Invariant broken in ?>> when trying on " ++ x-- isJust . checkedTest ?> \x -> do- _ :: FilesA <- apply1 $ FilesQ $ map packU $ fromJust $ test x- return ()-- rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpackU xs_ in- case checkedTest x of- Just ys | ys == xs -> Just $ do- liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs- act xs- liftIO $ getFileTimes "?>>" xs_- Just ys -> error $ "Error, ?>> is incompatible with " ++ show xs ++ " vs " ++ show ys- Nothing -> Nothing---getFileTimes :: String -> [BSU] -> IO FilesA-getFileTimes name xs = do- ys <- mapM getModTimeMaybe xs- case sequence ys of- Just ys -> return $ FilesA ys- Nothing -> do- let missing = length $ filter isNothing ys- error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++- " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++- concat ["\n " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]
− Development/Shake/Intern.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}--module Development.Shake.Intern(- Intern, Id,- empty, insert, add, lookup, toList, fromList- ) where--import Development.Shake.Binary-import Development.Shake.Classes-import Prelude hiding (lookup)-import qualified Data.HashMap.Strict as Map-import Data.List(foldl')----- Invariant: The first field is the highest value in the Map-data Intern a = Intern {-# UNPACK #-} !Word32 !(Map.HashMap a Id)--newtype Id = Id Word32- deriving (Eq,Hashable,Binary,Show,NFData)--instance BinaryWith w Id where- putWith ctx = put- getWith ctx = get---empty :: Intern a-empty = Intern 0 Map.empty---insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a-insert k v@(Id i) (Intern n mp) = Intern (max n i) $ Map.insert k v mp---add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)-add k (Intern v mp) = (Intern v2 $ Map.insert k (Id v2) mp, Id v2)- where v2 = v + 1---lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id-lookup k (Intern n mp) = Map.lookup k mp---toList :: Intern a -> [(a, Id)]-toList (Intern a b) = Map.toList b---fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a-fromList xs = Intern (foldl' max 0 [i | (_, Id i) <- xs]) (Map.fromList xs)
− Development/Shake/Oracle.hs
@@ -1,118 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}--- Allows the user to violate the functional dependency, but it has a runtime check so still safe-{-# LANGUAGE UndecidableInstances #-}--{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE ConstraintKinds #-}-#endif--module Development.Shake.Oracle(- addOracle, askOracle, askOracleWith- ) where--import Development.Shake.Core-import Development.Shake.Classes----- Use should type names, since the names appear in the Haddock, and are too long if they are in full-newtype OracleQ question = OracleQ question- deriving (Show,Typeable,Eq,Hashable,Binary,NFData)-newtype OracleA answer = OracleA answer- deriving (Show,Typeable,Eq,Hashable,Binary,NFData)--instance (-#if __GLASGOW_HASKELL__ >= 704- ShakeValue q, ShakeValue a-#else- Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,- Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a-#endif- ) => Rule (OracleQ q) (OracleA a) where- storedValue _ = return Nothing----- | Add extra information which rules can depend on.--- An oracle is a function from a question type @q@, to an answer type @a@.--- As an example, we can define an oracle allowing you to depend on the current version of GHC:------ @--- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)--- rules = do--- 'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\"--- ... rules ...--- @------ If a rule calls @'askOracle' (GhcVersion ())@, that rule will be rerun whenever the GHC version changes.--- Some notes:------ * We define @GhcVersion@ with a @newtype@ around @()@, allowing the use of @GeneralizedNewtypeDeriving@.--- All the necessary type classes are exported from "Development.Shake.Classes".------ * Each call to 'addOracle' must use a different type of question.------ * Actions passed to 'addOracle' will be run in every build they are required,--- but if their value does not change they will not invalidate any rules depending on them.--- To get a similar behaviour using data stored in files, see 'Development.Shake.alwaysRerun'.------ * If the value returned by 'askOracle' is ignored then 'askOracleWith' may help avoid ambiguous type messages.--- Alternatively, use the result of 'addOracle', which is 'askOracle' restricted to the correct type.------ As a more complex example, consider tracking Haskell package versions:------ @---newtype GhcPkgList = GhcPkgList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)---newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)------rules = do--- getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do--- Stdout out <- 'Development.Shake.cmd' \"ghc-pkg list --simple-output\"--- return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]--- ----- getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do--- pkgs <- getPkgList $ GhcPkgList ()--- return $ lookup pkg pkgs--- ----- \"myrule\" *> \\_ -> do--- getPkgVersion $ GhcPkgVersion \"shake\"--- ... rule using the shake version ...--- @------ Using these definitions, any rule depending on the version of @shake@--- should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.-addOracle :: (-#if __GLASGOW_HASKELL__ >= 704- ShakeValue q, ShakeValue a-#else- Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,- Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a-#endif- ) => (q -> Action a) -> Rules (q -> Action a)-addOracle act = do- rule $ \(OracleQ q) -> Just $ fmap OracleA $ act q- return askOracle----- | Get information previously added with 'addOracle'. The question/answer types must match those provided--- to 'addOracle'.-askOracle :: (-#if __GLASGOW_HASKELL__ >= 704- ShakeValue q, ShakeValue a-#else- Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,- Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a-#endif- ) => q -> Action a-askOracle question = do OracleA answer <- apply1 $ OracleQ question; return answer---- | Get information previously added with 'addOracle'. The second argument is not used, but can--- be useful to fix the answer type, avoiding ambiguous type error messages.-askOracleWith :: (-#if __GLASGOW_HASKELL__ >= 704- ShakeValue q, ShakeValue a-#else- Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,- Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a-#endif- ) => q -> a -> Action a-askOracleWith question _ = askOracle question
Development/Shake/Pool.hs view
@@ -4,8 +4,8 @@ import Control.Concurrent import Control.Exception hiding (blocked)-import Development.Shake.Util-import Development.Shake.Timing+import General.Base+import General.Timing import qualified Data.HashSet as Set import System.IO.Unsafe import System.Random
− Development/Shake/Rerun.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}--module Development.Shake.Rerun(- defaultRuleRerun, alwaysRerun- ) where--import Development.Shake.Core-import Development.Shake.Classes---newtype AlwaysRerunQ = AlwaysRerunQ ()- deriving (Typeable,Eq,Hashable,Binary,NFData)-instance Show AlwaysRerunQ where show _ = "alwaysRerun"--newtype AlwaysRerunA = AlwaysRerunA ()- deriving (Typeable,Hashable,Binary,NFData)-instance Show AlwaysRerunA where show _ = "<none>"-instance Eq AlwaysRerunA where a == b = False--instance Rule AlwaysRerunQ AlwaysRerunA where- storedValue _ = return Nothing----- | Always rerun the associated action. Useful for defining rules that query--- the environment. For example:------ @--- \"ghcVersion.txt\" 'Development.Shake.*>' \\out -> do--- 'alwaysRerun'--- 'Development.Shake.Stdout' stdout <- 'Development.Shake.cmd' \"ghc --numeric-version\"--- 'Development.Shake.writeFileChanged' out stdout--- @-alwaysRerun :: Action ()-alwaysRerun = do AlwaysRerunA _ <- apply1 $ AlwaysRerunQ (); return ()--defaultRuleRerun :: Rules ()-defaultRuleRerun = defaultRule $ \AlwaysRerunQ{} -> Just $ return $ AlwaysRerunA()
Development/Shake/Resource.hs view
@@ -5,7 +5,7 @@ ) where import Development.Shake.Errors-import Development.Shake.Util+import General.Base import Data.Function import System.IO.Unsafe import Control.Arrow
+ Development/Shake/Rules/Directory.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards #-}++-- | Both System.Directory and System.Environment wrappers+module Development.Shake.Rules.Directory(+ doesFileExist, doesDirectoryExist,+ getDirectoryContents, getDirectoryFiles, getDirectoryDirs,+ getEnv,+ removeFiles, removeFilesAfter,+ defaultRuleDirectory+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import System.IO.Error+import Data.Binary+import Data.List+import qualified System.Directory as IO+import qualified System.Environment as IO++import Development.Shake.Core+import Development.Shake.Classes+import Development.Shake.FilePath+import Development.Shake.FilePattern+import General.Base+++newtype DoesFileExistQ = DoesFileExistQ FilePath+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show DoesFileExistQ where+ show (DoesFileExistQ a) = "doesFileExist " ++ showQuote a++newtype DoesFileExistA = DoesFileExistA Bool+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show DoesFileExistA where+ show (DoesFileExistA a) = show a+++newtype DoesDirectoryExistQ = DoesDirectoryExistQ FilePath+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show DoesDirectoryExistQ where+ show (DoesDirectoryExistQ a) = "doesDirectoryExist " ++ showQuote a++newtype DoesDirectoryExistA = DoesDirectoryExistA Bool+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show DoesDirectoryExistA where+ show (DoesDirectoryExistA a) = show a+++newtype GetEnvQ = GetEnvQ String+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show GetEnvQ where+ show (GetEnvQ a) = "getEnv " ++ showQuote a++newtype GetEnvA = GetEnvA (Maybe String)+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show GetEnvA where+ show (GetEnvA a) = maybe "<unset>" showQuote a+++data GetDirectoryQ+ = GetDir {dir :: FilePath}+ | GetDirFiles {dir :: FilePath, pat :: [FilePattern]}+ | GetDirDirs {dir :: FilePath}+ deriving (Typeable,Eq)++newtype GetDirectoryA = GetDirectoryA [FilePath]+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show GetDirectoryQ where+ show (GetDir x) = "getDirectoryContents " ++ showQuote x+ show (GetDirFiles a b) = "getDirectoryFiles " ++ showQuote a ++ " [" ++ unwords (map showQuote b) ++ "]"+ show (GetDirDirs x) = "getDirectoryDirs " ++ showQuote x++instance Show GetDirectoryA where+ show (GetDirectoryA xs) = unwords $ map showQuote xs++instance NFData GetDirectoryQ where+ rnf (GetDir a) = rnf a+ rnf (GetDirFiles a b) = rnf a `seq` rnf b+ rnf (GetDirDirs a) = rnf a++instance Hashable GetDirectoryQ where+ hashWithSalt salt = hashWithSalt salt . f+ where f (GetDir x) = (0 :: Int, x, [])+ f (GetDirFiles x y) = (1, x, y)+ f (GetDirDirs x) = (2, x, [])++instance Binary GetDirectoryQ where+ get = do+ i <- getWord8+ case i of+ 0 -> liftM GetDir get+ 1 -> liftM2 GetDirFiles get get+ 2 -> liftM GetDirDirs get++ put (GetDir x) = putWord8 0 >> put x+ put (GetDirFiles x y) = putWord8 1 >> put x >> put y+ put (GetDirDirs x) = putWord8 2 >> put x+++instance Rule DoesFileExistQ DoesFileExistA where+ storedValue (DoesFileExistQ x) = fmap (Just . DoesFileExistA) $ IO.doesFileExist x+ -- invariant _ = True++instance Rule DoesDirectoryExistQ DoesDirectoryExistA where+ storedValue (DoesDirectoryExistQ x) = fmap (Just . DoesDirectoryExistA) $ IO.doesDirectoryExist x+ -- invariant _ = True++instance Rule GetEnvQ GetEnvA where+ storedValue (GetEnvQ x) = fmap (Just . GetEnvA) $ getEnvIO x+ -- invariant _ = True++instance Rule GetDirectoryQ GetDirectoryA where+ storedValue x = fmap Just $ getDir x+ -- invariant _ = True+++-- | This function is not actually exported, but Haddock is buggy. Please ignore.+defaultRuleDirectory :: Rules ()+defaultRuleDirectory = do+ defaultRule $ \(DoesFileExistQ x) -> Just $+ liftIO $ fmap DoesFileExistA $ IO.doesFileExist x+ defaultRule $ \(DoesDirectoryExistQ x) -> Just $+ liftIO $ fmap DoesDirectoryExistA $ IO.doesDirectoryExist x+ defaultRule $ \(x :: GetDirectoryQ) -> Just $+ liftIO $ getDir x+ defaultRule $ \(GetEnvQ x) -> Just $+ liftIO $ fmap GetEnvA $ getEnvIO x+++-- | Returns 'True' if the file exists. The existence of the file is tracked as a+-- dependency, and if the file is created or deleted the rule will rerun in subsequent builds.+--+-- You should not call 'doesFileExist' on files which can be created by the build system.+doesFileExist :: FilePath -> Action Bool+doesFileExist file = do+ DoesFileExistA res <- apply1 $ DoesFileExistQ file+ return res++-- | Returns 'True' if the directory exists. The existence of the directory is tracked as a+-- dependency, and if the directory is created or delete the rule will rerun in subsequent builds.+--+-- You should not call 'doesDirectoryExist' on directories which can be created by the build system.+doesDirectoryExist :: FilePath -> Action Bool+doesDirectoryExist file = do+ DoesDirectoryExistA res <- apply1 $ DoesDirectoryExistQ file+ return res++-- | Return 'Just' the value of the environment variable, or 'Nothing'+-- if the variable is not set. The environment variable is tracked as a+-- dependency, and if it changes the rule will rerun in subsequent builds.+getEnv :: String -> Action (Maybe String)+getEnv var = do+ GetEnvA res <- apply1 $ GetEnvQ var+ return res++getEnvIO :: String -> IO (Maybe String)+getEnvIO x = Control.Exception.catch (fmap Just $ IO.getEnv x) $+ \e -> if isDoesNotExistError e then return Nothing else ioError e++-- | Get the contents of a directory. The result will be sorted, and will not contain+-- the entries @.@ or @..@ (unlike the standard Haskell version). The resulting paths will be relative+-- to the first argument. The result is tracked as a+-- dependency, and if it changes the rule will rerun in subsequent builds.+--+-- It is usually simpler to call either 'getDirectoryFiles' or 'getDirectoryDirs'.+getDirectoryContents :: FilePath -> Action [FilePath]+getDirectoryContents x = getDirAction $ GetDir x++-- | Get the files anywhere under a directory that match any of a set of patterns.+-- For the interpretation of the patterns see '?=='. All results will be+-- relative to the 'FilePath' argument. The result is tracked as a+-- dependency, and if it changes the rule will rerun in subsequent builds.+-- Some examples:+--+-- > getDirectoryFiles "Config" ["//*.xml"]+-- > -- All .xml files anywhere under the Config directory+-- > -- If Config/foo/bar.xml exists it will return ["foo/bar.xml"]+-- > getDirectoryFiles "Modules" ["*.hs","*.lhs"]+-- > -- All .hs or .lhs in the Modules directory+-- > -- If Modules/foo.hs and Modules/foo.lhs exist, it will return ["foo.hs","foo.lhs"]+--+-- If you require a qualified file name it is often easier to use @\"\"@ as 'FilePath' argument,+-- for example the following two expressions are equivalent:+--+-- > fmap (map ("Config" </>)) (getDirectoryFiles "Config" ["//*.xml"])+-- > getDirectoryFiles "" ["Config//*.xml"]+getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath]+getDirectoryFiles x f = getDirAction $ GetDirFiles x f++-- | Get the directories in a directory, not including @.@ or @..@.+-- All directories are relative to the argument directory. The result is tracked as a+-- dependency, and if it changes the rule will rerun in subsequent builds.+--+--+-- > getDirectoryDirs "/Users"+-- > -- Return all directories in the /Users directory+-- > -- e.g. ["Emily","Henry","Neil"]+getDirectoryDirs :: FilePath -> Action [FilePath]+getDirectoryDirs x = getDirAction $ GetDirDirs x++getDirAction x = do GetDirectoryA y <- apply1 x; return y++contents :: FilePath -> IO [FilePath]+-- getDirectoryContents "" is equivalent to getDirectoryContents "." on Windows,+-- but raises an error on Linux. We smooth out the difference.+contents x = fmap (filter $ not . all (== '.')) $ IO.getDirectoryContents $ if x == "" then "." else x+++answer :: [FilePath] -> GetDirectoryA+answer = GetDirectoryA . sort++getDir :: GetDirectoryQ -> IO GetDirectoryA+getDir GetDir{..} = fmap answer $ contents dir++getDir GetDirDirs{..} = fmap answer $ filterM f =<< contents dir+ where f x = IO.doesDirectoryExist $ dir </> x++getDir GetDirFiles{..} = fmap answer $ concatMapM f $ directories pat+ where+ test = let ps = map (?==) pat in \x -> any ($ x) ps++ f (dir2,False) = do+ xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2+ flip filterM xs $ \x -> if not $ test x then return False else fmap not $ IO.doesDirectoryExist $ dir </> x++ f (dir2,True) = do+ xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2+ (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs+ rest <- concatMapM (\d -> f (d, True)) dirs+ return $ filter test files ++ rest+++-- | Remove all empty directories and files that match any of the patterns beneath a directory.+-- Some examples:+--+-- @+-- 'removeFiles' \"output\" [\"\/\/*\"]+-- 'removeFiles' \".\" [\"\/\/*.hi\",\"\/\/*.o\"]+-- @+--+-- This function is often useful when writing a @clean@ action for your build system,+-- often as a 'phony' rule.+removeFiles :: FilePath -> [FilePattern] -> IO ()+removeFiles dir ["//*"] = IO.removeDirectoryRecursive dir -- optimisation+removeFiles dir pat = f "" >> return ()+ where+ test = let ps = map (?==) pat in \x -> any ($ x) ps++ -- dir </> dir2 is the part to operate on, return True if you cleaned everything+ f :: FilePath -> IO Bool+ f dir2 = do+ xs <- fmap (map (dir2 </>)) $ contents $ dir </> dir2+ (dirs,files) <- partitionM (\x -> IO.doesDirectoryExist $ dir </> x) xs+ noDirs <- fmap and $ mapM f dirs+ let (del,keep) = partition test files+ mapM_ IO.removeFile $ map (dir </>) del+ let die = noDirs && null keep+ when die $ IO.removeDirectory $ dir </> dir2+ return die+++-- | Remove files, like 'removeFiles', but executed after the build completes successfully.+-- Useful for implementing @clean@ actions that delete files Shake may have open for building.+removeFilesAfter :: FilePath -> [FilePattern] -> Action ()+removeFilesAfter a b = runAfter $ removeFiles a b
+ Development/Shake/Rules/File.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}++module Development.Shake.Rules.File(+ need, needBS, needed, neededBS, want,+ defaultRuleFile,+ (*>), (**>), (?>), phony, (~>),+ newCache, newCacheIO+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import qualified Data.HashMap.Strict as Map+import System.Directory+import qualified Data.ByteString.Char8 as BS++import Development.Shake.Core+import General.Base+import Development.Shake.Classes+import Development.Shake.FilePattern+import Development.Shake.FileTime+import Development.Shake.Types+import Development.Shake.Errors++import Data.Maybe+import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong+++infix 1 *>, ?>, **>, ~>+++newtype FileQ = FileQ BSU+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show FileQ where show (FileQ x) = unpackU x++newtype FileA = FileA FileTime+ deriving (Typeable,Hashable,Binary,NFData)++instance Eq FileA where FileA x == FileA y = x /= fileTimeNone && x == y++instance Show FileA where show (FileA x) = "FileTimeHash " ++ show x++instance Rule FileQ FileA where+ storedValue (FileQ x) = fmap (fmap FileA) $ getModTimeMaybe x++{-+ observed act = do+ src <- getCurrentDirectory+ old <- listDir src+ sleepFileTime+ res <- act+ new <- listDir src+ let obs = compareItems old new+ -- if we didn't find anything used, then most likely we aren't tracking access time close enough+ obs2 = obs{used = if used obs == Just [] then Nothing else (used obs)}+ return (obs2, res)+++data Item = ItemDir [(String,Item)] -- sorted+ | ItemFile (Maybe FileTime) (Maybe FileTime) -- mod time, access time+ deriving Show++listDir :: FilePath -> IO Item+listDir root = do+ xs <- getDirectoryContents root+ xs <- return $ sort $ filter (not . all (== '.')) xs+ fmap ItemDir $ forM xs $ \x -> fmap ((,) x) $ do+ let s = root </> x+ b <- doesFileExist s+ if b then listFile s else listDir s++listFile :: FilePath -> IO Item+listFile x = do+ let f x = Control.Exception.catch (fmap Just x) $ \(_ :: SomeException) -> return Nothing+ mod <- f $ getModTime x+ acc <- f $ getAccTime x+ return $ ItemFile mod acc++compareItems :: Item -> Item -> Observed File+compareItems = f ""+ where+ f path (ItemFile mod1 acc1) (ItemFile mod2 acc2) =+ Observed (Just [File path | mod1 /= mod2]) (Just [File path | acc1 /= acc2])+ f path (ItemDir xs) (ItemDir ys) = mconcat $ map g $ zips xs ys+ where g (name, Just x, Just y) = f (path </> name) x y+ g (name, x, y) = Observed (Just $ concatMap (files path) $ catMaybes [x,y]) Nothing+ f path _ _ = Observed (Just [File path]) Nothing++ files path (ItemDir xs) = concat [files (path </> a) b | (a,b) <- xs]+ files path _ = [File path]++ zips :: Ord a => [(a,b)] -> [(a,b)] -> [(a, Maybe b, Maybe b)]+ zips ((x1,x2):xs) ((y1,y2):ys)+ | x1 == y1 = (x1,Just x2,Just y2):zips xs ys+ | x1 < y1 = (x1,Just x2,Nothing):zips xs ((y1,y2):ys)+ | otherwise = (y1,Nothing,Just y2):zips ((x1,x2):xs) ys+ zips xs ys = [(a,Just b,Nothing) | (a,b) <- xs] ++ [(a,Nothing,Just b) | (a,b) <- ys]+-}+++-- | This function is not actually exported, but Haddock is buggy. Please ignore.+defaultRuleFile :: Rules ()+defaultRuleFile = defaultRule $ \(FileQ x) -> Just $+ liftIO $ fmap FileA $ getModTimeError "Error, file does not exist and no rule available:" x+++-- | Add a dependency on the file arguments, ensuring they are built before continuing.+-- The file arguments may be built in parallel, in any order. This function is particularly+-- necessary when calling 'Development.Shake.cmd' or 'Development.Shake.command'. As an example:+--+-- @+-- \"\/\/*.rot13\" '*>' \\out -> do+-- let src = 'Development.Shake.FilePath.dropExtension' out+-- 'need' [src]+-- 'Development.Shake.cmd' \"rot13\" [src] \"-o\" [out]+-- @+--+-- Usually @need [foo,bar]@ is preferable to @need [foo] >> need [bar]@ as the former allows greater+-- parallelism, while the latter requires @foo@ to finish building before starting to build @bar@.+need :: [FilePath] -> Action ()+need xs = (apply $ map (FileQ . packU) xs :: Action [FileA]) >> return ()++needBS :: [BS.ByteString] -> Action ()+needBS xs = (apply $ map (FileQ . packU_) xs :: Action [FileA]) >> return ()+++-- | Like 'need', but if 'shakeLint' is set, check that the file does not rebuild.+-- Used for adding dependencies on files that have already been used in this rule.+needed :: [FilePath] -> Action ()+needed xs = do+ opts <- getShakeOptions+ if not $ shakeLint opts then need xs else neededCheck $ map packU xs+++neededBS :: [BS.ByteString] -> Action ()+neededBS xs = do+ opts <- getShakeOptions+ if not $ shakeLint opts then needBS xs else neededCheck $ map packU_ xs+++neededCheck :: [BSU] -> Action ()+neededCheck xs = do+ pre <- liftIO $ mapM getModTimeMaybe xs+ post <- apply $ map FileQ xs :: Action [FileA]+ let bad = [ (x, if isJust a then "File change" else "File created")+ | (x, a, FileA b) <- zip3 xs pre post, Just b /= a]+ case bad of+ [] -> return ()+ (file,msg):_ -> errorStructured+ "Lint checking error - 'needed' file required rebuilding"+ [("File", Just $ unpackU file)+ ,("Error",Just msg)]+ ""+++-- | Require that the argument files are built by the rules, used to specify the target.+--+-- @+-- main = 'Development.Shake.shake' 'shakeOptions' $ do+-- 'want' [\"Main.exe\"]+-- ...+-- @+--+-- This program will build @Main.exe@, given sufficient rules. All arguments to all 'want' calls+-- may be built in parallel, in any order.+--+-- This function is defined in terms of 'action' and 'need', use 'action' if you need more complex+-- targets than 'want' allows.+want :: [FilePath] -> Rules ()+want = action . need+++root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()+root help test act = rule $ \(FileQ x_) -> let x = unpackU x_ in+ if not $ test x then Nothing else Just $ do+ liftIO $ createDirectoryIfMissing True $ takeDirectory x+ act x+ liftIO $ fmap FileA $ getModTimeError ("Error, rule " ++ help ++ " failed to build file:") x_+++-- | Declare a phony action -- an action that does not produce a file, and will be rerun+-- in every execution that requires it. You can demand 'phony' rules using 'want' \/ 'need'.+-- Phony actions are never executed more than once in a single build run.+--+-- Phony actions are intended to define command-line abbreviations. If you 'need' a phony action+-- in a rule then every execution where that rule is required will rerun both the rule and the phony+-- action.+phony :: String -> Action () -> Rules ()+phony name act = rule $ \(FileQ x_) -> let x = unpackU x_ in+ if name /= x then Nothing else Just $ do+ act+ return $ FileA fileTimeNone++-- | Infix operator alias for 'phony', for sake of consistency with normal+-- rules.+(~>) :: String -> Action () -> Rules ()+(~>) = phony +++-- | Define a rule to build files. If the first argument returns 'True' for a given file,+-- the second argument will be used to build it. Usually '*>' is sufficient, but '?>' gives+-- additional power. For any file used by the build system, only one rule should return 'True'.+-- This function will create the directory for the result file, if necessary.+--+-- @+-- (all isUpper . 'Development.Shake.FilePath.takeBaseName') '?>' \\out -> do+-- let src = 'Development.Shake.FilePath.replaceBaseName' out $ map toLower $ takeBaseName out+-- 'Development.Shake.writeFile'' out . map toUpper =<< 'Development.Shake.readFile'' src+-- @+(?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()+(?>) = root "with ?>"+++-- | Define a set of patterns, and if any of them match, run the associated rule. See '*>'.+(**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()+-- Should probably have been called |*>, since it's an or (||) of *>+(**>) test = root "with **>" (\x -> any (?== x) test)++-- | Define a rule that matches a 'FilePattern'. No file required by the system must be+-- matched by more than one pattern. For the pattern rules, see '?=='.+-- This function will create the directory for the result file, if necessary.+--+-- @+-- \"*.asm.o\" '*>' \\out -> do+-- let src = 'Development.Shake.FilePath.dropExtension' out+-- 'need' [src]+-- 'Development.Shake.cmd' \"as\" [src] \"-o\" [out]+-- @+--+-- To define a build system for multiple compiled languages, we recommend using @.asm.o@,+-- @.cpp.o@, @.hs.o@, to indicate which language produces an object file.+-- I.e., the file @foo.cpp@ produces object file @foo.cpp.o@.+--+-- Note that matching is case-sensitive, even on Windows.+(*>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()+(*>) test = root (show test) (test ?==)+++-- | A version of 'newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.+-- Most people should use 'newCache' instead.+newCacheIO :: (FilePath -> IO a) -> IO (FilePath -> Action a)+newCacheIO act = do+ var <- newVar Map.empty -- Var (Map FilePath (Barrier (Either SomeException a)))+ let run = either (\e -> throwIO (e :: SomeException)) return+ return $ \file -> do+ need [file]+ liftIO $ join $ modifyVar var $ \mp -> case Map.lookup file mp of+ Just v -> return (mp, run =<< waitBarrier v)+ Nothing -> do+ v <- newBarrier+ return $ (,) (Map.insert file v mp) $ do+ res <- try $ act file+ signalBarrier v res+ run res+++-- | Given a way of loading information from a file, produce a cached version that will load each file at most once.+-- Using the cached function will still result in a dependency on the original file.+-- The argument function should not access any files other than the one passed as its argument.+-- Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'.+--+-- This function is useful when creating files that store intermediate values,+-- to avoid the overhead of repeatedly reading from disk, particularly if the file requires expensive parsing.+-- As an example:+--+-- @+-- digits \<- 'newCache' $ \\file -> do+-- src \<- readFile file+-- return $ length $ filter isDigit src+-- \"*.digits\" '*>' \\x -> do+-- v1 \<- digits ('dropExtension' x)+-- v2 \<- digits ('dropExtension' x)+-- 'Development.Shake.writeFile'' x $ show (v1,v2)+-- @+--+-- To create the result @MyFile.txt.digits@ the file @MyFile.txt@ will be read and counted, but only at most+-- once per execution.+newCache :: (FilePath -> IO a) -> Rules (FilePath -> Action a)+newCache = rulesIO . newCacheIO
+ Development/Shake/Rules/Files.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}++module Development.Shake.Rules.Files(+ (?>>), (*>>)+ ) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import System.Directory++import Development.Shake.Core+import General.Base+import Development.Shake.Classes+import Development.Shake.Rules.File+import Development.Shake.FilePattern+import Development.Shake.FileTime++import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong+++infix 1 ?>>, *>>+++newtype FilesQ = FilesQ [BSU]+ deriving (Typeable,Eq,Hashable,Binary,NFData)++newtype FilesA = FilesA [FileTime]+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show FilesA where show (FilesA xs) = unwords $ "FileTimeHashes" : map show xs++instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . unpackU) xs+++instance Rule FilesQ FilesA where+ storedValue (FilesQ xs) = fmap (fmap FilesA . sequence) $ mapM getModTimeMaybe xs+++-- | Define a rule for building multiple files at the same time.+-- As an example, a single invokation of GHC produces both @.hi@ and @.o@ files:+--+-- @+-- [\"*.o\",\"*.hi\"] '*>>' \\[o,hi] -> do+-- let hs = o 'Development.Shake.FilePath.-<.>' \"hs\"+-- 'Development.Shake.need' ... -- all files the .hs import+-- 'Development.Shake.cmd' \"ghc -c\" [hs]+-- @+--+-- However, in practice, it's usually easier to define rules with '*>' and make the @.hi@ depend+-- on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must+-- have the same sequence of @\/\/@ and @*@ wildcards in the same order.+-- This function will create directories for the result files, if necessary.+(*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()+-- Should probably have been called &*>, since it's an and (&&) of *>+ps *>> act+ | not $ compatible ps = error $+ "All patterns to *>> must have the same number and position of // and * wildcards\n" +++ unwords ps+ | otherwise = do+ forM_ ps $ \p ->+ p *> \file -> do+ _ :: FilesA <- apply1 $ FilesQ $ map (packU . substitute (extract p file)) ps+ return ()+ rule $ \(FilesQ xs_) -> let xs = map unpackU xs_ in+ if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do+ liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs+ act xs+ liftIO $ getFileTimes "*>>" xs_+++-- | Define a rule for building multiple files at the same time, a more powerful+-- and more dangerous version of '*>>'.+--+-- Given an application @test ?>> ...@, @test@ should return @Just@ if the rule applies, and should+-- return the list of files that will be produced. This list /must/ include the file passed as an argument and should+-- obey the invariant:+--+-- > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys+--+-- As an example of a function satisfying the invariaint:+--+-- @+--test x | 'Development.Shake.FilePath.takeExtension' x \`elem\` [\".hi\",\".o\"]+-- = Just ['Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"hi\", 'Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"o\"]+--test _ = Nothing+-- @+--+-- Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.+(?>>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()+-- Should probably have been called &?>, since it's an and (&&) of ?>+(?>>) test act = do+ let checkedTest x = case test x of+ Nothing -> Nothing+ Just ys | x `elem` ys && all ((== Just ys) . test) ys -> Just ys+ | otherwise -> error $ "Invariant broken in ?>> when trying on " ++ x++ isJust . checkedTest ?> \x -> do+ _ :: FilesA <- apply1 $ FilesQ $ map packU $ fromJust $ test x+ return ()++ rule $ \(FilesQ xs_) -> let xs@(x:_) = map unpackU xs_ in+ case checkedTest x of+ Just ys | ys == xs -> Just $ do+ liftIO $ mapM_ (createDirectoryIfMissing True) $ fastNub $ map takeDirectory xs+ act xs+ liftIO $ getFileTimes "?>>" xs_+ Just ys -> error $ "Error, ?>> is incompatible with " ++ show xs ++ " vs " ++ show ys+ Nothing -> Nothing+++getFileTimes :: String -> [BSU] -> IO FilesA+getFileTimes name xs = do+ ys <- mapM getModTimeMaybe xs+ case sequence ys of+ Just ys -> return $ FilesA ys+ Nothing -> do+ let missing = length $ filter isNothing ys+ error $ "Error, " ++ name ++ " rule failed to build " ++ show missing +++ " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" +++ concat ["\n " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (x,y) <- zip xs ys]
+ Development/Shake/Rules/Oracle.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}+-- Allows the user to violate the functional dependency, but it has a runtime check so still safe+{-# LANGUAGE UndecidableInstances #-}++{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE ConstraintKinds #-}+#endif++module Development.Shake.Rules.Oracle(+ addOracle, askOracle, askOracleWith+ ) where++import Development.Shake.Core+import Development.Shake.Classes+++-- Use should type names, since the names appear in the Haddock, and are too long if they are in full+newtype OracleQ question = OracleQ question+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+newtype OracleA answer = OracleA answer+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)++instance (+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue q, ShakeValue a+#else+ Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,+ Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a+#endif+ ) => Rule (OracleQ q) (OracleA a) where+ storedValue _ = return Nothing+++-- | Add extra information which rules can depend on.+-- An oracle is a function from a question type @q@, to an answer type @a@.+-- As an example, we can define an oracle allowing you to depend on the current version of GHC:+--+-- @+-- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+-- rules = do+-- 'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\"+-- ... rules ...+-- @+--+-- If a rule calls @'askOracle' (GhcVersion ())@, that rule will be rerun whenever the GHC version changes.+-- Some notes:+--+-- * We define @GhcVersion@ with a @newtype@ around @()@, allowing the use of @GeneralizedNewtypeDeriving@.+-- All the necessary type classes are exported from "Development.Shake.Classes".+--+-- * Each call to 'addOracle' must use a different type of question.+--+-- * Actions passed to 'addOracle' will be run in every build they are required,+-- but if their value does not change they will not invalidate any rules depending on them.+-- To get a similar behaviour using data stored in files, see 'Development.Shake.alwaysRerun'.+--+-- * If the value returned by 'askOracle' is ignored then 'askOracleWith' may help avoid ambiguous type messages.+-- Alternatively, use the result of 'addOracle', which is 'askOracle' restricted to the correct type.+--+-- As a more complex example, consider tracking Haskell package versions:+--+-- @+--newtype GhcPkgList = GhcPkgList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+--newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+--+--rules = do+-- getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do+-- Stdout out <- 'Development.Shake.cmd' \"ghc-pkg list --simple-output\"+-- return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]+-- --+-- getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do+-- pkgs <- getPkgList $ GhcPkgList ()+-- return $ lookup pkg pkgs+-- --+-- \"myrule\" *> \\_ -> do+-- getPkgVersion $ GhcPkgVersion \"shake\"+-- ... rule using the shake version ...+-- @+--+-- Using these definitions, any rule depending on the version of @shake@+-- should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.+addOracle :: (+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue q, ShakeValue a+#else+ Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,+ Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a+#endif+ ) => (q -> Action a) -> Rules (q -> Action a)+addOracle act = do+ rule $ \(OracleQ q) -> Just $ fmap OracleA $ act q+ return askOracle+++-- | Get information previously added with 'addOracle'. The question/answer types must match those provided+-- to 'addOracle'.+askOracle :: (+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue q, ShakeValue a+#else+ Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,+ Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a+#endif+ ) => q -> Action a+askOracle question = do OracleA answer <- apply1 $ OracleQ question; return answer++-- | Get information previously added with 'addOracle'. The second argument is not used, but can+-- be useful to fix the answer type, avoiding ambiguous type error messages.+askOracleWith :: (+#if __GLASGOW_HASKELL__ >= 704+ ShakeValue q, ShakeValue a+#else+ Show q, Typeable q, Eq q, Hashable q, Binary q, NFData q,+ Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a+#endif+ ) => q -> a -> Action a+askOracleWith question _ = askOracle question
+ Development/Shake/Rules/OrderOnly.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Development.Shake.Rules.OrderOnly(+ defaultRuleOrderOnly, orderOnly, orderOnlyBS+ ) where++import Development.Shake.Core+import General.Base+import Development.Shake.Classes+import Development.Shake.Rules.File+import qualified Data.ByteString.Char8 as BS+++newtype OrderOnlyQ = OrderOnlyQ BSU+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show OrderOnlyQ where show (OrderOnlyQ x) = unpackU x++newtype OrderOnlyA = OrderOnlyA ()+ deriving (Typeable,Eq,Hashable,Binary,NFData)++instance Show OrderOnlyA where show (OrderOnlyA ()) = "OrderOnly"+++instance Rule OrderOnlyQ OrderOnlyA where+ storedValue (OrderOnlyQ _) = return $ Just $ OrderOnlyA ()+++defaultRuleOrderOnly :: Rules ()+defaultRuleOrderOnly = defaultRule $ \(OrderOnlyQ x) -> Just $ do+ needBS [unpackU_ x]+ return $ OrderOnlyA ()+++-- | Define order-only dependencies, these are dependencies that will always+-- be built before continuing, but which aren't dependencies of this action.+-- Mostly useful for defining generated dependencies you think might be real dependencies.+-- If they turn out to be real dependencies, you should add an explicit dependency afterwards.+--+-- @+-- \"source.o\" *> \\out -> do+-- 'orderOnly' [\"header.h\"]+-- () <- 'cmd' \"gcc -c source.c -o source.o -MMD -MF source.m\"+-- 'neededMakefileDependencies' \"source.m\"+-- @+--+-- If @header.h@ is included by @source.c@ then the call to 'needMakefileDependencies' will cause+-- it to be added as a real dependency. If it isn't, then the rule won't rebuild if it changes,+-- and you will have lost some opportunity for parallelism.+orderOnly :: [FilePath] -> Action ()+orderOnly xs = (apply $ map (OrderOnlyQ . packU) xs :: Action [OrderOnlyA]) >> return ()+++orderOnlyBS :: [BS.ByteString] -> Action ()+orderOnlyBS xs = (apply $ map (OrderOnlyQ . packU_) xs :: Action [OrderOnlyA]) >> return ()
+ Development/Shake/Rules/Rerun.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}++module Development.Shake.Rules.Rerun(+ defaultRuleRerun, alwaysRerun+ ) where++import Development.Shake.Core+import Development.Shake.Classes+++newtype AlwaysRerunQ = AlwaysRerunQ ()+ deriving (Typeable,Eq,Hashable,Binary,NFData)+instance Show AlwaysRerunQ where show _ = "alwaysRerun"++newtype AlwaysRerunA = AlwaysRerunA ()+ deriving (Typeable,Hashable,Binary,NFData)+instance Show AlwaysRerunA where show _ = "<none>"+instance Eq AlwaysRerunA where a == b = False++instance Rule AlwaysRerunQ AlwaysRerunA where+ storedValue _ = return Nothing+++-- | Always rerun the associated action. Useful for defining rules that query+-- the environment. For example:+--+-- @+-- \"ghcVersion.txt\" 'Development.Shake.*>' \\out -> do+-- 'alwaysRerun'+-- 'Development.Shake.Stdout' stdout <- 'Development.Shake.cmd' \"ghc --numeric-version\"+-- 'Development.Shake.writeFileChanged' out stdout+-- @+alwaysRerun :: Action ()+alwaysRerun = do AlwaysRerunA _ <- apply1 $ AlwaysRerunQ (); return ()++defaultRuleRerun :: Rules ()+defaultRuleRerun = defaultRule $ \AlwaysRerunQ{} -> Just $ return $ AlwaysRerunA()
Development/Shake/Shake.hs view
@@ -3,12 +3,13 @@ module Development.Shake.Shake(shake) where import Development.Shake.Types-import Development.Shake.Timing+import General.Timing import Development.Shake.Core -import Development.Shake.Directory-import Development.Shake.File-import Development.Shake.Rerun+import Development.Shake.Rules.Directory+import Development.Shake.Rules.File+import Development.Shake.Rules.OrderOnly+import Development.Shake.Rules.Rerun -- | Main entry point for running Shake build systems. For an example see the top of the module "Development.Shake".@@ -23,5 +24,6 @@ r defaultRuleFile defaultRuleDirectory+ defaultRuleOrderOnly defaultRuleRerun return ()
Development/Shake/Storage.hs view
@@ -9,10 +9,10 @@ withStorage ) where -import Development.Shake.Binary-import Development.Shake.Util+import General.Binary+import General.Base import Development.Shake.Types-import Development.Shake.Timing+import General.Timing import Control.Arrow import Control.Exception as E@@ -25,12 +25,14 @@ import Development.Shake.Classes import qualified Data.HashMap.Strict as Map import Data.List+import Numeric import System.Directory import System.Exit import System.FilePath import System.IO import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.ByteString.Lazy as LBS8 type Map = Map.HashMap@@ -47,7 +49,7 @@ withStorage- :: (Eq w, Eq k, Hashable k+ :: (Show w, Show k, Show v, Eq w, Eq k, Hashable k ,Binary w, BinaryWith w k, BinaryWith w v) => ShakeOptions -- ^ Storage options -> (String -> IO ()) -- ^ Logging function@@ -104,17 +106,32 @@ -- add back to check during random testing return $ continue h Map.empty) $ case readChunks $ LBS.drop (LBS.length ver) src of- (slop, []) -> do- when (slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n"+ ([], slop) -> do+ when (LBS.length slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n" diagnostic $ "Read 0 chunks, plus " ++ show slop ++ " slop" return $ continue h Map.empty- (slop, w:xs) -> do+ (w:xs, slopRaw) -> do+ let slop = fromIntegral $ LBS.length slopRaw when (slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n" diagnostic $ "Read " ++ show (length xs + 1) ++ " chunks, plus " ++ show slop ++ " slop"- diagnostic $ "Chunk sizes " ++ show (map LBS.length (w:xs)) let ws = decode w f mp (k, v) = Map.insert k v mp- mp = foldl' f Map.empty $ map (runGet $ getWith ws) xs+ ents = map (runGet $ getWith ws) xs+ mp = foldl' f Map.empty ents++ when (shakeVerbosity == Diagnostic) $ do+ let raw x = "[len " ++ show (LBS.length x) ++ "] " ++ concat+ [['0' | length c == 1] ++ c | x <- LBS8.unpack x, let c = showHex x ""]+ let pretty (Left x) = "FAILURE: " ++ show (x :: SomeException)+ pretty (Right x) = x+ diagnostic $ "Witnesses " ++ raw w+ forM_ (zip3 [1..] xs ents) $ \(i,x,ent) -> do+ x2 <- try $ evaluate $ let s = show ent in rnf s `seq` s+ diagnostic $ "Chunk " ++ show i ++ " " ++ raw x ++ " " ++ pretty x2+ diagnostic $ "Slop " ++ raw slopRaw++ diagnostic $ "Found " ++ show (Map.size mp) ++ " real entries"+ -- if mp is null, continue will reset it, so no need to clean up if Map.null mp || (ws == witness && Map.size mp * 2 > length xs - 2) then do -- make sure we reset to before the slop@@ -167,53 +184,49 @@ when (Map.null mp) $ reset h mp -- might as well, no data to lose, and need to ensure a good witness table -- also lets us recover in the case of corruption- flushThread outputErr shakeFlush h $ \out -> do+ flushThread shakeFlush h $ \out -> do addTiming "With database" act mp $ \k v -> out $ toChunk $ runPut $ putWith witness (k, v) -- We avoid calling flush too often on SSD drives, as that can be slow--- Do not move writes to a separate thread, as then we'd have to marshal exceptions back which is tricky-flushThread :: (String -> IO ()) -> Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a-flushThread outputErr flush h act = do- alive <- newVar True- kick <- newEmptyMVar+-- Make sure all exceptions happen on the caller, so we don't have to move exceptions back+-- Make sure we only write on one thread, otherwise async exceptions can cause partial writes+flushThread :: Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a+flushThread flush h act = do+ chan <- newChan -- operations to perform on the file+ kick <- newEmptyMVar -- kicked whenever something is written+ died <- newBarrier -- has the writing thread finished - lock <- newLock- case flush of- Nothing -> return ()- Just flush -> do- let delay = ceiling $ flush * 1000000- let loop = do- takeMVar kick- threadDelay delay- b <- withVar alive $ \b -> do- when b $ do- tryTakeMVar kick- withLock lock $ hFlush h- return b- when b loop- forkIO $ do- let msg = "Warning: Flushing Shake journal failed, on abnormal termination you may lose some data, "- (loop >> return ()) `E.catch` \(e :: SomeException) -> outputErr $ msg ++ show e ++ "\n"- return ()+ flusher <- case flush of+ Nothing -> return Nothing+ Just flush -> fmap Just $ forkIO $ forever $ do+ takeMVar kick+ threadDelay $ ceiling $ flush * 1000000+ tryTakeMVar kick+ writeChan chan $ hFlush h >> return True + root <- myThreadId+ writer <- forkIO $ handle (\(e :: SomeException) -> signalBarrier died () >> throwTo root e) $+ -- only one thread ever writes, ensuring only the final write can be torn+ whileM $ join $ readChan chan+ (act $ \s -> do- withLock lock $ LBS.hPut h s- tryPutMVar kick ()- return ())+ evaluate $ LBS.length s -- ensure exceptions occur on this thread+ writeChan chan $ LBS.hPut h s >> tryPutMVar kick () >> return True) `finally` do- modifyVar_ alive $ const $ return False- tryPutMVar kick ()+ maybe (return ()) killThread flusher+ writeChan chan $ signalBarrier died () >> return False+ waitBarrier died -- Return the amount of junk at the end, along with all the chunk-readChunks :: LBS.ByteString -> (Integer, [LBS.ByteString])+readChunks :: LBS.ByteString -> ([LBS.ByteString], LBS.ByteString) readChunks x | Just (n, x) <- grab 4 x , Just (y, x) <- grab (fromIntegral (decode n :: Word32)) x- = second (y :) $ readChunks x- | otherwise = (toInteger $ LBS.length x, [])+ = first (y :) $ readChunks x+ | otherwise = ([], x) where grab i x | LBS.length a == i = Just (a, b) | otherwise = Nothing
Development/Shake/Sys.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators #-} --- | /Warning: I intend to remove this module. Please use 'command' or 'cmd' instead./+-- | /Deprecated: Please use command or cmd instead. This module will be removed in a future version./ -- -- This module provides versions of the 'Development.Shake.Derived.system'' family of functions -- which take a variable number of arguments.
− Development/Shake/Timing.hs
@@ -1,58 +0,0 @@--module Development.Shake.Timing(resetTimings, addTiming, printTimings) where--import Control.Arrow-import Data.IORef-import Data.Time-import System.IO.Unsafe-import Numeric---{-# NOINLINE timings #-}-timings :: IORef [(UTCTime, String)] -- number of times called, newest first-timings = unsafePerformIO $ newIORef []---resetTimings :: IO ()-resetTimings = do- now <- getCurrentTime- writeIORef timings [(now, "Start")]----- | Print all withTiming information and clear the information.-printTimings :: IO ()-printTimings = do- now <- getCurrentTime- old <- atomicModifyIORef timings $ \ts -> ([(now, "Start")], ts)- putStr $ unlines $ showTimings now $ reverse old---addTiming :: String -> IO ()-addTiming msg = do- now <- getCurrentTime- atomicModifyIORef timings $ \ts -> ((now,msg):ts, ())---showTimings :: UTCTime -> [(UTCTime, String)] -> [String]-showTimings _ [] = []-showTimings stop times = showGap $- [(a ++ " ", showDP 3 b ++ "s " ++ showPerc b ++ " " ++ progress b) | (a,b) <- xs] ++- [("Total", showDP 3 sm ++ "s " ++ showPerc sm ++ " " ++ replicate 25 ' ')]- where- a // b = if b == 0 then 0 else a / b- showPerc x = let s = show $ floor $ x * 100 // sm in replicate (3 - length s) ' ' ++ s ++ "%"- progress x = let i = floor $ x * 25 // mx in replicate i '=' ++ replicate (25-i) ' '- mx = maximum $ map snd xs- sm = sum $ map snd xs- xs = [ (name, fromRational $ toRational $ stop `diffUTCTime` start)- | ((start, name), stop) <- zip times $ map fst (drop 1 times) ++ [stop]]---showGap :: [(String,String)] -> [String]-showGap xs = [a ++ replicate (n - length a - length b) ' ' ++ b | (a,b) <- xs]- where n = maximum [length a + length b | (a,b) <- xs]---showDP :: Int -> Double -> String-showDP n x = a ++ "." ++ b ++ replicate (n - length b) '0'- where (a,b) = second (drop 1) $ break (== '.') $ showFFloat (Just n) x ""
Development/Shake/Types.hs view
@@ -47,6 +47,7 @@ {shakeFiles :: FilePath -- ^ Defaults to @.shake@. The prefix of the filename used for storing Shake metadata files. -- All metadata files will be named @'shakeFiles'./extension/@, for some @/extension/@.+ -- If the 'shakeFiles' directory does not exist it will be created. ,shakeThreads :: Int -- ^ Defaults to @1@. Maximum number of rules to run in parallel, similar to @make --jobs=/N/@. -- For many build systems, a number equal to or slightly less than the number of physical processors@@ -84,7 +85,10 @@ ,shakeLineBuffering :: Bool -- ^ Defaults to 'True'. Change 'stdout' and 'stderr' to line buffering while running Shake. ,shakeTimings :: Bool- -- ^ Default to 'False'. Print timing information for each stage at the end.+ -- ^ Defaults to 'False'. Print timing information for each stage at the end.+ ,shakeRunCommands :: Bool+ -- ^ Default to 'True'. Should you run command line actions, set to 'False' to skip actions whose output streams and exit code+ -- are not used. Useful for profiling the non-command portion of the build system. ,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.@@ -99,22 +103,23 @@ -- | The default set of 'ShakeOptions'. shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False (Just 10) Nothing [] False True False+shakeOptions = ShakeOptions ".shake" 1 "1" Normal False Nothing False (Just 10) Nothing [] False True False True (const $ return ()) (const $ BS.putStrLn . BS.pack) -- try and output atomically using BS fieldsShakeOptions = ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport" ,"shakeLint", "shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog"- ,"shakeLineBuffering", "shakeTimings", "shakeProgress", "shakeOutput"]+ ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "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 = ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 (fromFunction x14) (fromFunction x15)+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 =+ ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 (fromFunction x15) (fromFunction x16) instance Data ShakeOptions where- gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15) =- 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` Function x14 `k` Function x15- gunfold k z c = 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) =+ 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` Function x15 `k` Function x16+ gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions @@ -156,7 +161,7 @@ = Silent -- ^ Don't print any messages. | Quiet -- ^ Only print essential messages, typically errors. | Normal -- ^ Print errors and @# /command-name/ /file-name/@ when running a 'Development.Shake.traced' command.- | Loud -- ^ Print errors and full command lines when running a 'Development.Shake.system'' command.+ | Loud -- ^ Print errors and full command lines when running a 'Development.Shake.command' or 'Development.Shake.cmd' command. | Chatty -- ^ Print errors, full command line and status messages when starting a rule. | Diagnostic -- ^ Print messages for virtually everything (mostly for debugging). deriving (Eq,Ord,Bounded,Enum,Show,Read,Typeable,Data)
Development/Shake/Util.hs view
@@ -1,209 +1,34 @@-{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} +-- | A module for useful utility functions for Shake build systems. module Development.Shake.Util(- Lock, newLock, withLock, withLockTry,- Var, newVar, readVar, modifyVar, modifyVar_, withVar,- Barrier, newBarrier, signalBarrier, waitBarrier,- Duration, duration, Time, offsetTime, sleep,- modifyIORef'', writeIORef'',- whenJust, loop,- fastNub, showQuote,- BS, pack, unpack, pack_, unpack_,- BSU, packU, unpackU, packU_, unpackU_, requireU+ parseMakefile, needMakefileDependencies, neededMakefileDependencies ) where -import Control.Concurrent-import Control.Exception-import Data.Char-import Data.IORef-import Data.Time-import qualified Data.ByteString as BS (any)-import qualified Data.ByteString.Char8 as BS hiding (any)-import qualified Data.ByteString.UTF8 as UTF8-import qualified Data.HashSet as Set-import Development.Shake.Classes--------------------------------------------------------------------------- LOCK---- | Like an MVar, but has no value-newtype Lock = Lock (MVar ())-instance Show Lock where show _ = "Lock"--newLock :: IO Lock-newLock = fmap Lock $ newMVar ()--withLock :: Lock -> IO a -> IO a-withLock (Lock x) = withMVar x . const--withLockTry :: Lock -> IO a -> IO (Maybe a)-withLockTry (Lock m) act =- mask $ \restore -> do- a <- tryTakeMVar m- case a of- Nothing -> return Nothing- Just _ -> restore (fmap Just act) `finally` putMVar m ()--------------------------------------------------------------------------- VAR---- | Like an MVar, but must always be full-newtype Var a = Var (MVar a)-instance Show (Var a) where show _ = "Var"--newVar :: a -> IO (Var a)-newVar = fmap Var . newMVar--readVar :: Var a -> IO a-readVar (Var x) = readMVar x--modifyVar :: Var a -> (a -> IO (a, b)) -> IO b-modifyVar (Var x) f = modifyMVar x f--modifyVar_ :: Var a -> (a -> IO a) -> IO ()-modifyVar_ (Var x) f = modifyMVar_ x f--withVar :: Var a -> (a -> IO b) -> IO b-withVar (Var x) f = withMVar x f--------------------------------------------------------------------------- BARRIER---- | Starts out empty, then is filled exactly once-newtype Barrier a = Barrier (MVar a)-instance Show (Barrier a) where show _ = "Barrier"--newBarrier :: IO (Barrier a)-newBarrier = fmap Barrier newEmptyMVar--signalBarrier :: Barrier a -> a -> IO ()-signalBarrier (Barrier x) = putMVar x--waitBarrier :: Barrier a -> IO a-waitBarrier (Barrier x) = readMVar x--------------------------------------------------------------------------- Data.Time--type Time = Double -- how far you are through this run, in seconds---- | Call once at the start, then call repeatedly to get Time values out-offsetTime :: IO (IO Time)-offsetTime = do- start <- getCurrentTime- return $ do- end <- getCurrentTime- return $ fromRational $ toRational $ end `diffUTCTime` start---type Duration = Double -- duration in seconds--duration :: IO a -> IO (Duration, a)-duration act = do- time <- offsetTime- res <- act- time <- time- return (time, res)---sleep :: Duration -> IO ()-sleep x = threadDelay $ ceiling $ x * 1000000--------------------------------------------------------------------------- Data.IORef---- Two 's because GHC 7.6 has a strict modifyIORef-modifyIORef'' :: IORef a -> (a -> a) -> IO ()-modifyIORef'' ref f = do- x <- readIORef ref- writeIORef'' ref $ f x--writeIORef'' :: IORef a -> a -> IO ()-writeIORef'' ref !x = writeIORef ref x--------------------------------------------------------------------------- Data.List---- | Like 'nub', but the results may be in any order.-fastNub :: (Eq a, Hashable a) => [a] -> [a]-fastNub = f Set.empty- where f seen [] = []- f seen (x:xs) | x `Set.member` seen = f seen xs- | otherwise = x : f (Set.insert x seen) xs---showQuote :: String -> String-showQuote xs | any isSpace xs = "\"" ++ concatMap (\x -> if x == '\"' then "\"\"" else [x]) xs ++ "\""- | otherwise = xs--------------------------------------------------------------------------- Control.Monad--whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()-whenJust (Just a) f = f a-whenJust Nothing f = return ()--loop :: Monad m => (a -> m (Either a b)) -> a -> m b-loop act x = do- res <- act x- case res of- Left x -> loop act x- Right v -> return v+import Development.Shake+import Development.Shake.Rules.File+import qualified Data.ByteString.Char8 as BS+import qualified Development.Shake.ByteString as BS+import Control.Arrow ------------------------------------------------------------------------- Data.ByteString--- Mostly because ByteString does not have an NFData instance in older GHC---- | ASCII ByteString-newtype BS = BS BS.ByteString- deriving (Hashable, Binary, Eq)--instance NFData BS where- -- some versions of ByteString do not have NFData instances, but seq is equivalent- -- for a strict bytestring. Therefore, we write our own instance.- rnf (BS x) = x `seq` ()+-- | Given the text of a Makefile, extract the list of targets and dependencies. Assumes a+-- small subset of Makefile syntax, mostly that generated by @gcc -MM@.+--+-- > parseMakefile "a: b c\nd : e" == [("a",["b","c"]),("d",["e"])]+parseMakefile :: String -> [(FilePath, [FilePath])]+parseMakefile = map (BS.unpack *** map BS.unpack) . BS.parseMakefile . BS.pack --- | UTF8 ByteString-newtype BSU = BSU BS.ByteString- deriving (Hashable, Binary, Eq)--instance NFData BSU where- rnf (BSU x) = x `seq` ()-+-- | Depend on the dependencies listed in a Makefile. Does not depend on the Makefile itself.+--+-- > needMakefileDependencies file = need . concatMap snd . parseMakefile =<< liftIO (readFile file)+needMakefileDependencies :: FilePath -> Action ()+needMakefileDependencies file = needBS . concatMap snd . BS.parseMakefile =<< liftIO (BS.readFile file) -pack :: String -> BS-pack = pack_ . BS.pack--unpack :: BS -> String-unpack = BS.unpack . unpack_--pack_ :: BS.ByteString -> BS-pack_ = BS--unpack_ :: BS -> BS.ByteString-unpack_ (BS x) = x--packU :: String -> BSU-packU = packU_ . UTF8.fromString--unpackU :: BSU -> String-unpackU = UTF8.toString . unpackU_--unpackU_ :: BSU -> BS.ByteString-unpackU_ (BSU x) = x--packU_ :: BS.ByteString -> BSU-packU_ = BSU--requireU :: BSU -> Bool-requireU = BS.any (>= 0x80) . unpackU_+-- | Depend on the dependencies listed in a Makefile. Does not depend on the Makefile itself.+-- Use this function to indicate that you have /already/ used the files in question.+--+-- > neededMakefileDependencies file = needed . concatMap snd . parseMakefile =<< liftIO (readFile file)+neededMakefileDependencies :: FilePath -> Action ()+neededMakefileDependencies file = neededBS . concatMap snd . BS.parseMakefile =<< liftIO (BS.readFile file)
Development/Shake/Value.hs view
@@ -9,7 +9,7 @@ Witness, currentWitness, registerWitness ) where -import Development.Shake.Binary+import General.Binary import Development.Shake.Classes import Development.Shake.Errors import Data.Typeable@@ -90,7 +90,7 @@ {typeNames :: [String] -- the canonical data, the names of the types ,witnessIn :: Map.HashMap Word16 Value -- for reading in, the find the values (some may be missing) ,witnessOut :: Map.HashMap TypeRep Word16 -- for writing out, find the value- }+ } deriving Show instance Eq Witness where -- Type names are produced by toStableList so should to remain consistent
Examples/Ninja/Main.hs view
@@ -18,7 +18,9 @@ test build obj = do- let run xs = build $ map ('@':) $ words xs+ 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"@@ -46,3 +48,7 @@ run "-f../../Examples/Ninja/test5.ninja" assertExists $ obj "output file"++ 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"
+ Examples/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 +build bad.gen: gen
Examples/Test/Command.hs view
@@ -2,9 +2,6 @@ module Examples.Test.Command(main) where -import Control.Exception hiding (assert)-import Control.Monad-import Data.List import Development.Shake import Examples.Util @@ -37,17 +34,12 @@ "env" !> do (Exit _, Stdout out1) <- cmd (Env [("FOO","HELLO SHAKE")]) Shell "echo %FOO%"- (Exit _, Stdout out2) <- 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 = do- res <- try $ build $ "--quiet" : args- case res of- Left (err :: SomeException) -> let s = show err in forM_ parts $ \p ->- assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p- Right _ -> error "Expected an exception but succeeded"+ let crash args parts = assertException parts (build $ "--quiet" : args) build ["ghc-version"] assertContentsInfix (obj "ghc-version") "The Glorious Glasgow Haskell Compilation System"
Examples/Test/Docs.hs view
@@ -5,9 +5,12 @@ 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)@@ -21,7 +24,12 @@ index *> \_ -> do xs <- getDirectoryFiles "Development" ["//*.hs"] need $ map ("Development" </>) xs- cmd "cabal haddock"+ 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@@ -46,6 +54,7 @@ ,"import Data.Monoid" ,"import Development.Shake" ,"import Development.Shake.Classes"+ ,"import Development.Shake.Util" ,"import System.Console.GetOpt" ,"import System.Exit" ,"import System.IO"@@ -67,6 +76,8 @@ ,"instance Eq (OptDescr a)" ,"inputs = [\"\"]" ,"output = \"\""+ ,"(foo,bar,baz) = undefined"+ ,"((/./),(/../),(//)) = undefined" ] ++ rest @@ -152,6 +163,7 @@ "ConstraintKinds GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " ++ "NoProgress Error " ++ ".make/i586-linux-gcc/output _make/.database foo/.. file.src file.out " +++ "/usr/special /usr/special/userbinary $CFLAGS -O2 header.h source.c " ++ "-threaded -rtsopts -I0 Function extension $OUT $PATH xterm $TERM main opts result flagValues argValues " = True whitelist x = x `elem`@@ -164,6 +176,7 @@ ,"# command-name file-name" ,"ghc --make MyBuildSystem -rtsopts \"-with-rtsopts=-I0 -qg -qb\"" ,"-qg -qb"+ ,"gcc -MM" ] types = words $
Examples/Test/Errors.hs view
@@ -4,9 +4,7 @@ import Development.Shake import Examples.Util-import Control.Exception hiding (assert) import Control.Monad-import Data.List import System.Directory as IO @@ -52,12 +50,7 @@ test build obj = do- let crash args parts = do- res <- try $ build $ "--quiet" : args- case res of- Left (err :: SomeException) -> let s = show err in forM_ parts $ \p ->- assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p- Right _ -> error "Expected an exception but succeeded"+ let crash args parts = assertException parts (build $ "--quiet" : args) crash ["norule"] ["norule_isavailable"] crash ["failcreate"] ["failcreate"]
Examples/Test/FilePath.hs view
@@ -2,20 +2,75 @@ 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- normalise "neil//./test/moo/../bar/bob/../foo" === "neil/test/bar/foo"- normalise "bar/foo" === "bar/foo"- normalise "bar/foo/" === "bar/foo/"- normalise "../../foo" === "../../foo"- normalise "foo/bar/../../neil" === "neil"- normalise "foo/../bar/../neil" === "neil"+ 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" === ""@@ -28,3 +83,6 @@ combine "aaa/bbb" "ccc" === "aaa/bbb/ccc" combine "aaa/bbb" "./ccc" === "aaa/bbb/ccc" combine "aaa/bbb" "../ccc" === "aaa/ccc"++ searchPathSeparator === Native.searchPathSeparator+ pathSeparators === Posix.pathSeparators
Examples/Test/Lint.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE ScopedTypeVariables #-} module Examples.Test.Lint(main) where @@ -6,8 +5,6 @@ import Development.Shake.FilePath import Examples.Util import Control.Exception hiding (assert)-import Control.Monad-import Data.List import System.Directory as IO @@ -57,15 +54,23 @@ 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 ""+ test build obj = do dir <- getCurrentDirectory let crash args parts = do- res <- try $ build $ "--quiet" : args- setCurrentDirectory dir- case res of- Left (err :: SomeException) -> let s = show err in forM_ parts $ \p ->- assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p- Right _ -> error "Expected an exception but succeeded"+ assertException parts (build $ "--quiet" : args)+ `finally` setCurrentDirectory dir crash ["changedir"] ["current directory has changed"] build ["cdir.1","cdir.2","-j1"]@@ -75,3 +80,5 @@ 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"]
Examples/Test/Oracle.hs view
@@ -4,9 +4,7 @@ import Development.Shake import Examples.Util-import Control.Exception import Control.Monad-import Data.List main = shaken test $ \args obj -> do@@ -51,13 +49,7 @@ assertContents (obj "rerun") "bar" -- check error messages are good- let errors args err = do- r <- try $ build $ "--quiet" : args- case r of- Right _ -> error $ "Expected to fail but succeeded, wanted: " ++ err- Left (msg :: SomeException)- | err `isInfixOf` show msg -> return ()- | otherwise -> error $ "Bad error message, wanted: " ++ err ++ ", got: " ++ show msg+ 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
+ Examples/Test/OrderOnly.hs view
@@ -0,0 +1,41 @@++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/Throttle.hs view
@@ -2,7 +2,7 @@ module Examples.Test.Throttle(main) where import Development.Shake-import Development.Shake.Util+import General.Base import Development.Shake.FilePath import Examples.Util import Control.Monad
Examples/Test/Unicode.hs view
@@ -5,6 +5,7 @@ import Development.Shake import Development.Shake.FilePath import Examples.Util+import Control.Exception import Control.Monad import System.Directory(createDirectoryIfMissing) @@ -37,19 +38,24 @@ writeFile' m2 $ show b -test build obj = {- handle (\e -> print (e :: SomeException) >> error "dead") $ -} do+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- writeFile (ext "source") "x"- build [pre,pre <.> "out","--sleep"]- assertContents (ext "out") $ "x" ++ "False"- writeFile (ext "source") "y"- build [pre,pre <.> "out","--sleep"]- assertContents (ext "out") $ "y" ++ "False"- writeFile (ext "exist") ""- build [pre,pre <.> "out"]- assertContents (ext "out") $ "y" ++ "True"+ 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 view
@@ -0,0 +1,18 @@++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 view
@@ -0,0 +1,39 @@++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 view
@@ -2,9 +2,10 @@ module Examples.Util(sleep, module Examples.Util) where import Development.Shake-import Development.Shake.Util+import General.Base import Development.Shake.FilePath +import Control.Exception hiding (assert) import Control.Monad import Data.Char import Data.List@@ -112,7 +113,15 @@ 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"]@@ -156,14 +165,3 @@ return $ files++rest where isBadDir x = "." `isPrefixOf` x || "_" `isPrefixOf` x--partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])-partitionM f [] = return ([], [])-partitionM f (x:xs) = do- res <- f x- (as,bs) <- partitionM f xs- return $ if res then (x:as,bs) else (as,x:bs)--concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f = liftM concat . mapM f-
+ General/Base.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, CPP #-}++module General.Base(+ Lock, newLock, withLock, withLockTry,+ Var, newVar, readVar, modifyVar, modifyVar_, withVar,+ Barrier, newBarrier, signalBarrier, waitBarrier,+ Duration, duration, Time, offsetTime, sleep,+ isWindows,+ modifyIORef'', writeIORef'',+ whenJust, loop, whileM, partitionM, concatMapM,+ fastNub, showQuote,+ BS, pack, unpack, pack_, unpack_,+ BSU, packU, unpackU, packU_, unpackU_, requireU+ ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Char+import Data.IORef+import Data.Time+import qualified Data.ByteString as BS (any)+import qualified Data.ByteString.Char8 as BS hiding (any)+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.HashSet as Set+import Development.Shake.Classes+++---------------------------------------------------------------------+-- LOCK++-- | Like an MVar, but has no value+newtype Lock = Lock (MVar ())+instance Show Lock where show _ = "Lock"++newLock :: IO Lock+newLock = fmap Lock $ newMVar ()++withLock :: Lock -> IO a -> IO a+withLock (Lock x) = withMVar x . const++withLockTry :: Lock -> IO a -> IO (Maybe a)+withLockTry (Lock m) act =+ mask $ \restore -> do+ a <- tryTakeMVar m+ case a of+ Nothing -> return Nothing+ Just _ -> restore (fmap Just act) `finally` putMVar m ()+++---------------------------------------------------------------------+-- VAR++-- | Like an MVar, but must always be full+newtype Var a = Var (MVar a)+instance Show (Var a) where show _ = "Var"++newVar :: a -> IO (Var a)+newVar = fmap Var . newMVar++readVar :: Var a -> IO a+readVar (Var x) = readMVar x++modifyVar :: Var a -> (a -> IO (a, b)) -> IO b+modifyVar (Var x) f = modifyMVar x f++modifyVar_ :: Var a -> (a -> IO a) -> IO ()+modifyVar_ (Var x) f = modifyMVar_ x f++withVar :: Var a -> (a -> IO b) -> IO b+withVar (Var x) f = withMVar x f+++---------------------------------------------------------------------+-- BARRIER++-- | Starts out empty, then is filled exactly once+newtype Barrier a = Barrier (MVar a)+instance Show (Barrier a) where show _ = "Barrier"++newBarrier :: IO (Barrier a)+newBarrier = fmap Barrier newEmptyMVar++signalBarrier :: Barrier a -> a -> IO ()+signalBarrier (Barrier x) = putMVar x++waitBarrier :: Barrier a -> IO a+waitBarrier (Barrier x) = readMVar x+++---------------------------------------------------------------------+-- Data.Time++type Time = Double -- how far you are through this run, in seconds++-- | Call once at the start, then call repeatedly to get Time values out+offsetTime :: IO (IO Time)+offsetTime = do+ start <- getCurrentTime+ return $ do+ end <- getCurrentTime+ return $ fromRational $ toRational $ end `diffUTCTime` start+++type Duration = Double -- duration in seconds++duration :: IO a -> IO (Duration, a)+duration act = do+ time <- offsetTime+ res <- act+ time <- time+ return (time, res)+++sleep :: Duration -> IO ()+sleep x = threadDelay $ ceiling $ x * 1000000+++---------------------------------------------------------------------+-- Data.IORef++-- Two 's because GHC 7.6 has a strict modifyIORef+modifyIORef'' :: IORef a -> (a -> a) -> IO ()+modifyIORef'' ref f = do+ x <- readIORef ref+ writeIORef'' ref $ f x++writeIORef'' :: IORef a -> a -> IO ()+writeIORef'' ref !x = writeIORef ref x+++---------------------------------------------------------------------+-- Data.List++-- | Like 'nub', but the results may be in any order.+fastNub :: (Eq a, Hashable a) => [a] -> [a]+fastNub = f Set.empty+ where f seen [] = []+ f seen (x:xs) | x `Set.member` seen = f seen xs+ | otherwise = x : f (Set.insert x seen) xs+++showQuote :: String -> String+showQuote xs | any isSpace xs = "\"" ++ concatMap (\x -> if x == '\"' then "\"\"" else [x]) xs ++ "\""+ | otherwise = xs+++---------------------------------------------------------------------+-- Control.Monad++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust (Just a) f = f a+whenJust Nothing f = return ()++loop :: Monad m => (a -> m (Either a b)) -> a -> m b+loop act x = do+ res <- act x+ case res of+ Left x -> loop act x+ Right v -> return v++whileM :: Monad m => m Bool -> m ()+whileM act = do+ b <- act+ when b $ whileM act++concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]+concatMapM f xs = liftM concat $ mapM f xs++partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM f [] = return ([], [])+partitionM f (x:xs) = do+ t <- f x+ (a,b) <- partitionM f xs+ return $ if t then (x:a,b) else (a,x:b)++++---------------------------------------------------------------------+-- System.Info++isWindows :: Bool+#if defined(mingw32_HOST_OS)+isWindows = True+#else+isWindows = False+#endif+++---------------------------------------------------------------------+-- Data.ByteString+-- Mostly because ByteString does not have an NFData instance in older GHC++-- | ASCII ByteString+newtype BS = BS BS.ByteString+ deriving (Hashable, Binary, Eq)++instance Show BS where+ show (BS x) = show x++instance NFData BS where+ -- some versions of ByteString do not have NFData instances, but seq is equivalent+ -- for a strict bytestring. Therefore, we write our own instance.+ rnf (BS x) = x `seq` ()+++-- | UTF8 ByteString+newtype BSU = BSU BS.ByteString+ deriving (Hashable, Binary, Eq)++instance NFData BSU where+ rnf (BSU x) = x `seq` ()++++pack :: String -> BS+pack = pack_ . BS.pack++unpack :: BS -> String+unpack = BS.unpack . unpack_++pack_ :: BS.ByteString -> BS+pack_ = BS++unpack_ :: BS -> BS.ByteString+unpack_ (BS x) = x++packU :: String -> BSU+packU = packU_ . UTF8.fromString++unpackU :: BSU -> String+unpackU = UTF8.toString . unpackU_++unpackU_ :: BSU -> BS.ByteString+unpackU_ (BSU x) = x++packU_ :: BS.ByteString -> BSU+packU_ = BSU++requireU :: BSU -> Bool+requireU = BS.any (>= 0x80) . unpackU_
+ General/Binary.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++module General.Binary(+ BinaryWith(..), module Data.Binary+ ) where++import Control.Monad+import Data.Binary++class BinaryWith ctx a where+ putWith :: ctx -> a -> Put+ getWith :: ctx -> Get a++instance (BinaryWith ctx a, BinaryWith ctx b) => BinaryWith ctx (a,b) where+ putWith ctx (a,b) = putWith ctx a >> putWith ctx b+ getWith ctx = do a <- getWith ctx; b <- getWith ctx; return (a,b)++instance BinaryWith ctx a => BinaryWith ctx [a] where+ putWith ctx xs = put (length xs) >> mapM_ (putWith ctx) xs+ getWith ctx = do n <- get; replicateM n $ getWith ctx++instance BinaryWith ctx a => BinaryWith ctx (Maybe a) where+ putWith ctx Nothing = putWord8 0+ putWith ctx (Just x) = putWord8 1 >> putWith ctx x+ getWith ctx = do i <- getWord8; if i == 0 then return Nothing else fmap Just $ getWith ctx
+ General/Intern.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}++module General.Intern(+ Intern, Id,+ empty, insert, add, lookup, toList, fromList+ ) where++import General.Binary+import Development.Shake.Classes+import Prelude hiding (lookup)+import qualified Data.HashMap.Strict as Map+import Data.List(foldl')+++-- Invariant: The first field is the highest value in the Map+data Intern a = Intern {-# UNPACK #-} !Word32 !(Map.HashMap a Id)++newtype Id = Id Word32+ deriving (Eq,Hashable,Binary,Show,NFData)++instance BinaryWith w Id where+ putWith ctx = put+ getWith ctx = get+++empty :: Intern a+empty = Intern 0 Map.empty+++insert :: (Eq a, Hashable a) => a -> Id -> Intern a -> Intern a+insert k v@(Id i) (Intern n mp) = Intern (max n i) $ Map.insert k v mp+++add :: (Eq a, Hashable a) => a -> Intern a -> (Intern a, Id)+add k (Intern v mp) = (Intern v2 $ Map.insert k (Id v2) mp, Id v2)+ where v2 = v + 1+++lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id+lookup k (Intern n mp) = Map.lookup k mp+++toList :: Intern a -> [(a, Id)]+toList (Intern a b) = Map.toList b+++fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a+fromList xs = Intern (foldl' max 0 [i | (_, Id i) <- xs]) (Map.fromList xs)
+ General/Timing.hs view
@@ -0,0 +1,58 @@++module General.Timing(resetTimings, addTiming, printTimings) where++import Control.Arrow+import Data.IORef+import Data.Time+import System.IO.Unsafe+import Numeric+++{-# NOINLINE timings #-}+timings :: IORef [(UTCTime, String)] -- number of times called, newest first+timings = unsafePerformIO $ newIORef []+++resetTimings :: IO ()+resetTimings = do+ now <- getCurrentTime+ writeIORef timings [(now, "Start")]+++-- | Print all withTiming information and clear the information.+printTimings :: IO ()+printTimings = do+ now <- getCurrentTime+ old <- atomicModifyIORef timings $ \ts -> ([(now, "Start")], ts)+ putStr $ unlines $ showTimings now $ reverse old+++addTiming :: String -> IO ()+addTiming msg = do+ now <- getCurrentTime+ atomicModifyIORef timings $ \ts -> ((now,msg):ts, ())+++showTimings :: UTCTime -> [(UTCTime, String)] -> [String]+showTimings _ [] = []+showTimings stop times = showGap $+ [(a ++ " ", showDP 3 b ++ "s " ++ showPerc b ++ " " ++ progress b) | (a,b) <- xs] +++ [("Total", showDP 3 sm ++ "s " ++ showPerc sm ++ " " ++ replicate 25 ' ')]+ where+ a // b = if b == 0 then 0 else a / b+ showPerc x = let s = show $ floor $ x * 100 // sm in replicate (3 - length s) ' ' ++ s ++ "%"+ progress x = let i = floor $ x * 25 // mx in replicate i '=' ++ replicate (25-i) ' '+ mx = maximum $ map snd xs+ sm = sum $ map snd xs+ xs = [ (name, fromRational $ toRational $ stop `diffUTCTime` start)+ | ((start, name), stop) <- zip times $ map fst (drop 1 times) ++ [stop]]+++showGap :: [(String,String)] -> [String]+showGap xs = [a ++ replicate (n - length a - length b) ' ' ++ b | (a,b) <- xs]+ where n = maximum [length a + length b | (a,b) <- xs]+++showDP :: Int -> Double -> String+showDP n x = a ++ "." ++ b ++ replicate (n - length b) '0'+ where (a,b) = second (drop 1) $ break (== '.') $ showFFloat (Just n) x ""
Start.hs view
@@ -6,7 +6,7 @@ import System.Environment import Development.Shake import Development.Shake.FilePath-import Development.Shake.Timing+import General.Timing import qualified System.Directory as IO import System.Console.GetOpt
Test.hs view
@@ -8,9 +8,9 @@ import Data.Maybe import System.Environment import Development.Shake.Pool-import Development.Shake.Timing+import General.Timing import Development.Shake.FileTime-import Development.Shake.Util+import General.Base import qualified Data.ByteString.Char8 as BS import Examples.Util(sleepFileTime, sleepFileTimeCalibrate) import Control.Concurrent@@ -34,12 +34,15 @@ import qualified Examples.Test.Lint as Lint import qualified Examples.Test.Makefile as Makefile 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 Start as Start @@ -49,13 +52,13 @@ mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main ,"basic" * Basic.main, "cache" * Cache.main, "command" * Command.main, "directory" * Directory.main- ,"docs" * Docs.main, "errors" * Errors.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 ,"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- ,"throttle" * Throttle.main]+ ,"oracle" * Oracle.main, "progress" * Progress.main, "unicode" * Unicode.main, "util" * Util.main+ ,"throttle" * Throttle.main, "verbosity" * Verbosity.main] where (*) = (,)
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: shake-version: 0.10.8+version: 0.10.9 license: BSD3 license-file: LICENSE category: Development@@ -13,32 +13,23 @@ Shake is a Haskell library for writing build systems - designed as a replacement for @make@. See "Development.Shake" for an introduction, including an example. Further examples are included in the Cabal tarball,- under the @Examples@ directory.+ under the @Examples@ directory. The homepage contains links to a user+ manual, an academic paper and further information:+ <https://github.com/ndmitchell/shake> . To use Shake the user writes a Haskell program that imports "Development.Shake", defines some build rules, and calls- the 'Development.Shake.shake' function. Thanks to do notation and infix+ the 'Development.Shake.shakeArgs' function. Thanks to do notation and infix operators, a simple Shake build system is not too dissimilar from a simple Makefile. However, as build systems get more complex, Shake is able to take advantage of the excellent abstraction facilities offered by Haskell and easily support much larger- projects.- .- The Shake library provides all the standard features available in other+ projects. The Shake library provides all the standard features available in other build systems, including automatic parallelism and minimal rebuilds.- Shake provides highly accurate dependency tracking, including seamless+ Shake also provides more accurate dependency tracking, including seamless support for generated files, and dependencies on system information- (i.e. compiler version). Shake can produce profile reports, indicating- which files and take longest to build, and providing an analysis of the- parallelism.- .- The theory behind Shake is described in an ICFP 2012 paper,- Shake Before Building -- Replacing Make with Haskell- <http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf>.- The associated talk forms a short overview of Shake- <http://www.youtube.com/watch?v=xYCPpXVlqFM>.-homepage: http://community.haskell.org/~ndm/shake/-stability: Beta+ (e.g. compiler version).+homepage: https://github.com/ndmitchell/shake extra-source-files: Examples/C/constants.c Examples/C/constants.h@@ -50,6 +41,7 @@ Examples/Tar/list.txt Examples/Ninja/*.ninja Paths.hs+ CHANGES.txt data-files: html/jquery.flot.js@@ -99,33 +91,36 @@ Development.Shake.Command Development.Shake.FilePath Development.Shake.Sys+ Development.Shake.Util other-modules: Development.Shake.Args- Development.Shake.Binary+ Development.Shake.ByteString Development.Shake.Core Development.Shake.Database Development.Shake.Derived- Development.Shake.Directory Development.Shake.Errors- Development.Shake.File Development.Shake.FilePattern- Development.Shake.Files Development.Shake.FileTime- Development.Shake.Intern- Development.Shake.Oracle Development.Shake.Pool Development.Shake.Progress Development.Shake.Report- Development.Shake.Rerun Development.Shake.Resource+ Development.Shake.Rules.Directory+ Development.Shake.Rules.File+ Development.Shake.Rules.Files+ Development.Shake.Rules.Oracle+ Development.Shake.Rules.OrderOnly+ Development.Shake.Rules.Rerun Development.Shake.Shake Development.Shake.Special Development.Shake.Storage- Development.Shake.Timing Development.Shake.Types- Development.Shake.Util Development.Shake.Value+ General.Base+ General.Binary+ General.Intern+ General.Timing Paths_shake @@ -187,7 +182,8 @@ time, random, transformers >= 0.2 && < 0.4,- deepseq >= 1.1 && < 1.4+ deepseq >= 1.1 && < 1.4,+ QuickCheck >= 2.0 if flag(portable) cpp-options: -DPORTABLE@@ -224,10 +220,13 @@ Examples.Test.Lint Examples.Test.Makefile 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