diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/docs/Manual.md b/docs/Manual.md --- a/docs/Manual.md +++ b/docs/Manual.md @@ -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 diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -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 maintainer: Neil Mitchell -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 diff --git a/src/Development/Ninja/All.hs b/src/Development/Ninja/All.hs --- a/src/Development/Ninja/All.hs +++ b/src/Development/Ninja/All.hs @@ -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 diff --git a/src/Development/Ninja/Lexer.hs b/src/Development/Ninja/Lexer.hs --- a/src/Development/Ninja/Lexer.hs +++ b/src/Development/Ninja/Lexer.hs @@ -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 diff --git a/src/Development/Ninja/Parse.hs b/src/Development/Ninja/Parse.hs --- a/src/Development/Ninja/Parse.hs +++ b/src/Development/Ninja/Parse.hs @@ -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 [] = [] diff --git a/src/Development/Ninja/Type.hs b/src/Development/Ninja/Type.hs --- a/src/Development/Ninja/Type.hs +++ b/src/Development/Ninja/Type.hs @@ -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 diff --git a/src/Development/Shake.hs b/src/Development/Shake.hs --- a/src/Development/Shake.hs +++ b/src/Development/Shake.hs @@ -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 diff --git a/src/Development/Shake/Command.hs b/src/Development/Shake/Command.hs --- a/src/Development/Shake/Command.hs +++ b/src/Development/Shake/Command.hs @@ -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 diff --git a/src/Development/Shake/Internal/Args.hs b/src/Development/Shake/Internal/Args.hs --- a/src/Development/Shake/Internal/Args.hs +++ b/src/Development/Shake/Internal/Args.hs @@ -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." diff --git a/src/Development/Shake/Internal/Core/Action.hs b/src/Development/Shake/Internal/Core/Action.hs --- a/src/Development/Shake/Internal/Core/Action.hs +++ b/src/Development/Shake/Internal/Core/Action.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Database.hs b/src/Development/Shake/Internal/Core/Database.hs --- a/src/Development/Shake/Internal/Core/Database.hs +++ b/src/Development/Shake/Internal/Core/Database.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Monad.hs b/src/Development/Shake/Internal/Core/Monad.hs --- a/src/Development/Shake/Internal/Core/Monad.hs +++ b/src/Development/Shake/Internal/Core/Monad.hs @@ -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 () diff --git a/src/Development/Shake/Internal/Core/Pool.hs b/src/Development/Shake/Internal/Core/Pool.hs --- a/src/Development/Shake/Internal/Core/Pool.hs +++ b/src/Development/Shake/Internal/Core/Pool.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Rules.hs b/src/Development/Shake/Internal/Core/Rules.hs --- a/src/Development/Shake/Internal/Core/Rules.hs +++ b/src/Development/Shake/Internal/Core/Rules.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Run.hs b/src/Development/Shake/Internal/Core/Run.hs --- a/src/Development/Shake/Internal/Core/Run.hs +++ b/src/Development/Shake/Internal/Core/Run.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Storage.hs b/src/Development/Shake/Internal/Core/Storage.hs --- a/src/Development/Shake/Internal/Core/Storage.hs +++ b/src/Development/Shake/Internal/Core/Storage.hs @@ -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 diff --git a/src/Development/Shake/Internal/Core/Types.hs b/src/Development/Shake/Internal/Core/Types.hs --- a/src/Development/Shake/Internal/Core/Types.hs +++ b/src/Development/Shake/Internal/Core/Types.hs @@ -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 + } diff --git a/src/Development/Shake/Internal/Demo.hs b/src/Development/Shake/Internal/Demo.hs --- a/src/Development/Shake/Internal/Demo.hs +++ b/src/Development/Shake/Internal/Demo.hs @@ -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 diff --git a/src/Development/Shake/Internal/Derived.hs b/src/Development/Shake/Internal/Derived.hs --- a/src/Development/Shake/Internal/Derived.hs +++ b/src/Development/Shake/Internal/Derived.hs @@ -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 diff --git a/src/Development/Shake/Internal/Progress.hs b/src/Development/Shake/Internal/Progress.hs --- a/src/Development/Shake/Internal/Progress.hs +++ b/src/Development/Shake/Internal/Progress.hs @@ -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 @@ -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 diff --git a/src/Development/Shake/Internal/Resource.hs b/src/Development/Shake/Internal/Resource.hs --- a/src/Development/Shake/Internal/Resource.hs +++ b/src/Development/Shake/Internal/Resource.hs @@ -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 diff --git a/src/Development/Shake/Internal/Rules/Directory.hs b/src/Development/Shake/Internal/Rules/Directory.hs --- a/src/Development/Shake/Internal/Rules/Directory.hs +++ b/src/Development/Shake/Internal/Rules/Directory.hs @@ -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 "" 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 diff --git a/src/Development/Shake/Internal/Rules/File.hs b/src/Development/Shake/Internal/Rules/File.hs --- a/src/Development/Shake/Internal/Rules/File.hs +++ b/src/Development/Shake/Internal/Rules/File.hs @@ -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 "" 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 diff --git a/src/Development/Shake/Internal/Rules/Files.hs b/src/Development/Shake/Internal/Rules/Files.hs --- a/src/Development/Shake/Internal/Rules/Files.hs +++ b/src/Development/Shake/Internal/Rules/Files.hs @@ -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] diff --git a/src/Development/Shake/Internal/Rules/Oracle.hs b/src/Development/Shake/Internal/Rules/Oracle.hs --- a/src/Development/Shake/Internal/Rules/Oracle.hs +++ b/src/Development/Shake/Internal/Rules/Oracle.hs @@ -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 diff --git a/src/Development/Shake/Internal/Value.hs b/src/Development/Shake/Internal/Value.hs --- a/src/Development/Shake/Internal/Value.hs +++ b/src/Development/Shake/Internal/Value.hs @@ -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 diff --git a/src/General/Bag.hs b/src/General/Bag.hs new file mode 100644 --- /dev/null +++ b/src/General/Bag.hs @@ -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) diff --git a/src/General/Bilist.hs b/src/General/Bilist.hs --- a/src/General/Bilist.hs +++ b/src/General/Bilist.hs @@ -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 diff --git a/src/General/Binary.hs b/src/General/Binary.hs --- a/src/General/Binary.hs +++ b/src/General/Binary.hs @@ -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, diff --git a/src/General/Chunks.hs b/src/General/Chunks.hs --- a/src/General/Chunks.hs +++ b/src/General/Chunks.hs @@ -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 diff --git a/src/General/Cleanup.hs b/src/General/Cleanup.hs --- a/src/General/Cleanup.hs +++ b/src/General/Cleanup.hs @@ -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 diff --git a/src/General/Extra.hs b/src/General/Extra.hs --- a/src/General/Extra.hs +++ b/src/General/Extra.hs @@ -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 --------------------------------------------------------------------- diff --git a/src/General/FileLock.hs b/src/General/FileLock.hs --- a/src/General/FileLock.hs +++ b/src/General/FileLock.hs @@ -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 diff --git a/src/General/ListBuilder.hs b/src/General/ListBuilder.hs --- a/src/General/ListBuilder.hs +++ b/src/General/ListBuilder.hs @@ -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 diff --git a/src/General/Process.hs b/src/General/Process.hs --- a/src/General/Process.hs +++ b/src/General/Process.hs @@ -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 diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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) diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -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 diff --git a/src/Test/Basic.hs b/src/Test/Basic.hs --- a/src/Test/Basic.hs +++ b/src/Test/Basic.hs @@ -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" "" diff --git a/src/Test/Batch.hs b/src/Test/Batch.hs new file mode 100644 --- /dev/null +++ b/src/Test/Batch.hs @@ -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" diff --git a/src/Test/Command.hs b/src/Test/Command.hs --- a/src/Test/Command.hs +++ b/src/Test/Command.hs @@ -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 diff --git a/src/Test/Directory.hs b/src/Test/Directory.hs --- a/src/Test/Directory.hs +++ b/src/Test/Directory.hs @@ -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 diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -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)" ,"build rules" ,"actions" diff --git a/src/Test/Errors.hs b/src/Test/Errors.hs --- a/src/Test/Errors.hs +++ b/src/Test/Errors.hs @@ -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" diff --git a/src/Test/FileLock.hs b/src/Test/FileLock.hs --- a/src/Test/FileLock.hs +++ b/src/Test/FileLock.hs @@ -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 diff --git a/src/Test/Files.hs b/src/Test/Files.hs --- a/src/Test/Files.hs +++ b/src/Test/Files.hs @@ -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" diff --git a/src/Test/Lint.hs b/src/Test/Lint.hs --- a/src/Test/Lint.hs +++ b/src/Test/Lint.hs @@ -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 diff --git a/src/Test/Ninja.hs b/src/Test/Ninja.hs --- a/src/Test/Ninja.hs +++ b/src/Test/Ninja.hs @@ -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 diff --git a/src/Test/Ninja/continuations.ninja b/src/Test/Ninja/continuations.ninja new file mode 100644 --- /dev/null +++ b/src/Test/Ninja/continuations.ninja @@ -0,0 +1,12 @@ + +rule $ + run + command $ + = $ + touch $ + $out + +build $ + continuations.txt $ + : $ + run diff --git a/src/Test/Ninja/lint.ninja b/src/Test/Ninja/lint.ninja --- a/src/Test/Ninja/lint.ninja +++ b/src/Test/Ninja/lint.ninja @@ -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 diff --git a/src/Test/Ninja/restart.ninja b/src/Test/Ninja/restart.ninja new file mode 100644 --- /dev/null +++ b/src/Test/Ninja/restart.ninja @@ -0,0 +1,8 @@ + +rule add + command = echo build restart.txt: self >> $out + +build restart.ninja: add + +rule self + command = echo $out > $out diff --git a/src/Test/Pool.hs b/src/Test/Pool.hs --- a/src/Test/Pool.hs +++ b/src/Test/Pool.hs @@ -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 diff --git a/src/Test/Self.hs b/src/Test/Self.hs --- a/src/Test/Self.hs +++ b/src/Test/Self.hs @@ -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]] diff --git a/src/Test/Type.hs b/src/Test/Type.hs --- a/src/Test/Type.hs +++ b/src/Test/Type.hs @@ -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