shake 0.16.4 → 0.17
raw patch · 114 files changed
+4701/−2360 lines, 114 filesdep +heapsdep +networkdep +network-uridep ~basedep ~extra
Dependencies added: heaps, network, network-uri
Dependency ranges changed: base, extra
Files
- CHANGES.txt +40/−1
- README.md +1/−1
- docs/Manual.md +14/−14
- shake.cabal +70/−17
- src/Development/Ninja/All.hs +18/−15
- src/Development/Ninja/Env.hs +1/−1
- src/Development/Ninja/Lexer.hs +1/−0
- src/Development/Shake.hs +53/−7
- src/Development/Shake/Classes.hs +2/−2
- src/Development/Shake/Command.hs +6/−3
- src/Development/Shake/Database.hs +143/−0
- src/Development/Shake/FilePath.hs +14/−3
- src/Development/Shake/Forward.hs +6/−3
- src/Development/Shake/Internal/Args.hs +27/−5
- src/Development/Shake/Internal/Core/Action.hs +327/−68
- src/Development/Shake/Internal/Core/Build.hs +353/−0
- src/Development/Shake/Internal/Core/Database.hs +0/−543
- src/Development/Shake/Internal/Core/Monad.hs +23/−3
- src/Development/Shake/Internal/Core/Pool.hs +70/−157
- src/Development/Shake/Internal/Core/Rendezvous.hs +0/−87
- src/Development/Shake/Internal/Core/Rules.hs +140/−71
- src/Development/Shake/Internal/Core/Run.hs +258/−373
- src/Development/Shake/Internal/Core/Storage.hs +169/−128
- src/Development/Shake/Internal/Core/Types.hs +313/−37
- src/Development/Shake/Internal/Derived.hs +8/−3
- src/Development/Shake/Internal/Errors.hs +51/−47
- src/Development/Shake/Internal/FileInfo.hs +24/−13
- src/Development/Shake/Internal/FileName.hs +1/−1
- src/Development/Shake/Internal/FilePattern.hs +19/−13
- src/Development/Shake/Internal/History/Bloom.hs +54/−0
- src/Development/Shake/Internal/History/Cloud.hs +83/−0
- src/Development/Shake/Internal/History/Network.hs +49/−0
- src/Development/Shake/Internal/History/Serialise.hs +110/−0
- src/Development/Shake/Internal/History/Server.hs +44/−0
- src/Development/Shake/Internal/History/Shared.hs +153/−0
- src/Development/Shake/Internal/History/Types.hs +11/−0
- src/Development/Shake/Internal/Options.hs +58/−10
- src/Development/Shake/Internal/Profile.hs +90/−6
- src/Development/Shake/Internal/Progress.hs +34/−48
- src/Development/Shake/Internal/Resource.hs +55/−36
- src/Development/Shake/Internal/Rules/Default.hs +18/−0
- src/Development/Shake/Internal/Rules/Directory.hs +6/−3
- src/Development/Shake/Internal/Rules/File.hs +128/−97
- src/Development/Shake/Internal/Rules/Files.hs +68/−32
- src/Development/Shake/Internal/Rules/Oracle.hs +44/−18
- src/Development/Shake/Internal/Rules/OrderOnly.hs +2/−1
- src/Development/Shake/Internal/Rules/Rerun.hs +6/−3
- src/Development/Shake/Internal/Shake.hs +0/−30
- src/Development/Shake/Internal/Value.hs +3/−19
- src/Development/Shake/Rule.hs +131/−6
- src/General/Bag.hs +0/−40
- src/General/Binary.hs +12/−4
- src/General/Chunks.hs +42/−27
- src/General/Cleanup.hs +35/−19
- src/General/Concurrent.hs +0/−33
- src/General/Extra.hs +96/−13
- src/General/Fence.hs +54/−0
- src/General/FileLock.hs +33/−26
- src/General/Ids.hs +31/−9
- src/General/Intern.hs +3/−3
- src/General/ListBuilder.hs +1/−1
- src/General/Pool.hs +166/−0
- src/General/Process.hs +10/−7
- src/General/Template.hs +14/−6
- src/General/Timing.hs +2/−1
- src/General/TypeMap.hs +37/−0
- src/General/Wait.hs +140/−0
- src/Test.hs +91/−79
- src/Test/Basic.hs +9/−2
- src/Test/Batch.hs +1/−1
- src/Test/Benchmark.hs +5/−5
- src/Test/Builtin.hs +71/−0
- src/Test/C.hs +1/−1
- src/Test/Cache.hs +1/−1
- src/Test/Cleanup.hs +55/−0
- src/Test/Command.hs +3/−3
- src/Test/Config.hs +1/−1
- src/Test/Database.hs +75/−0
- src/Test/Deprioritize.hs +27/−0
- src/Test/Digest.hs +1/−1
- src/Test/Directory.hs +4/−4
- src/Test/Docs.hs +48/−18
- src/Test/Errors.hs +59/−13
- src/Test/FileLock.hs +1/−1
- src/Test/FilePath.hs +6/−5
- src/Test/FilePattern.hs +3/−4
- src/Test/Files.hs +7/−1
- src/Test/Forward.hs +1/−1
- src/Test/History.hs +58/−0
- src/Test/Journal.hs +1/−1
- src/Test/Lint.hs +1/−1
- src/Test/Live.hs +1/−1
- src/Test/Manual.hs +3/−6
- src/Test/Match.hs +2/−2
- src/Test/Monad.hs +3/−4
- src/Test/Ninja.hs +2/−1
- src/Test/Ninja/test7.ninja +1/−0
- src/Test/Oracle.hs +12/−9
- src/Test/OrderOnly.hs +1/−1
- src/Test/Parallel.hs +2/−2
- src/Test/Pool.hs +20/−23
- src/Test/Progress.hs +2/−1
- src/Test/Random.hs +8/−5
- src/Test/Rebuild.hs +1/−1
- src/Test/Resources.hs +1/−1
- src/Test/Self.hs +6/−6
- src/Test/SelfMake.hs +57/−0
- src/Test/Tar.hs +1/−1
- src/Test/Tup.hs +1/−1
- src/Test/Type.hs +26/−28
- src/Test/Unicode.hs +2/−2
- src/Test/Util.hs +1/−4
- src/Test/Verbosity.hs +1/−1
- src/Test/Version.hs +42/−3
CHANGES.txt view
@@ -1,5 +1,43 @@-Changelog for Shake+Changelog for Shake (* = breaking change) +0.17, released 2018-10-15+ Add Database module for repeated execution from one database+* Don't export the body of the Typeable type class+ Mark deprecated operators as DEPRECATED+ Improve async exception safety in some corner cases+ Support shakeFiles=/dev/null to avoid any database+ Add reprioritise to change the priority of a running rule+ Add a dependency on heaps package+ #611, fix a race condition in actionFinally that reran handlers+ Remove a potential space leak in the Rules monad+ #412, clarify that removeFilesAfter should be used sparingly+ #409, improve the documentation of newCache+ Generalise operations like versioned to Rules a -> Rules a+ Make the Shake database version string contain os and arch+ Don't delete the whole database when an oracle disappears+ #300, soften the database version change message+ IMPORTANT: Incompatible on disk format change+ #590, print "Build completed" timing with better accuracy+ #581, improve the information and display of call stacks+ Add actionRetry to retry actions if they fail+ #143, give locations when several rules match+ Compatibility with unix-2.8+ Add shakeShare, --share and history functions for shared builds+ #574, extensive documentation of Development.Shake.Rule+* Change how alternative and priority rules interact+ Add versioned for rules+* Change all the ways of obtaining user rules, see getUserRuleOne+ Improve time recording for unsafeExtraThread, parallel, batch+ #553, improve file-hash performance when nothing changes+* Require addBuiltinRule to take a BuiltinIdentity argument+* Make the third argument to BuiltinRun a real ADT+ Disable all the lintTrack functions unless lint is enabled+* Change the Development.Shake.Rule.track* functions to lintTrack*+ #584, add Semigroup/Monoid instances for Action+ Add produces to declare which untracked files a rule produces+ Add historyDisable to note which rules cannot be cached+ #583, add replaceDirectory1+ Add addOracleHash for oracles with reduced storage requirements 0.16.4, released 2018-04-04 #185, add addOracleCache which doesn't always rerun #576, remove incorrect Cabal description@@ -56,6 +94,7 @@ Expose 'Process' from Development.Shake #495, remove dangling link from LICENSE #436, remove Assume, switch to Rebuild+ Remove --always-make, use --rebuild instead #419, remove --assume-old and --assume-new, which never worked Remove support for running Makefile scripts Add getShakeOptionsRules, to get ShakeOptions in Rules
README.md view
@@ -1,4 +1,4 @@-# Shake [](https://hackage.haskell.org/package/shake) [](https://www.stackage.org/package/shake) [](https://travis-ci.org/ndmitchell/shake) [](https://ci.appveyor.com/project/ndmitchell/shake)+# Shake [](https://hackage.haskell.org/package/shake) [](https://www.stackage.org/package/shake) [](https://travis-ci.org/ndmitchell/shake) [](https://ci.appveyor.com/project/ndmitchell/shake) Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. The website for Shake users is at [shakebuild.com](https://shakebuild.com).
docs/Manual.md view
@@ -8,28 +8,28 @@ import Development.Shake.Command import Development.Shake.FilePath import Development.Shake.Util- + main :: IO () main = shakeArgs shakeOptions{shakeFiles="_build"} $ do want ["_build/run" <.> exe]- + phony "clean" $ do putNormal "Cleaning files in _build" removeFilesAfter "_build" ["//*"]- + "_build/run" <.> exe %> \out -> do cs <- getDirectoryFiles "" ["//*.c"] let os = ["_build" </> c -<.> "o" | c <- cs] need os cmd_ "gcc -o" [out] os- + "_build//*.o" %> \out -> do let c = dropDirectory1 $ out -<.> "c" let m = out -<.> "m" cmd_ "gcc -c" [c] "-o" [out] "-MMD -MF" [m] needMakefileDependencies m -This build system builds the executable `_build/run` from all C source files in the current directory. It will rebuild if you add/remove any C files to the directory, if the C files themselves change, or if any headers used by the C files change. All generated files are placed in `_build`, and a `clean` command is provided that will wipe all the generated files. In the rest of this manual we'll explain how the above code works and how to extend it. +This build system builds the executable `_build/run` from all C source files in the current directory. It will rebuild if you add/remove any C files to the directory, if the C files themselves change, or if any headers used by the C files change. All generated files are placed in `_build`, and a `clean` command is provided that will wipe all the generated files. In the rest of this manual we'll explain how the above code works and how to extend it. #### Running this example @@ -128,7 +128,7 @@ An <tt><i>expression</i></tt> is any combination of variables and function calls, for example `out -<.> "txt"`. A list of some common functions is discussed later. -Variables are evaluated by substituting the <tt><i>expression</i></tt> everywhere the <tt><i>variable</i></tt> is used. In the simple example we could have equivalently written: +Variables are evaluated by substituting the <tt><i>expression</i></tt> everywhere the <tt><i>variable</i></tt> is used. In the simple example we could have equivalently written: "*.rot13" %> \out -> do need [out -<.> "txt"]@@ -241,7 +241,7 @@ Variables local to a rule are defined using `let`, but you can also define top-level variables. Top-level variables are defined before the `main` call, for example: buildDir = "_build"- + You can now use `buildDir` in place of `"_build"` throughout. You can also define parametrised variables (functions) by adding argument names: buildDir x = "_build" </> x@@ -268,7 +268,7 @@ <i>actions</i> </pre> -Where <tt><i>name</i></tt> is the name used on the command line to invoke the actions, and <tt><i>actions</i></tt> are the list of things to do in response. These names are not dependency tracked and are simply run afresh each time they are requested.+Where <tt><i>name</i></tt> is the name used on the command line to invoke the actions, and <tt><i>actions</i></tt> are the list of things to do in response. These names are not dependency tracked and are run afresh each time they are requested. The <tt><i>actions</i></tt> can be any standard build actions, although for a `clean` rule, `removeFilesAfter` is typical. This function waits until after any files have finished building (which will be none, if you do `runhaskell Build.hs clean`) then deletes all files matching `//*` in the `_build` directory. The `putNormal` function writes out a message to the console, as long as `--quiet` was not passed. @@ -286,9 +286,9 @@ This script creates a folder named `_shake` for the build system objects to live in, then runs `ghc --make Build.hs` to produce `_shake/build`, then executes `_shake/build` with all arguments it was given. The `-with-rtsopts` flag instructs the Haskell compiler to disable "idle garbage collection", making more CPU available for the commands you are running, as [explained here](https://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/). -Now you can run a build by simply typing `stack exec ./build.sh` on Linux, or `stack exec build.bat` on Windows. On Linux you may want to alias `build` to `stack exec ./build.sh`. For the rest of this document we will assume `build` runs the build system.+Now you can run a build by typing `stack exec ./build.sh` on Linux, or `stack exec build.bat` on Windows. On Linux you may want to alias `build` to `stack exec ./build.sh`. For the rest of this document we will assume `build` runs the build system. -_Warning:_ You should not use the `-threaded` for GHC 7.6 or below because of a [GHC bug](https://ghc.haskell.org/trac/ghc/ticket/7646). If you do turn on `-threaded`, you should include `-qg -qb` in `-with-rtsopts`. +_Warning:_ You should not use the `-threaded` for GHC 7.6 or below because of a [GHC bug](https://ghc.haskell.org/trac/ghc/ticket/7646). If you do turn on `-threaded`, you should include `-qg -qb` in `-with-rtsopts`. #### Command line flags @@ -311,11 +311,11 @@ * Running `build --progress` * Setting `shakeOptions{shakeProgress = progressSimple}` -The progress message will be displayed in the titlebar of the window, for example `3m12s (82%)` to indicate that the build is 82% complete and is predicted to take a further 3 minutes and 12 seconds. If you are running Windows 7 or higher and place the [`shake-progress`](https://github.org/ndmitchell/shake) utility somewhere on your `%PATH%` then the progress will also be displayed in the taskbar progress indicator:+The progress message will be displayed in the titlebar of the window, for example `3m12s (82%)` to indicate that the build is 82% complete and is predicted to take a further 3 minutes and 12 seconds. If you are running Windows 7 or higher and place the [`shake-progress`](https://github.com/ndmitchell/shake/releases/tag/shake-progress-1) utility somewhere on your `%PATH%` then the progress will also be displayed in the taskbar progress indicator:  -Progress prediction is likely to be relatively poor during the first build and after running `build clean`, as then Shake has no information about the predicted execution time for each rule. To rebuild from scratch without running clean (because you really want to see the progress bar!) you can use the argument `--always-make`, which assumes all rules need rerunning. +Progress prediction is likely to be relatively poor during the first build and after running `build clean`, as then Shake has no information about the predicted execution time for each rule. To rebuild from scratch without running clean (because you really want to see the progress bar!) you can use the argument `--always-make`, which assumes all rules need rerunning. <span class="target" id="lint"></span> @@ -368,7 +368,7 @@ You can use tracked dependencies on environment variables using the `getEnv` function. As an example: link <- getEnv "C_LINK_FLAGS"- let linkFlags = fromMaybe "" link + let linkFlags = fromMaybe "" link cmd_ "gcc -o" [output] inputs linkFlags This example gets the `$C_LINK_FLAGS` environment variable (which is `Maybe String`, namely a `String` that might be missing), then using `fromMaybe` defines a local variable `linkFlags` that is the empty string when `$C_LINK_FLAGS` is not set. It then passes these flags to `gcc`.@@ -443,7 +443,7 @@ pattern %> actions = (pattern ?==) ?> actions -Where `?==` is a function for matching file patterns. +Where `?==` is a function for matching file patterns. #### Haskell Actions
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: shake-version: 0.16.4+version: 0.17 license: BSD3 license-file: LICENSE category: Development, Shake@@ -30,7 +30,7 @@ (e.g. compiler version). homepage: https://shakebuild.com bug-reports: https://github.com/ndmitchell/shake/issues-tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+tested-with: GHC==8.6.1, GHC==8.4.3, 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@@ -72,6 +72,11 @@ manual: True description: Obtain FileTime using portable functions +flag cloud+ default: False+ manual: True+ description: Enable cloud build features+ library default-language: Haskell2010 hs-source-dirs: src@@ -84,6 +89,7 @@ extra >= 1.6.1, filepath, hashable >= 1.1.2.3,+ heaps, js-flot, js-jquery, primitive,@@ -104,6 +110,10 @@ if !os(windows) build-depends: unix + if flag(cloud)+ cpp-options: -DNETWORK+ build-depends: network, network-uri+ if impl(ghc < 8.0) build-depends: semigroups >= 0.18 @@ -112,6 +122,7 @@ Development.Shake.Classes Development.Shake.Command Development.Shake.Config+ Development.Shake.Database Development.Shake.FilePath Development.Shake.Forward Development.Shake.Rule@@ -125,10 +136,16 @@ Development.Shake.Internal.Args Development.Shake.Internal.CmdOption Development.Shake.Internal.Core.Action- Development.Shake.Internal.Core.Database+ Development.Shake.Internal.Core.Build+ Development.Shake.Internal.History.Shared+ Development.Shake.Internal.History.Bloom+ Development.Shake.Internal.History.Cloud+ Development.Shake.Internal.History.Network+ Development.Shake.Internal.History.Server+ Development.Shake.Internal.History.Serialise+ Development.Shake.Internal.History.Types 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.Storage@@ -144,20 +161,19 @@ Development.Shake.Internal.Profile Development.Shake.Internal.Progress Development.Shake.Internal.Resource+ Development.Shake.Internal.Rules.Default Development.Shake.Internal.Rules.Directory Development.Shake.Internal.Rules.File Development.Shake.Internal.Rules.Files Development.Shake.Internal.Rules.Oracle Development.Shake.Internal.Rules.OrderOnly Development.Shake.Internal.Rules.Rerun- Development.Shake.Internal.Shake Development.Shake.Internal.Value- General.Bag General.Bilist General.Binary General.Chunks General.Cleanup- General.Concurrent+ General.Fence General.Extra General.FileLock General.GetOpt@@ -165,9 +181,12 @@ General.Intern General.ListBuilder General.Makefile+ General.Pool General.Process General.Template General.Timing+ General.TypeMap+ General.Wait Paths_shake @@ -189,6 +208,7 @@ extra >= 1.6.1, filepath, hashable >= 1.1.2.3,+ heaps, js-flot, js-jquery, primitive,@@ -209,6 +229,10 @@ if !os(windows) build-depends: unix + if flag(cloud)+ cpp-options: -DNETWORK+ build-depends: network, network-uri+ if impl(ghc < 8.0) build-depends: semigroups >= 0.18 @@ -221,14 +245,21 @@ Development.Shake Development.Shake.Classes Development.Shake.Command+ Development.Shake.Database 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.Build+ Development.Shake.Internal.History.Shared+ Development.Shake.Internal.History.Bloom+ Development.Shake.Internal.History.Cloud+ Development.Shake.Internal.History.Network+ Development.Shake.Internal.History.Server+ Development.Shake.Internal.History.Serialise+ Development.Shake.Internal.History.Types 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.Storage@@ -244,20 +275,19 @@ Development.Shake.Internal.Profile Development.Shake.Internal.Progress Development.Shake.Internal.Resource+ Development.Shake.Internal.Rules.Default Development.Shake.Internal.Rules.Directory Development.Shake.Internal.Rules.File Development.Shake.Internal.Rules.Files Development.Shake.Internal.Rules.Oracle Development.Shake.Internal.Rules.OrderOnly Development.Shake.Internal.Rules.Rerun- Development.Shake.Internal.Shake Development.Shake.Internal.Value- General.Bag General.Bilist General.Binary General.Chunks General.Cleanup- General.Concurrent+ General.Fence General.Extra General.FileLock General.GetOpt@@ -265,9 +295,12 @@ General.Intern General.ListBuilder General.Makefile+ General.Pool General.Process General.Template General.Timing+ General.TypeMap+ General.Wait Paths_shake @@ -294,6 +327,7 @@ extra >= 1.6.1, filepath, hashable >= 1.1.2.3,+ heaps, js-flot, js-jquery, primitive,@@ -315,6 +349,10 @@ if !os(windows) build-depends: unix + if flag(cloud)+ cpp-options: -DNETWORK+ build-depends: network, network-uri+ if impl(ghc < 8.0) build-depends: semigroups >= 0.18 @@ -328,15 +366,22 @@ Development.Shake.Classes Development.Shake.Command Development.Shake.Config+ Development.Shake.Database 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.Build+ Development.Shake.Internal.History.Shared+ Development.Shake.Internal.History.Bloom+ Development.Shake.Internal.History.Cloud+ Development.Shake.Internal.History.Network+ Development.Shake.Internal.History.Server+ Development.Shake.Internal.History.Serialise+ Development.Shake.Internal.History.Types 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.Storage@@ -352,22 +397,21 @@ Development.Shake.Internal.Profile Development.Shake.Internal.Progress Development.Shake.Internal.Resource+ Development.Shake.Internal.Rules.Default Development.Shake.Internal.Rules.Directory Development.Shake.Internal.Rules.File Development.Shake.Internal.Rules.Files Development.Shake.Internal.Rules.Oracle Development.Shake.Internal.Rules.OrderOnly Development.Shake.Internal.Rules.Rerun- Development.Shake.Internal.Shake Development.Shake.Internal.Value Development.Shake.Rule Development.Shake.Util- General.Bag General.Bilist General.Binary General.Chunks General.Cleanup- General.Concurrent+ General.Fence General.Extra General.FileLock General.GetOpt@@ -375,18 +419,25 @@ General.Intern General.ListBuilder General.Makefile+ General.Pool General.Process General.Template General.Timing+ General.TypeMap+ General.Wait Paths_shake Run Test.Basic Test.Batch Test.Benchmark+ Test.Builtin Test.C Test.Cache+ Test.Cleanup Test.Command Test.Config+ Test.Database+ Test.Deprioritize Test.Digest Test.Directory Test.Docs@@ -397,6 +448,7 @@ Test.FilePattern Test.Files Test.Forward+ Test.History Test.Journal Test.Lint Test.Live@@ -413,6 +465,7 @@ Test.Rebuild Test.Resources Test.Self+ Test.SelfMake Test.Tar Test.Tup Test.Type
src/Development/Ninja/All.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables, TupleSections #-} module Development.Ninja.All(runNinja) where @@ -6,6 +6,7 @@ import Development.Ninja.Type import Development.Ninja.Parse import Development.Shake hiding (addEnv)+import Development.Shake.Classes import qualified Data.ByteString as BS8 import qualified Data.ByteString.Char8 as BS @@ -28,7 +29,7 @@ import General.Makefile(parseMakefile) import Development.Shake.Internal.FileName(filepathNormalise, fileNameFromString) import Development.Shake.Internal.FileInfo(getFileInfo)-import Development.Shake.Internal.Errors(errorStructured)+import Development.Shake.Internal.Errors(throwM, errorStructured) import Development.Shake.Internal.Rules.File(needBS, neededBS) import Development.Shake.Internal.Rules.OrderOnly(orderOnlyBS) @@ -36,7 +37,7 @@ -- | 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+runNinja _ 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,13 +53,13 @@ forM_ buildBind $ \(a,b) -> addEnv env a b addBinds env ruleBind commandline <- fmap BS.unpack $ askVar env $ BS.pack "command"- return $ CompDb dir commandline $ BS.unpack $ head depsNormal+ return $ CompDb dir commandline $ BS.unpack file putStr $ printCompDb xs return Nothing -runNinja restart file args (Just x) = errorIO $ "Unknown tool argument, expected 'compdb', got " ++ x+runNinja _ _ _ (Just x) = errorIO $ "Unknown tool argument, expected 'compdb', got " ++ x -runNinja restart file args tool = do+runNinja restart file args Nothing = do addTiming "Ninja parse" ninja@Ninja{..} <- parse file =<< newEnv return $ Just $ do@@ -68,7 +69,7 @@ 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+ (name,) <$> newResource (BS.unpack name) depth action $ do -- build the .ninja files, if they change, restart the build@@ -159,10 +160,12 @@ -- first find which dependencies are generated files xs <- return $ filter (`Map.member` builds) xs -- now try and find them as dependencies+ -- performance note: allDependencies generates lazily, and difference consumes lazily,+ -- with the property that in the common case it won't generate much of the list at all let bad = xs `difference` allDependencies build case bad of [] -> return ()- xs -> liftIO $ errorStructured+ xs -> throwM $ errorStructured ("Lint checking error - " ++ (if length xs == 1 then "file in deps is" else "files in deps are") ++ " generated and not a pre-dependency")@@ -173,20 +176,20 @@ builds = Map.fromList $ singles ++ [(x,y) | (xs,y) <- multiples, x <- xs] -- do list difference, assuming a small initial set, most of which occurs early in the list- difference :: [Str] -> [Str] -> [Str]- difference [] ys = []+ difference :: (Eq a, Hashable a) => [a] -> [a] -> [a]+ difference [] _ = [] difference xs ys = f (Set.fromList xs) ys where f xs [] = Set.toList xs- f xs (y:ys) | y `Set.member` xs = if Set.null xs2 then [] else f xs2 ys- where xs2 = Set.delete y xs- f xs (y:ys) = f xs ys+ f xs (y:ys)+ | y `Set.member` xs = let xs2 = Set.delete y xs in if Set.null xs2 then [] else f xs2 ys+ | otherwise = f xs ys -- find all dependencies of a rule, no duplicates, with all dependencies of this rule listed first allDependencies :: Build -> [FileStr] allDependencies rule = f Set.empty [] [rule] where- f seen [] [] = []+ f _ [] [] = [] 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)@@ -283,7 +286,7 @@ | otherwise -> add (replicate ((a+1) `div` 2) '\\') $ f s ('\"':xs) xs -> add (replicate (a+1) '\\') $ f s xs f s (x:xs) = add [x] $ f s xs- f s [] = [[]]+ f _ [] = [[]] add a (b:c) = (a++b):c add a [] = [a]
src/Development/Ninja/Env.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} --- | A Ninja style environment, basically a linked-list of mutable hash tables.+-- | A Ninja style environment, equivalent to a non-empty list of mutable hash tables. module Development.Ninja.Env( Env, newEnv, scopeEnv, addEnv, askEnv, fromEnv ) where
src/Development/Ninja/Lexer.hs view
@@ -188,6 +188,7 @@ '\r' -> new a $ dropN x '\n' -> new a x '\0' -> new a c_x+ _ -> error "unexpected expression in Ninja" where new a x = add a ([], x) add (Exprs []) x = x
src/Development/Shake.hs view
@@ -38,7 +38,7 @@ -- -- * The theory behind Shake is described in an ICFP 2012 paper, -- <https://ndmitchell.com/downloads/paper-shake_before_building-10_sep_2012.pdf Shake Before Building -- Replacing Make with Haskell>.--- The <https://www.youtube.com/watch?v=xYCPpXVlqFM associated talk> forms a short overview of Shake .+-- The <https://www.youtube.com/watch?v=xYCPpXVlqFM associated talk> forms a short overview of Shake. module Development.Shake( -- * Writing a build system -- $writing@@ -46,12 +46,15 @@ -- * GHC build flags -- $flags + -- * Other Shake modules+ -- $modules+ -- * Core shake, shakeOptions,- Rules, action, withoutActions, alternatives, priority,+ Rules, action, withoutActions, alternatives, priority, versioned, Action, traced,- liftIO, actionOnException, actionFinally, runAfter,+ liftIO, actionOnException, actionFinally, actionRetry, runAfter, ShakeException(..), -- * Configuration ShakeOptions(..), Rebuild(..), Lint(..), Change(..),@@ -89,7 +92,7 @@ -- * Environment rules getEnv, getEnvWithDefault, -- * Oracle rules- ShakeValue, RuleResult, addOracle, addOracleCache, askOracle,+ ShakeValue, RuleResult, addOracle, addOracleCache, addOracleHash, askOracle, -- * Special rules alwaysRerun, -- * Resources@@ -98,10 +101,12 @@ unsafeExtraThread, -- * Cache newCache, newCacheIO,+ historyDisable, produces, -- * Batching needHasChanged, resultHasChanged, batch,+ deprioritize, -- * Deprecated (*>), (|*>), (&*>), (**>), (*>>), (?>>),@@ -115,13 +120,14 @@ import Control.Monad.IO.Class import Development.Shake.Internal.Value import Development.Shake.Internal.Options-import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Action import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Resource import Development.Shake.Internal.Derived import Development.Shake.Internal.Errors import Development.Shake.Internal.Progress import Development.Shake.Internal.Args-import Development.Shake.Internal.Shake import Development.Shake.Command import Development.Shake.Internal.FilePattern@@ -179,20 +185,57 @@ -- programs typically goes slower than sequential garbage collection, while occupying many cores that -- could be used for running system commands. +-- $modules+--+-- The main Shake module is this one, "Development.Shake", which should be sufficient for most+-- people writing build systems using Shake. However, Shake provides some additional modules,+--+-- * "Development.Shake.Classes" provides convenience exports of the classes Shake relies on,+-- in particular 'Binary', 'Hashable' and 'NFData'. Useful for deriving these types using+-- @GeneralizedNewtypeDeriving@ without adding dependencies on the associated packages.+--+-- * "Development.Shake.Command" provides the command line wrappers. These are reexported by+-- "Development.Shake", but if you want to reuse just the command-line running functionality+-- in a non-Shake program you can import just that.+--+-- * "Development.Shake.Config" provides a way to write configuration files that are tracked.+-- The configuration files are in the Ninja format. Useful for users of bigger systems who+-- want to track the build rules not in Haskell.+--+-- * "Development.Shake.Database" provides lower level primitives to drive Shake, particularly+-- useful if you want to run multiple Shake runs in a row without reloading from the database.+--+-- * "Development.Shake.FilePath" is an extension of "System.FilePath" with a few additional+-- methods and safer extension manipulation code.+--+-- * "Development.Shake.Forward" is an alternative take on build systems, where you write the+-- rules as a script where steps are skipped, rather than as a set of dependencies. Only really+-- works if you use @fsatrace@.+--+-- * "Development.Shake.Rule" provides tools for writing your own types of Shake rules. Useful+-- if you need something new, like a rule that queries a database or similar.+--+-- * "Development.Shake.Util" has general utilities that are useful for build systems, e.g.+-- reading @Makefile@ syntax and alternative forms of argument parsing. + --------------------------------------------------------------------- -- DEPRECATED SINCE 0.13, MAY 2014 infix 1 **>, ?>>, *>> ++{-# DEPRECATED (**>) "Use |%> instead" #-} -- | /Deprecated:/ Alias for '|%>'. (**>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules () (**>) = (|%>) +{-# DEPRECATED (?>>) "Use &?> instead" #-} -- | /Deprecated:/ Alias for '&?>'. (?>>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules () (?>>) = (&?>) +{-# DEPRECATED (*>>) "Use &%> instead" #-} -- | /Deprecated:/ Alias for '&%>'. (*>>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules () (*>>) = (&%>)@@ -203,14 +246,17 @@ infix 1 *>, |*>, &*> +{-# DEPRECATED (*>) "Use %> instead" #-} -- | /Deprecated:/ Alias for '%>'. Note that @*>@ clashes with a Prelude operator in GHC 7.10. (*>) :: FilePattern -> (FilePath -> Action ()) -> Rules () (*>) = (%>) +{-# DEPRECATED (|*>) "Use |%> instead" #-} -- | /Deprecated:/ Alias for '|%>'. (|*>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules () (|*>) = (|%>) +{-# DEPRECATED (&*>) "Use &%> instead" #-} -- | /Deprecated:/ Alias for '&%>'. (&*>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules () (&*>) = (&%>)@@ -219,7 +265,7 @@ --------------------------------------------------------------------- -- DEPRECATED SINCE 0.16.1, NOV 2017 --- | /Depreciated:/ Replace @'askOracleWith' q a@ by @'askOracle' q@+-- | /Deprecated:/ Replace @'askOracleWith' q a@ by @'askOracle' q@ -- since the 'RuleResult' type family now fixes the result type. askOracleWith :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> a -> Action a askOracleWith question _ = askOracle question
src/Development/Shake/Classes.hs view
@@ -1,8 +1,8 @@ --- | This module reexports the six necessary type classes that every 'Rule' type must support.+-- | This module reexports the six necessary type classes that many rule types must support through 'ShakeValue'. -- You can use this module to define new rules without depending on the @binary@, @deepseq@ and @hashable@ packages. module Development.Shake.Classes(- Show(..), Typeable(..), Eq(..), Hashable(..), Binary(..), NFData(..)+ Show(..), Typeable, Eq(..), Hashable(..), Binary(..), NFData(..) ) where -- I would probably reexport this module by default in Development.Shake,
src/Development/Shake/Command.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} #if __GLASGOW_HASKELL__ < 710+-- Older versions of GHC require this pragma, newer versions complain it is deprecated {-# LANGUAGE OverlappingInstances #-} #endif @@ -48,7 +49,8 @@ import Prelude import Development.Shake.Internal.CmdOption-import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Action+import Development.Shake.Internal.Core.Types hiding (Result) import Development.Shake.FilePath import Development.Shake.Internal.FilePattern import Development.Shake.Internal.Options@@ -246,7 +248,7 @@ -- | Given a very explicit set of CmdOption, translate them to a General.Process structure commandExplicitIO :: String -> [CmdOption] -> [Result] -> String -> [String] -> IO [Result] commandExplicitIO funcName opts results exe args = do- let (grabStdout, grabStderr) = both or $ unzip $ for results $ \r -> case r of+ let (grabStdout, grabStderr) = both or $ unzip $ flip map results $ \r -> case r of ResultStdout{} -> (True, False) ResultStderr{} -> (False, True) ResultStdouterr{} -> (True, True)@@ -569,7 +571,8 @@ -- When passing file arguments we use @[myfile]@ so that if the @myfile@ variable contains spaces they are properly escaped. -- -- If you use 'cmd' inside a @do@ block and do not use the result, you may get a compile-time error about being--- unable to deduce 'CmdResult'. To avoid this error, use 'cmd_'.+-- unable to deduce 'CmdResult'. To avoid this error, use 'cmd_'. If you enable @OverloadedStrings@ or @OverloadedLists@+-- you may have to give type signatures to the arguments, or use the more constrained 'command' instead. -- -- The 'cmd' function can also be run in the 'IO' monad, but then 'Traced' is ignored and command lines are not echoed. -- As an example:
+ src/Development/Shake/Database.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE RecordWildCards #-}++-- | Lower-level primitives to drive Shake, which are wrapped into the+-- 'Development.Shake.shake' function. Useful if you want to perform multiple Shake+-- runs in a row without reloading from the database.+-- Sometimes used in conjunction with @'shakeFiles'=\"\/dev\/null\"@.+-- Using these functions you can approximate the 'Development.Shake.shake' experience with:+--+-- @+-- shake opts rules = do+-- (_, after) \<- 'shakeWithDatabase' opts rules $ \\db -> do+-- 'shakeOneShotDatabase' db+-- 'shakeRunDatabase' db []+-- 'shakeRunAfter' opts after+-- @+module Development.Shake.Database(+ ShakeDatabase,+ shakeOpenDatabase,+ shakeWithDatabase,+ shakeOneShotDatabase,+ shakeRunDatabase,+ shakeLiveFilesDatabase,+ shakeErrorsDatabase,+ shakeRunAfter+ ) where++import Control.Concurrent.Extra+import Control.Exception+import Control.Monad+import Control.Monad.IO.Class+import Data.Functor+import Data.IORef+import General.Cleanup+import Development.Shake.Internal.Errors+import Development.Shake.Internal.Options+import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Rules.Default+import Prelude++data UseState+ = Closed+ | Using String+ | Open {openOneShot :: Bool, openRequiresReset :: Bool}++-- | The type of an open Shake database. Created with+-- 'shakeOpenDatabase' or 'shakeWithDatabase'. Used with+-- 'shakeRunDatabase'. You may not execute simultaneous calls using 'ShakeDatabase'+-- on separate threads (it will raise an error).+data ShakeDatabase = ShakeDatabase (Var UseState) RunState++-- | Given some options and rules, return a pair. The first component opens the database,+-- the second cleans it up. The creation /does not/ need to be run masked, because the+-- cleanup is able to run at any point. Most users should prefer 'shakeWithDatabase'+-- which handles exceptions duration creation properly.+shakeOpenDatabase :: ShakeOptions -> Rules () -> IO (IO ShakeDatabase, IO ())+shakeOpenDatabase opts rules = do+ (cleanup, clean) <- newCleanup+ use <- newVar $ Open False False+ let alloc =+ withOpen use "shakeOpenDatabase" id $ \_ ->+ ShakeDatabase use <$> open cleanup opts (rules >> defaultRules)+ let free = do+ modifyVar_ use $ \x -> case x of+ Using s -> throwM $ errorStructured "Error when calling shakeOpenDatabase close function, currently running" [("Existing call", Just s)] ""+ _ -> return Closed+ clean+ return (alloc, free)++withOpen :: Var UseState -> String -> (UseState -> UseState) -> (UseState -> IO a) -> IO a+withOpen var name final act = mask $ \restore -> do+ o <- modifyVar var $ \x -> case x of+ Using s -> throwM $ errorStructured ("Error when calling " ++ name ++ ", currently running") [("Existing call", Just s)] ""+ Closed -> throwM $ errorStructured ("Error when calling " ++ name ++ ", already closed") [] ""+ o@Open{} -> return (Using name, o)+ let clean = writeVar var $ final o+ res <- restore (act o) `onException` clean+ clean+ return res++-- | Declare that a just-openned database will be used to call 'shakeRunDatabase' at most once.+-- If so, an optimisation can be applied to retain less memory.+shakeOneShotDatabase :: ShakeDatabase -> IO ()+shakeOneShotDatabase (ShakeDatabase use _) =+ withOpen use "shakeOneShotDatabase" (\o -> o{openOneShot=True}) $ \_ -> return ()++-- | Given some options and rules, create a 'ShakeDatabase' that can be used to run+-- executions.+shakeWithDatabase :: ShakeOptions -> Rules () -> (ShakeDatabase -> IO a) -> IO a+shakeWithDatabase opts rules act = do+ (db, clean) <- shakeOpenDatabase opts rules+ (act =<< db) `finally` clean++-- | Given a 'ShakeDatabase', what files did the execution ensure were up-to-date+-- in the previous call to 'shakeRunDatabase'. Corresponds to the list of files+-- written out to 'shakeLiveFiles'.+shakeLiveFilesDatabase :: ShakeDatabase -> IO [FilePath]+shakeLiveFilesDatabase (ShakeDatabase use s) =+ withOpen use "shakeLiveFilesDatabase" id $ \_ ->+ liveFilesState s++-- | Given a 'ShakeDatabase', what files did the execution reach an error on last time.+-- Some special considerations when using this function:+--+-- * The presence of an error does not mean the build will fail, specifically if a+-- previously required dependency was run and raised an error, then the thing that previously+-- required it will be run. If the build system has changed in an untracked manner,+-- the build may succeed this time round.+--+-- * If the previous run actually failed then 'shakeRunDatabase' will have thrown an exception.+-- You probably want to catch that exception so you can make the call to 'shakeErrorsDatabase'.+--+-- * You may see a single failure reported multiple times, with increasingly large call stacks, showing+-- the ways in which the error lead to further errors throughout.+--+-- * The 'SomeException' values are highly likely to be of type 'ShakeException'.+--+-- * If you want as many errors as possile in one run set @'shakeStaunch'=True@.+shakeErrorsDatabase :: ShakeDatabase -> IO [(String, SomeException)]+shakeErrorsDatabase (ShakeDatabase use s) =+ withOpen use "shakeErrorsDatabase" id $ \_ ->+ errorsState s++-- | Given an open 'ShakeDatabase', run both whatever actions were added to the 'Rules',+-- plus the list of 'Action' given here. Returns the results from the explicitly passed+-- actions along with a list of actions to run after the database was closed, as added with+-- 'runAfter' and 'removeFilesAfter'.+shakeRunDatabase :: ShakeDatabase -> [Action a] -> IO ([a], [IO ()])+shakeRunDatabase (ShakeDatabase use s) as =+ withOpen use "shakeRunDatabase" (\o -> o{openRequiresReset=True}) $ \Open{..} -> do+ when openRequiresReset $ do+ when openOneShot $+ throwM $ errorStructured "Error when calling shakeRunDatabase twice, after calling shakeOneShotDatabase" [] ""+ reset s+ (refs, as) <- fmap unzip $ forM as $ \a -> do+ ref <- newIORef Nothing+ return (ref, liftIO . writeIORef ref . Just =<< a)+ after <- run s openOneShot $ map void as+ results <- mapM readIORef refs+ case sequence results of+ Just result -> return (result, after)+ Nothing -> throwM $ errorInternal "Expected all results were written, but some where not"
src/Development/Shake/FilePath.hs view
@@ -15,7 +15,8 @@ -- (which is bad for 'Development.Shake.FilePattern' values). module Development.Shake.FilePath( module System.FilePath, module System.FilePath.Posix,- dropDirectory1, takeDirectory1, normaliseEx,+ dropDirectory1, takeDirectory1, replaceDirectory1,+ normaliseEx, #if !MIN_VERSION_filepath(1,4,0) (-<.>), #endif@@ -71,6 +72,16 @@ takeDirectory1 = takeWhile (not . isPathSeparator) ++-- | Replace the first component of a 'FilePath'. Should only be used on+-- relative paths.+--+-- > replaceDirectory1 "root/file.ext" "directory" == "directory/file.ext"+-- > replaceDirectory1 "root/foo/bar/file.ext" "directory" == "directory/foo/bar/file.ext"+replaceDirectory1 :: FilePath -> String -> FilePath+replaceDirectory1 x dir = dir </> dropDirectory1 x++ -- | Normalise a 'FilePath', applying the rules: -- -- * All 'pathSeparators' become 'pathSeparator' (@\/@ on Linux, @\\@ on Windows)@@ -104,14 +115,14 @@ g i ("..":xs) = g (i+1) xs g i (".":xs) = g i xs g 0 (x:xs) = x : g 0 xs- g i (x:xs) = g (i-1) xs+ g i (_:xs) = g (i-1) xs -- equivalent to eliminating ../x split xs = if null ys then [] else a : split b where (a,b) = break sep ys ys = dropWhile sep xs --- | Convert to native path separators, namely @\\@ on Windows. +-- | Convert to native path separators, namely @\\@ on Windows. toNative :: FilePath -> FilePath toNative = if isWindows then map (\x -> if x == '/' then '\\' else x) else id
src/Development/Shake/Forward.hs view
@@ -32,6 +32,9 @@ -- -- All forward-defined systems use 'AutoDeps', which requires @fsatrace@ to be on the @$PATH@. -- You can obtain @fsatrace@ from <https://github.com/jacereda/fsatrace>.+--+-- This module is considered experimental - it has not been battle tested.+-- A possible alternative is available at <http://hackage.haskell.org/package/pier/docs/Pier-Core-Artifact.html>. module Development.Shake.Forward( shakeForward, shakeArgsForward, forwardOptions, forwardRule,@@ -76,9 +79,9 @@ -- | Given an 'Action', turn it into a 'Rules' structure which runs in forward mode. forwardRule :: Action () -> Rules () forwardRule act = do- addBuiltinRule noLint $ \k old dirty ->+ addBuiltinRule noLint noIdentity $ \k old mode -> case old of- Just old | not dirty -> return $ RunResult ChangedNothing old ()+ Just old | mode == RunDependenciesSame -> return $ RunResult ChangedNothing old () _ -> do res <- liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete k mp, Map.lookup k mp) case res of@@ -104,6 +107,6 @@ cache :: (forall r . CmdArguments r => r) -> Action () cache cmd = do let CmdArgument args = cmd- let isDull ['-',x] = True; isDull _ = False+ let isDull ['-',_] = True; isDull _ = False let name = head $ filter (not . isDull) (drop 1 $ rights args) ++ ["unknown"] cacheAction ("command " ++ toStandard name ++ " #" ++ upper (showHex (abs $ hash $ show args) "")) cmd
src/Development/Shake/Internal/Args.hs view
@@ -3,17 +3,19 @@ -- | Command line parsing flags. module Development.Shake.Internal.Args( shakeOptDescrs,+ shake, shakeArgs, shakeArgsWith, shakeArgsOptionsWith ) where import Development.Shake.Internal.Paths import Development.Shake.Internal.Options import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Errors import Development.Shake.Internal.Demo import Development.Shake.FilePath import Development.Shake.Internal.Rules.File import Development.Shake.Internal.Progress-import Development.Shake.Internal.Shake+import Development.Shake.Database import General.Timing import General.GetOpt @@ -33,6 +35,20 @@ import Prelude +-- | Main entry point for running Shake build systems. For an example see the top of the module "Development.Shake".+-- Use 'ShakeOptions' to specify how the system runs, and 'Rules' to specify what to build. The function will throw+-- an exception if the build fails.+--+-- To use command line flags to modify 'ShakeOptions' see 'shakeArgs'.+shake :: ShakeOptions -> Rules () -> IO ()+shake opts rules = do+ addTiming "Function shake"+ (_, after) <- shakeWithDatabase opts rules $ \db -> do+ shakeOneShotDatabase db+ shakeRunDatabase db []+ shakeRunAfter opts after++ -- | Run a build system using command line arguments for configuration. -- The available flags are those from 'shakeOptDescrs', along with a few additional -- @make@ compatible flags that are not represented in 'ShakeOptions', such as @--print-directory@.@@ -161,7 +177,7 @@ putWhenLn Normal $ "Writing report to " ++ file writeProgressReport file dat else do- when (Sleep `elem` flagsExtra) $ threadDelay 1000000+ when (Sleep `elem` flagsExtra) $ sleep 1 start <- offsetTime initDataDirectory -- must be done before we start changing directory let redir = maybe id withCurrentDirectory changeDirectory@@ -203,9 +219,7 @@ exitFailure Right () -> do tot <- start- let (mins,secs) = divMod (ceiling tot) (60 :: Int)- time = show mins ++ ":" ++ ['0' | secs < 10] ++ show secs- putWhenLn Normal $ esc "32" $ "Build completed in " ++ time ++ "m"+ putWhenLn Normal $ esc "32" $ "Build completed in " ++ showDuration tot where opts = removeOverlap userOptions (map snd shakeOptsEx) `mergeOptDescr` userOptions @@ -249,6 +263,7 @@ [yes $ Option "a" ["abbrev"] (pairArg "abbrev" "FULL=SHORT" $ \a s -> s{shakeAbbreviations=shakeAbbreviations s ++ [a]}) "Use abbreviation in status messages." ,no $ Option "" ["no-build"] (NoArg $ Right ([NoBuild], id)) "Don't build anything." ,no $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything."+ ,yes $ Option "" ["cloud"] (reqArg "URL" $ \x s -> s{shakeCloud=shakeCloud s ++ [x]}) "HTTP server providing a cloud cache." ,yes $ Option "" ["color","colour"] (noArg $ \s -> s{shakeColor=True}) "Colorize the output." ,no $ Option "" ["no-color","no-colour"] (noArg $ \s -> s{shakeColor=False}) "Don't colorize the output." ,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information."@@ -279,6 +294,7 @@ ,yes $ Option "" ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report." ,yes $ Option "" ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules." ,yes $ Option "" ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."+ ,yes $ Option "" ["share"] (OptArg (\x -> Right ([], \s -> s{shakeShare=Just $ fromMaybe "" x, shakeChange=ensureHash $ shakeChange s})) "DIRECTORY") "Shared cache location." ,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything." ,no $ Option "" ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building." ,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."@@ -317,6 +333,7 @@ Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id) Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id) _ -> func x+ progress _ = throwImpure $ errorInternal "incomplete pattern, progress" outputDebug output Nothing = output outputDebug output (Just file) = \v msg -> do@@ -326,3 +343,8 @@ prog i p = do program <- progressProgram progressDisplay i (\s -> progressTitlebar s >> program s) p++ -- ensure the file system always computes a hash, required for --share+ ensureHash ChangeModtime = ChangeModtimeAndDigest+ ensureHash ChangeModtimeAndDigestInput = ChangeModtimeAndDigest+ ensureHash x = x
src/Development/Shake/Internal/Core/Action.hs view
@@ -1,12 +1,22 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, ConstraintKinds #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, ConstraintKinds, TupleSections, ViewPatterns #-} module Development.Shake.Internal.Core.Action(- runAction, actionOnException, actionFinally,+ actionOnException, actionFinally, actionRetry, getShakeOptions, getProgress, runAfter,- trackUse, trackChange, trackAllow, trackCheckUsed,+ lintTrackRead, lintTrackWrite, lintTrackAllow, getVerbosity, putWhen, putLoud, putNormal, putQuiet, withVerbosity, quietly,- blockApply, unsafeAllowApply,- traced+ produces,+ orderOnlyAction,+ newCacheIO,+ unsafeExtraThread,+ parallel,+ batch,+ deprioritize,+ historyDisable,+ traced,+ -- Internal only+ producesUnchecked, producesCheck, lintCurrentDirectory,+ blockApply, unsafeAllowApply, shakeException, lintTrackFinished, ) where import Control.Exception@@ -15,29 +25,38 @@ import Control.Monad.IO.Class import Control.DeepSeq import Data.Typeable.Extra+import System.Directory import Data.Function-import Data.Either.Extra+import Control.Concurrent.Extra import Data.Maybe-import Data.IORef-import Data.List+import Data.Tuple.Extra+import Data.IORef.Extra+import Data.List.Extra+import Data.Either.Extra import System.IO.Extra+import Numeric.Extra+import General.Extra+import qualified Data.HashMap.Strict as Map+import qualified General.Ids as Ids+import qualified General.Intern as Intern -import Development.Shake.Internal.Core.Database+import Development.Shake.Classes import Development.Shake.Internal.Core.Monad+import General.Pool import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Core.Pool import Development.Shake.Internal.Value import Development.Shake.Internal.Options import Development.Shake.Internal.Errors import General.Cleanup+import General.Fence import Prelude --------------------------------------------------------------------- -- RAW WRAPPERS -runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)-runAction g l (Action x) = runRAW g l x- -- | Apply a modification, run an action, then run an undo action after. -- Doesn't actually require exception handling because we don't have the ability to catch exceptions to the user. actionBracket :: (Local -> (Local, Local -> Local)) -> Action a -> Action a@@ -53,16 +72,29 @@ --------------------------------------------------------------------- -- EXCEPTION HANDLING +-- | Turn a normal exception into a ShakeException, giving it a stack and printing it out if in staunch mode.+-- If the exception is already a ShakeException (e.g. it's a child of ours who failed and we are rethrowing)+-- then do nothing with it.+shakeException :: Global -> Stack -> SomeException -> IO ShakeException+shakeException Global{globalOptions=ShakeOptions{..},..} stk e@(SomeException inner) = case cast inner of+ Just e@ShakeException{} -> return e+ Nothing -> do+ e <- return $ exceptionStack stk e+ when (shakeStaunch && shakeVerbosity >= Quiet) $+ globalOutput Quiet $ show e ++ "Continuing due to staunch mode"+ return e++ actionBoom :: Bool -> Action a -> IO b -> Action a-actionBoom runOnSuccess act clean = do+actionBoom runOnSuccess act (void -> clean) = do Global{..} <- Action getRO- undo <- liftIO $ addCleanup globalCleanup $ void clean+ key <- liftIO $ register globalCleanup clean -- 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)+ res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (release key) >> throwRAW e+ liftIO $ if runOnSuccess then release key else unprotect key return res --- | If an exception is raised by the 'Action', perform some 'IO'.+-- | If an exception is raised by the 'Action', perform some 'IO' then reraise the exception. actionOnException :: Action a -> IO b -> Action a actionOnException = actionBoom False @@ -71,6 +103,15 @@ actionFinally = actionBoom True +-- | Retry an 'Action' if it throws an exception, at most /n/ times (where /n/ must be positive).+-- If you need to call this function, you should probably try and fix the underlying cause (but you also probably know that).+actionRetry :: Int -> Action a -> Action a+actionRetry i act+ | i <= 0 = fail $ "actionRetry first argument must be positive, got " ++ show i+ | i == 1 = act+ | otherwise = Action $ catchRAW (fromAction act) $ \_ -> fromAction $ actionRetry (i-1) act++ --------------------------------------------------------------------- -- QUERIES @@ -188,79 +229,297 @@ --------------------------------------------------------------------- -- TRACKING --- | Track that a key has been used by the action preceeding it.-trackUse :: ShakeValue key => key -> Action ()+-- | Track that a key has been used/read by the action preceeding it when 'shakeLint' is active.+lintTrackRead :: ShakeValue key => [key] -> Action () -- One of the following must be true: -- 1) you are the one building this key (e.g. key == topStack) -- 2) you have already been used by apply, and are on the dependency list -- 3) someone explicitly gave you permission with trackAllow -- 4) at the end of the rule, a) you are now on the dependency list, and b) this key itself has no dependencies (is source file)-trackUse key = do- let k = newKey key+lintTrackRead ks = do Global{..} <- Action getRO- l@Local{..} <- Action getRW- deps <- liftIO $ concatMapM (listDepends globalDatabase) localDepends- let top = topStack localStack- if top == Just k then- return () -- condition 1- else if k `elem` deps then- return () -- condition 2- else if any ($ k) localTrackAllows then- return () -- condition 3- else- Action $ putRW l{localTrackUsed = k : localTrackUsed} -- condition 4+ when (isJust $ shakeLint globalOptions) $ do+ l@Local{..} <- Action getRW+ deps <- liftIO $ concatMapM (listDepends globalDatabase) localDepends+ let top = topStack localStack + let condition1 k = top == Just k+ let condition2 k = k `elem` deps+ let condition3 k = any ($ k) localTrackAllows+ let condition4 = filter (\k -> not $ condition1 k || condition2 k || condition3 k) $ map newKey ks+ unless (null condition4) $+ Action $ putRW l{localTrackUsed = condition4 ++ localTrackUsed} -trackCheckUsed :: Action ()-trackCheckUsed = do++lintTrackFinished :: Action ()+lintTrackFinished = do Global{..} <- Action getRO- Local{..} <- Action getRW- liftIO $ do- deps <- concatMapM (listDepends globalDatabase) localDepends+ when (isJust $ shakeLint globalOptions) $ do+ Local{..} <- Action getRW+ liftIO $ do+ deps <- concatMapM (listDepends globalDatabase) localDepends - -- check 3a- bad <- return $ localTrackUsed \\ deps- unless (null bad) $ do- let n = length bad- errorStructured- ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " used but not depended upon")- [("Used", Just $ show x) | x <- bad]- ""+ -- check 4a+ bad <- return $ localTrackUsed \\ deps+ unless (null bad) $ do+ let n = length bad+ throwM $ errorStructured+ ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " used but not depended upon")+ [("Used", Just $ show x) | x <- bad]+ "" - -- check 3b- bad <- flip filterM localTrackUsed $ \k -> not . null <$> lookupDependencies globalDatabase k- unless (null bad) $ do- let n = length bad- errorStructured- ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " depended upon after being used")- [("Used", Just $ show x) | x <- bad]- ""+ -- check 4b+ bad <- flip filterM localTrackUsed $ \k -> not . null <$> lookupDependencies globalDatabase k+ unless (null bad) $ do+ let n = length bad+ throwM $ errorStructured+ ("Lint checking error - " ++ (if n == 1 then "value was" else show n ++ " values were") ++ " depended upon after being used")+ [("Used", Just $ show x) | x <- bad]+ "" --- | Track that a key has been changed by the action preceding it.-trackChange :: ShakeValue key => key -> Action ()+-- | Track that a key has been changed/written by the action preceding it when 'shakeLint' is active.+lintTrackWrite :: ShakeValue key => [key] -> Action () -- One of the following must be true: -- 1) you are the one building this key (e.g. key == topStack) -- 2) someone explicitly gave you permission with trackAllow -- 3) this file is never known to the build system, at the end it is not in the database-trackChange key = do- let k = newKey key+lintTrackWrite ks = do Global{..} <- Action getRO- Local{..} <- Action getRW- liftIO $ do+ when (isJust $ shakeLint globalOptions) $ do+ Local{..} <- Action getRW let top = topStack localStack- if top == Just k then- return () -- condition 1- else if any ($ k) localTrackAllows then- return () -- condition 2- else- -- condition 3- atomicModifyIORef globalTrackAbsent $ \ks -> ((fromMaybe k top, k):ks, ()) + let condition1 k = Just k == top+ let condition2 k = any ($ k) localTrackAllows+ let condition3 = filter (\k -> not $ condition1 k || condition2 k) $ map newKey ks+ unless (null condition3) $+ liftIO $ atomicModifyIORef globalTrackAbsent $ \old -> ([(fromMaybe k top, k) | k <- condition3] ++ old, ()) + -- | Allow any matching key to violate the tracking rules.-trackAllow :: ShakeValue key => (key -> Bool) -> Action ()-trackAllow (test :: key -> Bool) = Action $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows s}+lintTrackAllow :: ShakeValue key => (key -> Bool) -> Action ()+lintTrackAllow (test :: key -> Bool) = do+ Global{..} <- Action getRO+ when (isJust $ shakeLint globalOptions) $+ Action $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows s} where tk = typeRep (Proxy :: Proxy key) f k = typeKey k == tk && test (fromKey k)+++lintCurrentDirectory :: FilePath -> String -> IO ()+lintCurrentDirectory old msg = do+ now <- getCurrentDirectory+ when (old /= now) $ throwIO $ errorStructured+ "Lint checking error - current directory has changed"+ [("When", Just msg)+ ,("Wanted",Just old)+ ,("Got",Just now)]+ ""+++listDepends :: Var Database -> Depends -> IO [Key]+listDepends db (Depends xs) = withVar db $ \Database{..} ->+ -- FIXME: Don't actually need the database lock to do this as the results are stable+ forM xs $ \x ->+ fst . fromJust <$> Ids.lookup status x++lookupDependencies :: Var Database -> Key -> IO [Depends]+lookupDependencies db k = withVar db $ \Database{..} -> do+ -- FIXME: Don't actually need the database lock to do this as the results are stable+ intern <- readIORef intern+ let Just i = Intern.lookup k intern+ Just (_, Ready r) <- Ids.lookup status i+ return $ depends r+++-- | This rule should not be cached or recorded in the history because it makes use of untracked dependencies+-- (e.g. files in a system directory or items on the @$PATH@), or is trivial to compute locally.+historyDisable :: Action ()+historyDisable = Action $ modifyRW $ \s -> s{localHistory = False}+++-- | This rule the following files, in addition to any defined by its target.+-- At the end of the rule these files must have been written.+produces :: [FilePath] -> Action ()+produces xs = Action $ modifyRW $ \s -> s{localProduces = map (True,) (reverse xs) ++ localProduces s}++-- | A version of 'produces' that does not check.+producesUnchecked :: [FilePath] -> Action ()+producesUnchecked xs = Action $ modifyRW $ \s -> s{localProduces = map (False,) (reverse xs) ++ localProduces s}++producesCheck :: Action ()+producesCheck = do+ Local{localProduces} <- Action getRW+ missing <- liftIO $ filterM (notM . doesFileExist_) $ map snd $ filter fst localProduces+ when (missing /= []) $ throwM $ errorStructured+ "Files declared by 'produces' not produced"+ [("File " ++ show i, Just x) | (i,x) <- zipFrom 1 missing]+ ""+++-- | Run an action but do not depend on anything the action uses.+-- A more general version of 'orderOnly'.+orderOnlyAction :: Action a -> Action a+orderOnlyAction act = Action $ do+ Local{localDepends=pre} <- getRW+ res <- fromAction act+ modifyRW $ \s -> s{localDepends=pre}+ return res+++---------------------------------------------------------------------+-- MORE COMPLEX++-- | 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 :: k -> Action v) = do+ var :: Var (Map.HashMap k (Fence IO (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+ (offset, (deps, v)) <- actionFenceRequeue bar+ Action $ modifyRW $ \s -> addDiscount offset $ s{localDepends = deps ++ localDepends s}+ return v+ Nothing -> do+ bar <- newFence+ return $ (Map.insert key bar mp,) $ do+ Local{localDepends=pre} <- Action getRW+ res <- Action $ tryRAW $ fromAction $ act key+ case res of+ Left err -> do+ liftIO $ signalFence bar $ Left err+ Action $ throwRAW err+ Right v -> do+ Local{localDepends=post} <- Action getRW+ let deps = dropEnd (length pre) post+ liftIO $ signalFence bar $ Right (deps, v)+ return v+++-- | Run an action without counting to the thread limit, typically used for actions that execute+-- on remote machines using barely any local CPU resources.+-- Unsafe as it allows the 'shakeThreads' limit to be exceeded.+-- You cannot depend on a rule (e.g. 'need') while the extra thread is executing.+-- If the rule blocks (e.g. calls 'withResource') then the extra thread may be used by some other action.+-- Only really suitable for calling 'cmd' / 'command'.+unsafeExtraThread :: Action a -> Action a+unsafeExtraThread act = do+ Global{..} <- Action getRO+ stop <- liftIO $ increasePool globalPool+ res <- Action $ tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act+ liftIO stop+ -- we start a new thread, giving up ours, to ensure the thread count goes down+ (wait, res) <- actionAlwaysRequeue res+ Action $ modifyRW $ addDiscount wait+ return 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] = return <$> x+parallel acts = do+ Global{..} <- Action getRO++ done <- liftIO $ newIORef False+ waits <- forM acts $ \act ->+ addPoolWait PoolResume $ do+ whenM (liftIO $ readIORef done) $+ fail "parallel, one has already failed"+ Action $ modifyRW localClearMutable+ res <- act+ old <- Action getRW+ return (old, res)+ (wait, res) <- actionFenceSteal =<< liftIO (exceptFence waits)+ liftIO $ atomicWriteIORef done True+ let (waits, locals, results) = unzip3 $ map (\(a,(b,c)) -> (a,b,c)) res+ Action $ modifyRW $ \root -> addDiscount (wait - sum waits) $ localMergeMutable root locals+ return results+++-- | 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 -- ^ Maximum number to run in a single batch, e.g. @3@.+ -> ((a -> Action ()) -> Rules ()) -- ^ Way to match an entry, e.g. @\"*.ext\" '%>'@.+ -> (a -> Action b) -- ^ Preparation to run individually on each, e.g. using 'need'.+ -> ([b] -> Action ()) -- ^ Combination action to run on all, e.g. using 'cmd'.+ -> 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, Local, Fence IO (Either SomeException Local))]) <- liftIO $ newIORef (0, [])+ pred $ \a -> do+ b <- one a+ fence <- liftIO newFence+ -- add one to the batch+ local <- Action getRW+ count <- liftIO $ atomicModifyIORef todo $ \(count, bs) -> let i = count+1 in ((i, (b,local,fence):bs), i)+ requeue todo (==) count+ (wait, local2) <- actionFenceRequeue fence+ Action $ modifyRW $ \root -> addDiscount wait $ localMergeMutable root [local2]+ where+ -- When changing by one, only trigger on (==) so we don't have lots of waiting pool entries+ -- When changing by many, trigger on (>=) because we don't hit all edges+ requeue todo trigger count+ | count `trigger` mx = addPoolWait_ PoolResume $ go todo+ | count `trigger` 1 = addPoolWait_ PoolBatch $ go todo+ | otherwise = return ()++ go todo = do+ -- delete at most mx from the batch+ (now, count) <- liftIO $ atomicModifyIORef todo $ \(count, bs) ->+ let (now,later) = splitAt mx bs+ count2 = max 0 $ count - mx+ in ((count2, later), (now, count2))+ requeue todo (>=) count++ unless (null now) $ do+ res <- Action $ tryRAW $ do+ -- make sure we are using one of the local's that we are computing+ -- we things like stack, blockApply etc. work as expected+ modifyRW $ const $ localClearMutable $ snd3 $ head now+ fromAction $ many $ map fst3 now+ res <- getRW+ return res{localDiscount = localDiscount res / intToDouble (length now)} -- divide the batch fairly+ liftIO $ mapM_ (flip signalFence res . thd3) now+++-- | Given a running task, deprioritize so it only continues after all other pending tasks,+-- and all deprioritized tasks with a higher priority. Note that due to parallelism there is no guarantee+-- that all actions of a higher priority will have /completed/ before the action resumes.+-- Only useful if the results are being interactively reported or consumed.+deprioritize :: Double -> Action ()+deprioritize x = do+ (wait, _) <- actionAlwaysRequeuePriority (PoolDeprioritize $ negate x) $ return ()+ Action $ modifyRW $ addDiscount wait
+ src/Development/Shake/Internal/Core/Build.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables, NamedFieldPuns, GADTs #-}+{-# LANGUAGE Rank2Types, ConstraintKinds, TupleSections, ViewPatterns #-}++module Development.Shake.Internal.Core.Build(+ getDatabaseValue,+ historyIsEnabled, historySave, historyLoad,+ apply, apply1,+ ) where++import Development.Shake.Classes+import General.Pool+import Development.Shake.Internal.Value+import Development.Shake.Internal.Errors+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Action+import Development.Shake.Internal.History.Shared+import Development.Shake.Internal.History.Cloud+import Development.Shake.Internal.Options+import Development.Shake.Internal.Core.Monad+import General.Wait+import qualified Data.ByteString.Char8 as BS+import Control.Monad.IO.Class+import General.Extra+import qualified General.Intern as Intern+import General.Intern(Id)++import Control.Applicative+import Control.Exception+import Control.Monad.Extra+import Numeric.Extra+import qualified Data.HashMap.Strict as Map+import qualified General.Ids as Ids+import Development.Shake.Internal.Core.Rules+import Data.Typeable.Extra+import Data.IORef.Extra+import Data.Maybe+import Data.List.Extra+import Data.Tuple.Extra+import Data.Either.Extra+import System.Time.Extra+import Prelude+++---------------------------------------------------------------------+-- LOW-LEVEL OPERATIONS ON THE DATABASE++getKeyId :: Database -> Key -> Locked Id+getKeyId Database{..} k = liftIO $ do+ is <- readIORef intern+ case Intern.lookup k is of+ Just i -> return i+ Nothing -> do+ (is, i) <- return $ Intern.add k is+ -- make sure to write it into Status first to maintain Database invariants+ Ids.insert status i (k,Missing)+ writeIORef' intern is+ return i++-- Returns Nothing only if the Id was serialised previously but then the Id disappeared+getIdKeyStatus :: Database -> Id -> Locked (Maybe (Key, Status))+getIdKeyStatus Database{..} i = liftIO $ Ids.lookup status i+++setIdKeyStatus :: Global -> Database -> Id -> Key -> Status -> Locked ()+setIdKeyStatus Global{..} database@Database{..} i k v = do+ liftIO $ globalDiagnostic $ do+ old <- Ids.lookup status i+ let changeStatus = maybe "Missing" (statusType . snd) old ++ " -> " ++ statusType v ++ ", " ++ maybe "<unknown>" (show . fst) old+ let changeValue = case v of+ Ready r -> Just $ " = " ++ showBracket (result r) ++ " " ++ (if built r == changed r then "(changed)" else "(unchanged)")+ _ -> Nothing+ return $ changeStatus ++ maybe "" ("\n" ++) changeValue+ setIdKeyStatusQuiet database i k v++setIdKeyStatusQuiet :: Database -> Id -> Key -> Status -> Locked ()+setIdKeyStatusQuiet Database{..} i k v =+ liftIO $ Ids.insert status i (k,v)+++---------------------------------------------------------------------+-- QUERIES++getDatabaseValue :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action (Maybe (Either BS.ByteString value))+getDatabaseValue k = do+ Global{..} <- Action getRO+ Just (_, status) <- liftIO $ runLocked globalDatabase $ \database ->+ getIdKeyStatus database =<< getKeyId database (newKey k)+ return $ case getResult status of+ Just r -> Just $ fromValue <$> result r+ _ -> Nothing+++---------------------------------------------------------------------+-- NEW STYLE PRIMITIVES++-- | Lookup the value for a single Id, may need to spawn it+lookupOne :: Global -> Stack -> Database -> Id -> Wait Locked (Either SomeException (Result (Value, BS_Store)))+lookupOne global stack database i = do+ res <- quickly $ getIdKeyStatus database i+ case res of+ Nothing -> Now $ Left $ errorStructured "Shake Id no longer exists" [("Id", Just $ show i)] ""+ Just (k, s) -> case s of+ Ready r -> Now $ Right r+ Error e _ -> Now $ Left e+ Running{} | Left e <- addStack i k stack -> Now $ Left e+ _ -> Later $ \continue -> do+ Just (_, s) <- getIdKeyStatus database i+ case s of+ Ready r -> continue $ Right r+ Error e _ -> continue $ Left e+ Running (NoShow w) r -> do+ let w2 v = w v >> continue v+ setIdKeyStatusQuiet database i k $ Running (NoShow w2) r+ Loaded r -> buildOne global stack database i k (Just r) `fromLater` continue+ Missing -> buildOne global stack database i k Nothing `fromLater` continue+++-- | Build a key, must currently be either Loaded or Missing, changes to Waiting+buildOne :: Global -> Stack -> Database -> Id -> Key -> Maybe (Result BS.ByteString) -> Wait Locked (Either SomeException (Result (Value, BS_Store)))+buildOne global@Global{..} stack database i k r = case addStack i k stack of+ Left e -> do+ quickly $ setIdKeyStatus global database i k $ mkError e+ return $ Left e+ Right stack -> Later $ \continue -> do+ setIdKeyStatus global database i k (Running (NoShow continue) r)+ let go = buildRunMode global stack database r+ fromLater go $ \mode -> liftIO $ addPool PoolStart globalPool $+ runKey global stack k r mode $ \res -> do+ runLocked globalDatabase $ \_ -> do+ let val = fmap runValue res+ res <- getIdKeyStatus database i+ w <- case res of+ Just (_, Running (NoShow w) _) -> return w+ _ -> throwM $ errorInternal $ "expected Waiting but got " ++ maybe "nothing" (statusType . snd) res ++ ", key " ++ show k+ setIdKeyStatus global database i k $ either mkError Ready val+ w val+ case res of+ Right RunResult{..} | runChanged /= ChangedNothing -> journal database i k runValue{result=runStore}+ _ -> return ()+ where+ mkError e = if globalOneShot then Error e Nothing else Error e r+++-- | Compute the value for a given RunMode and a restore function to run+buildRunMode :: Global -> Stack -> Database -> Maybe (Result a) -> Wait Locked RunMode+buildRunMode global stack database me = do+ changed <- case me of+ Nothing -> return True+ Just me -> buildRunDependenciesChanged global stack database me+ return $ if changed then RunDependenciesChanged else RunDependenciesSame+++-- | Have the dependencies changed+buildRunDependenciesChanged :: Global -> Stack -> Database -> Result a -> Wait Locked Bool+buildRunDependenciesChanged global stack database me = isJust <$> firstJustM id+ [firstJustWaitUnordered (fmap test . lookupOne global stack database) x | Depends x <- depends me]+ where+ test (Right dep) | changed dep <= built me = Nothing+ test _ = Just ()+++---------------------------------------------------------------------+-- ACTUAL WORKERS++applyKeyValue :: [String] -> [Key] -> Action [Value]+applyKeyValue _ [] = return []+applyKeyValue callStack ks = do+ global@Global{..} <- Action getRO+ Local{localStack} <- Action getRW+ let stack = addCallStack (if shakeVerbosity globalOptions > Normal then callStack else take 1 callStack) localStack++ (is, wait) <- liftIO $ runLocked globalDatabase $ \database -> do+ is <- mapM (getKeyId database) ks+ wait <- runWait $ do+ x <- firstJustWaitUnordered (fmap (either Just (const Nothing)) . lookupOne global stack database) $ nubOrd is+ case x of+ Just e -> return $ Left e+ Nothing -> quickly $ Right <$> mapM (fmap (\(Just (_, Ready r)) -> fst $ result r) . getIdKeyStatus database) is+ return (is, wait)+ Action $ modifyRW $ \s -> s{localDepends = Depends is : localDepends s}++ case wait of+ Now vs -> either throwM return vs+ _ -> do+ offset <- liftIO offsetTime+ vs <- Action $ captureRAW $ \continue ->+ runLocked globalDatabase $ \_ -> fromLater wait $ \x ->+ liftIO $ addPool (if isLeft x then PoolException else PoolResume) globalPool $ continue x+ offset <- liftIO offset+ Action $ modifyRW $ addDiscount offset+ return vs+++runKey+ :: Global+ -> Stack -- Given the current stack with the key added on+ -> Key -- The key to build+ -> Maybe (Result BS.ByteString) -- A previous result, or Nothing if never been built before+ -> RunMode -- True if any of the children were dirty+ -> Capture (Either SomeException (RunResult (Result (Value, BS_Store))))+ -- Either an error, or a (the produced files, the result).+runKey global@Global{globalOptions=ShakeOptions{..},..} stack k r mode continue = do+ let tk = typeKey k+ BuiltinRule{..} <- case Map.lookup tk globalRules of+ Nothing -> throwM $ errorNoRuleToBuildType tk (Just $ show k) Nothing+ Just r -> return r++ let s = (newLocal stack shakeVerbosity){localBuiltinVersion = builtinVersion}+ time <- offsetTime+ runAction global s (do+ res <- builtinRun k (fmap result r) mode+ liftIO $ evaluate $ rnf res++ -- completed, now track anything required afterwards+ lintTrackFinished+ producesCheck++ Action $ fmap (res,) getRW) $ \x -> case x of+ Left e -> do+ e <- if isNothing shakeLint then return e else handle return $+ do lintCurrentDirectory globalCurDir $ "Running " ++ show k; return e+ continue . Left . toException =<< shakeException global stack e+ Right (RunResult{..}, Local{..})+ | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->+ continue $ Right $ RunResult runChanged runStore (r{result = mkResult runValue runStore})+ | otherwise -> do+ dur <- time+ let (cr, c) | Just r <- r, runChanged == ChangedRecomputeSame = (ChangedRecomputeSame, changed r)+ | otherwise = (ChangedRecomputeDiff, globalStep)+ continue $ Right $ RunResult cr runStore Result+ {result = mkResult runValue runStore+ ,changed = c+ ,built = globalStep+ ,depends = nubDepends $ reverse localDepends+ ,execution = doubleToFloat $ dur - localDiscount+ ,traces = reverse localTraces}+ where+ mkResult value store = (value, if globalOneShot then BS.empty else store)++---------------------------------------------------------------------+-- USER key/value WRAPPERS++-- | 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 'addBuiltinRule'.+-- All @key@ values passed to 'apply' become dependencies of the 'Action'.+apply :: (Partial, RuleResult key ~ value, ShakeValue key, Typeable value) => [key] -> Action [value]+-- Don't short-circuit [] as we still want error messages+apply ks = do+ -- this is the only place a user can inject a key into our world, so check they aren't throwing+ -- in unevaluated bottoms+ liftIO $ mapM_ (evaluate . rnf) ks++ let tk = typeRep ks+ Local{localBlockApply} <- Action getRW+ whenJust localBlockApply $ throwM . errorNoApply tk (show <$> listToMaybe ks)+ fmap (map fromValue) $ applyKeyValue callStackFull $ map newKey ks+++-- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,+-- use 'apply' to allow parallelism.+apply1 :: (Partial, RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value+apply1 = withFrozenCallStack $ fmap head . apply . return++++---------------------------------------------------------------------+-- HISTORY STUFF++-- | Load a value from the history. Given a version from any user rule+-- (or @0@), return the payload that was stored by 'historySave'.+--+-- If this function returns 'Just' it will also have restored any files that+-- were saved by 'historySave'.+historyLoad :: Int -> Action (Maybe BS.ByteString)+historyLoad (Ver -> ver) = do+ global@Global{..} <- Action getRO+ Local{localStack, localBuiltinVersion} <- Action getRW+ if isNothing globalShared && isNothing globalCloud then return Nothing else do+ key <- liftIO $ evaluate $ fromMaybe (error "Can't call historyLoad outside a rule") $ topStack localStack+ res <- liftIO $ runLocked globalDatabase $ \database -> runWait $ do+ let ask k = do+ i <- quickly $ getKeyId database k+ let identify = Just . runIdentify globalRules k . fst . result+ either (const Nothing) identify <$> lookupOne global localStack database i+ x <- case globalShared of+ Nothing -> return Nothing+ Just shared -> lookupShared shared ask key localBuiltinVersion ver+ x <- case x of+ Just res -> return $ Just res+ Nothing -> case globalCloud of+ Nothing -> return Nothing+ Just cloud -> lookupCloud cloud ask key localBuiltinVersion ver+ case x of+ Nothing -> return Nothing+ Just (a,b,c) -> quickly $ Just . (a,,c) <$> mapM (mapM $ getKeyId database) b+ -- FIXME: If running with cloud and shared, and you got a hit in cloud, should also add it to shared+ res <- case res of+ Now x -> return x+ _ -> do+ offset <- liftIO offsetTime+ res <- Action $ captureRAW $ \continue ->+ runLocked globalDatabase $ \_ -> fromLater res $ \x ->+ liftIO $ addPool PoolResume globalPool $ continue $ Right x+ offset <- liftIO offset+ Action $ modifyRW $ addDiscount offset+ return res+ case res of+ Nothing -> return Nothing+ Just (res, deps, restore) -> do+ liftIO $ globalDiagnostic $ return $ "History hit for " ++ show key+ liftIO restore+ Action $ modifyRW $ \s -> s{localDepends = reverse $ map Depends deps}+ return (Just res)+++-- | Is the history enabled.+historyIsEnabled :: Action Bool+historyIsEnabled = Action $+ (isJust . globalShared <$> getRO) &&^ (localHistory <$> getRW)++-- | Save a value to the history. Record the version of any user rule+-- (or @0@), and a payload. Must be run at the end of the rule, after+-- any dependencies have been captured. If history is enabled, stores the information+-- in a cache.+--+-- This function relies on 'produces' to have been called correctly to describe+-- which files were written during the execution of this rule.+historySave :: Int -> BS.ByteString -> Action ()+historySave (Ver -> ver) store = Action $ do+ Global{..} <- getRO+ Local{localHistory, localProduces, localDepends, localBuiltinVersion, localStack} <- getRW+ liftIO $ when (localHistory && (isJust globalShared || isJust globalCloud)) $ do+ -- make sure we throw errors before we get into the history+ evaluate ver+ evaluate store+ key <- evaluate $ fromMaybe (error "Can't call historySave outside a rule") $ topStack localStack++ let produced = reverse $ map snd localProduces+ deps <- runLocked globalDatabase $ \database ->+ -- technically this could be run without the DB lock, since it reads things that are stable+ forM (reverse localDepends) $ \(Depends is) -> forM is $ \i -> do+ Just (k, Ready r) <- getIdKeyStatus database i+ return (k, runIdentify globalRules k $ fst $ result r)+ let k = topStack localStack+ whenJust globalShared $ \shared -> addShared shared key localBuiltinVersion ver deps store produced+ whenJust globalCloud $ \cloud -> addCloud cloud key localBuiltinVersion ver deps store produced+ liftIO $ globalDiagnostic $ return $ "History saved for " ++ show k+++runIdentify :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> BS.ByteString+runIdentify mp k v+ | Just BuiltinRule{..} <- Map.lookup (typeKey k) mp = builtinIdentity k v+ | otherwise = throwImpure $ errorInternal "runIdentify can't find rule"
− src/Development/Shake/Internal/Core/Database.hs
@@ -1,543 +0,0 @@-{-# LANGUAGE RecordWildCards, PatternGuards, DeriveFunctor #-}-{-# LANGUAGE Rank2Types, FlexibleInstances #-}-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}--module Development.Shake.Internal.Core.Database(- Trace(..), newTrace,- Database, withDatabase, assertFinishedDatabase,- listDepends, lookupDependencies, lookupStatus,- BuildKey(..), build,- Depends, nubDepends,- Step, Result(..),- progress,- Stack, emptyStack, topStack, showStack, showTopStack,- toReport, checkValid, listLive- ) where--import Development.Shake.Classes-import General.Binary-import Development.Shake.Internal.Core.Pool-import Development.Shake.Internal.Value-import Development.Shake.Internal.Errors-import Development.Shake.Internal.Core.Storage-import Development.Shake.Internal.Options-import Development.Shake.Internal.Profile-import Development.Shake.Internal.Core.Monad-import Development.Shake.Internal.Core.Rendezvous-import qualified Data.ByteString.Char8 as BS-import Data.Word-import General.Extra-import qualified General.Intern as Intern-import General.Intern(Id, Intern)--import Numeric.Extra-import Control.Applicative-import Control.Exception-import Control.Monad.Extra-import Control.Concurrent.Extra-import qualified Data.HashSet as Set-import qualified Data.HashMap.Strict as Map-import qualified General.Ids as Ids-import Foreign.Storable-import Data.Typeable.Extra-import Data.IORef.Extra-import Data.Maybe-import Data.List-import Data.Tuple.Extra-import Data.Either.Extra-import System.Time.Extra-import Data.Monoid-import Prelude--type Map = Map.HashMap--------------------------------------------------------------------------- UTILITY TYPES--newtype Step = Step Word32 deriving (Eq,Ord,Show,Storable,BinaryEx,NFData,Hashable,Typeable)--incStep (Step i) = Step $ i + 1--------------------------------------------------------------------------- CALL STACK---- Invariant: Stack xs set . HashSet.fromList (map fst xs) == set-data Stack = Stack [(Id,Key)] !(Set.HashSet Id)--showStack :: Stack -> [String]-showStack (Stack xs _) = reverse $ map (show . snd) xs--showTopStack :: Stack -> String-showTopStack = maybe "<unknown>" show . topStack--addStack :: Id -> Key -> Stack -> Stack-addStack x key (Stack xs set) = Stack ((x,key):xs) (Set.insert x set)--topStack :: Stack -> Maybe Key-topStack (Stack xs _) = snd <$> listToMaybe xs--checkStack :: [Id] -> Stack -> Maybe (Id,Key)-checkStack new (Stack xs set)- | bad:_ <- filter (`Set.member` set) new = Just (bad, fromJust $ lookup bad xs)- | otherwise = Nothing--emptyStack :: Stack-emptyStack = Stack [] Set.empty--------------------------------------------------------------------------- TRACE--data Trace = Trace {-# UNPACK #-} !BS.ByteString {-# UNPACK #-} !Float {-# UNPACK #-} !Float -- ^ (message, start, end)- deriving Show--instance NFData Trace where- rnf x = x `seq` () -- all strict atomic fields--newTrace :: String -> Double -> Double -> Trace-newTrace msg start stop = Trace (BS.pack msg) (doubleToFloat start) (doubleToFloat stop)-------------------------------------------------------------------------- CENTRAL TYPES--type StatusDB = Ids.Ids (Key, Status)-type InternDB = IORef (Intern Key)---- | Invariant: The database does not have any cycles where a Key depends on itself-data Database = Database- {lock :: Lock- ,intern :: InternDB- ,status :: StatusDB- ,step :: {-# UNPACK #-} !Step- ,journal :: Id -> Key -> Result BS.ByteString -> IO ()- ,diagnostic :: IO String -> IO () -- ^ logging function- }--data Status- = Ready (Result Value) -- ^ I have a value- | Error SomeException -- ^ I have been run and raised an error- | Loaded (Result BS.ByteString) -- ^ Loaded from the database- | Waiting (Waiting Status) (Maybe (Result BS.ByteString)) -- ^ Currently checking if I am valid or building- | 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- ,changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid- ,depends :: [Depends] -- ^ dependencies (don't run them early)- ,execution :: {-# UNPACK #-} !Float -- ^ how long it took when it was last run (seconds)- ,traces :: [Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)- } deriving (Show,Functor)--statusType Ready{} = "Ready"-statusType Error{} = "Error"-statusType Loaded{} = "Loaded"-statusType Waiting{} = "Waiting"-statusType Missing{} = "Missing"---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--------------------------------------------------------------------------- OPERATIONS--newtype Depends = Depends {fromDepends :: [Id]}- deriving NFData--instance Show Depends where- -- 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- -> Step -- And the current step- -> Key -- The key to build- -> Maybe (Result BS.ByteString) -- A previous result, or Nothing if never been built before- -> Bool -- True if any of the children were dirty- -> Capture (Either SomeException (Bool, BS.ByteString, Result Value))- -- Either an error, or a result.- -- If the Bool is True you should rewrite the database entry.- }--type Returns a = forall b . (a -> IO b) -> (Capture a -> IO b) -> IO b---internKey :: InternDB -> StatusDB -> Key -> IO Id-internKey intern status k = do- is <- readIORef intern- case Intern.lookup k is of- Just i -> return i- Nothing -> do- (is, i) <- return $ Intern.add k is- writeIORef' intern is- 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]))-build pool Database{..} BuildKey{..} stack ks continue =- join $ withLock lock $ do- is <- forM ks $ internKey intern status-- 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 -> 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- i #= (k,v) = do- diagnostic $ do- old <- Ids.lookup status i- return $ maybe "Missing" (statusType . snd) old ++ " -> " ++ statusType v ++ ", " ++ maybe "<unknown>" (show . fst) old- Ids.insert status i (k,v)- return v-- buildMany :: Stack -> [Id] -> (Status -> Maybe a) -> Returns (Either a [Result Value])- buildMany stack is test fast slow = do- let toAnswer v | Just v <- test v = Abort v- toAnswer (Ready v) = Continue v- let toCompute (Waiting w _) = Later $ toAnswer <$> w- toCompute x = Now $ toAnswer x-- res <- rendezvous =<< mapM (fmap toCompute . reduce stack) is- case res of- Now v -> fast v- Later w -> slow $ \slow -> afterWaiting w slow-- -- Rules for each of the following functions- -- * Must NOT lock- -- * Must have an equal return to what is stored in the db at that point- -- * Must return one of the designated subset of values-- reduce :: Stack -> Id -> IO Status {- Ready | Error | Waiting -}- reduce stack i = do- s <- Ids.lookup status i- case s of- Nothing -> errorInternal $ "interned value missing from database, " ++ show i- Just (k, Missing) -> spawn True stack i k Nothing- Just (k, Loaded r) -> check stack i k r (depends r)- Just (k, res) -> return res--- -- | Given a Key and the list of dependencies yet to be checked, check them- check :: Stack -> Id -> Key -> Result BS.ByteString -> [Depends] -> IO Status {- Ready | Waiting -}- check stack i k r [] = spawn False stack i k $ Just r- check stack i k r (Depends ds:rest) = do- let cont v = if isLeft v then spawn True stack i k $ Just r else check stack i k r rest- buildMany (addStack i k stack) ds- (\v -> case v of- Error _ -> Just ()- Ready dep | changed dep > built r -> Just ()- _ -> Nothing)- cont $- \go -> do- (self, done) <- newWaiting- go $ \v -> do- res <- cont v- case res of- Waiting w _ -> afterWaiting w done- _ -> done res- i #= (k, Waiting self $ Just r)--- -- | Given a Key, queue up execution and return waiting- spawn :: Bool -> Stack -> Id -> Key -> Maybe (Result BS.ByteString) -> IO Status {- Waiting -}- spawn dirtyChildren stack i k r = do- (w, done) <- newWaiting- addPoolStart pool $- buildKey (addStack i k stack) step k r dirtyChildren $ \res -> do- let status = either Error (Ready . thd3) res- withLock lock $ do- i #= (k, status)- done status- case res of- Right (write, bs, r) -> do- diagnostic $ return $- "result " ++ showBracket k ++ " = "++ showBracket (result r) ++- " " ++ (if built r == changed r then "(changed)" else "(unchanged)")- when write $ journal i k r{result=bs}- Left _ ->- diagnostic $ return $ "result " ++ showBracket k ++ " = error"- i #= (k, Waiting w r)--------------------------------------------------------------------------- PROGRESS--progress :: Database -> IO Progress-progress Database{..} = do- xs <- Ids.toList status- return $! foldl' f mempty $ map (snd . snd) xs- where- g = floatToDouble-- f s (Ready Result{..}) = if step == built- then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + g execution}- else s{countSkipped = countSkipped s + 1, timeSkipped = timeSkipped s + g execution}- f s (Loaded Result{..}) = s{countUnknown = countUnknown s + 1, timeUnknown = timeUnknown s + g execution}- f s (Waiting _ r) =- let (d,c) = timeTodo s- t | Just Result{..} <- r = let d2 = d + g execution in d2 `seq` (d2,c)- | otherwise = let c2 = c + 1 in c2 `seq` (d,c2)- in s{countTodo = countTodo s + 1, timeTodo = t}- f s _ = s--------------------------------------------------------------------------- QUERY DATABASE--assertFinishedDatabase :: Database -> IO ()-assertFinishedDatabase Database{..} = do- -- if you have anyone Waiting, and are not exiting with an error, then must have a complex recursion (see #400)- status <- Ids.toList status- let bad = [key | (_, (key, Waiting{})) <- status]- when (bad /= []) $- errorComplexRecursion (map show bad)----- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such--- that no item points to an item before itself.--- Raise an error if you end up with a cycle.-dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> Map a [a] -> [a]--- Algorithm:--- Divide everyone up into those who have no dependencies [Id]--- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])]--- Where d :-> Just (k, ds), k depends on firstly d, then remaining on ds--- For each with no dependencies, add to list, then take its dep hole and--- promote them either to Nothing (if ds == []) or into a new slot.--- k :-> Nothing means the key has already been freed-dependencyOrder shw status = f (map fst noDeps) $ Map.map Just $ Map.fromListWith (++) [(d, [(k,ds)]) | (k,d:ds) <- hasDeps]- where- (noDeps, hasDeps) = partition (null . snd) $ Map.toList status-- f [] mp | null bad = []- | otherwise = error $ unlines $- "Internal invariant broken, database seems to be cyclic" :- map (" " ++) bad ++- ["... plus " ++ show (length badOverflow) ++ " more ..." | not $ null badOverflow]- where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- Map.toList mp]-- f (x:xs) mp = x : f (now++xs) later- where Just free = Map.lookupDefault (Just []) x mp- (now,later) = foldl' g ([], Map.insert x Nothing mp) free-- g (free, mp) (k, []) = (k:free, mp)- g (free, mp) (k, d:ds) = case Map.lookupDefault (Just []) d mp of- Nothing -> g (free, mp) (k, ds)- Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp)----- | Eliminate all errors from the database, pretending they don't exist-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--removeStep :: Map Id (Key, Result a) -> Map Id (Key, Result a)-removeStep = Map.filter (\(k,_) -> k /= stepKey)--toReport :: Database -> IO [ProfileEntry]-toReport Database{..} = do- status <- removeStep . resultsOnly <$> Ids.toMap status- let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status- in dependencyOrder shw $ Map.map (concatMap fromDepends . depends . snd) status- ids = Map.fromList $ zip order [0..]-- steps = let xs = Set.toList $ Set.fromList $ concat [[changed, built] | (_,Result{..}) <- Map.elems status]- in Map.fromList $ zip (sortBy (flip compare) xs) [0..]-- f (k, Result{..}) = ProfileEntry- {prfName = show k- ,prfBuilt = fromStep built- ,prfChanged = fromStep changed- ,prfDepends = mapMaybe (`Map.lookup` ids) (concatMap fromDepends depends)- ,prfExecution = floatToDouble execution- ,prfTraces = map fromTrace traces- }- where fromStep i = fromJust $ Map.lookup i steps- fromTrace (Trace a b c) = ProfileTrace (BS.unpack a) (floatToDouble b) (floatToDouble c)- return [maybe (errorInternal "toReport") f $ Map.lookup i status | i <- order]---checkValid :: Database -> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO ()-checkValid Database{..} check missing = do- status <- Ids.toList status- intern <- readIORef intern- diagnostic $ return "Starting validity/lint checking"-- -- Do not use a forM here as you use too much stack space- bad <- (\f -> foldM f [] status) $ \seen (i,v) -> case v of- (key, Ready Result{..}) -> do- good <- check key result- diagnostic $ return $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if isNothing good then "passed" else "FAILED"- return $ [(key, result, now) | Just now <- [good]] ++ seen- _ -> return seen- unless (null bad) $ do- let n = length bad- errorStructured- ("Lint checking error - " ++ (if n == 1 then "value has" else show n ++ " values have") ++ " changed since being depended upon")- (intercalate [("",Just "")] [ [("Key", Just $ show key),("Old", Just $ show result),("New", Just now)]- | (key, result, now) <- bad])- ""-- bad <- return [(parent,key) | (parent, key) <- missing, isJust $ Intern.lookup key intern]- unless (null bad) $ do- let n = length bad- errorStructured- ("Lint checking error - " ++ (if n == 1 then "value" else show n ++ " values") ++ " did not have " ++ (if n == 1 then "its" else "their") ++ " creation tracked")- (intercalate [("",Just "")] [ [("Rule", Just $ show parent), ("Created", Just $ show key)] | (parent,key) <- bad])- ""-- diagnostic $ return "Validity/lint check passed"---listLive :: Database -> IO [Key]-listLive Database{..} = do- diagnostic $ return "Listing live keys"- status <- Ids.toList status- return [k | (_, (k, Ready{})) <- status]---listDepends :: Database -> Depends -> IO [Key]-listDepends Database{..} (Depends xs) =- withLock lock $- forM xs $ \x ->- fst . fromJust <$> Ids.lookup status x--lookupDependencies :: Database -> Key -> IO [Key]-lookupDependencies Database{..} k =- withLock lock $ do- intern <- readIORef intern- let Just i = Intern.lookup k intern- Just (_, Ready r) <- Ids.lookup status i- forM (concatMap fromDepends $ depends r) $ \x ->- fst . fromJust <$> Ids.lookup status x--------------------------------------------------------------------------- STORAGE---- To simplify journaling etc we smuggle the Step in the database, with a special StepKey-newtype StepKey = StepKey ()- deriving (Show,Eq,Typeable,Hashable,Binary,BinaryEx,NFData)--stepKey :: Key-stepKey = newKey $ StepKey ()--toStepResult :: Step -> Result BS.ByteString-toStepResult i = Result (runBuilder $ putEx i) i i [] 0 []--fromStepResult :: Result BS.ByteString -> Step-fromStepResult = getEx . result---withDatabase :: ShakeOptions -> (IO String -> IO ()) -> Map TypeRep (BinaryOp Key) -> (Database -> IO a) -> IO a-withDatabase opts diagnostic witness act = do- let step = (typeRep (Proxy :: Proxy StepKey), BinaryOp (const mempty) (const stepKey))- witness <- return $ Map.fromList- [ (QTypeRep t, BinaryOp (putDatabase putOp) (getDatabase getOp))- | (t,BinaryOp{..}) <- step : Map.toList witness]- withStorage opts diagnostic witness $ \status journal -> do- journal <- return $ \i k v -> journal (QTypeRep $ typeKey k) i (k, Loaded v)-- xs <- Ids.toList status- let mp1 = Intern.fromList [(k, i) | (i, (k,_)) <- xs]-- (mp1, stepId) <- case Intern.lookup stepKey mp1 of- Just stepId -> return (mp1, stepId)- Nothing -> do- (mp1, stepId) <- return $ Intern.add stepKey mp1- return (mp1, stepId)-- intern <- newIORef mp1- step <- do- v <- Ids.lookup status stepId- return $ case v of- Just (_, Loaded r) -> incStep $ fromStepResult r- _ -> Step 1- journal stepId stepKey $ toStepResult step- lock <- newLock- act Database{..}---putDatabase :: (Key -> Builder) -> ((Key, Status) -> Builder)-putDatabase putKey (key, Loaded (Result x1 x2 x3 x4 x5 x6)) =- putExN (putKey key) <> putExN (putEx x1) <> putEx x2 <> putEx x3 <> putEx x5 <> putExN (putEx x4) <> putEx x6-putDatabase _ (_, x) = errorInternal $ "putWith, Cannot write Status with constructor " ++ statusType x---getDatabase :: (BS.ByteString -> Key) -> BS.ByteString -> (Key, Status)-getDatabase getKey bs- | (key, bs) <- getExN bs- , (x1, bs) <- getExN bs- , (x2, x3, x5, bs) <- binarySplit3 bs- , (x4, x6) <- getExN bs- = (getKey key, Loaded (Result x1 x2 x3 (getEx x4) x5 (getEx x6)))--instance BinaryEx Depends where- putEx (Depends xs) = putExStorableList xs- getEx = Depends . getExStorableList--instance BinaryEx [Depends] where- putEx = putExList . map putEx- getEx = map getEx . getExList--instance BinaryEx Trace where- putEx (Trace a b c) = putEx b <> putEx c <> putEx a- getEx x | (b,c,a) <- binarySplit2 x = Trace a b c--instance BinaryEx [Trace] where- putEx = putExList . map putEx- getEx = map getEx . getExList
src/Development/Shake/Internal/Core/Monad.hs view
@@ -4,7 +4,7 @@ module Development.Shake.Internal.Core.Monad( RAW, Capture, runRAW, getRO, getRW, putRW, modifyRW,- catchRAW, tryRAW, throwRAW,+ catchRAW, tryRAW, throwRAW, finallyRAW, captureRAW, ) where @@ -13,6 +13,7 @@ import Data.IORef.Extra import Control.Applicative import Control.Monad+import Data.Semigroup import Prelude #if __GLASGOW_HASKELL__ >= 800@@ -55,6 +56,14 @@ fail = liftIO . Control.Monad.Fail.fail #endif +instance Semigroup a => Semigroup (RAW ro rw a) where+ (<>) a b = (<>) <$> a <*> b++instance (Semigroup a, Monoid a) => Monoid (RAW ro rw a) where+ mempty = pure mempty+ mappend = (<>)++ type Capture a = (a -> IO ()) -> IO () @@ -62,7 +71,11 @@ runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a) runRAW ro rw m k = do rw <- newIORef rw- handler <- newIORef $ k . Left+ handler <- newIORef undefined+ writeIORef handler $ \e -> do+ -- make sure we never call the error continuation twice+ writeIORef handler throwIO+ k $ Left e goRAW handler ro rw m (k . Right) `catch_` \e -> ($ e) =<< readIORef handler @@ -99,7 +112,6 @@ Right v -> do writeIORef handler old k v `catch_` \e -> ($ e) =<< readIORef handler- writeIORef handler throwIO ---------------------------------------------------------------------@@ -129,7 +141,15 @@ tryRAW m = catchRAW (fmap Right m) (return . Left) throwRAW :: Exception e => e -> RAW ro rw a+-- Note that while we could directly pass this to the handler+-- that would avoid triggering the catch, which would mean they built up on the stack throwRAW = liftIO . throwIO++finallyRAW :: RAW ro rw a -> RAW ro rw b -> RAW ro rw a+finallyRAW a undo = do+ r <- catchRAW a (\e -> undo >> throwRAW e)+ undo+ return r ---------------------------------------------------------------------
src/Development/Shake/Internal/Core/Pool.hs view
@@ -1,175 +1,88 @@+{-# LANGUAGE RecordWildCards, TupleSections #-} --- | 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,- addPoolException, addPoolResume, addPoolStart, addPoolBatch,- increasePool+ addPoolWait, actionFenceSteal, actionFenceRequeue,+ actionAlwaysRequeue, actionAlwaysRequeuePriority,+ addPoolWait_,+ actionFenceRequeueBy ) where -import Control.Concurrent.Extra-import System.Time.Extra import Control.Exception-import Control.Monad.Extra-import General.Timing-import General.Extra-import qualified General.Bag as Bag-import qualified Data.HashSet as Set--------------------------------------------------------------------------- UNFAIR/RANDOM QUEUE--data Queue a = Queue- {queueException :: Bag.Bag a- ,queueResume :: Bag.Bag a- ,queueStart :: Bag.Bag a- ,queueBatch :: Bag.Bag 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 b b b b- where b = if deterministic then Bag.emptyPure else Bag.emptyRandom--dequeue :: Queue a -> Bag.Randomly (Maybe (a, Queue a))-dequeue q = firstJustM f lenses- where- f (sel, upd)- | Just x <- Bag.remove $ sel q- = do (x,b) <- x; return $ Just (x, upd q b)- f _ = return Nothing--------------------------------------------------------------------------- THREAD POOL--{--Must keep a list of active threads, so can raise exceptions in a timely manner-If any worker throws an exception, must signal to all the other workers--}--data Pool = Pool- !(Var (Maybe S)) -- Current state, 'Nothing' to say we are aborting- !(Barrier (Either SomeException S)) -- Barrier to signal that we are finished--data S = S- {threads :: !(Set.HashSet ThreadId) -- IMPORTANT: Must be strict or we leak thread stacks- ,threadsLimit :: {-# UNPACK #-} !Int -- user supplied thread limit, Set.size threads <= threadsLimit- ,threadsMax :: {-# UNPACK #-} !Int -- high water mark of Set.size threads (accounting only)- ,threadsSum :: {-# UNPACK #-} !Int -- number of threads we have been through (accounting only)- ,todo :: !(Queue (IO ())) -- operations waiting a thread- }+import General.Pool+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Monad+import System.Time.Extra+import Data.Either.Extra+import Control.Monad.IO.Class+import General.Fence+import Data.Functor+import Prelude -emptyS :: Int -> Bool -> S-emptyS n deterministic = S Set.empty n 0 0 $ newQueue deterministic+priority x = if isLeft x then PoolException else PoolResume -worker :: Pool -> IO ()-worker pool@(Pool var done) = do- let onVar act = modifyVar var $ maybe (return (Nothing, return ())) act- join $ onVar $ \s -> do- res <- dequeue $ todo s- case res of- Nothing -> return (Just s, return ())- Just (now, todo2) -> return (Just s{todo = todo2}, now >> worker pool)+-- | Enqueue an Action into the pool and return a Fence to wait for it.+-- Returns the value along with how long it spent executing.+addPoolWait :: PoolPriority -> Action a -> Action (Fence IO (Either SomeException (Seconds, a)))+addPoolWait pri act = do+ ro@Global{..} <- Action getRO+ rw <- Action getRW+ liftIO $ do+ fence <- newFence+ let act2 = do offset <- liftIO offsetTime; res <- act; offset <- liftIO offset; return (offset, res)+ addPool pri globalPool $ runAction ro rw act2 $ signalFence fence+ return fence --- | 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 -> Bag.Randomly S) -> IO ()-step pool@(Pool var done) op = do- let onVar act = modifyVar_ var $ maybe (return Nothing) act- onVar $ \s -> do- s <- op s- res <- dequeue $ todo s- case res of- Just (now, todo2) | Set.size (threads s) < threadsLimit s -> do- -- spawn a new worker- t <- forkFinallyUnmasked (now >> worker pool) $ \res -> case res of- Left e -> onVar $ \s -> do- t <- myThreadId- mapM_ killThread $ Set.toList $ Set.delete t $ threads s- signalBarrier done $ Left e- return Nothing- Right _ -> do- t <- myThreadId- step pool $ \s -> return s{threads = Set.delete t $ threads s}- let threads2 = Set.insert t $ threads s- return $ Just s{todo = todo2, threads = threads2- ,threadsSum = threadsSum s + 1, threadsMax = threadsMax s `max` Set.size threads2}- Nothing | Set.null $ threads s -> do- signalBarrier done $ Right s- return Nothing- _ -> return $ Just s+-- | Like 'addPoolWait' but doesn't provide a fence to wait for it - a fire and forget version.+-- Warning: If Action throws an exception, it would be lost, so must be executed with try. Seconds are not tracked.+addPoolWait_ :: PoolPriority -> Action a -> Action ()+addPoolWait_ pri act = do+ ro@Global{..} <- Action getRO+ rw <- Action getRW+ liftIO $ addPool pri globalPool $ runAction ro rw act $ \_ -> return () -addPool (sel, upd) pool act = step pool $ \s ->- return s{todo = upd (todo s) $ Bag.insert (void act) $ sel $ todo s}+actionFenceSteal :: Fence IO (Either SomeException a) -> Action (Seconds, a)+actionFenceSteal fence = do+ res <- liftIO $ testFence fence+ case res of+ Just (Left e) -> Action $ throwRAW e+ Just (Right v) -> return (0, v)+ Nothing -> Action $ captureRAW $ \continue -> do+ offset <- offsetTime+ waitFence fence $ \v -> do+ offset <- offset+ continue $ (offset,) <$> v --- | 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-+actionFenceRequeue :: Fence IO (Either SomeException b) -> Action (Seconds, b)+actionFenceRequeue = actionFenceRequeueBy id --- | Temporarily increase the pool by 1 thread. Call the cleanup action to restore the value.--- After calling cleanup you should requeue onto a new thread.-increasePool :: Pool -> IO (IO ())-increasePool pool = do- step pool $ \s -> return s{threadsLimit = threadsLimit s + 1}- return $ step pool $ \s -> return s{threadsLimit = threadsLimit s - 1}+actionFenceRequeueBy :: (a -> Either SomeException b) -> Fence IO a -> Action (Seconds, b)+actionFenceRequeueBy op fence = Action $ do+ res <- liftIO $ testFence fence+ case fmap op res of+ Just (Left e) -> throwRAW e+ Just (Right v) -> return (0, v)+ Nothing -> do+ Global{..} <- getRO+ offset <- liftIO offsetTime+ captureRAW $ \continue -> waitFence fence $ \v -> do+ let v2 = op v+ addPool (priority v2) globalPool $ do+ offset <- offset+ continue $ (offset,) <$> v2 --- | Run all the tasks in the pool on the given number of works.--- If any thread throws an exception, the exception will be reraised.--- When it completes all threads have either finished, or have had 'killThread'--- called on them (but may not have actually died yet).-runPool :: Bool -> Int -> (Pool -> IO ()) -> IO () -- run all tasks in the pool-runPool deterministic n act = do- s <- newVar $ Just $ emptyS n deterministic- done <- newBarrier-- let cleanup = modifyVar_ s $ \s -> do- -- if someone kills our thread, make sure we kill our child threads- case s of- Just s -> mapM_ killThread $ Set.toList $ threads s- Nothing -> return ()- return Nothing+actionAlwaysRequeue :: Either SomeException a -> Action (Seconds, a)+actionAlwaysRequeue res = actionAlwaysRequeuePriority (priority res) res - let ghc10793 = do- -- if this thread dies because it is blocked on an MVar there's a chance we have- -- a better error in the done barrier, and GHC raised the exception wrongly, see:- -- https://ghc.haskell.org/trac/ghc/ticket/10793- sleep 1 -- give it a little bit of time for the finally to run- -- no big deal, since the blocked indefinitely takes a while to fire anyway- res <- waitBarrierMaybe done- case res of- Just (Left e) -> throwIO e- _ -> throwIO BlockedIndefinitelyOnMVar- handle (\BlockedIndefinitelyOnMVar -> ghc10793) $ flip onException cleanup $ do- let pool = Pool s done- addPoolStart pool $ act pool- res <- waitBarrier done- case res of- Left e -> throwIO e- Right s -> addTiming $ "Pool finished (" ++ show (threadsSum s) ++ " threads, " ++ show (threadsMax s) ++ " max)"+actionAlwaysRequeuePriority :: PoolPriority -> Either SomeException a -> Action (Seconds, a)+actionAlwaysRequeuePriority pri res = Action $ do+ Global{..} <- getRO+ offset <- liftIO offsetTime+ captureRAW $ \continue ->+ addPool pri globalPool $ do+ offset <- offset+ continue $ (offset,) <$> res
− src/Development/Shake/Internal/Core/Rendezvous.hs
@@ -1,87 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}--module Development.Shake.Internal.Core.Rendezvous(- Waiting, newWaiting, afterWaiting,- Answer(..), Compute(..),- rendezvous- ) where--import Control.Monad-import Data.IORef.Extra-import Data.Primitive.Array-import Development.Shake.Internal.Errors----- | Given a sequence of 'Answer' values the sequence stops--- when there is a single 'Abort' or all values end up as 'Continue'.-data Answer a c- = Abort a- | Continue c---- | A compuation that either has a result available immediate,--- or has a result that can be collected later.-data Compute a- = Now a- | Later (Waiting a)--partitionAnswer :: [Answer a c] -> ([a], [c])-partitionAnswer = foldr f ([],[])- where f (Abort a) ~(as,cs) = (a:as,cs)- f (Continue c) ~(as,cs) = (as,c:cs)--partitionCompute :: [Compute a] -> ([a], [Waiting a])-partitionCompute = foldr f ([],[])- where f (Now x) ~(xs,ws) = (x:xs,ws)- f (Later w) ~(xs,ws) = (xs,w:ws)----- | A type representing someone waiting for a result.-data Waiting a = forall b . Waiting (b -> a) (IORef (b -> IO ()))- -- Contains a functor value to apply, along with somewhere to register callbacks--instance Functor Waiting where- fmap f (Waiting op ref) = Waiting (f . op) ref--instance Show (Waiting a) where- show _ = "Waiting"---newWaiting :: IO (Waiting a, a -> IO ())-newWaiting = do- ref <- newIORef $ \_ -> return ()- let run x = ($ x) =<< readIORef ref- return (Waiting id ref, run)--afterWaiting :: Waiting a -> (a -> IO ()) -> IO ()-afterWaiting (Waiting op ref) act = modifyIORef' ref (\a s -> a s >> act (op s))---rendezvous :: [Compute (Answer a c)] -> IO (Compute (Either a [c]))-rendezvous xs = do- let (now, later) = partitionCompute xs- let (abort, continue) = partitionAnswer now- if not $ null abort then- return $ Now $ Left $ head abort- else if null later then- return $ Now $ Right continue- else do- (waiting, run) <- newWaiting- let n = length xs- result <- newArray n $ errorInternal "rendezvous"- todo <- newIORef $ length later- forM_ (zip [0..] xs) $ \(i,x) -> case x of- Now (Continue c) -> writeArray result i c- Later w -> afterWaiting w $ \v -> do- t <- readIORef todo- case v of- _ | t == 0 -> return () -- must have already aborted- Abort a -> do- writeIORef todo 0- run $ Left a- Continue c -> do- writeArray result i c- writeIORef' todo $ t-1- when (t == 1) $ do- rs <- unsafeFreezeArray result- run $ Right $ map (indexArray rs) [0..n-1]- return $ Later waiting
src/Development/Shake/Internal/Core/Rules.hs view
@@ -5,29 +5,32 @@ module Development.Shake.Internal.Core.Rules( Rules, runRules,- RuleResult, addBuiltinRule, addBuiltinRuleEx, noLint,- getShakeOptionsRules, userRuleMatch,- getUserRules, addUserRule, alternatives, priority,+ RuleResult, addBuiltinRule, addBuiltinRuleEx,+ noLint, noIdentity,+ getShakeOptionsRules,+ getUserRuleInternal, getUserRuleOne, getUserRuleList, getUserRuleMaybe,+ addUserRule, alternatives, priority, versioned, action, withoutActions ) where import Control.Applicative import Data.Tuple.Extra+import Control.Exception import Control.Monad.Extra import Control.Monad.Fix import Control.Monad.IO.Class-import Control.Monad.Trans.Class import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer.Strict import Development.Shake.Classes import General.Binary+import General.Extra import Data.Typeable.Extra import Data.Function import Data.List.Extra import qualified Data.HashMap.Strict as Map+import qualified General.TypeMap as TMap import Data.Maybe+import Data.IORef.Extra import System.IO.Extra-import System.IO.Unsafe import Data.Semigroup (Semigroup (..)) import Data.Monoid hiding ((<>)) import qualified Data.ByteString.Lazy as LBS@@ -47,73 +50,100 @@ --------------------------------------------------------------------- -- RULES --- | Get the 'UserRule' value at a given type. This 'UserRule' will capture--- all rules added, along with things such as 'priority' and 'alternatives'.-getUserRules :: Typeable a => Action (UserRule a)-getUserRules = f where- f :: forall a . Typeable a => Action (UserRule a)- f = do- Global{..} <- Action getRO- return $ case Map.lookup (typeRep (Proxy :: Proxy a)) globalUserRules of- Nothing -> Unordered []- Just (UserRule_ r) -> fromJust $ cast r-- -- | Get the 'ShakeOptions' that were used. getShakeOptionsRules :: Rules ShakeOptions-getShakeOptionsRules = Rules $ lift ask+getShakeOptionsRules = Rules $ asks fst --- | Give a 'UserRule', and a function that tests a given rule, return the most important values--- that match. In most cases the caller will raise an error if the rule matching returns anything--- other than a singleton.-userRuleMatch :: UserRule a -> (a -> Maybe b) -> [b]-userRuleMatch u test = head $ (map snd $ reverse $ groupSort $ f Nothing $ fmap test u) ++ [[]]++-- | Internal variant, more flexible, but not such a nice API+-- Same args as getuserRuleMaybe, but returns (guaranteed version, items, error to throw if wrong number)+-- Fields are returned lazily, in particular ver can be looked up cheaper+getUserRuleInternal :: forall key a b . (ShakeValue key, Typeable a) => key -> (a -> Maybe String) -> (a -> Maybe b) -> Action (Maybe Ver, [(Int, b)], SomeException)+getUserRuleInternal key disp test = do+ Global{..} <- Action getRO+ let UserRuleVersioned versioned rules = fromMaybe mempty $ TMap.lookup globalUserRules+ let ver = if versioned then Nothing else Just $ Ver 0+ let items = head $ (map snd $ reverse $ groupSort $ f (Ver 0) Nothing rules) ++ [[]]+ let err = errorMultipleRulesMatch (typeOf key) (show key) (map snd3 items)+ return (ver, map (\(Ver v,_,x) -> (v,x)) items, err) where- f :: Maybe Double -> UserRule (Maybe a) -> [(Double,a)]- f p (UserRule x) = maybe [] (\x -> [(fromMaybe 1 p,x)]) x- f p (Unordered xs) = concatMap (f p) xs- f p (Priority p2 x) = f (Just $ fromMaybe p2 p) x- f p (Alternative x) = case f p x of- [] -> []- -- a bit weird to use the max priority but the first value- -- but that's what the current implementation does...- xs -> [(maximum $ map fst xs, snd $ head xs)]+ f :: Ver -> Maybe Double -> UserRule a -> [(Double,(Ver,Maybe String,b))]+ f v p (UserRule x) = [(fromMaybe 1 p, (v,disp x,x2)) | Just x2 <- [test x]]+ f v p (Unordered xs) = concatMap (f v p) xs+ f v p (Priority p2 x) = f v (Just $ fromMaybe p2 p) x+ f _ p (Versioned v x) = f v p x+ f v p (Alternative x) = take 1 $ f v p x +-- | Get the user rules that were added at a particular type which return 'Just' on a given function.+-- Return all equally applicable rules, paired with the version of the rule+-- (set by 'versioned'). Where rules are specified with 'alternatives' or 'priority'+-- the less-applicable rules will not be returned.+--+-- If you can only deal with zero/one results, call 'getUserRuleMaybe' or 'getUserRuleOne',+-- which raise informative errors.+getUserRuleList :: Typeable a => (a -> Maybe b) -> Action [(Int, b)]+getUserRuleList test = snd3 <$> getUserRuleInternal () (const Nothing) test+++-- | A version of 'getUserRuleList' that fails if there is more than one result+-- Requires a @key@ for better error messages.+getUserRuleMaybe :: (ShakeValue key, Typeable a) => key -> (a -> Maybe String) -> (a -> Maybe b) -> Action (Maybe (Int, b))+getUserRuleMaybe key disp test = do+ (_, xs, err) <- getUserRuleInternal key disp test+ case xs of+ [] -> return Nothing+ [x] -> return $ Just x+ _ -> throwM err++-- | A version of 'getUserRuleList' that fails if there is not exactly one result+-- Requires a @key@ for better error messages.+getUserRuleOne :: (ShakeValue key, Typeable a) => key -> (a -> Maybe String) -> (a -> Maybe b) -> Action (Int, b)+getUserRuleOne key disp test = do+ (_, xs, err) <- getUserRuleInternal key disp test+ case xs of+ [x] -> return x+ _ -> throwM err++ -- | Define a set of rules. Rules can be created with calls to functions such as 'Development.Shake.%>' or 'action'. -- Rules are combined with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation. -- To define your own custom types of rule, see "Development.Shake.Rule".-newtype Rules a = Rules (WriterT SRules (ReaderT ShakeOptions IO) a) -- All IO must be associative/commutative (e.g. creating IORef/MVars)+newtype Rules a = Rules (ReaderT (ShakeOptions, IORef SRules) IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) newRules :: SRules -> Rules ()-newRules = Rules . tell+newRules x = Rules $ liftIO . flip modifyIORef' (<> x) =<< asks snd -modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()-modifyRules f (Rules r) = Rules $ censor f r+modifyRules :: (SRules -> SRules) -> Rules a -> Rules a+modifyRules f (Rules r) = Rules $ do+ (opts, refOld) <- ask+ liftIO $ do+ refNew <- newIORef mempty+ res <- runReaderT r (opts, refNew)+ rules <- readIORef refNew+ modifyIORef' refOld (<> f rules)+ return res -runRules :: ShakeOptions -> Rules () -> IO ([Action ()], Map.HashMap TypeRep BuiltinRule, Map.HashMap TypeRep UserRule_)+runRules :: ShakeOptions -> Rules () -> IO ([(Stack, Action ())], Map.HashMap TypeRep BuiltinRule, TMap.Map UserRuleVersioned) runRules opts (Rules r) = do- SRules{..} <- runReaderT (execWriterT r) opts+ ref <- newIORef mempty+ runReaderT r (opts, ref)+ SRules{..} <- readIORef ref return (runListBuilder actions, builtinRules, userRules) data SRules = SRules- {actions :: !(ListBuilder (Action ()))+ {actions :: !(ListBuilder (Stack, Action ())) ,builtinRules :: !(Map.HashMap TypeRep{-k-} BuiltinRule)- ,userRules :: !(Map.HashMap TypeRep{-k-} UserRule_)+ ,userRules :: !(TMap.Map UserRuleVersioned) } 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)-- fromUnordered (Unordered xs) = xs- fromUnordered x = [x]+ (SRules x1 x2 x3) <> (SRules y1 y2 y3) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (TMap.unionWith (<>) x3 y3)+ where f k a b = throwImpure $ errorRuleDefinedMultipleTimes k [builtinLocation a, builtinLocation b] instance Monoid SRules where- mempty = SRules mempty Map.empty Map.empty+ mempty = SRules mempty Map.empty TMap.empty mappend = (<>) instance Semigroup a => Semigroup (Rules a) where@@ -124,36 +154,58 @@ mappend = (<>) --- | Add a value of type 'UserRule'.+-- | Add a user rule. In general these should be specialised to the type expected by a builtin rule.+-- The user rules can be retrieved by 'getUserRuleList'. addUserRule :: Typeable a => a -> Rules ()-addUserRule r = newRules mempty{userRules = Map.singleton (typeOf r) $ UserRule_ $ UserRule r}+addUserRule r = newRules mempty{userRules = TMap.singleton $ UserRuleVersioned False $ UserRule r} -- | A suitable 'BuiltinLint' that always succeeds. noLint :: BuiltinLint key value noLint _ _ = return Nothing +-- | A suitable 'BuiltinIdentity' that always fails with a runtime error, incompatible with 'shakeShare'.+-- Use this function if you don't care about 'shakeShare', or if your rule provides a dependency that can+-- never be cached (in which case you should also call 'Development.Shake.historyDisable').+noIdentity :: Typeable key => BuiltinIdentity key value+noIdentity k _ = throwImpure $ errorStructured+ "Key type does not support BuiltinIdentity, so does not work with 'shakeShare'"+ [("Key type", Just $ show (typeOf k))] []+++-- | The type mapping between the @key@ or a rule and the resulting @value@.+-- See 'addBuiltinRule' and 'apply'. type family RuleResult key -- = value --- | Add a builtin rule, comprising of a lint rule and an action. Each builtin rule must be identified by--- a unique key.-addBuiltinRule :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BuiltinLint key value -> BuiltinRun key value -> Rules ()-addBuiltinRule = addBuiltinRuleInternal $ BinaryOp+-- | Define a builtin rule, passing the functions to run in the right circumstances.+-- The @key@ and @value@ types will be what is used by 'Development.Shake.apply'.+-- As a start, you can use 'noLint' and 'noIdentity' as the first two functions,+-- but are required to supply a suitable 'BuiltinRun'.+--+-- Raises an error if any other rule exists at this type.+addBuiltinRule+ :: (RuleResult key ~ value, ShakeValue key, ShakeValue value, Partial)+ => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()+addBuiltinRule = withFrozenCallStack $ addBuiltinRuleInternal $ BinaryOp (putEx . Bin.toLazyByteString . execPut . put) (runGet get . LBS.fromChunks . return) -addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value) => BuiltinLint key value -> BuiltinRun key value -> Rules ()+addBuiltinRuleEx+ :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value, Partial)+ => BuiltinLint key value -> BuiltinIdentity 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, Typeable value, NFData value, Show value) => BinaryOp key -> BuiltinLint key value -> BuiltinRun key value -> Rules ()-addBuiltinRuleInternal binary lint (run :: BuiltinRun key value) = do+addBuiltinRuleInternal+ :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial)+ => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules ()+addBuiltinRuleInternal binary lint check (run :: BuiltinRun key value) = do let k = Proxy :: Proxy key- v = Proxy :: Proxy value- let run_ k v b = fmap newValue <$> run (fromKey k) v b let lint_ k v = lint (fromKey k) (fromValue v)+ let check_ k v = check (fromKey k) (fromValue v)+ let run_ k v b = fmap newValue <$> run (fromKey k) v b let binary_ = BinaryOp (putOp binary . fromKey) (newKey . getOp binary)- newRules mempty{builtinRules = Map.singleton (typeRep k) $ BuiltinRule run_ lint_ (typeRep v) binary_}+ newRules mempty{builtinRules = Map.singleton (typeRep k) $ BuiltinRule lint_ check_ run_ binary_ (Ver 0) callStackTop} -- | Change the priority of a given set of rules, where higher priorities take precedence.@@ -174,11 +226,27 @@ -- 'priority' p1 ('priority' p2 r1) === 'priority' p1 r1 -- 'priority' p1 (r1 >> r2) === 'priority' p1 r1 >> 'priority' p1 r2 -- @-priority :: Double -> Rules () -> Rules ()-priority d = modifyRules $ \s -> s{userRules = Map.map f $ userRules s}- where f (UserRule_ s) = UserRule_ $ Priority d s+priority :: Double -> Rules a -> Rules a+priority d = modifyRules $ \s -> s{userRules = TMap.map (\(UserRuleVersioned b x) -> UserRuleVersioned b $ Priority d x) $ userRules s} +-- | Indicate that the nested rules have a given version. If you change the semantics of the rule then updating (or adding)+-- a version will cause the rule to rebuild in some circumstances.+--+-- @+-- 'versioned' 1 $ \"hello.*\" %> \\out ->+-- 'writeFile'' out \"Writes v1 now\" -- previously wrote out v0+-- @+--+-- You should only use 'versioned' to track changes in the build source, for standard runtime dependencies you should use+-- other mechanisms, e.g. 'Development.Shake.addOracle'.+versioned :: Int -> Rules a -> Rules a+versioned v = modifyRules $ \s -> s+ {userRules = TMap.map (\(UserRuleVersioned b x) -> UserRuleVersioned (b || v /= 0) $ Versioned (Ver v) x) $ userRules s+ ,builtinRules = Map.map (\b -> b{builtinVersion = Ver v}) $ builtinRules s+ }++ -- | Change the matching behaviour of rules so rules do not have to be disjoint, but are instead matched -- in order. Only recommended for small blocks containing a handful of rules. --@@ -191,9 +259,8 @@ -- In this example @hello.txt@ will match the first rule, instead of raising an error about ambiguity. -- Inside 'alternatives' the 'priority' of each rule is not used to determine which rule matches, -- but the resulting match uses that priority compared to the rules outside the 'alternatives' block.-alternatives :: Rules () -> Rules ()-alternatives = modifyRules $ \r -> r{userRules = Map.map f $ userRules r}- where f (UserRule_ s) = UserRule_ $ Alternative s+alternatives :: Rules a -> Rules a+alternatives = modifyRules $ \r -> r{userRules = TMap.map (\(UserRuleVersioned b x) -> UserRuleVersioned b $ Alternative x) $ userRules r} -- | Run an action, usually used for specifying top-level requirements.@@ -207,15 +274,17 @@ -- -- This 'action' builds @file.out@, but only if @file.src@ exists. The 'action' -- will be run in every build execution (unless 'withoutActions' is used), so only cheap--- operations should be performed. All arguments to 'action' may be run in parallel, in any order.+-- operations should be performed. On the flip side, consulting system information+-- (e.g. environment variables) can be done directly as the information will not be cached.+-- All calls to 'action' may be run in parallel, in any order. -- -- For the standard requirement of only 'Development.Shake.need'ing a fixed list of files in the 'action', -- see 'Development.Shake.want'.-action :: Action a -> Rules ()-action a = newRules mempty{actions=newListBuilder $ void a}+action :: Partial => Action a -> Rules ()+action act = newRules mempty{actions=newListBuilder (addCallStack callStackFull emptyStack, void act)} -- | Remove all actions specified in a set of rules, usually used for implementing -- command line specification of what to build.-withoutActions :: Rules () -> Rules ()+withoutActions :: Rules a -> Rules a withoutActions = modifyRules $ \x -> x{actions=mempty}
src/Development/Shake/Internal/Core/Run.hs view
@@ -1,28 +1,30 @@ {-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, PatternGuards #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds, TupleSections #-} {-# LANGUAGE TypeFamilies #-} module Development.Shake.Internal.Core.Run(+ RunState,+ open,+ reset, run,- Action, actionOnException, actionFinally, apply, apply1, traced,- getDatabaseValue,- getShakeOptions, getProgress,- getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,- Resource, newResourceIO, withResource, newThrottleIO,- newCacheIO,- unsafeExtraThread, unsafeAllowApply,- parallel,- orderOnlyAction,- batch,- runAfter+ shakeRunAfter,+ liveFilesState,+ errorsState ) where import Control.Exception import Control.Applicative import Data.Tuple.Extra-import Control.Concurrent.Extra+import Control.Concurrent.Extra hiding (withNumCapabilities)+import General.Binary+import Development.Shake.Internal.Core.Storage+import Development.Shake.Internal.History.Shared+import Development.Shake.Internal.History.Cloud+import qualified General.Ids as Ids+import qualified General.Intern as Intern+import qualified General.TypeMap as TMap+import General.Wait import Control.Monad.Extra-import Control.Monad.IO.Class import Data.Typeable.Extra import Data.Function import Data.Either.Extra@@ -34,224 +36,185 @@ import System.Directory import System.IO.Extra import System.Time.Extra-import Numeric.Extra import qualified Data.ByteString as BS import Development.Shake.Classes import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Action import Development.Shake.Internal.Core.Rules-import Development.Shake.Internal.Core.Pool-import Development.Shake.Internal.Core.Database-import Development.Shake.Internal.Core.Monad-import Development.Shake.Internal.Resource+import General.Pool+import Development.Shake.Internal.Progress import Development.Shake.Internal.Value import Development.Shake.Internal.Profile import Development.Shake.Internal.Options import Development.Shake.Internal.Errors import General.Timing import General.Extra-import General.Concurrent import General.Cleanup+import Data.Monoid import Prelude --------------------------------------------------------------------- -- MAKE --- | Internal main function (not exported publicly)-run :: ShakeOptions -> Rules () -> IO ()-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}+data RunState = RunState+ {opts :: ShakeOptions+ ,ruleinfo :: Map.HashMap TypeRep BuiltinRule+ ,userRules :: TMap.Map UserRuleVersioned+ ,databaseVar :: Var Database+ ,curdir :: FilePath+ ,shared :: Maybe Shared+ ,cloud :: Maybe Cloud+ ,actions :: [(Stack, Action ())]+ } - start <- offsetTime++open :: Cleanup -> ShakeOptions -> Rules () -> IO RunState+open cleanup opts rs = withInit opts $ \opts@ShakeOptions{..} diagnostic _ -> do+ diagnostic $ return "Starting run" (actions, ruleinfo, userRules) <- runRules opts rs+ checkShakeExtra shakeExtra+ curdir <- getCurrentDirectory - outputLocked <- do- lock <- newLock- return $ \v msg -> withLock lock $ shakeOutput v msg+ databaseVar <- newVar =<< usingDatabase cleanup opts diagnostic ruleinfo+ (shared, cloud) <- loadSharedCloud databaseVar opts ruleinfo+ return RunState{..} - let diagnostic | shakeVerbosity < Diagnostic = const $ return ()- | otherwise = \act -> do v <- act; outputLocked Diagnostic $ "% " ++ v- let output v = outputLocked v . shakeAbbreviationsApply opts- diagnostic $ return "Starting run" - except <- newIORef (Nothing :: Maybe (String, ShakeException))- let raiseError err- | not shakeStaunch = throwIO err- | otherwise = do- let named = shakeAbbreviationsApply opts . shakeExceptionTarget- atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())- -- no need to print exceptions here, they get printed when they are wrapped+-- Prepare for a fresh run by changing Result to Loaded+reset :: RunState -> IO ()+reset RunState{..} = withVar databaseVar $ \database ->+ Ids.forMutate (status database) $ \(k, s) -> (k, f s)+ where+ f (Ready r) = Loaded (snd <$> r)+ f (Error _ x) = maybe Missing Loaded x+ f (Running _ x) = maybe Missing Loaded x -- shouldn't ever happen, but Loaded is least worst+ f x = x - curdir <- getCurrentDirectory- diagnostic $ return "Starting run 2"- checkShakeExtra shakeExtra - after <- newIORef []- absent <- newIORef []- withCleanup $ \cleanup -> do- addCleanup_ cleanup $ do+run :: RunState -> Bool -> [Action ()] -> IO [IO ()]+run RunState{..} oneshot actions2 =+ withCleanup $ \cleanup -> withInit opts $ \opts@ShakeOptions{..} diagnostic output -> do+ register cleanup $ do when (shakeTimings && shakeVerbosity >= Normal) printTimings resetTimings -- so we don't leak memory- withNumCapabilities shakeThreads $ do- diagnostic $ return "Starting run 3"- withDatabase opts diagnostic (Map.map builtinKey ruleinfo) $ \database -> do- wait <- newBarrier- let getProgress = do- failure <- fmap fst <$> readIORef except- stats <- progress database- return stats{isFailure=failure}- tid <- flip forkFinally (const $ signalBarrier wait ()) $- shakeProgress getProgress- addCleanup_ cleanup $ do- killThread tid- 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 ->- 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- assertFinishedDatabase database-- let putWhen lvl msg = when (shakeVerbosity >= lvl) $ output lvl msg+ start <- offsetTime+ database <- readVar databaseVar+ except <- newIORef (Nothing :: Maybe (String, ShakeException))+ let getFailure = fmap fst <$> readIORef except+ let raiseError err+ | not shakeStaunch = throwIO err+ | otherwise = do+ let named = shakeAbbreviationsApply opts . shakeExceptionTarget+ atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())+ -- no need to print exceptions here, they get printed when they are wrapped - when (null actions) $- putWhen Normal "Warning: No want/action statements, nothing to do"+ after <- newIORef []+ absent <- newIORef []+ step <- incrementStep database+ getProgress <- usingProgress cleanup opts database step getFailure+ lintCurrentDirectory curdir "When running" - when (isJust shakeLint) $ do- addTiming "Lint checking"- lintCurrentDirectory curdir "After completion"- absent <- readIORef absent- checkValid database (runLint ruleinfo) absent- putWhen Loud "Lint checking succeeded"- when (shakeReport /= []) $ do- addTiming "Profile report"- report <- toReport database- forM_ shakeReport $ \file -> do- putWhen Normal $ "Writing report to " ++ file- writeProfile file report- when (shakeLiveFiles /= []) $ do- addTiming "Listing live"- live <- listLive database- let specialIsFileKey t = show (fst $ splitTyConApp t) == "FileQ"- let liveFiles = [show k | k <- live, specialIsFileKey $ typeKey k]- forM_ shakeLiveFiles $ \file -> do- putWhen Normal $ "Writing live list to " ++ file- (if file == "-" then putStr else writeFile file) $ unlines liveFiles- after <- readIORef after- unless (null after) $ do- addTiming "Running runAfter"- sequence_ $ reverse after+ addTiming "Running rules"+ runPool (shakeThreads == 1) shakeThreads $ \pool -> do+ let global = Global databaseVar pool cleanup start ruleinfo output opts diagnostic curdir after absent getProgress userRules shared cloud step oneshot+ -- give each action a stack to start with!+ forM_ (actions ++ map (emptyStack,) actions2) $ \(stack, act) -> do+ let local = newLocal stack shakeVerbosity+ addPool PoolStart pool $ runAction global local act $ \x -> case x of+ Left e -> raiseError =<< shakeException global stack e+ Right x -> return x+ maybe (return ()) (throwIO . snd) =<< readIORef except+ assertFinishedDatabase database + let putWhen lvl msg = when (shakeVerbosity >= lvl) $ output lvl msg -checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO ()-checkShakeExtra mp = do- let bad = [(k,t) | (k,v) <- Map.toList mp, let t = dynTypeRep v, t /= k]- case bad of- (k,t):xs -> errorStructured "Invalid Map in shakeExtra"- [("Key",Just $ show k),("Value type",Just $ show t)]- (if null xs then "" else "Plus " ++ show (length xs) ++ " other keys")- _ -> return ()+ when (null actions && null actions2) $+ putWhen Normal "Warning: No want/action statements, nothing to do" + when (isJust shakeLint) $ do+ addTiming "Lint checking"+ lintCurrentDirectory curdir "After completion"+ checkValid diagnostic database (runLint ruleinfo) =<< readIORef absent+ putWhen Loud "Lint checking succeeded"+ when (shakeReport /= []) $ do+ addTiming "Profile report"+ forM_ shakeReport $ \file -> do+ putWhen Normal $ "Writing report to " ++ file+ writeProfile file database+ when (shakeLiveFiles /= []) $ do+ addTiming "Listing live"+ diagnostic $ return "Listing live keys"+ xs <- liveFiles database+ forM_ shakeLiveFiles $ \file -> do+ putWhen Normal $ "Writing live list to " ++ file+ (if file == "-" then putStr else writeFile file) $ unlines xs -lintCurrentDirectory :: FilePath -> String -> IO ()-lintCurrentDirectory old msg = do- now <- getCurrentDirectory- when (old /= now) $ errorStructured- "Lint checking error - current directory has changed"- [("When", Just msg)- ,("Wanted",Just old)- ,("Got",Just now)]- ""+ readIORef after -withLineBuffering :: IO a -> IO a-withLineBuffering act = do- -- instead of withBuffering avoid two finally handlers and stack depth- out <- hGetBuffering stdout- err <- hGetBuffering stderr- if out == LineBuffering && err == LineBuffering then act else do- hSetBuffering stdout LineBuffering- hSetBuffering stderr LineBuffering- act `finally` do- hSetBuffering stdout out- hSetBuffering stderr err+-- | Run a set of IO actions, treated as \"after\" actions, typically returned from+-- 'Development.Shake.Database.shakeRunDatabase'. The actions will be run with diagnostics+-- etc as specified in the 'ShakeOptions'.+shakeRunAfter :: ShakeOptions -> [IO ()] -> IO ()+shakeRunAfter _ [] = return ()+shakeRunAfter opts after = withInit opts $ \ShakeOptions{..} diagnostic _ -> do+ let n = show $ length after+ diagnostic $ return $ "Running " ++ n ++ " after actions"+ (time, _) <- duration $ sequence_ $ reverse after+ when (shakeTimings && shakeVerbosity >= Normal) $+ putStrLn $ "(+ running " ++ show n ++ " after actions in " ++ showDuration time ++ ")" -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+withInit :: ShakeOptions -> (ShakeOptions -> (IO String -> IO ()) -> (Verbosity -> String -> IO ()) -> IO a) -> IO a+withInit opts act =+ withCleanup $ \cleanup -> do+ opts@ShakeOptions{..} <- usingShakeOptions cleanup opts+ (diagnostic, output) <- outputFunctions opts <$> newLock+ act opts diagnostic output --- | 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, 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- -- in unevaluated bottoms- liftIO $ mapM_ (evaluate . rnf) ks-- let tk = typeRep (Proxy :: Proxy key)- tv = typeRep (Proxy :: Proxy value)- Global{..} <- Action getRO- Local{localBlockApply} <- Action getRW- whenJust localBlockApply $ 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- _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks+usingShakeOptions :: Cleanup -> ShakeOptions -> IO ShakeOptions+usingShakeOptions cleanup opts = do+ opts@ShakeOptions{..} <- if shakeThreads opts /= 0 then return opts else do p <- getProcessorCount; return opts{shakeThreads=p}+ when shakeLineBuffering $ usingLineBuffering cleanup+ usingNumCapabilities cleanup shakeThreads+ return opts +outputFunctions :: ShakeOptions -> Lock -> (IO String -> IO (), Verbosity -> String -> IO ())+outputFunctions opts@ShakeOptions{..} outputLock = (diagnostic, output)+ where+ outputLocked v msg = withLock outputLock $ shakeOutput v msg -applyKeyValue :: [Key] -> Action [Value]-applyKeyValue [] = return []-applyKeyValue ks = do- global@Global{..} <- Action getRO- Local{localStack} <- Action getRW- (dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (BuildKey $ runKey global) localStack ks- Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}- return vs+ diagnostic | shakeVerbosity < Diagnostic = const $ return ()+ | otherwise = \act -> do v <- act; outputLocked Diagnostic $ "% " ++ v+ output v = outputLocked v . shakeAbbreviationsApply opts -runKey :: Global -> Stack -> Step -> Key -> Maybe (Result BS.ByteString) -> Bool -> Capture (Either SomeException (Bool, BS.ByteString, Result Value))-runKey global@Global{globalOptions=ShakeOptions{..},..} stack step k r dirtyChildren continue = do- let tk = typeKey k- BuiltinRule{..} <- case Map.lookup tk globalRules of- Nothing -> errorNoRuleToBuildType tk (Just $ show k) Nothing- Just r -> return r+usingProgress :: Cleanup -> ShakeOptions -> Database -> Step -> IO (Maybe String) -> IO (IO Progress)+usingProgress cleanup ShakeOptions{..} database step getFailure = do+ wait <- newBarrier+ let getProgress = do+ failure <- getFailure+ stats <- progress database step+ return stats{isFailure=failure}+ allocate cleanup+ (flip forkFinally (const $ signalBarrier wait ()) $+ shakeProgress getProgress)+ (\tid -> do+ killThread tid+ void $ timeout 1 $ waitBarrier wait)+ return getProgress - let s = newLocal stack shakeVerbosity- time <- offsetTime- runAction global s (do- res <- builtinRun k (fmap result r) dirtyChildren- liftIO $ evaluate $ rnf res- when (Just LintFSATrace == shakeLint) trackCheckUsed- Action $ fmap ((,) res) getRW) $ \x -> case x of- Left e -> do- e <- if isNothing shakeLint then return e else handle return $- do lintCurrentDirectory globalCurDir $ "Running " ++ show k; return e- continue . Left . toException =<< shakeException global (showStack stack) e- Right (RunResult{..}, Local{..})- | runChanged == ChangedNothing || runChanged == ChangedStore, Just r <- r ->- continue $ Right (runChanged == ChangedStore, runStore, r{result = runValue})- | otherwise -> do- dur <- time- let c | Just r <- r, runChanged == ChangedRecomputeSame = changed r- | otherwise = step- continue $ Right $ (,,) True runStore Result- {result = runValue- ,changed = c- ,built = step- ,depends = nubDepends $ reverse localDepends- ,execution = doubleToFloat $ dur - localDiscount- ,traces = reverse localTraces}+checkShakeExtra :: Map.HashMap TypeRep Dynamic -> IO ()+checkShakeExtra mp = do+ let bad = [(k,t) | (k,v) <- Map.toList mp, let t = dynTypeRep v, t /= k]+ case bad of+ (k,t):xs -> throwIO $ errorStructured "Invalid Map in shakeExtra"+ [("Key",Just $ show k),("Value type",Just $ show t)]+ (if null xs then "" else "Plus " ++ show (length xs) ++ " other keys")+ _ -> return () runLint :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)@@ -260,208 +223,130 @@ Just BuiltinRule{..} -> builtinLint k v --- | Turn a normal exception into a ShakeException, giving it a stack and printing it out if in staunch mode.--- If the exception is already a ShakeException (e.g. it's a child of ours who failed and we are rethrowing)--- then do nothing with it.-shakeException :: Global -> [String] -> SomeException -> IO ShakeException-shakeException Global{globalOptions=ShakeOptions{..},..} stk e@(SomeException inner) = case cast inner of- Just e@ShakeException{} -> return e- Nothing -> do- e <- return $ ShakeException (last $ "Unknown call stack" : stk) stk e- when (shakeStaunch && shakeVerbosity >= Quiet) $- globalOutput Quiet $ show e ++ "Continuing due to staunch mode"- return e+assertFinishedDatabase :: Database -> IO ()+assertFinishedDatabase Database{..} = do+ -- if you have anyone Waiting, and are not exiting with an error, then must have a complex recursion (see #400)+ status <- Ids.elems status+ let bad = [key | (key, Running{}) <- status]+ when (bad /= []) $+ throwM $ errorComplexRecursion (map show bad) --- | 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, Typeable value) => key -> Action value-apply1 = fmap head . apply . return+liveFilesState :: RunState -> IO [FilePath]+liveFilesState RunState{..} = do+ database <- readVar databaseVar+ liveFiles database +liveFiles :: Database -> IO [FilePath]+liveFiles database = do+ status <- Ids.elems $ status database+ let specialIsFileKey t = show (fst $ splitTyConApp t) == "FileQ"+ return [show k | (k, Ready{}) <- status, specialIsFileKey $ typeKey k] ------------------------------------------------------------------------- RESOURCES+errorsState :: RunState -> IO [(String, SomeException)]+errorsState RunState{..} = do+ database <- readVar databaseVar+ status <- Ids.elems $ status database+ return [(show k, e) | (k, Error e _) <- status] --- | Run an action which uses part of a finite resource. For more details see 'Resource'.--- You cannot depend on a rule (e.g. 'need') while a resource is held.-withResource :: Resource -> Int -> Action a -> Action a-withResource r i act = do- Global{..} <- Action getRO- liftIO $ globalDiagnostic $ return $ show r ++ " waiting to acquire " ++ show i- offset <- liftIO offsetTime- Action $ captureRAW $ \continue -> acquireResource r globalPool i $ continue $ Right ()- res <- Action $ tryRAW $ fromAction $ blockApply ("Within withResource using " ++ show r) $ do- offset <- liftIO offset- liftIO $ globalDiagnostic $ return $ show r ++ " acquired " ++ show i ++ " in " ++ showDuration offset- Action $ modifyRW $ \s -> s{localDiscount = localDiscount s + offset}- act- liftIO $ releaseResource r globalPool i- liftIO $ globalDiagnostic $ return $ show r ++ " released " ++ show i- Action $ either throwRAW return res +checkValid :: (IO String -> IO ()) -> Database -> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO ()+checkValid diagnostic Database{..} check missing = do+ status <- Ids.elems status+ intern <- readIORef intern+ diagnostic $ return "Starting validity/lint checking" --- | 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 :: 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- res <- liftIO $ testFence bar- (res,offset) <- case res of- Just res -> return (res, 0)- Nothing -> do- Global{..} <- Action getRO- offset <- liftIO offsetTime- Action $ captureRAW $ \k -> waitFence bar $ \v ->- addPoolResume globalPool $ do offset <- liftIO offset; k $ Right (v,offset)- case res of- Left err -> Action $ throwRAW err- Right (deps,v) -> do- Action $ modifyRW $ \s -> s{localDepends = deps ++ localDepends s, localDiscount = localDiscount s + offset}- return v- Nothing -> do- bar <- newFence- return $ (,) (Map.insert key bar mp) $ do- Local{localDepends=pre} <- Action getRW- res <- Action $ tryRAW $ fromAction $ act key- case res of- Left err -> do- liftIO $ signalFence bar $ Left err- Action $ throwRAW err- Right v -> do- Local{localDepends=post} <- Action getRW- let deps = take (length post - length pre) post- liftIO $ signalFence bar $ Right (deps, v)- return v+ -- Do not use a forM here as you use too much stack space+ bad <- (\f -> foldM f [] status) $ \seen v -> case v of+ (key, Ready Result{..}) -> do+ good <- check key $ fst result+ diagnostic $ return $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if isNothing good then "passed" else "FAILED"+ return $ [(key, result, now) | Just now <- [good]] ++ seen+ _ -> return seen+ unless (null bad) $ do+ let n = length bad+ throwM $ errorStructured+ ("Lint checking error - " ++ (if n == 1 then "value has" else show n ++ " values have") ++ " changed since being depended upon")+ (intercalate [("",Just "")] [ [("Key", Just $ show key),("Old", Just $ show result),("New", Just now)]+ | (key, result, now) <- bad])+ "" + bad <- return [(parent,key) | (parent, key) <- missing, isJust $ Intern.lookup key intern]+ unless (null bad) $ do+ let n = length bad+ throwM $ errorStructured+ ("Lint checking error - " ++ (if n == 1 then "value" else show n ++ " values") ++ " did not have " ++ (if n == 1 then "its" else "their") ++ " creation tracked")+ (intercalate [("",Just "")] [ [("Rule", Just $ show parent), ("Created", Just $ show key)] | (parent,key) <- bad])+ "" --- | Run an action without counting to the thread limit, typically used for actions that execute--- on remote machines using barely any local CPU resources.--- Unsafe as it allows the 'shakeThreads' limit to be exceeded.--- You cannot depend on a rule (e.g. 'need') while the extra thread is executing.--- If the rule blocks (e.g. calls 'withResource') then the extra thread may be used by some other action.--- Only really suitable for calling 'cmd' / 'command'.-unsafeExtraThread :: Action a -> Action a-unsafeExtraThread act = Action $ do- Global{..} <- getRO- stop <- liftIO $ increasePool globalPool- res <- tryRAW $ fromAction $ blockApply "Within unsafeExtraThread" act- liftIO stop- captureRAW $ \continue -> (if isLeft res then addPoolException else addPoolResume) globalPool $ continue res+ diagnostic $ return "Validity/lint check passed" --- | 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- global@Global{..} <- getRO- local <- getRW- -- number of items still to complete, or Nothing for has completed (by either failure or completion)- todo :: Var (Maybe Int) <- liftIO $ newVar $ Just $ length acts- -- a list of refs where the results go- results :: [IORef (Maybe (Either SomeException (Local, a)))] <- liftIO $ replicateM (length acts) $ newIORef Nothing+---------------------------------------------------------------------+-- STORAGE - (locals, results) <- captureRAW $ \continue -> do- let resume = do- res <- liftIO $ sequence . catMaybes <$> mapM readIORef results- continue $ fmap unzip res+usingDatabase :: Cleanup -> ShakeOptions -> (IO String -> IO ()) -> Map.HashMap TypeRep BuiltinRule -> IO Database+usingDatabase cleanup opts diagnostic owitness = do+ let step = (typeRep (Proxy :: Proxy StepKey), (Ver 0, BinaryOp (const mempty) (const stepKey)))+ witness <- return $ Map.fromList+ [ (QTypeRep t, (version, BinaryOp (putDatabase putOp) (getDatabase getOp)))+ | (t,(version, BinaryOp{..})) <- step : Map.toList (Map.map (\BuiltinRule{..} -> (builtinVersion, builtinKey)) owitness)]+ (status, journal) <- usingStorage cleanup opts diagnostic witness+ journal <- return $ \i k v -> journal (QTypeRep $ typeKey k) i (k, Loaded v) - liftIO $ forM_ (zip acts results) $ \(act, result) -> do- let act2 = do- whenM (liftIO $ isNothing <$> readVar todo) $- fail "parallel, one has already failed"- res <- act- old <- Action getRW- return (old, res)- 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+ xs <- Ids.toList status+ intern <- newIORef $ Intern.fromList [(k, i) | (i, (k,_)) <- xs]+ return Database{..} - modifyRW $ \root -> localMergeMutable root locals- return results +incrementStep :: Database -> IO Step+incrementStep Database{..} = do+ is <- readIORef intern+ stepId <- case Intern.lookup stepKey is of+ Just stepId -> return stepId+ Nothing -> do+ (is, stepId) <- return $ Intern.add stepKey is+ writeIORef intern is+ return stepId+ step <- do+ v <- Ids.lookup status stepId+ return $ case v of+ Just (_, Loaded r) -> incStep $ fromStepResult r+ _ -> Step 1+ let stepRes = toStepResult step+ Ids.insert status stepId (stepKey, Ready stepRes)+ journal stepId stepKey $ fmap snd stepRes+ return step --- | Run an action but do not depend on anything the action uses.--- A more general version of 'orderOnly'.-orderOnlyAction :: Action a -> Action a-orderOnlyAction act = Action $ do- Local{localDepends=pre} <- getRW- res <- fromAction act- modifyRW $ \s -> s{localDepends=pre}- return res +loadSharedCloud :: Var a -> ShakeOptions -> Map.HashMap TypeRep BuiltinRule -> IO (Maybe Shared, Maybe Cloud)+loadSharedCloud var opts owitness = do+ let mp = Map.fromList $ map (first $ show . QTypeRep) $ Map.toList owitness+ let wit = binaryOpMap $ \a -> maybe (error $ "loadSharedCloud, couldn't find map for " ++ show a) builtinKey $ Map.lookup a mp+ let wit2 = BinaryOp (\k -> putOp wit (show $ QTypeRep $ typeKey k, k)) (snd . getOp wit)+ let keyVers = [(k, builtinVersion v) | (k,v) <- Map.toList owitness]+ let ver = makeVer $ shakeVersion opts --- | 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 ()+ shared <- case shakeShare opts of+ Nothing -> return Nothing+ Just x -> Just <$> newShared wit2 ver x+ cloud <- case newCloud (runLocked var . const) (Map.map builtinKey owitness) ver keyVers $ shakeCloud opts of+ _ | null $ shakeCloud opts -> return Nothing+ Nothing -> fail "shakeCloud set but Shake not compiled for cloud operation"+ Just res -> Just <$> res+ return (shared, cloud) - 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++putDatabase :: (Key -> Builder) -> ((Key, Status) -> Builder)+putDatabase putKey (key, Loaded (Result x1 x2 x3 x4 x5 x6)) =+ putExN (putKey key) <> putExN (putEx x1) <> putEx x2 <> putEx x3 <> putEx x5 <> putExN (putEx x4) <> putEx x6+putDatabase _ (_, x) = throwImpure $ errorInternal $ "putWith, Cannot write Status with constructor " ++ statusType x+++getDatabase :: (BS.ByteString -> Key) -> BS.ByteString -> (Key, Status)+getDatabase getKey bs+ | (key, bs) <- getExN bs+ , (x1, bs) <- getExN bs+ , (x2, x3, x5, bs) <- binarySplit3 bs+ , (x4, x6) <- getExN bs+ = (getKey key, Loaded (Result x1 x2 x3 (getEx x4) x5 (getEx x6)))
src/Development/Shake/Internal/Core/Storage.hs view
@@ -1,19 +1,21 @@ {-# LANGUAGE ScopedTypeVariables, RecordWildCards, FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving #-} {- This module stores the meta-data so its very important its always accurate We can't rely on getting any exceptions or termination at the end, so we'd better write out a journal-We store a series of records, and if they contain twice as many records as needed, we compress+We store a series of records, and if they contain twice as many records as needed, we compact -} module Development.Shake.Internal.Core.Storage(- withStorage+ usingStorage ) where import General.Chunks+import General.Cleanup import General.Binary import General.Intern import Development.Shake.Internal.Options+import Development.Shake.Internal.Errors import General.Timing import General.FileLock import qualified General.Ids as Ids@@ -25,6 +27,7 @@ import Data.Time import Data.Char import Data.Word+import System.Info import Development.Shake.Classes import Numeric import General.Extra@@ -46,26 +49,65 @@ -- THINGS I WANT TO DO ON THE NEXT CHANGE -- * Change filepaths to store a 1 byte prefix saying 8bit ASCII or UTF8 -- * Duration and Time should be stored as number of 1/10000th seconds Int32-databaseVersion x = "SHAKE-DATABASE-13-" ++ s ++ "\r\n"+databaseVersion x = "SHAKE-DATABASE-14-" ++ os ++ "-" ++ arch ++ "-" ++ s ++ "\r\n" where s = tail $ init $ show x -- call show, then take off the leading/trailing quotes -- ensures we do not get \r or \n in the user portion +messageCorrupt :: FilePath -> SomeException -> IO [String]+messageCorrupt dbfile err = do+ msg <- showException err+ return $+ ("Error when reading Shake database " ++ dbfile) :+ map (" "++) (lines msg) +++ ["All files will be rebuilt"]+++messageDatabaseVersionChange :: FilePath -> BS.ByteString -> BS.ByteString -> [String]+messageDatabaseVersionChange dbfile old new =+ ["Shake database version changed (either shake library version, or shakeVersion):"+ ," File: " ++ dbfile+ ," Old version: " ++ disp (limit $ BS.unpack old)+ ," New version: " ++ disp (BS.unpack new)+ ,"All rules will be rebuilt"]+ where+ limit x = let (a,b) = splitAt 200 x in a ++ (if null b then "" else "...")+ disp = map (\x -> if isPrint x && isAscii x then x else '?') . takeWhile (`notElem` "\r\n")+++messageMissingTypes :: FilePath -> [String] -> [String]+messageMissingTypes dbfile types =+ ["Shake database rules have changed for the following types:"+ ," File: " ++ dbfile] +++ [" Type: " ++ x | x <- types] +++ ["All rules using these types will be rebuilt"]++ -- | Storage of heterogeneous things. In the particular case of Shake,--- k ~ TypeRep, v ~ (Key, Status{Value}).+-- k ~ QTypeRep, v ~ (Key, Status{Value}). -- -- The storage starts with a witness table saying what can be contained.--- If any entries in the witness table don't have a current Witness then a fake+-- If any entries in the witness table don't have a current Witness then a fake -- error witness is manufactured. If the witness ever changes the entire DB is -- rewritten.-withStorage+usingStorage :: (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- -> (Ids.Ids v -> (k -> Id -> v -> IO ()) -> IO a) -- ^ Execute- -> IO a-withStorage ShakeOptions{..} diagnostic witness act = withLockFileDiagnostic diagnostic (shakeFiles </> ".shake.lock") $ do+ => Cleanup+ -> ShakeOptions -- ^ Storage options+ -> (IO String -> IO ()) -- ^ Logging function+ -> Map.HashMap k (Ver, BinaryOp v) -- ^ Witnesses+ -> IO (Ids.Ids v, k -> Id -> v -> IO ())+usingStorage _ ShakeOptions{..} diagnostic _ | shakeFiles == "/dev/null" = do+ diagnostic $ return "Using in-memory database"+ ids <- Ids.empty+ return (ids, \_ _ _ -> return ())++usingStorage cleanup ShakeOptions{..} diagnostic witness = do+ let lockFile = shakeFiles </> ".shake.lock"+ diagnostic $ return $ "Before usingLockFile on " ++ lockFile+ usingLockFile cleanup lockFile+ diagnostic $ return "After usingLockFile"+ let dbfile = shakeFiles </> ".shake.database" createDirectoryRecursive shakeFiles @@ -75,140 +117,139 @@ diagnostic $ return "Backup file move to original" addTiming "Database read"- withChunks dbfile shakeFlush $ \h -> do+ h <- usingChunks cleanup dbfile shakeFlush+ let corrupt+ | not shakeStorageLog = resetChunksCorrupt Nothing h+ | otherwise = do+ let file = dbfile <.> "corrupt"+ resetChunksCorrupt (Just file) h+ unexpected $ "Backup of corrupted file stored at " ++ file ++ "\n" - let corrupt- | not shakeStorageLog = resetChunksCorrupt Nothing h- | otherwise = do- let file = dbfile <.> "corrupt"- resetChunksCorrupt (Just file) h- unexpected $ "Backup of corrupted file stored at " ++ file ++ "\n"+ -- check the version information matches+ let ver = BS.pack $ databaseVersion shakeVersion+ oldVer <- readChunkMax h $ fromIntegral $ BS.length ver + 100000+ let verEq = Right ver == oldVer+ when (not shakeVersionIgnore && not verEq && oldVer /= Left BS.empty) $ do+ outputErr $ messageDatabaseVersionChange dbfile (fromEither oldVer) ver+ corrupt - -- check the version information matches- let ver = BS.pack $ databaseVersion shakeVersion- oldVer <- readChunkMax h $ fromIntegral $ BS.length ver + 100000- let verEq = Right ver == oldVer- when (not shakeVersionIgnore && not verEq && oldVer /= Left BS.empty) $ do- let limit x = let (a,b) = splitAt 200 x in a ++ (if null b then "" else "...")- let disp = map (\x -> if isPrint x && isAscii x then x else '?') . takeWhile (`notElem` "\r\n")- outputErr $ unlines- ["Error when reading Shake database - invalid version stamp detected:"- ," File: " ++ dbfile- ," Expected: " ++ disp (BS.unpack ver)- ," Found: " ++ disp (limit $ BS.unpack $ fromEither oldVer)- ,"All rules will be rebuilt"]+ (!witnessNew, !save) <- evaluate $ saveWitness witness+ witnessOld <- readChunk h+ ids <- case witnessOld of+ Left _ -> do+ resetChunksCorrupt Nothing h+ return Nothing+ Right witnessOld -> handleBool (not . isAsyncException) (\err -> do+ outputErr =<< messageCorrupt dbfile err corrupt-- let (witnessNew, save) = putWitness witness- evaluate save- witnessOld <- readChunk h- ids <- case witnessOld of- Left _ -> do- resetChunksCorrupt Nothing h- return Nothing- Right witnessOld -> handleBool (not . isAsyncException) (\err -> do- msg <- showException err- outputErr $ unlines $- ("Error when reading Shake database " ++ dbfile) :- map (" "++) (lines msg) ++- ["All files will be rebuilt"]- corrupt- return Nothing) $ do+ return Nothing) $ do - let load = getWitness witnessOld witness- evaluate load- ids <- Ids.empty- let go !i = do- v <- readChunk h- case v of- Left e -> do- let slop = fromIntegral $ BS.length e- when (slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n"- diagnostic $ return $ "Read " ++ show i ++ " chunks, plus " ++ show slop ++ " slop"- 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- [['0' | length c == 1] ++ c | x <- BS8.unpack bs, let c = showHex x ""]- let pretty (Left x) = "FAILURE: " ++ show x- pretty (Right x) = x- x2 <- try_ $ evaluate $ let s = show v in rnf s `seq` s- return $ "Chunk " ++ show i ++ " " ++ raw bs ++ " " ++ show id ++ " = " ++ pretty x2- go $ i+1- countItems <- go 0- countDistinct <- Ids.sizeUpperBound ids- diagnostic $ return $ "Found at most " ++ show countDistinct ++ " distinct entries out of " ++ show countItems+ (!missing, !load) <- evaluate $ loadWitness witness witnessOld+ when (missing /= []) $ outputErr $ messageMissingTypes dbfile missing+ ids <- Ids.empty+ let raw bs = "[len " ++ show (BS.length bs) ++ "] " ++ concat+ [['0' | length c == 1] ++ c | x <- BS8.unpack bs, let c = showHex x ""]+ let go !i = do+ v <- readChunk h+ case v of+ Left e -> do+ let slop = fromIntegral $ BS.length e+ when (slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n"+ diagnostic $ return $ "Read " ++ show i ++ " chunks, plus " ++ show slop ++ " slop"+ return i+ Right bs | (id, Just (k,v)) <- load bs -> do+ evaluate $ rnf k+ evaluate $ rnf v+ Ids.insert ids id (k,v)+ diagnostic $ do+ let pretty (Left x) = "FAILURE: " ++ show x+ pretty (Right x) = x+ x2 <- try_ $ evaluate $ let s = show v in rnf s `seq` s+ return $ "Chunk " ++ show i ++ " " ++ raw bs ++ " " ++ show id ++ " = " ++ pretty x2+ go $ i+1+ Right bs -> do+ diagnostic $ return $ "Chunk " ++ show i ++ " " ++ raw bs ++ " UNKNOWN WITNESS"+ go i+ countItems <- go 0+ countDistinct <- Ids.sizeUpperBound ids+ diagnostic $ return $ "Found at most " ++ show countDistinct ++ " distinct entries out of " ++ show countItems - when (countItems > countDistinct*2 || not verEq || witnessOld /= witnessNew) $ do- addTiming "Database compression"- resetChunksCompact h $ \out -> do- out $ putEx ver- out $ putEx witnessNew- Ids.forWithKeyM_ ids $ \i (k,v) -> out $ save k i v- Just <$> Ids.for ids snd+ when (countItems > countDistinct*2 || not verEq || witnessOld /= witnessNew) $ do+ addTiming "Database compression"+ resetChunksCompact h $ \out -> do+ out $ putEx ver+ out $ putEx witnessNew+ Ids.forWithKeyM_ ids $ \i (k,v) -> out $ save k i v+ Just <$> Ids.forCopy ids snd - ids <- case ids of- Just ids -> return ids- Nothing -> do- writeChunk h $ putEx ver- writeChunk h $ putEx witnessNew- Ids.empty+ ids <- case ids of+ Just ids -> return ids+ Nothing -> do+ writeChunk h $ putEx ver+ writeChunk h $ putEx witnessNew+ Ids.empty - addTiming "With database"- writeChunks h $ \out ->- act ids $ \k i v ->- out $ save k i v+ addTiming "With database"+ out <- usingWriteChunks cleanup h+ return (ids, \k i v -> out $ save k i v) where unexpected x = when shakeStorageLog $ do t <- getCurrentTime appendFile (shakeFiles </> ".shake.storage.log") $ "\n[" ++ show t ++ "]: " ++ trimEnd x ++ "\n" outputErr x = do- when (shakeVerbosity >= Quiet) $ shakeOutput Quiet x- unexpected x+ when (shakeVerbosity >= Quiet) $ shakeOutput Quiet $ unlines x+ unexpected $ unlines x -keyName :: Show k => k -> BS.ByteString-keyName = UTF8.fromString . show+-- | A list oft witnesses, saved+type Witnesses = BS.ByteString +-- | The version and key, serialised+newtype Witness = Witness BS.ByteString+ deriving (Eq, Hashable, Ord) -getWitness :: Show k => BS.ByteString -> Map.HashMap k (BinaryOp v) -> (BS.ByteString -> (k, Id, v))-getWitness bs mp- | length ws > limit || Map.size mp > limit = error "Number of distinct witness types exceeds limit"- | otherwise = ind `seq` mp2 `seq` \bs ->- let (k :: Word16,bs2) = binarySplit bs- in case ind (fromIntegral k) of- Nothing -> error $ "Witness type out of bounds, " ++ show k- Just f -> f bs2+toWitness :: Show k => Ver -> k -> Witness+toWitness (Ver v) k = Witness $ UTF8.fromString (show k ++ (if v == 0 then "" else ", v" ++ show v))++instance BinaryEx [Witness] where+ putEx xs = putEx [x | Witness x <- xs]+ getEx = map Witness . getEx+++-- | Given the current witness table, and the serialised one from last time, return+-- (witnesses that got removed, way to deserialise an entry into an Id, and (if the witness remains) the key and value)+loadWitness :: forall k v . Show k => Map.HashMap k (Ver, BinaryOp v) -> Witnesses -> ([String], BS.ByteString -> (Id, Maybe (k, v)))+loadWitness mp bs = (,) missing $ seq ind $ \bs ->+ let (wInd :: Word16, i :: Id, bs2) = binarySplit2 bs+ in case ind (fromIntegral wInd) of+ Nothing -> throwImpure $ errorInternal $ "Witness index out of bounds, " ++ show wInd+ Just f -> (i, f bs2) where- limit = fromIntegral (maxBound :: Word16)- ws :: [BS.ByteString] = getEx bs- mp2 = Map.fromList [(keyName k, (k, v)) | (k,v) <- Map.toList mp]- ind = fastAt [ case Map.lookup w mp2 of- Nothing -> error $ "Witness type has disappeared, " ++ UTF8.toString w- Just (k, BinaryOp{..}) -> \bs ->- let (i, bs2) = binarySplit bs- v = getOp bs2- in (k, i, v)- | w <- ws]+ ws :: [Witness] = getEx bs+ missing = [UTF8.toString w | (i, Witness w) <- zipFrom 0 ws, isNothing $ fromJust (ind i) BS.empty] + mp2 :: Map.HashMap Witness (k, BinaryOp v) = Map.fromList [(toWitness ver k, (k, bin)) | (k,(ver,bin)) <- Map.toList mp] -putWitness :: (Eq k, Hashable k, Show k) => Map.HashMap k (BinaryOp v) -> (BS.ByteString, k -> Id -> v -> Builder)-putWitness mp = (runBuilder $ putEx (ws :: [BS.ByteString]), mp2 `seq` \k -> fromMaybe (error $ "Don't know how to save, " ++ show k) $ Map.lookup k mp2)+ ind :: (Int -> Maybe (BS.ByteString -> Maybe (k, v))) = seq mp2 $ fastAt $ flip map ws $ \w ->+ case Map.lookup w mp2 of+ Nothing -> const Nothing+ Just (k, BinaryOp{..}) -> \bs -> Just (k, getOp bs)+++saveWitness :: forall k v . (Eq k, Hashable k, Show k) => Map.HashMap k (Ver, BinaryOp v) -> (Witnesses, k -> Id -> v -> Builder)+saveWitness mp+ | Map.size mp > fromIntegral (maxBound :: Word16) = throwImpure $ errorInternal $ "Number of distinct witness types exceeds limit, got " ++ show (Map.size mp)+ | otherwise = (runBuilder $ putEx ws+ ,mpSave `seq` \k -> fromMaybe (throwImpure $ errorInternal $ "Don't know how to save, " ++ show k) $ Map.lookup k mpSave) where- ws = sort $ map keyName $ Map.keys mp- wsMp = Map.fromList $ zip ws [0 :: Word16 ..]- mp2 = Map.mapWithKey (\k BinaryOp{..} -> let tag = putEx $ wsMp Map.! keyName k in \(Id w) v -> tag <> putEx w <> putOp v) mp+ -- the entries in the witness table (in a stable order, to make it more likely to get a good equality)+ ws :: [Witness] = sort $ map (\(k,(ver,_)) -> toWitness ver k) $ Map.toList mp + -- an index for each of the witness entries+ wsIndex :: Map.HashMap Witness Word16 = Map.fromList $ zip ws [0 :: Word16 ..] -withLockFileDiagnostic :: (IO String -> IO ()) -> FilePath -> IO a -> IO a-withLockFileDiagnostic diagnostic file act = do- diagnostic $ return $ "Before withLockFile on " ++ file- res <- withLockFile file $ do- diagnostic $ return "Inside withLockFile"- act- diagnostic $ return "After withLockFile"- return res+ -- the save functions+ mpSave :: Map.HashMap k (Id -> v -> Builder) = flip Map.mapWithKey mp $+ \k (ver,BinaryOp{..}) ->+ let tag = putEx $ wsIndex Map.! toWitness ver k+ in \(Id w) v -> tag <> putEx w <> putOp v
src/Development/Shake/Internal/Core/Types.hs view
@@ -1,29 +1,52 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards #-}+{-# LANGUAGE ExistentialQuantification, DeriveFunctor, RecordWildCards, FlexibleInstances #-} module Development.Shake.Internal.Core.Types(- BuiltinRun, BuiltinLint, RunResult(..), RunChanged(..),- UserRule(..), UserRule_(..),- BuiltinRule(..), Global(..), Local(..), Action(..),- newLocal, localClearMutable, localMergeMutable+ BuiltinRun, BuiltinLint, BuiltinIdentity,+ RunMode(..), RunResult(..), RunChanged(..),+ UserRule(..), UserRuleVersioned(..),+ BuiltinRule(..), Global(..), Local(..), Action(..), runAction, addDiscount,+ newLocal, localClearMutable, localMergeMutable,+ Stack, Step(..), Result(..), Database(..), Depends(..), Status(..), Trace(..), BS_Store,+ getResult, exceptionStack, statusType, addStack, addCallStack,+ incStep, newTrace, nubDepends, emptyStack, topStack, showTopStack,+ stepKey, StepKey(..), toStepResult, fromStepResult, NoShow(..) ) where -import Control.DeepSeq import Control.Monad.IO.Class import Control.Applicative+import Control.DeepSeq+import Foreign.Storable+import Data.Word import Data.Typeable import General.Binary-import qualified Data.HashMap.Strict as Map+import Control.Exception+import Data.Maybe+import General.Extra+import Control.Concurrent.Extra+import Development.Shake.Internal.History.Shared+import Development.Shake.Internal.History.Cloud+import Development.Shake.Internal.History.Types+import General.Wait+import Development.Shake.Internal.Errors+import qualified General.TypeMap as TMap import Data.IORef-import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS+import Numeric.Extra import System.Time.Extra+import General.Intern(Id, Intern)+import qualified Data.HashSet as Set+import qualified Data.HashMap.Strict as Map+import qualified General.Ids as Ids+import Data.Tuple.Extra -import Development.Shake.Internal.Core.Pool-import Development.Shake.Internal.Core.Database+import General.Pool import Development.Shake.Internal.Core.Monad import Development.Shake.Internal.Value import Development.Shake.Internal.Options+import Development.Shake.Classes+import Data.Semigroup import General.Cleanup import Prelude @@ -39,16 +62,31 @@ -- 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, Semigroup, Monoid #if __GLASGOW_HASKELL__ >= 800 ,MonadFail #endif ) --- | How has a rule changed.+runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)+runAction g l (Action x) = runRAW g l x+++---------------------------------------------------------------------+-- PUBLIC TYPES++-- | What mode a rule is running in, passed as an argument to 'BuiltinRun'.+data RunMode+ = RunDependenciesSame -- ^ My dependencies have not changed.+ | RunDependenciesChanged -- ^ At least one of my dependencies from last time have changed, or I have no recorded dependencies.+ deriving (Eq,Show)++instance NFData RunMode where rnf x = x `seq` ()++-- | How the output of a rule has changed. data RunChanged = ChangedNothing -- ^ Nothing has changed.- | ChangedStore -- ^ The persisted value has changed, but in a way that should be considered identical.+ | ChangedStore -- ^ The stored value has changed, but in a way that should be considered identical (used rarely). | ChangedRecomputeSame -- ^ I recomputed the value and it was the same. | ChangedRecomputeDiff -- ^ I recomputed the value and it was different. deriving (Eq,Show)@@ -59,32 +97,214 @@ -- | The result of 'BuiltinRun'. data RunResult value = RunResult {runChanged :: RunChanged- -- ^ What has changed from the previous time.+ -- ^ How has the 'RunResult' changed from what happened last time. ,runStore :: BS.ByteString- -- ^ Return the new value to store. Often a serialised version of 'runValue'.+ -- ^ The value to store in the Shake database. ,runValue :: value- -- ^ Return the produced value.+ -- ^ The value to return from 'Development.Shake.Rule.apply'. } deriving Functor instance NFData value => NFData (RunResult value) where rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3 --- | Define a rule between @key@ and @value@. A rule for a class of artifacts (e.g. /files/) provides:++---------------------------------------------------------------------+-- UTILITY TYPES++newtype Step = Step Word32 deriving (Eq,Ord,Show,Storable,BinaryEx,NFData,Hashable,Typeable)++incStep (Step i) = Step $ i + 1+++-- To simplify journaling etc we smuggle the Step in the database, with a special StepKey+newtype StepKey = StepKey ()+ deriving (Show,Eq,Typeable,Hashable,Binary,BinaryEx,NFData)++stepKey :: Key+stepKey = newKey $ StepKey ()++toStepResult :: Step -> Result (Value, BS_Store)+toStepResult i = Result (newValue i, runBuilder $ putEx i) i i [] 0 []++fromStepResult :: Result BS_Store -> Step+fromStepResult = getEx . result++++---------------------------------------------------------------------+-- CALL STACK++-- Invariant: Every key must have its Id in the set+data Stack = Stack (Maybe Key) [Either Key [String]] !(Set.HashSet Id) deriving Show++exceptionStack :: Stack -> SomeException -> ShakeException+exceptionStack stack@(Stack _ xs _) = ShakeException (showTopStack stack) $+ concatMap f (reverse xs) ++ ["* Raised the exception:" | not $ null xs]+ where+ f (Left x) = ["* Depends on: " ++ show x]+ f (Right x) = map (" at " ++) x+++showTopStack :: Stack -> String+showTopStack = maybe "<unknown>" show . topStack++addStack :: Id -> Key -> Stack -> Either SomeException Stack+addStack i k (Stack _ ks is)+ | i `Set.member` is = Left $ toException $ exceptionStack stack2 $ errorRuleRecursion (typeKey k) (show k)+ | otherwise = Right stack2+ where stack2 = Stack (Just k) (Left k:ks) (Set.insert i is)++addCallStack :: [String] -> Stack -> Stack+-- use group/head to squash adjacent duplicates, e.g. a want does an action and a need, both of which get the same location+addCallStack xs (Stack t a b) = Stack t (Right xs : dropWhile (== Right xs) a) b++topStack :: Stack -> Maybe Key+topStack (Stack t _ _) = t++emptyStack :: Stack+emptyStack = Stack Nothing [] Set.empty+++---------------------------------------------------------------------+-- TRACE++data Trace = Trace+ {traceMessage :: {-# UNPACK #-} !BS.ByteString+ ,traceStart :: {-# UNPACK #-} !Float+ ,traceEnd :: {-# UNPACK #-} !Float+ }+ deriving Show++instance NFData Trace where+ rnf x = x `seq` () -- all strict atomic fields++instance BinaryEx Trace where+ putEx (Trace a b c) = putEx b <> putEx c <> putEx a+ getEx x | (b,c,a) <- binarySplit2 x = Trace a b c++instance BinaryEx [Trace] where+ putEx = putExList . map putEx+ getEx = map getEx . getExList++newTrace :: String -> Seconds -> Seconds -> Trace+newTrace msg start stop = Trace (BS.pack msg) (doubleToFloat start) (doubleToFloat stop)+++---------------------------------------------------------------------+-- CENTRAL TYPES++newtype NoShow a = NoShow a+instance Show (NoShow a) where show _ = "NoShow"++-- Things stored under OneShot are not required if we only do one compilation,+-- but are if we do multiple, as we have to reset the database each time.+-- globalOneShot controls that, and gives us a small memory optimisation.+type OneShot a = a++data Status+ = Ready (Result (Value, OneShot BS_Store)) -- ^ I have a value+ | Error SomeException (OneShot (Maybe (Result BS_Store))) -- ^ I have been run and raised an error+ | Loaded (Result BS_Store) -- ^ Loaded from the database+ | Running (NoShow (Either SomeException (Result (Value, BS_Store)) -> Locked ())) (Maybe (Result BS_Store)) -- ^ Currently in the process of being checked or built+ | 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 (\(a,b) -> b `seq` rnf a) x+ Error x y -> rnfException x `seq` maybe () (rnfResult id) y+ Loaded x -> rnfResult id x+ Running _ x -> maybe () (rnfResult id) x -- Can't RNF a waiting, but also unnecessary+ Missing -> ()+ where+ -- best we can do for an arbitrary exception+ rnfException = rnf . show++ -- 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+ ,changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid+ ,depends :: [Depends] -- ^ dependencies (don't run them early)+ ,execution :: {-# UNPACK #-} !Float -- ^ how long it took when it was last run (seconds)+ ,traces :: [Trace] -- ^ a trace of the expensive operations (start/end in seconds since beginning of run)+ } deriving (Show,Functor)++statusType Ready{} = "Ready"+statusType Error{} = "Error"+statusType Loaded{} = "Loaded"+statusType Running{} = "Running"+statusType Missing{} = "Missing"+++getResult :: Status -> Maybe (Result (Either BS_Store Value))+getResult (Ready r) = Just $ Right . fst <$> r+getResult (Loaded r) = Just $ Left <$> r+getResult (Running _ r) = fmap Left <$> r+getResult _ = Nothing+++---------------------------------------------------------------------+-- OPERATIONS++newtype Depends = Depends {fromDepends :: [Id]}+ deriving NFData++instance Show Depends where+ -- Appears in diagnostic output and the Depends ctor is just verbose+ show = show . fromDepends++instance BinaryEx Depends where+ putEx (Depends xs) = putExStorableList xs+ getEx = Depends . getExStorableList++instance BinaryEx [Depends] where+ putEx = putExList . map putEx+ getEx = map getEx . getExList++-- | Afterwards each Id must occur at most once and there are no empty Depends+nubDepends :: [Depends] -> [Depends]+nubDepends = fMany Set.empty+ where+ fMany _ [] = []+ 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+++-- | Define a rule between @key@ and @value@. As an example, a typical 'BuiltinRun' will look like: ----- * How to identify individual artifacts, given by the @key@ type, e.g. with file names.+-- > run key oldStore mode = do+-- > ...+-- > return $ RunResult change newStore newValue ----- * How to describe the state of an artifact, given by the @value@ type, e.g. the file modification time.+-- Where you have: ----- * How to persist the state of an artifact, using the 'ByteString' values, e.g. seralised @value@.+-- * @key@, how to identify individual artifacts, e.g. with file names. ----- The arguments comprise the @key@, the value of the previous serialisation or 'Nothing' if the rule--- has not been run previously, and 'True' to indicate the dependencies have changed or 'False' that--- they have not.+-- * @oldStore@, the value stored in the database previously, e.g. the file modification time.+--+-- * @mode@, either 'RunDependenciesSame' (none of your dependencies changed, you can probably not rebuild) or+-- 'RunDependenciesChanged' (your dependencies changed, probably rebuild).+--+-- * @change@, usually one of either 'ChangedNothing' (no work was required) or 'ChangedRecomputeDiff'+-- (I reran the rule and it should be considered different).+--+-- * @newStore@, the new value to store in the database, which will be passed in next time as @oldStore@.+--+-- * @newValue@, the result that 'Development.Shake.Rule.apply' will return when asked for the given @key@. type BuiltinRun key value = key -> Maybe BS.ByteString- -> Bool+ -> RunMode -> Action (RunResult value) -- | The action performed by @--lint@ for a given @key@/@value@ pair.@@ -92,19 +312,29 @@ -- passing the @value@ it produced. Return 'Nothing' to indicate the value has not changed and -- is acceptable, or 'Just' an error message to indicate failure. ----- For builtin rules where the value is expected to change use 'Development.Shake.Rules.noLint'.+-- For builtin rules where the value is expected to change, or has no useful checks to perform.+-- use 'Development.Shake.Rules.noLint'. type BuiltinLint key value = key -> value -> IO (Maybe String) ++-- | Produce an identity for a @value@ that can be used to do direct equality. If you have a custom+-- notion of equality then the result should return only one member from each equivalence class,+-- as values will be compared for literal equality.+-- The result of the identity should be reasonably short (if it is excessively long, hash it).+--+-- For rules where the value is never compatible use 'Development.Shake.Rules.noIdentity' and+-- make sure to call 'Development.Shake.historyDisable' if you are ever depended upon.+type BuiltinIdentity key value = key -> value -> BS.ByteString+ data BuiltinRule = BuiltinRule- {builtinRun :: BuiltinRun Key Value- ,builtinLint :: BuiltinLint Key Value- ,builtinResult :: TypeRep+ {builtinLint :: BuiltinLint Key Value+ ,builtinIdentity :: BuiltinIdentity Key Value+ ,builtinRun :: BuiltinRun Key Value ,builtinKey :: BinaryOp Key+ ,builtinVersion :: Ver+ ,builtinLocation :: String } --data UserRule_ = forall a . Typeable a => UserRule_ (UserRule a)- -- | A 'UserRule' data type, representing user-defined rules associated with a particular type. -- As an example 'Development.Shake.?>' and 'Development.Shake.%>' will add entries to the 'UserRule' data type. data UserRule a@@ -118,12 +348,45 @@ | Unordered [UserRule a] -- ^ Rules combined with the 'Monad' \/ 'Monoid'. | Priority Double (UserRule a) -- ^ Rules defined under 'priority'. | Alternative (UserRule a) -- ^ Rule defined under 'alternatives', matched in order.+ | Versioned Ver (UserRule a) -- ^ Rule defined under 'versioned', attaches a version. deriving (Eq,Show,Functor,Typeable) +data UserRuleVersioned a = UserRuleVersioned+ {userRuleVersioned :: Bool -- ^ Does Versioned exist anywhere within userRuleContents+ ,userRuleContents :: UserRule a -- ^ The actual rules+ } +instance Semigroup (UserRuleVersioned a) where+ UserRuleVersioned b1 x1 <> UserRuleVersioned b2 x2 = UserRuleVersioned (b1 || b2) (x1 <> x2)++instance Monoid (UserRuleVersioned a) where+ mempty = UserRuleVersioned False mempty+ mappend = (<>)++instance Semigroup (UserRule a) where+ x <> y = Unordered $ fromUnordered x ++ fromUnordered y+ where+ fromUnordered (Unordered xs) = xs+ fromUnordered x = [x]++instance Monoid (UserRule a) where+ mempty = Unordered []+ mappend = (<>)+++-- | Invariant: The database does not have any cycles where a Key depends on itself.+-- Everything is mutable. intern and status must form a bijecttion.+-- There may be dangling Id's as a result of version changes.+data Database = Database+ {intern :: IORef (Intern Key) -- ^ Key |-> Id mapping+ ,status :: Ids.Ids (Key, Status) -- ^ Id |-> (Key, Status) mapping+ ,journal :: Id -> Key -> Result BS_Store -> IO () -- ^ Record all changes to status+ }++ -- global constants of Action data Global = Global- {globalDatabase :: Database -- ^ Database, contains knowledge of the state of each key+ {globalDatabase :: Var Database -- ^ Database, contains knowledge of the state of each key ,globalPool :: Pool -- ^ Pool, for queuing new elements ,globalCleanup :: Cleanup -- ^ Cleanup operations ,globalTimestamp :: IO Seconds -- ^ Clock saying how many seconds through the build@@ -135,30 +398,40 @@ ,globalAfter :: IORef [IO ()] -- ^ Operations to run on success, e.g. removeFilesAfter ,globalTrackAbsent :: IORef [(Key, Key)] -- ^ Tracked things, in rule fst, snd must be absent ,globalProgress :: IO Progress -- ^ Request current progress state- ,globalUserRules :: Map.HashMap TypeRep UserRule_+ ,globalUserRules :: TMap.Map UserRuleVersioned+ ,globalShared :: Maybe Shared -- ^ The active shared state, if any+ ,globalCloud :: Maybe Cloud+ ,globalStep :: {-# UNPACK #-} !Step+ ,globalOneShot :: Bool -- ^ I am running in one-shot mode so don't need to store BS's for Result/Error } -- local variables of Action data Local = Local -- constants {localStack :: Stack -- ^ The stack that ran to get here.+ ,localBuiltinVersion :: Ver -- ^ The builtinVersion of the rule you are running -- stack scoped local variables ,localVerbosity :: Verbosity -- ^ Verbosity, may be changed locally ,localBlockApply :: Maybe String -- ^ Reason to block apply, or Nothing to allow -- mutable local variables ,localDepends :: [Depends] -- ^ Dependencies, built up in reverse- ,localDiscount :: !Seconds -- ^ Time spend building dependencies+ ,localDiscount :: !Seconds -- ^ Time spend building dependencies (may be negative for parallel) ,localTraces :: [Trace] -- ^ Traces, built in reverse ,localTrackAllows :: [Key -> Bool] -- ^ Things that are allowed to be used ,localTrackUsed :: [Key] -- ^ Things that have been used+ ,localProduces :: [(Bool, FilePath)] -- ^ Things this rule produces, True to check them+ ,localHistory :: !Bool -- ^ Is it valid to cache the result } +addDiscount :: Seconds -> Local -> Local+addDiscount s l = l{localDiscount = s + localDiscount l}+ newLocal :: Stack -> Verbosity -> Local-newLocal stack verb = Local stack verb Nothing [] 0 [] [] []+newLocal stack verb = Local stack (Ver 0) verb Nothing [] 0 [] [] [] [] True -- Clear all the local mutable variables localClearMutable :: Local -> Local-localClearMutable Local{..} = (newLocal localStack localVerbosity){localBlockApply=localBlockApply}+localClearMutable Local{..} = (newLocal localStack localVerbosity){localBlockApply=localBlockApply, localBuiltinVersion=localBuiltinVersion} -- Merge, works well assuming you clear the variables first localMergeMutable :: Local -> [Local] -> Local@@ -166,13 +439,16 @@ localMergeMutable root xs = Local -- immutable/stack that need copying {localStack = localStack root+ ,localBuiltinVersion = localBuiltinVersion 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)+ ,localDiscount = sum $ map localDiscount $ root : xs ,localTraces = concatMap localTraces xs ++ localTraces root ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows xs ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed xs+ ,localProduces = concatMap localProduces xs ++ localProduces root+ ,localHistory = all localHistory $ root:xs }
src/Development/Shake/Internal/Derived.hs view
@@ -22,7 +22,9 @@ import qualified System.IO.Extra as IO import Development.Shake.Internal.Errors-import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Resource+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Action import Development.Shake.Internal.Core.Rules import Development.Shake.Internal.Options import Development.Shake.Internal.Rules.File@@ -71,7 +73,7 @@ case Map.lookup want mp of Just dyn | Just x <- fromDynamic dyn -> return $ Just x- | otherwise -> errorStructured+ | otherwise -> throwM $ errorStructured "shakeExtra value is malformed, all keys and values must agree" [("Key", Just $ show want) ,("Value", Just $ show $ dynTypeRep dyn)]@@ -271,9 +273,12 @@ -- | Given an action on a key, produce a cached version that will execute the action at most once per key per run.--- Using the cached result will still result include any dependencies that the action requires.+-- Using the cached result will still result include any dependencies that the action requires - e.g. if the action+-- does 'need' then those dependencies will be added to every rule that uses that cache. -- Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'.+-- -- The operations will not be cached between runs and nothing will be persisted to the Shake database.+-- For an alternative that does persist the cache, see 'Development.Shake.addOracleCache'. -- -- 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.
src/Development/Shake/Internal/Errors.hs view
@@ -1,24 +1,36 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, RecordWildCards, CPP #-}+{-# LANGUAGE DeriveDataTypeable, PatternGuards, RecordWildCards, ConstraintKinds #-} -- | Errors seen by the user module Development.Shake.Internal.Errors( ShakeException(..),+ throwM, throwImpure, errorInternal, errorStructured, errorNoRuleToBuildType, errorRuleDefinedMultipleTimes, errorMultipleRulesMatch, errorRuleRecursion, errorComplexRecursion, errorNoApply,- errorDirectoryNotFile+ errorDirectoryNotFile, errorNoHash ) where import Data.Tuple.Extra import Control.Exception.Extra+import Control.Monad.IO.Class+import General.Extra import Data.Typeable-import Data.List+import Data.List.Extra+import Data.Maybe -errorInternal :: String -> a-errorInternal msg = error $ "Development.Shake: Internal error, please report to Neil Mitchell (" ++ msg ++ ")"+throwM :: MonadIO m => SomeException -> m a+throwM = liftIO . throwIO +throwImpure :: SomeException -> a+throwImpure = throw+++errorInternal :: Partial => String -> SomeException+errorInternal msg = toException $ ErrorCall $ unlines $+ ("Development.Shake: Internal error, please report to Neil Mitchell (" ++ msg ++ ")") : callStackFull+ alternatives = let (*) = (,) in ["_rule_" * "oracle" ,"_Rule_" * "Oracle"@@ -30,12 +42,9 @@ ,"_apply_" * "askOracle"] -errorStructured :: String -> [(String, Maybe String)] -> String -> IO a-errorStructured msg args hint = errorIO $ errorStructuredContents msg args hint--errorStructuredContents :: String -> [(String, Maybe String)] -> String -> String-errorStructuredContents msg args hint = unlines $- [msg ++ ":"] +++errorStructured :: String -> [(String, Maybe String)] -> String -> SomeException+errorStructured msg args hint = toException $ ErrorCall $ unlines $+ [msg ++ (if null args then "." else ":")] ++ [" " ++ a ++ [':' | a /= ""] ++ replicate (as - length a + 2) ' ' ++ b | (a,b) <- args2] ++ [hint | hint /= ""] where@@ -44,22 +53,22 @@ -structured :: Bool -> String -> [(String, Maybe String)] -> String -> IO a+structured :: Bool -> String -> [(String, Maybe String)] -> String -> SomeException structured alt msg args hint = errorStructured (f msg) (map (first f) args) (f hint) where f = filter (/= '_') . (if alt then g else id)- g xs | (a,b):_ <- filter (\(a,b) -> a `isPrefixOf` xs) alternatives = b ++ g (drop (length a) xs)+ g xs | res:_ <- [to ++ g rest | (from, to) <- alternatives, Just rest <- [stripPrefix from xs]] = res g (x:xs) = x : g xs g [] = [] -errorDirectoryNotFile :: FilePath -> IO a+errorDirectoryNotFile :: FilePath -> SomeException errorDirectoryNotFile dir = errorStructured "Build system error - expected a file, got a directory" [("Directory", Just dir)] "Probably due to calling 'need' on a directory. Shake only permits 'need' on files." -errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> IO a+errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> SomeException errorNoRuleToBuildType tk k tv = structured (specialIsOracleKey tk) "Build system error - no _rule_ matches the _key_ type" [("_Key_ type", Just $ show tk)@@ -67,52 +76,47 @@ ,("_Result_ type", fmap show tv)] "You are missing a call to _addBuiltinRule_, or your call to _apply_ has the wrong _key_ type" -errorRuleDefinedMultipleTimes :: TypeRep-> IO a-errorRuleDefinedMultipleTimes tk = structured (specialIsOracleKey tk)+errorRuleDefinedMultipleTimes :: TypeRep -> [String] -> SomeException+errorRuleDefinedMultipleTimes tk locations = structured (specialIsOracleKey tk) "Build system error - _rule_ defined twice at one _key_ type"- [("_Key_ type", Just $ show tk)]+ (("_Key_ type", Just $ show tk) :+ [("Location " ++ show i, Just x) | (i, x) <- zipFrom 1 locations]) "You have called _addBuiltinRule_ more than once on the same key type" -errorMultipleRulesMatch :: TypeRep -> String -> Int -> IO a-errorMultipleRulesMatch tk k count- | specialIsOracleKey tk, count == 0 =- errorInternal $ "no oracle match for " ++ show tk -- they are always irrifutable rules- | specialIsOracleKey tk = errorStructured- "Build system error - duplicate oracles for the same question type"- [("Question type",Just $ show tk)- ,("Question value",Just k)]- "Only one call to addOracle is allowed per question type"- | otherwise = errorStructured- ("Build system error - key matches " ++ (if count == 0 then "no" else "multiple") ++ " rules")- [("Key type",Just $ show tk)- ,("Key value",Just k)- ,("Rules matched",Just $ show count)]- (if count == 0 then "Either add a rule that produces the above key, or stop requiring the above key"- else "Modify your rules/defaultRules so only one can produce the above key")+errorMultipleRulesMatch :: TypeRep -> String -> [Maybe String] -> SomeException+errorMultipleRulesMatch tk k names = errorStructured+ ("Build system error - key matches " ++ (if null names then "no" else "multiple") ++ " rules")+ ([("Key type",Just $ show tk)+ ,("Key value",Just k)+ ,("Rules matched",Just $ show $ length names)] +++ [("Rule " ++ show i, x) | any isJust names, (i, x) <- zipFrom 1 names])+ (if null names then "Either add a rule that produces the above key, or stop requiring the above key"+ else "Modify your rules so only one can produce the above key") -errorRuleRecursion :: [String] -> TypeRep -> String -> IO a+errorNoHash :: SomeException+errorNoHash = errorStructured "Cannot use shakeChange=ChangeModTime with shakeShare" [] ""++errorRuleRecursion :: TypeRep -> String -> SomeException -- may involve both rules and oracle, so report as only rules-errorRuleRecursion stack tk k = throwIO $ wrap $ toException $ ErrorCall $ errorStructuredContents+errorRuleRecursion tk k = errorStructured "Build system error - recursion detected" [("Key type",Just $ show tk) ,("Key value",Just k)] "Rules may not be recursive"- where- wrap = if null stack then id else toException . ShakeException (last stack) stack -errorComplexRecursion :: [String] -> IO a+errorComplexRecursion :: [String] -> SomeException errorComplexRecursion ks = errorStructured "Build system error - indirect recursion detected" [("Key value " ++ show i, Just k) | (i, k) <- zip [1..] ks] "Rules may not be recursive" -errorNoApply :: TypeRep -> Maybe String -> String -> IO a-errorNoApply tk k msg = structured (specialIsOracleKey tk)- "Build system error - cannot currently call _apply_"+errorNoApply :: TypeRep -> Maybe String -> String -> SomeException+errorNoApply tk k msg = errorStructured+ "Build system error - cannot currently introduce a dependency (e.g. calling 'apply')" [("Reason", Just msg)- ,("_Key_ type", Just $ show tk)- ,("_Key_ value", k)]- "Move the _apply_ call earlier/later"+ ,("Key type", Just $ show tk)+ ,("Key value", k)]+ "Move the call earlier/later" -- Should be in Special, but then we get an import cycle@@ -125,7 +129,7 @@ -- Problems when executing rules will be raising using this exception type. data ShakeException = ShakeException {shakeExceptionTarget :: String -- ^ The target that was being built when the exception occured.- ,shakeExceptionStack :: [String] -- ^ The stack of targets, where the 'shakeExceptionTarget' is last.+ ,shakeExceptionStack :: [String] -- ^ A description of the call stack, one entry per line. ,shakeExceptionInner :: SomeException -- ^ The underlying exception that was raised. } deriving Typeable@@ -135,5 +139,5 @@ instance Show ShakeException where show ShakeException{..} = unlines $ "Error when running Shake build system:" :- map ("* " ++) shakeExceptionStack +++ shakeExceptionStack ++ [displayException shakeExceptionInner]
src/Development/Shake/Internal/FileInfo.hs view
@@ -1,16 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-} module Development.Shake.Internal.FileInfo(- FileInfo, fileInfoNoHash,+ noFileHash, isNoFileHash, FileSize, ModTime, FileHash, getFileHash, getFileInfo ) where +import Data.Hashable import Control.Exception.Extra import Development.Shake.Classes-import Development.Shake.Internal.Errors import Development.Shake.Internal.FileName-import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Internal as LBS (defaultChunkSize) import Data.Char import Data.Word import Numeric@@ -26,12 +26,14 @@ #endif #elif defined(mingw32_HOST_OS)+import Development.Shake.Internal.Errors import Control.Monad import qualified Data.ByteString.Char8 as BS import Foreign.C.Types import Foreign.C.String #else+import Development.Shake.Internal.Errors import GHC.IO.Exception import System.IO.Error import System.Posix.Files.ByteString@@ -41,9 +43,12 @@ newtype FileInfo a = FileInfo Word32 deriving (Typeable,Hashable,Binary,Storable,NFData) -fileInfoNoHash :: FileInfo FileInfoHash-fileInfoNoHash = FileInfo 1 -- Equal to nothing+noFileHash :: FileHash+noFileHash = FileInfo 1 -- Equal to nothing +isNoFileHash :: FileHash -> Bool+isNoFileHash (FileInfo i) = i == 1+ fileInfo :: Word32 -> FileInfo a fileInfo a = FileInfo $ if a > maxBound - 2 then a else a + 2 @@ -65,12 +70,19 @@ getFileHash :: FileName -> IO FileHash-getFileHash x = withFile (fileNameToString x) ReadMode $ \h -> do- s <- LBS.hGetContents h- let res = fileInfo $ fromIntegral $ hash s- evaluate res- return res+getFileHash x = withFile (fileNameToString x) ReadMode $ \h ->+ allocaBytes LBS.defaultChunkSize $ \ptr ->+ go h ptr (hash ())+ where+ go h ptr salt = do+ n <- hGetBufSome h ptr LBS.defaultChunkSize+ if n == 0 then+ return $! fileInfo $ fromIntegral salt+ else+ go h ptr =<< hashPtrWithSalt ptr n salt ++ -- If the result isn't strict then we are referencing a much bigger structure, -- and it causes a space leak I don't really understand on Linux when running -- the 'tar' test, followed by the 'benchmark' test.@@ -105,11 +117,10 @@ getFileInfo x = BS.useAsCString (fileNameToByteString x) $ \file -> alloca_WIN32_FILE_ATTRIBUTE_DATA $ \fad -> do res <- c_GetFileAttributesExA file 0 fad- code <- peekFileAttributes fad let peek = do code <- peekFileAttributes fad if testBit code 4 then- errorDirectoryNotFile $ fileNameToString x+ throwIO $ errorDirectoryNotFile $ fileNameToString x else join $ liftM2 result (peekLastWriteTimeLow fad) (peekFileSizeLow fad) if res then@@ -153,7 +164,7 @@ getFileInfo x = handleBool isDoesNotExistError' (const $ return Nothing) $ do s <- getFileStatus $ fileNameToByteString x if isDirectory s then- errorDirectoryNotFile $ fileNameToString x+ throwM $ errorDirectoryNotFile $ fileNameToString x else result (extractFileTime s) (fromIntegral $ fileSize s) where
src/Development/Shake/Internal/FileName.hs view
@@ -74,7 +74,7 @@ g i (x:xs) | x == dotDot = g (i+1) xs g i (x:xs) | x == dot = g i xs g 0 (x:xs) = x : g 0 xs- g i (x:xs) = g (i-1) xs+ g i (_:xs) = g (i-1) xs -- equivalent to eliminating ../x split = BS.splitWith sep
src/Development/Shake/Internal/FilePattern.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, ViewPatterns #-}+{-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-} module Development.Shake.Internal.FilePattern( -- * Primitive API, as exposed@@ -66,8 +66,9 @@ -- e.g. *foo*bar = Stars "" ["foo"] "bar" deriving (Show,Eq,Ord) -isLit Lit{} = True; isLit _ = False-fromLit (Lit x) = x+fromLit :: Pat -> Maybe String+fromLit (Lit x) = Just x+fromLit _ = Nothing data Lexeme = Str String | Slash | SlashSlash@@ -86,12 +87,13 @@ where -- str = I have ever seen a Str go past (equivalent to "can I be satisfied by no paths") -- slash = I am either at the start, or my previous character was Slash- f str slash [] = [Lit "" | slash]- f str slash (Str "**":xs) = Skip : f True False xs- f str slash (Str x:xs) = parseLit x : f True False xs- f str slash (SlashSlash:Slash:xs) | not str = Skip1 : f str True xs- f str slash (SlashSlash:xs) = Skip : f str False xs- f str slash (Slash:xs) = [Lit "" | not str] ++ f str True xs+ f str slash = \x -> case x of+ [] -> [Lit "" | slash]+ Str "**":xs -> Skip : f True False xs+ Str x:xs -> parseLit x : f True False xs+ SlashSlash:Slash:xs | not str -> Skip1 : f str True xs+ SlashSlash:xs -> Skip : f str False xs+ Slash:xs -> [Lit "" | not str] ++ f str True xs parseLit :: String -> Pat@@ -99,6 +101,7 @@ parseLit x = case split (== '*') x of [x] -> Lit x pre:xs | Just (mid,post) <- unsnoc xs -> Stars pre mid post+ _ -> Lit "" internalTest :: IO ()@@ -148,7 +151,7 @@ isRelativePattern :: FilePattern -> Bool isRelativePattern ('*':'*':xs) | [] <- xs = True- | x:xs <- xs, isPathSeparator x = True+ | x:_ <- xs, isPathSeparator x = True isRelativePattern _ = False -- | A non-absolute 'FilePath'.@@ -175,6 +178,7 @@ matchOne (Lit x) y = x == y matchOne x@Stars{} y = isJust $ matchStars x y matchOne Star _ = True+matchOne p _ = throwImpure $ errorInternal $ "unreachablePattern, matchOne " ++ show p -- Only return the first (all patterns left-most) valid star matching@@ -188,7 +192,7 @@ stripInfixes (m:ms) x = do (a,x) <- stripInfix m x (a:) <$> stripInfixes ms x-+matchStars p _ = throwImpure $ errorInternal $ "unreachablePattern, matchStars " ++ show p -- | Match a 'FilePattern' against a 'FilePath', There are three special forms: --@@ -267,7 +271,7 @@ extract :: FilePattern -> FilePath -> [String] extract p = let pat = parse p in \x -> case match pat (split isPathSeparator x) of- [] | p ?== x -> errorInternal $ "extract with " ++ show p ++ " and " ++ show x+ [] | p ?== x -> throwImpure $ errorInternal $ "extract with " ++ show p ++ " and " ++ show x | otherwise -> error $ "Pattern " ++ show p ++ " does not match " ++ x ++ ", when trying to extract the FilePattern matches" ms:_ -> ms @@ -304,7 +308,9 @@ ps2 = map (filter (/= Lit ".") . optimise . parse) ps f (nubOrd -> ps)- | all isLit fin, all (isLit . fst) nxt = WalkTo (map fromLit fin, map (fromLit *** f) nxt)+ | Just fin <- mapM fromLit fin+ , Just nxt <- mapM (\(a,b) -> (,f b) <$> fromLit a) nxt+ = WalkTo (fin, nxt) | otherwise = Walk $ \xs -> (if finStar then xs else filter (\x -> any (`matchOne` x) fin) xs ,[(x, f ys) | x <- xs, let ys = concat [b | (a,b) <- nxt, matchOne a x], not $ null ys])
+ src/Development/Shake/Internal/History/Bloom.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ViewPatterns #-}++-- | The endpoints on the cloud server+module Development.Shake.Internal.History.Bloom(+ Bloom, bloomTest, bloomCreate+ ) where++import Data.Word+import Data.Bits+import Data.Hashable+import Data.Semigroup+import Foreign.Storable+import Foreign.Ptr+import Control.Applicative+import Prelude+++-- | Given an Int hash we store+data Bloom a = Bloom+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ deriving (Eq,Show)++instance Storable (Bloom a) where+ sizeOf _ = 4 * sizeOf (0 :: Word64)+ alignment _ = alignment (0 :: Word64)+ peek (castPtr -> ptr) = Bloom <$> peekElemOff ptr 0 <*> peekElemOff ptr 1 <*> peekElemOff ptr 2 <*> peekElemOff ptr 3+ poke (castPtr -> ptr) (Bloom x1 x2 x3 x4) = do+ pokeElemOff ptr 0 x1+ pokeElemOff ptr 1 x2+ pokeElemOff ptr 2 x3+ pokeElemOff ptr 3 x4++instance Semigroup (Bloom a) where+ Bloom x1 x2 x3 x4 <> Bloom y1 y2 y3 y4 =+ Bloom (x1 .|. y1) (x2 .|. y2) (x3 .|. y3) (x4 .|. y4)++instance Monoid (Bloom a) where+ mempty = Bloom 0 0 0 0+ mappend = (<>)++-- Should the cloud need to know about Key's? It only needs to do Eq on them...+-- If you Key has a smart Eq your build tree might be more diverse+-- Have the Id resolved in Server.++bloomTest :: Hashable a => Bloom a -> a -> Bool+bloomTest bloom x = bloomCreate x <> bloom == bloom++bloomCreate :: Hashable a => a -> Bloom a+bloomCreate (fromIntegral . hash -> x) =+ Bloom (f 1) (f 2) (f 3) (f 4)+ where f i = x `xor` rotate x i
+ src/Development/Shake/Internal/History/Cloud.hs view
@@ -0,0 +1,83 @@++-- | The endpoints on the server+module Development.Shake.Internal.History.Cloud(+ Cloud, newCloud, addCloud, lookupCloud+ ) where++import Development.Shake.Internal.Value+import Development.Shake.Internal.History.Types+import Development.Shake.Internal.History.Network+import Development.Shake.Internal.History.Server+import Development.Shake.Internal.History.Bloom+import Control.Concurrent.Extra+import System.Time.Extra+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import General.Fence+import Data.List.Extra+import qualified Data.HashMap.Strict as Map+import Data.Typeable+import Data.Either.Extra+import General.Binary+import General.Extra+import General.Wait+import Data.Maybe+import Data.Monoid+import Control.Applicative+import Prelude+++type Initial = Map.HashMap Key (Ver, [Key], Bloom [BS_Identity])++data Cloud = Cloud Server (Locked () -> IO ()) (Fence Locked Initial)+++newLaterFence :: (Locked () -> IO ()) -> Seconds -> a -> IO a -> IO (Fence Locked a)+newLaterFence relock maxTime def act = do+ fence <- newFence+ forkFinally (timeout maxTime act) $ \res -> relock $ signalFence fence $ case res of+ Right (Just v) -> v+ _ -> def+ return fence++laterFence :: (Applicative m, MonadIO m) => Fence m a -> Wait m a+laterFence fence = do+ res <- liftIO $ testFence fence+ case res of+ Just v -> return v+ Nothing -> Later $ waitFence fence+++newCloud :: (Locked () -> IO ()) -> Map.HashMap TypeRep (BinaryOp Key) -> Ver -> [(TypeRep, Ver)] -> [String] -> Maybe (IO Cloud)+newCloud relock binop globalVer ruleVer urls = flip fmap (if null urls then Nothing else connect $ last urls) $ \conn -> do+ conn <- conn+ server <- newServer conn binop globalVer+ fence <- newLaterFence relock 10 Map.empty $ do+ xs <- serverAllKeys server ruleVer+ return $ Map.fromList [(k,(v,ds,test)) | (k,v,ds,test) <- xs]+ return $ Cloud server relock fence+++addCloud :: Cloud -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()+addCloud (Cloud server _ _) x1 x2 x3 x4 x5 x6 = void $ forkIO $ serverUpload server x1 x2 x3 x4 x5 x6+++lookupCloud :: Cloud -> (Key -> Wait Locked (Maybe BS_Identity)) -> Key -> Ver -> Ver -> Wait Locked (Maybe (BS_Store, [[Key]], IO ()))+lookupCloud (Cloud server relock initial) ask key builtinVer userVer = runMaybeT $ do+ mp <- lift $ laterFence initial+ Just (ver, deps, bloom) <- return $ Map.lookup key mp+ unless (ver == userVer) $ fail ""+ Right vs <- lift $ firstLeftWaitUnordered (fmap (maybeToEither ()) . ask) deps+ unless (bloomTest bloom vs) $ fail ""+ fence <- liftIO $ newLaterFence relock 10 mempty $ serverOneKey server key builtinVer userVer $ zip deps vs+ tree <- lift $ laterFence fence+ f [deps] tree+ where+ f :: [[Key]] -> BuildTree Key -> MaybeT (Wait Locked) (BS_Store, [[Key]], IO ())+ f ks (Done store xs) = return (store, reverse ks, serverDownloadFiles server key xs)+ f ks (Depend deps trees) = do+ Right vs <- lift $ firstLeftWaitUnordered (fmap (maybeToEither ()) . ask) deps+ Just tree <- return $ lookup vs trees+ f (deps:ks) tree
+ src/Development/Shake/Internal/History/Network.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP #-}++-- | The network operations available+module Development.Shake.Internal.History.Network(+ Conn, connect, post+ ) where++#ifdef NETWORK+import Network.HTTP+import Network.URI+import Data.List+import Data.Maybe+#endif++import qualified Data.ByteString.Lazy as LBS+++newtype Conn = Conn String++connect :: String -> Maybe (IO Conn)+post :: Conn -> String -> LBS.ByteString -> IO LBS.ByteString+++#ifndef NETWORK++connect _ = Nothing+post (Conn _) _ _ = fail "impossible to get here"++#else++connect x = Just $ return $ Conn $ x ++ ['/' | not $ "/" `isSuffixOf` x]++post (Conn prefix) url send = do+ let request = Request+ {rqURI = parseURI_ $ prefix ++ url+ ,rqMethod = POST+ ,rqHeaders = [Header HdrContentType "application/octet-stream", Header HdrContentLength $ show $ LBS.length send]+ ,rqBody = send}+ response <- simpleHTTP request+ case response of+ Left e -> fail $ "Network.post, failed: " ++ show e+ Right v | rspCode v /= (2,0,0) -> fail $ "Network.post, failed: " ++ show (rspCode v)+ | otherwise -> return $ rspBody v+++parseURI_ :: String -> URI+parseURI_ x = fromMaybe (error $ "Failed to parse URI, " ++ x) $ parseURI x++#endif
+ src/Development/Shake/Internal/History/Serialise.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE FlexibleInstances, DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++-- | The endpoints on the cloud server+module Development.Shake.Internal.History.Serialise(+ BuildTree(..),+ WithTypeReps(..), withTypeReps,+ WithKeys(..), withKeys, withIds, withoutKeys,+ SendAllKeys(..), RecvAllKeys(..),+ SendOneKey(..), RecvOneKey(..),+ SendDownloadFiles(..),+ SendUpload(..)+ ) where++import Development.Shake.Internal.History.Bloom+import General.Extra+import General.Binary+import General.Ids+import Data.List.Extra+import Development.Shake.Internal.Value+import Development.Shake.Internal.FileInfo+import Development.Shake.Internal.History.Types+import qualified Data.HashMap.Strict as Map+import Data.Semigroup+import Data.Typeable+import Data.Traversable+import Data.Foldable+import Prelude+++data BuildTree key+ -- invariant: Entries are sorted+ = Depend [key] [([BS_Identity], BuildTree key)]+ | Done BS_Store [(FilePath, FileSize, FileHash)]++instance BinaryEx (BuildTree Int) where+ getEx = undefined+ putEx = undefined++instance Eq key => Semigroup (BuildTree key) where+ Depend ks1 vs1 <> Depend ks2 vs2+ | ks1 == ks2 = Depend ks1 $ mergeBy undefined vs1 vs2+ | otherwise = Depend ks2 vs2 -- this shouldn't happen, so give up+ x@Done{} <> _ = x+ _ <> y@Done{} = y++instance Eq key => Monoid (BuildTree key) where+ mempty = Depend [] []+ mappend = (<>)+++data WithTypeReps a = WithTypeReps [BS_QTypeRep] a++instance BinaryEx a => BinaryEx (WithTypeReps a) where+ putEx = undefined+ getEx = undefined++withTypeReps :: Traversable f => f TypeRep -> WithTypeReps (f Int)+withTypeReps = undefined++data WithKeys a = WithKeys [BS_Key] a++instance BinaryEx a => BinaryEx (WithKeys a) where+ putEx = undefined+ getEx = undefined++withKeys :: Traversable f => f Key -> WithKeys (f Int)+withKeys = undefined++withIds :: Traversable f => (Id -> m Key) -> f Id -> m (WithKeys (f Int))+withIds = undefined++withoutKeys :: Map.HashMap TypeRep (BinaryOp Key) -> WithKeys (f Int) -> f Key+withoutKeys = undefined++data SendAllKeys typ = SendAllKeys Ver [(typ, Ver)]+ deriving (Functor, Foldable, Traversable)++instance BinaryEx (SendAllKeys Int) where+ putEx = undefined+ getEx = undefined++newtype RecvAllKeys key = RecvAllKeys [(key, Ver, [key], Bloom [BS_Identity])]++instance BinaryEx (RecvAllKeys Int) where+ getEx = undefined+ putEx = undefined++data SendOneKey key = SendOneKey Ver key Ver Ver [(key, BS_Identity)]++instance BinaryEx (SendOneKey Int) where+ getEx = undefined+ putEx = undefined++newtype RecvOneKey key = RecvOneKey (BuildTree key)++instance BinaryEx (RecvOneKey Int) where+ getEx = undefined+ putEx = undefined++data SendDownloadFiles key = SendDownloadFiles Ver key Ver Ver [(FilePath, FileSize, FileHash)]++instance BinaryEx (SendDownloadFiles Int) where+ getEx = undefined+ putEx = undefined++data SendUpload key = SendUpload Ver key Ver Ver [[(key, BS_Identity)]] BS_Store [(FilePath, FileSize, FileHash)]++instance BinaryEx (SendUpload Int) where+ getEx = undefined+ putEx = undefined
+ src/Development/Shake/Internal/History/Server.hs view
@@ -0,0 +1,44 @@++-- | The endpoints on the cloud server+module Development.Shake.Internal.History.Server(+ Server, BuildTree(..),+ newServer,+ serverAllKeys, serverOneKey, serverDownloadFiles,+ serverUpload+ ) where++import Development.Shake.Internal.History.Bloom+import Development.Shake.Internal.History.Serialise+import Development.Shake.Internal.Value+import General.Binary+import General.Extra+import qualified Data.HashMap.Strict as Map+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString as BS+import Development.Shake.Internal.FileInfo+import Development.Shake.Internal.History.Types+import Development.Shake.Internal.History.Network+import Data.Typeable+++data Server = Server Conn (Map.HashMap TypeRep (BinaryOp Key)) Ver++newServer :: Conn -> Map.HashMap TypeRep (BinaryOp Key) -> Ver -> IO Server+newServer a b c = return $ Server a b c++serverAllKeys :: Server -> [(TypeRep, Ver)] -> IO [(Key, Ver, [Key], Bloom [BS_Identity])]+serverAllKeys (Server conn key ver) typs = do+ res <- post conn "allkeys/v1" $ LBS.fromChunks [runBuilder $ putEx $ withTypeReps $ SendAllKeys ver typs]+ let RecvAllKeys ans = withoutKeys key $ getEx $ BS.concat $ LBS.toChunks res+ return ans++serverOneKey :: Server -> Key -> Ver -> Ver -> [(Key, BS_Identity)] -> IO (BuildTree Key)+serverOneKey _ _ _ _ _ = return $ Depend [] []+++serverDownloadFiles :: Server -> Key -> [(FilePath, FileSize, FileHash)] -> IO ()+serverDownloadFiles _ _ _ = fail "Failed to download the files"+++serverUpload :: Server -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()+serverUpload _ key _ _ _ _ _ = print ("SERVER", "Uploading key", key)
@@ -0,0 +1,153 @@+{-# LANGUAGE RecordWildCards, TupleSections #-}++module Development.Shake.Internal.History.Shared(+ Shared, newShared, addShared, lookupShared+ ) where++import Development.Shake.Internal.Value+import Development.Shake.Internal.History.Types+import Development.Shake.Classes+import General.Binary+import General.Extra+import General.Chunks+import Control.Monad.Extra+import System.FilePath+import System.Directory+import System.IO+import Numeric+import Development.Shake.Internal.FileInfo+import General.Wait+import Development.Shake.Internal.FileName+import Data.Monoid+import Data.Functor+import Control.Monad.IO.Class+import Data.Maybe+import qualified Data.ByteString as BS+import Prelude++{-+#ifndef mingw32_HOST_OS+import System.Posix.Files(createLink)+#else++import Foreign.Ptr+import Foreign.C.Types+import Foreign.C.String++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "Windows.h CreateHardLinkW" c_CreateHardLinkW :: Ptr CWchar -> Ptr CWchar -> Ptr () -> IO Bool++createLink :: FilePath -> FilePath -> IO ()+createLink from to = withCWString from $ \cfrom -> withCWString to $ \cto -> do+ res <- c_CreateHardLinkW cfrom cto nullPtr+ unless res $ error $ show ("Failed to createLink", from, to)++#endif+-}++data Shared = Shared+ {globalVersion :: !Ver+ ,keyOp :: BinaryOp Key+ ,sharedRoot :: FilePath+ }++newShared :: BinaryOp Key -> Ver -> FilePath -> IO Shared+newShared keyOp globalVersion sharedRoot = return Shared{..}+++data Entry = Entry+ {entryKey :: Key+ ,entryGlobalVersion :: !Ver+ ,entryBuiltinVersion :: !Ver+ ,entryUserVersion :: !Ver+ ,entryDepends :: [[(Key, BS_Identity)]]+ ,entryResult :: BS_Store+ ,entryFiles :: [(FilePath, FileHash)]+ } deriving (Show, Eq)++putEntry :: BinaryOp Key -> Entry -> Builder+putEntry binop Entry{..} =+ putExStorable entryGlobalVersion <>+ putExStorable entryBuiltinVersion <>+ putExStorable entryUserVersion <>+ putExN (putOp binop entryKey) <>+ putExN (putExList $ map (putExList . map putDepend) entryDepends) <>+ putExN (putExList $ map putFile entryFiles) <>+ putEx entryResult+ where+ putDepend (a,b) = putExN (putOp binop a) <> putEx b+ putFile (a,b) = putExStorable b <> putEx a++getEntry :: BinaryOp Key -> BS.ByteString -> Entry+getEntry binop x+ | (x1, x2, x3, x) <- binarySplit3 x+ , (x4, x) <- getExN x+ , (x5, x) <- getExN x+ , (x6, x7) <- getExN x+ = Entry+ {entryGlobalVersion = x1+ ,entryBuiltinVersion = x2+ ,entryUserVersion = x3+ ,entryKey = getOp binop x4+ ,entryDepends = map (map getDepend . getExList) $ getExList x5+ ,entryFiles = map getFile $ getExList x6+ ,entryResult = getEx x7+ }+ where+ getDepend x | (a, b) <- getExN x = (getOp binop a, getEx b)+ getFile x | (b, a) <- binarySplit x = (getEx a, b)++sharedFileDir :: Shared -> Key -> FilePath+sharedFileDir shared key = sharedRoot shared </> ".shake.cache" </> showHex (abs $ hash key) ""++loadSharedEntry :: Shared -> Key -> Ver -> Ver -> IO [Entry]+loadSharedEntry shared@Shared{..} key builtinVersion userVersion = do+ let file = sharedFileDir shared key </> "_key"+ b <- doesFileExist_ file+ if not b then return [] else do+ (items, slop) <- withFile file ReadMode $ \h ->+ readChunksDirect h maxBound+ unless (BS.null slop) $+ error $ "Corrupted key file, " ++ show file+ let eq Entry{..} = entryKey == key && entryGlobalVersion == globalVersion && entryBuiltinVersion == builtinVersion && entryUserVersion == userVersion+ return $ filter eq $ map (getEntry keyOp) items+++-- | Given a way to get the identity, see if you can a stored cloud version+lookupShared :: Shared -> (Key -> Wait Locked (Maybe BS_Identity)) -> Key -> Ver -> Ver -> Wait Locked (Maybe (BS_Store, [[Key]], IO ()))+lookupShared shared ask key builtinVersion userVersion = do+ ents <- liftIO $ loadSharedEntry shared key builtinVersion userVersion+ flip firstJustWaitUnordered ents $ \Entry{..} -> do+ -- use Nothing to indicate success, Just () to bail out early on mismatch+ let result x = if isJust x then Nothing else Just $ (entryResult, map (map fst) entryDepends, ) $ do+ let dir = sharedFileDir shared entryKey+ forM_ entryFiles $ \(file, hash) -> do+ createDirectoryRecursive $ takeDirectory file+ copyFile (dir </> show hash) file+ result <$> firstJustM id+ [ firstJustWaitUnordered id+ [ test <$> ask k | (k, i1) <- kis+ , let test = maybe (Just ()) (\i2 -> if i1 == i2 then Nothing else Just ())]+ | kis <- entryDepends]+++saveSharedEntry :: Shared -> Entry -> IO ()+saveSharedEntry shared entry = do+ let dir = sharedFileDir shared (entryKey entry)+ createDirectoryRecursive dir+ withFile (dir </> "_key") AppendMode $ \h -> writeChunkDirect h $ putEntry (keyOp shared) entry+ forM_ (entryFiles entry) $ \(file, hash) ->+ -- FIXME: should use a combination of symlinks and making files read-only+ unlessM (doesFileExist_ $ dir </> show hash) $+ copyFile file (dir </> show hash)+++addShared :: Shared -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()+addShared shared entryKey entryBuiltinVersion entryUserVersion entryDepends entryResult files = do+ hashes <- mapM (getFileHash . fileNameFromString) files+ saveSharedEntry shared Entry{entryFiles = zip files hashes, entryGlobalVersion = globalVersion shared, ..}
+ src/Development/Shake/Internal/History/Types.hs view
@@ -0,0 +1,11 @@++module Development.Shake.Internal.History.Types(+ BS_QTypeRep, BS_Key, BS_Store, BS_Identity+ ) where++import qualified Data.ByteString as BS++type BS_QTypeRep = BS.ByteString+type BS_Key = BS.ByteString+type BS_Store = BS.ByteString+type BS_Identity = BS.ByteString
src/Development/Shake/Internal/Options.hs view
@@ -13,12 +13,14 @@ import Data.Tuple.Extra import Data.Maybe import Data.Dynamic+import Control.Monad import qualified Data.HashMap.Strict as Map-import Development.Shake.Internal.Progress import Development.Shake.Internal.FilePattern import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.UTF8 as UTF8 import Development.Shake.Internal.CmdOption+import Data.Semigroup+import Prelude -- | The current assumptions made by the build system, used by 'shakeRebuild'. These options@@ -82,6 +84,46 @@ deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded) +-- | Information about the current state of the build, obtained by either passing a callback function+-- to 'Development.Shake.shakeProgress' (asynchronous output) or 'Development.Shake.getProgress'+-- (synchronous output). Typically a build system will pass 'progressDisplay' to 'Development.Shake.shakeProgress',+-- which will poll this value and produce status messages.+data Progress = Progress+-- In retrospect shakeProgress should have been done differently, as a feature you turn on in Rules+-- but easiest way around that for now is put the Progress type in Options++ {isFailure :: !(Maybe String) -- ^ Starts out 'Nothing', becomes 'Just' a target name if a rule fails.+ ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state.+ ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run.+ ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required.+ ,countTodo :: {-# UNPACK #-} !Int -- ^ Number of rules which are currently required (ignoring dependencies that do not change), but not built.+ ,timeSkipped :: {-# UNPACK #-} !Double -- ^ Time spent building 'countSkipped' rules in previous runs.+ ,timeBuilt :: {-# UNPACK #-} !Double -- ^ Time spent building 'countBuilt' rules.+ ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs.+ ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before).+ }+ deriving (Eq,Ord,Show,Read,Data,Typeable)++instance Semigroup Progress where+ a <> b = Progress+ {isFailure = isFailure a `mplus` isFailure b+ ,countSkipped = countSkipped a + countSkipped b+ ,countBuilt = countBuilt a + countBuilt b+ ,countUnknown = countUnknown a + countUnknown b+ ,countTodo = countTodo a + countTodo b+ ,timeSkipped = timeSkipped a + timeSkipped b+ ,timeBuilt = timeBuilt a + timeBuilt b+ ,timeUnknown = timeUnknown a + timeUnknown b+ ,timeTodo = let (a1,a2) = timeTodo a; (b1,b2) = timeTodo b+ x1 = a1 + b1; x2 = a2 + b2+ in x1 `seq` x2 `seq` (x1,x2)+ }++instance Monoid Progress where+ mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0)+ mappend = (<>)++ -- | Options to control the execution of Shake, usually specified by overriding fields in -- 'shakeOptions': --@@ -94,6 +136,7 @@ -- ^ Defaults to @.shake@. The directory used for storing Shake metadata files. -- All metadata files will be named @'shakeFiles'\/.shake./file-name/@, for some @/file-name/@. -- If the 'shakeFiles' directory does not exist it will be created.+ -- If set to @\"\/dev\/null\"@ then no shakeFiles are read or written (even on Windows). ,shakeThreads :: Int -- ^ Defaults to @1@. Maximum number of rules to run in parallel, similar to @make --jobs=/N/@. -- For many build systems, a number equal to or slightly less than the number of physical processors@@ -157,6 +200,10 @@ -- ^ Defaults to 'False'. Ignore any differences in 'shakeVersion'. ,shakeColor :: Bool -- ^ Defaults to 'False'. Whether to colorize the output.+ ,shakeShare :: Maybe FilePath+ -- ^ Defaults to 'Nothing'. Whether to use and store outputs in a shared directory.+ ,shakeCloud :: [String]+ -- ^ Defaults to @[]@. Cloud servers to talk to forming a shared cache. ,shakeProgress :: IO Progress -> IO () -- ^ Defaults to no action. A function called when the build starts, allowing progress to be reported. -- The function is called on a separate thread, and that thread is killed when the build completes.@@ -178,7 +225,7 @@ shakeOptions :: ShakeOptions shakeOptions = ShakeOptions ".shake" 1 "1" Normal False [] Nothing [] [] [] (Just 10) [] [] False True False- True ChangeModtime True [] False False+ True ChangeModtime True [] False False Nothing [] (const $ return ()) (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS Map.empty@@ -188,18 +235,18 @@ ,"shakeLint", "shakeLintInside", "shakeLintIgnore", "shakeCommandOptions" ,"shakeFlush", "shakeRebuild", "shakeAbbreviations", "shakeStorageLog" ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"- ,"shakeLiveFiles","shakeVersionIgnore","shakeProgress", "shakeOutput", "shakeColor", "shakeExtra"]+ ,"shakeLiveFiles", "shakeVersionIgnore", "shakeProgress", "shakeShare", "shakeCloud", "shakeOutput", "shakeColor", "shakeExtra"] tyShakeOptions = mkDataType "Development.Shake.Types.ShakeOptions" [conShakeOptions] conShakeOptions = mkConstr tyShakeOptions "ShakeOptions" fieldsShakeOptions Prefix-unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 y1 y2 y3 =- ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 (fromHidden y1) (fromHidden y2) (fromHidden y3)+unhide x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 y1 y2 y3 =+ ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 (fromHidden y1) (fromHidden y2) (fromHidden y3) instance Data ShakeOptions where- gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 y1 y2 y3) =+ gfoldl k z (ShakeOptions x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 y1 y2 y3) = z unhide `k` x1 `k` x2 `k` x3 `k` x4 `k` x5 `k` x6 `k` x7 `k` x8 `k` x9 `k` x10 `k` x11 `k`- x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k`+ x12 `k` x13 `k` x14 `k` x15 `k` x16 `k` x17 `k` x18 `k` x19 `k` x20 `k` x21 `k` x22 `k` x23 `k` x24 `k` Hidden y1 `k` Hidden y2 `k` Hidden y3- gunfold k z c = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide+ gunfold k z _ = k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ k $ z unhide toConstr ShakeOptions{} = conShakeOptions dataTypeOf _ = tyShakeOptions @@ -217,6 +264,7 @@ | Just x <- cast x = show (x :: [(Rebuild, FilePattern)]) | Just x <- cast x = show (x :: Maybe Lint) | Just x <- cast x = show (x :: Maybe Double)+ | Just x <- cast x = show (x :: Maybe String) | Just x <- cast x = show (x :: [(String,String)]) | Just x <- cast x = show (x :: Hidden (IO Progress -> IO ())) | Just x <- cast x = show (x :: Hidden (Verbosity -> String -> IO ()))@@ -232,8 +280,8 @@ instance Show (Hidden a) where show _ = "<hidden>" instance Typeable a => Data (Hidden a) where- gfoldl k z = z- gunfold k z c = error "Development.Shake.Types.ShakeProgress: gunfold not implemented - data type has no constructors"+ gfoldl _ z = z+ gunfold _ _ _ = error "Development.Shake.Types.ShakeProgress: gunfold not implemented - data type has no constructors" toConstr _ = error "Development.Shake.Types.ShakeProgress: toConstr not implemented - data type has no constructors" dataTypeOf _ = tyHidden
src/Development/Shake/Internal/Profile.hs view
@@ -1,19 +1,96 @@ {-# LANGUAGE PatternGuards, RecordWildCards #-} -module Development.Shake.Internal.Profile(ProfileEntry(..), ProfileTrace(..), writeProfile) where+module Development.Shake.Internal.Profile(writeProfile) where import General.Template import Data.Tuple.Extra import Data.Function-import Data.List+import Data.List.Extra+import Data.Maybe import System.FilePath import Numeric.Extra import General.Extra+import Development.Shake.Internal.Errors+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Value+import qualified General.Ids as Ids+import qualified Data.HashSet as Set import Development.Shake.Internal.Paths+import Development.Shake.Classes import System.Time.Extra+import qualified Data.HashMap.Strict as Map import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.ByteString.Char8 as BS+import General.Intern(Id)+import Data.Functor+import Prelude +-- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such+-- that no item points to an item before itself.+-- Raise an error if you end up with a cycle.+dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> Map.HashMap a [a] -> [a]+-- Algorithm:+-- Divide everyone up into those who have no dependencies [Id]+-- And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])]+-- Where d :-> Just (k, ds), k depends on firstly d, then remaining on ds+-- For each with no dependencies, add to list, then take its dep hole and+-- promote them either to Nothing (if ds == []) or into a new slot.+-- k :-> Nothing means the key has already been freed+dependencyOrder shw status = f (map fst noDeps) $ Map.map Just $ Map.fromListWith (++) [(d, [(k,ds)]) | (k,d:ds) <- hasDeps]+ where+ (noDeps, hasDeps) = partition (null . snd) $ Map.toList status++ f [] mp | null bad = []+ | otherwise = error $ unlines $+ "Internal invariant broken, database seems to be cyclic" :+ map (" " ++) bad +++ ["... plus " ++ show (length badOverflow) ++ " more ..." | not $ null badOverflow]+ where (bad,badOverflow) = splitAt 10 [shw i | (i, Just _) <- Map.toList mp]++ f (x:xs) mp = x : f (now++xs) later+ where Just free = Map.lookupDefault (Just []) x mp+ (now,later) = foldl' g ([], Map.insert x Nothing mp) free++ g (free, mp) (k, []) = (k:free, mp)+ g (free, mp) (k, d:ds) = case Map.lookupDefault (Just []) d mp of+ Nothing -> g (free, mp) (k, ds)+ Just todo -> (free, Map.insert d (Just $ (k,ds) : todo) mp)+++-- | Eliminate all errors from the database, pretending they don't exist+resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap 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++removeStep :: Map.HashMap Id (Key, Result a) -> Map.HashMap Id (Key, Result a)+removeStep = Map.filter (\(k,_) -> k /= stepKey)++-- | FIXME: Move into Profile itself+toReport :: Database -> IO [ProfileEntry]+toReport Database{..} = do+ status <- removeStep . resultsOnly <$> Ids.toMap status+ let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status+ in dependencyOrder shw $ Map.map (concatMap fromDepends . depends . snd) status+ ids = Map.fromList $ zip order [0..]++ steps = let xs = Set.toList $ Set.fromList $ concat [[changed, built] | (_,Result{..}) <- Map.elems status]+ in Map.fromList $ zip (sortBy (flip compare) xs) [0..]++ f (k, Result{..}) = ProfileEntry+ {prfName = show k+ ,prfBuilt = fromStep built+ ,prfChanged = fromStep changed+ ,prfDepends = mapMaybe (`Map.lookup` ids) (concatMap fromDepends depends)+ ,prfExecution = floatToDouble execution+ ,prfTraces = map fromTrace traces+ }+ where fromStep i = fromJust $ Map.lookup i steps+ fromTrace (Trace a b c) = ProfileTrace (BS.unpack a) (floatToDouble b) (floatToDouble c)+ return [maybe (throwImpure $ errorInternal "toReport") f $ Map.lookup i status | i <- order]+++-- FIXME: These data types are now almost entirely pointless data ProfileEntry = ProfileEntry {prfName :: String, prfBuilt :: Int, prfChanged :: Int, prfDepends :: [Int], prfExecution :: Double, prfTraces :: [ProfileTrace]} data ProfileTrace = ProfileTrace@@ -22,8 +99,11 @@ -- | Generates an report given some build system profiling data.-writeProfile :: FilePath -> [ProfileEntry] -> IO ()-writeProfile out xs+writeProfile :: FilePath -> Database -> IO ()+writeProfile out db = writeProfileInternal out =<< toReport db++writeProfileInternal :: FilePath -> [ProfileEntry] -> IO ()+writeProfileInternal out xs | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ generateJSON xs | takeExtension out == ".json" = writeFile out $ generateJSON xs | takeExtension out == ".trace" = writeFile out $ generateTrace xs@@ -66,9 +146,13 @@ showEntries 0 [y{prfCommand=prfName x} | x <- xs, y <- prfTraces x] ++ showEntries 1 (concatMap prfTraces xs) where- showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortBy (compare `on` prfStart) xs- alloc as r | (a1,an:a2) <- break (\a -> prfStop a <= prfStart r) as = (a1++r:a2, (length a1,r))+ showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortOn prfStart xs++ alloc :: [ProfileTrace] -> ProfileTrace -> ([ProfileTrace], (Int, ProfileTrace))+ -- FIXME: I don't really understand what this code is doing, or the invariants it ensures+ alloc as r | (a1,_:a2) <- break (\a -> prfStop a <= prfStart r) as = (a1++r:a2, (length a1,r)) | otherwise = (as++[r], (length as,r))+ showEntry pid (tid, ProfileTrace{..}) = jsonObject [("args","{}"), ("ph",show "X"), ("cat",show "target") ,("name",show prfCommand), ("tid",show tid), ("pid",show pid)
src/Development/Shake/Internal/Progress.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface #-}+{-# LANGUAGE RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface, TupleSections #-} -- | Progress tracking module Development.Shake.Internal.Progress(- Progress(..),+ progress, progressSimple, progressDisplay, progressTitlebar, progressProgram, ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY ) where@@ -16,24 +16,26 @@ import System.Process import System.FilePath import Data.Char-import Data.Data import Data.IORef import Data.List import Data.Maybe+import Development.Shake.Internal.Options+import Development.Shake.Internal.Core.Types import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import Numeric.Extra import General.Template import System.IO.Unsafe import Development.Shake.Internal.Paths+import Data.Monoid import System.Time.Extra-import Data.Semigroup (Semigroup (..))-import Data.Monoid hiding ((<>))+import qualified General.Ids as Ids import Prelude + #ifdef mingw32_HOST_OS -import Foreign+import Foreign.Ptr import Foreign.C.Types #ifdef x86_64_HOST_ARCH@@ -47,45 +49,30 @@ #endif + ------------------------------------------------------------------------ PROGRESS TYPES - exposed to the user+-- PROGRESS --- | Information about the current state of the build, obtained by either passing a callback function--- to 'Development.Shake.shakeProgress' (asynchronous output) or 'Development.Shake.getProgress'--- (synchronous output). Typically a build system will pass 'progressDisplay' to 'Development.Shake.shakeProgress',--- which will poll this value and produce status messages.-data Progress = Progress- {isFailure :: !(Maybe String) -- ^ Starts out 'Nothing', becomes 'Just' a target name if a rule fails.- ,countSkipped :: {-# UNPACK #-} !Int -- ^ Number of rules which were required, but were already in a valid state.- ,countBuilt :: {-# UNPACK #-} !Int -- ^ Number of rules which were have been built in this run.- ,countUnknown :: {-# UNPACK #-} !Int -- ^ Number of rules which have been built previously, but are not yet known to be required.- ,countTodo :: {-# UNPACK #-} !Int -- ^ Number of rules which are currently required (ignoring dependencies that do not change), but not built.- ,timeSkipped :: {-# UNPACK #-} !Double -- ^ Time spent building 'countSkipped' rules in previous runs.- ,timeBuilt :: {-# UNPACK #-} !Double -- ^ Time spent building 'countBuilt' rules.- ,timeUnknown :: {-# UNPACK #-} !Double -- ^ Time spent building 'countUnknown' rules in previous runs.- ,timeTodo :: {-# UNPACK #-} !(Double,Int) -- ^ Time spent building 'countTodo' rules in previous runs, plus the number which have no known time (have never been built before).- }- deriving (Eq,Ord,Show,Read,Data,Typeable)-instance Semigroup Progress where- a <> b = Progress- {isFailure = isFailure a `mplus` isFailure b- ,countSkipped = countSkipped a + countSkipped b- ,countBuilt = countBuilt a + countBuilt b- ,countUnknown = countUnknown a + countUnknown b- ,countTodo = countTodo a + countTodo b- ,timeSkipped = timeSkipped a + timeSkipped b- ,timeBuilt = timeBuilt a + timeBuilt b- ,timeUnknown = timeUnknown a + timeUnknown b- ,timeTodo = let (a1,a2) = timeTodo a; (b1,b2) = timeTodo b- x1 = a1 + b1; x2 = a2 + b2- in x1 `seq` x2 `seq` (x1,x2)- }+progress :: Database -> Step -> IO Progress+progress Database{..} step = do+ xs <- Ids.elems status+ return $! foldl' f mempty $ map snd xs+ where+ g = floatToDouble + f s (Ready Result{..}) = if step == built+ then s{countBuilt = countBuilt s + 1, timeBuilt = timeBuilt s + g execution}+ else s{countSkipped = countSkipped s + 1, timeSkipped = timeSkipped s + g execution}+ f s (Loaded Result{..}) = s{countUnknown = countUnknown s + 1, timeUnknown = timeUnknown s + g execution}+ f s (Running _ r) =+ let (d,c) = timeTodo s+ t | Just Result{..} <- r = let d2 = d + g execution in d2 `seq` (d2,c)+ | otherwise = let c2 = c + 1 in c2 `seq` (d,c2)+ in s{countTodo = countTodo s + 1, timeTodo = t}+ f s _ = s -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 <https://hackage.haskell.org/package/machines-0.2.3.1/docs/Data-Machine-Mealy.html>@@ -104,7 +91,7 @@ (x, mx) -> (f x, mf <*> mx) echoMealy :: Mealy i i-echoMealy = Mealy $ \i -> (i, echoMealy)+echoMealy = Mealy (,echoMealy) scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a scanMealy f z (Mealy m) = Mealy $ \i -> case m i of@@ -231,8 +218,8 @@ sleep sample p <- prog t <- time- ((secs,perc,debug), mealy) <- return $ runMealy mealy (t, p)- -- putStrLn debug+ ((secs,perc,_debug), mealy) <- return $ runMealy mealy (t, p)+ -- putStrLn _debug disp $ formatMessage secs perc ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p) loop time mealy @@ -341,18 +328,17 @@ case exe of Nothing -> return $ const $ return () Just exe -> do- ref <- newIORef Nothing+ lastArgs <- newIORef Nothing -- the arguments we passed to shake-progress last time return $ \msg -> do let failure = " Failure! " `isInfixOf` msg let perc = let (a,b) = break (== '%') msg in if null b then "" else reverse $ takeWhile isDigit $ reverse a- let key = (failure, perc)- same <- atomicModifyIORef ref $ \old -> (Just key, old == Just key) let state | perc == "" = "NoProgress" | failure = "Error" | otherwise = "Normal"- rawSystem exe $ ["--title=" ++ msg, "--state=" ++ state] ++ ["--value=" ++ perc | perc /= ""]- return ()+ let args = ["--title=" ++ msg, "--state=" ++ state] ++ ["--value=" ++ perc | perc /= ""]+ same <- atomicModifyIORef lastArgs $ \old -> (Just args, old == Just args)+ unless same $ void $ rawSystem exe args -- | A simple method for displaying progress messages, suitable for using as 'Development.Shake.shakeProgress'.
src/Development/Shake/Internal/Resource.hs view
@@ -1,30 +1,55 @@ {-# LANGUAGE RecordWildCards, ViewPatterns #-} module Development.Shake.Internal.Resource(- Resource, newResourceIO, newThrottleIO, acquireResource, releaseResource+ Resource, newResourceIO, newThrottleIO, withResource ) where import Data.Function import System.IO.Unsafe import Control.Concurrent.Extra+import General.Fence import Control.Exception.Extra import Data.Tuple.Extra-import Control.Monad+import Data.IORef.Extra+import Control.Monad.Extra import General.Bilist+import General.Pool+import Development.Shake.Internal.Core.Action+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Monad import Development.Shake.Internal.Core.Pool+import Control.Monad.IO.Class import System.Time.Extra import Data.Monoid import Prelude -{-# NOINLINE resourceIds #-}-resourceIds :: Var Int-resourceIds = unsafePerformIO $ newVar 0-+{-# NOINLINE resourceId #-} resourceId :: IO Int-resourceId = modifyVar resourceIds $ \i -> let j = i + 1 in j `seq` return (j, j)+resourceId = unsafePerformIO $ do+ ref <- newIORef 0+ return $ atomicModifyIORef' ref $ \i -> let j = i + 1 in (j, j) +-- | Run an action which uses part of a finite resource. For more details see 'Resource'.+-- You cannot depend on a rule (e.g. 'need') while a resource is held.+withResource :: Resource -> Int -> Action a -> Action a+withResource r i act = do+ Global{..} <- Action getRO+ liftIO $ globalDiagnostic $ return $ show r ++ " waiting to acquire " ++ show i++ fence <- liftIO $ acquireResource r globalPool i+ whenJust fence $ \fence -> do+ (offset, ()) <- actionFenceRequeueBy Right fence+ Action $ modifyRW $ addDiscount offset++ liftIO $ globalDiagnostic $ return $ show r ++ " running with " ++ show i+ Action $ fromAction (blockApply ("Within withResource using " ++ show r) act) `finallyRAW` do+ liftIO $ releaseResource r globalPool i+ liftIO $ globalDiagnostic $ return $ show r ++ " released " ++ show i+++ -- | A type representing an external resource which the build system should respect. There -- are two ways to create 'Resource's in Shake: --@@ -46,7 +71,7 @@ -- ^ Key used for Eq/Ord operations. To make withResources work, we require newResourceIO < newThrottleIO ,resourceShow :: String -- ^ String used for Show- ,acquireResource :: Pool -> Int -> IO () -> IO ()+ ,acquireResource :: Pool -> Int -> IO (Maybe (Fence IO ())) -- ^ Acquire the resource and call the function. ,releaseResource :: Pool -> Int -> IO () -- ^ You should only ever releaseResource that you obtained with acquireResource.@@ -63,7 +88,7 @@ data Finite = Finite {finiteAvailable :: !Int -- ^ number of currently available resources- ,finiteWaiting :: Bilist (Int, IO ())+ ,finiteWaiting :: Bilist (Int, Fence IO ()) -- ^ queue of people with how much they want and the action when it is allocated to them } @@ -79,21 +104,22 @@ where shw = "Resource " ++ name - acquire :: Var Finite -> Pool -> Int -> IO () -> IO ()- acquire var pool want continue+ acquire :: Var Finite -> Pool -> Int -> IO (Maybe (Fence IO ()))+ acquire var _ want | want < 0 = errorIO $ "You cannot acquire a negative quantity of " ++ shw ++ ", requested " ++ show want | want > mx = errorIO $ "You cannot acquire more than " ++ show mx ++ " of " ++ shw ++ ", requested " ++ show want- | otherwise = join $ modifyVar var $ \x@Finite{..} -> return $+ | otherwise = modifyVar var $ \x@Finite{..} -> if want <= finiteAvailable then- (x{finiteAvailable = finiteAvailable - want}, continue)- else- (x{finiteWaiting = finiteWaiting `snoc` (want, addPoolResume pool continue)}, return ())+ return (x{finiteAvailable = finiteAvailable - want}, Nothing)+ else do+ fence <- newFence+ return (x{finiteWaiting = finiteWaiting `snoc` (want, fence)}, Just fence) release :: Var Finite -> Pool -> Int -> IO () release var _ i = join $ modifyVar var $ \x -> return $ f x{finiteAvailable = finiteAvailable x + i} where f (Finite i (uncons -> Just ((wi,wa),ws)))- | wi <= i = second (wa >>) $ f $ Finite (i-wi) ws+ | wi <= i = second (signalFence wa () >>) $ f $ Finite (i-wi) ws | otherwise = first (add (wi,wa)) $ f $ Finite i ws f (Finite i _) = (Finite i mempty, return ()) add a s = s{finiteWaiting = a `cons` finiteWaiting s}@@ -109,22 +135,12 @@ sleep period act --- Make sure the pool cannot run try until after you have finished with it-blockPool :: Pool -> IO (IO ())-blockPool pool = do- bar <- newBarrier- addPoolResume pool $ do- cancel <- increasePool pool- waitBarrier bar- cancel- return $ signalBarrier bar () - data Throttle -- | Some number of resources are available = ThrottleAvailable !Int -- | Some users are blocked (non-empty), plus an action to call once we go back to Available- | ThrottleWaiting (IO ()) (Bilist (Int, IO ()))+ | ThrottleWaiting (IO ()) (Bilist (Int, Fence IO ())) -- | A version of 'Development.Shake.newThrottle' that runs in IO, and can be called before calling 'Development.Shake.shake'.@@ -139,24 +155,27 @@ where shw = "Throttle " ++ name - acquire :: Var Throttle -> Pool -> Int -> IO () -> IO ()- acquire var pool want continue+ acquire :: Var Throttle -> Pool -> Int -> IO (Maybe (Fence IO ()))+ acquire var pool want | want < 0 = errorIO $ "You cannot acquire a negative quantity of " ++ shw ++ ", requested " ++ show want | want > count = errorIO $ "You cannot acquire more than " ++ show count ++ " of " ++ shw ++ ", requested " ++ show want- | otherwise = join $ modifyVar var $ \x -> case x of+ | otherwise = modifyVar var $ \x -> case x of ThrottleAvailable i- | i >= want -> return (ThrottleAvailable $ i - want, continue)+ | i >= want -> return (ThrottleAvailable $ i - want, Nothing) | otherwise -> do- stop <- blockPool pool- return (ThrottleWaiting stop $ (want - i, addPoolResume pool continue) `cons` mempty, return ())- ThrottleWaiting stop xs -> return (ThrottleWaiting stop $ xs `snoc` (want, addPoolResume pool continue), return ())+ stop <- keepAlivePool pool+ fence <- newFence+ return (ThrottleWaiting stop $ (want - i, fence) `cons` mempty, Just fence)+ ThrottleWaiting stop xs -> do+ fence <- newFence+ return (ThrottleWaiting stop $ xs `snoc` (want, fence), Just fence) release :: Var Throttle -> Pool -> Int -> IO ()- release var pool n = waiter period $ join $ modifyVar var $ \x -> return $ case x of+ release var _ n = waiter period $ join $ modifyVar var $ \x -> return $ case x of ThrottleAvailable i -> (ThrottleAvailable $ i+n, return ()) ThrottleWaiting stop xs -> f stop n xs where f stop i (uncons -> Just ((wi,wa),ws))- | i >= wi = second (wa >>) $ f stop (i-wi) ws+ | i >= wi = second (signalFence wa () >>) $ f stop (i-wi) ws | otherwise = (ThrottleWaiting stop $ (wi-i,wa) `cons` ws, return ()) f stop i _ = (ThrottleAvailable i, stop)
+ src/Development/Shake/Internal/Rules/Default.hs view
@@ -0,0 +1,18 @@++module Development.Shake.Internal.Rules.Default(+ defaultRules+ ) where++import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Rules.Directory+import Development.Shake.Internal.Rules.File+import Development.Shake.Internal.Rules.Files+import Development.Shake.Internal.Rules.Rerun++-- All the rules baked into Shake+defaultRules :: Rules ()+defaultRules = do+ defaultRuleFile+ defaultRuleFiles+ defaultRuleDirectory+ defaultRuleRerun
src/Development/Shake/Internal/Rules/Directory.hs view
@@ -23,8 +23,9 @@ import qualified System.Environment.Extra as IO import Development.Shake.Internal.Core.Types-import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Action import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Core.Build import Development.Shake.Internal.Value import Development.Shake.Classes import Development.Shake.FilePath@@ -122,6 +123,7 @@ (\k old -> do new <- query k return $ if old == new then Nothing else Just $ show new)+ (\_ v -> runBuilder $ putEx $ witness v) (\k old _ -> liftIO $ do new <- query k let wnew = witness new@@ -317,8 +319,9 @@ IO.removeDirectory x --- | Remove files, like 'removeFiles', but executed after the build completes successfully.--- Useful for implementing @clean@ actions that delete files Shake may have open for building.+-- | Remove files, like 'removeFiles', but executed after the build completes successfully using 'runAfter'.+-- Useful for implementing @clean@ actions that delete files Shake may have open for building, e.g. 'shakeFiles'.+-- Where possible, delete the files as a normal part of the build, e.g. using @'liftIO' $ 'removeFiles' dir pats@. removeFilesAfter :: FilePath -> [FilePattern] -> Action () removeFilesAfter a b = do putLoud $ "Will remove " ++ unwords b ++ " from " ++ a
src/Development/Shake/Internal/Rules/File.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns, RecordWildCards, FlexibleInstances, TypeFamilies #-}+{-# LANGUAGE ViewPatterns, RecordWildCards, FlexibleInstances, TypeFamilies, ConstraintKinds #-} module Development.Shake.Internal.Rules.File( need, needHasChanged, needBS, needed, neededBS, want,@@ -8,13 +8,13 @@ (%>), (|%>), (?>), phony, (~>), phonys, resultHasChanged, -- * Internal only- FileQ(..), FileA, fileStoredValue, fileEqualValue, EqualCost(..), fileForward+ FileQ(..), FileA(..), fileStoredValue, fileEqualValue, EqualCost(..), fileForward ) where import Control.Applicative import Control.Monad.Extra import Control.Monad.IO.Class-import Data.Typeable+import Data.Typeable.Extra import Data.List import Data.Maybe import qualified Data.ByteString.Char8 as BS@@ -25,11 +25,10 @@ import General.Binary import General.Extra -import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Types hiding (Result, result) import Development.Shake.Internal.Core.Rules-import Development.Shake.Internal.Core.Run-import Development.Shake.Internal.Core.Action hiding (trackAllow)-import qualified Development.Shake.Internal.Core.Action as S+import Development.Shake.Internal.Core.Build+import Development.Shake.Internal.Core.Action import Development.Shake.Internal.FileName import Development.Shake.Internal.Rules.Rerun import Development.Shake.Classes@@ -61,9 +60,10 @@ 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.+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+ , useLint :: !Bool -- ^ Should we lint the resulting file+ , hasChanged :: !Bool -- ^ Whether the file changed this build. Transient -- information, that doesn't get serialized. } deriving (Typeable)@@ -77,11 +77,11 @@ -- | The results of the various 'Mode' rules. data Result = ResultPhony- | ResultDirect FileA- | ResultForward FileA+ | ResultDirect Ver FileA+ | ResultForward Ver FileA --- | The use rules we use.-newtype FileRule = FileRule (FilePath -> Maybe Mode)+-- | The file rules we use, first is the name (as pretty as you can get).+data FileRule = FileRule String (FilePath -> Maybe Mode) deriving Typeable @@ -98,7 +98,7 @@ rnf (FileA a b c) = rnf a `seq` rnf b `seq` rnf c instance NFData FileR where- rnf (FileR f b) = rnf f `seq` rnf b+ rnf (FileR a b c) = rnf a `seq` rnf b `seq` rnf c instance Show FileA where show (FileA m s h) = "File {mod=" ++ show m ++ ",size=" ++ show s ++ ",digest=" ++ show h ++ "}"@@ -122,18 +122,20 @@ fromResult :: Result -> Maybe FileA fromResult ResultPhony = Nothing-fromResult (ResultDirect x) = Just x-fromResult (ResultForward x) = Just x+fromResult (ResultDirect _ x) = Just x+fromResult (ResultForward _ x) = Just x instance BinaryEx Result where putEx ResultPhony = mempty- putEx (ResultDirect x) = putEx x- putEx (ResultForward x) = putEx (0 :: Word8) <> putEx x+ putEx (ResultDirect ver x) = putExStorable ver <> putEx x+ putEx (ResultForward ver x) = putEx (0 :: Word8) <> putExStorable ver <> putEx x getEx x = case BS.length x of 0 -> ResultPhony- 12 -> ResultDirect $ getEx x- 13 -> ResultForward $ getEx $ BS.tail x+ i -> if i == sz then f ResultDirect x else f ResultForward $ BS.tail x+ where+ sz = sizeOf (undefined :: Ver) + sizeOf (undefined :: FileA)+ f ctor x = let (a,b) = binarySplit x in ctor a $ getEx b ---------------------------------------------------------------------@@ -151,7 +153,7 @@ res <- getFileInfo x case res of Nothing -> return Nothing- Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size fileInfoNoHash+ Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size noFileHash Just (time,size) -> do hash <- unsafeInterleaveIO $ getFileHash x return $ Just $ FileA time size hash@@ -189,27 +191,43 @@ defaultRuleFile = do opts@ShakeOptions{..} <- getShakeOptionsRules -- A rule from FileQ to (Maybe FileA). The result value is only useful for linting.- addBuiltinRuleEx (ruleLint opts) (ruleRun opts $ shakeRebuildApply opts)+ addBuiltinRuleEx (ruleLint opts) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts) ruleLint :: ShakeOptions -> BuiltinLint FileQ FileR-ruleLint opts k (FileR Nothing _) = return Nothing-ruleLint opts k (FileR (Just v) _) = do+ruleLint opts k (FileR (Just v) True _) = do now <- fileStoredValue opts k return $ case now of Nothing -> Just "<missing>" Just now | fileEqualValue opts v now == EqualCheap -> Nothing | otherwise -> Just $ show now+ruleLint _ _ _ = return Nothing +ruleIdentity :: ShakeOptions -> BuiltinIdentity FileQ FileR+ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure errorNoHash+ruleIdentity _ = \k v -> case result v of+ Just (FileA _ size hash) -> runBuilder $ putExStorable size <> putExStorable hash+ Nothing -> throwImpure $ errorInternal $ "File.ruleIdentity has no result for " ++ show k+ ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ FileR-ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ x) oldBin@(fmap getEx -> old) dirtyChildren = do+ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ (fileNameToString -> xStr)) oldBin@(fmap getEx -> old :: Maybe Result) mode = 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 -- for Phony, it doesn't make that much sense, but probably isn't harmful?- let r = rebuildFlags $ fileNameToString x+ let r = rebuildFlags xStr++ (ruleVer, ruleAct, ruleErr) <- getUserRuleInternal o (\(FileRule s _) -> Just s) $ \(FileRule _ f) -> f xStr+ let verEq v = Just v == ruleVer || case ruleAct of [] -> v == Ver 0; [(v2,_)] -> v == Ver v2; _ -> False+ let rebuild = do+ putWhen Chatty $ "# " ++ show o+ case ruleAct of+ [] -> rebuildWith Nothing+ [x] -> rebuildWith $ Just x+ _ -> throwM ruleErr+ case old of _ | r == RebuildNow -> rebuild _ | r == RebuildLater -> case old of- Just old ->+ Just _ -> -- ignoring the currently stored value, which may trigger lint has changed -- so disable lint on this file unLint <$> retOld ChangedNothing@@ -218,7 +236,7 @@ now <- liftIO $ fileStoredValue opts o case now of Nothing -> rebuild- Just now -> do alwaysRerun; retNew ChangedStore $ ResultDirect now+ Just now -> do alwaysRerun; retNew ChangedStore $ ResultDirect (Ver 0) now {- _ | r == RebuildNever -> do now <- liftIO $ fileStoredValue opts o@@ -229,38 +247,37 @@ | otherwise = ChangedRecomputeDiff retNew diff $ ResultDirect now -}- Just (ResultDirect old) | not dirtyChildren -> do+ Just (ResultDirect ver old) | mode == RunDependenciesSame, verEq ver -> do now <- liftIO $ fileStoredValue opts o+ let noHash (FileA _ _ x) = isNoFileHash x case now of Nothing -> rebuild Just now -> case fileEqualValue opts old now of- EqualCheap -> retNew ChangedNothing $ ResultDirect now- EqualExpensive -> retNew ChangedStore $ ResultDirect now- NotEqual -> rebuild- Just (ResultForward old) | not dirtyChildren -> retOld ChangedNothing+ NotEqual ->+ rebuild+ -- if our last build used no file hashing, but this build should, then we must refresh the hash+ EqualCheap | if noHash old then shakeChange == ChangeModtimeAndDigestInput || noHash now else True ->+ retOld ChangedNothing+ _ ->+ retNew ChangedStore $ ResultDirect ver now+ Just (ResultForward ver _) | verEq ver, mode == RunDependenciesSame -> retOld ChangedNothing _ -> rebuild where -- no need to lint check forward files -- but more than that, it goes wrong if you do, see #427- asLint (ResultDirect x) = Just x- asLint x = Nothing- unLint (RunResult a b (FileR _ c)) = RunResult a b $ FileR Nothing c+ fileR (ResultDirect _ x) = FileR (Just x) True+ fileR (ResultForward _ x) = FileR (Just x) False+ fileR ResultPhony = FileR Nothing False+ unLint (RunResult a b c) = RunResult a b c{useLint = False} retNew :: RunChanged -> Result -> Action (RunResult FileR)- retNew c v = return $ RunResult c (runBuilder $ putEx v) (FileR (asLint v) (c == ChangedRecomputeDiff))+ retNew c v = return $ RunResult c (runBuilder $ putEx v) $ fileR v (c == ChangedRecomputeDiff) retOld :: RunChanged -> Action (RunResult FileR)- retOld c = return $ RunResult c (fromJust oldBin) $ FileR (asLint $ fromJust old) False+ retOld c = return $ RunResult c (fromJust oldBin) $ fileR (fromJust old) False -- actually run the rebuild- rebuild = do- putWhen Chatty $ "# " ++ show o- x <- return $ fileNameToString x- rules <- getUserRules- act <- case userRuleMatch rules $ \(FileRule f) -> f x of- [] -> return Nothing- [r] -> return $ Just r- rs -> liftIO $ errorMultipleRulesMatch (typeOf o) (show o) (length rs)+ rebuildWith act = do let answer ctor new = do let b = case () of _ | Just old <- old@@ -271,21 +288,32 @@ case act of Nothing -> do new <- liftIO $ storedValueError opts True "Error, file does not exist and no rule available:" o- answer ResultDirect $ fromJust new- Just (ModeForward act) -> do+ answer (ResultDirect $ Ver 0) $ fromJust new+ Just (ver, ModeForward act) -> do new <- act case new of Nothing -> do alwaysRerun retNew ChangedRecomputeDiff ResultPhony- Just new -> answer ResultForward new- Just (ModeDirect act) -> do- act- 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- Just (ModePhony act) -> do+ Just new -> answer (ResultForward $ Ver ver) new+ Just (ver, ModeDirect act) -> do+ cache <- historyLoad ver+ case cache of+ Just encodedHash -> do+ Just (FileA mod size _) <- liftIO $ storedValueError opts False "Error, restored the rule but did not produce file:" o+ answer (ResultDirect $ Ver ver) $ FileA mod size $ getExStorable encodedHash+ Nothing -> do+ act+ new <- liftIO $ storedValueError opts False "Error, rule finished running but did not produce file:" o+ case new of+ Nothing -> retNew ChangedRecomputeDiff ResultPhony+ Just new@(FileA _ _ fileHash) -> do+ producesUnchecked [xStr]+ res <- answer (ResultDirect $ Ver ver) new+ historySave ver $ runBuilder $+ if isNoFileHash fileHash then throwImpure errorNoHash else putExStorable fileHash+ return res+ Just (_, ModePhony act) -> do -- See #523 and #524 -- Shake runs the dependencies first, but stops when one has changed. -- We don't want to run the existing deps first if someone changes the build system,@@ -295,7 +323,7 @@ retNew ChangedRecomputeDiff ResultPhony -apply_ :: (a -> FileName) -> [a] -> Action [FileR]+apply_ :: Partial => (a -> FileName) -> [a] -> Action [FileR] apply_ f = apply . map (FileQ . f) @@ -325,8 +353,8 @@ -- OPTIONS ON TOP -- | Internal method for adding forwarding actions-fileForward :: (FilePath -> Maybe (Action (Maybe FileA))) -> Rules ()-fileForward act = addUserRule $ FileRule $ fmap ModeForward . act+fileForward :: String -> (FilePath -> Maybe (Action (Maybe FileA))) -> Rules ()+fileForward help act = addUserRule $ FileRule help $ fmap ModeForward . act -- | Add a dependency on the file arguments, ensuring they are built before continuing.@@ -346,8 +374,8 @@ -- This function should not be called with wildcards (e.g. @*.txt@ - use 'getDirectoryFiles' to expand them), -- environment variables (e.g. @$HOME@ - use 'getEnv' to expand them) or directories (directories cannot be -- tracked directly - track files within the directory instead).-need :: [FilePath] -> Action ()-need = void . apply_ fileNameFromString+need :: Partial => [FilePath] -> Action ()+need = withFrozenCallStack $ void . apply_ fileNameFromString -- | Like 'need' but returns a list of rebuild dependencies this build.@@ -367,38 +395,38 @@ -- 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+needHasChanged :: Partial => [FilePath] -> Action [FilePath]+needHasChanged paths = withFrozenCallStack $ do res <- apply_ fileNameFromString paths return [a | (a,b) <- zip paths res, hasChanged b] -needBS :: [BS.ByteString] -> Action ()-needBS = void . apply_ fileNameFromByteString+needBS :: Partial => [BS.ByteString] -> Action ()+needBS = withFrozenCallStack $ 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 ()-needed xs = do+needed :: Partial => [FilePath] -> Action ()+needed xs = withFrozenCallStack $ do opts <- getShakeOptions if isNothing $ shakeLint opts then need xs else neededCheck $ map fileNameFromString xs -neededBS :: [BS.ByteString] -> Action ()-neededBS xs = do+neededBS :: Partial => [BS.ByteString] -> Action ()+neededBS xs = withFrozenCallStack $ do opts <- getShakeOptions if isNothing $ shakeLint opts then needBS xs else neededCheck $ map fileNameFromByteString xs -neededCheck :: [FileName] -> Action ()-neededCheck xs = do+neededCheck :: Partial => [FileName] -> Action ()+neededCheck xs = withFrozenCallStack $ do opts <- getShakeOptions 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, FileR (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+ (file,msg):_ -> throwM $ errorStructured "Lint checking error - 'needed' file required rebuilding" [("File", Just $ fileNameToString file) ,("Error",Just msg)]@@ -409,21 +437,18 @@ -- then these files must be dependencies of this rule. Calls to 'trackRead' are -- automatically inserted in 'LintFSATrace' mode. trackRead :: [FilePath] -> Action ()-trackRead = mapM_ (trackUse . FileQ . fileNameFromString)+trackRead = lintTrackRead . map (FileQ . fileNameFromString) -- | Track that a file was written by the action preceeding it. If 'shakeLint' is activated -- then these files must either be the target of this rule, or never referred to by the build system. -- Calls to 'trackWrite' are automatically inserted in 'LintFSATrace' mode. trackWrite :: [FilePath] -> Action ()-trackWrite = mapM_ (trackChange . FileQ . fileNameFromString)+trackWrite = lintTrackWrite . map (FileQ . fileNameFromString) -- | Allow accessing a file in this rule, ignoring any 'trackRead' \/ 'trackWrite' calls matching -- the pattern. trackAllow :: [FilePattern] -> Action ()-trackAllow ps = do- opts <- getShakeOptions- when (isJust $ shakeLint opts) $- S.trackAllow $ \(FileQ x) -> any (?== fileNameToString x) ps+trackAllow ps = lintTrackAllow $ \(FileQ x) -> any (?== fileNameToString x) ps -- | Require that the argument files are built by the rules, used to specify the target.@@ -439,13 +464,13 @@ -- -- This function is defined in terms of 'action' and 'need', use 'action' if you need more complex -- targets than 'want' allows.-want :: [FilePath] -> Rules ()+want :: Partial => [FilePath] -> Rules () want [] = return ()-want xs = action $ need xs+want xs = withFrozenCallStack $ action $ need xs root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-root help test act = addUserRule $ FileRule $ \x -> if not $ test x then Nothing else Just $ ModeDirect $ do+root help test act = addUserRule $ FileRule help $ \x -> if not $ test x then Nothing else Just $ ModeDirect $ do liftIO $ createDirectoryRecursive $ takeDirectory x act x @@ -468,19 +493,24 @@ -- question, a Shake rule which behaves this way will fail lint. -- Use a phony rule! For file-producing rules which should be -- rerun every execution of Shake, see 'Development.Shake.alwaysRerun'.-phony :: String -> Action () -> Rules ()-phony (toStandard -> name) act = phonys $ \s -> if s == name then Just act else Nothing+phony :: Located => String -> Action () -> Rules ()+phony oname@(toStandard -> name) act =+ addPhony ("phony " ++ show oname ++ " at " ++ callStackTop) $ \s -> if s == name then Just act else Nothing -- | A predicate version of 'phony', return 'Just' with the 'Action' for the matching rules.-phonys :: (String -> Maybe (Action ())) -> Rules ()-phonys act = addUserRule $ FileRule $ fmap ModePhony . act+phonys :: Located => (String -> Maybe (Action ())) -> Rules ()+phonys = addPhony ("phonys at " ++ callStackTop) -- | Infix operator alias for 'phony', for sake of consistency with normal -- rules.-(~>) :: String -> Action () -> Rules ()-(~>) = phony+(~>) :: Located => String -> Action () -> Rules ()+(~>) oname@(toStandard -> name) act =+ addPhony (show oname ++ " ~> at " ++ callStackTop) $ \s -> if s == name then Just act else Nothing +addPhony :: String -> (String -> Maybe (Action ())) -> Rules ()+addPhony help act = addUserRule $ FileRule help $ fmap ModePhony . act + -- | Define a rule to build files. If the first argument returns 'True' for a given file, -- the second argument will be used to build it. Usually '%>' is sufficient, but '?>' gives -- additional power. For any file used by the build system, only one rule should return 'True'.@@ -494,21 +524,22 @@ -- -- If the 'Action' completes successfully the file is considered up-to-date, even if the file -- has not changed.-(?>) :: (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-(?>) test act = priority 0.5 $ root "with ?>" test act+(?>) :: Located => (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()+(?>) test act = priority 0.5 $ root ("?> at " ++ callStackTop) test act -- | Define a set of patterns, and if any of them match, run the associated rule. Defined in terms of '%>'. -- Think of it as the OR (@||@) equivalent of '%>'.-(|%>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()+(|%>) :: Located => [FilePattern] -> (FilePath -> Action ()) -> Rules () (|%>) pats act = do let (simp,other) = partition simple pats- case simp of+ case map toStandard simp of [] -> return ()- [p] -> let pp = toStandard p in root "with |%>" (\x -> toStandard x == pp) act- ps -> let ps = Set.fromList $ map toStandard pats in root "with |%>" (flip Set.member ps . toStandard) act+ [p] -> root help (\x -> toStandard x == p) act+ ps -> let set = Set.fromList ps in root help (flip Set.member set . toStandard) act unless (null other) $- let ps = map (?==) other in priority 0.5 $ root "with |%>" (\x -> any ($ x) ps) act+ let ps = map (?==) other in priority 0.5 $ root help (\x -> any ($ x) ps) act+ where help = show pats ++ " |%> at " ++ callStackTop -- | Define a rule that matches a 'FilePattern', see '?==' for the pattern rules. -- Patterns with no wildcards have higher priority than those with wildcards, and no file@@ -531,5 +562,5 @@ -- -- If the 'Action' completes successfully the file is considered up-to-date, even if the file -- has not changed.-(%>) :: FilePattern -> (FilePath -> Action ()) -> Rules ()-(%>) test act = (if simple test then id else priority 0.5) $ root (show test) (test ?==) act+(%>) :: Located => FilePattern -> (FilePath -> Action ()) -> Rules ()+(%>) test act = withFrozenCallStack $ (if simple test then id else priority 0.5) $ root (show test ++ " %> at " ++ callStackTop) (test ?==) act
src/Development/Shake/Internal/Rules/Files.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns, TypeFamilies #-}+{-# LANGUAGE ViewPatterns, TypeFamilies, ConstraintKinds #-} module Development.Shake.Internal.Rules.Files( (&?>), (&%>), defaultRuleFiles@@ -12,13 +12,12 @@ import Control.Applicative import Data.Typeable.Extra import General.Binary-import Prelude -import Development.Shake.Internal.Errors-import Development.Shake.Internal.Core.Action hiding (trackAllow)-import Development.Shake.Internal.Core.Run-import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Action+import Development.Shake.Internal.Core.Types hiding (Result)+import Development.Shake.Internal.Core.Build import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Errors import General.Extra import Development.Shake.Internal.FileName import Development.Shake.Classes@@ -26,7 +25,10 @@ import Development.Shake.Internal.Rules.File import Development.Shake.Internal.FilePattern import Development.Shake.FilePath+import Development.Shake.Internal.FileInfo import Development.Shake.Internal.Options+import Data.Monoid+import Prelude infix 1 &?>, &%>@@ -44,7 +46,16 @@ instance Show FilesQ where show (FilesQ xs) = unwords $ map (wrapQuote . show) xs +data FilesRule = FilesRule String (FilesQ -> Maybe (Action FilesA))+ deriving Typeable +data Result = Result Ver FilesA++instance BinaryEx Result where+ putEx (Result v x) = putExStorable v <> putEx x+ getEx s = let (a,b) = binarySplit s in Result a $ getEx b++ filesStoredValue :: ShakeOptions -> FilesQ -> IO (Maybe FilesA) filesStoredValue opts (FilesQ xs) = fmap FilesA . sequence <$> mapM (fileStoredValue opts) xs @@ -52,7 +63,7 @@ filesEqualValue opts (FilesA xs) (FilesA ys) | length xs /= length ys = NotEqual | otherwise = foldr and_ EqualCheap $ zipWith (fileEqualValue opts) xs ys- where and_ NotEqual x = NotEqual+ where and_ NotEqual _ = NotEqual and_ EqualCheap x = x and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive @@ -60,10 +71,10 @@ defaultRuleFiles = do opts <- getShakeOptionsRules -- A rule from FilesQ to FilesA. The result value is only useful for linting.- addBuiltinRuleEx (ruleLint opts) (ruleRun opts $ shakeRebuildApply opts)+ addBuiltinRuleEx (ruleLint opts) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts) ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA-ruleLint opts k (FilesA []) = return Nothing -- in the case of disabling lint+ruleLint _ _ (FilesA []) = return Nothing -- in the case of disabling lint ruleLint opts k v = do now <- filesStoredValue opts k return $ case now of@@ -71,13 +82,30 @@ Just now | filesEqualValue opts v now == EqualCheap -> Nothing | otherwise -> Just $ show now +ruleIdentity :: ShakeOptions -> BuiltinIdentity FilesQ FilesA+ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure $ errorStructured+ "Cannot use shakeChange=ChangeModTime with shakeShare" [] ""+ruleIdentity _ = \_ (FilesA files) ->+ runBuilder $ putExList [putExStorable size <> putExStorable hash | FileA _ size hash <- files]+++ ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA-ruleRun opts rebuildFlags k o@(fmap getEx -> old) dirtyChildren = do+ruleRun opts rebuildFlags k o@(fmap getEx -> old :: Maybe Result) mode = do let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k++ (ruleVer, ruleAct, ruleErr) <- getUserRuleInternal k (\(FilesRule s _) -> Just s) $ \(FilesRule _ f) -> f k+ let verEq v = Just v == ruleVer || map (Ver . fst) ruleAct == [v]+ let rebuild = do+ putWhen Chatty $ "# " ++ show k+ case ruleAct of+ [x] -> rebuildWith x+ _ -> throwM ruleErr+ case old of _ | RebuildNow `elem` r -> rebuild _ | RebuildLater `elem` r -> case old of- Just old ->+ Just _ -> -- ignoring the currently stored value, which may trigger lint has changed -- so disable lint on this file return $ RunResult ChangedNothing (fromJust o) $ FilesA []@@ -86,26 +114,33 @@ now <- liftIO $ filesStoredValue opts k case now of Nothing -> rebuild- Just now -> do alwaysRerun; return $ RunResult ChangedStore (runBuilder $ putEx now) now- Just old | not dirtyChildren -> do+ Just now -> do alwaysRerun; return $ RunResult ChangedStore (runBuilder $ putEx $ Result (Ver 0) now) now+ Just (Result ver old) | mode == RunDependenciesSame, verEq ver -> do v <- liftIO $ filesStoredValue opts k case v of Just v -> case filesEqualValue opts old v of NotEqual -> rebuild EqualCheap -> return $ RunResult ChangedNothing (fromJust o) v- EqualExpensive -> return $ RunResult ChangedStore (runBuilder $ putEx v) v+ EqualExpensive -> return $ RunResult ChangedStore (runBuilder $ putEx $ Result ver v) v Nothing -> rebuild _ -> rebuild where- rebuild = do- putWhen Chatty $ "# " ++ show k- rules :: UserRule (FilesQ -> Maybe (Action FilesA)) <- getUserRules- v <- case userRuleMatch rules ($ k) of- [r] -> r- rs -> liftIO $ errorMultipleRulesMatch (typeOf k) (show k) (length rs)- let c | Just old <- old, filesEqualValue opts old v /= NotEqual = ChangedRecomputeSame- | otherwise = ChangedRecomputeDiff- return $ RunResult c (runBuilder $ putEx v) v+ rebuildWith (ver, act) = do+ cache <- historyLoad ver+ v <- case cache of+ Just res ->+ fmap FilesA $ forM (zip (getExList res) (fromFilesQ k)) $ \(bin, file) -> do+ Just (FileA mod size _) <- liftIO $ fileStoredValue opts file+ return $ FileA mod size $ getExStorable bin+ Nothing -> do+ FilesA v <- act+ producesUnchecked $ map (fileNameToString . fromFileQ) $ fromFilesQ k+ historySave ver $ runBuilder $ putExList+ [if isNoFileHash hash then throwImpure errorNoHash else putExStorable hash | FileA _ _ hash <- v]+ return $ FilesA v+ let c | Just (Result _ old) <- old, filesEqualValue opts old v /= NotEqual = ChangedRecomputeSame+ | otherwise = ChangedRecomputeDiff+ return $ RunResult c (runBuilder $ putEx $ Result (Ver ver) v) v @@ -124,20 +159,20 @@ -- on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must -- have the same sequence of @\/\/@ and @*@ wildcards in the same order. -- This function will create directories for the result files, if necessary.-(&%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()-[p] &%> act = p %> act . return+(&%>) :: Located => [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()+[p] &%> act = withFrozenCallStack $ p %> act . return ps &%> act | not $ compatible ps = error $ unlines $ "All patterns to &%> must have the same number and position of // and * wildcards" : ["* " ++ p ++ (if compatible [p, head ps] then "" else " (incompatible)") | p <- ps]- | otherwise = do- forM_ (zip [0..] ps) $ \(i,p) ->+ | otherwise = withFrozenCallStack $ do+ forM_ (zipFrom 0 ps) $ \(i,p) -> (if simple p then id else priority 0.5) $- fileForward $ let op = (p ?==) in \file -> if not $ op file then Nothing else Just $ do+ fileForward (show ps ++ " &%> at " ++ callStackTop) $ let op = (p ?==) in \file -> if not $ op file then Nothing else Just $ do FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString . substitute (extract p file)) ps return $ if null res then Nothing else Just $ res !! i (if all simple ps then id else priority 0.5) $- addUserRule $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in+ addUserRule $ FilesRule (show ps ++ " &%> " ++ callStackTop) $ \(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_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs trackAllow xs@@ -154,6 +189,7 @@ -- -- > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys --+-- Intuitively, the function defines a set partitioning, mapping each element to the partition that contains it. -- As an example of a function satisfying the invariaint: -- -- @@@ -163,7 +199,7 @@ -- @ -- -- Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.-(&?>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()+(&?>) :: Located => (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules () (&?>) test act = priority 0.5 $ do let inputOutput suf inp out = ["Input" ++ suf ++ ":", " " ++ inp] ++@@ -180,13 +216,13 @@ inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad) Just ys -> Just ys - fileForward $ \x -> case checkedTest x of+ fileForward ("&?> at " ++ callStackTop) $ \x -> case checkedTest x of Nothing -> Nothing Just ys -> Just $ do FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString) ys return $ if null res then Nothing else Just $ res !! fromJust (elemIndex x ys) - addUserRule $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in+ addUserRule $ FilesRule ("&?> " ++ callStackTop) $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in case checkedTest x of Just ys | ys == xs -> Just $ do liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs
src/Development/Shake/Internal/Rules/Oracle.hs view
@@ -2,18 +2,21 @@ {-# LANGUAGE TypeFamilies, ConstraintKinds #-} module Development.Shake.Internal.Rules.Oracle(- addOracle, addOracleCache, askOracle+ addOracle, addOracleCache, addOracleHash, askOracle ) where -import Development.Shake.Internal.Core.Run import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Rules import Development.Shake.Internal.Options+import Development.Shake.Internal.Core.Build import Development.Shake.Internal.Value import Development.Shake.Classes import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS+import Control.Monad import Data.Binary+import General.Binary+import General.Extra import Control.Applicative import Prelude @@ -26,24 +29,42 @@ type instance RuleResult (OracleQ a) = OracleA (RuleResult a) +data Flavor = Norm | Cache | Hash deriving Eq -addOracleRaw :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => Bool -> (q -> Action a) -> Rules (q -> Action a)-addOracleRaw cache act = do+addOracleFlavor :: (Located, RuleResult q ~ a, ShakeValue q, ShakeValue a) => Flavor -> (q -> Action a) -> Rules (q -> Action a)+addOracleFlavor flavor act = do -- rebuild is automatic for oracles, skip just means we don't rebuild opts <- getShakeOptionsRules let skip = shakeRebuildApply opts "" == RebuildLater - addBuiltinRule noLint $ \(OracleQ q) old changed -> case old of- Just old | skip || (cache && not changed) ->+ addBuiltinRule noLint (\_ v -> runBuilder $ putEx $ hash v) $ \(OracleQ q) old mode -> case old of+ Just old | (flavor /= Hash && skip) || (flavor == Cache && mode == RunDependenciesSame) -> return $ RunResult ChangedNothing old $ decode' old _ -> do- new <- OracleA <$> act q- return $ RunResult- (if fmap decode' old == Just new then ChangedRecomputeSame else ChangedRecomputeDiff)- (encode' new)- new+ -- can only use cmpHash if flavor == Hash+ let cmpValue new = if fmap decode' old == Just new then ChangedRecomputeSame else ChangedRecomputeDiff+ let cmpHash newHash = if old == Just newHash then ChangedRecomputeSame else ChangedRecomputeDiff++ cache <- if flavor == Cache then historyLoad 0 else return Nothing+ case cache of+ Just newEncode -> do+ let new = decode' newEncode+ return $ RunResult (cmpValue new) newEncode new+ Nothing -> do+ new <- OracleA <$> act q+ let newHash = encodeHash new+ let newEncode = encode' new+ when (flavor == Cache) $+ historySave 0 newEncode+ return $+ if flavor == Hash+ then RunResult (cmpHash newHash) newHash new+ else RunResult (cmpValue new) newEncode new return askOracle where+ encodeHash :: Hashable a => a -> BS.ByteString+ encodeHash = runBuilder . putEx . hash+ encode' :: Binary a => a -> BS.ByteString encode' = BS.concat . LBS.toChunks . encode @@ -78,9 +99,6 @@ -- If the result of an oracle does not change it will not invalidate any rules depending on it. -- To always rerun files rules see 'Development.Shake.alwaysRerun'. ----- * If the value returned by 'askOracle' is ignored then 'askOracleWith' may help avoid ambiguous type messages.--- Alternatively, use the result of 'addOracle', which is 'askOracle' restricted to the correct type.--- -- As a more complex example, consider tracking Haskell package versions: -- -- @@@ -105,9 +123,17 @@ -- -- Using these definitions, any rule depending on the version of @shake@ -- should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.-addOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a)-addOracle = addOracleRaw False+--+-- If you apply 'versioned' to an oracle it will cause that oracle result to be discarded, and not do early-termination.+addOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a, Partial) => (q -> Action a) -> Rules (q -> Action a)+addOracle = withFrozenCallStack $ addOracleFlavor Norm ++-- | An alternative to to 'addOracle' that relies on the 'hash' function providing a perfect equality,+-- doesn't support @--skip@, but requires less storage.+addOracleHash :: (RuleResult q ~ a, ShakeValue q, ShakeValue a, Partial) => (q -> Action a) -> Rules (q -> Action a)+addOracleHash = withFrozenCallStack $ addOracleFlavor Hash+ -- | A combination of 'addOracle' and 'newCache' - an action that only runs when its dependencies change, -- whose result is stored in the database. --@@ -121,8 +147,8 @@ -- An alternative to using 'addOracleCache' is introducing an intermediate file containing the result, -- which requires less storage in the Shake database and can be inspected by existing file-system viewing -- tools.-addOracleCache ::(RuleResult q ~ a, ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a)-addOracleCache = addOracleRaw True+addOracleCache ::(RuleResult q ~ a, ShakeValue q, ShakeValue a, Partial) => (q -> Action a) -> Rules (q -> Action a)+addOracleCache = withFrozenCallStack $ addOracleFlavor Cache -- | Get information previously added with 'addOracle' or 'addOracleCache'.
src/Development/Shake/Internal/Rules/OrderOnly.hs view
@@ -3,7 +3,8 @@ orderOnly, orderOnlyBS ) where -import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Action import Development.Shake.Internal.Rules.File import qualified Data.ByteString.Char8 as BS
src/Development/Shake/Internal/Rules/Rerun.hs view
@@ -5,9 +5,10 @@ defaultRuleRerun, alwaysRerun ) where -import Development.Shake.Internal.Core.Run import Development.Shake.Internal.Core.Rules import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Build+import Development.Shake.Internal.Core.Action import Development.Shake.Classes import qualified Data.ByteString as BS import General.Binary@@ -35,9 +36,11 @@ -- Note that 'alwaysRerun' is applied when a rule is executed. Modifying an existing rule -- to insert 'alwaysRerun' will /not/ cause that rule to rerun next time. alwaysRerun :: Action ()-alwaysRerun = apply1 $ AlwaysRerunQ ()+alwaysRerun = do+ historyDisable+ apply1 $ AlwaysRerunQ () defaultRuleRerun :: Rules () defaultRuleRerun =- addBuiltinRuleEx noLint $+ addBuiltinRuleEx noLint noIdentity $ \AlwaysRerunQ{} _ _ -> return $ RunResult ChangedRecomputeDiff BS.empty ()
− src/Development/Shake/Internal/Shake.hs
@@ -1,30 +0,0 @@---- | The main entry point that calls all the default rules-module Development.Shake.Internal.Shake(shake) where--import Development.Shake.Internal.Options-import General.Timing-import Development.Shake.Internal.Core.Run-import Development.Shake.Internal.Core.Rules--import Development.Shake.Internal.Rules.Directory-import Development.Shake.Internal.Rules.File-import Development.Shake.Internal.Rules.Files-import Development.Shake.Internal.Rules.Rerun----- | Main entry point for running Shake build systems. For an example see the top of the module "Development.Shake".--- Use 'ShakeOptions' to specify how the system runs, and 'Rules' to specify what to build. The function will throw--- an exception if the build fails.------ To use command line flags to modify 'ShakeOptions' see 'Development.Shake.shakeArgs'.-shake :: ShakeOptions -> Rules () -> IO ()-shake opts r = do- addTiming "Function shake"- run opts $ do- r- defaultRuleFile- defaultRuleFiles- defaultRuleDirectory- defaultRuleRerun- return ()
src/Development/Shake/Internal/Value.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE ExistentialQuantification, RecordWildCards, ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ConstraintKinds #-} -- | This module implements the Key/Value types, to abstract over hetrogenous data types. module Development.Shake.Internal.Value(- QTypeRep(..), Value, newValue, fromValue, Key, newKey, fromKey, typeKey, ShakeValue@@ -13,25 +12,10 @@ import Development.Shake.Internal.Errors import Data.Typeable.Extra -import Numeric import Data.Bits import Unsafe.Coerce --- | Like TypeRep, but the Show includes enough information to be unique--- so I can rely on @a == b === show a == show b@.-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) "" ++ "}"-- -- | Define an alias for the six type classes required for things involved in Shake rules. -- Using this alias requires the @ConstraintKinds@ extension. --@@ -97,13 +81,13 @@ fromKey :: forall a . Typeable a => Key -> a fromKey Key{..} | keyType == resType = unsafeCoerce keyValue- | otherwise = errorInternal $ "fromKey, bad cast, have " ++ show keyType ++ ", wanted " ++ show resType+ | otherwise = throwImpure $ errorInternal $ "fromKey, bad cast, have " ++ show keyType ++ ", wanted " ++ show resType where resType = typeRep (Proxy :: Proxy a) fromValue :: forall a . Typeable a => Value -> a fromValue Value{..} | valueType == resType = unsafeCoerce valueValue- | otherwise = errorInternal $ "fromValue, bad cast, have " ++ show valueType ++ ", wanted " ++ show resType+ | otherwise = throwImpure $ errorInternal $ "fromValue, bad cast, have " ++ show valueType ++ ", wanted " ++ show resType where resType = typeRep (Proxy :: Proxy a) instance Show Key where
src/Development/Shake/Rule.hs view
@@ -1,19 +1,144 @@ --- | This module is used for defining new types of rules for Shake build systems.--- Most users will find the built-in set of rules sufficient.+-- | This module is used for defining new types of rules for Shake build systems, e.g. to support values stored in a database.+-- Most users will find the built-in set of rules sufficient. The functions in this module are designed for high-performance,+-- not ease of use or abstraction. As a result, they are difficult to work with and change more often than the other parts of Shake.+-- Before writing a builtin rule you are encouraged to use 'Development.Shake.addOracle' or 'Development.Shake.addOracleCache' if possible.+-- With all those warnings out the way, read on for the grungy details. module Development.Shake.Rule(+ -- * Builtin rules+ -- $builtin_rules++ -- ** Extensions+ -- $extensions++ -- ** Worked example+ -- $example+ -- * Defining builtin rules+ -- | Functions and types for defining new types of Shake rules. addBuiltinRule,- BuiltinLint, noLint, BuiltinRun, RunChanged(..), RunResult(..),+ BuiltinLint, noLint, BuiltinIdentity, noIdentity, BuiltinRun, RunMode(..), RunChanged(..), RunResult(..), -- * Calling builtin rules+ -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule. apply, apply1, -- * User rules- UserRule(..), addUserRule, getUserRules, userRuleMatch,+ -- | Define user rules that can be used by builtin rules.+ -- Absent any builtin rule making use of a user rule at a given type, a user rule will have on effect -+ -- they have no inherent effect or interpretation on their own.+ addUserRule, getUserRuleList, getUserRuleMaybe, getUserRuleOne, -- * Lint integration- trackUse, trackChange, trackAllow+ -- | Provide lint warnings when running code.+ lintTrackRead, lintTrackWrite, lintTrackAllow,+ -- * History caching+ -- | Interact with the non-local cache. When using the cache it is important that all+ -- rules have accurate 'BuiltinIdentity' functions.+ historyIsEnabled, historySave, historyLoad ) where import Development.Shake.Internal.Core.Types import Development.Shake.Internal.Core.Action-import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Build import Development.Shake.Internal.Core.Rules++-- $builtin_rules+--+-- Shake \"Builtin\" rules are ones map keys to values - e.g. files to file contents. For each builtin rule you need to think:+--+-- * What is the @key@ type, which uniquely identifies each location, e.g. a filename.+--+-- * What is the @value@ type. The @value@ is not necessarily the full value, but is the result people can get if they ask+-- for the value associated with the @key@. As an example, for files when you 'need' a file you don't get any value back from+-- the file, so a simple file rule could have @()@ as its value.+--+-- * What information is stored between runs. This information should be sufficient to check if the value has changed since last time,+-- e.g. the modification time for files.+--+-- Typically a custom rule will define a wrapper of type 'Rules' that calls 'addBuiltinRule', along with a type-safe wrapper over+-- 'apply' so users can introduce dependencies.++-- $extensions+--+-- Once you have implemented the basic functionality there is more scope for embracing additional features of Shake, e.g.:+--+-- * You can integrate with cached history by providing a working 'BuiltinIdentity' and using 'historySave' and 'historyLoad'.+--+-- * You can let users provide their own rules which you interpret with 'addUserRule'.+--+-- * You can integrate with linting by specifying a richer 'BuiltinLint' and options like 'lintTrackRead'.+--+-- There are lots of rules defined in the Shake repo at <https://github.com/ndmitchell/shake/tree/master/src/Development/Shake/Internal/Rules>.+-- You are encouraged to read those for inspiration.++-- $example+--+-- Shake provides a very comprehensive file rule which currently runs to over 500 lines of code, and supports lots of features+-- and optimisations. However, let's imagine we want to define a simpler rule type for files. As mentioned earlier, we have to make some decisions.+--+-- * A @key@ will just be the file name.+--+-- * A @value@ will be @()@ - when the user depends on a file they don't expect any information in return.+--+-- * The stored information will be the contents of the file, in it's entirety. Alternative choices would be the modtime or a hash of the contents,+-- but Shake doesn't require that. The stored information in Shake must be stored in a 'ByteString', so we 'Data.ByteString.pack' and+-- 'Data.ByteString.unpack' to convert.+--+-- * We will allow user rules to be defined saying how to build any individual file.+--+-- First we define the type of key and value, deriving all the necessary type classes. We define a @newtype@ over 'FilePath' so we can+-- guarantee not to conflict with anyone else. Typically you wouldn't export the @File@ type, providing only sugar functions over it.+--+-- > newtype File = File FilePath+-- > deriving (Show,Eq,Hashable,Binary,NFData)+-- > type instance RuleResult File = ()+--+-- Since we have decided we are also going to have user rules, we need to define a new type to capture the information stored by the rules.+-- We need to store at least the file it is producing and the action, which we do with:+--+-- > data FileRule = FileRule File (Action ())+--+-- With the definitions above users could call 'apply' and 'addUserRule' directly, but that's tedious and not very type safe. To make it easier+-- we introduce some helpers:+--+-- > fileRule :: FilePath -> Action () -> Rules ()+-- > fileRule file act = addUserRule $ FileRule (File file) act+-- >+-- > fileNeed :: FilePath -> Action ()+-- > fileNeed = apply1 . File+--+-- These helpers just add our type names, providing a more pleasant interface for the user. Using these function we can+-- exercise our build system with:+--+-- > example = do+-- > fileRule "a.txt" $ return ()+-- > fileRule "b.txt" $ do+-- > fileNeed "a.txt"+-- > liftIO $ writeFile "b.txt" . reverse =<< readFile "a.txt"+-- >+-- > action $ fileNeed "b.txt"+--+-- This example defines rules for @a.txt@ (a source file) and @b.txt@ (the 'reverse' of @a.txt@). At runtime this example will+-- complain about not having a builtin rule for @File@, so the only thing left is to provide one.+--+-- > addBuiltinFileRule :: Rules ()+-- > addBuiltinFileRule = addBuiltinRule noLint noIdentity run+-- > where+-- > fileContents (File x) = do b <- IO.doesFileExist x; if b then IO.readFile' x else return ""+-- >+-- > run :: BuiltinRun File ()+-- > run key old mode = do+-- > now <- liftIO $ fileContents key+-- > if mode == RunDependenciesSame && fmap BS.unpack old == Just now then+-- > return $ RunResult ChangedNothing (BS.pack now) ()+-- > else do+-- > (_, act) <- getUserRuleOne key (const Nothing) $ \(FileRule k act) -> if k == key then Just act else Nothing+-- > act+-- > now <- liftIO $ fileContents key+-- > return $ RunResult ChangedRecomputeDiff (BS.pack now) ()+--+-- We define a wrapper @addBuiltinFileRule@ that calls @addBuiltinRule@, opting out of linting and cached storage.+-- The only thing we provide is a 'BuiltinRun' function which gets the previous state, and whether any dependency has changed,+-- and decides whether to rebuild. If something has changed we call 'getUserRuleOne' to find the users rule and rerun it.+-- The 'RunResult' says what changed (either 'ChangedNothing' or 'ChangedRecomputeDiff' in our cases), gives us a new stored value+-- (just packing the contents) and the @value@ which is @()@.+--+-- To execute our example we need to also call @addBuiltinFileRule@, and now everything works.
− src/General/Bag.hs
@@ -1,40 +0,0 @@---- | A bag of elements that you can pull at either deterministically or randomly.-module General.Bag(- Bag, Randomly,- emptyPure, emptyRandom,- insert, remove- ) where--import qualified Data.HashMap.Strict as Map-import System.Random---- Monad for random (but otherwise pure) computations-type Randomly a = IO a--data Bag a- = BagPure [a]- | BagRandom {-# UNPACK #-} !Int (Map.HashMap Int a)- -- HashMap has O(n) Map.size so we record it separately--emptyPure :: Bag a-emptyPure = BagPure []--emptyRandom :: Bag a-emptyRandom = BagRandom 0 Map.empty--insert :: a -> Bag a -> Bag a-insert x (BagPure xs) = BagPure $ x:xs-insert x (BagRandom n mp) = BagRandom (n+1) $ Map.insert n x mp--remove :: Bag a -> Maybe (Randomly (a, Bag a))-remove (BagPure []) = Nothing-remove (BagPure (x:xs)) = Just $ return (x, BagPure xs)-remove (BagRandom n mp)- | n == 0 = Nothing- | n == 1 = Just $ return (mp Map.! 0, emptyRandom)- | otherwise = Just $ do- i <- randomRIO (0, n-1)- let mp2 | i == n-1 = Map.delete i mp- | otherwise = Map.insert i (mp Map.! (n-1)) $ Map.delete (n-1) mp- return (mp Map.! i, BagRandom (n-1) mp2)
src/General/Binary.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE FlexibleInstances, ExplicitForAll, ScopedTypeVariables, Rank2Types #-} module General.Binary(- BinaryOp(..),+ BinaryOp(..), binaryOpMap, binarySplit, binarySplit2, binarySplit3, unsafeBinarySplit, Builder(..), runBuilder, sizeBuilder, BinaryEx(..),- putExStorable, getExStorable, putExStorableList, getExStorableList,+ Storable, putExStorable, getExStorable, putExStorableList, getExStorableList, putExList, getExList, putExN, getExN ) where +import Development.Shake.Classes import Control.Monad import Data.Binary import Data.List.Extra@@ -36,6 +37,13 @@ ,getOp :: BS.ByteString -> v } +binaryOpMap :: (Eq a, Hashable a, BinaryEx a) => (a -> BinaryOp b) -> BinaryOp (a, b)+binaryOpMap mp = BinaryOp+ {putOp = \(a, b) -> putExN (putEx a) <> putOp (mp a) b+ ,getOp = \bs -> let (bs1,bs2) = getExN bs; a = getEx bs1 in (a, getOp (mp a) bs2)+ }++ binarySplit :: forall a . Storable a => BS.ByteString -> (a, BS.ByteString) binarySplit bs | BS.length bs < sizeOf (undefined :: a) = error "Reading from ByteString, insufficient left" | otherwise = unsafeBinarySplit bs@@ -91,7 +99,7 @@ instance BinaryEx LBS.ByteString where putEx x = Builder (fromIntegral $ LBS.length x) $ \ptr i -> do- let go i [] = return ()+ let go _ [] = return () go i (x:xs) = do let n = BS.length x BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)@@ -191,7 +199,7 @@ -- BS putExList :: [Builder] -> Builder putExList xs = Builder (sum $ map (\b -> sizeBuilder b + 4) xs) $ \p i -> do- let go i [] = return ()+ let go _ [] = return () go i (Builder n b:xs) = do pokeByteOff p i (fromIntegral n :: Word32) b p (i+4)
src/General/Chunks.hs view
@@ -2,8 +2,9 @@ module General.Chunks( Chunks,- readChunk, readChunkMax, writeChunks, writeChunk,- restoreChunksBackup, withChunks, resetChunksCompact, resetChunksCorrupt+ readChunk, readChunkMax, usingWriteChunks, writeChunk,+ restoreChunksBackup, usingChunks, resetChunksCompact, resetChunksCorrupt,+ readChunksDirect, writeChunkDirect ) where import System.Time.Extra@@ -18,6 +19,7 @@ import Data.Monoid import General.Binary import General.Extra+import General.Cleanup import Prelude @@ -36,7 +38,10 @@ -- | Return either a valid chunk (Right), or a trailing suffix with no information (Left) readChunkMax :: Chunks -> Word32 -> IO (Either BS.ByteString BS.ByteString)-readChunkMax Chunks{..} mx = withMVar chunksHandle $ \h -> do+readChunkMax Chunks{..} mx = withMVar chunksHandle $ \h -> readChunkDirect h mx++readChunkDirect :: Handle -> Word32 -> IO (Either BS.ByteString BS.ByteString)+readChunkDirect h mx = do let slop x = do unless (BS.null x) $ hSetFileSize h . subtract (toInteger $ BS.length x) =<< hFileSize h return $ Left x@@ -46,42 +51,52 @@ v <- BS.hGet h count if BS.length v < count then slop (n `BS.append` v) else return $ Right v +readChunksDirect :: Handle -> Word32 -> IO ([BS.ByteString], BS.ByteString)+readChunksDirect h mx = do+ res <- readChunkDirect h mx+ case res of+ Left done -> return ([], done)+ Right x -> do+ (xs, done) <- readChunksDirect h mx+ return (x : xs, done)+ writeChunkDirect :: Handle -> Builder -> IO () writeChunkDirect h x = bs `seq` BS.hPut h bs where bs = runBuilder $ putEx (fromIntegral $ sizeBuilder x :: Word32) <> x -- | If 'writeChunks' and any of the reopen operations are interleaved it will cause issues.-writeChunks :: Chunks -> ((Builder -> IO ()) -> IO a) -> IO a+usingWriteChunks :: Cleanup -> Chunks -> IO (Builder -> IO ()) -- We avoid calling flush too often on SSD drives, as that can be slow -- Make sure all exceptions happen on the caller, so we don't have to move exceptions back -- Make sure we only write on one thread, otherwise async exceptions can cause partial writes-writeChunks Chunks{..} act = withMVar chunksHandle $ \h -> do+usingWriteChunks cleanup Chunks{..} = do+ h <- allocate cleanup (takeMVar chunksHandle) (putMVar chunksHandle) chan <- newChan -- operations to perform on the file kick <- newEmptyMVar -- kicked whenever something is written died <- newBarrier -- has the writing thread finished - flusher <- case chunksFlush of- Nothing -> return Nothing- Just flush -> fmap Just $ forkIO $ forever $ do- takeMVar kick- threadDelay $ ceiling $ flush * 1000000- tryTakeMVar kick- writeChan chan $ hFlush h >> return True+ whenJust chunksFlush $ \flush ->+ void $ allocate cleanup+ (forkIO $ forever $ do+ takeMVar kick+ sleep flush+ tryTakeMVar kick+ writeChan chan $ hFlush h >> return True)+ killThread root <- myThreadId- 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+ allocate cleanup+ (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)+ (const $ do writeChan chan $ return False; waitBarrier died) - (act $ \s -> do- out <- evaluate $ writeChunkDirect h s -- ensure exceptions occur on this thread- writeChan chan $ out >> tryPutMVar kick () >> return True)- `finally` do- maybe (return ()) killThread flusher- writeChan chan $ return False- waitBarrier died+ return $ \s -> do+ out <- evaluate $ writeChunkDirect h s -- ensure exceptions occur on this thread+ writeChan chan $ out >> tryPutMVar kick () >> return True + writeChunk :: Chunks -> Builder -> IO () writeChunk Chunks{..} x = withMVar chunksHandle $ \h -> writeChunkDirect h x @@ -101,13 +116,13 @@ return True -withChunks :: FilePath -> Maybe Seconds -> (Chunks -> IO a) -> IO a-withChunks file flush act = do+usingChunks :: Cleanup -> FilePath -> Maybe Seconds -> IO Chunks+usingChunks cleanup file flush = do h <- newEmptyMVar- bracket_+ allocate cleanup (putMVar h =<< openFile file ReadWriteMode)- (hClose =<< takeMVar h) $- act $ Chunks file flush h+ (const $ hClose =<< takeMVar h)+ return $ Chunks file flush h -- | The file is being compacted, if the process fails, use a backup.
src/General/Cleanup.hs view
@@ -1,42 +1,58 @@ -- | Code for ensuring cleanup actions are run. module General.Cleanup(- Cleanup, withCleanup, addCleanup, addCleanup_+ Cleanup, newCleanup, withCleanup,+ register, release, allocate, unprotect ) where import Control.Exception import qualified Data.HashMap.Strict as Map-import Control.Monad import Data.IORef.Extra import Data.List.Extra+import Data.Maybe -data S = S {unique :: {-# UNPACK #-} !Int, items :: !(Map.HashMap Int (IO ()))}+data S = S+ {unique :: {-# UNPACK #-} !Int -- next index to be used to items+ ,items :: !(Map.HashMap Int (IO ()))+ } newtype Cleanup = Cleanup (IORef S) +data ReleaseKey = ReleaseKey (IORef S) {-# UNPACK #-} !Int + -- | Run with some cleanup scope. Regardless of exceptions/threads, all 'addCleanup' actions -- will be run by the time it exits. The 'addCleanup' actions will be run in reverse order. withCleanup :: (Cleanup -> IO a) -> IO a withCleanup act = do+ (c, clean) <- newCleanup+ act c `finally` clean++newCleanup :: IO (Cleanup, IO ())+newCleanup = do ref <- newIORef $ S 0 Map.empty- act (Cleanup ref) `finally` runCleanup (Cleanup ref)+ let clean = mask_ $ do+ items <- atomicModifyIORef' ref $ \s -> (s{items=Map.empty}, items s)+ mapM_ snd $ sortOn (negate . fst) $ Map.toList items+ return (Cleanup ref, clean) --- | 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 (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- (,) (S (unique s + 1) (Map.insert i act $ items s)) $- atomicModifyIORef' ref $ \s -> (s{items = Map.delete i $ items s}, ())+register :: Cleanup -> IO () -> IO ReleaseKey+register (Cleanup ref) act = atomicModifyIORef' ref $ \s -> let i = unique s in+ (S (unique s + 1) (Map.insert i act $ items s), ReleaseKey ref i) -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+unprotect :: ReleaseKey -> IO ()+unprotect (ReleaseKey ref i) = atomicModifyIORef' ref $ \s -> (s{items = Map.delete i $ items s}, ())++release :: ReleaseKey -> IO ()+release (ReleaseKey ref i) = mask_ $ do+ undo <- atomicModifyIORef' ref $ \s -> (s{items = Map.delete i $ items s}, Map.lookup i $ items s)+ fromMaybe (return ()) undo++allocate :: Cleanup -> IO a -> (a -> IO ()) -> IO a+allocate cleanup acquire release =+ mask_ $ do+ v <- acquire+ register cleanup $ release v+ return v
− src/General/Concurrent.hs
@@ -1,33 +0,0 @@--module General.Concurrent(- Fence, newFence, signalFence, waitFence, testFence,- ) where--import Control.Applicative-import Control.Monad-import Data.IORef-import Prelude--------------------------------------------------------------------------- FENCE---- | Like a barrier, but based on callbacks-newtype Fence a = Fence (IORef (Either [a -> IO ()] a))-instance Show (Fence a) where show _ = "Fence"--newFence :: IO (Fence a)-newFence = Fence <$> newIORef (Left [])--signalFence :: Fence a -> a -> IO ()-signalFence (Fence ref) v = join $ atomicModifyIORef ref $ \x -> case x of- Left queue -> (Right v, mapM_ ($ v) $ reverse queue)- Right v -> error "Shake internal error, signalFence called twice on one Fence"--waitFence :: Fence a -> (a -> IO ()) -> IO ()-waitFence (Fence ref) call = join $ atomicModifyIORef ref $ \x -> case x of- Left queue -> (Left (call:queue), return ())- Right v -> (Right v, call v)--testFence :: Fence a -> IO (Maybe a)-testFence (Fence x) = either (const Nothing) Just <$> readIORef x
src/General/Extra.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RecordWildCards, GeneralizedNewtypeDeriving, Rank2Types #-} module General.Extra( getProcessorCount, findGcc,- withResultType, whenLeft, randomElem, wrapQuote, showBracket,@@ -12,30 +12,44 @@ fastAt, forkFinallyUnmasked, isAsyncException,+ usingLineBuffering, doesFileExist_,+ usingNumCapabilities, removeFile_, createDirectoryRecursive,- catchIO, tryIO, handleIO+ catchIO, tryIO, handleIO,+ Located, Partial, callStackTop, callStackFull, withFrozenCallStack,+ Ver(..), makeVer,+ QTypeRep(..) ) where -import Control.Exception+import Control.Exception.Extra import Data.Char-import Data.List+import Data.List.Extra import System.Environment.Extra+import Development.Shake.FilePath+import Control.DeepSeq+import Numeric+import General.Cleanup+import Data.Typeable import System.IO.Extra import System.IO.Unsafe import System.Info.Extra-import System.FilePath import System.Random import System.Directory import System.Exit-import Control.Concurrent+import Foreign.Storable+import Control.Concurrent.Extra import Data.Maybe import Data.Functor+import Data.Hashable import Data.Primitive.Array import Control.Applicative import Control.Monad import Control.Monad.ST import GHC.Conc(getNumProcessors)+#if __GLASGOW_HASKELL__ >= 800+import GHC.Stack+#endif import Prelude @@ -77,7 +91,7 @@ arr = runST $ do let n = length xs arr <- newArray n undefined- forM_ (zip [0..] xs) $ \(i,x) ->+ forM_ (zipFrom 0 xs) $ \(i,x) -> writeArray arr i x unsafeFreezeArray arr @@ -130,6 +144,18 @@ ---------------------------------------------------------------------+-- System.IO++usingLineBuffering :: Cleanup -> IO ()+usingLineBuffering cleanup = do+ out <- hGetBuffering stdout+ err <- hGetBuffering stderr+ when (out /= LineBuffering || err /= LineBuffering) $ do+ register cleanup $ hSetBuffering stdout out >> hSetBuffering stderr err+ hSetBuffering stdout LineBuffering >> hSetBuffering stderr LineBuffering+++--------------------------------------------------------------------- -- Control.Monad withs :: [(a -> r) -> r] -> ([a] -> r) -> r@@ -146,7 +172,14 @@ mask_ $ forkIOWithUnmask $ \unmask -> try (unmask act) >>= cleanup +usingNumCapabilities :: Cleanup -> Int -> IO ()+usingNumCapabilities cleanup new = when rtsSupportsBoundThreads $ do+ old <- getNumCapabilities+ when (old /= new) $ do+ register cleanup $ setNumCapabilities old+ setNumCapabilities new + --------------------------------------------------------------------- -- Control.Exception @@ -158,7 +191,7 @@ | otherwise = False catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = Control.Exception.catch -- GHC 7.4 has catch in the Prelude as well+catchIO = Control.Exception.Extra.catch -- GHC 7.4 has catch in the Prelude as well tryIO :: IO a -> IO (Either IOException a) tryIO = try@@ -193,8 +226,58 @@ ------------------------------------------------------------------------ Data.Proxy+-- Data.CallStack --- Should be Proxy, but that's not available in older GHC 7.6 and before-withResultType :: (Maybe a -> a) -> a-withResultType f = f Nothing+type Located = Partial++callStackTop :: Partial => String+callStackTop = withFrozenCallStack $ head $ callStackFull ++ ["unknown location"]++callStackFull :: Partial => [String]++#if __GLASGOW_HASKELL__ >= 800++callStackFull = map f $ getCallStack $ popCallStack callStack+ where+ f (_, SrcLoc{..}) = toStandard srcLocFile ++ ":" +++ -- match the format of GHC error messages+ if srcLocStartLine == srcLocEndLine then+ show srcLocStartLine ++ ":" ++ show srcLocStartCol +++ (if srcLocStartCol == srcLocEndCol then "" else "-" ++ show srcLocEndCol) ++ ":"+ else+ show (srcLocStartLine, srcLocStartCol) ++ "-" ++ show (srcLocEndLine, srcLocEndCol) ++ ":"+#else++callStackFull = []++withFrozenCallStack :: a -> a+withFrozenCallStack = id+#endif++---------------------------------------------------------------------+-- Data.Version++-- | A version number that indicates change, not ordering or compatibilty.+-- Always presented as an 'Int' to the user, but a newtype inside the library for safety.+newtype Ver = Ver Int+ deriving (Show,Eq,Storable)++makeVer :: String -> Ver+makeVer = Ver . hash+++---------------------------------------------------------------------+-- Data.Typeable++-- | Like TypeRep, but the Show includes enough information to be unique+-- so I can rely on @a == b === show a == show b@.+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) "" ++ "}"
+ src/General/Fence.hs view
@@ -0,0 +1,54 @@++module General.Fence(+ Fence, newFence, signalFence, waitFence, testFence,+ exceptFence+ ) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.Either.Extra+import Data.Functor+import Data.IORef.Extra+import Prelude+++---------------------------------------------------------------------+-- FENCE++-- | Like a barrier, but based on callbacks+newtype Fence m a = Fence (IORef (Either (a -> m ()) a))+instance Show (Fence m a) where show _ = "Fence"++newFence :: MonadIO m => IO (Fence m a)+newFence = Fence <$> newIORef (Left $ const $ return ())++signalFence :: MonadIO m => Fence m a -> a -> m ()+signalFence (Fence ref) v = join $ liftIO $ atomicModifyIORef' ref $ \x -> case x of+ Left queue -> (Right v, queue v)+ Right _ -> error "Shake internal error, signalFence called twice on one Fence"++waitFence :: MonadIO m => Fence m a -> (a -> m ()) -> m ()+waitFence (Fence ref) call = join $ liftIO $ atomicModifyIORef' ref $ \x -> case x of+ Left queue -> (Left (\a -> queue a >> call a), return ())+ Right v -> (Right v, call v)++testFence :: Fence m a -> IO (Maybe a)+testFence (Fence x) = either (const Nothing) Just <$> readIORef x+++---------------------------------------------------------------------+-- FENCE COMPOSITES++exceptFence :: MonadIO m => [Fence m (Either e r)] -> m (Fence m (Either e [r]))+exceptFence xs = do+ -- number of items still to complete, becomes negative after it has triggered+ todo <- liftIO $ newIORef $ length xs+ fence <- liftIO newFence++ forM_ xs $ \x -> waitFence x $ \res ->+ join $ liftIO $ atomicModifyIORef' todo $ \i -> case res of+ Left e | i >= 0 -> (-1, signalFence fence $ Left e)+ _ | i == 1 -> (-1, signalFence fence . Right =<< liftIO (mapM (fmap (fromRight' . fromJust) . testFence) xs))+ | otherwise -> (i-1, return ())+ return fence
src/General/FileLock.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE CPP #-} -module General.FileLock(withLockFile) where+module General.FileLock(usingLockFile) where import Control.Exception.Extra import System.FilePath import General.Extra+import General.Cleanup #ifdef mingw32_HOST_OS+import Control.Monad import Data.Bits import Data.Word import Foreign.Ptr@@ -37,40 +39,45 @@ c_ERROR_SHARING_VIOLATION = 32 #endif -withLockFile :: FilePath -> IO a -> IO a+usingLockFile :: Cleanup -> FilePath -> IO () #ifdef mingw32_HOST_OS -withLockFile file act = withCWString file $ \cfile -> do+usingLockFile b file = do 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- err <- c_GetLastError- errorIO $ "Shake failed to acquire a file lock on " ++ file ++ "\n" ++- (if err == c_ERROR_SHARING_VIOLATION- then "ERROR_SHARING_VIOLATION - Shake is probably already running."- else "Code " ++ show err ++ ", unknown reason for failure.")- else- act+ let open = withCWString file $ \cfile ->+ c_CreateFileW cfile (c_GENERIC_READ .|. c_GENERIC_WRITE) c_FILE_SHARE_NONE nullPtr c_OPEN_ALWAYS c_FILE_ATTRIBUTE_NORMAL nullPtr+ h <- allocate b open (void . c_CloseHandle)+ when (h == c_INVALID_HANDLE_VALUE) $ do+ err <- c_GetLastError+ errorIO $ "Shake failed to acquire a file lock on " ++ file ++ "\n" +++ (if err == c_ERROR_SHARING_VIOLATION+ then "ERROR_SHARING_VIOLATION - Shake is probably already running."+ else "Code " ++ show err ++ ", unknown reason for failure.") #else -withLockFile file act = do+usingLockFile cleanup file = do createDirectoryRecursive $ takeDirectory file tryIO $ writeFile file "" - bracket (openFd file ReadWrite Nothing defaultFileFlags) closeFd $ \fd -> do- let lock = (WriteLock, AbsoluteSeek, 0, 0)- res <- tryIO $ setLock fd lock- case res of- Right () -> act- Left e -> do- res <- getLock fd lock- errorIO $ "Shake failed to acquire a file lock on " ++ file ++ "\n" ++- (case res of- Nothing -> ""- Just (pid, _) -> "Shake process ID " ++ show pid ++ " is using this lock.\n") ++- show e+ fd <- allocate cleanup (openSimpleFd file ReadWrite) closeFd+ let lock = (WriteLock, AbsoluteSeek, 0, 0)+ setLock fd lock `catchIO` \e -> do+ res <- getLock fd lock+ errorIO $ "Shake failed to acquire a file lock on " ++ file ++ "\n" +++ (case res of+ Nothing -> ""+ Just (pid, _) -> "Shake process ID " ++ show pid ++ " is using this lock.\n") +++ show e++#ifndef MIN_VERSION_unix+#define MIN_VERSION_unix(a,b,c) 0+#endif+#if MIN_VERSION_unix(2,8,0)+openSimpleFd file mode = openFd file mode defaultFileFlags+#else+openSimpleFd file mode = openFd file mode Nothing defaultFileFlags+#endif #endif
src/General/Ids.hs view
@@ -2,18 +2,19 @@ -- Note that argument order is more like IORef than Map, because its mutable module General.Ids(- Ids, Id,- empty, insert, lookup,+ Ids, Id(..),+ empty, insert, lookup, fromList, null, size, sizeUpperBound,- forWithKeyM_, for,- toList, toMap+ forWithKeyM_, forCopy, forMutate,+ toList, elems, toMap ) where import Data.IORef.Extra-import Data.Primitive.Array+import Data.Primitive.Array hiding (fromList) import Control.Exception import General.Intern(Id(..)) import Control.Monad.Extra+import Data.List.Extra(zipFrom) import Data.Maybe import Data.Functor import qualified Data.HashMap.Strict as Map@@ -38,6 +39,14 @@ values <- newArray capacity Nothing Ids <$> newIORef S{..} +fromList :: [a] -> IO (Ids a)+fromList xs = do+ let capacity = length xs+ let used = capacity+ values <- newArray capacity Nothing+ forM_ (zipFrom 0 xs) $ \(i, x) ->+ writeArray values i $ Just x+ Ids <$> newIORef S{..} sizeUpperBound :: Ids a -> IO Int sizeUpperBound (Ids ref) = do@@ -71,8 +80,8 @@ go $ i+1 go 0 -for :: Ids a -> (a -> b) -> IO (Ids b)-for (Ids ref) f = do+forCopy :: Ids a -> (a -> b) -> IO (Ids b)+forCopy (Ids ref) f = do S{..} <- readIORef ref values2 <- newArray capacity Nothing let go !i | i >= used = return ()@@ -84,13 +93,24 @@ Ids <$> newIORef (S capacity used values2) +forMutate :: Ids a -> (a -> a) -> IO ()+forMutate (Ids ref) f = do+ S{..} <- readIORef ref+ let go !i | i >= used = return ()+ | otherwise = do+ v <- readArray values i+ whenJust v $ \v -> writeArray values i $ Just $ f v+ go $ i+1+ go 0++ toListUnsafe :: Ids a -> IO [(Id, a)] toListUnsafe (Ids ref) = do S{..} <- readIORef ref -- execute in O(1) stack -- see https://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html- let index r i | i >= used = []+ let index _ i | i >= used = [] index r i | IO io <- readArray values i = case io r of (# r, Nothing #) -> index r (i+1) (# r, Just v #) -> (Id $ fromIntegral i, v) : index r (i+1)@@ -101,11 +121,13 @@ toList :: Ids a -> IO [(Id, a)] toList ids = do xs <- toListUnsafe ids- let demand (x:xs) = demand xs+ let demand (_:xs) = demand xs demand [] = () evaluate $ demand xs return xs +elems :: Ids a -> IO [a]+elems ids = map snd <$> toList ids null :: Ids a -> IO Bool null ids = (== 0) <$> sizeUpperBound ids
src/General/Intern.hs view
@@ -17,7 +17,7 @@ data Intern a = Intern {-# UNPACK #-} !Word32 !(Map.HashMap a Id) newtype Id = Id Word32- deriving (Eq,Hashable,Binary,Show,NFData,Storable)+ deriving (Eq,Hashable,Ord,Binary,Show,NFData,Storable) empty :: Intern a empty = Intern 0 Map.empty@@ -33,11 +33,11 @@ lookup :: (Eq a, Hashable a) => a -> Intern a -> Maybe Id-lookup k (Intern n mp) = Map.lookup k mp+lookup k (Intern _ mp) = Map.lookup k mp toList :: Intern a -> [(a, Id)]-toList (Intern a b) = Map.toList b+toList (Intern _ mp) = Map.toList mp fromList :: (Eq a, Hashable a) => [(a, Id)] -> Intern a
src/General/ListBuilder.hs view
@@ -28,6 +28,6 @@ runListBuilder :: ListBuilder a -> [a] runListBuilder x = f x [] where- f Zero acc = []+ f Zero acc = acc f (One x) acc = x : acc f (Add x y) acc = f x (f y acc)
+ src/General/Pool.hs view
@@ -0,0 +1,166 @@++-- | 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 General.Pool(+ Pool, runPool,+ addPool, PoolPriority(..),+ increasePool, keepAlivePool+ ) where++import Control.Concurrent.Extra+import System.Time.Extra+import Control.Exception+import Control.Monad.Extra+import General.Timing+import General.Extra+import qualified Data.Heap as Heap+import qualified Data.HashSet as Set+import Data.IORef.Extra+import System.Random+++---------------------------------------------------------------------+-- THREAD POOL++{-+Must keep a list of active threads, so can raise exceptions in a timely manner+If any worker throws an exception, must signal to all the other workers+-}++data Pool = Pool+ !(Var (Maybe S)) -- Current state, 'Nothing' to say we are aborting+ !(Barrier (Either SomeException S)) -- Barrier to signal that we are finished++data S = S+ {threads :: !(Set.HashSet ThreadId) -- IMPORTANT: Must be strict or we leak thread stacks+ ,threadsLimit :: {-# UNPACK #-} !Int -- user supplied thread limit, Set.size threads <= threadsLimit+ ,threadsCount :: {-# UNPACK #-} !Int -- Set.size threads, but in O(1)+ ,threadsMax :: {-# UNPACK #-} !Int -- high water mark of Set.size threads (accounting only)+ ,threadsSum :: {-# UNPACK #-} !Int -- number of threads we have been through (accounting only)+ ,rand :: IO Int -- operation to give us the next random Int+ ,todo :: !(Heap.Heap (Heap.Entry (PoolPriority, Int) (IO ()))) -- operations waiting a thread+ }+++emptyS :: Int -> Bool -> IO S+emptyS n deterministic = do+ rand <- if not deterministic then return randomIO else do+ ref <- newIORef 0+ -- no need to be thread-safe - if two threads race they were basically the same time anyway+ return $ do i <- readIORef ref; writeIORef' ref (i+1); return i+ return $ S Set.empty n 0 0 0 rand Heap.empty+++worker :: Pool -> IO ()+worker pool@(Pool var _) = do+ let onVar act = modifyVar var $ maybe (return (Nothing, return ())) act+ join $ onVar $ \s ->return $ case Heap.uncons $ todo s of+ Nothing -> (Just s, return ())+ Just (Heap.Entry _ now, todo2) -> (Just s{todo = todo2}, now >> worker pool)++-- | 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 -> IO S) -> IO ()+step pool@(Pool var done) op = do+ let onVar act = modifyVar_ var $ maybe (return Nothing) act+ onVar $ \s -> do+ s <- op s+ case Heap.uncons $ todo s of+ Just (Heap.Entry _ now, todo2) | threadsCount s < threadsLimit s -> do+ -- spawn a new worker+ t <- forkFinallyUnmasked (now >> worker pool) $ \res -> case res of+ Left e -> onVar $ \s -> do+ t <- myThreadId+ mapM_ killThread $ Set.toList $ Set.delete t $ threads s+ signalBarrier done $ Left e+ return Nothing+ Right _ -> do+ t <- myThreadId+ step pool $ \s -> return s{threads = Set.delete t $ threads s, threadsCount = threadsCount s - 1}+ return $ Just s{todo = todo2, threads = Set.insert t $ threads s, threadsCount = threadsCount s + 1+ ,threadsSum = threadsSum s + 1, threadsMax = threadsMax s `max` (threadsCount s + 1)}+ Nothing | threadsCount s == 0 -> do+ signalBarrier done $ Right s+ return Nothing+ _ -> return $ Just s+++-- | Add a new task to the pool. See the top of the module for the relative ordering+-- and semantics.+addPool :: PoolPriority -> Pool -> IO a -> IO ()+addPool priority pool act = step pool $ \s -> do+ i <- rand s+ return s{todo = Heap.insert (Heap.Entry (priority, i) $ void act) $ todo s}+++data PoolPriority+ = PoolException+ | PoolResume+ | PoolStart+ | PoolBatch+ | PoolDeprioritize Double+ deriving (Eq,Ord)++-- | Temporarily increase the pool by 1 thread. Call the cleanup action to restore the value.+-- After calling cleanup you should requeue onto a new thread.+increasePool :: Pool -> IO (IO ())+increasePool pool = do+ step pool $ \s -> return s{threadsLimit = threadsLimit s + 1}+ return $ step pool $ \s -> return s{threadsLimit = threadsLimit s - 1}+++-- | Make sure the pool cannot run out of tasks (and thus everything finishes) until after the cancel is called.+-- Ensures that a pool that will requeue in time doesn't go idle.+keepAlivePool :: Pool -> IO (IO ())+keepAlivePool pool = do+ bar <- newBarrier+ addPool PoolResume pool $ do+ cancel <- increasePool pool+ waitBarrier bar+ cancel+ return $ signalBarrier bar ()+++-- | Run all the tasks in the pool on the given number of works.+-- If any thread throws an exception, the exception will be reraised.+-- When it completes all threads have either finished, or have had 'killThread'+-- called on them (but may not have actually died yet).+runPool :: Bool -> Int -> (Pool -> IO ()) -> IO () -- run all tasks in the pool+runPool deterministic n act = do+ s <- newVar . Just =<< emptyS n deterministic+ done <- newBarrier++ let cleanup = modifyVar_ s $ \s -> do+ -- if someone kills our thread, make sure we kill our child threads+ case s of+ Just s -> mapM_ killThread $ Set.toList $ threads s+ Nothing -> return ()+ return Nothing++ let ghc10793 = do+ -- if this thread dies because it is blocked on an MVar there's a chance we have+ -- a better error in the done barrier, and GHC raised the exception wrongly, see:+ -- https://ghc.haskell.org/trac/ghc/ticket/10793+ sleep 1 -- give it a little bit of time for the finally to run+ -- no big deal, since the blocked indefinitely takes a while to fire anyway+ res <- waitBarrierMaybe done+ case res of+ Just (Left e) -> throwIO e+ _ -> throwIO BlockedIndefinitelyOnMVar+ handle (\BlockedIndefinitelyOnMVar -> ghc10793) $ flip onException cleanup $ do+ let pool = Pool s done+ addPool PoolStart pool $ act pool+ res <- waitBarrier done+ case res of+ Left e -> throwIO e+ Right s -> addTiming $ "Pool finished (" ++ show (threadsSum s) ++ " threads, " ++ show (threadsMax s) ++ " max)"
src/General/Process.hs view
@@ -25,6 +25,7 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import General.Extra+import Development.Shake.Internal.Errors import Prelude import GHC.IO.Exception (IOErrorType(..), IOException(..))@@ -84,13 +85,13 @@ optimiseBuffers po@ProcessOpts{..} = return (po{poStdout = nubOrd poStdout, poStderr = nubOrd poStderr}, return ()) stdStream :: (FilePath -> Handle) -> [Destination] -> [Destination] -> StdStream-stdStream file [DestEcho] other = Inherit+stdStream _ [DestEcho] _ = Inherit stdStream file [DestFile x] other | other == [DestFile x] || DestFile x `notElem` other = UseHandle $ file x-stdStream file _ _ = CreatePipe+stdStream _ _ _ = CreatePipe stdIn :: (FilePath -> Handle) -> [Source] -> (StdStream, Handle -> IO ())-stdIn file [] = (Inherit, const $ return ())+stdIn _ [] = (Inherit, const $ return ()) stdIn file [SrcFile x] = (UseHandle $ file x, const $ return ()) stdIn file src = (,) CreatePipe $ \h -> ignoreSigPipe $ do forM_ src $ \x -> case x of@@ -107,7 +108,7 @@ withTimeout :: Maybe Double -> IO () -> IO a -> IO a-withTimeout Nothing stop go = go+withTimeout Nothing _ go = go withTimeout (Just s) stop go = bracket (forkIO $ sleep s >> stop) killThread $ const go @@ -154,7 +155,7 @@ wait <- forM streams $ \(h, hh, dest) -> do -- no point tying the streams together if one is being streamed directly let isTied = not (poStdout `disjoint` poStderr) && length streams == 2- let isBinary = not $ any isDestString dest && not (any isDestBytes dest)+ let isBinary = any isDestBytes dest || not (any isDestString dest) when isTied $ hSetBuffering h LineBuffering when (DestEcho `elem` dest) $ do buf <- hGetBuffering hh@@ -164,7 +165,7 @@ if isBinary then do hSetBinaryMode h True- dest <- return $ for dest $ \d -> case d of+ dest <- return $ flip map dest $ \d -> case d of DestEcho -> BS.hPut hh DestFile x -> BS.hPut (outHandle x) DestString x -> addBuffer x . (if isWindows then replace "\r\n" "\n" else id) . BS.unpack@@ -174,10 +175,11 @@ mapM_ ($ src) dest notM $ hIsEOF h else if isTied then do- dest <- return $ for dest $ \d -> case d of+ dest <- return $ flip map dest $ \d -> case d of DestEcho -> hPutStrLn hh DestFile x -> hPutStrLn (outHandle x) DestString x -> addBuffer x . (++ "\n")+ DestBytes{} -> throwImpure $ errorInternal "Not reachable due to isBinary condition" forkWait $ whileM $ ifM (hIsEOF h) (return False) $ do src <- hGetLine h@@ -190,6 +192,7 @@ DestEcho -> forkWait $ hPutStr hh src DestFile x -> forkWait $ hPutStr (outHandle x) src DestString x -> do addBuffer x src; return $ return ()+ DestBytes{} -> throwImpure $ errorInternal "Not reachable due to isBinary condition" return $ sequence_ $ wait1 : waits whenJust inh $ snd $ stdIn inHandle poStdin
src/General/Template.hs view
@@ -4,8 +4,8 @@ import System.FilePath.Posix import Control.Exception.Extra-import Control.Monad.IO.Class import Data.Char+import System.IO.Unsafe import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Language.Javascript.Flot as Flot import qualified Language.Javascript.JQuery as JQuery@@ -22,9 +22,8 @@ -- * <script src="foo"></script> ==> <script>[[foo]]</script> -- -- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>-runTemplate :: (Functor m, MonadIO m) => (FilePath -> m LBS.ByteString) -> LBS.ByteString -> m LBS.ByteString--- Functor constraint is required for GHC 7.8 and before-runTemplate ask = fmap LBS.unlines . mapM f . LBS.lines+runTemplate :: (FilePath -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString+runTemplate ask = lbsMapLinesIO f where link = LBS.pack "<link href=\"" script = LBS.pack "<script src=\""@@ -37,9 +36,18 @@ grab = asker . takeWhile (/= '\"') . LBS.unpack asker o@(splitFileName -> ("lib/",x)) = case lookup x libraries of- Just act -> liftIO $ LBS.readFile =<< act- Nothing -> liftIO $ errorIO $ "Template library, unknown library: " ++ o+ Just act -> LBS.readFile =<< act+ Nothing -> errorIO $ "Template library, unknown library: " ++ o asker x = ask x+++-- Perform a mapM on each line and put the result back together again+lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString+-- If we do the obvious @fmap LBS.unlines . mapM f@ then all the monadic actions are run on all the lines+-- before it starts producing the lazy result, killing streaming and having more stack usage.+-- The real solution (albeit with too many dependencies for something small) is a streaming library,+-- but a little bit of unsafePerformIO does the trick too.+lbsMapLinesIO f = return . LBS.unlines . map (unsafePerformIO . f) . LBS.lines ---------------------------------------------------------------------
src/General/Timing.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} module General.Timing(resetTimings, addTiming, printTimings) where @@ -26,7 +27,7 @@ printTimings :: IO () printTimings = do now <- timer- old <- atomicModifyIORef timings $ \ts -> ([(now, "Start")], ts)+ old <- atomicModifyIORef timings ([(now, "Start")],) putStr $ unlines $ showTimings now $ reverse old
+ src/General/TypeMap.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ExistentialQuantification, ConstraintKinds, KindSignatures, GADTs, ScopedTypeVariables, Rank2Types #-}++module General.TypeMap(+ Map, empty, singleton, insert, map, lookup, unionWith+ ) where++import qualified Data.HashMap.Strict as Map+import Data.Typeable.Extra+import Unsafe.Coerce+import Data.Functor+import Prelude hiding (lookup, map)+++data F f = forall a . F (f a)++unF :: F f -> f a+unF x = case x of F x -> unsafeCoerce x++newtype Map (f :: * -> *) = Map (Map.HashMap TypeRep (F f))++empty :: Map f+empty = Map Map.empty++singleton :: Typeable a => f a -> Map f+singleton x = Map $ Map.singleton (typeRep x) (F x)++insert :: Typeable a => f a -> Map f -> Map f+insert x (Map mp) = Map $ Map.insert (typeRep x) (F x) mp++lookup :: forall a f . Typeable a => Map f -> Maybe (f a)+lookup (Map mp) = unF <$> Map.lookup (typeRep (Proxy :: Proxy a)) mp++unionWith :: (forall a . f a -> f a -> f a) -> Map f -> Map f -> Map f+unionWith f (Map mp1) (Map mp2) = Map $ Map.unionWith (\x1 x2 -> F $ f (unF x1) (unF x2)) mp1 mp2++map :: (forall a . f1 a -> f2 a) -> Map f1 -> Map f2+map f (Map mp) = Map $ Map.map (\(F a) -> F $ f a) mp
+ src/General/Wait.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, CPP #-}++-- | A bit like 'Fence', but not thread safe and optimised for avoiding taking the fence+module General.Wait(+ Locked, runLocked,+ Wait(Now,Later), runWait, quickly, fromLater,+ firstJustWaitUnordered, firstLeftWaitUnordered+ ) where++import Control.Monad.Extra+import Control.Monad.IO.Class+import Control.Concurrent.Extra+import Data.IORef.Extra+import Data.List.Extra+import Data.Primitive.Array+import GHC.Exts(RealWorld)+import Control.Applicative+import Prelude++#if __GLASGOW_HASKELL__ >= 800+import Control.Monad.Fail+#endif+++runWait :: Monad m => Wait m a -> m (Wait m a)+runWait (Lift x) = runWait =<< x+runWait x = return x++fromLater :: Monad m => Wait m a -> (a -> m ()) -> m ()+fromLater (Lift x) f = do x <- x; fromLater x f+fromLater (Now x) f = f x+fromLater (Later x) f = x f++newtype Locked a = Locked (IO a)+ deriving (Functor, Applicative, Monad, MonadIO+#if __GLASGOW_HASKELL__ >= 800+ ,MonadFail+#endif+ )++runLocked :: Var a -> (a -> Locked b) -> IO b+runLocked var act = withVar var $ \v -> case act v of Locked x -> x++quickly :: Functor m => m a -> Wait m a+quickly = Lift . fmap Now++data Wait m a = Now a+ | Lift (m (Wait m a))+ | Later ((a -> m ()) -> m ())+ deriving Functor++instance (Monad m, Applicative m) => Applicative (Wait m) where+ pure = Now+ Now x <*> y = x <$> y+ Lift x <*> y = Lift $ (<*> y) <$> x+ Later x <*> Now y = Later $ \c -> x $ \x -> c $ x y+ -- Note: We pull the Lift from the right BEFORE the Later, to enable parallelism+ Later x <*> Lift y = Lift $ do y <- y; return $ Later x <*> y+ Later x <*> Later y = Later $ \c -> x $ \x -> y $ \y -> c $ x y++instance (Monad m, Applicative m) => Monad (Wait m) where+ return = pure+ (>>) = (*>)+ Now x >>= f = f x+ Lift x >>= f = Lift $ do x <- x; return $ x >>= f+ Later x >>= f = Later $ \c -> x $ \x -> do+ x <- runWait $ f x+ case x of+ Now x -> c x+ _ -> fromLater x c++instance (MonadIO m, Applicative m) => MonadIO (Wait m) where+ liftIO = Lift . liftIO . fmap Now++#if __GLASGOW_HASKELL__ >= 800+instance MonadFail m => MonadFail (Wait m) where+ fail = Lift . Control.Monad.Fail.fail+#endif+++firstJustWaitUnordered :: MonadIO m => (a -> Wait m (Maybe b)) -> [a] -> Wait m (Maybe b)+firstJustWaitUnordered f = go [] . map f+ where+ -- keep a list of those things we might visit later, and ask for each we see in turn+ go :: MonadIO m => [(Maybe a -> m ()) -> m ()] -> [Wait m (Maybe a)] -> Wait m (Maybe a)+ go later (x:xs) = case x of+ Now (Just a) -> Now $ Just a+ Now Nothing -> go later xs+ Later l -> go (l:later) xs+ Lift x -> Lift $ do+ x <- x+ return $ go later (x:xs)+ go [] [] = Now Nothing+ go [l] [] = Later l+ go ls [] = Later $ \callback -> do+ ref <- liftIO $ newIORef $ length ls+ forM_ ls $ \l -> l $ \r -> do+ old <- liftIO $ readIORef ref+ when (old > 0) $ case r of+ Just a -> do+ liftIO $ writeIORef' ref 0+ callback $ Just a+ Nothing -> do+ liftIO $ writeIORef' ref $ old-1+ when (old == 1) $ callback Nothing+++firstLeftWaitUnordered :: (Applicative m, MonadIO m) => (a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b])+firstLeftWaitUnordered f xs = do+ let n = length xs+ mut <- liftIO $ newArray n undefined+ res <- go mut [] $ zipFrom 0 $ map f xs+ case res of+ Just e -> return $ Left e+ Nothing -> liftIO $ Right <$> mapM (readArray mut) [0..n-1]+ where+ -- keep a list of those things we might visit later, and ask for each we see in turn+ go :: (Applicative m, MonadIO m) => MutableArray RealWorld b -> [(Int, (Either e b -> m ()) -> m ())] -> [(Int, Wait m (Either e b))] -> Wait m (Maybe e)+ go mut later ((i,x):xs) = case x of+ Now (Left e) -> Now $ Just e+ Now (Right b) -> do+ liftIO $ writeArray mut i b+ go mut later xs+ Later l -> go mut ((i,l):later) xs+ Lift x -> Lift $ do+ x <- x+ return $ go mut later ((i,x):xs)+ go _ [] [] = Now Nothing+ go mut ls [] = Later $ \callback -> do+ ref <- liftIO $ newIORef $ length ls+ forM_ ls $ \(i,l) -> l $ \r -> do+ old <- liftIO $ readIORef ref+ when (old > 0) $ case r of+ Left a -> do+ liftIO $ writeIORef' ref 0+ callback $ Just a+ Right v -> do+ liftIO $ writeArray mut i v+ liftIO $ writeIORef' ref $ old-1+ when (old == 1) $ callback Nothing
src/Test.hs view
@@ -14,45 +14,51 @@ import Control.Concurrent.Extra import Prelude -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-import qualified Test.Command as Command-import qualified Test.Config as Config-import qualified Test.Digest as Digest-import qualified Test.Directory as Directory-import qualified Test.Docs as Docs-import qualified Test.Errors as Errors-import qualified Test.Existence as Existence-import qualified Test.FileLock as FileLock-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-import qualified Test.Live as Live-import qualified Test.Manual as Manual-import qualified Test.Match as Match-import qualified Test.Monad as Monad-import qualified Test.Ninja as Ninja-import qualified Test.Oracle as Oracle-import qualified Test.OrderOnly as OrderOnly-import qualified Test.Parallel as Parallel-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-import qualified Test.Tup as Tup-import qualified Test.Unicode as Unicode-import qualified Test.Util as Util-import qualified Test.Verbosity as Verbosity-import qualified Test.Version as Version+import qualified Test.Basic+import qualified Test.Batch+import qualified Test.Benchmark+import qualified Test.Builtin+import qualified Test.C+import qualified Test.Cache+import qualified Test.Cleanup+import qualified Test.Command+import qualified Test.Config+import qualified Test.Database+import qualified Test.Digest+import qualified Test.Directory+import qualified Test.Docs+import qualified Test.Errors+import qualified Test.Existence+import qualified Test.FileLock+import qualified Test.FilePath+import qualified Test.FilePattern+import qualified Test.Files+import qualified Test.Forward+import qualified Test.History+import qualified Test.Journal+import qualified Test.Lint+import qualified Test.Live+import qualified Test.Manual+import qualified Test.Match+import qualified Test.Monad+import qualified Test.Ninja+import qualified Test.Oracle+import qualified Test.OrderOnly+import qualified Test.Parallel+import qualified Test.Pool+import qualified Test.Progress+import qualified Test.Random+import qualified Test.Rebuild+import qualified Test.Deprioritize+import qualified Test.Resources+import qualified Test.Self+import qualified Test.SelfMake+import qualified Test.Tar+import qualified Test.Tup+import qualified Test.Unicode+import qualified Test.Util+import qualified Test.Verbosity+import qualified Test.Version import qualified Run @@ -61,45 +67,51 @@ where (*) = (,) 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]+ ["basic" * Test.Basic.main+ ,"batch" * Test.Batch.main+ ,"benchmark" * Test.Benchmark.main+ ,"builtin" * Test.Builtin.main+ ,"c" * Test.C.main+ ,"cache" * Test.Cache.main+ ,"cleanup" * Test.Cleanup.main+ ,"command" * Test.Command.main+ ,"config" * Test.Config.main+ ,"database" * Test.Database.main+ ,"deprioritize" * Test.Deprioritize.main+ ,"digest" * Test.Digest.main+ ,"directory" * Test.Directory.main+ ,"docs" * Test.Docs.main+ ,"errors" * Test.Errors.main+ ,"existence" * Test.Existence.main+ ,"filelock" * Test.FileLock.main+ ,"filepath" * Test.FilePath.main+ ,"filepattern" * Test.FilePattern.main+ ,"files" * Test.Files.main+ ,"forward" * Test.Forward.main+ ,"history" * Test.History.main+ ,"journal" * Test.Journal.main+ ,"lint" * Test.Lint.main+ ,"live" * Test.Live.main+ ,"manual" * Test.Manual.main+ ,"match" * Test.Match.main+ ,"monad" * Test.Monad.main+ ,"ninja" * Test.Ninja.main+ ,"oracle" * Test.Oracle.main+ ,"orderonly" * Test.OrderOnly.main+ ,"parallel" * Test.Parallel.main+ ,"pool" * Test.Pool.main+ ,"progress" * Test.Progress.main+ ,"random" * Test.Random.main+ ,"rebuild" * Test.Rebuild.main+ ,"resources" * Test.Resources.main+ ,"self" * Test.Self.main+ ,"selfmake" * Test.SelfMake.main+ ,"tar" * Test.Tar.main+ ,"tup" * Test.Tup.main+ ,"unicode" * Test.Unicode.main+ ,"util" * Test.Util.main+ ,"verbosity" * Test.Verbosity.main+ ,"version" * Test.Version.main] where (*) = (,) @@ -126,7 +138,7 @@ ,unwords [" ", exePath, "self", "--jobs=2", "--trace"] ,"" ,"Which will build Shake, using Shake, on 2 threads."]- Just main -> main =<< sleepFileTimeCalibrate+ Just main -> main =<< sleepFileTimeCalibrate "output/calibrate" makefile :: IO () -> IO ()
src/Test/Basic.hs view
@@ -13,7 +13,7 @@ import Prelude -main = shakeTest_ test $ do+main = testBuild test $ do "AB.txt" %> \out -> do need ["A.txt", "B.txt"] text1 <- readFile' "A.txt"@@ -35,6 +35,9 @@ phony "cleaner" $ removeFilesAfter "dir" ["//*"] + phony "cleandb" $+ removeFilesAfter "." [".shake.database"]+ phony "configure" $ liftIO $ appendFile "configure" "1" @@ -74,7 +77,7 @@ ["sep" </> "3.txt", "sep" </> "4.txt", "sep" </> "5.*", "sep/6.txt"] |%> \out -> writeFile' out "" ["sep" </> "7.txt"] |%> \out -> writeFile' out "" - "ids/source" %> \out -> return ()+ "ids/source" %> \_ -> return () "ids/out" %> \out -> do need =<< readFileLines "ids/source"; writeFile' out "" "ids/*" %> \out -> do alwaysRerun; trace (takeFileName out); writeFile' out $ takeFileName out @@ -129,6 +132,10 @@ build ["cleaner"] sleep 1 -- sometimes takes a while for the file system to notice assertBoolIO (not <$> IO.doesDirectoryExist "dir") "Directory should not exist, cleaner should have removed it"++ assertBoolIO (IO.doesFileExist ".shake.database") "Precondition not met"+ build ["cleandb"]+ assertBoolIO (not <$> IO.doesFileExist ".shake.database") "Postcondition not met" writeFile "zero.txt" "" writeFile "configure" ""
src/Test/Batch.hs view
@@ -9,7 +9,7 @@ import Control.Monad -main = shakeTest test [] $ \opts -> do+main = testBuild test $ do let inp x = x -<.> "in" file <- newResource "log.txt" 1 batch 3 ("*.out" %>) (\out -> do need [inp out]; return out) $ \outs -> do
src/Test/Benchmark.hs view
@@ -13,9 +13,9 @@ ,Option "" ["breadth"] (ReqArg (fmap Breadth . readEither) "INT") ""] -- | Given a breadth and depth come up with a set of build files-main = shakeTest test opts $ \opts -> do- let depth = last $ error "Missing --depth" : [x | Depth x <- opts]- let breadth = last $ error "Missing --breadth" : [x | Breadth x <- opts]+main = testBuildArgs test opts $ \opts -> do+ let depth = last $ 75 : [x | Depth x <- opts]+ let breadth = last $ 75 : [x | Breadth x <- opts] want ["0." ++ show i | i <- [1..breadth]] "*" %> \out -> do@@ -26,5 +26,5 @@ test build = do -- these help to test the stack limit build ["clean"]- build ["--breadth=75","--depth=75"]- build ["--breadth=75","--depth=75"]+ build []+ build []
+ src/Test/Builtin.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}++module Test.Builtin(main) where++import Development.Shake+import Development.Shake.Classes+import Development.Shake.Rule+import System.Directory as IO+import qualified System.IO.Extra as IO+import qualified Data.ByteString.Char8 as BS+import Test.Type+++-- WARNING: This code is also reproduced in "Development.Shake.Rule" as documentation.+-- If it needs editing, you probably need to edit it there too.++newtype File = File FilePath+ deriving (Show,Eq,Hashable,Binary,NFData,Typeable)+type instance RuleResult File = ()++data FileRule = FileRule File (Action ())+ deriving Typeable++addBuiltinFileRule :: Rules ()+addBuiltinFileRule = addBuiltinRule noLint noIdentity run+ where+ fileContents (File x) = do b <- IO.doesFileExist x; if b then IO.readFile' x else return ""++ run :: BuiltinRun File ()+ run key old mode = do+ now <- liftIO $ fileContents key+ if mode == RunDependenciesSame && fmap BS.unpack old == Just now then+ return $ RunResult ChangedNothing (BS.pack now) ()+ else do+ (_, act) <- getUserRuleOne key (const Nothing) $ \(FileRule k act) -> if k == key then Just act else Nothing+ act+ now <- liftIO $ fileContents key+ return $ RunResult ChangedRecomputeDiff (BS.pack now) ()++fileRule :: FilePath -> Action () -> Rules ()+fileRule file act = addUserRule $ FileRule (File file) act++fileNeed :: FilePath -> Action ()+fileNeed = apply1 . File+++main = testBuild test $ do+ addBuiltinFileRule++ fileRule "a.txt" $ return ()+ fileRule "b.txt" $ do+ fileNeed "a.txt"+ liftIO $ appendFile "log.txt" "X"+ liftIO $ writeFile "b.txt" . reverse =<< readFile "a.txt"++ action $ fileNeed "b.txt"+++test build = do+ writeFile "log.txt" ""+ writeFile "a.txt" "test"+ build []+ assertContents "b.txt" "tset"+ assertContents "log.txt" "X"++ build []+ assertContents "log.txt" "X" -- it doesn't rebuild++ writeFile "a.txt" "more"+ build []+ assertContents "b.txt" "erom"
src/Test/C.hs view
@@ -5,7 +5,7 @@ import Development.Shake.FilePath import Test.Type -main = shakeTest_ noTest $ do+main = testBuild noTest $ do let src = root </> "src/Test/C" want ["Main.exe"]
src/Test/Cache.hs view
@@ -7,7 +7,7 @@ import Test.Type -main = shakeTest_ test $ do+main = testBuild test $ do vowels <- newCache $ \file -> do src <- readFile' file liftIO $ appendFile "trace.txt" "1"
+ src/Test/Cleanup.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}++-- Initially copied from https://raw.githubusercontent.com/snoyberg/conduit/master/resourcet/test/main.hs+-- on 2018-10-11+module Test.Cleanup(main) where++import General.Cleanup+import Data.Typeable+import Control.Monad+import Data.IORef+import Control.Exception+import Test.Type+++main = testSimple $ do+ do -- survives releasing bottom+ x <- newIORef (0 :: Int)+ handle (\(_ :: SomeException) -> return ()) $ withCleanup $ \cleanup -> do+ _ <- register cleanup $ modifyIORef x (+1)+ release undefined+ (=== 1) =<< readIORef x++ do -- early release+ x <- newIORef (0 :: Int)+ withCleanup $ \cleanup -> do+ undo <- register cleanup $ modifyIORef x (+1)+ release undo+ (=== 1) =<< readIORef x+ (=== 1) =<< readIORef x++ do -- unprotect keeps resource from being cleared+ x <- newIORef (0 :: Int)+ _ <- withCleanup $ \cleanup -> do+ key <- register cleanup $ writeIORef x 1+ unprotect key+ (=== 0) =<< readIORef x+++ do -- cleanup actions are masked https://github.com/snoyberg/conduit/issues/144+ let checkMasked name = do+ ms <- getMaskingState+ unless (ms == MaskedInterruptible) $+ error $ show (name, ms)+ withCleanup $ \cleanup -> do+ register cleanup (checkMasked "release") >>= release+ register cleanup (checkMasked "normal")+ Left Dummy <- try $ withCleanup $ \cleanup -> do+ register cleanup (checkMasked "exception")+ throwIO Dummy+ return ()+++data Dummy = Dummy+ deriving (Show, Typeable)+instance Exception Dummy
src/Test/Command.hs view
@@ -21,14 +21,14 @@ import Prelude -main = shakeTest_ test $ do+main = testBuild test $ do -- shake_helper must be in a subdirectory so we can test placing that subdir on the $PATH let helper = toNative $ "helper/shake_helper" <.> exe let name !> test = do want [name] name ~> do need ["helper/shake_helper" <.> exe]; test let helper_source = unlines- ["import Control.Concurrent"+ ["import System.Time.Extra" ,"import Control.Monad" ,"import System.Directory" ,"import System.Environment"@@ -44,7 +44,7 @@ ," 'x' -> exitFailure" ," 'c' -> putStrLn =<< getCurrentDirectory" ," 'v' -> putStrLn =<< getEnv rg"- ," 'w' -> threadDelay $ floor $ 1000000 * (read rg :: Double)"+ ," 'w' -> sleep (read rg :: Double)" ," 'r' -> LBS.putStr $ LBS.replicate (read rg) 'x'" ," 'i' -> putStr =<< getContents" ," hFlush stdout"
src/Test/Config.hs view
@@ -10,7 +10,7 @@ import Data.Maybe -main = shakeTest_ test $ do+main = testBuild test $ do want ["hsflags.var","cflags.var","none.var","keys"] usingConfigFile "config" "*.var" %> \out -> do
+ src/Test/Database.hs view
@@ -0,0 +1,75 @@++module Test.Database(main) where++import Control.Concurrent.Extra+import Control.Exception.Extra+import Control.Monad+import Data.List+import Development.Shake+import Development.Shake.Database+import Development.Shake.FilePath+import System.Time.Extra+import System.Directory as IO+import Test.Type+import Data.Functor+import Prelude+++rules = do+ "*.out" %> \out -> do+ liftIO $ appendFile "log.txt" "x"+ copyFile' (out -<.> "in") out+ removeFilesAfter "." ["log.txt"]++ "*.err" %> \out -> fail out++ phony "sleep" $ liftIO $ sleep 20++main = testSimple $ do+ let opts = shakeOptions{shakeFiles="/dev/null"}+ writeFile "a.in" "a"+ writeFile "b.in" "b"+ sleepFileTime+ writeFile "log.txt" ""+ (open, close) <- shakeOpenDatabase opts rules+ db <- open++ ([12], after) <- shakeRunDatabase db [need ["a.out"] >> return 12]+ assertContents "log.txt" "x"++ writeFile "a.in" "A"+ shakeRunDatabase db [need ["a.out","b.out"]]+ assertContents "a.out" "A"+ assertContents "log.txt" "xxx"++ ([13,14], _) <- shakeRunDatabase db [need ["a.out"] >> return 13, return 14]+ assertContents "log.txt" "xxx"++ live <- shakeLiveFilesDatabase db+ sort live === ["a.in","a.out"]++ -- check that parallel runs blow up, and that we can throw async exceptions to kill it+ assertWithin 10 $ do+ threads <- newBarrier+ results <- replicateM 2 newBarrier+ ts <- forM results $ \result -> forkFinally (void $ shakeRunDatabase db [need ["sleep"]]) $ \r -> mask_ $ do+ print $ "Failed with " ++ show r+ signalBarrier result r+ threads <- waitBarrier threads+ me <- myThreadId+ forM_ threads $ \t -> when (t /= me) $ throwTo t $ ErrorCall "ab123c"+ signalBarrier threads ts+ results <- show <$> mapM waitBarrier results+ assertBool ("ab123c" `isInfixOf` results) "Contains ab123c"+ assertBool ("currently running" `isInfixOf` results) "Contains 'currently using'"++ close+ assertException ["already closed"] $ void $ shakeRunDatabase db []++ shakeRunAfter opts after+ assertBoolIO (not <$> IO.doesFileExist "log.txt") "Log must be deleted"++ errs <- shakeWithDatabase opts{shakeStaunch=True, shakeVerbosity=Silent} rules $ \db -> do+ assertException ["Error when running"] $ void $ shakeRunDatabase db [need ["foo.err","bar.err"]]+ shakeErrorsDatabase db+ sort (map fst errs) === ["bar.err","foo.err"]
+ src/Test/Deprioritize.hs view
@@ -0,0 +1,27 @@++module Test.Deprioritize(main) where++import Development.Shake+import Test.Type+++main = testBuild test $ do+ file <- newResource "log.txt" 1+ let log x = withResource file 1 $ liftIO $ appendFile "log.txt" x+ "*.p0" %> \out -> do+ log "0"+ writeFile' out ""+ "*.p1" %> \out -> do+ deprioritize 1+ log "1"+ writeFile' out ""+ "*.p2" %> \out -> do+ deprioritize 2+ log "2"+ writeFile' out ""+++test build = do+ build ["clean"]+ build ["foo.p1","bar.p1","baz.p0","qux.p2"]+ assertContents "log.txt" "0211"
src/Test/Digest.hs view
@@ -6,7 +6,7 @@ import Test.Type -main = shakeTest_ test $ do+main = testBuild test $ do want ["Out.txt","Out2.txt"] "Out.txt" %> \out -> do
src/Test/Directory.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} module Test.Directory(main) where @@ -8,7 +9,7 @@ import Data.Function import Control.Monad import General.Extra-import System.Directory(getCurrentDirectory, createDirectory)+import System.Directory(createDirectory) import qualified System.Directory as IO import qualified System.IO.Extra as IO @@ -27,7 +28,7 @@ f x = [x] -main = shakeTest_ test $ do+main = testBuild test $ do "*.contents" %> \out -> writeFileLines out =<< getDirectoryContents (readEsc $ dropExtension out) "*.dirs" %> \out ->@@ -45,7 +46,6 @@ writeFileLines out $ zipWith ((++) `on` bool) fs ds "dots" %> \out -> do- cwd <- liftIO getCurrentDirectory b1 <- liftM2 (==) (getDirectoryContents ".") (getDirectoryContents "") b2 <- liftM2 (==) (getDirectoryDirs ".") (getDirectoryDirs "") b3 <- liftM2 (==) (getDirectoryFiles "." ["*.txt"]) (getDirectoryFiles "" ["*.txt"])@@ -90,7 +90,7 @@ writeFile (dir </> s) "" removeFiles dir pat createDirectoryRecursive dir- forM_ (map ((,) False) del ++ map ((,) True) keep) $ \(b,s) -> do+ forM_ (map (False,) del ++ map (True,) keep) $ \(b,s) -> do b2 <- (if hasTrailingPathSeparator s then IO.doesDirectoryExist else IO.doesFileExist) $ dir </> s when (b /= b2) $ do let f b = if b then "present" else "missing"
src/Test/Docs.hs view
@@ -18,7 +18,7 @@ -- Older versions of Haddock garbage the --@ markup and have ambiguity errors brokenHaddock = compilerVersion < makeVersion [8] -main = shakeTest_ (unless brokenHaddock . noTest) $ do+main = testBuild (unless brokenHaddock . noTest) $ do let index = "dist/doc/html/shake/index.html" let config = "dist/setup-config" want ["Success.txt"]@@ -55,9 +55,9 @@ need [root </> "src/Test/Docs.hs"] -- so much of the generator is in this module let noR = filter (/= '\r') src <- if "_md" `isSuffixOf` takeBaseName out then- fmap (findCodeMarkdown . lines . noR) $ readFile' $ root </> "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md"+ fmap (findCodeMarkdown . lines . checkBlacklist . noR) $ readFile' $ root </> "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md" else- fmap (findCodeHaddock . noR) $ readFile' $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html"+ fmap (findCodeHaddock . checkBlacklist . noR) $ readFile' $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html" let (imports,rest) = partition ("import " `isPrefixOf`) $ showCode src writeFileChanged out $ unlines $@@ -69,7 +69,10 @@ ,"import Control.Concurrent" ,"import Control.Exception" ,"import Control.Monad"- ,"import Data.ByteString(ByteString)"+ ,"import Data.ByteString(ByteString, pack, unpack)"+ ,"import qualified Data.ByteString.Char8 as BS"+ ,"import qualified System.Directory.Extra as IO"+ ,"import qualified System.IO.Extra as IO" ,"import Data.Char" ,"import Data.Data" ,"import Data.Dynamic"@@ -77,19 +80,21 @@ ,"import System.Time.Extra" ,"import Data.Maybe" ,"import Data.Monoid"- ,"import Development.Shake hiding ((*>),trackAllow)"+ ,"import Development.Shake hiding ((*>))" ,"import Development.Shake.Classes"- ,"import Development.Shake.Rule hiding (trackAllow)"+ ,"import Development.Shake.Database"+ ,"import Development.Shake.Rule" ,"import Development.Shake.Util" ,"import Development.Shake.FilePath" ,"import System.Console.GetOpt" ,"import System.Directory(setCurrentDirectory)" ,"import qualified System.Directory"- ,"import System.Environment(lookupEnv, getEnvironment)"+ ,"import System.Environment(withArgs, lookupEnv, getEnvironment)" ,"import System.Process" ,"import System.Exit" ,"import Control.Applicative" ,"import Control.Monad.IO.Class"+ ,"import Control.Monad.Fail" ,"import System.IO"] ++ ["import " ++ replace "_" "." (drop 5 $ takeBaseName out) | not $ "_md.hs" `isSuffixOf` out] ++ imports ++@@ -127,6 +132,9 @@ ,"str2 = \"\"" ,"def = undefined" ,"var = undefined"+ ,"newValue = undefined"+ ,"newStore = BS.empty"+ ,"change = ChangedNothing" ,"str = \"\""] ++ rest @@ -134,6 +142,8 @@ need [root </> "src/Test/Docs.hs"] -- so much of the generator is in this module need [index] filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"]+ -- filesMd on Travis will only include Manual.md, since it's the only one listed in the .cabal+ -- On AppVeyor, where we build from source, it will check the rest of the website filesMd <- getDirectoryFiles (root </> "docs") ["*.md"] writeFileChanged out $ unlines $ ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs,@@ -153,9 +163,12 @@ need ["Main.hs"] trackAllow ["dist//*"] needSource- cmd_ "ghc -fno-code -ignore-package=hashmap " ["-idist/build/autogen","-i" ++ root </> "src","Main.hs"]+ cmd_ "ghc -fno-code -ignore-package=hashmap" ["-idist/build/autogen","-i" ++ root </> "src","Main.hs"] writeFile' out "" +checkBlacklist :: String -> String+checkBlacklist xs = if null bad then xs else error $ show ("Blacklist", bad)+ where bad = [(w, x) | x <- map lower $ lines xs, w <- blacklist, w `isInfixOf` x] --------------------------------------------------------------------- -- FIND THE CODE@@ -169,7 +182,8 @@ | tag <- ["code","pre"] , x <- insideTag tag src , let bad = nubOrd (insideTag "em" x) \\ italics- , if null bad then True else error $ "Bad italics, " ++ show bad]+ , if null bad then True else error $ "Bad italics, " ++ show bad+ ] findCodeMarkdown :: [String] -> [Code]@@ -180,7 +194,7 @@ indented x = length (takeWhile isSpace x) >= 4 findCodeMarkdown (x:xs) = map (Code . return) (evens $ splitOn "`" x) ++ findCodeMarkdown xs where- evens (x:y:xs) = y : evens xs+ evens (_:x:xs) = x : evens xs evens _ = [] findCodeMarkdown [] = [] @@ -208,10 +222,10 @@ where new = if words x `disjoint` ["cmd","cmd_","Development.Shake.cmd","Development.Shake.cmd_"] then "undefined" else "[\"\"]" showStmt :: Int -> [String] -> [String]-showStmt i [] = []+showStmt _ [] = [] showStmt i xs | isDecl $ unlines xs = map f xs where f x = if fst (word1 x) `elem` dupes then "_" ++ show i ++ "_" ++ x else x-showStmt i (x:xs) | fst (word1 x) `elem` types = ["type Code_" ++ show i ++ " = " ++ x]+showStmt i [x] | fst (word1 x) `elem` types = ["type Code_" ++ show i ++ " = " ++ x] showStmt i [x] | length (words x) <= 2 = ["code_" ++ show i ++ " = (" ++ x ++ ")"] -- deal with operators and sections showStmt i xs | all isPredicate xs, length xs > 1 = zipWith (\j x -> "code_" ++ show i ++ "_" ++ show j ++ " = " ++ x) [1..] xs@@ -277,8 +291,8 @@ "Action Resource Rebuild FilePattern Development.Shake.FilePattern " ++ "Lint Verbosity Rules CmdOption Int Double " ++ "NFData Binary Hashable Eq Typeable Show Applicative " ++- "CmdResult ByteString ProcessHandle Rule Monad Monoid Data TypeRep " ++- "BuiltinRun BuiltinLint"+ "CmdResult ByteString ProcessHandle Rule Monad MonadFail Monoid Data TypeRep " +++ "BuiltinRun BuiltinLint BuiltinCheck ShakeDatabase" -- | Duplicated identifiers which require renaming dupes :: [String]@@ -309,7 +323,8 @@ 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 ghci cabal distcc build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple"+ where programs = words "excel gcc cl make ghc ghci cabal distcc npm build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh apt-get build-multiple"+isProgram _ = False -- | Should a fragment be whitelisted and not checked whitelist :: String -> Bool@@ -317,17 +332,18 @@ whitelist x | elem x $ words $ "newtype do a q m c x value key os contents clean _make " ++ ".. /. // \\ //* dir/*/* dir " ++- "ConstraintKinds TemplateHaskell GeneralizedNewtypeDeriving DeriveDataTypeable TypeFamilies SetConsoleTitle " +++ "ConstraintKinds TemplateHaskell OverloadedLists OverloadedStrings GeneralizedNewtypeDeriving DeriveDataTypeable TypeFamilies SetConsoleTitle " ++ "Data.List System.Directory Development.Shake.FilePath run " ++ "NoProgress Error src about://tracing " ++ ".make/i586-linux-gcc/output build " ++ "/usr/special /usr/special/userbinary " ++- "Hidden extension xterm main opts result flagValues argValues " +++ "Hidden extension xterm main opts result flagValues argValues fail " ++ "HEADERS_DIR /path/to/dir CFLAGS let linkFlags temp code out err " ++ "_shake _shake/build manual chrome://tracing/ compdb " ++ "docs/manual foo.* _build _build/run depfile 0.000s " ++ "@ndm_haskell file-name .PHONY filepath trim base stack extra #include " ++- "*> BuiltinRun BuiltinLint RuleResult"+ "*> BuiltinRun BuiltinLint BuiltinIdentity RuleResult " +++ "oldStore mode node_modules llbuild Makefile" = True whitelist x = x `elem` ["[Foo.hi, Foo.o]"@@ -351,4 +367,18 @@ ,"$(LitE . StringL . loc_filename <$> location)" ,"-d[ FILE], --debug[=FILE]" ,"-r[ FILE], --report[=FILE], --profile[=FILE]"+ ]++blacklist :: [String]+blacklist =+ -- from https://twitter.com/jesstelford/status/992756386160234497+ ["obviously"+ ,"basically"+ ,"simply"+ ,"of course"+ ,"clearly"+ ,"everyone knows"+ -- ,"however"+ -- ,"so,"+ -- ,"easy" ]
src/Test/Errors.hs view
@@ -8,9 +8,12 @@ import Test.Type import Data.List import Control.Monad-import Control.Concurrent+import Control.Concurrent.Extra import General.GetOpt import General.Extra+import Data.IORef+import System.Info+import Data.Version.Extra import Control.Exception.Extra import System.Directory as IO import System.Time.Extra@@ -26,7 +29,7 @@ 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+main = testBuildArgs test optionsEnum $ \args -> do "norule" %> \_ -> need ["norule_isavailable"] @@ -36,11 +39,11 @@ ["failcreates", "failcreates2"] &%> \_ -> writeFile' "failcreates" "" - "recursive_" %> \out -> need ["intermediate_"]- "intermediate_" %> \out -> need ["recursive_"]+ "recursive_" %> \_ -> need ["intermediate_"]+ "intermediate_" %> \_ -> need ["recursive_"] - "rec1" %> \out -> need ["rec2"]- "rec2" %> \out -> need ["rec1"]+ "rec1" %> \_ -> need ["rec2"]+ "rec2" %> \_ -> need ["rec1"] "systemcmd" %> \_ -> cmd "random_missing_command"@@ -65,14 +68,23 @@ catcher "exception1" $ actionOnException $ fail "die" catcher "exception2" $ actionOnException $ return () + "retry*" %> \out -> do+ ref <- liftIO $ newIORef 3+ actionRetry (read [last out]) $ liftIO $ do+ old <- readIORef ref+ writeIORef ref $ old - 1+ if old == 0 then writeFile' out "" else fail "die"+ res <- newResource "resource_name" 1- "resource" %> \out ->+ "resource" %> \_ -> withResource res 1 $ need ["resource-dep"] "overlap.txt" %> \out -> writeFile' out "overlap.txt" "overlap.t*" %> \out -> writeFile' out "overlap.t*" "overlap.*" %> \out -> writeFile' out "overlap.*"+ ["*.txx","*.tox"] &%> \_ -> fail "do not run"+ ["*p.txx"] &%> \_ -> fail "do not run" "chain.2" %> \out -> do src <- readFile' "chain.1"@@ -123,7 +135,7 @@ else writeFileChanged out src - "fast_failure" %> \out -> do+ "fast_failure" %> \_ -> do liftIO $ sleep 0.1 fail "die" "slow_success" %> \out -> do@@ -141,13 +153,29 @@ alwaysRerun liftIO $ appendFile out "x" + "produces1" %> \out -> do+ produces [out <.> "also"]+ writeFile' (out <.> "also") ""+ writeFile' out ""+ "produces2" %> \out -> do+ produces [out <.> "also"]+ writeFile' out ""++ "finalfinal" %> \out -> do+ writeFile' out ""+ lock <- liftIO newLock+ let output = withLock lock . appendFile out+ liftIO (sleep 100)+ `actionFinally` (output "X" >> sleep 0.1)+ `actionFinally` output "Y"+ -- 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","--sleep"]+ build ["clean"] writeFile "chain.1" "x" build ["chain.3","--sleep"]@@ -158,7 +186,7 @@ crash ["failcreate"] ["failcreate"] crash ["failcreates"] ["failcreates"] crash ["recursive_"] ["recursive_","intermediate_","recursive"]- crash ["rec1","rec2"] ["rec1","rec2","recursive"]+ crash ["rec1","rec2"] ["rec1","rec2","indirect recursion","recursive"] crash ["systemcmd"] ["systemcmd","random_missing_command"] crash ["stack1"] ["stack1","stack2","stack3","crash"] @@ -178,26 +206,33 @@ build ["exception2"] assertContents "exception2" "0" + crash ["retry0"] ["positive","0"]+ crash ["retry1"] ["die"]+ build ["retry4"]+ forM_ ["finally3","finally4"] $ \name -> do t <- forkIO $ ignore $ build [name,"--exception"] retry 10 $ sleep 0.1 >> assertContents name "0" throwTo t (IndexOutOfBounds "test") retry 10 $ sleep 0.1 >> assertContents name "1" - crash ["resource"] ["cannot currently call apply","withResource","resource_name"]+ crash ["resource"] ["cannot currently introduce a dependency","withResource","resource_name"] build ["overlap.foo"] assertContents "overlap.foo" "overlap.*" build ["overlap.txt"] assertContents "overlap.txt" "overlap.txt"- crash ["overlap.txx"] ["key matches multiple rules","2","overlap.txx"]+ crash ["overlap.txx"] $+ ["key matches multiple rules","matched: 4","overlap.txx","overlap.t*","overlap.*","*.tox"] +++ ["Test/Errors.hs" | compilerVersion >= readVersion "8.0"] -- when GHC got support for locations crash ["tempfile"] ["tempfile-died"] src <- readFile "tempfile" assertMissing src build ["tempdir"] - crash ["--die"] ["Shake","action","death error"]+ crash ["--die"] $ ["Shake","death error"] +++ ["Test/Errors.hs" | compilerVersion >= readVersion "8.0"] -- when GHC got support for locations putStrLn "## BUILD errors" (out,_) <- IO.captureOutput $ build []@@ -240,3 +275,14 @@ crash ["badoutput"] ["badoutput","BadBinary"] build ["badnone"] -- must be able to still run other rules assertContents "badnone" "xx"++ -- check that produces works+ build ["produces1"]+ crash ["produces2"] ["produces","produces2.also"]++ -- check finally doesn't run twice, See https://github.com/ndmitchell/shake/issues/611+ t <- forkIO $ build ["finalfinal","--quiet"]+ sleep 0.2+ killThread t+ sleep 0.3+ assertContents "finalfinal" "XY"
src/Test/FileLock.hs view
@@ -11,7 +11,7 @@ import Test.Type -main = shakeTest_ test $+main = testBuild test $ action $ do putNormal "Starting sleep" liftIO $ sleep 5
src/Test/FilePath.hs view
@@ -13,9 +13,6 @@ import System.Info.Extra -main = shakeTest_ test $ return ()-- newtype File = File String deriving Show instance Arbitrary File where@@ -23,8 +20,9 @@ shrink (File x) = map File $ shrink x -test build = do- let a === b = a Test.Type.=== b -- duplicate definition in QuickCheck 2.7 and above+main = testSimple $ do+ let infix 1 ===+ a === b = a Test.Type.=== b -- duplicate definition in QuickCheck 2.7 and above let norm x = let s = toStandard $ normaliseEx x@@ -83,6 +81,9 @@ takeDirectory1 "aaa/bbb" === "aaa" takeDirectory1 "aaa/" === "aaa" takeDirectory1 "aaa" === "aaa"++ replaceDirectory1 "root/file.ext" "directory" === "directory" ++ [pathSeparator] ++ "file.ext"+ replaceDirectory1 "root/foo/bar/file.ext" "directory" === "directory" ++ [pathSeparator] ++ "foo/bar/file.ext" searchPathSeparator === Native.searchPathSeparator pathSeparators === Native.pathSeparators
src/Test/FilePattern.hs view
@@ -10,7 +10,6 @@ import Test.Type import Test.QuickCheck hiding ((===)) -main = shakeTest_ test $ return () newtype Pattern = Pattern FilePattern deriving (Show,Eq)@@ -27,7 +26,7 @@ shrink (Path x) = map Path $ shrinkList (\x -> ['/' | x == '\\']) x -test build = do+main = testSimple $ do internalTest let norm = filter (/= ".") . split isPathSeparator let f b pat file = do@@ -211,6 +210,6 @@ where f (".":xs) w = f xs w f (x:xs) (Walk op) = f (x:xs) $ WalkTo $ op [x]- f [x] (WalkTo (file, dir)) = x `elem` file- f (x:xs) (WalkTo (file, dir)) | Just w <- lookup x dir = f xs w+ f [x] (WalkTo (file, _ )) = x `elem` file+ f (x:xs) (WalkTo (_ , dir)) | Just w <- lookup x dir = f xs w f _ _ = False
src/Test/Files.hs view
@@ -9,7 +9,7 @@ import Data.List -main = shakeTest test [] $ \opts -> do+main = testBuild test $ do want ["even.txt","odd.txt"] "A1-plus-B" %> \out -> do@@ -34,6 +34,9 @@ writeFile' a "a" writeFile' b "b" + ["or1.txt","or2.txt","or*.txt"] |%> \x ->+ writeFile' x x+ (\x -> let dir = takeDirectory x in if takeFileName dir /= "pred" then Nothing else Just [dir </> "a.txt",dir </> "b.txt"]) &?> \outs -> mapM_ (`writeFile'` "") outs@@ -56,3 +59,6 @@ build ["A1-plus-B"] removeFile "A2" build ["A1-plus-B"]++ build ["or2.txt","or4.txt"]+ assertContents "or4.txt" "or4.txt"
src/Test/Forward.hs view
@@ -7,7 +7,7 @@ import Control.Monad.Extra import Test.Type -main = shakeTest_ test $ forwardRule $ do+main = testBuild test $ forwardRule $ do let src = root </> "src/Test/C" cs <- getDirectoryFiles src ["*.c"] os <- forP cs $ \c -> do
+ src/Test/History.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE TypeFamilies #-}++module Test.History(main) where++import Development.Shake+import Test.Type+import General.GetOpt+import System.Directory+import Data.List+import Control.Monad+import Prelude++data Args = Die deriving (Eq,Enum,Bounded,Show)++type instance RuleResult FilePath = String++main = testBuildArgs test optionsEnum $ \args -> do+ let die :: a -> a+ die x = if Die `elem` args then error "Die" else x++ "OutFile.txt" %> \out -> die $ copyFile' "In.txt" out++ reader <- addOracleCache $ \x -> die (readFile' x)+ "OutOracle.txt" %> \out -> do+ historyDisable+ writeFile' out =<< reader "In.txt"++ ["OutFiles1.txt","OutFiles2.txt"] &%> \[out1, out2] -> die $ do+ copyFile' "In.txt" out1+ copyFile' "In.txt" out2++test build = do+ let setIn = writeFile "In.txt"+ let outs = ["OutFile.txt","OutOracle.txt","OutFiles1.txt","OutFiles2.txt"]+ let checkOut x = mapM_ (`assertContents` x) outs++ build ["clean"]+ setIn "1"+ build $ ["--share","--sleep"] ++ outs+ checkOut "1"+ setIn "2"+ build $ ["--share","--sleep"] ++ outs+ checkOut "2"++ setIn "1"+ assertException [] $ build ["OutFile.txt","--die","--quiet","--sleep"]+ build $ ["--die","--share"] ++ outs+ checkOut "1"++ setIn "2"+ mapM_ removeFile outs+ build $ ["--die","--share"] ++ outs+ checkOut "2"++ setIn "2"+ removeFile ".shake.database"+ build $ ["--die","--share"] ++ outs+ checkOut "2"
src/Test/Journal.hs view
@@ -14,7 +14,7 @@ rebuilt = unsafePerformIO $ newIORef 0 -main = shakeTest_ test $ do+main = testBuild test $ do want ["a.out","b.out","c.out"] "*.out" %> \out -> do liftIO $ atomicModifyIORef rebuilt $ \a -> (a+1,())
src/Test/Lint.hs view
@@ -16,7 +16,7 @@ type instance RuleResult Zero = Zero -main = shakeTest_ test $ do+main = testBuild test $ do addOracle $ \Zero{} -> do liftIO $ createDirectoryRecursive "dir" liftIO $ setCurrentDirectory "dir"
src/Test/Live.hs view
@@ -5,7 +5,7 @@ import Test.Type -main = shakeTest_ test $ do+main = testBuild test $ do "foo" %> \ out -> do need ["bar"] writeFile' out ""
src/Test/Manual.hs view
@@ -1,7 +1,7 @@ module Test.Manual(main) where -import Development.Shake hiding (copyFileChanged)+import Development.Shake import Development.Shake.FilePath import Test.Type import General.Extra@@ -9,17 +9,14 @@ import System.Info.Extra -main = shakeTest_ test $- action $ fail "The 'manual' example should only be used in test mode"--test build = do+main = testSimple $ do -- we use .git as our destination, despite not being a real git repo -- so that search tools ignore it, and I don't get dupes for every source file let dest = ".git" copyDirectoryChanged (root </> "docs/manual") dest copyDirectoryChanged (root </> "src/Development") $ dest </> "Development" copyDirectoryChanged (root </> "src/General") $ dest </> "General"- copyFileChanged (root </> "src/Paths.hs") $ dest </> "Paths_shake.hs"+ copyFileChangedIO (root </> "src/Paths.hs") $ dest </> "Paths_shake.hs" (_, gccPath) <- findGcc let opts = [Cwd dest, Shell, AddPath [] (maybeToList gccPath)] let cmdline = if isWindows then "build.bat" else "/bin/sh build.sh"
src/Test/Match.hs view
@@ -6,7 +6,7 @@ import Test.Type -main = shakeTest_ test $ do+main = testBuild test $ do let output x file = writeFile' file x ["or*","*or"] |%> output ""@@ -53,7 +53,7 @@ assertContents "priority.txt" "100" build ["altpri.txt","altpri2.txt"]- assertContents "altpri.txt" "20"+ assertContents "altpri.txt" "30" assertContents "altpri2.txt" "23" build ["x","xx"]
src/Test/Monad.hs view
@@ -11,7 +11,6 @@ import Control.Monad.IO.Class -main = shakeTest_ test $ return () run :: ro -> rw -> RAW ro rw a -> IO a@@ -21,7 +20,7 @@ either throwIO return =<< readMVar res -test build = do+main = testSimple $ do let conv x = either (Left . fromException) Right x :: Either (Maybe ArithException) Int let dump rw = liftIO . (=== rw) =<< getRW @@ -67,10 +66,10 @@ -- catch does not scope too far res <- try $ run 1 "test" $- fmap (either show id) $ tryRAW $ captureRAW $ \k -> throwIO Overflow+ fmap (either show id) $ tryRAW $ captureRAW $ \_ -> throwIO Overflow res === Left Overflow res <- try $ run 1 "test" $ do- captureRAW $ \k -> throwIO Overflow+ captureRAW $ \_ -> throwIO Overflow return "x" res === Left Overflow -- test for GHC bug 11555
src/Test/Ninja.hs view
@@ -19,7 +19,7 @@ opts = Option "" ["arg"] (ReqArg Right "") "" -main = shakeTest test [opts] $ \opts -> do+main = testBuildArgs test [opts] $ \opts -> do let real = "real" `elem` opts action $ if real then cmd "ninja" opts@@ -61,6 +61,7 @@ run "-f../../src/Test/Ninja/test5.ninja" assertExists "output file" + -- #565, check multi-file rules that don't create their contents run "-f../../src/Test/Ninja/test7.ninja" writeFile "nocreate.log" ""
src/Test/Ninja/test7.ninja view
@@ -1,3 +1,4 @@+# #565, check multi-file rules that don't create their contents ninja_required_version = 1.5 build test : phony a b rule CUSTOM_COMMAND
src/Test/Oracle.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, ConstraintKinds #-}+{-# LANGUAGE TypeFamilies, ConstraintKinds, ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} module Test.Oracle(main) where@@ -9,6 +9,8 @@ import General.GetOpt import Data.List.Extra import Data.Tuple.Extra+import System.Info+import Data.Version.Extra import Test.Type hiding (RandomType) import qualified Test.Type as T import Control.Monad@@ -36,7 +38,7 @@ data Define = Define String String -- this type produces this result opt = [Option "" ["def"] (ReqArg (Right . uncurry Define . second tail . breakOn "=") "type=value") ""] -main = shakeTest test opt $ \args -> do+main = testBuildArgs test opt $ \args -> do addOracle $ \(T.RandomType _) -> return 42 addOracle $ \(RandomType _) -> return (-42) "randomtype.txt" %> \out -> do@@ -47,13 +49,13 @@ addOracle $ \b -> return $ not b "true.txt" %> \out -> writeFile' out . show =<< askOracle False - let add :: (ShakeValue a, RuleResult a ~ String) => String -> a -> Rules ()+ let add :: forall a . (ShakeValue a, RuleResult a ~ String) => String -> a -> Rules () add name key = do name <.> "txt" %> \out -> do liftIO $ appendFile ".log" "." writeFile' out =<< askOracle key forM_ [val | Define nam val <- args, nam == name] $ \val ->- addOracle $ \k -> let _ = k `asTypeOf` key in return val+ addOracle $ \(_ :: a) -> return val add "string" "" add "unit" () add "int" (0 :: Int)@@ -105,14 +107,15 @@ assertContents ".log" "#!##!" -- check error messages are good- let errors args err = assertException [err] $ build $ "--quiet" : args+ let errors args err = assertException err $ build $ "--quiet" : args build ["--def=unit=test","unit.txt"] errors ["unit.txt"] -- Building with an an Oracle that has been removed- "missing a call to addOracle"+ ["missing a call to addOracle"] errors ["int.txt"] -- Building with an Oracle that I know nothing about- "missing a call to addOracle"+ ["missing a call to addOracle"] - errors ["--def=string=1","--def=string=1"] -- Two Oracles defined in one go- "oracle defined twice"+ errors ["--def=string=1","--def=string=1"] $ -- Two Oracles defined in one go+ "oracle defined twice" :+ ["Test/Oracle.hs" | compilerVersion >= readVersion "8.0"] -- when GHC got support for locations
src/Test/OrderOnly.hs view
@@ -7,7 +7,7 @@ import Control.Exception.Extra -main = shakeTest_ test $ do+main = testBuild test $ do "bar.txt" %> \out -> do alwaysRerun writeFile' out =<< liftIO (readFile "bar.in")
src/Test/Parallel.hs view
@@ -9,7 +9,7 @@ import Data.IORef -main = shakeTest_ test $ do+main = testBuild test $ do "AB.txt" %> \out -> do -- need [obj "A.txt", obj "B.txt"] (text1,text2) <- readFile' "A.txt" `par` readFile' "B.txt"@@ -26,7 +26,7 @@ phony "parallel" $ do active <- liftIO $ newIORef 0- peak <- liftIO $ newIORef 0 + peak <- liftIO $ newIORef 0 void $ parallel $ replicate 8 $ liftIO $ do now <- atomicModifyIORef active $ dupe . succ atomicModifyIORef peak $ dupe . max now
src/Test/Pool.hs view
@@ -2,34 +2,31 @@ module Test.Pool(main) where import Test.Type-import Development.Shake.Internal.Core.Pool+import General.Pool import Control.Concurrent.Extra import Control.Exception.Extra import Control.Monad -main = shakeTest_ test $ return ()---test build = do+main = testSimple $ do -- See #474, we should never be running pool actions masked- let addPool pool act = addPoolStart pool $ do+ let add pool act = addPool PoolStart pool $ do Unmasked <- getMaskingState act forM_ [False,True] $ \deterministic -> do -- check that it aims for exactly the limit forM_ [1..6] $ \n -> do- var <- newMVar (0,0) -- (maximum, current)+ var <- newVar (0,0) -- (maximum, current) runPool deterministic n $ \pool ->- forM_ [1..5] $ \i ->- addPool pool $ do- modifyMVar_ var $ \(mx,now) -> return (max (now+1) mx, now+1)+ replicateM_ 5 $+ add pool $ do+ modifyVar_ var $ \(mx,now) -> return (max (now+1) mx, now+1) -- requires that all tasks get spawned within 0.1s sleep 0.1- modifyMVar_ var $ \(mx,now) -> return (mx,now-1)- res <- takeMVar var+ modifyVar_ var $ \(mx,now) -> return (mx,now-1)+ res <- readVar var res === (min n 5, 0) -- check that exceptions are immediate@@ -37,10 +34,10 @@ started <- newBarrier stopped <- newBarrier res <- try_ $ runPool deterministic 3 $ \pool -> do- addPool pool $ do+ add pool $ do waitBarrier started error "pass"- addPool pool $+ add pool $ flip finally (signalBarrier stopped ()) $ do signalBarrier started () sleep 10@@ -56,8 +53,8 @@ -- check someone spawned when at zero todo still gets run done <- newBarrier runPool deterministic 1 $ \pool ->- addPool pool $- addPool pool $+ add pool $+ add pool $ signalBarrier done () assertWithin 1 $ waitBarrier done @@ -66,12 +63,12 @@ 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'+ addPool PoolBatch pool $ note 'b'+ addPool PoolException pool $ note 'e'+ addPool PoolStart pool $ note 's'+ addPool PoolStart pool $ note 's'+ addPool PoolResume pool $ note 'r'+ addPool PoolException pool $ note 'e' (=== "bssree") =<< readVar res -- check that killing a thread pool stops the tasks, bug 545@@ -79,7 +76,7 @@ died <- newBarrier done <- newBarrier t <- forkIO $ flip finally (signalBarrier died ()) $ runPool deterministic 1 $ \pool ->- addPool pool $+ add pool $ flip onException (signalBarrier done ()) $ do killThread =<< waitBarrier thread sleep 10
src/Test/Progress.hs view
@@ -1,6 +1,7 @@ module Test.Progress(main) where import Development.Shake.Internal.Progress+import Development.Shake.Internal.Options import Test.Type import System.Directory.Extra import System.FilePath@@ -8,7 +9,7 @@ import Prelude -main = shakeTest_ test $ return ()+main = testBuild test $ return () -- | Given a list of todo times, get out a list of how long is predicted
src/Test/Random.hs view
@@ -34,7 +34,7 @@ arg = [Option "" ["arg"] (ReqArg Right "") ""] -main = shakeTest test arg $ \args -> do+main = testBuildArgs test arg $ \args -> do let toFile (Input i) = "input-" ++ show i ++ ".txt" toFile (Output i) = "output-" ++ show i ++ ".txt" toFile Bang = error "BANG"@@ -79,7 +79,7 @@ writeFile ("input-" ++ show i ++ ".txt") $ show $ Single i logic <- randomLogic runLogic [] logic- chng <- filterM (const randomIO) inputRange + chng <- filterM (const randomIO) inputRange forM_ chng $ \i -> writeFile ("input-" ++ show i ++ ".txt") $ show $ Single $ negate i runLogic chng logic@@ -106,10 +106,12 @@ j <- randomRIO (1::Int,8) build $ ("-j" ++ show j) : map ((++) "--arg=" . show) (xs ++ map Want wants) - let value i = case [ys | Logic j ys <- xs, j == i] of- [ys] -> Multiple $ flip map ys $ map $ \i -> case i of+ let value i =+ let ys = head [ys | Logic j ys <- xs, j == i]+ in Multiple $ flip map ys $ map $ \i -> case i of Input i -> Single $ if i `elem` negated then negate i else i Output i -> value i+ Bang -> error "BANG" forM_ (concat wants) $ \i -> do let wanted = value i got <- fmap read $ IO.readFile' $ "output-" ++ show i ++ ".txt"@@ -128,6 +130,7 @@ i <- randomRIO (0, length xs) let (before,after) = splitAt i xs return $ Logic log $ before ++ [Bang] : after+ f x = return x randomLogic :: IO [Logic] -- only Logic constructors@@ -135,7 +138,7 @@ rules <- randomRIO (1,100) f rules $ map Input inputRange where- f 0 avail = return []+ f 0 _ = return [] f i avail = do needs <- randomRIO (0,3) xs <- replicateM needs $ do
src/Test/Rebuild.hs view
@@ -12,7 +12,7 @@ opts = [Option "" ["timestamp"] (ReqArg (Right . Timestamp) "VALUE") "Value used to detect what has rebuilt when" ,Option "" ["pattern"] (ReqArg (fmap Pattern . readEither) "PATTERN") "Which file rules to use (%>, &?> etc)"] -main = shakeTest test opts $ \args -> do+main = testBuildArgs test opts $ \args -> do let timestamp = concat [x | Timestamp x <- args] let p = last $ PatWildcard : [x | Pattern x <- args] want ["a.txt"]
src/Test/Resources.hs view
@@ -11,7 +11,7 @@ import Data.IORef -main = shakeTest_ test $ do+main = testBuild test $ do -- test I have good Ord and Show do r1 <- newResource "test" 2
src/Test/Self.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-} -module Test.Self(main) where+module Test.Self(main, cabalBuildDepends) where import Development.Shake import Development.Shake.Classes@@ -22,18 +22,18 @@ type instance RuleResult GhcPkg = [String] type instance RuleResult GhcFlags = [String] -main = shakeTest_ noTest $ do+main = testBuild noTest $ do let moduleToFile ext xs = replace "." "/" xs <.> ext want ["Main" <.> exe] -- fixup to cope with Cabal's generated files let fixPaths x = if x == "Paths_shake.hs" then "Paths.hs" else x - ghcPkg <- addOracle $ \GhcPkg{} -> do+ ghcPkg <- addOracleHash $ \GhcPkg{} -> do Stdout out <- quietly $ cmd "ghc-pkg list --simple-output" return $ words out - ghcFlags <- addOracle $ \GhcFlags{} ->+ ghcFlags <- addOracleHash $ \GhcFlags{} -> map ("-package=" ++) <$> readFileLines ".pkgs" let ghc args = do@@ -67,7 +67,7 @@ need $ hs : map (moduleToFile "hi") deps ghc ["-c",hs,"-i" ++ root </> "src","-main-is","Run.main" ,"-hide-all-packages","-outputdir=."- ,"-DPORTABLE","-fwarn-unused-imports"] -- to test one CPP branch+ ,"-DPORTABLE","-fwarn-unused-imports","-Werror"] -- to test one CPP branch ".pkgs" %> \out -> do src <- readFile' $ root </> "shake.cabal"@@ -87,7 +87,7 @@ cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"] packages = words- ("base transformers binary unordered-containers hashable time bytestring primitive " +++ ("base transformers binary unordered-containers hashable heaps time bytestring primitive " ++ "filepath directory process deepseq random utf8-string extra js-jquery js-flot") ++ ["old-time" | compilerVersion < makeVersion [7,6]] ++ ["semigroups" | compilerVersion < makeVersion [8,0]]
+ src/Test/SelfMake.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-}++module Test.SelfMake(main) where++import Development.Shake+import Development.Shake.Classes+import Development.Shake.FilePath+import Development.Shake.Util+import Test.Self(cabalBuildDepends)+import Test.Type++import Control.Applicative+import Control.Monad.Extra+import Data.List.Extra+import System.Info+import Data.Version.Extra+import Prelude+++newtype GhcPkg = GhcPkg () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+newtype GhcFlags = GhcFlags () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)++type instance RuleResult GhcPkg = [String]+type instance RuleResult GhcFlags = [String]++main = testBuild noTest $ do+ want ["Main" <.> exe]++ ghcPkg <- addOracleHash $ \GhcPkg{} -> do+ Stdout out <- quietly $ cmd "ghc-pkg list --simple-output"+ return $ words out++ ghcFlags <- addOracleHash $ \GhcFlags{} ->+ map ("-package=" ++) <$> readFileLines ".pkgs"++ let ghc args = do+ -- since ghc-pkg includes the ghc package, it changes if the version does+ ghcPkg $ GhcPkg ()+ flags <- ghcFlags $ GhcFlags ()+ cmd "ghc" flags args++ "Main" <.> exe %> \out -> do+ let run = root </> "src/Run.hs"+ copyFileChanged (root </> "src" </> "Paths.hs") "Paths_shake.hs"+ let flags =+ ["-i" ++ root </> "src","-dep-suffix=.","-main-is","Run.main"+ ,"-hide-all-packages","-outputdir=."+ ,"-DPORTABLE","-fwarn-unused-imports","-Werror"] -- to test one CPP branch++ trackAllow ["**/*.o"]+ ghc $ ["-M",run] ++ flags+ need . filter (\x -> takeExtension x == ".hs") . concatMap snd . parseMakefile =<< liftIO (readFile "Makefile")+ ghc $ ["-o",out,run] ++ ["-j4" | compilerVersion >= makeVersion [7,8]] ++ flags++ ".pkgs" %> \out -> do+ src <- readFile' $ root </> "shake.cabal"+ writeFileLines out $ sort $ cabalBuildDepends src
src/Test/Tar.hs view
@@ -6,7 +6,7 @@ import Test.Type -main = shakeTest_ noTest $ do+main = testBuild noTest $ do want ["result.tar"] "result.tar" %> \out -> do contents <- fmap (map (root </>)) $ readFileLines $ root </> "src/Test/Tar/list.txt"
src/Test/Tup.hs view
@@ -11,7 +11,7 @@ import Prelude -main = shakeTest_ noTest $ do+main = testBuild noTest $ do -- Example inspired by http://gittup.org/tup/ex_multiple_directories.html usingConfigFile $ root </> "src/Test/Tup/root.cfg"
src/Test/Type.hs view
@@ -2,10 +2,10 @@ module Test.Type( sleep, sleepFileTime, sleepFileTimeCalibrate,- shakeTest, shakeTest_,+ testBuildArgs, testBuild, testSimple, root, noTest, hasTracker,- copyDirectoryChanged, copyFileChanged,+ copyDirectoryChanged, copyFileChangedIO, assertWithin, assertBool, assertBoolIO, assertException, assertContents, assertContentsUnordered, assertContentsWords,@@ -16,7 +16,7 @@ BinarySentinel(..), RandomType(..), ) where -import Development.Shake hiding (copyFileChanged)+import Development.Shake import Development.Shake.Classes import Development.Shake.Forward import Development.Shake.Internal.FileName@@ -31,7 +31,6 @@ import Data.Maybe import Data.Either import Data.Typeable.Extra-import qualified Data.ByteString as BS import System.Directory.Extra as IO import System.Environment.Extra import System.Random@@ -41,22 +40,26 @@ import Prelude -shakeTest+testBuildArgs :: (([String] -> IO ()) -> IO ()) -- ^ The test driver -> [OptDescr (Either String a)] -- ^ Arguments the test can accept -> ([a] -> Rules ()) -- ^ The Shake script under test -> IO () -- ^ Sleep function, driven by passing @--sleep@ -> IO ()-shakeTest f opts g = shakenEx False opts f+testBuildArgs f opts g = shakenEx False opts f (\os args -> if null args then g os else want args >> withoutActions (g os)) -shakeTest_+testBuild :: (([String] -> IO ()) -> IO ()) -- ^ The test driver -> Rules () -- ^ The Shake script under test -> IO () -- ^ Sleep function, driven by passing @--sleep@ -> IO ()-shakeTest_ f g = shakeTest f [] (const g)+testBuild f g = testBuildArgs f [] (const g) +testSimple :: IO () -> IO () -> IO ()+testSimple act = testBuild (const act) (return ())++ shakenEx :: Bool -> [OptDescr (Either String a)]@@ -73,7 +76,6 @@ args <- return $ delete "--forward" args cwd <- getCurrentDirectory let out = "output/" ++ name ++ "/"- let obj x = if null x then "." else x let change = if not reenter then withCurrentDirectory out else id let clean = do now <- getCurrentDirectory@@ -84,14 +86,14 @@ createDirectoryRecursive now unless reenter $ createDirectoryRecursive out case args of- "test":extra -> do+ "test":_ -> do putStrLn $ "## TESTING " ++ name- -- if the extra arguments are not --quiet/--loud it's probably going to go wrong- -- as it is, they do go wrong for random, so disabling for now- change $ test (\args -> withArgs (name:args {- ++ extra -}) $ shakenEx True options test rules sleeper)+ change $ test (\args -> withArgs (name:args) $ shakenEx True options test rules sleeper) putStrLn $ "## FINISHED TESTING " ++ name - "clean":_ -> change clean+ "clean":args -> do+ when (args /= []) $ fail "Unexpected additional arguments to 'clean'"+ change clean "perturb":args -> forever $ do del <- removeFilesRandom out@@ -101,9 +103,7 @@ args -> do t <- tracker- opts <- return $ shakeOptions- {shakeFiles = obj ""- ,shakeReport = [obj "report.html"]}+ opts <- return shakeOptions{shakeFiles = "."} opts <- return $ if forward then forwardOptions opts else opts {shakeLint = Just t ,shakeLintInside = [cwd]@@ -213,7 +213,7 @@ noTest :: ([String] -> IO ()) -> IO () noTest build = do- build ["--abbrev=output=$OUT","-j3"]+ build ["--abbrev=output=$OUT","-j3","--report"] build ["--no-build","--report=-"] build [] @@ -223,9 +223,8 @@ sleepFileTime = sleep 1 -sleepFileTimeCalibrate :: IO (IO ())-sleepFileTimeCalibrate = do- let file = "output/calibrate"+sleepFileTimeCalibrate :: FilePath -> IO (IO ())+sleepFileTimeCalibrate file = do 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@@ -265,14 +264,13 @@ forM_ xs $ \from -> do let to = new </> drop (length $ addTrailingPathSeparator old) from createDirectoryRecursive $ takeDirectory to- copyFileChanged from to+ copyFileChangedIO from to -copyFileChanged :: FilePath -> FilePath -> IO ()-copyFileChanged old new = do- good <- IO.doesFileExist new- good <- if not good then return False else liftM2 (==) (BS.readFile old) (BS.readFile new)- unless good $ copyFile old new+copyFileChangedIO :: FilePath -> FilePath -> IO ()+copyFileChangedIO old new =+ unlessM (liftIO $ IO.doesFileExist new &&^ IO.fileEq old new) $+ copyFile old new -- The operators %> ?> &*> &?> |?> |*> all have an isomorphism data Pat = PatWildcard | PatPredicate | PatOrWildcard | PatAndWildcard | PatAndPredicate@@ -297,7 +295,7 @@ deriving (Eq,Show,NFData,Typeable,Hashable) instance forall a . Typeable a => Binary (BinarySentinel a) where- put (BinarySentinel x) = put $ show (typeRep (Proxy :: Proxy a))+ put (BinarySentinel ()) = put $ show (typeRep (Proxy :: Proxy a)) get = do x <- get let want = show (typeRep (Proxy :: Proxy a))
src/Test/Unicode.hs view
@@ -22,7 +22,7 @@ [Option "" ["prefix"] (ReqArg (Right . Prefix) "") "" ,Option "" ["want"] (ReqArg (Right . Want) "") ""] -main = shakeTest test opts $ \xs -> do+main = testBuildArgs test opts $ \xs -> do let pre = last $ "" : [decode x | Prefix x <- xs :: [Arg]] want [decode x | Want x <- xs] @@ -50,7 +50,7 @@ let ext x = decode pre <.> x res <- try_ $ writeFile (ext "source") "x" case res of- Left err ->+ Left _ -> putStrLn $ "WARNING: Failed to write file " ++ pre ++ ", skipping unicode test (LANG=C ?)" Right _ -> do build ["--prefix=" ++ pre, "--want=" ++ pre <.> "out", "--sleep"]
src/Test/Util.hs view
@@ -5,10 +5,7 @@ import Test.Type -main = shakeTest_ test $ return ()---test build = do+main = testSimple $ do parseMakefile "" === [] parseMakefile "a:b c\ndef : ee" === [("a",["b","c"]),("def",["ee"])] parseMakefile "a: #comment\n#comment : b\nc : d" === [("a",[]),("c",["d"])]
src/Test/Verbosity.hs view
@@ -5,7 +5,7 @@ import Test.Type -main = shakeTest_ test $ do+main = testBuild test $ do "in.txt" %> \out -> do a <- getVerbosity b <- withVerbosity Normal getVerbosity
src/Test/Version.hs view
@@ -1,14 +1,37 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Test.Version(main) where import Development.Shake+import Development.Shake.Classes+import General.GetOpt+import Text.Read.Extra import Test.Type -main = shakeTest_ test $ do- want ["foo.txt"]+newtype Opts = Ver Int+opts = [Option "" ["ver"] (ReqArg (fmap Ver . readEither) "INT") ""]++newtype Oracle = Oracle ()+ deriving (Show,Eq,Hashable,Binary,NFData,Typeable)+type instance RuleResult Oracle = Int++main = testBuildArgs test opts $ \opts -> do+ want ["foo.txt","ver.txt","oracle.txt"]+ "foo.txt" %> \file -> liftIO $ appendFile file "x" + let ver = head $ [x | Ver x <- opts] ++ [0]+ versioned ver $ "ver.txt" %> \out -> liftIO $ appendFile out $ show ver++ versioned ver $ addOracleCache $ \(Oracle ()) -> do+ liftIO $ appendFile "oracle.in" $ show ver+ return $ ver `mod` 2+ "oracle.txt" %> \out -> do+ v <- askOracle $ Oracle ()+ liftIO $ appendFile out $ show v++ test build = do writeFile "foo.txt" "" v1 <- getHashedShakeVersion ["foo.txt"]@@ -19,7 +42,7 @@ build ["clean"] build [] assertContents "foo.txt" "x"- build ["--rule-version=new","--silent"]+ build ["--rule-version=new"] assertContents "foo.txt" "xx" build ["--rule-version=new"] assertContents "foo.txt" "xx"@@ -31,3 +54,19 @@ assertContents "foo.txt" "xxx" build ["--rule-version=final","--silent"] assertContents "foo.txt" "xxxx"++ build ["clean"]+ build []+ assertContents "ver.txt" "0"+ assertContents "foo.txt" "x"+ build ["--ver=0","--silent"]+ assertContents "ver.txt" "0"+ build ["--ver=8"]+ build ["--ver=9","--silent"]+ build ["--ver=9","--silent"]+ build ["--ver=3","--silent"]+ assertContents "ver.txt" "0893"+ assertContents "oracle.in" "0893"+ -- when you change version you don't do cutoff+ assertContents "oracle.txt" "0011"+ assertContents "foo.txt" "x"