shake 0.16 → 0.16.1
raw patch · 55 files changed
+1376/−748 lines, 55 filesdep +semigroupsdep ~basedep ~extradep ~unordered-containersPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: semigroups
Dependency ranges changed: base, extra, unordered-containers
API changes (from Hackage documentation)
- Development.Shake.Command: instance GHC.Classes.Eq Development.Shake.Command.Pid
- Development.Shake.Command: type (:->) a t = a
+ Development.Shake: batch :: Int -> ((a -> Action ()) -> Rules ()) -> (a -> Action b) -> ([b] -> Action ()) -> Rules ()
+ Development.Shake: getShakeExtraRules :: Typeable a => Rules (Maybe a)
+ Development.Shake: needHasChanged :: [FilePath] -> Action [FilePath]
+ Development.Shake: resultHasChanged :: FilePath -> Action Bool
+ Development.Shake: runAfter :: IO () -> Action ()
+ Development.Shake: shakeArgsOptionsWith :: ShakeOptions -> [OptDescr (Either String a)] -> (ShakeOptions -> [a] -> [String] -> IO (Maybe (ShakeOptions, Rules ()))) -> IO ()
+ Development.Shake: withTempDirWithin :: FilePath -> (FilePath -> Action a) -> Action a
+ Development.Shake: withTempFileWithin :: FilePath -> (FilePath -> Action a) -> Action a
+ Development.Shake.Command: instance Data.Semigroup.Semigroup Development.Shake.Command.CmdArgument
+ Development.Shake.Command: instance GHC.Classes.Eq Development.Shake.Command.PID
+ Development.Shake.Command: type a :-> t = a
- Development.Shake: liftIO :: MonadIO m => forall a. IO a -> m a
+ Development.Shake: liftIO :: MonadIO m => forall a. () => IO a -> m a
- Development.Shake: unit :: m () -> m ()
+ Development.Shake: unit :: () => m () -> m ()
- Development.Shake.Command: unit :: m () -> m ()
+ Development.Shake.Command: unit :: () => m () -> m ()
- Development.Shake.Rule: apply :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => [key] -> Action [value]
+ Development.Shake.Rule: apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]
- Development.Shake.Rule: apply1 :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => key -> Action value
+ Development.Shake.Rule: apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
Files
- CHANGES.txt +102/−79
- LICENSE +1/−1
- docs/Manual.md +1/−1
- shake.cabal +94/−81
- src/Development/Ninja/All.hs +33/−19
- src/Development/Ninja/Lexer.hs +27/−17
- src/Development/Ninja/Parse.hs +1/−1
- src/Development/Ninja/Type.hs +3/−2
- src/Development/Shake.hs +22/−6
- src/Development/Shake/Command.hs +36/−35
- src/Development/Shake/Internal/Args.hs +23/−9
- src/Development/Shake/Internal/Core/Action.hs +4/−3
- src/Development/Shake/Internal/Core/Database.hs +46/−16
- src/Development/Shake/Internal/Core/Monad.hs +10/−1
- src/Development/Shake/Internal/Core/Pool.hs +46/−73
- src/Development/Shake/Internal/Core/Rules.hs +15/−9
- src/Development/Shake/Internal/Core/Run.hs +111/−143
- src/Development/Shake/Internal/Core/Storage.hs +4/−3
- src/Development/Shake/Internal/Core/Types.hs +33/−3
- src/Development/Shake/Internal/Demo.hs +3/−2
- src/Development/Shake/Internal/Derived.hs +156/−21
- src/Development/Shake/Internal/Progress.hs +11/−9
- src/Development/Shake/Internal/Resource.hs +4/−4
- src/Development/Shake/Internal/Rules/Directory.hs +12/−10
- src/Development/Shake/Internal/Rules/File.hs +79/−26
- src/Development/Shake/Internal/Rules/Files.hs +4/−5
- src/Development/Shake/Internal/Rules/Oracle.hs +1/−8
- src/Development/Shake/Internal/Value.hs +6/−1
- src/General/Bag.hs +40/−0
- src/General/Bilist.hs +6/−2
- src/General/Binary.hs +6/−3
- src/General/Chunks.hs +5/−3
- src/General/Cleanup.hs +20/−12
- src/General/Extra.hs +56/−10
- src/General/FileLock.hs +7/−7
- src/General/ListBuilder.hs +9/−4
- src/General/Process.hs +26/−25
- src/Run.hs +14/−14
- src/Test.hs +47/−23
- src/Test/Basic.hs +3/−3
- src/Test/Batch.hs +88/−0
- src/Test/Command.hs +13/−7
- src/Test/Directory.hs +4/−3
- src/Test/Docs.hs +11/−5
- src/Test/Errors.hs +37/−5
- src/Test/FileLock.hs +3/−1
- src/Test/Files.hs +1/−7
- src/Test/Lint.hs +3/−2
- src/Test/Ninja.hs +16/−8
- src/Test/Ninja/continuations.ninja +12/−0
- src/Test/Ninja/lint.ninja +8/−2
- src/Test/Ninja/restart.ninja +8/−0
- src/Test/Pool.hs +14/−1
- src/Test/Self.hs +4/−4
- src/Test/Type.hs +27/−9
CHANGES.txt view
@@ -1,6 +1,29 @@ Changelog for Shake -0.16+0.16.1, released 2018-02-11+ Support process-1.6.3.0+ #290, add withTempFileInside and withTempDirInside+ #549, Semigroup-Monoid proposal support+ Hadrian-462, fail gracefully if on-disk formats change+ #469, only print timing information at normal verbosity or above+ #340, add runAfter+ #372, deprecate askOracleWith+ #520, only record each dependency once+ #548, rebuild the Ninja files, if they change, restart+ #547, make Ninja --lint checking see through phonys+ #546, support Ninja line continuations in more places+ #470, make --verbose and --quiet help text clearer+ #534, make writeFile' and writeFileChanged create the directory+ #543, add resultHasChanged to track results which have changed+ Add getShakeExtraRules, like getShakeOptionsRules for shakeExtra+ #535, add shakeArgsOptionsWith to manipulate ShakeOptions+ #538, make sure processes can be killed properly+ #502, add needHasChanged to track what in a need has changed+ Weaken the typeclasses required for apply/apply1+ #502, add batch function to batch commands with high startup+ Avoid parallel duplicating local state such as discounting+ Prefer to resume tasks rather than start new ones+0.16, released 2017-09-20 #536, make --skip work for oracles Ensure shakeOutput is used more consistently #49, add shakeColor and --color flags@@ -33,18 +56,18 @@ Delete the deprecated defaultRule IMPORTANT: Incompatible on disk format change #428, don't persist errors to the database-0.15.11+0.15.11, released 2017-01-18 #488, make sure parallel tracks dependencies #513, permit process-1.4.3.0 and above-0.15.10+0.15.10, released 2016-06-14 #465, fix phony names which clash with directories-0.15.9+0.15.9, released 2016-06-12 Documentation tweaks Optimise the thread pool Fix progress output through wget-0.15.8+0.15.8, released 2016-06-01 Extra base bounds to rule out building on GHC 7.4-0.15.7+0.15.7, released 2016-06-01 Require extra-1.4.8 #457, better error message when calling need on a directory #456, use displayException for inner exceptions@@ -52,7 +75,7 @@ #448, fix FSATrace on Mac 10.11 #444, optimise copyFileChanged #58, change writeFile functions to MonadIO-0.15.6+0.15.6, released 2016-04-19 Require the primitive package #431, make it an error to need a directory #393, add orderOnlyAction, a general version of orderOnly@@ -107,18 +130,18 @@ #295, discount time spent waiting for a cache #294, give better error messages if you hit GHC bug #10793 #4, add a lock file to stop corrupting databases-0.15.5+0.15.5, released 2015-08-04 #279, make usingConfigFile do a need on the config file Fix a bug where predicted progress could sometimes be ?? #264, make the the suite more less non-deterministic-0.15.4+0.15.4, released 2015-06-20 Undo a locally modified file-0.15.3+0.15.3, released 2015-06-20 #254, in staunch mode, print out all exceptions Require extra-1.3 #259, discount time waiting for a resource in profiles #252, have the docs test configure not in dist-0.15.2+0.15.2, released 2015-05-22 #248, add another example of using cmd #245, initial support for fsatrace lint checking Reexport -<.> from filepath where available@@ -126,7 +149,7 @@ Add AddEnv and AddPath command options #243, close fds in child processes when spawning commands Make Ninja variable handling more accurate-0.15.1+0.15.1, released 2015-04-25 If you have Shakefile.hs, pass it all arguments without interp Add shakeArgsPrune and shakeArgsPruneWith #228, allow running cmd async by collecting the ProcessHandle@@ -137,7 +160,7 @@ #226, add escaping for GraphViz labels #227, add StdinBS for passing a bytestring as Stdin Make cmd Timeout call terminateProcess as well-0.15+0.15, released 2015-03-26 #203, make shakeFiles a directory rather than a file prefix #220, add getHashedShakeVersion helper #220, add shakeVersionIgnore to ignore version numbers@@ -157,17 +180,17 @@ Add unit for use with cmd IMPORTANT: Incompatible on disk format change #209, improve orderOnly dependencies-0.14.3+0.14.3, released 2015-01-07 Support for the filepath shipped with GHC 7.10 Add Timeout option to command-0.14.2+0.14.2, released 2014-11-27 #198, add <//> operator to join FilePatterns #198, fix the <.> and other extension methods to work with //-0.14.1+0.14.1, released 2014-11-21 #196, change the links to point at http://www.shakebuild.com/ Improve the error messages when &%> or &?> go wrong Normalise file patterns used by &?>-0.14+0.14, released 2014-11-19 Make FilePattern on Windows cope with all path separators Rename normalise to normaliseEx Expose native System.FilePath in Development.Shake.FilePath@@ -184,9 +207,9 @@ Fix incorrect units when showing profile to the console Require the extra library #178, make --help show the current executable name-0.13.4+0.13.4, released 2014-09-19 #171, fix the --demo mode on Linux-0.13.3+0.13.3, released 2014-09-16 Ensure you wait until the progress thread cleans up Add --demo mode Add --progress=record and --progress=replay@@ -211,16 +234,16 @@ Add Maybe instances for cmd arguments Add a --profile flag (alias for --report) Switch to an underlying continuation monad-0.13.2+0.13.2, released 2014-06-20 #95, ensure progress never gets corrupted #124, add a profile report demo #128, allow long Ninja command lines Fix --report=- for builds with no commands in them-0.13.1+0.13.1, released 2014-05-28 Remove all package upper bounds #126, Ninja compatibility if Ninja fails to create a file #123, generate Chrome compatible traces-0.13+0.13, released 2014-05-27 #122, make --report=- write a report to stdout Improve the profile report summary #122, turn shakeReport into a list of files, instead of a Maybe@@ -234,7 +257,7 @@ Deprecate defaultRule Make literal *> matches take precedence over wildcard matches #120, add a priority function-0.12+0.12, released 2014-05-09 #62, move to a ReaderT/IORef for the Action monad Add DEPRECATED pragmas on system' calls Delete Development.Shake.Sys, use command or cmd instead@@ -244,13 +267,13 @@ #117, use higher precision times for Unicode files on Windows #118, add support for Ninja -t compdb #119, more test fixes for Linux GHC 7.8-0.11.7+0.11.7, released 2014-05-05 #119, test fixes for Linux GHC 7.8-0.11.6+0.11.6, released 2014-05-04 #114, run build.sh in the test suite with sh #115, fix the test suite on Linux GHC 7.8 #116, fix for GHC 7.10-0.11.5+0.11.5, released 2014-04-25 Include the sources for flot and jQuery in the dist tarball Note that .. in FilePattern values is unlikely to be correct #109, make removeFiles delete directories that match@@ -259,20 +282,20 @@ #110, don't give a warning if -threaded is turned off #103, don't suggest -qg and -qb, they fail without -threaded #102, fix up </> when the LHS starts with .-0.11.4+0.11.4, released 2014-03-20 Work with QuickCheck-2.7 (which defines ===) #100, handle GraphViz missing gracefully Fix up the profiling report generation #99, add getEnvWithDefault-0.11.3+0.11.3, released 2014-02-27 #97, fix a serialisation bug when > 254 arguments to need-0.11.2+0.11.2, released 2014-02-18 #96, fix a bug in addPath that caused $PATH to be added twice-0.11.1+0.11.1, released 2014-02-06 #94, GHC 7.8 support Add a Config module #89, support :: as a build rule separator-0.11+0.11, released 2014-01-03 Add alternatives to allow overlapping rules Make storedValue take a ShakeOptions structure Generalise the newCache function@@ -287,9 +310,9 @@ Mark Development.Shake.Sys as DEPRECATED with a pragma Change shakeLint to be of type Maybe Lint, instead of Bool #50, add shakeArgsAccumulate-0.10.10+0.10.10, released 2013-11-16 Improve Ninja --lint checking-0.10.9+0.10.9, released 2013-11-15 #76, add Ninja specific lint checking #75, add orderOnly dependencies #76, add needed, to assert a need doesn't rebuild@@ -311,11 +334,11 @@ Add a --no-build flag #74, allow cmd to be used with result IO Add a Util module, with Makefile parsing-0.10.8+0.10.8, released 2013-10-15 Allow unix-1.5.1 again Require Cabal 1.10 or above Convert to the cabal test compatible test suite-0.10.7+0.10.7, released 2013-09-26 Support time-1.2 #71, fix a bug when requesting all three outputs from command #64, add progressProgram and use it in progressSimple@@ -340,16 +363,16 @@ Reduce stack usage when lint checking #24, create the output directories for the multiple file rule Improvements to match Ninja behaviour-0.10.6+0.10.6, released 2013-06-28 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+0.10.5, released 2013-06-14 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+0.10.4, released 2013-06-13 Fix writeFileChanged for line endings on Windows Support arguments to --progress Set the number of capabilities based on -j flags@@ -362,10 +385,10 @@ Add -<.> alias for replaceExtension Add selectors on Stdout/Stdin/Exit Add CmdResult instance for ExitCode-0.10.3+0.10.3, released 2013-05-12 Upgrade to Flot-0.8 Small documentation markup fixes-0.10.2+0.10.2, released 2013-03-30 Require process-1.1 or above Improve progress guesses (use exponential decay of work rate) Improve profiling report error messages@@ -382,9 +405,9 @@ Add a --no-time flag Makefile improvements Avoid use of ghc-options in .cabal file-0.10.1+0.10.1, released 2013-03-18 Allow the shake executable to build-0.10+0.10, released 2013-03-17 Add phony, for writing phony actions Add removeFilesAfter Switch to the new profiling code@@ -397,9 +420,9 @@ Change how progress messages are written Do not write a beep in progressDisplay, avoids a beep Add exe function to FilePath-0.9.1+0.9.1, released 2013-02-28 GHC head (7.7) compatibility by removing the Rules fundep-0.9+0.9, released 2013-02-16 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@@ -414,10 +437,10 @@ 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+0.8, released 2013-01-31 Improve the Oracle documentation Allow getDirectoryFiles to operate recursively-0.7+0.7, released 2013-01-29 Change getDirectoryFiles to take a set of file patterns Add doesDirectoryExist function Add shakeAbbreviations feature@@ -432,16 +455,16 @@ Change the storage to not write messages on --silent Add Applicative on Rules Add Applicative on Action-0.6+0.6, released 2013-01-09 Make addOracle return a result of askOracle Export the class bodies from Classes Don't export ShakeValue from Classes-0.5+0.5, released 2013-01-05 IMPORTANT: Incompatible on disk format change Add the ShakeValue constraint synonym Change the Oracle to be strongly typed Add a Classes module-0.4+0.4, released 2013-01-02 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@@ -451,29 +474,29 @@ #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+0.3.10, released 2012-12-17 Add Paths.hs so you can run the tests from the tarball-0.3.9+0.3.9, released 2012-12-17 Don't rely on toList returning a consistent order Allow hashable-1.2-0.3.8+0.3.8, released 2012-12-12 Fix up FilePattern so "foo//bar" ?== "foo/bar"-0.3.7+0.3.7, released 2012-12-02 Update the cabal file-0.3.6+0.3.6, released 2012-11-27 Add addOracles, for implementing more advanced oracles Add withoutActions, for implementing command line arguments-0.3.5+0.3.5, released 2012-11-27 #571, vastly improve the correctness of FilePattern #574, documentation typos Expose rulePriority-0.3.4+0.3.4, released 2012-09-17 Update documentation with links to ICFP 2012 paper/talk-0.3.3+0.3.3, released 2012-09-17 Minor refactorings-0.3.2+0.3.2, released 2012-09-12 Fix cabal specification on non-Windows-0.3.1+0.3.1, released 2012-09-08 Don't use syntax also stolen by QuasiQuotes Avoid warnings about unused monadic values Fix up getModificationTime for GHC 7.6@@ -493,7 +516,7 @@ Switch to ByteString for storing File Add shakeDeterministic, along with a default random pool Make the Monad/Monoid instance for Rules strict-0.3+0.3, released 2012-06-17 #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@@ -503,13 +526,13 @@ Better messages on invalid database versions Complete rewrite of the storage layer and journal design IMPORTANT: Incompatible on disk format change-0.2.11+0.2.11, released 2012-05-19 IMPORTANT: #546, don't save the database to where it was created-0.2.10+0.2.10, released 2012-05-19 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+0.2.9, released 2012-03-25 Require unordered-containers 2.1 or higher, fixes bugs Allow transformers-0.3.* Add a random script generator and tester@@ -517,31 +540,31 @@ 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+0.2.8, released 2012-02-24 Rename shakeDump to shakeReport Add profile report generator-0.2.7+0.2.7, released 2012-02-18 #530, require unordered-containers >= 0.1.4.3-0.2.6+0.2.6, released 2012-02-17 Improve the documentation code fragments (more links) Add support for managing finite resources-0.2.5+0.2.5, released 2012-02-15 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+0.2.4, released 2012-02-11 Include the C example source files Significant documentation improvements-0.2.3+0.2.3, released 2012-02-09 Create the shakeFiles directory if missing-0.2.2+0.2.2, released 2012-02-05 Allow deepseq-1.3.* Add a basic lint checking mode Remove the Dirty state entirely (was incorrect)-0.2.1+0.2.1, released 2012-01-28 Put diagnostics in more places Add a C example-0.2+0.2, released 2012-01-23 Add shakeStaunch Rename shakeParallel to shakeThreads Delete the lint support (never actually worked)@@ -553,25 +576,25 @@ Add an Oracle module Add an explicit Verbosity type Change to lower precedence for *> etc-0.1.5+0.1.5, released 2012-01-01 Allow deepseq-1.2-0.1.4+0.1.4, released 2012-01-01 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+0.1.3, released 2011-12-22 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+0.1.2, released 2011-12-18 Add a warning in the description-0.1.1+0.1.1, released 2011-12-18 Significantly improved documentation system' now takes an initial argument for the program-0.1+0.1, released 2011-12-18 Many changes to signatures, some basic documentation Additional demo, to build shake itself-0.0+0.0, released 2011-12-11 Initial version, not ready for public use
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2011-2017.+Copyright Neil Mitchell 2011-2018. All rights reserved. Redistribution and use in source and binary forms, with or without
docs/Manual.md view
@@ -251,7 +251,7 @@ buildDir ("run" <.> exe) %> \out -> do ... -All top-level variables and functions can be though of as being expanded wherever they are used, although in practice may have their evaluation shared.+All top-level variables and functions can be thought of as being expanded wherever they are used, although in practice may have their evaluation shared. #### A clean command
shake.cabal view
@@ -1,13 +1,13 @@ cabal-version: >= 1.18 build-type: Simple name: shake-version: 0.16+version: 0.16.1 license: BSD3 license-file: LICENSE category: Development, Shake author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2011-2017+copyright: Neil Mitchell 2011-2018 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a@@ -31,39 +31,39 @@ (e.g. compiler version). homepage: http://shakebuild.com bug-reports: https://github.com/ndmitchell/shake/issues-tested-with: GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+tested-with: GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-doc-files: CHANGES.txt README.md extra-source-files:+ docs/Manual.md+ docs/shake-progress.png+ src/Paths.hs src/Test/C/constants.c src/Test/C/constants.h src/Test/C/main.c- src/Test/Tar/list.txt src/Test/Ninja/*.ninja- src/Test/Ninja/subdir/*.ninja src/Test/Ninja/*.output+ src/Test/Ninja/subdir/*.ninja src/Test/Progress/*.prog+ src/Test/Tar/list.txt src/Test/Tup/hello.c- src/Test/Tup/root.cfg src/Test/Tup/newmath/root.cfg src/Test/Tup/newmath/square.c src/Test/Tup/newmath/square.h- src/Paths.hs- docs/Manual.md- docs/shake-progress.png+ src/Test/Tup/root.cfg data-files:- html/viz.js- html/profile.html- html/progress.html- html/shake.js docs/manual/build.bat docs/manual/Build.hs docs/manual/build.sh docs/manual/constants.c docs/manual/constants.h docs/manual/main.c+ html/profile.html+ html/progress.html+ html/shake.js+ html/viz.js source-repository head type: git@@ -79,22 +79,22 @@ hs-source-dirs: src build-depends: base >= 4.5,- directory,- hashable >= 1.1.2.3, binary,+ bytestring,+ deepseq >= 1.1,+ directory,+ extra >= 1.5.3, filepath,+ hashable >= 1.1.2.3,+ js-flot,+ js-jquery,+ primitive, process >= 1.1,- unordered-containers >= 0.2.1,- bytestring,- utf8-string >= 0.3,- time, random,- js-jquery,- js-flot,+ time, transformers >= 0.2,- extra >= 1.5.3,- deepseq >= 1.1,- primitive+ unordered-containers >= 0.2.1,+ utf8-string >= 0.3 if flag(portable) cpp-options: -DPORTABLE@@ -106,6 +106,9 @@ if !os(windows) build-depends: unix + if impl(ghc < 8.0)+ build-depends: semigroups >= 0.18+ exposed-modules: Development.Shake Development.Shake.Classes@@ -122,21 +125,23 @@ Development.Ninja.Parse Development.Ninja.Type Development.Shake.Internal.Args- General.Makefile+ Development.Shake.Internal.CmdOption Development.Shake.Internal.Core.Action+ Development.Shake.Internal.Core.Database+ Development.Shake.Internal.Core.Monad+ Development.Shake.Internal.Core.Pool Development.Shake.Internal.Core.Rendezvous Development.Shake.Internal.Core.Rules Development.Shake.Internal.Core.Run- Development.Shake.Internal.CmdOption- Development.Shake.Internal.Core.Database+ Development.Shake.Internal.Core.Storage Development.Shake.Internal.Core.Types Development.Shake.Internal.Demo Development.Shake.Internal.Derived Development.Shake.Internal.Errors Development.Shake.Internal.FileInfo+ Development.Shake.Internal.FileName Development.Shake.Internal.FilePattern- Development.Shake.Internal.Core.Monad- Development.Shake.Internal.Core.Pool+ Development.Shake.Internal.Options Development.Shake.Internal.Profile Development.Shake.Internal.Progress Development.Shake.Internal.Resource@@ -147,9 +152,8 @@ Development.Shake.Internal.Rules.OrderOnly Development.Shake.Internal.Rules.Rerun Development.Shake.Internal.Shake- Development.Shake.Internal.Core.Storage- Development.Shake.Internal.Options Development.Shake.Internal.Value+ General.Bag General.Bilist General.Binary General.Chunks@@ -161,8 +165,8 @@ General.Ids General.Intern General.ListBuilder+ General.Makefile General.Process- Development.Shake.Internal.FileName General.Template General.Timing Paths_shake@@ -179,22 +183,22 @@ ghc-options: -threaded "-with-rtsopts=-I0 -qg -qb" build-depends: base == 4.*,- directory,- hashable >= 1.1.2.3, binary,+ bytestring,+ deepseq >= 1.1,+ directory,+ extra >= 1.5.3, filepath,+ hashable >= 1.1.2.3,+ js-flot,+ js-jquery,+ primitive, process >= 1.1,- unordered-containers >= 0.2.1,- bytestring,- utf8-string >= 0.3,- time, random,- js-jquery,- js-flot,+ time, transformers >= 0.2,- extra >= 1.5.3,- deepseq >= 1.1,- primitive+ unordered-containers >= 0.2.1,+ utf8-string >= 0.3 if flag(portable) cpp-options: -DPORTABLE@@ -206,6 +210,9 @@ if !os(windows) build-depends: unix + if impl(ghc < 8.0)+ build-depends: semigroups >= 0.18+ other-modules: Development.Ninja.All Development.Ninja.Env@@ -213,25 +220,27 @@ Development.Ninja.Parse Development.Ninja.Type Development.Shake- Development.Shake.Internal.Args- General.Makefile Development.Shake.Classes- Development.Shake.Internal.CmdOption Development.Shake.Command+ Development.Shake.FilePath+ Development.Shake.Internal.Args+ Development.Shake.Internal.CmdOption Development.Shake.Internal.Core.Action+ Development.Shake.Internal.Core.Database+ Development.Shake.Internal.Core.Monad+ Development.Shake.Internal.Core.Pool Development.Shake.Internal.Core.Rendezvous Development.Shake.Internal.Core.Rules Development.Shake.Internal.Core.Run- Development.Shake.Internal.Core.Database+ Development.Shake.Internal.Core.Storage Development.Shake.Internal.Core.Types Development.Shake.Internal.Demo Development.Shake.Internal.Derived Development.Shake.Internal.Errors Development.Shake.Internal.FileInfo- Development.Shake.FilePath+ Development.Shake.Internal.FileName Development.Shake.Internal.FilePattern- Development.Shake.Internal.Core.Monad- Development.Shake.Internal.Core.Pool+ Development.Shake.Internal.Options Development.Shake.Internal.Profile Development.Shake.Internal.Progress Development.Shake.Internal.Resource@@ -242,22 +251,21 @@ Development.Shake.Internal.Rules.OrderOnly Development.Shake.Internal.Rules.Rerun Development.Shake.Internal.Shake- Development.Shake.Internal.Core.Storage- Development.Shake.Internal.Options Development.Shake.Internal.Value+ General.Bag General.Bilist General.Binary General.Chunks General.Cleanup General.Concurrent General.Extra- General.GetOpt General.FileLock+ General.GetOpt General.Ids General.Intern General.ListBuilder+ General.Makefile General.Process- Development.Shake.Internal.FileName General.Template General.Timing Paths_shake@@ -280,23 +288,23 @@ build-depends: base == 4.*,- directory,- hashable >= 1.1.2.3, binary,- filepath,- process >= 1.1,- unordered-containers >= 0.2.1, bytestring,- utf8-string >= 0.3,- time,- random,- js-jquery,- js-flot,- transformers >= 0.2, deepseq >= 1.1,+ directory, extra >= 1.5.3,+ filepath,+ hashable >= 1.1.2.3,+ js-flot,+ js-jquery, primitive,- QuickCheck >= 2.0+ process >= 1.1,+ QuickCheck >= 2.0,+ random,+ time,+ transformers >= 0.2,+ unordered-containers >= 0.2.1,+ utf8-string >= 0.3 if flag(portable) cpp-options: -DPORTABLE@@ -308,6 +316,9 @@ if !os(windows) build-depends: unix + if impl(ghc < 8.0)+ build-depends: semigroups >= 0.18+ other-modules: Development.Ninja.All Development.Ninja.Env@@ -315,31 +326,32 @@ Development.Ninja.Parse Development.Ninja.Type Development.Shake- Development.Shake.Internal.Args- General.Makefile Development.Shake.Classes- Development.Shake.Internal.CmdOption Development.Shake.Command Development.Shake.Config+ Development.Shake.FilePath+ Development.Shake.Forward+ Development.Shake.Internal.Args+ Development.Shake.Internal.CmdOption Development.Shake.Internal.Core.Action+ Development.Shake.Internal.Core.Database+ Development.Shake.Internal.Core.Monad+ Development.Shake.Internal.Core.Pool Development.Shake.Internal.Core.Rendezvous Development.Shake.Internal.Core.Rules Development.Shake.Internal.Core.Run- Development.Shake.Internal.Core.Database+ Development.Shake.Internal.Core.Storage Development.Shake.Internal.Core.Types Development.Shake.Internal.Demo Development.Shake.Internal.Derived Development.Shake.Internal.Errors Development.Shake.Internal.FileInfo- Development.Shake.FilePath+ Development.Shake.Internal.FileName Development.Shake.Internal.FilePattern- Development.Shake.Forward- Development.Shake.Internal.Core.Monad- Development.Shake.Internal.Core.Pool+ Development.Shake.Internal.Options Development.Shake.Internal.Profile Development.Shake.Internal.Progress Development.Shake.Internal.Resource- Development.Shake.Rule Development.Shake.Internal.Rules.Directory Development.Shake.Internal.Rules.File Development.Shake.Internal.Rules.Files@@ -347,10 +359,10 @@ Development.Shake.Internal.Rules.OrderOnly Development.Shake.Internal.Rules.Rerun Development.Shake.Internal.Shake- Development.Shake.Internal.Core.Storage- Development.Shake.Internal.Options- Development.Shake.Util Development.Shake.Internal.Value+ Development.Shake.Rule+ Development.Shake.Util+ General.Bag General.Bilist General.Binary General.Chunks@@ -358,18 +370,18 @@ General.Concurrent General.Extra General.FileLock- General.Ids General.GetOpt+ General.Ids General.Intern General.ListBuilder+ General.Makefile General.Process- Development.Shake.Internal.FileName General.Template General.Timing Paths_shake Run- Test.Rebuild Test.Basic+ Test.Batch Test.Benchmark Test.C Test.Cache@@ -398,6 +410,7 @@ Test.Pool Test.Progress Test.Random+ Test.Rebuild Test.Resources Test.Self Test.Tar
src/Development/Ninja/All.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, ViewPatterns #-}+{-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables #-} module Development.Ninja.All(runNinja) where @@ -23,16 +23,20 @@ import Prelude -- Internal imports+import General.Extra(removeFile_) import General.Timing(addTiming) import General.Makefile(parseMakefile)-import Development.Shake.Internal.FileName(filepathNormalise)+import Development.Shake.Internal.FileName(filepathNormalise, fileNameFromString)+import Development.Shake.Internal.FileInfo(getFileInfo) import Development.Shake.Internal.Errors(errorStructured) import Development.Shake.Internal.Rules.File(needBS, neededBS) import Development.Shake.Internal.Rules.OrderOnly(orderOnlyBS) -runNinja :: FilePath -> [String] -> Maybe String -> IO (Maybe (Rules ()))-runNinja file args (Just "compdb") = do+-- | Given the Ninja source file, a list of file arguments, a tool name.+-- Return a bool if you should restart and the rules.+runNinja :: IO () -> FilePath -> [String] -> Maybe String -> IO (Maybe (Rules ()))+runNinja restart file args (Just "compdb") = do dir <- getCurrentDirectory Ninja{..} <- parse file =<< newEnv rules <- return $ Map.fromList [r | r <- rules, BS.unpack (fst r) `elem` args]@@ -52,26 +56,34 @@ putStr $ printCompDb xs return Nothing -runNinja file args (Just x) = errorIO $ "Unknown tool argument, expected 'compdb', got " ++ x+runNinja restart file args (Just x) = errorIO $ "Unknown tool argument, expected 'compdb', got " ++ x -runNinja file args tool = do+runNinja restart file args tool = do addTiming "Ninja parse" ninja@Ninja{..} <- parse file =<< newEnv return $ Just $ do- needDeps <- return $ needDeps ninja -- partial application phonys <- return $ Map.fromList phonys+ needDeps <- return $ needDeps ninja phonys -- partial application singles <- return $ Map.fromList $ map (first filepathNormalise) singles multiples <- return $ Map.fromList [(x,(xs,b)) | (xs,b) <- map (first $ map filepathNormalise) multiples, x <- xs] rules <- return $ Map.fromList rules pools <- fmap Map.fromList $ forM ((BS.pack "console",1):pools) $ \(name,depth) -> (,) name <$> newResource (BS.unpack name) depth - action $ needBS $ 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+ action $ do+ -- build the .ninja files, if they change, restart the build+ before <- liftIO $ mapM (getFileInfo . fileNameFromString) sources+ need sources+ after <- liftIO $ mapM (getFileInfo . fileNameFromString) sources+ if before /= after then+ runAfter restart+ else+ needBS $ 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 -> (map BS.unpack . fst) <$> Map.lookup (BS.pack x) multiples) &?> \out -> let out2 = map BS.pack out in+ (\x -> map BS.unpack . fst <$> Map.lookup (BS.pack x) multiples) &?> \out -> let out2 = map BS.pack out in build needDeps phonys rules pools out2 $ snd $ multiples Map.! head out2 (flip Map.member singles . BS.pack) ?> \out -> let out2 = BS.pack out in@@ -138,8 +150,8 @@ -- when (deps == "gcc") $ liftIO $ removeFile depfile -needDeps :: Ninja -> Build -> [Str] -> Action ()-needDeps Ninja{..} = \build xs -> do -- eta reduced so 'builds' is shared+needDeps :: Ninja -> Map.HashMap Str [Str] -> Build -> [Str] -> Action ()+needDeps Ninja{..} phonysMp = \build xs -> do -- eta reduced so 'builds' is shared opts <- getShakeOptions if isNothing $ shakeLint opts then needBS xs else do neededBS xs@@ -150,9 +162,11 @@ let bad = xs `difference` allDependencies build case bad of [] -> return ()- x:_ -> liftIO $ errorStructured- "Lint checking error - file in deps is generated and not a pre-dependency"- [("File", Just $ BS.unpack x)]+ xs -> liftIO $ errorStructured+ ("Lint checking error - " +++ (if length xs == 1 then "file in deps is" else "files in deps are") +++ " generated and not a pre-dependency")+ [("File", Just $ BS.unpack x) | x <- xs] "" where builds :: Map.HashMap FileStr Build@@ -173,7 +187,7 @@ allDependencies rule = f Set.empty [] [rule] where f seen [] [] = []- f seen [] (x:xs) = f seen (map filepathNormalise $ depsNormal x ++ depsImplicit x ++ depsOrderOnly x) xs+ f seen [] (x:xs) = f seen (map filepathNormalise $ concatMap (resolvePhony phonysMp) $ depsNormal x ++ depsImplicit x ++ depsOrderOnly x) xs f seen (x:xs) rest | x `Set.member` seen = f seen xs rest | otherwise = x : f (Set.insert x seen) xs (maybeToList (Map.lookup x builds) ++ rest) @@ -185,7 +199,7 @@ if rspfile == "" then act else- flip actionFinally (ignore $ removeFile rspfile) $ do+ flip actionFinally (removeFile_ rspfile) $ do liftIO $ BS.writeFile rspfile rspfile_content act
src/Development/Ninja/Lexer.hs view
@@ -121,16 +121,16 @@ '\n' -> lexerLoop x ' ' -> lexBind $ dropSpace x '#' -> lexerLoop $ dropWhile0 (/= '\n') x- 'b' | Just x <- strip "uild " x -> lexBuild $ dropSpace x- 'r' | Just x <- strip "ule " x -> lexRule $ dropSpace x- 'd' | Just x <- strip "efault " x -> lexDefault $ dropSpace x- 'p' | Just x <- strip "ool " x -> lexPool $ dropSpace x- 'i' | Just x <- strip "nclude " x -> lexInclude $ dropSpace x- 's' | Just x <- strip "ubninja " x -> lexSubninja $ dropSpace x+ 'b' | Just x <- strip "uild " x -> lexBuild x+ 'r' | Just x <- strip "ule " x -> lexRule x+ 'd' | Just x <- strip "efault " x -> lexDefault x+ 'p' | Just x <- strip "ool " x -> lexPool x+ 'i' | Just x <- strip "nclude " x -> lexInclude x+ 's' | Just x <- strip "ubninja " x -> lexSubninja x '\0' -> [] _ -> lexDefine c_x where- strip str (Str0 x) = if b `BS.isPrefixOf` x then Just $ Str0 $ BS.drop (BS.length b) x else Nothing+ strip str (Str0 x) = if b `BS.isPrefixOf` x then Just $ dropSpace $ Str0 $ BS.drop (BS.length b) x else Nothing where b = BS.pack str lexBind :: Str0 -> [Lexeme]@@ -144,7 +144,7 @@ lexBuild :: Str0 -> [Lexeme] lexBuild x | (outputs,x) <- lexxExprs True x- , (rule,x) <- span0 isVarDot $ dropSpace x+ , (rule,x) <- span0 isVarDot $ jumpCont $ dropSpace x , (deps,x) <- lexxExprs False $ dropSpace x = LexBuild outputs rule deps : lexerLoop x @@ -163,8 +163,8 @@ lexxBind :: (Str -> Expr -> Lexeme) -> Str0 -> [Lexeme] lexxBind ctor x | (var,x) <- span0 isVarDot x- , ('=',x) <- list0 $ dropSpace x- , (exp,x) <- lexxExpr False False $ dropSpace x+ , ('=',x) <- list0 $ jumpCont $ dropSpace x+ , (exp,x) <- lexxExpr False False $ jumpCont $ dropSpace x = ctor var exp : lexerLoop x lexxBind _ x = error $ show ("parse failed when parsing binding", take0 100 x) @@ -182,15 +182,16 @@ lexxExprs :: Bool -> Str0 -> ([Expr], Str0) lexxExprs stopColon x = case lexxExpr stopColon True x of (a,c_x) | c <- head0 c_x, x <- tail0 c_x -> case c of- ' ' -> first (a:) $ lexxExprs stopColon $ dropSpace x- ':' | stopColon -> ([a], x)+ ' ' -> add a $ lexxExprs stopColon $ dropSpace x+ ':' | stopColon -> new a x _ | stopColon -> error "expected a colon"- '\r' -> a $: dropN x- '\n' -> a $: x- '\0' -> a $: c_x+ '\r' -> new a $ dropN x+ '\n' -> new a x+ '\0' -> new a c_x where- Exprs [] $: x = ([], x)- a $: x = ([a], x)+ new a x = add a ([], x)+ add (Exprs []) x = x+ add a (as,x) = (a:as,x) {-# NOINLINE lexxExpr #-}@@ -220,6 +221,15 @@ _ | (name,x) <- span0 isVar c_x, not $ BS.null name -> Var name $: f x _ -> error "Unexpect $ followed by unexpected stuff" +jumpCont :: Str0 -> Str0+jumpCont o+ | '$' <- head0 o+ , let x = tail0 o+ = case head0 x of+ '\n' -> dropSpace $ tail0 x+ '\r' -> dropSpace $ dropN $ tail0 x+ _ -> o+ | otherwise = o splitLineCont :: Str0 -> (Str, Str0) splitLineCont x = first BS.concat $ f x
src/Development/Ninja/Parse.hs view
@@ -18,7 +18,7 @@ parseFile :: FilePath -> Env Str Str -> Ninja -> IO Ninja parseFile file env ninja = do lexes <- lexerFile $ if file == "-" then Nothing else Just file- foldM (applyStmt env) ninja $ withBinds lexes+ foldM (applyStmt env) ninja{sources=file:sources ninja} $ withBinds lexes withBinds :: [Lexeme] -> [(Lexeme, [(Str,Expr)])] withBinds [] = []
src/Development/Ninja/Type.hs view
@@ -46,7 +46,8 @@ -- STRUCTURE data Ninja = Ninja- {rules :: [(Str,Rule)]+ {sources :: [FilePath]+ ,rules :: [(Str,Rule)] ,singles :: [(FileStr,Build)] ,multiples :: [([FileStr], Build)] ,phonys :: [(Str, [FileStr])]@@ -56,7 +57,7 @@ deriving Show newNinja :: Ninja-newNinja = Ninja [] [] [] [] [] []+newNinja = Ninja [] [] [] [] [] [] [] data Build = Build {ruleName :: Str
src/Development/Shake.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies, ConstraintKinds #-} -- | This module is used for defining Shake build systems. As a simple example of a Shake build system, -- let us build the file @result.tar@ from the files listed by @result.txt@:@@ -50,14 +51,14 @@ shakeOptions, Rules, action, withoutActions, alternatives, priority, Action, traced,- liftIO, actionOnException, actionFinally,+ liftIO, actionOnException, actionFinally, runAfter, ShakeException(..), -- * Configuration ShakeOptions(..), Rebuild(..), Lint(..), Change(..), getShakeOptions, getShakeOptionsRules, getHashedShakeVersion,- getShakeExtra, addShakeExtra,+ getShakeExtra, getShakeExtraRules, addShakeExtra, -- ** Command line- shakeArgs, shakeArgsWith, shakeOptDescrs,+ shakeArgs, shakeArgsWith, shakeArgsOptionsWith, shakeOptDescrs, -- ** Progress reporting Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram, getProgress, -- ** Verbosity@@ -75,6 +76,7 @@ writeFile', writeFileLines, writeFileChanged, removeFiles, removeFilesAfter, withTempFile, withTempDir,+ withTempFileWithin, withTempDirWithin, -- * File rules need, want, (%>), (|%>), (?>), phony, (~>), phonys, (&%>), (&?>),@@ -87,7 +89,7 @@ -- * Environment rules getEnv, getEnvWithDefault, -- * Oracle rules- ShakeValue, RuleResult, addOracle, askOracle, askOracleWith,+ ShakeValue, RuleResult, addOracle, askOracle, -- * Special rules alwaysRerun, -- * Resources@@ -96,9 +98,14 @@ unsafeExtraThread, -- * Cache newCache, newCacheIO,+ -- * Batching+ needHasChanged,+ resultHasChanged,+ batch, -- * Deprecated (*>), (|*>), (&*>),- (**>), (*>>), (?>>)+ (**>), (*>>), (?>>),+ askOracleWith ) where import Prelude(Maybe, FilePath) -- Since GHC 7.10 duplicates *>@@ -156,7 +163,7 @@ -- -- For large build systems the choice of GHC flags can have a significant impact. We recommend: ----- > ghc --make MyBuildSystem -threaded -rtsopts "-with-rtsopts=-I0 -qg qb"+-- > ghc --make MyBuildSystem -threaded -rtsopts "-with-rtsopts=-I0 -qg -qb" -- -- * @-rtsopts@: Allow the setting of further GHC options at runtime. --@@ -207,3 +214,12 @@ -- | /Deprecated:/ Alias for '&%>'. (&*>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules () (&*>) = (&%>)+++---------------------------------------------------------------------+-- DEPRECATED SINCE 0.16.1, NOV 2017++-- | /Depreciated:/ Replace @'askOracleWith' q a@ by @'askOracle' q@+-- since the 'RuleResult' type family now fixes the result type.+askOracleWith :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> a -> Action a+askOracleWith question _ = askOracle question
src/Development/Shake/Command.hs view
@@ -24,13 +24,13 @@ ) where import Data.Tuple.Extra-import Control.Exception.Extra import Control.Monad.Extra import Control.Monad.IO.Class import Data.Char import Data.Either.Extra import Data.List.Extra import Data.Maybe+import Data.Semigroup (Semigroup) import Data.Monoid import System.Directory import System.Environment.Extra@@ -42,6 +42,7 @@ import System.IO.Unsafe(unsafeInterleaveIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS+import General.Extra import General.Process import Control.Applicative import Prelude@@ -103,11 +104,11 @@ | ResultCode ExitCode | ResultTime Double | ResultLine String- | ResultProcess Pid+ | ResultProcess PID deriving Eq -data Pid = Pid0 | Pid ProcessHandle-instance Eq Pid where _ == _ = True+data PID = PID0 | PID ProcessHandle+instance Eq PID where _ == _ = True ---------------------------------------------------------------------@@ -129,14 +130,18 @@ let verboser act = do let cwd = listToMaybe $ reverse [x | Cwd x <- opts]- putLoud $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++ showCommandForUser2 exe args+ putLoud $+ maybe "" (\x -> "cd " ++ x ++ "; ") cwd +++ if useShell then unwords $ exe : args else showCommandForUser2 exe args verb <- getVerbosity+ -- run quietly to supress the tracer (don't want to print twice) (if verb >= Loud then quietly else id) act let tracer = case reverse [x | Traced x <- opts] of "":_ -> liftIO msg:_ -> traced msg- [] -> traced (takeFileName exe)+ _ | useShell -> traced $ takeFileName $ fst $ word1 exe+ [] -> traced $ takeFileName exe let tracker act | useLint = fsatrace act@@ -170,7 +175,7 @@ tmpdir <- getTemporaryDirectory let fake = tmpdir ++ "fsatrace-fakes" ++ re unlessM (doesFileExist fake) $ do- createDirectoryIfMissing True $ takeDirectory fake+ createDirectoryRecursive $ takeDirectory fake copyFile re fake return fake else return re@@ -256,7 +261,7 @@ _ -> Nothing let optShell = Shell `elem` opts let optBinary = BinaryPipes `elem` opts- let optAsync = ResultProcess Pid0 `elem` results+ let optAsync = ResultProcess PID0 `elem` results let optTimeout = listToMaybe $ reverse [x | Timeout x <- opts] let optWithStdout = last $ False : [x | WithStdout x <- opts] let optWithStderr = last $ True : [x | WithStderr x <- opts]@@ -277,7 +282,7 @@ ResultCode _ -> return ([], [], \_ _ ex -> return $ ResultCode ex) ResultTime _ -> return ([], [], \dur _ _ -> return $ ResultTime dur) ResultLine _ -> return ([], [], \_ _ _ -> return $ ResultLine cmdline)- ResultProcess _ -> return ([], [], \_ pid _ -> return $ ResultProcess $ Pid pid)+ ResultProcess _ -> return ([], [], \_ pid _ -> return $ ResultProcess $ PID pid) ResultStdout s -> do (a,b) <- buf s; return (a , [], \_ _ _ -> fmap ResultStdout b) ResultStderr s -> do (a,b) <- buf s; return ([], a , \_ _ _ -> fmap ResultStderr b) ResultStdouterr s -> do (a,b) <- buf s; return (a , a , \_ _ _ -> fmap ResultStdouterr b)@@ -291,29 +296,25 @@ ,poStderr = [DestEcho | optEchoStderr] ++ map DestFile optFileStderr ++ [DestString exceptionBuffer | optWithStderr && not optAsync] ++ concat dStderr ,poAsync = optAsync }- res <- try_ $ duration $ process po-- let failure extra = do- cwd <- case optCwd of- Nothing -> return ""- Just v -> do- v <- canonicalizePath v `catch_` const (return v)- return $ "Current directory: " ++ v ++ "\n"- fail $- "Development.Shake." ++ funcName ++ ", system command failed\n" ++- "Command: " ++ cmdline ++ "\n" ++- cwd ++ extra- case res of- Left err -> failure $ show err- Right (_,(_,ex)) | ex /= ExitSuccess && ResultCode ExitSuccess `notElem` results -> do- exceptionBuffer <- readBuffer exceptionBuffer- let captured = ["Stderr" | optWithStderr] ++ ["Stdout" | optWithStdout]- failure $- "Exit code: " ++ show (case ex of ExitFailure i -> i; _ -> 0) ++ "\n" ++- if null captured then "Stderr not captured because WithStderr False was used\n"- else if null exceptionBuffer then intercalate " and " captured ++ " " ++ (if length captured == 1 then "was" else "were") ++ " empty"- else intercalate " and " captured ++ ":\n" ++ unlines (dropWhile null $ lines $ concat exceptionBuffer)- Right (dur,(pid,ex)) -> mapM (\f -> f dur pid ex) resultBuild+ (dur,(pid,exit)) <- duration $ process po+ if exit == ExitSuccess || ResultCode ExitSuccess `elem` results then+ mapM (\f -> f dur pid exit) resultBuild+ else do+ exceptionBuffer <- readBuffer exceptionBuffer+ let captured = ["Stderr" | optWithStderr] ++ ["Stdout" | optWithStdout]+ cwd <- case optCwd of+ Nothing -> return ""+ Just v -> do+ v <- canonicalizePath v `catchIO` const (return v)+ return $ "Current directory: " ++ v ++ "\n"+ fail $+ "Development.Shake." ++ funcName ++ ", system command failed\n" +++ "Command: " ++ cmdline ++ "\n" +++ cwd +++ "Exit code: " ++ show (case exit of ExitFailure i -> i; _ -> 0) ++ "\n" +++ if null captured then "Stderr not captured because WithStderr False was used\n"+ else if null exceptionBuffer then intercalate " and " captured ++ " " ++ (if length captured == 1 then "was" else "were") ++ " empty"+ else intercalate " and " captured ++ ":\n" ++ unlines (dropWhile null $ lines $ concat exceptionBuffer) -- | Apply all environment operations, to produce a new environment to use.@@ -451,10 +452,10 @@ cmdResult = ([ResultCode ExitSuccess], \[ResultCode x] -> x) instance CmdResult Process where- cmdResult = ([ResultProcess Pid0], \[ResultProcess (Pid x)] -> Process x)+ cmdResult = ([ResultProcess PID0], \[ResultProcess (PID x)] -> Process x) instance CmdResult ProcessHandle where- cmdResult = ([ResultProcess Pid0], \[ResultProcess (Pid x)] -> x)+ cmdResult = ([ResultProcess PID0], \[ResultProcess (PID x)] -> x) instance CmdResult CmdLine where cmdResult = ([ResultLine ""], \[ResultLine x] -> CmdLine x)@@ -586,7 +587,7 @@ -- | The arguments to 'cmd' - see 'cmd' for examples and semantics. newtype CmdArgument = CmdArgument [Either CmdOption String]- deriving (Eq, Monoid, Show)+ deriving (Eq, Semigroup, Monoid, Show) -- | The arguments to 'cmd' - see 'cmd' for examples and semantics. class CmdArguments t where
src/Development/Shake/Internal/Args.hs view
@@ -1,6 +1,10 @@+{-# LANGUAGE TupleSections #-} -- | Command line parsing flags.-module Development.Shake.Internal.Args(shakeOptDescrs, shakeArgs, shakeArgsWith) where+module Development.Shake.Internal.Args(+ shakeOptDescrs,+ shakeArgs, shakeArgsWith, shakeArgsOptionsWith+ ) where import Paths_shake import Development.Shake.Internal.Options@@ -19,6 +23,7 @@ import Control.Monad import Data.Char import Data.Either+import Data.Functor import Data.List import Data.Maybe import Data.Version(showVersion)@@ -26,6 +31,7 @@ import System.Environment import System.Exit import System.Time.Extra+import Prelude -- | Run a build system using command line arguments for configuration.@@ -102,7 +108,15 @@ -- -- Now you can pass @--distcc@ to use the @distcc@ compiler. shakeArgsWith :: ShakeOptions -> [OptDescr (Either String a)] -> ([a] -> [String] -> IO (Maybe (Rules ()))) -> IO ()-shakeArgsWith baseOpts userOptions rules = do+shakeArgsWith opt args f = shakeArgsOptionsWith opt args $ \so a b -> fmap (so,) <$> f a b++-- | Like 'shakeArgsWith', but also lets you manipulate the 'ShakeOptions'.+shakeArgsOptionsWith+ :: ShakeOptions+ -> [OptDescr (Either String a)]+ -> (ShakeOptions -> [a] -> [String] -> IO (Maybe (ShakeOptions, Rules ())))+ -> IO ()+shakeArgsOptionsWith baseOpts userOptions rules = do addTiming "shakeArgsWith" args <- getArgs let (flag1,files,errs) = getOpt opts args@@ -169,15 +183,15 @@ appendFile file $ show (t,p) ++ "\n" return p }- (ran,res) <- redir $ do+ (ran,shakeOpts,res) <- redir $ do when printDirectory $ putWhenLn Normal $ "shake: In directory `" ++ curdir ++ "'"- rules <- rules user files+ rules <- rules shakeOpts user files case rules of- Nothing -> return (False,Right ())- Just rules -> do+ Nothing -> return (False, shakeOpts, Right ())+ Just (shakeOpts, rules) -> do res <- try_ $ shake shakeOpts $ if NoBuild `elem` flagsExtra then withoutActions rules else rules- return (True, res)+ return (True, shakeOpts, res) if not ran || shakeVerbosity shakeOpts < Normal || NoTime `elem` flagsExtra then either throwIO return res@@ -274,10 +288,10 @@ ,yes $ Option "" ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log." ,yes $ Option "p" ["progress"] (progress $ optIntArg 1 "progress" "N" $ \i s -> s{shakeProgress=prog $ fromMaybe 5 i}) "Show progress messages [every N secs, default 5]." ,yes $ Option "" ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."- ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much."+ ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Print less (pass repeatedly for even less)." ,no $ Option "" ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time." ,yes $ Option "" ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."- ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print tracing information."+ ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print more (pass repeatedly for even more)." ,no $ Option "v" ["version"] (NoArg $ Right ([Version],id)) "Print the version number and exit." ,no $ Option "w" ["print-directory"] (NoArg $ Right ([PrintDirectory True],id)) "Print the current directory." ,no $ Option "" ["no-print-directory"] (NoArg $ Right ([PrintDirectory False],id)) "Turn off -w, even if it was turned on implicitly."
src/Development/Shake/Internal/Core/Action.hs view
@@ -9,7 +9,7 @@ traced ) where -import Control.Exception.Extra+import Control.Exception import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class@@ -46,7 +46,8 @@ actionBoom runOnSuccess act clean = do cleanup <- Action $ getsRO globalCleanup undo <- liftIO $ addCleanup cleanup $ void clean- res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (mask_ undo >> clean) >> throwRAW e+ -- important to mask_ the undo/clean combo so either both happen or neither+ res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (mask_ $ undo >> clean) >> throwRAW e liftIO $ mask_ $ undo >> when runOnSuccess (void clean) return res @@ -216,7 +217,7 @@ "" -- check 3b- bad <- flip filterM localTrackUsed $ \k -> (not . null) <$> lookupDependencies globalDatabase k+ bad <- flip filterM localTrackUsed $ \k -> not . null <$> lookupDependencies globalDatabase k unless (null bad) $ do let n = length bad errorStructured
src/Development/Shake/Internal/Core/Database.hs view
@@ -5,8 +5,9 @@ module Development.Shake.Internal.Core.Database( Trace(..), newTrace, Database, withDatabase, assertFinishedDatabase,- listDepends, lookupDependencies,- BuildKey(..), build, Depends,+ listDepends, lookupDependencies, lookupStatus,+ BuildKey(..), build,+ Depends, nubDepends, Step, Result(..), progress, Stack, emptyStack, topStack, showStack, showTopStack,@@ -122,6 +123,19 @@ | Missing -- ^ I am only here because I got into the Intern table deriving Show +instance NFData Status where+ rnf x = case x of+ Ready x -> rnfResult rnf x+ Error x -> rnf $ show x -- Best I can do for arbitrary exceptions+ Loaded x -> rnfResult id x+ Waiting _ x -> maybe () (rnfResult id) x -- Can't RNF a waiting, but also unnecessary+ Missing -> ()+ where+ -- ignore the unpacked fields+ -- complex because ByteString lacks NFData in GHC 7.4 and below+ rnfResult by (Result a _ _ b _ c) = by a `seq` rnf b `seq` rnf c `seq` ()+ {-# INLINE rnfResult #-}+ data Result a = Result {result :: a -- ^ the result associated with the Key ,built :: {-# UNPACK #-} !Step -- ^ when it was actually run@@ -131,7 +145,6 @@ ,traces :: [Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run) } deriving (Show,Functor) - statusType Ready{} = "Ready" statusType Error{} = "Error" statusType Loaded{} = "Loaded"@@ -139,10 +152,10 @@ statusType Missing{} = "Missing" -getResult :: Status -> Maybe (Result ())-getResult (Ready r) = Just $ void r-getResult (Loaded r) = Just $ void r-getResult (Waiting _ r) = void <$> r+getResult :: Status -> Maybe (Result (Either BS.ByteString Value))+getResult (Ready r) = Just $ Right <$> r+getResult (Loaded r) = Just $ Left <$> r+getResult (Waiting _ r) = fmap Left <$> r getResult _ = Nothing @@ -156,7 +169,19 @@ -- Appears in diagnostic output and the Depends ctor is just verbose show = show . fromDepends +-- | Afterwards each Id must occur at most once and there are no empty Depends+nubDepends :: [Depends] -> [Depends]+nubDepends = fMany Set.empty+ where+ fMany seen [] = []+ fMany seen (Depends d:ds) = [Depends d2 | d2 /= []] ++ fMany seen2 ds+ where (d2,seen2) = fOne seen d + fOne seen [] = ([], seen)+ fOne seen (x:xs) | x `Set.member` seen = fOne seen xs+ fOne seen (x:xs) = first (x:) $ fOne (Set.insert x seen) xs++ newtype BuildKey = BuildKey {buildKey :: Stack -- Given the current stack with the key added on@@ -183,6 +208,10 @@ Ids.insert status i (k,Missing) return i +lookupStatus :: Database -> Key -> IO (Maybe (Either BS.ByteString Value))+lookupStatus Database{..} k = withLock lock $ do+ i <- internKey intern status k+ maybe Nothing (fmap result . getResult . snd) <$> Ids.lookup status i -- | Return either an exception (crash), or (how much time you spent waiting, the value) build :: Pool -> Database -> BuildKey -> Stack -> [Key] -> Capture (Either SomeException (Seconds,Depends,[Value]))@@ -190,21 +219,22 @@ join $ withLock lock $ do is <- forM ks $ internKey intern status - whenJust (checkStack is stack) $ \(badId, badKey) ->- -- everything else gets thrown via Left and can be Staunch'd- -- recursion in the rules is considered a worse error, so fails immediately- errorRuleRecursion (showStack stack ++ [show badKey]) (typeKey badKey) (show badKey)- buildMany stack is (\v -> case v of Error e -> Just e; _ -> Nothing) (\v -> return $ continue $ case v of Left e -> Left e Right rs -> Right (0, Depends is, map result rs)) $ \go -> do+ -- only bother doing the stack check if we're actually going to build stuff+ whenJust (checkStack is stack) $ \(badId, badKey) ->+ -- everything else gets thrown via Left and can be Staunch'd+ -- recursion in the rules is considered a worse error, so fails immediately+ errorRuleRecursion (showStack stack ++ [show badKey]) (typeKey badKey) (show badKey)+ time <- offsetTime go $ \x -> case x of- Left e -> addPoolHighPriority pool $ continue $ Left e- Right rs -> addPoolMediumPriority pool $ do dur <- time; continue $ Right (dur, Depends is, map result rs)+ Left e -> addPoolException pool $ continue $ Left e+ Right rs -> addPoolResume pool $ do dur <- time; continue $ Right (dur, Depends is, map result rs) return $ return () where (#=) :: Id -> (Key, Status) -> IO Status@@ -267,7 +297,7 @@ spawn :: Bool -> Stack -> Id -> Key -> Maybe (Result BS.ByteString) -> IO Status {- Waiting -} spawn dirtyChildren stack i k r = do (w, done) <- newWaiting- addPoolLowPriority pool $+ addPoolStart pool $ buildKey (addStack i k stack) step k r dirtyChildren $ \res -> do let status = either Error (Ready . thd3) res withLock lock $ do@@ -351,7 +381,7 @@ -- | Eliminate all errors from the database, pretending they don't exist-resultsOnly :: Map Id (Key, Status) -> Map Id (Key, Result ())+resultsOnly :: Map Id (Key, Status) -> Map Id (Key, Result (Either BS.ByteString Value)) resultsOnly mp = Map.map (\(k, v) -> (k, let Just r = getResult v in r{depends = map (Depends . filter (isJust . flip Map.lookup keep) . fromDepends) $ depends r})) keep where keep = Map.filter (isJust . getResult . snd) mp
src/Development/Shake/Internal/Core/Monad.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Development.Shake.Internal.Core.Monad(@@ -17,7 +18,11 @@ import Control.Monad import Prelude +#if __GLASGOW_HASKELL__ >= 800+import Control.Monad.Fail+#endif + data S ro rw = S {handler :: IORef (SomeException -> IO ()) ,ro :: ro@@ -25,7 +30,11 @@ } newtype RAW ro rw a = RAW {fromRAW :: ReaderT (S ro rw) (ContT () IO) a}- deriving (Functor, Applicative, Monad, MonadIO)+ deriving (Functor, Applicative, Monad, MonadIO+#if __GLASGOW_HASKELL__ >= 800+ , MonadFail+#endif+ ) type Capture a = (a -> IO ()) -> IO ()
src/Development/Shake/Internal/Core/Pool.hs view
@@ -1,73 +1,59 @@ --- | Thread pool implementation.+-- | Thread pool implementation. The three names correspond to the following+-- priority levels (highest to lowest):+--+-- * 'addPoolException' - things that probably result in a build error,+-- so kick them off quickly.+--+-- * 'addPoolResume' - things that started, blocked, and may have open+-- resources in their closure.+--+-- * 'addPoolStart' - rules that haven't yet started.+--+-- * 'addPoolBatch' - rules that might batch if other rules start first. module Development.Shake.Internal.Core.Pool( Pool, runPool,- addPoolHighPriority, addPoolMediumPriority, addPoolLowPriority,+ addPoolException, addPoolResume, addPoolStart, addPoolBatch, increasePool ) where import Control.Concurrent.Extra import System.Time.Extra import Control.Exception-import Control.Monad+import Control.Monad.Extra import General.Timing+import General.Extra+import qualified General.Bag as Bag import qualified Data.HashSet as Set-import qualified Data.HashMap.Strict as Map-import System.Random --------------------------------------------------------------------- -- UNFAIR/RANDOM QUEUE --- Monad for non-deterministic (but otherwise pure) computations-type NonDet a = IO a+data Queue a = Queue+ {queueException :: Bag.Bag a+ ,queueResume :: Bag.Bag a+ ,queueStart :: Bag.Bag a+ ,queueBatch :: Bag.Bag a+ } --- Left = deterministic list, Right = non-deterministic tree-data Queue a = Queue [a] (Either [a] (Tree a))+lensException = (queueException, \x v -> x{queueException=v})+lensResume = (queueResume, \x v -> x{queueResume=v})+lensStart = (queueStart, \x v -> x{queueStart=v})+lensBatch = (queueBatch, \x v -> x{queueBatch=v})+lenses = [lensException, lensResume, lensStart, lensBatch] newQueue :: Bool -> Queue a-newQueue deterministic = Queue [] $ if deterministic then Left [] else Right emptyTree--enqueuePriority :: a -> Queue a -> Queue a-enqueuePriority x (Queue p t) = Queue (x:p) t--enqueue :: a -> Queue a -> Queue a-enqueue x (Queue p (Left xs)) = Queue p $ Left $ x:xs-enqueue x (Queue p (Right t)) = Queue p $ Right $ insertTree x t--dequeue :: Queue a -> NonDet (Maybe (a, Queue a))-dequeue (Queue (p:ps) t) = return $ Just (p, Queue ps t)-dequeue (Queue [] (Left (x:xs))) = return $ Just (x, Queue [] $ Left xs)-dequeue (Queue [] (Left [])) = return Nothing-dequeue (Queue [] (Right t)) = do- bs <- randomIO- return $ case removeTree bs t of- Nothing -> Nothing- Just (x,t) -> Just (x, Queue [] $ Right t)--------------------------------------------------------------------------- TREE---- A tree where removal is random. Nodes are stored at indicies 0..n-1-data Tree a = Tree {-# UNPACK #-} !Int (Map.HashMap Int a)---emptyTree :: Tree a-emptyTree = Tree 0 Map.empty--insertTree :: a -> Tree a -> Tree a-insertTree x (Tree n mp) = Tree (n+1) $ Map.insert n x mp+newQueue deterministic = Queue b b b b+ where b = if deterministic then Bag.emptyPure else Bag.emptyRandom --- Remove an item at random, put the n-1 item to go in it's place-removeTree :: Int -> Tree a -> Maybe (a, Tree a)-removeTree rnd (Tree n mp)- | n == 0 = Nothing- | n == 1 = Just (mp Map.! 0, emptyTree)- | i == n-1 = Just (mp Map.! i, Tree (n-1) $ Map.delete i mp)- | otherwise = Just (mp Map.! i, Tree (n-1) $ Map.insert i (mp Map.! (n-1)) $ Map.delete (n-1) mp)+dequeue :: Queue a -> Bag.Randomly (Maybe (a, Queue a))+dequeue q = firstJustM f lenses where- i = abs rnd `mod` n+ f (sel, upd)+ | Just x <- Bag.remove $ sel q+ = do (x,b) <- x; return $ Just (x, upd q b)+ f _ = return Nothing ---------------------------------------------------------------------@@ -104,15 +90,9 @@ Nothing -> return (Just s, return ()) Just (now, todo2) -> return (Just s{todo = todo2}, now >> worker pool) --- | Like 'forkFinally', but the inner thread is unmasked even if you started masked.-forkFinallyUnmasked :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId-forkFinallyUnmasked act cleanup =- mask_ $ forkIOWithUnmask $ \unmask ->- try (unmask act) >>= cleanup- -- | Given a pool, and a function that breaks the S invariants, restore them -- They are only allowed to touch threadsLimit or todo-step :: Pool -> (S -> NonDet S) -> IO ()+step :: Pool -> (S -> Bag.Randomly S) -> IO () step pool@(Pool var done) op = do let onVar act = modifyVar_ var $ maybe (return Nothing) act onVar $ \s -> do@@ -139,24 +119,17 @@ _ -> return $ Just s --- | Add a new task to the pool.--- Medium priority is suitable for tasks that are resuming running after a pause.-addPoolMediumPriority :: Pool -> IO a -> IO ()-addPoolMediumPriority pool act = step pool $ \s -> do- todo <- return $ enqueue (void act) (todo s)- return s{todo = todo}+addPool (sel, upd) pool act = step pool $ \s ->+ return s{todo = upd (todo s) $ Bag.insert (void act) $ sel $ todo s} --- | Add a new task to the pool.--- Low priority is suitable for new tasks that are just starting.-addPoolLowPriority :: Pool -> IO a -> IO ()-addPoolLowPriority = addPoolMediumPriority --- | Add a new task to the pool.--- High priority is suitable for tasks that have detected failure and are resuming to propagate that failure.-addPoolHighPriority :: Pool -> IO a -> IO ()-addPoolHighPriority pool act = step pool $ \s -> do- todo <- return $ enqueuePriority (void act) (todo s)- return s{todo = todo}+-- | Add a new task to the pool. See the top of the module for the relative ordering+-- and semantics.+addPoolException, addPoolResume, addPoolStart :: Pool -> IO a -> IO ()+addPoolException = addPool lensException+addPoolResume = addPool lensResume+addPoolStart = addPool lensStart+addPoolBatch = addPool lensBatch -- | Temporarily increase the pool by 1 thread. Call the cleanup action to restore the value.@@ -195,7 +168,7 @@ _ -> throwIO BlockedIndefinitelyOnMVar handle (\BlockedIndefinitelyOnMVar -> ghc10793) $ flip onException cleanup $ do let pool = Pool s done- addPoolMediumPriority pool $ act pool+ addPoolStart pool $ act pool res <- waitBarrier done case res of Left e -> throwIO e
src/Development/Shake/Internal/Core/Rules.hs view
@@ -19,7 +19,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer.Strict-import Data.Binary+import Development.Shake.Classes import General.Binary import Data.Typeable.Extra import Data.Function@@ -28,7 +28,8 @@ import Data.Maybe import System.IO.Extra import System.IO.Unsafe-import Data.Monoid+import Data.Semigroup (Semigroup (..))+import Data.Monoid hiding ((<>)) import qualified Data.ByteString.Lazy as LBS import qualified Data.Binary.Builder as Bin import Data.Binary.Put@@ -102,9 +103,8 @@ ,userRules :: !(Map.HashMap TypeRep{-k-} UserRule_) } -instance Monoid SRules where- mempty = SRules mempty Map.empty Map.empty- mappend (SRules x1 x2 x3) (SRules y1 y2 y3) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (Map.unionWith g x3 y3)+instance Semigroup SRules where+ (SRules x1 x2 x3) <> (SRules y1 y2 y3) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (Map.unionWith g x3 y3) where f k _ _ = unsafePerformIO $ errorRuleDefinedMultipleTimes k g (UserRule_ x) (UserRule_ y) = UserRule_ $ Unordered $ fromUnordered x ++ fromUnordered (fromJust $ cast y)@@ -112,10 +112,16 @@ fromUnordered (Unordered xs) = xs fromUnordered x = [x] +instance Monoid SRules where+ mempty = SRules mempty Map.empty Map.empty+ mappend = (<>) -instance Monoid a => Monoid (Rules a) where+instance Semigroup a => Semigroup (Rules a) where+ (<>) = liftA2 (<>)++instance (Semigroup a, Monoid a) => Monoid (Rules a) where mempty = return mempty- mappend = liftA2 mappend+ mappend = (<>) -- | Add a value of type 'UserRule'.@@ -135,12 +141,12 @@ (putEx . Bin.toLazyByteString . execPut . put) (runGet get . LBS.fromChunks . return) -addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, ShakeValue value, BinaryEx key) => BuiltinLint key value -> BuiltinRun key value -> Rules ()+addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value) => BuiltinLint key value -> BuiltinRun key value -> Rules () addBuiltinRuleEx = addBuiltinRuleInternal $ BinaryOp putEx getEx -- | Unexpected version of 'addBuiltinRule', which also lets me set the 'BinaryOp'.-addBuiltinRuleInternal :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BinaryOp key -> BuiltinLint key value -> BuiltinRun key value -> Rules ()+addBuiltinRuleInternal :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value) => BinaryOp key -> BuiltinLint key value -> BuiltinRun key value -> Rules () addBuiltinRuleInternal binary lint (run :: BuiltinRun key value) = do let k = Proxy :: Proxy key v = Proxy :: Proxy value
src/Development/Shake/Internal/Core/Run.hs view
@@ -5,18 +5,19 @@ module Development.Shake.Internal.Core.Run( run, Action, actionOnException, actionFinally, apply, apply1, traced,+ getDatabaseValue, getShakeOptions, getProgress, getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,- Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO,- newCache, newCacheIO,+ Resource, newResourceIO, withResource, newThrottleIO,+ newCacheIO, unsafeExtraThread, unsafeAllowApply, parallel, orderOnlyAction,- -- Internal stuff+ batch, runAfter ) where -import Control.Exception.Extra+import Control.Exception import Control.Applicative import Data.Tuple.Extra import Control.Concurrent.Extra@@ -59,7 +60,7 @@ -- | Internal main function (not exported publicly) run :: ShakeOptions -> Rules () -> IO ()-run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id) $ do+run opts@ShakeOptions{..} rs = (if shakeLineBuffering then withLineBuffering else id) $ do opts@ShakeOptions{..} <- if shakeThreads /= 0 then return opts else do p <- getProcessorCount; return opts{shakeThreads=p} start <- offsetTime@@ -89,8 +90,8 @@ after <- newIORef [] absent <- newIORef [] withCleanup $ \cleanup -> do- _ <- addCleanup cleanup $ do- when shakeTimings printTimings+ addCleanup_ cleanup $ do+ when (shakeTimings && shakeVerbosity >= Normal) printTimings resetTimings -- so we don't leak memory withNumCapabilities shakeThreads $ do diagnostic $ return "Starting run 3"@@ -102,16 +103,16 @@ return stats{isFailure=failure} tid <- flip forkFinally (const $ signalBarrier wait ()) $ shakeProgress getProgress- _ <- addCleanup cleanup $ do+ addCleanup_ cleanup $ do killThread tid- void $ timeout 1000000 $ waitBarrier wait+ void $ timeout 1 $ waitBarrier wait addTiming "Running rules" runPool (shakeThreads == 1) shakeThreads $ \pool -> do let s0 = Global database pool cleanup start ruleinfo output opts diagnostic curdir after absent getProgress userRules let s1 = newLocal emptyStack shakeVerbosity forM_ actions $ \act ->- addPoolLowPriority pool $ runAction s0 s1 act $ \x -> case x of+ addPoolStart pool $ runAction s0 s1 act $ \x -> case x of Left e -> raiseError =<< shakeException s0 ["Top-level action/want"] e Right x -> return x maybe (return ()) (throwIO . snd) =<< readIORef except@@ -142,7 +143,10 @@ forM_ shakeLiveFiles $ \file -> do putWhen Normal $ "Writing live list to " ++ file (if file == "-" then putStr else writeFile file) $ unlines liveFiles- sequence_ . reverse =<< readIORef after+ after <- readIORef after+ unless (null after) $ do+ addTiming "Running runAfter"+ sequence_ $ reverse after checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO ()@@ -166,22 +170,29 @@ "" -lineBuffering :: IO a -> IO a-lineBuffering act = do+withLineBuffering :: IO a -> IO a+withLineBuffering act = do -- instead of withBuffering avoid two finally handlers and stack depth out <- hGetBuffering stdout err <- hGetBuffering stderr- hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering- act `finally` do- hSetBuffering stdout out- hSetBuffering stderr err+ if out == LineBuffering && err == LineBuffering then act else do+ hSetBuffering stdout LineBuffering+ hSetBuffering stderr LineBuffering+ act `finally` do+ hSetBuffering stdout out+ hSetBuffering stderr err +getDatabaseValue :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action (Maybe (Either BS.ByteString value))+getDatabaseValue k = do+ global@Global{..} <- Action getRO+ liftIO $ fmap (fmap $ fmap fromValue) $ lookupStatus globalDatabase $ newKey k++ -- | 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 'addUserRule'. -- All @key@ values passed to 'apply' become dependencies of the 'Action'.-apply :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => [key] -> Action [value]+apply :: (RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value] -- Don't short-circuit [] as we still want error messages apply (ks :: [key]) = withResultType $ \(p :: Maybe (Action [value])) -> do -- this is the only place a user can inject a key into our world, so check they aren't throwing@@ -195,7 +206,7 @@ whenJust block $ liftIO . errorNoApply tk (show <$> listToMaybe ks) case Map.lookup tk globalRules of Nothing -> liftIO $ errorNoRuleToBuildType tk (show <$> listToMaybe ks) (Just tv)- Just BuiltinRule{builtinResult=tv2} | tv /= tv2 -> errorInternal $ "result type does not match, " ++ show tv ++ " vs " ++ show tv2 + Just BuiltinRule{builtinResult=tv2} | tv /= tv2 -> errorInternal $ "result type does not match, " ++ show tv ++ " vs " ++ show tv2 _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks @@ -238,7 +249,7 @@ {result = runValue ,changed = c ,built = step- ,depends = reverse localDepends+ ,depends = nubDepends $ reverse localDepends ,execution = doubleToFloat $ dur - localDiscount ,traces = reverse localTraces} @@ -264,79 +275,13 @@ -- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible, -- use 'apply' to allow parallelism.-apply1 :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => key -> Action value+apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value apply1 = fmap head . apply . return --------------------------------------------------------------------- -- RESOURCES --- | Create a finite resource, given a name (for error messages) and a quantity of the resource that exists.--- Shake will ensure that actions using the same finite resource do not execute in parallel.--- As an example, only one set of calls to the Excel API can occur at one time, therefore--- Excel is a finite resource of quantity 1. You can write:------ @--- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=2} $ do--- 'Development.Shake.want' [\"a.xls\",\"b.xls\"]--- excel <- 'Development.Shake.newResource' \"Excel\" 1--- \"*.xls\" 'Development.Shake.%>' \\out ->--- 'Development.Shake.withResource' excel 1 $--- 'Development.Shake.cmd' \"excel\" out ...--- @------ Now the two calls to @excel@ will not happen in parallel.------ As another example, calls to compilers are usually CPU bound but calls to linkers are usually--- disk bound. Running 8 linkers will often cause an 8 CPU system to grid to a halt. We can limit--- ourselves to 4 linkers with:------ @--- disk <- 'Development.Shake.newResource' \"Disk\" 4--- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]--- \"*.exe\" 'Development.Shake.%>' \\out ->--- 'Development.Shake.withResource' disk 1 $--- 'Development.Shake.cmd' \"ld -o\" [out] ...--- \"*.o\" 'Development.Shake.%>' \\out ->--- 'Development.Shake.cmd' \"cl -o\" [out] ...--- @-newResource :: String -> Int -> Rules Resource-newResource name mx = liftIO $ newResourceIO name mx----- | Create a throttled resource, given a name (for error messages) and a number of resources (the 'Int') that can be--- used per time period (the 'Double' in seconds). Shake will ensure that actions using the same throttled resource--- do not exceed the limits. As an example, let us assume that making more than 1 request every 5 seconds to--- Google results in our client being blacklisted, we can write:------ @--- google <- 'Development.Shake.newThrottle' \"Google\" 1 5--- \"*.url\" 'Development.Shake.%>' \\out -> do--- 'Development.Shake.withResource' google 1 $--- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]--- @------ Now we will wait at least 5 seconds after querying Google before performing another query. If Google change the rules to--- allow 12 requests per minute we can instead use @'Development.Shake.newThrottle' \"Google\" 12 60@, which would allow--- greater parallelisation, and avoid throttling entirely if only a small number of requests are necessary.------ In the original example we never make a fresh request until 5 seconds after the previous request has /completed/. If we instead--- want to throttle requests since the previous request /started/ we can write:------ @--- google <- 'Development.Shake.newThrottle' \"Google\" 1 5--- \"*.url\" 'Development.Shake.%>' \\out -> do--- 'Development.Shake.withResource' google 1 $ return ()--- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]--- @------ However, the rule may not continue running immediately after 'Development.Shake.withResource' completes, so while--- we will never exceed an average of 1 request every 5 seconds, we may end up running an unbounded number of--- requests simultaneously. If this limitation causes a problem in practice it can be fixed.-newThrottle :: String -> Int -> Double -> Rules Resource-newThrottle name count period = liftIO $ newThrottleIO name count period-- -- | Run an action which uses part of a finite resource. For more details see 'Resource'. -- You cannot depend on a rule (e.g. 'need') while a resource is held. withResource :: Resource -> Int -> Action a -> Action a@@ -355,23 +300,11 @@ Action $ either throwRAW return res --- | Run an action which uses part of several finite resources. Acquires the resources in a stable--- order, to prevent deadlock. If all rules requiring more than one resource acquire those--- resources with a single call to 'withResources', resources will not deadlock.-withResources :: [(Resource, Int)] -> Action a -> Action a-withResources res act- | (r,i):_ <- filter ((< 0) . snd) res = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show i- | otherwise = f $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) res- where- f [] = act- f (r:rs) = withResource (fst $ head r) (sum $ map snd r) $ f rs----- | A version of 'newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.--- Most people should use 'newCache' instead.+-- | A version of 'Development.Shake.newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.+-- Most people should use 'Development.Shake.newCache' instead. newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v)-newCacheIO act = do- var {- :: Var (Map k (Fence (Either SomeException ([Depends],v)))) -} <- newVar Map.empty+newCacheIO (act :: k -> Action v) = do+ var :: Var (Map.HashMap k (Fence (Either SomeException ([Depends],v)))) <- newVar Map.empty return $ \key -> join $ liftIO $ modifyVar var $ \mp -> case Map.lookup key mp of Just bar -> return $ (,) mp $ do@@ -382,7 +315,7 @@ pool <- Action $ getsRO globalPool offset <- liftIO offsetTime Action $ captureRAW $ \k -> waitFence bar $ \v ->- addPoolMediumPriority pool $ do offset <- liftIO offset; k $ Right (v,offset)+ addPoolResume pool $ do offset <- liftIO offset; k $ Right (v,offset) case res of Left err -> Action $ throwRAW err Right (deps,v) -> do@@ -403,30 +336,7 @@ liftIO $ signalFence bar $ Right (deps, v) return v --- | Given an action on a key, produce a cached version that will execute the action at most once per key.--- Using the cached result will still result include any dependencies that the action requires.--- 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\" 'Development.Shake.%>' \\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 :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)-newCache = liftIO . newCacheIO - -- | Run an action without counting to the thread limit, typically used for actions that execute -- on remote machines using barely any local CPU resources. -- Unsafe as it allows the 'shakeThreads' limit to be exceeded.@@ -439,11 +349,12 @@ stop <- liftIO $ increasePool globalPool res <- tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act liftIO stop- captureRAW $ \continue -> (if isLeft res then addPoolHighPriority else addPoolMediumPriority) globalPool $ continue res+ captureRAW $ \continue -> (if isLeft res then addPoolException else addPoolResume) globalPool $ continue res -- | Execute a list of actions in parallel. In most cases 'need' will be more appropriate to benefit from parallelism. parallel :: [Action a] -> Action [a]+-- Note: There is no parallel_ unlike sequence_ because there is no stack benefit to doing so parallel [] = return [] parallel [x] = fmap return x parallel acts = Action $ do@@ -466,26 +377,14 @@ res <- act old <- Action getRW return (old, res)- addPoolMediumPriority globalPool $ runAction global local act2 $ \res -> do+ addPoolResume globalPool $ runAction global (localClearMutable local) act2 $ \res -> do writeIORef result $ Just res modifyVar_ todo $ \v -> case v of Nothing -> return Nothing Just i | i == 1 || isLeft res -> do resume; return Nothing Just i -> return $ Just $ i - 1 - -- don't construct with RecordWildCards so any new fields raise an error- modifyRW $ \root -> Local- -- immutable/stack that need copying- {localStack = localStack root- ,localVerbosity = localVerbosity root- ,localBlockApply = localBlockApply root- -- mutable locals that need integrating- ,localDepends = localDepends root ++ concatMap localDepends locals- ,localDiscount = localDiscount root + maximum (0:map localDiscount locals)- ,localTraces = localTraces root ++ concatMap localTraces locals- ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows locals- ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed locals- }+ modifyRW $ \root -> localMergeMutable root locals return results @@ -497,3 +396,72 @@ res <- fromAction act modifyRW $ \s -> s{localDepends=pre} return res+++-- | Batch different outputs into a single 'Action', typically useful when a command has a high+-- startup cost - e.g. @apt-get install foo bar baz@ is a lot cheaper than three separate+-- calls to @apt-get install@. As an example, if we have a standard build rule:+--+-- @+-- \"*.out\" 'Development.Shake.%>' \\out -> do+-- 'Development.Shake.need' [out '-<.>' \"in\"]+-- 'Development.Shake.cmd' "build-multiple" [out '-<.>' \"in\"]+-- @+--+-- Assuming that @build-multiple@ can compile multiple files in a single run,+-- and that the cost of doing so is a lot less than running each individually,+-- we can write:+--+-- @+-- 'batch' 3 (\"*.out\" 'Development.Shake.%>')+-- (\\out -> do 'Development.Shake.need' [out '-<.>' \"in\"]; return out)+-- (\\outs -> 'Development.Shake.cmd' "build-multiple" [out '-<.>' \"in\" | out \<- outs])+-- @+--+-- In constrast to the normal call, we have specified a maximum batch size of 3,+-- an action to run on each output individually (typically all the 'need' dependencies),+-- and an action that runs on multiple files at once. If we were to require lots of+-- @*.out@ files, they would typically be built in batches of 3.+--+-- If Shake ever has nothing else to do it will run batches before they are at the maximum,+-- so you may see much smaller batches, especially at high parallelism settings.+batch+ :: Int+ -> ((a -> Action ()) -> Rules ())+ -> (a -> Action b)+ -> ([b] -> Action ())+ -> Rules ()+batch mx pred one many+ | mx <= 0 = error $ "Can't call batchable with <= 0, you used " ++ show mx+ | mx == 1 = pred $ \a -> do b <- one a; many [b]+ | otherwise = do+ todo :: IORef (Int, [(b, Either SomeException Local -> IO ())]) <- liftIO $ newIORef (0, [])+ pred $ \a -> Action $ do+ b <- fromAction $ one a+ -- optimisation would be to avoid taking the continuation if count >= mx+ -- but it only saves one pool requeue per mx, which is likely to be trivial+ -- and the code becomes a lot more special cases+ global@Global{..} <- getRO+ local <- getRW+ local2 <- captureRAW $ \k -> do+ count <- atomicModifyIORef todo $ \(count, bs) -> ((count+1, (b,k):bs), count+1)+ -- only trigger on the edge so we don't have lots of waiting pool entries+ (if count == mx then addPoolResume else if count == 1 then addPoolBatch else none)+ globalPool $ go global (localClearMutable local) todo+ modifyRW $ \root -> localMergeMutable root [local2]+ where+ none _ _ = return ()++ go global@Global{..} local todo = do+ (now, count) <- atomicModifyIORef todo $ \(count, bs) ->+ if count <= mx then+ ((0, []), (bs, 0))+ else+ let (xs,ys) = splitAt mx bs+ in ((count - mx, ys), (xs, count - mx))+ (if count >= mx then addPoolResume else if count > 0 then addPoolBatch else none)+ globalPool $ go global local todo+ unless (null now) $+ runAction global local (do many $ map fst now; Action getRW) $ \x ->+ forM_ now $ \(_,k) ->+ (if isLeft x then addPoolException else addPoolResume) globalPool $ k x
src/Development/Shake/Internal/Core/Storage.hs view
@@ -30,7 +30,6 @@ import General.Extra import Data.List.Extra import Data.Maybe-import System.Directory import System.FilePath import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.HashMap.Strict as Map@@ -60,7 +59,7 @@ -- error witness is manufactured. If the witness ever changes the entire DB is -- rewritten. withStorage- :: (Show k, Eq k, Hashable k, Show v)+ :: (Show k, Eq k, Hashable k, NFData k, Show v, NFData v) => ShakeOptions -- ^ Storage options -> (IO String -> IO ()) -- ^ Logging function -> Map.HashMap k (BinaryOp v) -- ^ Witnesses@@ -68,7 +67,7 @@ -> IO a withStorage ShakeOptions{..} diagnostic witness act = withLockFileDiagnostic diagnostic (shakeFiles </> ".shake.lock") $ do let dbfile = shakeFiles </> ".shake.database"- createDirectoryIfMissing True shakeFiles+ createDirectoryRecursive shakeFiles -- complete a partially failed compress whenM (restoreChunksBackup dbfile) $ do@@ -129,6 +128,8 @@ return i Right bs -> do let (k,id,v) = load bs+ evaluate $ rnf k+ evaluate $ rnf v Ids.insert ids id (k,v) diagnostic $ do let raw x = "[len " ++ show (BS.length bs) ++ "] " ++ concat
src/Development/Shake/Internal/Core/Types.hs view
@@ -1,11 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification, DeriveFunctor #-}+{-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards #-} module Development.Shake.Internal.Core.Types( BuiltinRun, BuiltinLint, RunResult(..), RunChanged(..), UserRule(..), UserRule_(..), BuiltinRule(..), Global(..), Local(..), Action(..),- newLocal+ newLocal, localClearMutable, localMergeMutable ) where import Control.DeepSeq@@ -26,7 +27,11 @@ import General.Cleanup import Prelude +#if __GLASGOW_HASKELL__ >= 800+import Control.Monad.Fail+#endif + --------------------------------------------------------------------- -- UNDERLYING DATA TYPE @@ -34,7 +39,11 @@ -- Action values are used by 'addUserRule' and 'action'. The 'Action' monad tracks the dependencies of a rule. -- To raise an exception call 'error', 'fail' or @'liftIO' . 'throwIO'@. newtype Action a = Action {fromAction :: RAW Global Local a}- deriving (Functor, Applicative, Monad, MonadIO, Typeable)+ deriving (Functor, Applicative, Monad, MonadIO, Typeable+#if __GLASGOW_HASKELL__ >= 800+ ,MonadFail+#endif+ ) -- | How has a rule changed. data RunChanged@@ -146,3 +155,24 @@ newLocal :: Stack -> Verbosity -> Local newLocal stack verb = Local stack verb Nothing [] 0 [] [] []++-- Clear all the local mutable variables+localClearMutable :: Local -> Local+localClearMutable Local{..} = (newLocal localStack localVerbosity){localBlockApply=localBlockApply}++-- Merge, works well assuming you clear the variables first+localMergeMutable :: Local -> [Local] -> Local+-- don't construct with RecordWildCards so any new fields raise an error+localMergeMutable root xs = Local+ -- immutable/stack that need copying+ {localStack = localStack root+ ,localVerbosity = localVerbosity root+ ,localBlockApply = localBlockApply root+ -- mutable locals that need integrating+ -- note that a lot of the lists are stored in reverse, assume root happened first+ ,localDepends = concatMap localDepends xs ++ localDepends root+ ,localDiscount = localDiscount root + maximum (0:map localDiscount xs)+ ,localTraces = concatMap localTraces xs ++ localTraces root+ ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows xs+ ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed xs+ }
src/Development/Shake/Internal/Demo.hs view
@@ -8,6 +8,7 @@ import Control.Applicative import Control.Exception.Extra import Control.Monad+import General.Extra import Data.Char import Data.List import Data.Maybe@@ -50,7 +51,7 @@ require shakeLib "% You don't have the 'shake' library installed with GHC, which is required to run the demo." require hasManual "% You don't have the Shake data files installed, which are required to run the demo." - empty <- (not . any (not . all (== '.'))) <$> getDirectoryContents "."+ empty <- not . any (not . all (== '.')) <$> getDirectoryContents "." dir <- if empty then getCurrentDirectory else do home <- getHomeDirectory dir <- getDirectoryContents home@@ -62,7 +63,7 @@ require b "% Please create an empty directory to run the demo from, then run 'shake --demo' again." putStr "% Copying files... "- createDirectoryIfMissing True dir+ createDirectoryRecursive dir forM_ ["Build.hs","main.c","constants.c","constants.h","build" <.> if isWindows then "bat" else "sh"] $ \file -> copyFile (manual </> file) (dir </> file) unless isWindows $ do
src/Development/Shake/Internal/Derived.hs view
@@ -5,25 +5,31 @@ readFile', readFileLines, writeFile', writeFileLines, writeFileChanged, withTempFile, withTempDir,+ withTempFileWithin, withTempDirWithin, getHashedShakeVersion,- getShakeExtra, addShakeExtra,- apply1,- par, forP+ getShakeExtra, getShakeExtraRules, addShakeExtra,+ par, forP,+ newResource, newThrottle, withResources,+ newCache ) where import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class import System.Directory-import General.Extra import System.FilePath (takeDirectory)-import System.IO.Extra hiding (withTempFile, withTempDir, readFile')+import System.IO+import qualified System.IO.Extra as IO +import Development.Shake.Internal.Errors import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Rules import Development.Shake.Internal.Options import Development.Shake.Internal.Rules.File import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as Map+import General.Extra+import Data.List.Extra import Data.Hashable import Data.Typeable.Extra import Data.Dynamic@@ -54,15 +60,24 @@ -- | Get an item from 'shakeExtra', using the requested type as the key. Fails -- if the value found at this key does not match the requested type. getShakeExtra :: Typeable a => Action (Maybe a)-getShakeExtra = withResultType $ \(_ :: Maybe (Action (Maybe a))) -> do- let want = typeRep (Proxy :: Proxy a)- extra <- shakeExtra <$> getShakeOptions- case Map.lookup want extra of+getShakeExtra = liftIO . lookupShakeExtra . shakeExtra =<< getShakeOptions++-- | A version of 'getShakeExtra' in 'Rules'.+getShakeExtraRules :: Typeable a => Rules (Maybe a)+getShakeExtraRules = liftIO . lookupShakeExtra . shakeExtra =<< getShakeOptionsRules++lookupShakeExtra :: forall a . Typeable a => Map.HashMap TypeRep Dynamic -> IO (Maybe a)+lookupShakeExtra mp =+ case Map.lookup want mp of Just dyn | Just x <- fromDynamic dyn -> return $ Just x- | otherwise -> fail $- "getShakeExtra: Key " ++ show want ++ " had value of unexpected type " ++ show (dynTypeRep dyn)+ | otherwise -> errorStructured+ "shakeExtra value is malformed, all keys and values must agree"+ [("Key", Just $ show want)+ ,("Value", Just $ show $ dynTypeRep dyn)]+ "Use addShakeExtra to ensure shakeExtra is well-formed" Nothing -> return Nothing+ where want = typeRep (Proxy :: Proxy a) -- | Add a properly structued value to 'shakeExtra' which can be retrieved with 'getShakeExtra'. addShakeExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> Map.HashMap TypeRep Dynamic@@ -76,8 +91,9 @@ copyFile' old new = do need [old] putLoud $ "Copying from " ++ old ++ " to " ++ new- liftIO $ createDirectoryIfMissing True $ takeDirectory new- liftIO $ copyFile old new+ liftIO $ do+ createDirectoryRecursive $ takeDirectory new+ copyFile old new -- | @copyFileChanged old new@ copies the existing file from @old@ to @new@, if the contents have changed. -- The @old@ file will be tracked as a dependency.@@ -87,11 +103,12 @@ need [old] -- in newer versions of the directory package we can use copyFileWithMetadata which (we think) updates -- the timestamp as well and thus no need to read the source file twice.- unlessM (liftIO $ doesFileExist new &&^ fileEq old new) $ do+ unlessM (liftIO $ doesFileExist new &&^ IO.fileEq old new) $ do putLoud $ "Copying from " ++ old ++ " to " ++ new- liftIO $ createDirectoryIfMissing True $ takeDirectory new- -- copyFile does a lot of clever stuff with permissions etc, so make sure we just reuse it- liftIO $ copyFile old new+ liftIO $ do+ createDirectoryRecursive $ takeDirectory new+ -- copyFile does a lot of clever stuff with permissions etc, so make sure we just reuse it+ liftIO $ copyFile old new -- | Read a file, after calling 'need'. The argument file will be tracked as a dependency.@@ -100,7 +117,9 @@ -- | Write a file, lifted to the 'Action' monad. writeFile' :: MonadIO m => FilePath -> String -> m ()-writeFile' name x = liftIO $ writeFile name x+writeFile' name x = liftIO $ do+ createDirectoryRecursive $ takeDirectory name+ writeFile name x -- | A version of 'readFile'' which also splits the result into lines.@@ -116,6 +135,7 @@ -- | Write a file, but only if the contents would change. writeFileChanged :: MonadIO m => FilePath -> String -> m () writeFileChanged name x = liftIO $ do+ createDirectoryRecursive $ takeDirectory name b <- doesFileExist name if not b then writeFile name x else do -- Cannot use ByteString here, since it has different line handling@@ -132,10 +152,16 @@ -- If you require a file with a specific name, use 'withTempDir'. withTempFile :: (FilePath -> Action a) -> Action a withTempFile act = do- (file, del) <- liftIO newTempFile+ (file, del) <- liftIO IO.newTempFile act file `actionFinally` del +-- | Like 'withTempFile' but using a custom temporary directory.+withTempFileWithin :: FilePath -> (FilePath -> Action a) -> Action a+withTempFileWithin tdir act = do+ (file, del) <- liftIO $ IO.newTempFileWithin tdir+ act file `actionFinally` del + -- | Create a temporary directory inside the system temporary directory. -- The directory will be deleted after the action completes. As an example: --@@ -146,14 +172,123 @@ -- @ withTempDir :: (FilePath -> Action a) -> Action a withTempDir act = do- (dir,del) <- liftIO newTempDir+ (dir,del) <- liftIO IO.newTempDir act dir `actionFinally` del +-- | Like 'withTempDir' but using a custom temporary directory.+withTempDirWithin :: FilePath -> (FilePath -> Action a) -> Action a+withTempDirWithin tdir act = do+ (dir,del) <- liftIO $ IO.newTempDirWithin tdir+ act dir `actionFinally` del ++ -- | A 'parallel' version of 'forM'. forP :: [a] -> (a -> Action b) -> Action [b] forP xs f = parallel $ map f xs -- | Execute two operations in parallel, based on 'parallel'. par :: Action a -> Action b -> Action (a,b)-par a b = do [Left a, Right b] <- parallel [Left <$> a, Right <$> b]; return (a,b)+par a b = (\[Left a, Right b] -> (a,b)) <$> parallel [Left <$> a, Right <$> b]+++-- | Create a finite resource, given a name (for error messages) and a quantity of the resource that exists.+-- Shake will ensure that actions using the same finite resource do not execute in parallel.+-- As an example, only one set of calls to the Excel API can occur at one time, therefore+-- Excel is a finite resource of quantity 1. You can write:+--+-- @+-- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=2} $ do+-- 'Development.Shake.want' [\"a.xls\",\"b.xls\"]+-- excel <- 'Development.Shake.newResource' \"Excel\" 1+-- \"*.xls\" 'Development.Shake.%>' \\out ->+-- 'Development.Shake.withResource' excel 1 $+-- 'Development.Shake.cmd' \"excel\" out ...+-- @+--+-- Now the two calls to @excel@ will not happen in parallel.+--+-- As another example, calls to compilers are usually CPU bound but calls to linkers are usually+-- disk bound. Running 8 linkers will often cause an 8 CPU system to grid to a halt. We can limit+-- ourselves to 4 linkers with:+--+-- @+-- disk <- 'Development.Shake.newResource' \"Disk\" 4+-- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]+-- \"*.exe\" 'Development.Shake.%>' \\out ->+-- 'Development.Shake.withResource' disk 1 $+-- 'Development.Shake.cmd' \"ld -o\" [out] ...+-- \"*.o\" 'Development.Shake.%>' \\out ->+-- 'Development.Shake.cmd' \"cl -o\" [out] ...+-- @+newResource :: String -> Int -> Rules Resource+newResource name mx = liftIO $ newResourceIO name mx+++-- | Create a throttled resource, given a name (for error messages) and a number of resources (the 'Int') that can be+-- used per time period (the 'Double' in seconds). Shake will ensure that actions using the same throttled resource+-- do not exceed the limits. As an example, let us assume that making more than 1 request every 5 seconds to+-- Google results in our client being blacklisted, we can write:+--+-- @+-- google <- 'Development.Shake.newThrottle' \"Google\" 1 5+-- \"*.url\" 'Development.Shake.%>' \\out -> do+-- 'Development.Shake.withResource' google 1 $+-- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]+-- @+--+-- Now we will wait at least 5 seconds after querying Google before performing another query. If Google change the rules to+-- allow 12 requests per minute we can instead use @'Development.Shake.newThrottle' \"Google\" 12 60@, which would allow+-- greater parallelisation, and avoid throttling entirely if only a small number of requests are necessary.+--+-- In the original example we never make a fresh request until 5 seconds after the previous request has /completed/. If we instead+-- want to throttle requests since the previous request /started/ we can write:+--+-- @+-- google <- 'Development.Shake.newThrottle' \"Google\" 1 5+-- \"*.url\" 'Development.Shake.%>' \\out -> do+-- 'Development.Shake.withResource' google 1 $ return ()+-- 'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]+-- @+--+-- However, the rule may not continue running immediately after 'Development.Shake.withResource' completes, so while+-- we will never exceed an average of 1 request every 5 seconds, we may end up running an unbounded number of+-- requests simultaneously. If this limitation causes a problem in practice it can be fixed.+newThrottle :: String -> Int -> Double -> Rules Resource+newThrottle name count period = liftIO $ newThrottleIO name count period+++-- | Run an action which uses part of several finite resources. Acquires the resources in a stable+-- order, to prevent deadlock. If all rules requiring more than one resource acquire those+-- resources with a single call to 'withResources', resources will not deadlock.+withResources :: [(Resource, Int)] -> Action a -> Action a+withResources res act+ | (r,i):_ <- filter ((< 0) . snd) res = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show i+ | otherwise = f $ groupSort res+ where+ f [] = act+ f ((r,xs):rs) = withResource r (sum xs) $ f rs+++-- | Given an action on a key, produce a cached version that will execute the action at most once per key.+-- Using the cached result will still result include any dependencies that the action requires.+-- 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\" 'Development.Shake.%>' \\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 :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)+newCache = liftIO . newCacheIO
src/Development/Shake/Internal/Progress.hs view
@@ -11,7 +11,7 @@ import Data.Tuple.Extra import Control.Exception.Extra import Control.Monad-import System.Environment+import System.Environment.Extra import System.Directory import System.Process import System.FilePath@@ -28,7 +28,8 @@ import System.IO.Unsafe import Paths_shake import System.Time.Extra-import Data.Monoid+import Data.Semigroup (Semigroup (..))+import Data.Monoid hiding ((<>)) import Prelude #ifdef mingw32_HOST_OS@@ -66,10 +67,8 @@ ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before). } deriving (Eq,Ord,Show,Read,Data,Typeable)--instance Monoid Progress where- mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0)- mappend a b = Progress+instance Semigroup Progress where+ a <> b = Progress {isFailure = isFailure a `mplus` isFailure b ,countSkipped = countSkipped a + countSkipped b ,countBuilt = countBuilt a + countBuilt b@@ -84,6 +83,10 @@ } +instance Monoid Progress where+ mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0)+ mappend = (<>)+ --------------------------------------------------------------------- -- MEALY TYPE - for writing the progress functions -- See <http://hackage.haskell.org/package/machines-0.2.3.1/docs/Data-Machine-Mealy.html>@@ -302,10 +305,9 @@ {-# NOINLINE xterm #-} xterm :: Bool-xterm = System.IO.Unsafe.unsafePerformIO $+xterm = unsafePerformIO $ -- Terminal.app uses "xterm-256color" as its env variable- catch_ (("xterm" `isPrefixOf`) <$> getEnv "TERM") $- \e -> return False+ maybe False ("xterm" `isPrefixOf`) <$> lookupEnv "TERM" -- | Set the title of the current console window to the given text. If the
src/Development/Shake/Internal/Resource.hs view
@@ -87,7 +87,7 @@ if want <= finiteAvailable then (x{finiteAvailable = finiteAvailable - want}, continue) else- (x{finiteWaiting = finiteWaiting `snoc` (want, addPoolMediumPriority pool continue)}, return ())+ (x{finiteWaiting = finiteWaiting `snoc` (want, addPoolResume pool continue)}, return ()) release :: Var Finite -> Pool -> Int -> IO () release var _ i = join $ modifyVar var $ \x -> return $ f x{finiteAvailable = finiteAvailable x + i}@@ -113,7 +113,7 @@ blockPool :: Pool -> IO (IO ()) blockPool pool = do bar <- newBarrier- addPoolMediumPriority pool $ do+ addPoolResume pool $ do cancel <- increasePool pool waitBarrier bar cancel@@ -148,8 +148,8 @@ | i >= want -> return (ThrottleAvailable $ i - want, continue) | otherwise -> do stop <- blockPool pool- return (ThrottleWaiting stop $ (want - i, addPoolMediumPriority pool continue) `cons` mempty, return ())- ThrottleWaiting stop xs -> return (ThrottleWaiting stop $ xs `snoc` (want, addPoolMediumPriority pool continue), return ())+ return (ThrottleWaiting stop $ (want - i, addPoolResume pool continue) `cons` mempty, return ())+ ThrottleWaiting stop xs -> return (ThrottleWaiting stop $ xs `snoc` (want, addPoolResume pool continue), return ()) release :: Var Throttle -> Pool -> Int -> IO () release var pool n = waiter period $ join $ modifyVar var $ \x -> return $ case x of
src/Development/Shake/Internal/Rules/Directory.hs view
@@ -12,7 +12,6 @@ ) where import Control.Applicative-import Control.Exception as C import Control.Monad.Extra import Control.Monad.IO.Class import Data.Maybe@@ -47,7 +46,7 @@ show (DoesFileExistQ a) = "doesFileExist " ++ wrapQuote a newtype DoesFileExistA = DoesFileExistA {fromDoesFileExistA :: Bool}- deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)+ deriving (Typeable,Eq,BinaryEx,NFData) instance Show DoesFileExistA where show (DoesFileExistA a) = show a@@ -61,7 +60,7 @@ show (DoesDirectoryExistQ a) = "doesDirectoryExist " ++ wrapQuote a newtype DoesDirectoryExistA = DoesDirectoryExistA {fromDoesDirectoryExistA :: Bool}- deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)+ deriving (Typeable,Eq,BinaryEx,NFData) instance Show DoesDirectoryExistA where show (DoesDirectoryExistA a) = show a@@ -76,7 +75,7 @@ show (GetEnvQ a) = "getEnv " ++ wrapQuote a newtype GetEnvA = GetEnvA {fromGetEnvA :: Maybe String}- deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)+ deriving (Typeable,Eq,Hashable,BinaryEx,NFData) instance Show GetEnvA where show (GetEnvA a) = maybe "<unset>" wrapQuote a@@ -105,7 +104,7 @@ show (GetDirectoryDirsQ dir) = "getDirectoryDirs " ++ wrapQuote dir newtype GetDirectoryA = GetDirectoryA {fromGetDirectoryA :: [FilePath]}- deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)+ deriving (Typeable,Eq,Hashable,BinaryEx,NFData) instance Show GetDirectoryA where show (GetDirectoryA xs) = unwords $ map wrapQuote xs@@ -114,7 +113,10 @@ --------------------------------------------------------------------- -- RULE DEFINITIONS -queryRule :: (RuleResult key ~ value, BinaryEx key, BinaryEx witness, Eq witness, ShakeValue key, ShakeValue value)+queryRule :: (RuleResult key ~ value+ ,BinaryEx witness, Eq witness+ ,BinaryEx key, ShakeValue key+ ,Typeable value, NFData value, Show value, Eq value) => (value -> witness) -> (key -> IO value) -> Rules () queryRule witness query = addBuiltinRuleEx (\k old -> do@@ -169,8 +171,8 @@ getEnv :: String -> Action (Maybe String) getEnv = fmap fromGetEnvA . apply1 . GetEnvQ --- | Return the value of the environment variable (second argument), or the--- default value (first argument) if it is not set. Similar to 'getEnv'.+-- | @'getEnvWithDefault' def var@ returns the value of the environment variable @var@, or the+-- default value @def@ if it is not set. Similar to 'getEnv'. -- -- @ -- flags <- getEnvWithDefault \"-Wall\" \"CFLAGS\"@@ -294,14 +296,14 @@ f dir (Walk op) = f dir . WalkTo . op =<< getDirectoryContentsIO dir f dir (WalkTo (files, dirs)) = do forM_ files $ \fil ->- try $ removeItem $ dir </> fil :: IO (Either IOException ())+ tryIO $ removeItem $ dir </> fil let done = Set.fromList files forM_ (filter (not . flip Set.member done . fst) dirs) $ \(d,w) -> do let dir2 = dir </> d whenM (IO.doesDirectoryExist dir2) $ f dir2 w removeItem :: FilePath -> IO ()- removeItem x = IO.removeFile x `C.catch` \(_ :: IOException) -> removeDir x+ removeItem x = IO.removeFile x `catchIO` \_ -> removeDir x -- In newer GHC's removeDirectoryRecursive is probably better, but doesn't follow -- symlinks, so it's got different behaviour
src/Development/Shake/Internal/Rules/File.hs view
@@ -2,10 +2,11 @@ {-# LANGUAGE ViewPatterns, RecordWildCards, FlexibleInstances, TypeFamilies #-} module Development.Shake.Internal.Rules.File(- need, needBS, needed, neededBS, want,+ need, needHasChanged, needBS, needed, neededBS, want, trackRead, trackWrite, trackAllow, defaultRuleFile, (%>), (|%>), (?>), phony, (~>), phonys,+ resultHasChanged, -- * Internal only FileQ(..), FileA, fileStoredValue, fileEqualValue, EqualCost(..), fileForward ) where@@ -13,10 +14,8 @@ import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class-import System.Directory import Data.Typeable import Data.List-import Data.Bits import Data.Maybe import qualified Data.ByteString.Char8 as BS import qualified Data.HashSet as Set@@ -24,6 +23,7 @@ import Data.Word import Data.Monoid import General.Binary+import General.Extra import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Rules@@ -42,13 +42,15 @@ import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong import System.IO.Unsafe(unsafeInterleaveIO) +import Prelude + infix 1 %>, ?>, |%>, ~> --------------------------------------------------------------------- -- TYPES -type instance RuleResult FileQ = Maybe FileA+type instance RuleResult FileQ = FileR -- | The unique key we use to index File rules, to avoid name clashes. newtype FileQ = FileQ {fromFileQ :: FileName}@@ -56,8 +58,16 @@ -- | Raw information about a file. data FileA = FileA {-# UNPACK #-} !ModTime {-# UNPACK #-} !FileSize FileHash- deriving (Typeable,Eq)+ deriving (Typeable) +-- | Result of a File rule, may contain raw file information and whether the rule did run this build+data FileR = FileR { result :: Maybe FileA -- ^ Raw information about the file built by this rule.+ -- Set to 'Nothing' to prevent linting some times.+ , hasChanged :: Bool -- ^ Whether the file changed this build. Transient+ -- information, that doesn't get serialized.+ }+ deriving (Typeable)+ -- | The types of file rule that occur. data Mode = ModePhony (Action ()) -- ^ An action with no file value@@ -84,19 +94,18 @@ putEx = putEx . map fromFileQ getEx = map FileQ . getEx -instance Hashable FileA where- hashWithSalt salt (FileA a b c) = hashWithSalt salt a `xor` hashWithSalt salt b `xor` hashWithSalt salt c- instance NFData FileA where rnf (FileA a b c) = rnf a `seq` rnf b `seq` rnf c -instance Binary FileA where- put (FileA a b c) = put a >> put b >> put c- get = liftA3 FileA get get get+instance NFData FileR where+ rnf (FileR f b) = rnf f `seq` rnf b instance Show FileA where show (FileA m s h) = "File {mod=" ++ show m ++ ",size=" ++ show s ++ ",digest=" ++ show h ++ "}" +instance Show FileR where+ show FileR{..} = show result ++ if hasChanged then " recomputed" else " not recomputed"+ instance Storable FileA where sizeOf _ = 4 * 3 -- 4 Word32's alignment _ = alignment (undefined :: ModTime)@@ -182,16 +191,16 @@ -- A rule from FileQ to (Maybe FileA). The result value is only useful for linting. addBuiltinRuleEx (ruleLint opts) (ruleRun opts $ shakeRebuildApply opts) -ruleLint :: ShakeOptions -> BuiltinLint FileQ (Maybe FileA) -ruleLint opts k Nothing = return Nothing-ruleLint opts k (Just v) = do+ruleLint :: ShakeOptions -> BuiltinLint FileQ FileR+ruleLint opts k (FileR Nothing _) = return Nothing+ruleLint opts k (FileR (Just v) _) = do now <- fileStoredValue opts k return $ case now of Nothing -> Just "<missing>" Just now | fileEqualValue opts v now == EqualCheap -> Nothing | otherwise -> Just $ show now -ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ (Maybe FileA)+ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ FileR ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ x) oldBin@(fmap getEx -> old) dirtyChildren = do -- for One, rebuild makes perfect sense -- for Forward, we expect the child will have already rebuilt - Rebuild just lets us deal with code changes@@ -235,13 +244,13 @@ -- but more than that, it goes wrong if you do, see #427 asLint (ResultDirect x) = Just x asLint x = Nothing- unLint (RunResult a b _) = RunResult a b Nothing+ unLint (RunResult a b (FileR _ c)) = RunResult a b $ FileR Nothing c - retNew :: RunChanged -> Result -> Action (RunResult (Maybe FileA))- retNew c v = return $ RunResult c (runBuilder $ putEx v) (asLint v)+ retNew :: RunChanged -> Result -> Action (RunResult FileR)+ retNew c v = return $ RunResult c (runBuilder $ putEx v) (FileR (asLint v) (c == ChangedRecomputeDiff)) - retOld :: RunChanged -> Action (RunResult (Maybe FileA))- retOld c = return $ RunResult c (fromJust oldBin) $ asLint $ fromJust old+ retOld :: RunChanged -> Action (RunResult FileR)+ retOld c = return $ RunResult c (fromJust oldBin) $ FileR (asLint $ fromJust old) False -- actually run the rebuild rebuild = do@@ -267,7 +276,7 @@ answer ResultForward =<< act Just (ModeDirect act) -> do act- new <- liftIO $ storedValueError opts False "Error, rule failed to build file:" o+ new <- liftIO $ storedValueError opts False "Error, rule finished running but did not produce file:" o case new of Nothing -> retNew ChangedRecomputeDiff ResultPhony Just new -> answer ResultDirect new@@ -281,16 +290,38 @@ retNew ChangedRecomputeDiff ResultPhony -apply_ :: (a -> FileName) -> [a] -> Action [Maybe FileA]+apply_ :: (a -> FileName) -> [a] -> Action [FileR] apply_ f = apply . map (FileQ . f) +-- | Has a file changed. This function will only give the correct answer if called in the rule+-- producing the file, /before/ the rule has modified the file in question.+-- Best avoided, but sometimes necessary in conjunction with 'needHasChanged' to cause rebuilds+-- to happen if the result is deleted or modified.+resultHasChanged :: FilePath -> Action Bool+resultHasChanged file = do+ let filename = FileQ $ fileNameFromString file+ res <- getDatabaseValue filename+ old <- return $ case res of+ Nothing -> Nothing+ Just (Left bs) -> fromResult $ getEx bs+ Just (Right v) -> result v+ case old of+ Nothing -> return True+ Just old -> do+ opts <- getShakeOptions+ new <- liftIO $ fileStoredValue opts filename+ return $ case new of+ Nothing -> True+ Just new -> fileEqualValue opts old new == NotEqual++ --------------------------------------------------------------------- -- OPTIONS ON TOP -- | Internal method for adding forwarding actions fileForward :: (FilePath -> Maybe (Action FileA)) -> Rules ()-fileForward act = addUserRule $ FileRule $ fmap ModeForward . act +fileForward act = addUserRule $ FileRule $ fmap ModeForward . act -- | Add a dependency on the file arguments, ensuring they are built before continuing.@@ -313,10 +344,32 @@ need :: [FilePath] -> Action () need = void . apply_ fileNameFromString ++-- | Like 'need' but returns a list of rebuild dependencies this build.+--+-- The following example writes a list of changed dependencies to a file as its action.+--+-- @+-- \"target\" '%>' \\out -> do+-- let sourceList = [\"source1\", \"source2\"]+-- rebuildList <- 'needHasChanged' sourceList+-- 'Development.Shake.writeFileLines' out rebuildList+-- @+--+-- This function can be used to alter the action depending on which dependency needed+-- to be rebuild.+--+-- Note that a rule can be run even if no dependency has changed, for example+-- because of 'shakeRebuild' or because the target has changed or been deleted.+-- To detect the latter case you may wish to use 'resultHasChanged'.+needHasChanged :: [FilePath] -> Action [FilePath]+needHasChanged paths = do+ res <- apply_ fileNameFromString paths+ return [a | (a,b) <- zip paths res, hasChanged b]+ needBS :: [BS.ByteString] -> Action () needBS = void . apply_ fileNameFromByteString - -- | 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 ()@@ -337,7 +390,7 @@ pre <- liftIO $ mapM (fileStoredValue opts . FileQ) xs post <- apply_ id xs let bad = [ (x, if isJust a then "File change" else "File created")- | (x, a, Just b) <- zip3 xs pre post, maybe NotEqual (\a -> fileEqualValue opts a b) a == NotEqual]+ | (x, a, FileR (Just b) _) <- zip3 xs pre post, maybe NotEqual (\a -> fileEqualValue opts a b) a == NotEqual] case bad of [] -> return () (file,msg):_ -> liftIO $ errorStructured@@ -388,7 +441,7 @@ root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules () root help test act = addUserRule $ FileRule $ \x -> if not $ test x then Nothing else Just $ ModeDirect $ do- liftIO $ createDirectoryIfMissing True $ takeDirectory x+ liftIO $ createDirectoryRecursive $ takeDirectory x act x
src/Development/Shake/Internal/Rules/Files.hs view
@@ -9,7 +9,6 @@ import Control.Monad.IO.Class import Data.Maybe import Data.List.Extra-import System.Directory import Control.Applicative import Data.Typeable.Extra import General.Binary@@ -39,7 +38,7 @@ deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData) newtype FilesA = FilesA [FileA]- deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)+ deriving (Typeable,BinaryEx,NFData) instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs @@ -140,7 +139,7 @@ (if all simple ps then id else priority 0.5) $ addUserRule $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do- liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs+ liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs trackAllow xs act xs getFileTimes "&%>" xs_@@ -190,7 +189,7 @@ addUserRule $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in case checkedTest x of Just ys | ys == xs -> Just $ do- liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs+ liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs act xs getFileTimes "&?>" xs_ Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys@@ -207,6 +206,6 @@ Nothing | not $ shakeCreationCheck opts -> return $ FilesA [] Nothing -> do let missing = length $ filter isNothing ys- error $ "Error, " ++ name ++ " rule failed to build " ++ show missing +++ error $ "Error, " ++ name ++ " rule failed to produce " ++ show missing ++ " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++ concat ["\n " ++ fileNameToString x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zip xs ys]
src/Development/Shake/Internal/Rules/Oracle.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds #-} module Development.Shake.Internal.Rules.Oracle(- addOracle, askOracle, askOracleWith+ addOracle, askOracle ) where import Development.Shake.Internal.Core.Run@@ -109,10 +109,3 @@ -- to 'addOracle'. askOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => 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.------ Since the 'RuleResult' type family now fixes the result type, 'askOracle' should be used instead.-askOracleWith :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> a -> Action a-askOracleWith question _ = askOracle question
src/Development/Shake/Internal/Value.hs view
@@ -23,6 +23,11 @@ newtype QTypeRep = QTypeRep {fromQTypeRep :: TypeRep} deriving (Eq,Hashable) +instance NFData QTypeRep where+ -- Incorrect, but TypeRep doesn't have an NFData until GHC 7.10+ -- See https://github.com/haskell/deepseq/issues/37+ rnf (QTypeRep x) = x `seq` ()+ instance Show QTypeRep where show (QTypeRep x) = show x ++ " {" ++ showHex (abs $ hashWithSalt 0 x) "" ++ "}" @@ -83,7 +88,7 @@ newKey :: forall a . ShakeValue a => a -> Key newKey = Key (typeRep (Proxy :: Proxy a)) show rnf (==) hashWithSalt -newValue :: forall a . ShakeValue a => a -> Value+newValue :: forall a . (Typeable a, Show a, NFData a) => a -> Value newValue = Value (typeRep (Proxy :: Proxy a)) show rnf typeKey :: Key -> TypeRep
+ src/General/Bag.hs view
@@ -0,0 +1,40 @@++-- | A bag of elements that you can pull at either deterministically or randomly.+module General.Bag(+ Bag, Randomly,+ emptyPure, emptyRandom,+ insert, remove+ ) where++import qualified Data.HashMap.Strict as Map+import System.Random++-- Monad for random (but otherwise pure) computations+type Randomly a = IO a++data Bag a+ = BagPure [a]+ | BagRandom {-# UNPACK #-} !Int (Map.HashMap Int a)+ -- HashMap has O(n) Map.size so we record it separately++emptyPure :: Bag a+emptyPure = BagPure []++emptyRandom :: Bag a+emptyRandom = BagRandom 0 Map.empty++insert :: a -> Bag a -> Bag a+insert x (BagPure xs) = BagPure $ x:xs+insert x (BagRandom n mp) = BagRandom (n+1) $ Map.insert n x mp++remove :: Bag a -> Maybe (Randomly (a, Bag a))+remove (BagPure []) = Nothing+remove (BagPure (x:xs)) = Just $ return (x, BagPure xs)+remove (BagRandom n mp)+ | n == 0 = Nothing+ | n == 1 = Just $ return (mp Map.! 0, emptyRandom)+ | otherwise = Just $ do+ i <- randomRIO (0, n-1)+ let mp2 | i == n-1 = Map.delete i mp+ | otherwise = Map.insert i (mp Map.! (n-1)) $ Map.delete (n-1) mp+ return (mp Map.! i, BagRandom (n-1) mp2)
src/General/Bilist.hs view
@@ -4,7 +4,8 @@ Bilist, cons, snoc, uncons, toList, isEmpty ) where -import Data.Monoid+import Data.Semigroup (Semigroup(..))+import Data.Monoid hiding ((<>)) import Prelude @@ -19,9 +20,12 @@ instance Eq a => Eq (Bilist a) where a == b = toList a == toList b +instance Semigroup (Bilist a) where+ a <> b = Bilist (toList a ++ toList b) []+ instance Monoid (Bilist a) where mempty = Bilist [] []- mappend a b = Bilist (toList a ++ toList b) []+ mappend = (<>) cons :: a -> Bilist a -> Bilist a cons x (Bilist as bs) = Bilist (x:as) bs
src/General/Binary.hs view
@@ -22,7 +22,8 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.UTF8 as UTF8 import Data.Functor-import Data.Monoid+import Data.Semigroup (Semigroup (..))+import Data.Monoid hiding ((<>)) import Prelude @@ -68,10 +69,12 @@ runBuilder :: Builder -> BS.ByteString runBuilder (Builder i f) = unsafePerformIO $ BS.create i $ \ptr -> f ptr 0 +instance Semigroup Builder where+ (Builder x1 x2) <> (Builder y1 y2) = Builder (x1+y1) $ \p i -> do x2 p i; y2 p $ i+x1+ instance Monoid Builder where mempty = Builder 0 $ \_ _ -> return ()- mappend (Builder x1 x2) (Builder y1 y2) = Builder (x1+y1) $ \p i -> do x2 p i; y2 p $ i+x1-+ mappend = (<>) -- | Methods for Binary serialisation that go directly between strict ByteString values. -- When the Database is read each key/value will be loaded as a separate ByteString,
src/General/Chunks.hs view
@@ -10,13 +10,15 @@ import System.FilePath import Control.Concurrent.Extra import Control.Monad.Extra-import Control.Exception.Extra+import Control.Exception import System.IO import System.Directory import qualified Data.ByteString as BS import Data.Word import Data.Monoid import General.Binary+import General.Extra+import Prelude data Chunks = Chunks@@ -68,7 +70,7 @@ writeChan chan $ hFlush h >> return True root <- myThreadId- writer <- flip forkFinally (\e -> do signalBarrier died (); either (throwTo root) (const $ return ()) e) $+ writer <- flip forkFinally (\e -> do signalBarrier died (); whenLeft e (throwTo root)) $ -- only one thread ever writes, ensuring only the final write can be torn whileM $ join $ readChan chan @@ -94,7 +96,7 @@ -- complete a partially failed compress b <- doesFileExist $ backup file if not b then return False else do- handle (\(_ :: IOError) -> return ()) $ removeFile file+ removeFile_ file renameFile (backup file) file return True
src/General/Cleanup.hs view
@@ -1,17 +1,17 @@ -- | Code for ensuring cleanup actions are run. module General.Cleanup(- Cleanup, withCleanup, addCleanup+ Cleanup, withCleanup, addCleanup, addCleanup_ ) where -import Control.Exception as E+import Control.Exception import qualified Data.HashMap.Strict as Map-import Data.Function-import Data.IORef-import Data.List+import Control.Monad+import Data.IORef.Extra+import Data.List.Extra -data S = S {unique :: !Int, items :: Map.HashMap Int (IO ())}+data S = S {unique :: {-# UNPACK #-} !Int, items :: !(Map.HashMap Int (IO ()))} newtype Cleanup = Cleanup (IORef S) @@ -21,14 +21,22 @@ withCleanup :: (Cleanup -> IO a) -> IO a withCleanup act = do ref <- newIORef $ S 0 Map.empty- act (Cleanup ref) `finally` do- items <- atomicModifyIORef ref $ \s -> (s{items=Map.empty}, items s)- mapM_ snd $ sortBy (compare `on` negate . fst) $ Map.toList items+ act (Cleanup ref) `finally` runCleanup (Cleanup ref) +-- | Run all the cleanup actions immediately. Done automatically by withCleanup+runCleanup :: Cleanup -> IO ()+runCleanup (Cleanup ref) = do+ items <- atomicModifyIORef' ref $ \s -> (s{items=Map.empty}, items s)+ mapM_ snd $ sortOn (negate . fst) $ Map.toList items --- | Add a cleanup action to a 'Cleanup' scope, returning a way to remove that action.+-- | Add a cleanup action to a 'Cleanup' scope, returning a way to remove (but not perform) that action. -- If not removed by the time 'withCleanup' terminates then the cleanup action will be run then. addCleanup :: Cleanup -> IO () -> IO (IO ())-addCleanup (Cleanup ref) act = atomicModifyIORef ref $ \s -> let i = unique s in+addCleanup (Cleanup ref) act = atomicModifyIORef' ref $ \s -> let i = unique s in (,) (S (unique s + 1) (Map.insert i act $ items s)) $- atomicModifyIORef ref $ \s -> (s{items = Map.delete i $ items s}, ())+ atomicModifyIORef' ref $ \s -> (s{items = Map.delete i $ items s}, ())++addCleanup_ :: Cleanup -> IO () -> IO ()+-- we could avoid inserting into the Map, but we need to store the pairs anyway+-- to unregister them in order, so might as well keep it simple+addCleanup_ c act = void $ addCleanup c act
src/General/Extra.hs view
@@ -3,25 +3,31 @@ module General.Extra( getProcessorCount, withResultType,+ whenLeft, randomElem, wrapQuote, showBracket, withs, maximum', maximumBy', fastAt,- isAsyncException+ forkFinallyUnmasked,+ isAsyncException,+ removeFile_, createDirectoryRecursive,+ catchIO, tryIO, handleIO ) where -import Control.Exception.Extra+import Control.Exception import Data.Char import Data.List import System.Environment.Extra import System.IO.Extra import System.IO.Unsafe import System.Random+import System.Directory import System.Exit import Control.Concurrent import Data.Functor import Data.Primitive.Array+import Control.Applicative import Control.Monad import Control.Monad.ST import GHC.Conc(getNumProcessors)@@ -82,14 +88,13 @@ act = if rtsSupportsBoundThreads then fromIntegral <$> getNumProcessors- else- handle_ (const $ return 1) $ do- env <- lookupEnv "NUMBER_OF_PROCESSORS"- case env of- Just s | [(i,"")] <- reads s -> return i- _ -> do- src <- readFile' "/proc/cpuinfo"- return $! length [() | x <- lines src, "processor" `isPrefixOf` x]+ else do+ env <- lookupEnv "NUMBER_OF_PROCESSORS"+ case env of+ Just s | [(i,"")] <- reads s -> return i+ _ -> do+ src <- readFile' "/proc/cpuinfo" `catchIO` \_ -> return ""+ return $! max 1 $ length [() | x <- lines src, "processor" `isPrefixOf` x] ---------------------------------------------------------------------@@ -110,6 +115,16 @@ ---------------------------------------------------------------------+-- Control.Concurrent++-- | Like 'forkFinally', but the inner thread is unmasked even if you started masked.+forkFinallyUnmasked :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinallyUnmasked act cleanup =+ mask_ $ forkIOWithUnmask $ \unmask ->+ try (unmask act) >>= cleanup+++--------------------------------------------------------------------- -- Control.Exception -- | Is the exception asynchronous, not a "coding error" that should be ignored@@ -118,6 +133,37 @@ | Just (_ :: AsyncException) <- fromException e = True | Just (_ :: ExitCode) <- fromException e = True | otherwise = False++catchIO :: IO a -> (IOException -> IO a) -> IO a+catchIO = Control.Exception.catch -- GHC 7.4 has catch in the Prelude as well++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++handleIO :: (IOException -> IO a) -> IO a -> IO a+handleIO = flip catchIO+++---------------------------------------------------------------------+-- System.Directory++-- | Remove a file, but don't worry if it fails+removeFile_ :: FilePath -> IO ()+removeFile_ x = removeFile x `catchIO` \_ -> return ()++-- | Like @createDirectoryIfMissing True@ but faster, as it avoids+-- any work in the common case the directory already exists.+createDirectoryRecursive :: FilePath -> IO ()+createDirectoryRecursive dir = do+ x <- tryIO $ doesDirectoryExist dir+ when (x /= Right True) $ createDirectoryIfMissing True dir+++---------------------------------------------------------------------+-- Data.Either++whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m ()+whenLeft x f = either f (const $ pure ()) x ---------------------------------------------------------------------
src/General/FileLock.hs view
@@ -1,10 +1,10 @@-{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} module General.FileLock(withLockFile) where import Control.Exception.Extra-import System.Directory import System.FilePath+import General.Extra #ifdef mingw32_HOST_OS import Data.Bits import Data.Word@@ -42,7 +42,7 @@ #ifdef mingw32_HOST_OS withLockFile file act = withCWString file $ \cfile -> do- createDirectoryIfMissing True $ takeDirectory file+ createDirectoryRecursive $ takeDirectory file let open = c_CreateFileW cfile (c_GENERIC_READ .|. c_GENERIC_WRITE) c_FILE_SHARE_NONE nullPtr c_OPEN_ALWAYS c_FILE_ATTRIBUTE_NORMAL nullPtr bracket open c_CloseHandle $ \h -> if h == c_INVALID_HANDLE_VALUE then do@@ -57,15 +57,15 @@ #else withLockFile file act = do- createDirectoryIfMissing True $ takeDirectory file- try $ writeFile file "" :: IO (Either IOException ())+ createDirectoryRecursive $ takeDirectory file+ tryIO $ writeFile file "" bracket (openFd file ReadWrite Nothing defaultFileFlags) closeFd $ \fd -> do let lock = (WriteLock, AbsoluteSeek, 0, 0)- res <- try $ setLock fd lock+ res <- tryIO $ setLock fd lock case res of Right () -> act- Left (e :: IOException) -> do+ Left e -> do res <- getLock fd lock errorIO $ "Shake failed to acquire a file lock on " ++ file ++ "\n" ++ (case res of
src/General/ListBuilder.hs view
@@ -3,7 +3,8 @@ ListBuilder, runListBuilder, newListBuilder ) where -import Data.Monoid+import Data.Semigroup (Semigroup (..))+import Data.Monoid hiding ((<>)) import Prelude() data ListBuilder a@@ -11,11 +12,15 @@ | One a | Add (ListBuilder a) (ListBuilder a) ++instance Semigroup (ListBuilder a) where+ Zero <> x = x+ x <> Zero = x+ x <> y = Add x y+ instance Monoid (ListBuilder a) where mempty = Zero- mappend Zero x = x- mappend x Zero = x- mappend x y = Add x y+ mappend = (<>) newListBuilder :: a -> ListBuilder a newListBuilder = One
src/General/Process.hs view
@@ -92,19 +92,20 @@ stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ()) stdIn file [] = (Inherit, const $ return ()) stdIn file [SrcFile x] = (UseHandle $ file x, const $ return ())-stdIn file src = (,) CreatePipe $ \h ->- void $ tryBool isPipeGone $ do- forM_ src $ \x -> case x of- SrcString x -> hPutStr h x- SrcBytes x -> LBS.hPutStr h x- SrcFile x -> LBS.hPutStr h =<< LBS.hGetContents (file x)- hFlush h- hClose h- where- isPipeGone IOError{ioe_type=ResourceVanished, ioe_errno=Just ioe} = Errno ioe == ePIPE- isPipeGone _ = False+stdIn file src = (,) CreatePipe $ \h -> ignoreSigPipe $ do+ forM_ src $ \x -> case x of+ SrcString x -> hPutStr h x+ SrcBytes x -> LBS.hPutStr h x+ SrcFile x -> LBS.hPutStr h =<< LBS.hGetContents (file x)+ hClose h +ignoreSigPipe :: IO () -> IO ()+ignoreSigPipe = handleIO $ \e -> case e of+ IOError {ioe_type=ResourceVanished, ioe_errno=Just ioe} | Errno ioe == ePIPE -> return ()+ _ -> throwIO e++ withTimeout :: Maybe Double -> IO () -> IO a -> IO a withTimeout Nothing stop go = go withTimeout (Just s) stop go = bracket (forkIO $ sleep s >> stop) killThread $ const go@@ -130,19 +131,6 @@ -- seems to happen with some GHC 7.2 compiled binaries with FFI etc terminateProcess pid --- FIXME: There is a new withCreateProcess in process-1.4.3.0 which is probably better than ours...-withCreateProcessOld :: CreateProcess -> ((Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO a) -> IO a-withCreateProcessOld cp act = mask $ \restore -> do- ans@(inh, outh, errh, pid) <- createProcess cp- onException (restore $ act ans) $ do- mapM_ (`whenJust` hClose) [inh, outh, errh]- ignore $ do- -- sometimes we fail before the process is valid- -- therefore if terminate process fails, skip waiting on the process- terminateProcess pid- void $ waitForProcess pid-- withFiles :: IOMode -> [FilePath] -> ((FilePath -> Handle) -> IO a) -> IO a withFiles mode files act = withs (map (`withFile` mode) files) $ \handles -> act $ \x -> fromJust $ lookup x $ zip files handles@@ -158,7 +146,7 @@ let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = isJust poTimeout, close_fds = True ,std_in = fst $ stdIn inHandle poStdin ,std_out = stdStream outHandle poStdout poStderr, std_err = stdStream outHandle poStderr poStdout}- withCreateProcessOld cp $ \(inh, outh, errh, pid) ->+ withCreateProcessCompat cp $ \inh outh errh pid -> withTimeout poTimeout (abort pid) $ do let streams = [(outh, stdout, poStdout) | Just outh <- [outh], CreatePipe <- [std_out cp]] ++@@ -223,3 +211,16 @@ -- implementation copied below bsHGetSome :: Handle -> Int -> IO BS.ByteString bsHGetSome h i = BS.createAndTrim i $ \p -> hGetBufSome h p i++-- available in process-1.4.3.0, GHC ??? (Nov 2015)+-- logic copied directly (apart from Ctrl-C handling magic using internal pieces)+withCreateProcessCompat :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a+withCreateProcessCompat cp act = bracketOnError (createProcess cp) cleanup+ (\(m_in, m_out, m_err, ph) -> act m_in m_out m_err ph)+ where+ cleanup (inh, outh, errh, pid) = do+ terminateProcess pid+ whenJust inh $ ignoreSigPipe . hClose+ whenJust outh hClose+ whenJust errh hClose+ forkIO $ void $ waitForProcess pid
src/Run.hs view
@@ -10,6 +10,7 @@ import Control.Exception.Extra import Data.Maybe import qualified System.Directory as IO+import General.Extra import General.GetOpt import System.Process import System.Exit@@ -28,19 +29,18 @@ if takeExtension file `elem` [".hs",".lhs"] then ("runhaskell", file:args) else (toNative file, args) e <- rawSystem prog args when (e /= ExitSuccess) $ exitWith e- Nothing -> - withArgs ("--no-time":args) $- shakeArgsWith shakeOptions{shakeCreationCheck=False} flags $ \opts targets -> do- let tool = listToMaybe [x | Tool x <- opts]- makefile <- case reverse [x | UseMakefile x <- opts] of- x:_ -> return x- _ -> do- res <- findFile ["build.ninja"]- case res of- Just x -> return x- Nothing -> errorIO "Could not find `build.ninja'"- runNinja makefile targets tool-+ Nothing -> do+ let go = shakeArgsWith shakeOptions{shakeCreationCheck=False} flags $ \opts targets -> do+ let tool = listToMaybe [x | Tool x <- opts]+ makefile <- case reverse [x | UseMakefile x <- opts] of+ x:_ -> return x+ _ -> do+ res <- findFile ["build.ninja"]+ case res of+ Just x -> return x+ Nothing -> errorIO "Could not find `build.ninja'"+ runNinja go makefile targets tool+ withArgs ("--no-time":args) go data Flag = UseMakefile FilePath | Tool String@@ -50,4 +50,4 @@ ] findFile :: [FilePath] -> IO (Maybe FilePath)-findFile = findM (fmap (either (const False) id) . try_ . IO.doesFileExist)+findFile = findM (fmap (either (const False) id) . tryIO . IO.doesFileExist)
src/Test.hs view
@@ -11,11 +11,11 @@ import Development.Shake.Internal.FileName import qualified Data.ByteString.Char8 as BS import Test.Type(sleepFileTimeCalibrate)-import Control.Concurrent+import Control.Concurrent.Extra import Prelude -import qualified Test.Rebuild as Rebuild import qualified Test.Basic as Basic+import qualified Test.Batch as Batch import qualified Test.Benchmark as Benchmark import qualified Test.C as C import qualified Test.Cache as Cache@@ -27,9 +27,9 @@ import qualified Test.Errors as Errors import qualified Test.Existence as Existence import qualified Test.FileLock as FileLock-import qualified Test.Files as Files import qualified Test.FilePath as FilePath import qualified Test.FilePattern as FilePattern+import qualified Test.Files as Files import qualified Test.Forward as Forward import qualified Test.Journal as Journal import qualified Test.Lint as Lint@@ -44,6 +44,7 @@ import qualified Test.Pool as Pool import qualified Test.Progress as Progress import qualified Test.Random as Random+import qualified Test.Rebuild as Rebuild import qualified Test.Resources as Resources import qualified Test.Self as Self import qualified Test.Tar as Tar@@ -59,19 +60,46 @@ fakes = ["clean" * clean, "test" * test, "make" * makefile, "filetime" * filetime] where (*) = (,) -mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main- ,"basic" * Basic.main, "cache" * Cache.main, "command" * Command.main- ,"config" * Config.main, "digest" * Digest.main, "directory" * Directory.main- ,"docs" * Docs.main- ,"errors" * Errors.main, "existence" * Existence.main- ,"orderonly" * OrderOnly.main- ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main, "filelock" * FileLock.main- ,"forward" * Forward.main, "match" * Match.main- ,"journal" * Journal.main, "lint" * Lint.main, "live" * Live.main, "manual" * Manual.main- ,"monad" * Monad.main, "parallel" * Parallel.main, "pool" * Pool.main, "random" * Random.main, "ninja" * Ninja.main- ,"resources" * Resources.main, "rebuild" * Rebuild.main, "benchmark" * Benchmark.main- ,"oracle" * Oracle.main, "progress" * Progress.main, "unicode" * Unicode.main, "util" * Util.main- ,"verbosity" * Verbosity.main, "version" * Version.main, "tup" * Tup.main]+mains =+ ["basic" * Basic.main+ ,"batch" * Batch.main+ ,"benchmark" * Benchmark.main+ ,"c" * C.main+ ,"cache" * Cache.main+ ,"command" * Command.main+ ,"config" * Config.main+ ,"digest" * Digest.main+ ,"directory" * Directory.main+ ,"docs" * Docs.main+ ,"errors" * Errors.main+ ,"existence" * Existence.main+ ,"filelock" * FileLock.main+ ,"filepath" * FilePath.main+ ,"filepattern" * FilePattern.main+ ,"files" * Files.main+ ,"forward" * Forward.main+ ,"journal" * Journal.main+ ,"lint" * Lint.main+ ,"live" * Live.main+ ,"manual" * Manual.main+ ,"match" * Match.main+ ,"monad" * Monad.main+ ,"ninja" * Ninja.main+ ,"oracle" * Oracle.main+ ,"orderonly" * OrderOnly.main+ ,"parallel" * Parallel.main+ ,"pool" * Pool.main+ ,"progress" * Progress.main+ ,"random" * Random.main+ ,"rebuild" * Rebuild.main+ ,"resources" * Resources.main+ ,"self" * Self.main+ ,"tar" * Tar.main+ ,"tup" * Tup.main+ ,"unicode" * Unicode.main+ ,"util" * Util.main+ ,"verbosity" * Verbosity.main+ ,"version" * Version.main] where (*) = (,) @@ -112,19 +140,15 @@ args <- getArgs addTiming "Reading files" files <- fmap concat $ forM (drop 1 args) $ \file ->- (BS.lines . BS.filter (/= '\r')) <$> BS.readFile file+ BS.lines . BS.filter (/= '\r') <$> BS.readFile file let n = length files evaluate n addTiming "Modtime" let (a,bcd) = splitAt (n `div` 4) files let (b,cd) = splitAt (n `div` 4) bcd let (c,d) = splitAt (n `div` 4) cd- vars <- forM [a,b,c,d] $ \xs -> do- mvar <- newEmptyMVar- forkIO $ do- mapM_ (getFileInfo . fileNameFromByteString) xs- putMVar mvar ()- return $ takeMVar mvar+ vars <- forM [a,b,c,d] $ \xs ->+ onceFork $ mapM_ (getFileInfo . fileNameFromByteString) xs sequence_ vars printTimings
src/Test/Basic.hs view
@@ -81,7 +81,7 @@ "rerun" %> \out -> do alwaysRerun; liftIO $ appendFile out "." phony "foo" $- liftIO $ createDirectoryIfMissing True "foo"+ liftIO $ createDirectoryRecursive "foo" phony "ordering2" $ liftIO $ appendFile "order.log" "X"@@ -120,7 +120,7 @@ show shakeOptions === show shakeOptions - createDirectoryIfMissing True "dir"+ createDirectoryRecursive "dir" writeFile "dir/ae.txt" "" writeFile "dir/ea.txt" "" build ["halfclean"]@@ -182,7 +182,7 @@ build ["slash" </> "platform","slash" </> "forward"] build ["slash/platform","slash/forward"] - createDirectoryIfMissing True "ids"+ createDirectoryRecursive "ids" writeFile "ids/source" "ids/a" build ["ids/out","--sleep"] writeFile ".log" ""
+ src/Test/Batch.hs view
@@ -0,0 +1,88 @@++module Test.Batch(main) where++import Development.Shake+import Development.Shake.FilePath+import System.Directory+import General.Extra+import Test.Type+import Control.Monad+++main = shakeTest test [] $ \opts -> do+ let inp x = x -<.> "in"+ file <- newResource "log.txt" 1+ batch 3 ("*.out" %>) (\out -> do need [inp out]; return out) $ \outs -> do+ liftIO $ assertBool (length outs <= 3) "length outs <= 3"+ withResource file 1 $ liftIO $ appendFile "log.txt" $ show (length outs) ++ "\n"+ putNormal $ "Building batch: " ++ unwords outs+ forM_ outs $ \out -> liftIO $ copyFile (inp out) out+ want [show i <.> "out" | i <- [1..6]]++ "ABn.txt" %> \out -> do+ xs <- needHasChanged ["An.txt", "Bn.txt"]+ writeFileLines out xs++ ["An", "Bn"] &?%> \outs -> do+ xs <- needHasChanged $ map (-<.> "in") outs+ os <- mapM resultHasChanged outs+ forM_ (zip outs os) $ \(out, o) ->+ when (o || (out -<.> "in" `elem` xs)) $+ writeFile' out "1"++ "On" %> \out -> do+ xs <- needHasChanged ["An", "Bn"]+ o <- resultHasChanged out+ writeFileLines out $ xs ++ ["On" | o]+++test build = do+ forM_ [1..6] $ \i -> writeFile (show i <.> "in") $ show i+ build ["--sleep","-j2"]+ assertBoolIO (do src <- readFile "log.txt"; return $ length (lines src) < 6) "some batching"+ writeFile "log.txt" ""+ writeFile "2.in" "22"+ writeFile "5.in" "55"+ build []+ assertContents "log.txt" "2\n"++ writeFile "An.txt" "1"+ writeFile "Bn.txt" "1"+ build ["ABn.txt", "--sleep"]+ assertContents "ABn.txt" "An.txt\nBn.txt\n"+ writeFile "An.txt" "1"+ build ["ABn.txt", "--sleep"]+ assertContents "ABn.txt" "An.txt\n"+ writeFile "Bn.txt" "1"+ build ["ABn.txt", "--sleep"]+ assertContents "ABn.txt" "Bn.txt\n"+ build ["ABn.txt", "--sleep"]+ assertContents "ABn.txt" "Bn.txt\n"+ writeFile "ABn.txt" "bogus"+ build ["ABn.txt", "--sleep"]+ assertContents "ABn.txt" ""++ forM_ [[],["--usepredicate"]] $ \args -> do+ writeFile "An.in" "1"+ writeFile "Bn.in" "1"+ removeFile_ "On"+ build $ ["On", "--sleep"] ++ args+ assertContents "On" "An\nBn\nOn\n"+ writeFile "An.in" "1"+ build $ ["On", "--sleep"] ++ args+ assertContents "On" "An\n"+ writeFile "Bn.in" "1"+ build $ ["On", "--sleep"] ++ args+ assertContents "On" "Bn\n"+ build $ ["On", "--sleep"] ++ args+ assertContents "On" "Bn\n"+ removeFile "An"+ build $ ["On", "--sleep"] ++ args+ assertContents "On" "An\n"+ removeFile "An"+ writeFile "Bn.in" "2"+ build $ ["On", "--sleep"] ++ args+ assertContents "On" "An\nBn\n"+ removeFile "On"+ build $ ["On", "--sleep"] ++ args+ assertContents "On" "On\n"
src/Test/Command.hs view
@@ -79,14 +79,20 @@ let norm = fmap dropTrailingPathSeparator . canonicalizePath . trim liftIO $ join $ liftM2 (===) (norm out) (norm "helper") - "timeout" !> do- opts <- getShakeOptions- offset <- liftIO offsetTime+ let checkTimeout act = do+ offset <- liftIO offsetTime+ act+ t <- liftIO offset+ putNormal $ "Timed out in " ++ showDuration t+ when (t < 2 || t > 8) $ error $ "failed to timeout, took " ++ show t++ "timeout1" !> checkTimeout (do Exit exit <- cmd (Timeout 2) helper "w20"- t <- liftIO offset- putNormal $ "Timed out in " ++ showDuration t- when (exit == ExitSuccess) $ error "== ExitSuccess"- when (t < 2 || t > 8) $ error $ "failed to timeout, took " ++ show t+ liftIO $ assertBool (exit /= ExitSuccess) "exit was ExitSuccess")++ "timeout2" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ helper "w20"++ when False $ "timeout3" !> do checkTimeout $ liftIO $ timeout 2 $ cmd_ Shell helper "w20" "env" !> do -- use liftIO since it blows away PATH which makes lint-tracker stop working
src/Test/Directory.hs view
@@ -7,7 +7,8 @@ import Data.List import Data.Function import Control.Monad-import System.Directory(getCurrentDirectory, createDirectory, createDirectoryIfMissing)+import General.Extra+import System.Directory(getCurrentDirectory, createDirectory) import qualified System.Directory as IO import qualified System.IO.Extra as IO @@ -84,11 +85,11 @@ let removeTest pat del keep = IO.withTempDir $ \dir -> do forM_ (del ++ keep) $ \s -> do- createDirectoryIfMissing True $ dir </> takeDirectory s+ createDirectoryRecursive $ dir </> takeDirectory s unless (hasTrailingPathSeparator s) $ writeFile (dir </> s) "" removeFiles dir pat- createDirectoryIfMissing True dir+ createDirectoryRecursive dir forM_ (map ((,) False) del ++ map ((,) True) keep) $ \(b,s) -> do b2 <- (if hasTrailingPathSeparator s then IO.doesDirectoryExist else IO.doesFileExist) $ dir </> s when (b /= b2) $ do
src/Test/Docs.hs view
@@ -8,6 +8,7 @@ import Test.Type import Control.Monad import Data.Char+import General.Extra import Data.List.Extra import Data.Maybe import System.Info@@ -29,7 +30,7 @@ need $ map (root </>) ["shake.cabal","Setup.hs"] -- Make Cabal and Stack play nicely path <- getEnv "GHC_PACKAGE_PATH"- liftIO $ createDirectoryIfMissing True "dist"+ liftIO $ createDirectoryRecursive "dist" dist <- liftIO $ canonicalizePath "dist" -- make sure it works even if we cwd cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd root) "runhaskell Setup.hs configure" ["--builddir=" ++ dist,"--user"]@@ -121,8 +122,11 @@ ,"out = \"\"" ,"str1 = \"\"" ,"str2 = \"\""+ ,"def = undefined"+ ,"var = undefined" ,"str = \"\""] ++ rest+ liftIO $ putStrLn =<< readFile out "Files.lst" %> \out -> do need [root </> "src/Test/Docs.hs"] -- so much of the generator is in this module@@ -130,8 +134,10 @@ filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"] filesMd <- getDirectoryFiles (root </> "docs") ["*.md"] writeFileChanged out $ unlines $- ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs, not $ "-Classes.html" `isSuffixOf` x] ++- ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd, takeBaseName x `notElem` ["Developing","Model"]]+ ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs,+ not $ any (`isSuffixOf` x) ["-Classes.html", "-FilePath.html"]] +++ ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd,+ takeBaseName x `notElem` ["Developing","Model"]] let needModules = do mods <- readFileLines "Files.lst"; need [m <.> "hs" | m <- mods]; return mods @@ -300,7 +306,7 @@ isProgram :: String -> Bool isProgram (words -> x:xs) = x `elem` programs && all (\x -> isCmdFlag x || isFilePath x || all isAlpha x || x == "&&") xs- where programs = words "excel gcc cl make ghc cabal distcc build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh"+ where programs = words "excel gcc cl make ghc cabal distcc build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple" -- | Should a fragment be whitelisted and not checked whitelist :: String -> Bool@@ -327,7 +333,7 @@ ,"1m25s (15%)" ,"3m12s (82%)" ,"getPkgVersion $ GhcPkgVersion \"shake\""- ,"ghc --make MyBuildSystem -threaded -rtsopts \"-with-rtsopts=-I0 -qg qb\""+ ,"ghc --make MyBuildSystem -threaded -rtsopts \"-with-rtsopts=-I0 -qg -qb\"" ,"# command-name (for file-name)" ,"<i>build rules</i>" ,"<i>actions</i>"
src/Test/Errors.hs view
@@ -1,14 +1,17 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Test.Errors(main) where import Development.Shake+import Development.Shake.Classes import Development.Shake.FilePath import Test.Type import Data.List import Control.Monad import Control.Concurrent import General.GetOpt-import Control.Exception.Extra hiding (assert)+import General.Extra+import Control.Exception.Extra import System.Directory as IO import System.Time.Extra import qualified System.IO.Extra as IO@@ -17,6 +20,12 @@ data Args = Die deriving (Eq,Enum,Bounded,Show) +newtype BadBinary = BadBinary String deriving (NFData,Show,Eq,Hashable,Typeable)+type instance RuleResult BadBinary = BadBinary+instance Binary BadBinary where+ put (BadBinary x) = put x+ get = do x <- get; if x == "bad" then error "get: BadBinary \"bad\"" else return $ BadBinary x+ main = shakeTest test optionsEnum $ \args -> do "norule" %> \_ -> need ["norule_isavailable"]@@ -94,9 +103,9 @@ when (Die `elem` args) $ action $ error "death error" - "fresh_dir" %> \out -> liftIO $ createDirectoryIfMissing True out+ "fresh_dir" %> \out -> liftIO $ createDirectoryRecursive out "need_dir" %> \out -> do- liftIO $ createDirectoryIfMissing True "existing_dir"+ liftIO $ createDirectoryRecursive "existing_dir" need ["existing_dir"] writeFile' out "" @@ -121,14 +130,24 @@ liftIO $ sleep 20 writeFile' out "" + addOracle $ \(BadBinary x) -> return $ BadBinary $ 'b':x+ "badinput" %> \out -> do+ askOracle $ BadBinary "bad"+ liftIO $ appendFile out "x"+ "badoutput" %> \out -> do+ askOracle $ BadBinary "ad"+ liftIO $ appendFile out "x"+ "badnone" %> \out -> do+ alwaysRerun+ liftIO $ appendFile out "x"+ -- not tested by default since only causes an error when idle GC is turned on phony "block" $ liftIO $ putStrLn $ let x = x in x test build = do let crash args parts = assertException parts (build $ "--quiet" : args)- build ["clean"]- build ["--sleep"]+ build ["clean","--sleep"] writeFile "chain.1" "x" build ["chain.3","--sleep"]@@ -208,3 +227,16 @@ -- check a fast failure aborts a slow success (t, _) <- duration $ crash ["fast_failure","slow_success","-j2"] ["die"] assertBool (t < 10) $ "Took too long, expected < 10, got " ++ show t++ -- for exceptions on Key we die while reading the database, and restart from scratch+ build ["badinput"]+ build ["badinput","--silent"]+ assertContents "badinput" "xx"+ build ["badnone","--silent"] -- must be able to still run other rules+ assertContents "badnone" "x"++ -- for exceptions on Value we die while running the rule that requires it+ build ["badoutput"]+ crash ["badoutput"] ["badoutput","BadBinary"]+ build ["badnone"] -- must be able to still run other rules+ assertContents "badnone" "xx"
src/Test/FileLock.hs view
@@ -7,6 +7,7 @@ import Control.Monad import Data.Either.Extra import System.Time.Extra+import System.Info.Extra import Test.Type @@ -17,7 +18,8 @@ putNormal "Finished sleep" -test build = do+-- Disabled under Mac because it fails, see #560+test build = unless isMac $ do -- check it fails exactly once time <- offsetTime lock <- newLock
src/Test/Files.hs view
@@ -7,11 +7,9 @@ import Test.Type import Control.Monad import Data.List-import General.GetOpt -data Args = UsePredicate deriving (Eq,Show,Bounded,Enum) -main = shakeTest test optionsEnum $ \opts -> do+main = shakeTest test [] $ \opts -> do want ["even.txt","odd.txt"] "A1-plus-B" %> \out -> do@@ -25,10 +23,6 @@ "B" %> \out -> writeFileLines out ["This is", "B"]-- -- Since &?> and &%> are implemented separately we test everything in both modes- let deps &?%> act | UsePredicate `elem` opts = (\x -> if x `elem` deps then Just deps else Nothing) &?> act- | otherwise = deps &%> act ["even.txt","odd.txt"] &?%> \[evens,odds] -> do src <- readFileLines "numbers.txt"
src/Test/Lint.hs view
@@ -5,6 +5,7 @@ import Development.Shake import Development.Shake.Classes import Development.Shake.FilePath+import General.Extra import Test.Type import Control.Exception import System.Directory as IO@@ -17,7 +18,7 @@ main = shakeTest_ test $ do addOracle $ \Zero{} -> do- liftIO $ createDirectoryIfMissing True "dir"+ liftIO $ createDirectoryRecursive "dir" liftIO $ setCurrentDirectory "dir" return $ Zero () @@ -33,7 +34,7 @@ "cdir.*" %> \out -> do pwd <- liftIO getCurrentDirectory let dir2 = "dir" ++ takeExtension out- liftIO $ createDirectoryIfMissing True dir2+ liftIO $ createDirectoryRecursive dir2 liftIO $ setCurrentDirectory dir2 liftIO $ sleep 0.2 liftIO $ setCurrentDirectory pwd
src/Test/Ninja.hs view
@@ -3,10 +3,11 @@ import Development.Shake import qualified Development.Shake.Config as Config-import System.Directory(copyFile, createDirectoryIfMissing, removeFile)+import System.Directory(copyFile, removeFile) import Control.Applicative import Control.Monad import General.GetOpt+import General.Extra import Test.Type import qualified Data.HashMap.Strict as Map import Data.List@@ -19,14 +20,14 @@ opts = Option "" ["arg"] (ReqArg Right "") "" main = shakeTest test [opts] $ \opts -> do- let args2 = "-C." : opts- let real = "real" `elem` args2- action $- if real then cmd "ninja" args2 else liftIO $ withArgs args2 Run.main+ let real = "real" `elem` opts+ action $ if real+ then cmd "ninja" opts+ else liftIO $ withArgs ("--lint":"--report=report.html":opts) Run.main test build = do- let runEx ninja shake = build $ "--exception" : map ("--arg=" ++) (words ninja) ++ words shake+ let runEx ninja shake = build $ "--exception" : "--no-report" : map ("--arg=" ++) (words ninja) ++ words shake let run ninja = runEx ninja [] let runFail ninja bad = assertException [bad] $ runEx ninja "--quiet" @@ -44,7 +45,7 @@ copyFile "../../src/Test/Ninja/test3-sub.ninja" "test3-sub.ninja" copyFile "../../src/Test/Ninja/test3-inc.ninja" "test3-inc.ninja"- createDirectoryIfMissing True "subdir"+ createDirectoryRecursive "subdir" copyFile "../../src/Test/Ninja/subdir/1.ninja" "subdir/1.ninja" copyFile "../../src/Test/Ninja/subdir/2.ninja" "subdir/2.ninja" run "-f../../src/Test/Ninja/test3.ninja"@@ -73,7 +74,7 @@ run "-f../../src/Test/Ninja/lint.ninja good --lint" runFail "-f../../src/Test/Ninja/lint.ninja bad --lint" "not a pre-dependency" - res <- fmap (drop 1 . lines . fst) $ captureOutput $ runEx "-f../../src/Test/Ninja/compdb.ninja -t compdb cxx" "--no-report --quiet"+ res <- fmap (drop 1 . lines . fst) $ captureOutput $ runEx "-f../../src/Test/Ninja/compdb.ninja -t compdb cxx" "--quiet" want <- lines <$> readFile "../../src/Test/Ninja/compdb.output" let eq a b | (a1,'*':a2) <- break (== '*') a = unless (a1 `isPrefixOf` b && a2 `isSuffixOf` b) $ a === b | otherwise = a === b@@ -102,6 +103,13 @@ run "-f../../src/Test/Ninja/lexical.ninja" assertContentsWords "lexical.txt" "XFoo_BarXXFooX.bar"++ run "-f../../src/Test/Ninja/continuations.ninja"+ assertExists "continuations.txt"++ copyFile "../../src/Test/Ninja/restart.ninja" "restart.ninja"+ runEx "-frestart.ninja" "--sleep"+ assertExists "restart.txt" when False $ do -- currently fails because Shake doesn't match Ninja here
+ src/Test/Ninja/continuations.ninja view
@@ -0,0 +1,12 @@++rule $+ run+ command $+ = $+ touch $+ $out++build $+ continuations.txt $+ : $+ run
src/Test/Ninja/lint.ninja view
@@ -6,8 +6,14 @@ 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 good: phony good1 good2++build good1: run || good1.gen+build good1.gen: gen++build good2: run || good2_phony+build good2_phony: phony good2.gen+build good2.gen: gen build bad: run | input build bad.gen: gen
+ src/Test/Ninja/restart.ninja view
@@ -0,0 +1,8 @@++rule add+ command = echo build restart.txt: self >> $out++build restart.ninja: add++rule self+ command = echo $out > $out
src/Test/Pool.hs view
@@ -14,7 +14,7 @@ test build = do -- See #474, we should never be running pool actions masked- let addPool pool act = addPoolMediumPriority pool $ do+ let addPool pool act = addPoolStart pool $ do Unmasked <- getMaskingState act @@ -60,6 +60,19 @@ addPool pool $ signalBarrier done () assertWithin 1 $ waitBarrier done++ -- check high priority stuff runs first+ res <- newVar ""+ runPool deterministic 1 $ \pool -> do+ let note c = modifyVar_ res $ return . (c:)+ -- deliberately in a random order+ addPoolBatch pool $ note 'b'+ addPoolException pool $ note 'e'+ addPoolStart pool $ note 's'+ addPoolStart pool $ note 's'+ addPoolResume pool $ note 'r'+ addPoolException pool $ note 'e'+ (=== "bssree") =<< readVar res -- check that killing a thread pool stops the tasks, bug 545 thread <- newBarrier
src/Test/Self.hs view
@@ -33,9 +33,8 @@ Stdout out <- quietly $ cmd "ghc-pkg list --simple-output" return $ words out - ghcFlags <- addOracle $ \GhcFlags{} -> do- pkgs <- readFileLines ".pkgs"- return $ map ("-package=" ++) pkgs+ ghcFlags <- addOracle $ \GhcFlags{} ->+ map ("-package=" ++) <$> readFileLines ".pkgs" let ghc args = do -- since ghc-pkg includes the ghc package, it changes if the version does@@ -90,4 +89,5 @@ packages = words ("base transformers binary unordered-containers hashable time bytestring primitive " ++ "filepath directory process deepseq random utf8-string extra js-jquery js-flot") ++- ["old-time" | compilerVersion < makeVersion [7,6]]+ ["old-time" | compilerVersion < makeVersion [7,6]] +++ ["semigroups" | compilerVersion < makeVersion [8,0]]
src/Test/Type.hs view
@@ -11,6 +11,7 @@ assertContents, assertContentsUnordered, assertContentsWords, assertExists, assertMissing, (===),+ (&?%>), Pat(PatWildcard), pat, BinarySentinel(..), RandomType(..), ) where@@ -82,8 +83,8 @@ fail $ "Clean went horribly wrong! Dangerous deleting: " ++ show now withCurrentDirectory (now </> "..") $ do removeDirectoryRecursive now- createDirectoryIfMissing True now- unless reenter $ createDirectoryIfMissing True out+ createDirectoryRecursive now+ unless reenter $ createDirectoryRecursive out case args of "test":extra -> do putStrLn $ "## TESTING " ++ name@@ -110,22 +111,39 @@ ,shakeLintInside = [cwd] ,shakeLintIgnore = map (cwd </>) [".cabal-sandbox//",".stack-work//"]} withArgs args $ do- let cleanOpt = optionsEnumDesc+ let optionsBuiltin = optionsEnumDesc [(Clean, "Clean before building.")- ,(Sleep, "Pause before executing.")]- change $ shakeArgsWith opts (cleanOpt `mergeOptDescr` options) $ \extra files -> do+ ,(Sleep, "Pause before executing.")+ ,(UsePredicate, "Use &?> in preference to &%>")]+ change $ shakeArgsOptionsWith opts (optionsBuiltin `mergeOptDescr` options) $ \so extra files -> do let (extra1, extra2) = partitionEithers extra when (Clean `elem` extra1) clean when (Sleep `elem` extra1) sleeper+ so <- return $ if UsePredicate `notElem` extra1 then so else+ so{shakeExtra = addShakeExtra UsePredicateYes $ shakeExtra so} if "clean" `elem` files then clean >> return Nothing- else return $ Just $ do+ else return $ Just $ (,) so $ do -- if you have passed sleep, supress the "no actions" warning when (Sleep `elem` extra1) $ action $ return () rules extra2 files -data Flags = Clean | Sleep deriving (Eq,Show)+data Flags+ = Clean -- ^ Clean all the files before starting+ | Sleep -- ^ Call 'sleepFileTimeCalibrate' before starting+ | UsePredicate -- ^ Use &?> in preference to &%>+ deriving (Eq,Show) +data UsePredicateYes = UsePredicateYes deriving Typeable++(&?%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()+deps &?%> act = do+ so :: Maybe UsePredicateYes <- getShakeExtraRules+ if isJust so+ then (\x -> if x `elem` deps then Just deps else Nothing) &?> act+ else deps &%> act++ root :: FilePath root = "../.." @@ -210,7 +228,7 @@ sleepFileTimeCalibrate :: IO (IO ()) sleepFileTimeCalibrate = do let file = "output/calibrate"- createDirectoryIfMissing True $ takeDirectory file+ createDirectoryRecursive $ takeDirectory file -- with 10 measurements can get a bit slow, see #451 -- if it rounds to a second then 1st will be a fraction, but 2nd will be full second mtimes <- forM [1..2] $ \i -> fmap fst $ duration $ do@@ -248,7 +266,7 @@ xs <- getDirectoryContentsRecursive old forM_ xs $ \from -> do let to = new </> drop (length $ addTrailingPathSeparator old) from- createDirectoryIfMissing True $ takeDirectory to+ createDirectoryRecursive $ takeDirectory to copyFileChanged from to