packages feed

shake 0.15.11 → 0.16

raw patch · 139 files changed

+8101/−7332 lines, 139 filesdep ~extra

Dependency ranges changed: extra

Files

CHANGES.txt view
@@ -1,5 +1,38 @@ Changelog for Shake +0.16+    #536, make --skip work for oracles+    Ensure shakeOutput is used more consistently+    #49, add shakeColor and --color flags+    #490, recommend -threaded as standard+    #517, ignore ./ in FilePattern+    Require extra-1.5.3+    #499, add a filePattern function, like ?== but with the matches+    #474, never spawn user actions unmasked+    Allow user arguments to replace builtin arguments+    #522, make copyFile create directories if necessary+    #516, add an example for withTempDir+    #514, expose more about cmd arguments+    #523, #524, make sure phony doesn't run its dependencies first+    #515, add cmd_ function+    #506, allow duplicate type names in different modules+    #503, require shakeExtra to obey the sensible invariants+    #503, add getShakeExtra/addShakeExtra+    #492, fix the single letter flag documentation+    Expose 'Process' from Development.Shake+    #495, remove dangling link from LICENSE+    #436, remove Assume, switch to Rebuild+    #419, remove --assume-old and --assume-new, which never worked+    Remove support for running Makefile scripts+    Add getShakeOptionsRules, to get ShakeOptions in Rules+    #479, improve the robustness of the Pool tests+    #481, document how to raise errors in Action+    Delete the deprecated system* functions+    #427, check stored value after checking dependencies+    Significant changes to defining custom rules+    Delete the deprecated defaultRule+    IMPORTANT: Incompatible on disk format change+    #428, don't persist errors to the database 0.15.11     #488, make sure parallel tracks dependencies     #513, permit process-1.4.3.0 and above
LICENSE view
@@ -28,7 +28,3 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.---Some of the JavaScript files in html/ have different copyright and licenses.-Please consult the corresponding source file in js-src/
docs/Manual.md view
@@ -21,12 +21,12 @@             cs <- getDirectoryFiles "" ["//*.c"]             let os = ["_build" </> c -<.> "o" | c <- cs]             need os-            cmd "gcc -o" [out] 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]+            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. @@ -106,15 +106,15 @@     "*.rot13" %> \out -> do         let src = out -<.> "txt"         need [src]-        cmd "rot13" src "-o" out+        cmd_ "rot13" src "-o" out  This rule can build any `.rot13` file. Imagine we are building `"file.rot13"`, it proceeds by:  * Using `let` to define a local variable `src`, using the `-<.>` extension replacement method, which removes the extension from a file and adds a new extension. When `out` is `"file.rot13"` the variable `src` will become `file.txt`. * Using `need` to introduce a dependency on the `src` file, ensuring that if `src` changes then `out` will be rebuilt and that `src` will be up-to-date before any further commands are run.-* Using `cmd` to run the command line `rot13 file.txt -o file.rot13`, which should read `file.txt` and write out `file.rot13` being the ROT13 encoding of the file.+* Using `cmd_` to run the command line `rot13 file.txt -o file.rot13`, which should read `file.txt` and write out `file.rot13` being the ROT13 encoding of the file. -Many rules follow this pattern -- calculate some local variables, `need` some dependencies, then use `cmd` to perform some actions. We now discuss each of the three statements.+Many rules follow this pattern -- calculate some local variables, `need` some dependencies, then use `cmd_` to perform some actions. We now discuss each of the three statements.  #### Local variables @@ -132,7 +132,7 @@      "*.rot13" %> \out -> do         need [out -<.> "txt"]-        cmd "rot13" (out -<.> "txt") "-o" out+        cmd_ "rot13" (out -<.> "txt") "-o" out  Variables are local to the rule they are defined in, cannot be modified, and should not be defined multiple times within a single rule. @@ -155,24 +155,22 @@  #### Running external commands -The `cmd` function allows you to call system commands, e.g. `gcc`. Taking the initial example, we see: +The `cmd_` function allows you to call system commands, e.g. `gcc`. Taking the initial example, we see: -    cmd "gcc -o" [out] os+    cmd_ "gcc -o" [out] os  After substituting `out` (a string variable) and `os` (a list of strings variable) we might get: -    cmd "gcc -o" ["_make/run"] ["_build/main.o","_build/constants.o"]+    cmd_ "gcc -o" ["_make/run"] ["_build/main.o","_build/constants.o"] -The `cmd` function takes any number of space-separated expressions. Each expression can be either a string (which is treated as a space-separated list of arguments) or a list of strings (which is treated as a direct list of arguments).  Therefore the above command line is equivalent to either of:+The `cmd_` function takes any number of space-separated expressions. Each expression can be either a string (which is treated as a space-separated list of arguments) or a list of strings (which is treated as a direct list of arguments).  Therefore the above command line is equivalent to either of: -    cmd "gcc -o _make/run _build/main.o _build/constants.o"-    cmd ["gcc","-o","_make/run","_build/main.o","_build/constants.o"]+    cmd_ "gcc -o _make/run _build/main.o _build/constants.o"+    cmd_ ["gcc","-o","_make/run","_build/main.o","_build/constants.o"]  To properly handle unknown string variables it is recommended to enclose them in a list, e.g. `[out]`, so that even if `out` contains a space it will be treated as a single argument. -The `cmd` function as presented here will fail if the system command returns a non-zero exit code, but see later for how to treat failing commands differently.--As a wart, if the `cmd` call is _not_ the last line of a rule, you must precede it with `() <- cmd ...`.+The `cmd_` function as presented here will fail if the system command returns a non-zero exit code, but see later for how to treat failing commands differently.  #### Filepath manipulation functions @@ -233,7 +231,7 @@     "_build//*.o" %> \out -> do         let c = dropDirectory1 $ out -<.> "c"         let m = out -<.> "m"-        () <- cmd "gcc -c" [c] "-o" [out] "-MMD -MF" [m]+        cmd_ "gcc -c" [c] "-o" [out] "-MMD -MF" [m]         needMakefileDependencies m  We first compute the source file `c` (e.g. `"main.c"`) that is associated with the `out` file (e.g. `"_build/main.o"`). We then compute a temporary file `m` to write the dependencies to (e.g. `"_build/main.m"`). We then call `gcc` using the `-MMD -MF` flags and then finally call `needMakefileDependencies`.@@ -284,7 +282,7 @@      #!/bin/sh     mkdir -p _shake-    ghc --make Build.hs -rtsopts -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@"+    ghc --make Build.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@"  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](http://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/). @@ -325,7 +323,7 @@  Shake features a built in "lint" features to check the build system is well formed. To run use `build --lint`. You are likely to catch more lint violations if you first `build clean`. Sadly, lint does _not_ catch missing dependencies. However, it does catch: -* Changing the current directory, typically with `setCurrentDirectory`. You should never change the current directory within the build system as multiple rules running at the same time share the current directory. You can still run `cmd` calls in different directories using the `Cwd` argument.+* Changing the current directory, typically with `setCurrentDirectory`. You should never change the current directory within the build system as multiple rules running at the same time share the current directory. You can still run `cmd_` calls in different directories using the `Cwd` argument. * Outputs that change after Shake has built them. The usual cause of this error is if the rule for `foo` also writes to the file `bar`, despite `bar` having a different rule producing it.  There is a performance penalty for building with `--lint`, but it is typically small.@@ -353,15 +351,15 @@  #### Advanced `cmd` usage -The `cmd` function can also obtain the stdout and stderr streams, along with the  exit code. As an example:+The `cmd_` has a related function `cmd` that can also obtain the stdout and stderr streams, along with the  exit code. As an example:      (Exit code, Stdout out, Stderr err) <- cmd "gcc --version"  Now the variable `code` is bound to the exit code, while `out` and `err` are bound to the stdout and stderr streams. If `ExitCode` is not requested then any non-zero return value will raise an error. -The `cmd` function also takes additional parameters to control how the command is run. As an example:+Both `cmd_` and `cmd` also takes additional parameters to control how the command is run. As an example: -    cmd Shell (Cwd "temp") "pwd"+    cmd_ Shell (Cwd "temp") "pwd"  This runs the `pwd` command through the system shell, after first changing to the `temp` directory. @@ -371,7 +369,7 @@      link <- getEnv "C_LINK_FLAGS"     let linkFlags = fromMaybe "" link    -    cmd "gcc -o" [output] inputs linkFlags+    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`. @@ -398,9 +396,9 @@     want [show i <.> "exe" | i <- [1..100]]     "*.exe" %> \out -> do         withResource disk 1 $ do-            cmd "ld -o" [out] ...+            cmd_ "ld -o" [out] ...     "*.o" %> \out -> do-        cmd "cl -o" [out] ...+        cmd_ "cl -o" [out] ...  Assuming `-j8`, this allows up to 8 compilers, but only a maximum of 4 linkers. @@ -410,13 +408,13 @@      ["//*.bison.h","//*.bison.c"] &%> \[outh, outc] -> do         let src = outc -<.> "y"-        cmd "bison -d -o" [outc] [src]+        cmd_ "bison -d -o" [outc] [src]  Now we define a list of patterns that are matched, and get a list of output files. If any output file is required, then all output files will be built, with proper dependencies.  #### Changing build rules -Shake build systems are set up to rebuild files when the dependencies change, but mostly assume that the build rules themselves do not change. To minimise the impact of build rule changes there are three approaches:+Shake build systems are set up to rebuild files when the dependencies change, but mostly assume that the build rules themselves do not change (including both the code and the shell commands contained within). To minimise the impact of build rule changes there are three approaches:  _Use configuration files:_ Most build information, such as which files a C file includes, can be computed from source files. Where such information is not available, such as which C files should be linked together to form an executable, use configuration files to provide the information. The rule for linking can use these configuration files, which can be properly tracked. Moving any regularly changing configuration into separate files will significantly reduce the number of build system changes.
docs/manual/build.bat view
@@ -1,2 +1,2 @@ @mkdir _shake 2> nul
-@ghc --make Build.hs -rtsopts -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake\build %*
+@ghc --make Build.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake\build %*
docs/manual/build.sh view
@@ -1,3 +1,3 @@ #!/bin/sh mkdir -p _shake-ghc --make Build.hs -rtsopts -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@"+ghc --make Build.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@"
html/shake.js view
@@ -1,3 +1,6 @@+// GENERATED CODE - DO NOT MODIFY+// SOURCE IS IN THE ts/ DIRECTORY+ "use strict"; var Summary = (function () {     function Summary() {
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.18 build-type:         Simple name:               shake-version:            0.15.11+version:            0.16 license:            BSD3 license-file:       LICENSE category:           Development, Shake@@ -31,7 +31,7 @@     (e.g. compiler version). homepage:           http://shakebuild.com bug-reports:        https://github.com/ndmitchell/shake/issues-tested-with:        GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2+tested-with:        GHC==8.2.1, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 extra-doc-files:     CHANGES.txt     README.md@@ -39,10 +39,6 @@     src/Test/C/constants.c     src/Test/C/constants.h     src/Test/C/main.c-    src/Test/MakeTutor/Makefile-    src/Test/MakeTutor/hellofunc.c-    src/Test/MakeTutor/hellomake.c-    src/Test/MakeTutor/hellomake.h     src/Test/Tar/list.txt     src/Test/Ninja/*.ninja     src/Test/Ninja/subdir/*.ninja@@ -96,8 +92,9 @@         js-jquery,         js-flot,         transformers >= 0.2,-        extra >= 1.4.8,-        deepseq >= 1.1+        extra >= 1.5.3,+        deepseq >= 1.1,+        primitive      if flag(portable)         cpp-options: -DPORTABLE@@ -124,41 +121,48 @@         Development.Ninja.Lexer         Development.Ninja.Parse         Development.Ninja.Type-        Development.Shake.Args-        Development.Shake.ByteString-        Development.Shake.Core-        Development.Shake.CmdOption-        Development.Shake.Database-        Development.Shake.Demo-        Development.Shake.Derived-        Development.Shake.Errors-        Development.Shake.FileInfo-        Development.Shake.FilePattern-        Development.Shake.Monad-        Development.Shake.Pool-        Development.Shake.Profile-        Development.Shake.Progress-        Development.Shake.Resource-        Development.Shake.Rules.Directory-        Development.Shake.Rules.File-        Development.Shake.Rules.Files-        Development.Shake.Rules.Oracle-        Development.Shake.Rules.OrderOnly-        Development.Shake.Rules.Rerun-        Development.Shake.Shake-        Development.Shake.Special-        Development.Shake.Storage-        Development.Shake.Types-        Development.Shake.Value+        Development.Shake.Internal.Args+        General.Makefile+        Development.Shake.Internal.Core.Action+        Development.Shake.Internal.Core.Rendezvous+        Development.Shake.Internal.Core.Rules+        Development.Shake.Internal.Core.Run+        Development.Shake.Internal.CmdOption+        Development.Shake.Internal.Core.Database+        Development.Shake.Internal.Core.Types+        Development.Shake.Internal.Demo+        Development.Shake.Internal.Derived+        Development.Shake.Internal.Errors+        Development.Shake.Internal.FileInfo+        Development.Shake.Internal.FilePattern+        Development.Shake.Internal.Core.Monad+        Development.Shake.Internal.Core.Pool+        Development.Shake.Internal.Profile+        Development.Shake.Internal.Progress+        Development.Shake.Internal.Resource+        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.Core.Storage+        Development.Shake.Internal.Options+        Development.Shake.Internal.Value         General.Bilist         General.Binary+        General.Chunks         General.Cleanup         General.Concurrent         General.Extra         General.FileLock+        General.GetOpt+        General.Ids         General.Intern+        General.ListBuilder         General.Process-        General.String+        Development.Shake.Internal.FileName         General.Template         General.Timing         Paths_shake@@ -188,7 +192,7 @@         js-jquery,         js-flot,         transformers >= 0.2,-        extra >= 1.4.8,+        extra >= 1.5.3,         deepseq >= 1.1,         primitive @@ -203,57 +207,57 @@         build-depends: unix      other-modules:-        Development.Make.All-        Development.Make.Env-        Development.Make.Parse-        Development.Make.Rules-        Development.Make.Type         Development.Ninja.All         Development.Ninja.Env         Development.Ninja.Lexer         Development.Ninja.Parse         Development.Ninja.Type         Development.Shake-        Development.Shake.Args-        Development.Shake.ByteString+        Development.Shake.Internal.Args+        General.Makefile         Development.Shake.Classes-        Development.Shake.CmdOption+        Development.Shake.Internal.CmdOption         Development.Shake.Command-        Development.Shake.Core-        Development.Shake.Database-        Development.Shake.Demo-        Development.Shake.Derived-        Development.Shake.Errors-        Development.Shake.FileInfo+        Development.Shake.Internal.Core.Action+        Development.Shake.Internal.Core.Rendezvous+        Development.Shake.Internal.Core.Rules+        Development.Shake.Internal.Core.Run+        Development.Shake.Internal.Core.Database+        Development.Shake.Internal.Core.Types+        Development.Shake.Internal.Demo+        Development.Shake.Internal.Derived+        Development.Shake.Internal.Errors+        Development.Shake.Internal.FileInfo         Development.Shake.FilePath-        Development.Shake.FilePattern-        Development.Shake.Forward-        Development.Shake.Monad-        Development.Shake.Pool-        Development.Shake.Profile-        Development.Shake.Progress-        Development.Shake.Resource-        Development.Shake.Rule-        Development.Shake.Rules.Directory-        Development.Shake.Rules.File-        Development.Shake.Rules.Files-        Development.Shake.Rules.Oracle-        Development.Shake.Rules.OrderOnly-        Development.Shake.Rules.Rerun-        Development.Shake.Shake-        Development.Shake.Special-        Development.Shake.Storage-        Development.Shake.Types-        Development.Shake.Value+        Development.Shake.Internal.FilePattern+        Development.Shake.Internal.Core.Monad+        Development.Shake.Internal.Core.Pool+        Development.Shake.Internal.Profile+        Development.Shake.Internal.Progress+        Development.Shake.Internal.Resource+        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.Core.Storage+        Development.Shake.Internal.Options+        Development.Shake.Internal.Value         General.Bilist         General.Binary+        General.Chunks         General.Cleanup         General.Concurrent         General.Extra+        General.GetOpt         General.FileLock+        General.Ids         General.Intern+        General.ListBuilder         General.Process-        General.String+        Development.Shake.Internal.FileName         General.Template         General.Timing         Paths_shake@@ -290,7 +294,8 @@         js-flot,         transformers >= 0.2,         deepseq >= 1.1,-        extra >= 1.4.8,+        extra >= 1.5.3,+        primitive,         QuickCheck >= 2.0      if flag(portable)@@ -304,64 +309,66 @@         build-depends: unix      other-modules:-        Development.Make.All-        Development.Make.Env-        Development.Make.Parse-        Development.Make.Rules-        Development.Make.Type         Development.Ninja.All         Development.Ninja.Env         Development.Ninja.Lexer         Development.Ninja.Parse         Development.Ninja.Type         Development.Shake-        Development.Shake.Args-        Development.Shake.ByteString+        Development.Shake.Internal.Args+        General.Makefile         Development.Shake.Classes-        Development.Shake.CmdOption+        Development.Shake.Internal.CmdOption         Development.Shake.Command         Development.Shake.Config-        Development.Shake.Core-        Development.Shake.Database-        Development.Shake.Demo-        Development.Shake.Derived-        Development.Shake.Errors-        Development.Shake.FileInfo+        Development.Shake.Internal.Core.Action+        Development.Shake.Internal.Core.Rendezvous+        Development.Shake.Internal.Core.Rules+        Development.Shake.Internal.Core.Run+        Development.Shake.Internal.Core.Database+        Development.Shake.Internal.Core.Types+        Development.Shake.Internal.Demo+        Development.Shake.Internal.Derived+        Development.Shake.Internal.Errors+        Development.Shake.Internal.FileInfo         Development.Shake.FilePath-        Development.Shake.FilePattern+        Development.Shake.Internal.FilePattern         Development.Shake.Forward-        Development.Shake.Monad-        Development.Shake.Pool-        Development.Shake.Profile-        Development.Shake.Progress-        Development.Shake.Resource+        Development.Shake.Internal.Core.Monad+        Development.Shake.Internal.Core.Pool+        Development.Shake.Internal.Profile+        Development.Shake.Internal.Progress+        Development.Shake.Internal.Resource         Development.Shake.Rule-        Development.Shake.Rules.Directory-        Development.Shake.Rules.File-        Development.Shake.Rules.Files-        Development.Shake.Rules.Oracle-        Development.Shake.Rules.OrderOnly-        Development.Shake.Rules.Rerun-        Development.Shake.Shake-        Development.Shake.Special-        Development.Shake.Storage-        Development.Shake.Types+        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.Core.Storage+        Development.Shake.Internal.Options         Development.Shake.Util-        Development.Shake.Value+        Development.Shake.Internal.Value         General.Bilist         General.Binary+        General.Chunks         General.Cleanup         General.Concurrent         General.Extra         General.FileLock+        General.Ids+        General.GetOpt         General.Intern+        General.ListBuilder         General.Process-        General.String+        Development.Shake.Internal.FileName         General.Template         General.Timing         Paths_shake         Run-        Test.Assume+        Test.Rebuild         Test.Basic         Test.Benchmark         Test.C@@ -372,6 +379,7 @@         Test.Directory         Test.Docs         Test.Errors+        Test.Existence         Test.FileLock         Test.FilePath         Test.FilePattern@@ -380,7 +388,6 @@         Test.Journal         Test.Lint         Test.Live-        Test.Makefile         Test.Manual         Test.Match         Test.Monad
− src/Development/Make/All.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE RecordWildCards, PatternGuards #-}--module Development.Make.All(runMakefile) where--import Development.Shake hiding (addEnv)-import Development.Shake.FilePath-import Development.Make.Parse-import Development.Make.Env-import Development.Make.Rules-import Development.Make.Type-import qualified System.Directory as IO-import Data.List-import Data.Maybe-import Data.Tuple.Extra-import Control.Applicative-import Control.Monad.Extra-import Control.Exception.Extra-import System.Process-import System.Exit-import System.Environment.Extra-import Control.Monad.Trans.State.Strict-import Prelude---runMakefile :: FilePath -> [String] -> IO (Rules ())-runMakefile file args = do-    env <- defaultEnv-    mk <- parse file-    rs <- eval env mk-    return $ do-        defaultRuleFile_-        case filter (not . isPrefixOf "." . target) rs of-            Ruler x _ _ : _ | null args, '%' `notElem` x -> want_ [x]-            _ -> return ()-        mapM_ (want_ . return) args-        convert rs---data Ruler = Ruler-    {target :: String-    ,prereq :: (Env, Expr) -- Env is the Env at this point-    ,cmds :: (Env, [Command]) -- Env is the Env at the end-    }---eval :: Env -> Makefile -> IO [Ruler]-eval env (Makefile xs) = do-    (rs, env) <- runStateT (concatMapM f xs) env-    return [r{cmds=(env,snd $ cmds r)} | r <- rs]-    where-        f :: Stmt -> StateT Env IO [Ruler]-        f Assign{..} = do-            e <- get-            e <- liftIO $ addEnv name assign expr e-            put e-            return []--        f Rule{..} = do-            e <- get-            target <- liftIO $ words <$> askEnv e targets-            return $ map (\t -> Ruler t (e, prerequisites) (undefined, commands)) target---convert :: [Ruler] -> Rules ()-convert rs = match ??> run-    where-        match s = any (isJust . check s) rs-        check s r = makePattern (target r) s--        run target =  do-            let phony = has False ".PHONY" target-            let silent = has True ".SILENT" target-            (deps, cmds) <- fmap (first concat . second concat . unzip) $ forM rs $ \r ->-                case check target r of-                    Nothing -> return ([], [])-                    Just op -> do-                        let (preEnv,preExp) = prereq r-                        env <- liftIO $ addEnv "@" Equals (Lit target) preEnv-                        pre <- liftIO $ askEnv env preExp-                        vp <- liftIO $ fmap splitSearchPath $ askEnv env $ Var "VPATH"-                        pre <- mapM (vpath vp) $ words $ op pre-                        return (pre, [cmds r])-            mapM_ (need_ . return) deps-            forM_ cmds $ \(env,cmd) -> do-                env <- liftIO $ addEnv "@" Equals (Lit target) env-                env <- liftIO $ addEnv "^" Equals (Lit $ unwords deps) env-                env <- liftIO $ addEnv "<" Equals (Lit $ head $ deps ++ [""]) env-                forM_ cmd $ \c ->-                    case c of-                        Expr c -> (if silent then quietly else id) $-                            execCommand =<< liftIO (askEnv env c)-            return $ if phony then Phony else NotPhony--        has auto name target =-            or [(null ws && auto) || target `elem` ws | Ruler t (_,Lit s) _ <- rs, t == name, let ws = words s]---execCommand :: String -> Action ()-execCommand x = do-    res <- if "@" `isPrefixOf` x then sys $ drop 1 x-           else putNormal x >> sys x-    when (res /= ExitSuccess) $-        liftIO $ errorIO $ "System command failed: " ++ x-    where sys = quietly . traced (unwords $ take 1 $ words x) . system---makePattern :: String -> FilePath -> Maybe (String -> String)-makePattern pat v = case break (== '%') pat of-    (pre,'%':post) -> if pre `isPrefixOf` v && post `isSuffixOf` v && rest >= 0-                      then Just $ concatMap (\x -> if x == '%' then subs else [x])-                      else Nothing-        where rest = length v - (length pre + length post)-              subs = take rest $ drop (length pre) v-    _ -> if pat == v then Just id else Nothing---vpath :: [FilePath] -> FilePath -> Action FilePath-vpath [] y = return y-vpath (x:xs) y = do-    b <- doesFileExist $ x </> y-    if b then return $ x </> y else vpath xs y---defaultEnv :: IO Env-defaultEnv = do-    exePath <- getExecutablePath-    env <- getEnvironment-    cur <- IO.getCurrentDirectory-    return $ newEnv $-        ("EXE",if null exe then "" else "." ++ exe) :-        ("MAKE",normaliseEx exePath) :-        ("CURDIR",normaliseEx cur) :-        env
− src/Development/Make/Env.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- | The IO in this module is only to evaluate an envrionment variable,---   the 'Env' itself it passed around purely.-module Development.Make.Env(Env, newEnv, addEnv, askEnv) where--import Development.Make.Type-import Data.Maybe-import qualified Data.HashMap.Strict as Map---newtype Env = Env (Map.HashMap String (Assign,Expr))--newEnv :: [(String,String)] -> Env-newEnv xs = Env $ Map.fromList [(a,(Equals,Lit b)) | (a,b) <- xs]---addEnv :: String -> Assign -> Expr -> Env -> IO Env-addEnv name ass val env@(Env e) = case ass of-    QuestionEquals -> if isJust $ Map.lookup name e then return env else addEnv name Equals val env-    Equals -> return $ Env $ Map.insert name (Equals,val) e-    ColonEquals -> do l <- askEnv env val; return $ Env $ Map.insert name (ColonEquals,Lit l) e-    PlusEquals -> case Map.lookup name e of-        Just (Equals,x) -> return $ Env $ Map.insert name (Equals,Concat [x,Lit " ",val]) e-        Just (ColonEquals,x) -> do l <- askEnv env val; return $ Env $ Map.insert name (ColonEquals,Concat [x,Lit " ",Lit l]) e-        _ -> addEnv name Equals val env---askEnv :: Env -> Expr -> IO String-askEnv (Env e) x = do-    res <- f [] x-    case simplifyExpr res of-        Lit x -> return x-        x -> error $ "Internal error in askEnv, " ++ show x-    where-        f seen (Var x) | x `elem` seen = error $ "Recursion in variables, " ++ show seen-                       | Just (_,y) <- Map.lookup x e = f (x:seen) y-                       | otherwise = return $ Lit ""-        f seen x = descendExprM (f seen) x-
− src/Development/Make/Parse.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module Development.Make.Parse(parse) where--import Development.Make.Type-import Data.Char-import Data.List-import Data.Maybe---trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse---parse :: FilePath -> IO Makefile-parse file = do-    src <- if file == "-" then getContents else readFile file-    return $ parseMakefile src---parseMakefile :: String -> Makefile-parseMakefile xs = Makefile $ rejoin $ concatMap (parse . comments) $ continuations $ lines xs-    where-        continuations (x:y:xs) | "\\" `isSuffixOf` x = continuations $ (init x ++ dropWhile isSpace y):xs-        continuations (x:xs) = x : continuations xs-        continuations [] = []--        comments = takeWhile (/= '#')--        parse x | all isSpace x = []-                | all isSpace $ take 1 x = [Right $ parseCommand $ trim x]-                | (a,b) <- break (== ';') x = Left (parseStmt a) : [Right $ parseCommand $ trim $ drop 1 b | b /= ""]--        rejoin (Left r@Rule{}:Right e:xs) = rejoin $ Left r{commands = commands r ++ [e]} : xs-        rejoin (Right e:xs) = error $ "Command must be under a rule: " ++ show e-        rejoin (Left r:xs) = r : rejoin xs-        rejoin [] = []---parseStmt :: String -> Stmt-parseStmt x-    | (a,'=':b) <- break (== '=') x, ':' `notElem` a =-        if "+" `isSuffixOf` a then Assign (trim $ init a) PlusEquals (parseExpr $ trim b)-        else if "?" `isSuffixOf` a then Assign (trim $ init a) QuestionEquals (parseExpr $ trim b)-        else Assign (trim a) Equals (parseExpr $ trim b)-    | (a,':':b) <- break (== ':') x = case b of-        '=':b -> Assign (trim a) ColonEquals (parseExpr $ trim b)-        ':':'=':b -> Assign (trim a) ColonEquals (parseExpr $ trim b)-        _ -> Rule (parseExpr $ trim a) (parseExpr $ trim $ fromMaybe b $ stripPrefix ":" b) []-    | otherwise = error $ "Invalid statement: " ++ x---parseExpr :: String -> Expr-parseExpr x = simplifyExpr $ Concat $ f x-    where-        f ('$':'$':x) = Lit "$" : f x-        f ('$':'(':xs) = case break (== ')') xs of-            (var,')':rest) -> parseVar var : f rest-            _ -> error $ "Couldn't find trailing `)' after " ++ xs-        f ('$':'{':xs) = case break (== '}') xs of-            (var,'}':rest) -> parseVar var : f rest-            _ -> error $ "Couldn't find trailing `}' after " ++ xs-        f ('$':x:xs) = Var [x] : f xs-        f (x:xs) = Lit [x] : f xs-        f [] = []---parseVar :: String -> Expr-parseVar = Var---parseCommand :: String -> Command-parseCommand = Expr . parseExpr
− src/Development/Make/Rules.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}---- | These are the additional rule types required by Makefile-module Development.Make.Rules(-    need_, want_,-    defaultRuleFile_,-    (??>), Phony(..)-    ) where--import Control.Monad.IO.Class-import System.Directory-import Control.Applicative-import Prelude--import Development.Shake-import Development.Shake.Rule-import Development.Shake.Classes-import Development.Shake.FilePath---- Internal imports-import General.String(BSU, unpackU, packU)-import Development.Shake.FileInfo(ModTime, getFileInfo)--infix 1 ??>-------------------------------------------------------------------------- FILE_ RULES--- These are like file rules, but a rule may not bother creating the result--- Which matches the (insane) semantics of make--- If a file is not produced, it will rebuild forever--newtype File_Q = File_Q BSU-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show File_Q where show (File_Q x) = unpackU x--newtype File_A = File_A (Maybe ModTime)-    deriving (Typeable,Eq,Hashable,Binary,Show,NFData)--instance Rule File_Q File_A where-    storedValue _ (File_Q x) = fmap (File_A . Just . fst) <$> getFileInfo x---defaultRuleFile_ :: Rules ()-defaultRuleFile_ = priority 0 $ rule $ \(File_Q x) -> Just $ liftIO $ do-    res <- getFileInfo x-    case res of-        Nothing -> error $ "Error, file does not exist and no rule available:\n  " ++ unpackU x-        Just (mt,_) -> return $ File_A $ Just mt---need_ :: [FilePath] -> Action ()-need_ xs = (apply $ map (File_Q . packU) xs :: Action [File_A]) >> return ()--want_ :: [FilePath] -> Rules ()-want_ = action . need_--data Phony = Phony | NotPhony deriving Eq--(??>) :: (FilePath -> Bool) -> (FilePath -> Action Phony) -> Rules ()-(??>) test act = rule $ \(File_Q x_) -> let x = unpackU x_ in-    if not $ test x then Nothing else Just $ do-        liftIO $ createDirectoryIfMissing True $ takeDirectory x-        res <- act x-        liftIO $ fmap (File_A . fmap fst) $ if res == Phony-            then return Nothing-            else getFileInfo x_
− src/Development/Make/Type.hs 
@@ -1,57 +0,0 @@--module Development.Make.Type where--import Control.Monad---data Makefile = Makefile [Stmt] deriving Show--data Stmt-    = Rule-        {targets :: Expr-        ,prerequisites :: Expr-        ,commands :: [Command]-        }-    | Assign-        {name :: String-        ,assign :: Assign-        ,expr :: Expr-        }-      deriving Show--data Assign = Equals | ColonEquals | PlusEquals | QuestionEquals deriving Show--data Expr = Apply String [Expr]-          | Concat [Expr]-          | Var String-          | Lit String-            deriving Show--data Command = Expr Expr | String := Expr deriving Show--descendExpr :: (Expr -> Expr) -> Expr -> Expr-descendExpr f (Apply a b) = Apply a $ map f b-descendExpr f (Concat xs) = Concat $ map f xs-descendExpr f x = x--descendExprM :: Monad m => (Expr -> m Expr) -> Expr -> m Expr-descendExprM f (Apply a b) = Apply a `liftM` mapM f b-descendExprM f (Concat xs) = Concat `liftM` mapM f xs-descendExprM f x = return x--transformExpr :: (Expr -> Expr) -> Expr -> Expr-transformExpr f = f . descendExpr (transformExpr f)--simplifyExpr :: Expr -> Expr-simplifyExpr = transformExpr f-    where-        f (Concat xs) = case g xs of-            [] -> Lit ""-            [x] -> x-            xs -> Concat xs-        f x = x--        g (Concat x:xs) = g $ x ++ xs-        g (Lit x:Lit y:xs) = g $ Lit (x ++ y) : xs-        g (x:xs) = x : g xs-        g [] = []
src/Development/Ninja/All.hs view
@@ -24,10 +24,11 @@  -- Internal imports import General.Timing(addTiming)-import Development.Shake.ByteString(filepathNormalise, parseMakefile)-import Development.Shake.Errors(errorStructured)-import Development.Shake.Rules.File(needBS, neededBS)-import Development.Shake.Rules.OrderOnly(orderOnlyBS)+import General.Makefile(parseMakefile)+import Development.Shake.Internal.FileName(filepathNormalise)+import Development.Shake.Internal.Errors(errorStructured)+import Development.Shake.Internal.Rules.File(needBS, neededBS)+import Development.Shake.Internal.Rules.OrderOnly(orderOnlyBS)   runNinja :: FilePath -> [String] -> Maybe String -> IO (Maybe (Rules ()))
src/Development/Ninja/Lexer.hs view
@@ -3,10 +3,11 @@ -- {-# OPTIONS_GHC -ddump-simpl #-}  -- | Lexing is a slow point, the code below is optimised-module Development.Ninja.Lexer(Lexeme(..), lexer, lexerFile) where+module Development.Ninja.Lexer(Lexeme(..), lexerFile) where  import Control.Applicative import Data.Tuple.Extra+import Data.Char import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Unsafe as BS import Development.Ninja.Type@@ -25,11 +26,11 @@  type S = Ptr Word8 -chr :: S -> Char-chr x = Internal.w2c $ unsafePerformIO $ peek x+char :: S -> Char+char x = Internal.w2c $ unsafePerformIO $ peek x -inc :: S -> S-inc x = x `plusPtr` 1+next :: S -> S+next x = x `plusPtr` 1  {-# INLINE dropWhile0 #-} dropWhile0 :: (Char -> Bool) -> Str0 -> Str0@@ -49,8 +50,8 @@             return $! Ptr end `minusPtr` start          go s@(Ptr a) | c == '\0' || f c = a-                     | otherwise = go (inc s)-            where c = chr s+                     | otherwise = go (next s)+            where c = char s  {-# INLINE break00 #-} -- The predicate must return true for '\0'@@ -63,8 +64,8 @@             return $! Ptr end `minusPtr` start          go s@(Ptr a) | f c = a-                     | otherwise = go (inc s)-            where c = chr s+                     | otherwise = go (next s)+            where c = char s  head0 :: Str0 -> Char head0 (Str0 x) = Internal.w2c $ BS.unsafeHead x@@ -95,7 +96,7 @@       deriving Show  isVar, isVarDot :: Char -> Bool-isVar x = x == '-' || x == '_' || (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') || (x >= '0' && x <= '9')+isVar x = x == '-' || x == '_' || isAsciiLower x || isAsciiUpper x || isDigit x isVarDot x = x == '.' || isVar x  endsDollar :: Str -> Bool
src/Development/Ninja/Parse.hs view
@@ -59,7 +59,7 @@     LexDefine a b -> do         addBind env a b         return ninja-    LexBind a b ->+    LexBind a _ ->         error $ "Unexpected binding defining " ++ BS.unpack a
src/Development/Ninja/Type.hs view
@@ -67,6 +67,6 @@     ,buildBind :: [(Str,Str)]     } deriving Show -data Rule = Rule+newtype Rule = Rule     {ruleBind :: [(Str,Expr)]     } deriving Show
src/Development/Shake.hs view
@@ -38,56 +38,13 @@ -- * The theory behind Shake is described in an ICFP 2012 paper, --   <http://community.haskell.org/~ndm/downloads/paper-shake_before_building-10_sep_2012.pdf Shake Before Building -- Replacing Make with Haskell>. --   The <http://www.youtube.com/watch?v=xYCPpXVlqFM associated talk> forms a short overview of Shake .------   /== WRITING A BUILD SYSTEM ==============================/------   When writing a Shake build system, start by defining what you 'want', then write rules---   with '%>' to produce the results. Before calling 'cmd' you should ensure that any files the command---   requires are demanded with calls to 'need'. We offer the following advice to Shake users:------ * If @ghc --make@ or @cabal@ is capable of building your project, use that instead. Custom build systems are---   necessary for many complex projects, but many projects are not complex.------ * The 'shakeArgs' function automatically handles command line arguments. To define non-file targets use 'phony'.------ * Put all result files in a distinguished directory, for example @_make@. You can implement a @clean@---   command by removing that directory, using @'removeFilesAfter' \"_make\" [\"\/\/\*\"]@.------ * To obtain parallel builds set 'shakeThreads' to a number greater than 1.------ * Lots of compilers produce @.o@ files. To avoid overlapping rules, use @.c.o@ for C compilers,---   @.hs.o@ for Haskell compilers etc.------ * Do not be afraid to mix Shake rules, system commands and other Haskell libraries -- use each for what---   it does best.------ * The more accurate the dependencies are, the better. Use additional rules like 'doesFileExist' and---   'getDirectoryFiles' to track information other than just the contents of files. For information in the environment---   that you suspect will change regularly (perhaps @ghc@ version number), either write the information to---   a file with 'alwaysRerun' and 'writeFileChanged', or use 'addOracle'.------   /== GHC BUILD FLAGS ==============================/------   For large build systems the choice of GHC flags can have a significant impact. We recommend:------ > ghc --make MyBuildSystem -rtsopts -with-rtsopts=-I0------   * @-rtsopts@: Allow the setting of further GHC options at runtime.------   * @-I0@: Disable idle garbage collection, to avoid frequent unnecessary garbage collection, see---     <http://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/ a full explanation>.------   * With GHC 7.6 and before, omit @-threaded@: <http://ghc.haskell.org/trac/ghc/ticket/7646 GHC bug 7646>---     can cause a race condition in build systems that write files then read them. Omitting @-threaded@ will---     still allow your 'cmd' actions to run in parallel, so most build systems will still run in parallel.------   * With GHC 7.8 and later you may add @-threaded@, and pass the options @-qg -qb@ to @-with-rtsopts@---     to disable parallel garbage collection. Parallel garbage collection in Shake---     programs typically goes slower than sequential garbage collection, while occupying many cores that---     could be used for running system commands.------   /Acknowledgements/: Thanks to Austin Seipp for properly integrating the profiling code. module Development.Shake(+    -- * Writing a build system+    -- $writing++    -- * GHC build flags+    -- $flags+     -- * Core     shake,     shakeOptions,@@ -96,7 +53,9 @@     liftIO, actionOnException, actionFinally,     ShakeException(..),     -- * Configuration-    ShakeOptions(..), Assume(..), Lint(..), Change(..), getShakeOptions, getHashedShakeVersion,+    ShakeOptions(..), Rebuild(..), Lint(..), Change(..),+    getShakeOptions, getShakeOptionsRules, getHashedShakeVersion,+    getShakeExtra, addShakeExtra,     -- ** Command line     shakeArgs, shakeArgsWith, shakeOptDescrs,     -- ** Progress reporting@@ -104,8 +63,8 @@     -- ** Verbosity     Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,     -- * Running commands-    command, command_, cmd, unit,-    Stdout(..), Stderr(..), Stdouterr(..), Exit(..), CmdTime(..), CmdLine(..),+    command, command_, cmd, cmd_, unit,+    Stdout(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..),     CmdResult, CmdString, CmdOption(..),     addPath, addEnv,     -- * Explicit parallelism@@ -120,7 +79,7 @@     need, want, (%>), (|%>), (?>), phony, (~>), phonys,     (&%>), (&?>),     orderOnly, orderOnlyAction,-    FilePattern, (?==), (<//>),+    FilePattern, (?==), (<//>), filePattern,     needed, trackRead, trackWrite, trackAllow,     -- * Directory rules     doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs,@@ -128,7 +87,7 @@     -- * Environment rules     getEnv, getEnvWithDefault,     -- * Oracle rules-    ShakeValue, addOracle, askOracle, askOracleWith,+    ShakeValue, RuleResult, addOracle, askOracle, askOracleWith,     -- * Special rules     alwaysRerun,     -- * Resources@@ -139,8 +98,7 @@     newCache, newCacheIO,     -- * Deprecated     (*>), (|*>), (&*>),-    (**>), (*>>), (?>>),-    system', systemCwd, systemOutput+    (**>), (*>>), (?>>)     ) where  import Prelude(Maybe, FilePath) -- Since GHC 7.10 duplicates *>@@ -148,22 +106,71 @@ -- I would love to use module export in the above export list, but alas Haddock -- then shows all the things that are hidden in the docs, which is terrible. import Control.Monad.IO.Class-import Development.Shake.Types-import Development.Shake.Core hiding (trackAllow)-import Development.Shake.Derived-import Development.Shake.Errors-import Development.Shake.Progress-import Development.Shake.Args-import Development.Shake.Shake+import Development.Shake.Internal.Value+import Development.Shake.Internal.Options+import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Rules+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.Rules.Directory-import Development.Shake.Rules.File-import Development.Shake.FilePattern-import Development.Shake.Rules.Files-import Development.Shake.Rules.Oracle-import Development.Shake.Rules.OrderOnly-import Development.Shake.Rules.Rerun+import Development.Shake.Internal.FilePattern+import Development.Shake.Internal.Rules.Directory+import Development.Shake.Internal.Rules.File+import Development.Shake.Internal.Rules.Files+import Development.Shake.Internal.Rules.Oracle+import Development.Shake.Internal.Rules.OrderOnly+import Development.Shake.Internal.Rules.Rerun++-- $writing+--+--   When writing a Shake build system, start by defining what you 'want', then write rules+--   with '%>' to produce the results. Before calling 'cmd' you should ensure that any files the command+--   requires are demanded with calls to 'need'. We offer the following advice to Shake users:+--+-- * If @ghc --make@ or @cabal@ is capable of building your project, use that instead. Custom build systems are+--   necessary for many complex projects, but many projects are not complex.+--+-- * The 'shakeArgs' function automatically handles command line arguments. To define non-file targets use 'phony'.+--+-- * Put all result files in a distinguished directory, for example @_make@. You can implement a @clean@+--   command by removing that directory, using @'removeFilesAfter' \"_make\" [\"\/\/\*\"]@.+--+-- * To obtain parallel builds set 'shakeThreads' to a number greater than 1.+--+-- * Lots of compilers produce @.o@ files. To avoid overlapping rules, use @.c.o@ for C compilers,+--   @.hs.o@ for Haskell compilers etc.+--+-- * Do not be afraid to mix Shake rules, system commands and other Haskell libraries -- use each for what+--   it does best.+--+-- * The more accurate the dependencies are, the better. Use additional rules like 'doesFileExist' and+--   'getDirectoryFiles' to track information other than just the contents of files. For information in the environment+--   that you suspect will change regularly (perhaps @ghc@ version number), either write the information to+--   a file with 'alwaysRerun' and 'writeFileChanged', or use 'addOracle'.++-- $flags+--+--   For large build systems the choice of GHC flags can have a significant impact. We recommend:+--+-- > ghc --make MyBuildSystem -threaded -rtsopts "-with-rtsopts=-I0 -qg qb"+--+--   * @-rtsopts@: Allow the setting of further GHC options at runtime.+--+--   * @-I0@: Disable idle garbage collection, to avoid frequent unnecessary garbage collection, see+--     <http://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/ a full explanation>.+--+--   * With GHC 7.6 and before, omit @-threaded@: <http://ghc.haskell.org/trac/ghc/ticket/7646 GHC bug 7646>+--     can cause a race condition in build systems that write files then read them. Omitting @-threaded@ will+--     still allow your 'cmd' actions to run in parallel, so most build systems will still run in parallel.+--+--   * With GHC 7.8 and later you may add @-threaded@, and pass the options @-qg -qb@ to @-with-rtsopts@+--     to disable parallel garbage collection. Parallel garbage collection in Shake+--     programs typically goes slower than sequential garbage collection, while occupying many cores that+--     could be used for running system commands.   ---------------------------------------------------------------------
− src/Development/Shake/Args.hs 
@@ -1,350 +0,0 @@---- | Command line parsing flags.-module Development.Shake.Args(shakeOptDescrs, shakeArgs, shakeArgsWith) where--import Paths_shake-import Development.Shake.Types-import Development.Shake.Core-import Development.Shake.Demo-import Development.Shake.FilePath-import Development.Shake.Rules.File-import Development.Shake.Progress-import Development.Shake.Shake-import General.Timing--import Data.Tuple.Extra-import Control.Concurrent-import Control.Exception.Extra-import Control.Monad-import Data.Char-import Data.Either-import Data.List-import Data.Maybe-import Data.Time-import Data.Version(showVersion)-import System.Console.GetOpt-import System.Directory-import System.Environment-import System.Exit-import System.Time.Extra----- | 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@.---   If there are no file arguments then the 'Rules' are used directly, otherwise the file arguments---   are 'want'ed (after calling 'withoutActions'). As an example:------ @--- main = 'shakeArgs' 'shakeOptions'{'shakeFiles' = \"_make\", 'shakeProgress' = 'progressSimple'} $ do---     'phony' \"clean\" $ 'Development.Shake.removeFilesAfter' \"_make\" [\"\/\/*\"]---     'want' [\"_make\/neil.txt\",\"_make\/emily.txt\"]---     \"_make\/*.txt\" '%>' \\out ->---         ... build action here ...--- @------   This build system will default to building @neil.txt@ and @emily.txt@, while showing progress messages,---   and putting the Shake files in locations such as @_make\/.database@. Some example command line flags:------ * @main --no-progress@ will turn off progress messages.------ * @main -j6@ will build on 6 threads.------ * @main --help@ will display a list of supported flags.------ * @main clean@ will not build anything, but will remove the @_make@ directory, including the---   any 'shakeFiles'.------ * @main _make/henry.txt@ will not build @neil.txt@ or @emily.txt@, but will instead build @henry.txt@.-shakeArgs :: ShakeOptions -> Rules () -> IO ()-shakeArgs opts rules = shakeArgsWith opts [] f-    where f _ files = return $ Just $ if null files then rules else want files >> withoutActions rules----- | A version of 'shakeArgs' with more flexible handling of command line arguments.---   The caller of 'shakeArgsWith' can add additional flags (the second argument) and chose how to convert---   the flags/arguments into rules (the third argument). Given:------ @--- 'shakeArgsWith' opts flags (\\flagValues argValues -> result)--- @------ * @opts@ is the initial 'ShakeOptions' value, which may have some fields overriden by command line flags.---   This argument is usually 'shakeOptions', perhaps with a few fields overriden.------ * @flags@ is a list of flag descriptions, which either produce a 'String' containing an error---   message (typically for flags with invalid arguments, .e.g. @'Left' \"could not parse as int\"@), or a value---   that is passed as @flagValues@. If you have no custom flags, pass @[]@.------ * @flagValues@ is a list of custom flags that the user supplied. If @flags == []@ then this list will---   be @[]@.------ * @argValues@ is a list of non-flag arguments, which are often treated as files and passed to 'want'.------ * @result@ should produce a 'Nothing' to indicate that no building needs to take place, or a 'Just'---   providing the rules that should be used.------   As an example of a build system that can use either @gcc@ or @distcc@ for compiling:------ @--- import System.Console.GetOpt------ data Flags = DistCC deriving Eq--- flags = [Option \"\" [\"distcc\"] (NoArg $ Right DistCC) \"Run distributed.\"]------ main = 'shakeArgsWith' 'shakeOptions' flags $ \\flags targets -> return $ Just $ do---     if null targets then 'want' [\"result.exe\"] else 'want' targets---     let compiler = if DistCC \`elem\` flags then \"distcc\" else \"gcc\"---     \"*.o\" '%>' \\out -> do---         'need' ...---         'cmd' compiler ...---     ...--- @------   Now you can pass @--distcc@ to use the @distcc@ compiler.-shakeArgsWith :: ShakeOptions -> [OptDescr (Either String a)] -> ([a] -> [String] -> IO (Maybe (Rules ()))) -> IO ()-shakeArgsWith baseOpts userOptions rules = do-    addTiming "shakeArgsWith"-    args <- getArgs-    let (flags,files,errs) = getOpt Permute opts args-        (flagsError,flag1) = partitionEithers flags-        (self,user) = partitionEithers flag1-        (flagsExtra,flagsShake) = first concat $ unzip self-        assumeNew = [x | AssumeNew x <- flagsExtra]-        assumeOld = [x | AssumeOld x <- flagsExtra]-        progressReplays = [x | ProgressReplay x <- flagsExtra]-        progressRecords = [x | ProgressRecord x <- flagsExtra]-        changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra]-        printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra]-        oshakeOpts = foldl' (flip ($)) baseOpts flagsShake-        shakeOpts = oshakeOpts {shakeLintInside = map (toStandard . normalise . addTrailingPathSeparator) $-                                                  shakeLintInside oshakeOpts-                               ,shakeLintIgnore = map toStandard $-                                                  shakeLintIgnore oshakeOpts-                               }--    -- error if you pass some clean and some dirty with specific flags-    errs <- return $ errs ++ flagsError ++ ["cannot mix " ++ a ++ " and " ++ b | a:b:_ <--        [["`--assume-new'" | assumeNew/=[] ] ++ ["`--assume-old'" | assumeOld/=[] ] ++ ["explicit targets" | files/=[]]]]--    when (errs /= []) $ do-        putStr $ unlines $ map ("shake: " ++) $ filter (not . null) $ lines $ unlines errs-        showHelp-        exitFailure--    if Help `elem` flagsExtra then-        showHelp-     else if Version `elem` flagsExtra then-        putStrLn $ "Shake build system, version " ++ showVersion version-     else if NumericVersion `elem` flagsExtra then-        putStrLn $ showVersion version-     else if Demo `elem` flagsExtra then-        demo $ shakeStaunch shakeOpts-     else if not $ null progressReplays then do-        dat <- forM progressReplays $ \file -> do-            src <- readFile file-            return (file, map read $ lines src)-        forM_ (if null $ shakeReport shakeOpts then ["-"] else shakeReport shakeOpts) $ \file -> do-            putStrLn $ "Writing report to " ++ file-            writeProgressReport file dat-     else do-        when (Sleep `elem` flagsExtra) $ threadDelay 1000000-        start <- getCurrentTime-        curdir <- getCurrentDirectory-        let redir = case changeDirectory of-                Nothing -> id-                -- get the "html" directory so it caches with the current directory-                -- required only for debug code-                Just d -> bracket_ (getDataFileName "html" >> setCurrentDirectory d) (setCurrentDirectory curdir)-        shakeOpts <- if null progressRecords then return shakeOpts else do-            t <- offsetTime-            return shakeOpts{shakeProgress = \p ->-                bracket-                    (forkIO $ shakeProgress shakeOpts p)-                    killThread-                    $ const $ progressDisplay 1 (const $ return ()) $ do-                        p <- p-                        t <- t-                        forM_ progressRecords $ \file ->-                            appendFile file $ show (t,p) ++ "\n"-                        return p-            }-        (ran,res) <- redir $ do-            when printDirectory $ putStrLn $ "shake: In directory `" ++ curdir ++ "'"-            rules <- rules user files-            case rules of-                Nothing -> return (False,Right ())-                Just rules -> do-                    res <- try_ $ shake shakeOpts $-                        if NoBuild `elem` flagsExtra then withoutActions rules else rules-                    return (True, res)--        if not ran || shakeVerbosity shakeOpts < Normal || NoTime `elem` flagsExtra then-            either throwIO return res-         else-            let esc code = if Color `elem` flagsExtra then escape code else id-            in case res of-                Left err ->-                    if Exception `elem` flagsExtra then-                        throwIO err-                    else do-                        putStrLn $ esc "31" $ show err-                        exitFailure-                Right () -> do-                    stop <- getCurrentTime-                    let tot = diffUTCTime stop start-                        (mins,secs) = divMod (ceiling tot) (60 :: Int)-                        time = show mins ++ ":" ++ ['0' | secs < 10] ++ show secs-                    putStrLn $ esc "32" $ "Build completed in " ++ time ++ "m"-    where-        opts = map (wrap Left . snd) shakeOptsEx ++ map (wrap Right) userOptions-        showHelp = do-            progName <- getProgName-            putStr $ unlines $ ("Usage: " ++ progName ++ " [options] [target] ...") : "Options:" : showOptDescr opts--        wrap :: (a -> b) -> OptDescr (Either String a) -> OptDescr (Either String b)-        wrap = fmapOptDescr . fmap---showOptDescr :: [OptDescr a] -> [String]-showOptDescr xs = concat-    [ if nargs <= 26 then ["  " ++ args ++ replicate (28 - nargs) ' ' ++ desc]-                     else ["  " ++ args, replicate 30 ' ' ++ desc]-    | Option s l arg desc <- xs-    , let args = intercalate ", " $ map (short arg) s ++ map (long arg) l-    , let nargs = length args]-    where short NoArg{} x = "-" ++ [x]-          short (ReqArg _ b) x = "-" ++ [x] ++ " " ++ b-          short (OptArg _ b) x = "-" ++ [x] ++ "[=" ++ b ++ "]"-          long NoArg{} x = "--" ++ x-          long (ReqArg _ b) x = "--" ++ x ++ "=" ++ b-          long (OptArg _ b) x = "--" ++ x ++ "[=" ++ b ++ "]"---fmapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b-fmapOptDescr f (Option a b c d) = Option a b (g c) d-    where g (NoArg a) = NoArg $ f a-          g (ReqArg a b) = ReqArg (f . a) b-          g (OptArg a b) = OptArg (f . a) b----- | A list of command line options that can be used to modify 'ShakeOptions'. Each option returns---   either an error message (invalid argument to the flag) or a function that changes some fields---   in 'ShakeOptions'. The command line flags are @make@ compatible where possbile, but additional---   flags have been added for the extra options Shake supports.-shakeOptDescrs :: [OptDescr (Either String (ShakeOptions -> ShakeOptions))]-shakeOptDescrs = [fmapOptDescr (fmap snd) o | (True, o) <- shakeOptsEx]--data Extra = ChangeDirectory FilePath-           | Version-           | NumericVersion-           | AssumeNew FilePath-           | AssumeOld FilePath-           | PrintDirectory Bool-           | Color-           | Help-           | Sleep-           | NoTime-           | Exception-           | NoBuild-           | ProgressRecord FilePath-           | ProgressReplay FilePath-           | Demo-             deriving Eq---unescape :: String -> String-unescape ('\ESC':'[':xs) = unescape $ drop 1 $ dropWhile (not . isAlpha) xs-unescape (x:xs) = x : unescape xs-unescape [] = []--escape :: String -> String -> String-escape code x = "\ESC[" ++ code ++ "m" ++ x ++ "\ESC[0m"----- | True if it has a potential effect on ShakeOptions-shakeOptsEx :: [(Bool, OptDescr (Either String ([Extra], ShakeOptions -> ShakeOptions)))]-shakeOptsEx =-    [yes $ Option "a" ["abbrev"] (pairArg "abbrev" "FULL=SHORT" $ \a s -> s{shakeAbbreviations=shakeAbbreviations s ++ [a]}) "Use abbreviation in status messages."-    ,yes $ Option "B" ["always-make"] (noArg $ \s -> s{shakeAssume=Just AssumeDirty}) "Unconditionally make all targets."-    ,no  $ Option ""  ["no-build"] (NoArg $ Right ([NoBuild], id)) "Don't build anything."-    ,no  $ Option "C" ["directory"] (ReqArg (\x -> Right ([ChangeDirectory x],id)) "DIRECTORY") "Change to DIRECTORY before doing anything."-    ,yes $ Option ""  ["color","colour"] (NoArg $ Right ([Color], \s -> s{shakeOutput=outputColor (shakeOutput s)})) "Colorize the output."-    ,yes $ Option "d" ["debug"] (OptArg (\x -> Right ([], \s -> s{shakeVerbosity=Diagnostic, shakeOutput=outputDebug (shakeOutput s) x})) "FILE") "Print lots of debugging information."-    ,no  $ Option ""  ["demo"] (NoArg $ Right ([Demo], id)) "Run in demo mode."-    ,yes $ Option ""  ["digest"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeDigest})) "Files change when digest changes."-    ,yes $ Option ""  ["digest-and"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigest})) "Files change when modtime and digest change."-    ,yes $ Option ""  ["digest-and-input"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigestInput})) "Files change on modtime (and digest for inputs)."-    ,yes $ Option ""  ["digest-or"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeOrDigest})) "Files change when modtime or digest change."-    ,yes $ Option ""  ["digest-not"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtime})) "Files change when modtime changes."-    ,no  $ Option ""  ["exception"] (NoArg $ Right ([Exception], id)) "Throw exceptions directly."-    ,yes $ Option ""  ["flush"] (intArg 1 "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds."-    ,yes $ Option ""  ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata."-    ,no  $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit."-    ,yes $ Option "j" ["jobs"] (optIntArg 0 "jobs" "N" $ \i s -> s{shakeThreads=fromMaybe 0 i}) "Allow N jobs/threads at once [default CPUs]."-    ,yes $ Option "k" ["keep-going"] (noArg $ \s -> s{shakeStaunch=True}) "Keep going when some targets can't be made."-    ,yes $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=Just LintBasic}) "Perform limited validation after the run."-    ,yes $ Option ""  ["lint-fsatrace"] (noArg $ \s -> s{shakeLint=Just LintFSATrace}) "Use fsatrace to do validation."-    ,yes $ Option ""  ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."-    ,yes $ Option ""  ["live"] (OptArg (\x -> Right ([], \s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]})) "FILE") "List the files that are live [to live.txt]."-    ,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."-    ,no  $ Option ""  ["numeric-version"] (NoArg $ Right ([NumericVersion],id)) "Print just the version number and exit."-    ,no  $ Option "o" ["old-file","assume-old"] (ReqArg (\x -> Right ([AssumeOld x],id)) "FILE") "Consider FILE to be very old and don't remake it."-    ,yes $ Option ""  ["old-all"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Don't remake any files."-    ,yes $ Option ""  ["assume-skip"] (noArg $ \s -> s{shakeAssume=Just AssumeSkip}) "Don't remake any files this run."-    ,yes $ Option ""  ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."-    ,yes $ Option "r" ["report","profile"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]."-    ,yes $ Option ""  ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report."-    ,yes $ Option ""  ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."-    ,yes $ Option ""  ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."-    ,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything."-    ,no  $ Option ""  ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building."-    ,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."-    ,yes $ Option ""  ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log."-    ,yes $ Option "p" ["progress"] (progress $ optIntArg 1 "progress" "N" $ \i s -> s{shakeProgress=prog $ fromMaybe 5 i}) "Show progress messages [every N secs, default 5]."-    ,yes $ Option ""  ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."-    ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much."-    ,no  $ Option ""  ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time."-    ,yes $ Option ""  ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."-    ,yes $ Option ""  ["touch"] (noArg $ \s -> s{shakeAssume=Just AssumeClean}) "Assume targets are clean."-    ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print tracing information."-    ,no  $ Option "v" ["version"] (NoArg $ Right ([Version],id)) "Print the version number and exit."-    ,no  $ Option "w" ["print-directory"] (NoArg $ Right ([PrintDirectory True],id)) "Print the current directory."-    ,no  $ Option ""  ["no-print-directory"] (NoArg $ Right ([PrintDirectory False],id)) "Turn off -w, even if it was turned on implicitly."-    ,no  $ Option "W" ["what-if","new-file","assume-new"] (ReqArg (\x -> Right ([AssumeNew x],id)) "FILE") "Consider FILE to be infinitely new."-    ]-    where-        yes = (,) True-        no  = (,) False--        move :: Verbosity -> (Int -> Int) -> Verbosity-        move x by = toEnum $ min (fromEnum mx) $ max (fromEnum mn) $ by $ fromEnum x-            where (mn,mx) = (asTypeOf minBound x, asTypeOf maxBound x)--        noArg f = NoArg $ Right ([], f)-        reqArg a f = ReqArg (\x -> Right ([], f x)) a-        intArg mn flag a f = flip ReqArg a $ \x -> case reads x of-            [(i,"")] | i >= mn -> Right ([],f i)-            _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"-        optIntArg mn flag a f = flip OptArg a $ maybe (Right ([], f Nothing)) $ \x -> case reads x of-            [(i,"")] | i >= mn -> Right ([],f $ Just i)-            _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"-        pairArg flag a f = flip ReqArg a $ \x -> case break (== '=') x of-            (a,'=':b) -> Right ([],f (a,b))-            _ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument"--        progress (OptArg func msg) = flip OptArg msg $ \x -> case break (== '=') `fmap` x of-            Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id)-            Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id)-            _ -> func x--        outputDebug output Nothing = output-        outputDebug output (Just file) = \v msg -> do-            when (v /= Diagnostic) $ output v msg-            appendFile file $ unescape msg ++ "\n"--        outputColor output v msg = output v $ escape "34" msg--        prog i p = do-            program <- progressProgram-            progressDisplay i (\s -> progressTitlebar s >> program s) p
− src/Development/Shake/ByteString.hs 
@@ -1,76 +0,0 @@--module Development.Shake.ByteString(parseMakefile, filepathNormalise, linesCR) where--import qualified Data.ByteString.Char8 as BS-import qualified System.FilePath as Native-import System.Info.Extra-import Data.Char-import Data.List---endsSlash :: BS.ByteString -> Bool-endsSlash = BS.isSuffixOf (BS.singleton '\\')--wordsMakefile :: BS.ByteString -> [BS.ByteString]-wordsMakefile = f . BS.splitWith isSpace-    where-        f (x:xs) | BS.null x = f xs-        f (x:y:xs) | endsSlash x = f $ BS.concat [BS.init x, BS.singleton ' ', y] : xs-        f (x:xs) = x : f xs-        f [] = []--parseMakefile :: BS.ByteString -> [(BS.ByteString, [BS.ByteString])]-parseMakefile = concatMap f . join . linesCR-    where-        join xs = case span endsSlash xs of-            ([], []) -> []-            (xs, []) -> [BS.unwords $ map BS.init xs]-            ([], y:ys) -> y : join ys-            (xs, y:ys) -> BS.unwords (map BS.init xs ++ [y]) : join ys--        f x = [(a, wordsMakefile $ BS.drop 1 b) | a <- wordsMakefile a]-            where (a,b) = BS.break (== ':') $ BS.takeWhile (/= '#') x----- | This is a hot-spot, so optimised-linesCR :: BS.ByteString -> [BS.ByteString]-linesCR x = case BS.split '\n' x of-    x:xs | Just ('\r',x) <- unsnoc x -> x : map (\x -> case unsnoc x of Just ('\r',x) -> x; _ -> x) xs-    xs -> xs-    where-        -- the ByteString unsnoc was introduced in a newer version-        unsnoc x | BS.null x = Nothing-                 | otherwise = Just (BS.last x, BS.init x)----- | Equivalent to @toStandard . normaliseEx@ from "Development.Shake.FilePath".-filepathNormalise :: BS.ByteString -> BS.ByteString-filepathNormalise xs-    | isWindows, Just (a,xs) <- BS.uncons xs, sep a, Just (b,_) <- BS.uncons xs, sep b = '/' `BS.cons` f xs-    | otherwise = f xs-    where-        sep = Native.isPathSeparator-        f o = deslash o $ BS.concat $ (slash:) $ intersperse slash $ reverse $ (BS.empty:) $ g 0 $ reverse $ split o--        deslash o x-            | x == slash = case (pre,pos) of-                (True,True) -> slash-                (True,False) -> BS.pack "/."-                (False,True) -> BS.pack "./"-                (False,False) -> dot-            | otherwise = (if pre then id else BS.tail) $ (if pos then id else BS.init) x-            where pre = not (BS.null o) && sep (BS.head o)-                  pos = not (BS.null o) && sep (BS.last o)--        g i [] = replicate i dotDot-        g i (x:xs) | BS.null x = g i xs-        g i (x:xs) | x == dotDot = g (i+1) xs-        g i (x:xs) | x == dot = g i xs-        g 0 (x:xs) = x : g 0 xs-        g i (x:xs) = g (i-1) xs--        split = BS.splitWith sep--dotDot = BS.pack ".."-dot = BS.singleton '.'-slash = BS.singleton '/'
− src/Development/Shake/CmdOption.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-module Development.Shake.CmdOption where--import Data.Data-import qualified Data.ByteString.Lazy.Char8 as LBS---- | Options passed to 'command' or 'cmd' to control how processes are executed.-data CmdOption-    = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory.-    | Env [(String,String)] -- ^ Change the environment variables in the spawned process. By default uses this processes environment.-    | AddEnv String String -- ^ Add an environment variable in the child process.-    | RemEnv String -- ^ Remove an environment variable from the child process.-    | AddPath [String] [String] -- ^ Add some items to the prefix and suffix of the @$PATH@ variable.-    | Stdin String -- ^ Given as the @stdin@ of the spawned process. By default the @stdin@ is inherited.-    | StdinBS LBS.ByteString -- ^ Given as the @stdin@ of the spawned process.-    | FileStdin FilePath -- ^ Take the @stdin@ from a file.-    | Shell -- ^ Pass the command to the shell without escaping - any arguments will be joined with spaces. By default arguments are escaped properly.-    | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default 'String' results use text encoding and 'ByteString' results use binary encoding.-    | Traced String -- ^ Name to use with 'traced', or @\"\"@ for no tracing. By default traces using the name of the executable.-    | Timeout Double -- ^ Abort the computation after N seconds, will raise a failure exit code. Calls 'interruptProcessGroupOf' and 'terminateProcess', but may sometimes fail to abort the process and not timeout.-    | WithStdout Bool -- ^ Should I include the @stdout@ in the exception if the command fails? Defaults to 'False'.-    | WithStderr Bool -- ^ Should I include the @stderr@ in the exception if the command fails? Defaults to 'True'.-    | EchoStdout Bool -- ^ Should I echo the @stdout@? Defaults to 'True' unless a 'Stdout' result is required or you use 'FileStdout'.-    | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required or you use 'FileStderr'.-    | FileStdout FilePath -- ^ Should I put the @stdout@ to a file.-    | FileStderr FilePath -- ^ Should I put the @stderr@ to a file.-    | AutoDeps -- ^ Compute dependencies automatically.-      deriving (Eq,Ord,Show,Data,Typeable)
src/Development/Shake/Command.hs view
@@ -1,5 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, TypeOperators, ScopedTypeVariables, NamedFieldPuns #-}+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} +#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif++ -- | This module provides functions for calling command line programs, primarily --   'command' and 'cmd'. As a simple example: --@@ -10,7 +17,7 @@ --   The functions from this module are now available directly from "Development.Shake". --   You should only need to import this module if you are using the 'cmd' function in the 'IO' monad. module Development.Shake.Command(-    command, command_, cmd, unit, CmdArguments, (:->),+    command, command_, cmd, cmd_, unit, CmdArgument(..), CmdArguments(..), IsCmdArgument(..), (:->),     Stdout(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..),     CmdResult, CmdString, CmdOption(..),     addPath, addEnv,@@ -24,6 +31,7 @@ import Data.Either.Extra import Data.List.Extra import Data.Maybe+import Data.Monoid import System.Directory import System.Environment.Extra import System.Exit@@ -38,13 +46,13 @@ import Control.Applicative import Prelude -import Development.Shake.CmdOption-import Development.Shake.Core+import Development.Shake.Internal.CmdOption+import Development.Shake.Internal.Core.Run import Development.Shake.FilePath-import Development.Shake.FilePattern-import Development.Shake.Types-import Development.Shake.Rules.File-import Development.Shake.Derived+import Development.Shake.Internal.FilePattern+import Development.Shake.Internal.Options+import Development.Shake.Internal.Rules.File+import Development.Shake.Internal.Derived  --------------------------------------------------------------------- -- ACTUAL EXECUTION@@ -137,7 +145,7 @@             | otherwise = act exe args          shelled = runShell (unwords $ exe : args)-                              +         ignore = map (?==) shakeLintIgnore         ham cwd xs = [makeRelative cwd x | x <- map toStandard xs                                          , any (`isPrefixOf` x) shakeLintInside@@ -196,7 +204,7 @@             pxs <- liftIO $ parseFSAT <$> readFileUTF8' file             xs <- liftIO $ filterM doesFileExist [x | FSATRead x <- pxs]             cwd <- liftIO getCurrentDirectory-            unsafeAllowApply $ needNorm $ ham cwd xs+            unsafeAllowApply $ need $ ham cwd xs             return res      skipper $ tracker $ \exe args -> verboser $ tracer $ commandExplicitIO funcName opts results exe args@@ -387,8 +395,8 @@ newtype Exit = Exit {fromExit :: ExitCode}  -- | Collect the 'ProcessHandle' of the process.---   If you do collect the process handle, the command will run asyncronously and the call to 'cmd'/'command'---   will return as soon as the process is spawned. Any 'Stdout'\/'Stderr' captures will return empty strings.+--   If you do collect the process handle, the command will run asyncronously and the call to 'cmd' \/ 'command'+--   will return as soon as the process is spawned. Any 'Stdout' \/ 'Stderr' captures will return empty strings. newtype Process = Process {fromProcess :: ProcessHandle}  -- | Collect the time taken to execute the process. Can be used in conjunction with 'CmdLine' to@@ -417,6 +425,18 @@ instance CmdString BS.ByteString where cmdString = (BS BS.empty, \(BS x) -> x) instance CmdString LBS.ByteString where cmdString = (LBS LBS.empty, \(LBS x) -> x) ++#if __GLASGOW_HASKELL__ >= 710+class Unit a+instance {-# OVERLAPPING #-} Unit b => Unit (a -> b)+instance {-# OVERLAPPABLE #-} a ~ () => Unit (m a)+#else+class Unit a+instance Unit b => Unit (a -> b)+instance a ~ () => Unit (m a)+#endif++ -- | A class for specifying what results you want to collect from a process. --   Values are formed of 'Stdout', 'Stderr', 'Exit' and tuples of those. class CmdResult a where@@ -528,18 +548,17 @@ --   As some examples, here are some calls, and the resulting command string: -- -- @--- 'unit' $ 'cmd' \"git log --pretty=\" \"oneline\"           -- git log --pretty= oneline--- 'unit' $ 'cmd' \"git log --pretty=\" [\"oneline\"]         -- git log --pretty= oneline--- 'unit' $ 'cmd' \"git log\" (\"--pretty=\" ++ \"oneline\")    -- git log --pretty=oneline--- 'unit' $ 'cmd' \"git log\" (\"--pretty=\" ++ \"one line\")   -- git log --pretty=one line--- 'unit' $ 'cmd' \"git log\" [\"--pretty=\" ++ \"one line\"]   -- git log "--pretty=one line"+-- 'cmd_' \"git log --pretty=\" \"oneline\"           -- git log --pretty= oneline+-- 'cmd_' \"git log --pretty=\" [\"oneline\"]         -- git log --pretty= oneline+-- 'cmd_' \"git log\" (\"--pretty=\" ++ \"oneline\")    -- git log --pretty=oneline+-- 'cmd_' \"git log\" (\"--pretty=\" ++ \"one line\")   -- git log --pretty=one line+-- 'cmd_' \"git log\" [\"--pretty=\" ++ \"one line\"]   -- git log "--pretty=one line" -- @ -- --   More examples, including return values, see this translation of the examples given for the 'command' function: -- -- @--- () <- 'cmd' \"gcc -c myfile.c\"                                  -- compile a file, throwing an exception on failure--- 'unit' $ 'cmd' \"gcc -c myfile.c\"                                 -- alternative to () <- binding.+-- 'cmd_' \"gcc -c myfile.c\"                                         -- compile a file, throwing an exception on failure -- 'Exit' c <- 'cmd' \"gcc -c\" [myfile]                              -- run a command, recording the exit code -- ('Exit' c, 'Stderr' err) <- 'cmd' \"gcc -c myfile.c\"                -- run a command, recording the exit code and error output -- 'Stdout' out <- 'cmd' \"gcc -MM myfile.c\"                         -- run a command, recording the output@@ -549,8 +568,7 @@ --   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, bind the result to @()@, or include a type signature, or use---   the 'unit' function.+--   unable to deduce 'CmdResult'. To avoid this error, use 'cmd_'. -- --   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:@@ -559,31 +577,43 @@ -- 'cmd' ('Cwd' \"generated\") 'Shell' \"gcc -c myfile.c\" :: IO () -- @ cmd :: CmdArguments args => args :-> Action r-cmd = cmdArguments []+cmd = cmdArguments mempty +-- | See 'cmd'. Same as 'cmd' except with a unit result.+-- 'cmd' is to 'cmd_' as 'command' is to 'command_'.+cmd_ :: (CmdArguments args, Unit args) => args :-> Action ()+cmd_ = cmd+ -- | The arguments to 'cmd' - see 'cmd' for examples and semantics.-class CmdArguments t where cmdArguments :: [Either CmdOption String] -> t-instance (Arg a, CmdArguments r) => CmdArguments (a -> r) where-    cmdArguments xs x = cmdArguments $ xs ++ arg x+newtype CmdArgument = CmdArgument [Either CmdOption String]+  deriving (Eq, Monoid, Show)++-- | The arguments to 'cmd' - see 'cmd' for examples and semantics.+class CmdArguments t where+    -- | Arguments to cmd+    cmdArguments :: CmdArgument -> t+instance (IsCmdArgument a, CmdArguments r) => CmdArguments (a -> r) where+    cmdArguments xs x = cmdArguments $ xs `mappend` toCmdArgument x instance CmdResult r => CmdArguments (Action r) where-    cmdArguments x = case partitionEithers x of+    cmdArguments (CmdArgument x) = case partitionEithers x of         (opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicit "cmd" opts a x xs         _ -> error "Error, no executable or arguments given to Development.Shake.cmd" instance CmdResult r => CmdArguments (IO r) where-    cmdArguments x = case partitionEithers x of+    cmdArguments (CmdArgument x) = case partitionEithers x of         (opts, x:xs) -> let (a,b) = cmdResult in b <$> commandExplicitIO "cmd" opts a x xs         _ -> error "Error, no executable or arguments given to Development.Shake.cmd"--instance CmdArguments [Either CmdOption String] where+instance CmdArguments CmdArgument where     cmdArguments = id --class Arg a where arg :: a -> [Either CmdOption String]-instance Arg String where arg = map Right . words-instance Arg [String] where arg = map Right-instance Arg CmdOption where arg = return . Left-instance Arg [CmdOption] where arg = map Left-instance Arg a => Arg (Maybe a) where arg = maybe [] arg+-- | Class to convert an a  to a CmdArgument+class IsCmdArgument a where+    -- | Conversion to a CmdArgument+    toCmdArgument :: a -> CmdArgument+instance IsCmdArgument String where toCmdArgument = CmdArgument . map Right . words+instance IsCmdArgument [String] where toCmdArgument = CmdArgument . map Right+instance IsCmdArgument CmdOption where toCmdArgument = CmdArgument . return . Left+instance IsCmdArgument [CmdOption] where toCmdArgument = CmdArgument . map Left+instance IsCmdArgument a => IsCmdArgument (Maybe a) where toCmdArgument = maybe mempty toCmdArgument   ---------------------------------------------------------------------
src/Development/Shake/Config.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, TypeFamilies #-}  -- | A module for parsing and using config files in a Shake build system. Config files --   consist of variable bindings, for example:@@ -13,6 +13,8 @@ --   @CFLAGS@ (equal to @-g -I\/path\/to\/dir -O2@), and also includes the configuration --   statements in the file @extra/file.cfg@. The full lexical syntax for configuration --   files is defined here: <https://ninja-build.org/manual.html#_lexical_syntax>.+--   The use of Ninja file syntax is due to convenience and the desire to reuse an+--    externally-defined specification (but the choice of configuration language is mostly arbitrary). -- --   To use the configuration file either use 'readConfigFile' to parse the configuration file --   and use the values directly, or 'usingConfigFile' and 'getConfig' to track the configuration@@ -58,7 +60,10 @@  newtype ConfigKeys = ConfigKeys () deriving (Show,Typeable,Eq,Hashable,Binary,NFData) +type instance RuleResult Config = Maybe String+type instance RuleResult ConfigKeys = [String] + -- | Specify the file to use with 'getConfig'. usingConfigFile :: FilePath -> Rules () usingConfigFile file = do@@ -66,7 +71,7 @@         need [file]         liftIO $ readConfigFile file     addOracle $ \(Config x) -> Map.lookup x <$> mp ()-    addOracle $ \(ConfigKeys x) -> sort . Map.keys <$> mp ()+    addOracle $ \(ConfigKeys ()) -> sort . Map.keys <$> mp ()     return ()  @@ -76,6 +81,7 @@ usingConfig :: Map.HashMap String String -> Rules () usingConfig mp = do     addOracle $ \(Config x) -> return $ Map.lookup x mp+    addOracle $ \(ConfigKeys ()) -> return $ sort $ Map.keys mp     return ()
− src/Development/Shake/Core.hs 
@@ -1,971 +0,0 @@-{-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards #-}-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, ConstraintKinds #-}--module Development.Shake.Core(-    run,-    ShakeValue,-    Rule(..), Rules, rule, action, withoutActions, alternatives, priority,-    Action, actionOnException, actionFinally, apply, apply1, traced, getShakeOptions, getProgress,-    trackUse, trackChange, trackAllow,-    getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,-    Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO,-    newCache, newCacheIO,-    unsafeExtraThread, unsafeAllowApply,-    parallel,-    orderOnlyAction,-    -- Internal stuff-    runAfter-    ) where--import Control.Exception.Extra-import Control.Applicative-import Data.Tuple.Extra-import Control.Concurrent.Extra-import Control.Monad.Extra-import Control.Monad.Fix-import Control.Monad.IO.Class-import Control.Monad.Trans.Writer.Strict-import Data.Typeable-import Data.Function-import Data.Either.Extra-import Numeric.Extra-import Data.List.Extra-import qualified Data.HashMap.Strict as Map-import Data.Maybe-import Data.IORef-import System.Directory-import System.IO.Extra-import System.Time.Extra-import Data.Monoid-import System.IO.Unsafe--import Development.Shake.Classes-import Development.Shake.Pool-import Development.Shake.Database-import Development.Shake.Monad-import Development.Shake.Resource-import Development.Shake.Value-import Development.Shake.Profile-import Development.Shake.Types-import Development.Shake.Errors-import Development.Shake.Special-import General.Timing-import General.Extra-import General.Concurrent-import General.Cleanup-import General.String-import Prelude--------------------------------------------------------------------------- RULES---- | Define a pair of types that can be used by Shake rules.---   To import all the type classes required see "Development.Shake.Classes".------   A 'Rule' instance for a class of artifacts (e.g. /files/) provides:------ * How to identify individual artifacts, given by the @key@ type, e.g. with file names.------ * How to describe the state of an artifact, given by the @value@ type, e.g. the file modification time.------ * A way to compare two states of the same individual artifact, with 'equalValue' returning either---   'EqualCheap' or 'NotEqual'.------ * A way to query the current state of an artifact, with 'storedValue' returning the current state,---   or 'Nothing' if there is no current state (e.g. the file does not exist).------   Checking if an artifact needs to be built consists of comparing two @value@s---   of the same @key@ with 'equalValue'. The first value is obtained by applying---   'storedValue' to the @key@ and the second is the value stored in the build---   database after the last successful build.------   As an example, below is a simplified rule for building files, where files are identified---   by a 'FilePath' and their state is identified by a hash of their contents---   (the builtin functions 'Development.Shake.need' and 'Development.Shake.%>'---   provide a similar rule).------ @--- newtype File = File FilePath deriving (Show, Typeable, Eq, Hashable, Binary, NFData)--- newtype Modtime = Modtime Double deriving (Show, Typeable, Eq, Hashable, Binary, NFData)--- getFileModtime file = ...------ instance Rule File Modtime where---     storedValue _ (File x) = do---         exists <- System.Directory.doesFileExist x---         if exists then Just \<$\> getFileModtime x else return Nothing---     equalValue _ _ t1 t2 =---         if t1 == t2 then EqualCheap else NotEqual--- @------   This example instance means:------ * A value of type @File@ uniquely identifies a generated file.------ * A value of type @Modtime@ will be used to check if a file is up-to-date.------   It is important to distinguish 'Rule' instances from actual /rules/. 'Rule'---   instances are one component required for the creation of rules.---   Actual /rules/ are functions from a @key@ to an 'Action'; they are---   added to 'Rules' using the 'rule' function.------   A rule can be created for the instance above with:------ @--- -- Compile foo files; for every foo output file there must be a--- -- single input file named \"filename.foo\".--- compileFoo :: 'Rules' ()--- compileFoo = 'rule' (Just . compile)---     where---         compile :: File -> 'Action' Modtime---         compile (File outputFile) = do---             -- figure out the name of the input file---             let inputFile = outputFile '<.>' \"foo\"---             'unit' $ 'Development.Shake.cmd' \"fooCC\" inputFile outputFile---             -- return the (new) file modtime of the output file:---             getFileModtime outputFile--- @------   /Note:/ In this example, the timestamps of the input files are never---   used, let alone compared to the timestamps of the ouput files.---   Dependencies between output and input files are /not/ expressed by---   'Rule' instances. Dependencies are created automatically by 'apply'.------   For rules whose values are not stored externally,---   'storedValue' should return 'Just' with a sentinel value---   and 'equalValue' should always return 'EqualCheap' for that sentinel.-class (ShakeValue key, ShakeValue value) => Rule key value where--    -- | /[Required]/ Retrieve the @value@ associated with a @key@, if available.-    ---    --   As an example for filenames/timestamps, if the file exists you should return 'Just'-    --   the timestamp, but otherwise return 'Nothing'.-    storedValue :: ShakeOptions -> key -> IO (Maybe value)--    -- | /[Optional]/ Equality check, with a notion of how expensive the check was.-    equalValue :: ShakeOptions -> key -> value -> value -> EqualCost-    equalValue _ _ v1 v2 = if v1 == v2 then EqualCheap else NotEqual---data ARule m = forall key value . Rule key value => ARule (key -> Maybe (m value))--ruleKey :: (key -> Maybe (m value)) -> key-ruleKey = err "ruleKey"--ruleValue :: (key -> Maybe (m value)) -> value-ruleValue = err "ruleValue"----- | 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 Action) IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars)-    deriving (Functor, Applicative, Monad, MonadIO, MonadFix)--newRules :: SRules Action -> Rules ()-newRules = Rules . tell--modifyRules :: (SRules Action -> SRules Action) -> Rules () -> Rules ()-modifyRules f (Rules r) = Rules $ censor f r--getRules :: Rules () -> IO (SRules Action)-getRules (Rules r) = execWriterT r---data SRules m = SRules-    {actions :: [m ()]-    ,rules :: Map.HashMap TypeRep{-k-} (TypeRep{-k-},TypeRep{-v-},[(Double,ARule m)]) -- higher fst is higher priority-    }--instance Monoid (SRules m) where-    mempty = SRules [] (Map.fromList [])-    mappend (SRules x1 x2) (SRules y1 y2) = SRules (x1++y1) (Map.unionWith f x2 y2)-        where f (k, v1, xs) (_, v2, ys)-                | v1 == v2 = (k, v1, xs ++ ys)-                | otherwise = unsafePerformIO $ errorIncompatibleRules k v1 v2--instance Monoid a => Monoid (Rules a) where-    mempty = return mempty-    mappend = liftA2 mappend----- | Add a rule to build a key, returning an appropriate 'Action' if the @key@ matches,---   or 'Nothing' otherwise.---   All rules at a given priority must be disjoint on all used @key@ values, with at most one match.---   Rules have priority 1 by default, which can be modified with 'priority'.-rule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()-rule r = newRules mempty{rules = Map.singleton k (k, v, [(1,ARule r)])}-    where k = typeOf $ ruleKey r; v = typeOf $ ruleValue r----- | Change the priority of a given set of rules, where higher priorities take precedence.---   All matching rules at a given priority must be disjoint, or an error is raised.---   All builtin Shake rules have priority between 0 and 1.---   Excessive use of 'priority' is discouraged. As an example:------ @--- 'priority' 4 $ \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"--- 'priority' 8 $ \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"--- @------   In this example @hello.txt@ will match the second rule, instead of raising an error about ambiguity.------   The 'priority' function obeys the invariants:------ @--- 'priority' p1 ('priority' p2 r1) === 'priority' p1 r1--- 'priority' p1 (r1 >> r2) === 'priority' p1 r1 >> 'priority' p1 r2--- @-priority :: Double -> Rules () -> Rules ()-priority i = modifyRules $ \s -> s{rules = Map.map (\(a,b,cs) -> (a,b,map (first $ const i) cs)) $ rules 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.------ @--- 'alternatives' $ do---     \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"---     \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"--- @------   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{rules = Map.map f $ rules r}-    where-        f (k, v, []) = (k, v, [])-        f (k, v, xs) = let (is,rs) = unzip xs in (k, v, [(maximum is, foldl1' g rs)])--        g (ARule a) (ARule b) = ARule $ \x -> a x `mplus` b2 x-            where b2 = fmap (fmap (fromJust . cast)) . b . fromJust . cast----- | Run an action, usually used for specifying top-level requirements.------ @--- main = 'Development.Shake.shake' 'shakeOptions' $ do---    'action' $ do---        b <- 'Development.Shake.doesFileExist' \"file.src\"---        when b $ 'Development.Shake.need' [\"file.out\"]--- @------   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.------   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=[void a]}----- | Remove all actions specified in a set of rules, usually used for implementing---   command line specification of what to build.-withoutActions :: Rules () -> Rules ()-withoutActions = modifyRules $ \x -> x{actions=[]}---registerWitnesses :: SRules m -> IO ()-registerWitnesses SRules{..} =-    forM_ (Map.elems rules) $ \(_, _, (_,ARule r):_) -> do-        registerWitness $ ruleKey r-        registerWitness $ ruleValue r---data RuleInfo m = RuleInfo-    {stored :: Key -> IO (Maybe Value)-    ,equal :: Key -> Value -> Value -> EqualCost-    ,execute :: Key -> m Value-    ,resultType :: TypeRep-    }--createRuleinfo :: ShakeOptions -> SRules Action -> Map.HashMap TypeRep (RuleInfo Action)-createRuleinfo opt SRules{..} = flip Map.map rules $ \(_,tv,rs) -> RuleInfo (stored rs) (equal rs) (execute rs) tv-    where-        stored ((_,ARule r):_) = fmap (fmap newValue) . f r . fromKey-            where f :: Rule key value => (key -> Maybe (m value)) -> (key -> IO (Maybe value))-                  f _ = storedValue opt--        equal ((_,ARule r):_) = \k v1 v2 -> f r (fromKey k) (fromValue v1) (fromValue v2)-            where f :: Rule key value => (key -> Maybe (m value)) -> key -> value -> value -> EqualCost-                  f _ = equalValue opt--        execute rs = \k -> case filter (not . null) $ map (mapMaybe ($ k)) rs2 of-               [r]:_ -> r-               rs -> liftIO $ errorMultipleRulesMatch (typeKey k) (show k) (length rs)-            where rs2 = sets [(i, \k -> fmap newValue <$> r (fromKey k)) | (i,ARule r) <- rs]--        sets :: Ord a => [(a, b)] -> [[b]] -- highest to lowest-        sets = map snd . reverse . groupSort--runStored :: Map.HashMap TypeRep (RuleInfo m) -> Key -> IO (Maybe Value)-runStored mp k = case Map.lookup (typeKey k) mp of-    Nothing -> return Nothing-    Just RuleInfo{..} -> stored k--runEqual :: Map.HashMap TypeRep (RuleInfo m) -> Key -> Value -> Value -> EqualCost-runEqual mp k v1 v2 = case Map.lookup (typeKey k) mp of-    Nothing -> NotEqual-    Just RuleInfo{..} -> equal k v1 v2--runExecute :: MonadIO m => Map.HashMap TypeRep (RuleInfo m) -> Key -> m Value-runExecute mp k = let tk = typeKey k in case Map.lookup tk mp of-    Nothing -> liftIO $ errorNoRuleToBuildType tk (Just $ show k) Nothing-    Just RuleInfo{..} -> execute k--------------------------------------------------------------------------- MAKE---- global constants of Action-data Global = Global-    {globalDatabase :: Database-    ,globalPool :: Pool-    ,globalCleanup :: Cleanup-    ,globalTimestamp :: IO Seconds-    ,globalRules :: Map.HashMap TypeRep (RuleInfo Action)-    ,globalOutput :: Verbosity -> String -> IO ()-    ,globalOptions  :: ShakeOptions-    ,globalDiagnostic :: String -> IO ()-    ,globalLint :: String -> IO ()-    ,globalAfter :: IORef [IO ()]-    ,globalTrackAbsent :: IORef [(Key, Key)] -- in rule fst, snd must be absent-    ,globalProgress :: IO Progress-    }----- local variables of Action-data Local = Local-    -- constants-    {localStack :: Stack-    -- stack scoped local variables-    ,localVerbosity :: Verbosity-    ,localBlockApply ::  Maybe String -- reason to block apply, or Nothing to allow-    -- mutable local variables-    ,localDepends :: [Depends] -- built up in reverse-    ,localDiscount :: !Seconds-    ,localTraces :: [Trace] -- in reverse-    ,localTrackAllows :: [Key -> Bool]-    ,localTrackUsed :: [Key]-    }---- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files.---   Action values are used by 'rule' and 'action'. The 'Action' monad tracks the dependencies of a 'Rule'.-newtype Action a = Action {fromAction :: RAW Global Local a}-    deriving (Functor, Applicative, Monad, MonadIO)---actionBoom :: Bool -> Action a -> IO b -> Action a-actionBoom runOnSuccess act clean = do-    cleanup <- Action $ getsRO globalCleanup-    clean <- liftIO $ addCleanup cleanup $ void clean-    res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (clean True) >> throwRAW e-    liftIO $ clean runOnSuccess-    return res---- | If an exception is raised by the 'Action', perform some 'IO'.-actionOnException :: Action a -> IO b -> Action a-actionOnException = actionBoom False---- | After an 'Action', perform some 'IO', even if there is an exception.-actionFinally :: Action a -> IO b -> Action a-actionFinally = actionBoom True----- | Internal main function (not exported publicly)-run :: ShakeOptions -> Rules () -> IO ()-run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id) $ do-    opts@ShakeOptions{..} <- if shakeThreads /= 0 then return opts else do p <- getProcessorCount; return opts{shakeThreads=p}--    start <- offsetTime-    rs <- getRules rs-    registerWitnesses rs--    outputLocked <- do-        lock <- newLock-        return $ \v msg -> withLock lock $ shakeOutput v msg--    let diagnostic = if shakeVerbosity >= Diagnostic then outputLocked Diagnostic . ("% "++) else const $ return ()-    let output v = outputLocked v . abbreviate shakeAbbreviations-    diagnostic "Starting run"--    except <- newIORef (Nothing :: Maybe (String, ShakeException))-    let raiseError err-            | not shakeStaunch = throwIO err-            | otherwise = do-                let named = abbreviate shakeAbbreviations . shakeExceptionTarget-                atomicModifyIORef except $ \v -> (Just $ fromMaybe (named err, err) v, ())-                -- no need to print exceptions here, they get printed when they are wrapped--    lint <- if isNothing shakeLint then return $ const $ return () else do-        dir <- getCurrentDirectory-        return $ \msg -> do-            now <- getCurrentDirectory-            when (dir /= now) $ errorStructured-                "Lint checking error - current directory has changed"-                [("When", Just msg)-                ,("Wanted",Just dir)-                ,("Got",Just now)]-                ""-    diagnostic "Starting run 2"--    after <- newIORef []-    absent <- newIORef []-    withCleanup $ \cleanup -> do-        _ <- addCleanup cleanup $ do-            when shakeTimings printTimings-            resetTimings -- so we don't leak memory-        withNumCapabilities shakeThreads $ do-            diagnostic "Starting run 3"-            withDatabase opts diagnostic $ \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 1000000 $ waitBarrier wait--                let ruleinfo = createRuleinfo opts rs-                addTiming "Running rules"-                runPool (shakeThreads == 1) shakeThreads $ \pool -> do-                    let s0 = Global database pool cleanup start ruleinfo output opts diagnostic lint after absent getProgress-                    let s1 = Local emptyStack shakeVerbosity Nothing [] 0 [] [] []-                    forM_ (actions rs) $ \act ->-                        addPool pool $ runAction s0 s1 act $ \x -> case x of-                            Left e -> raiseError =<< shakeException s0 (return ["Top-level action/want"]) e-                            Right x -> return x-                maybe (return ()) (throwIO . snd) =<< readIORef except-                assertFinishedDatabase database--                when (null $ actions rs) $-                    when (shakeVerbosity >= Normal) $ output Normal "Warning: No want/action statements, nothing to do"--                when (isJust shakeLint) $ do-                    addTiming "Lint checking"-                    absent <- readIORef absent-                    checkValid database (runStored ruleinfo) (runEqual ruleinfo) absent-                    when (shakeVerbosity >= Loud) $ output Loud "Lint checking succeeded"-                when (shakeReport /= []) $ do-                    addTiming "Profile report"-                    report <- toReport database-                    forM_ shakeReport $ \file -> do-                        when (shakeVerbosity >= Normal) $-                            output Normal $ "Writing report to " ++ file-                        writeProfile file report-                when (shakeLiveFiles /= []) $ do-                    addTiming "Listing live"-                    live <- listLive database-                    let liveFiles = [show k | k <- live, specialIsFileKey $ typeKey k]-                    forM_ shakeLiveFiles $ \file -> do-                        when (shakeVerbosity >= Normal) $-                            output Normal $ "Writing live list to " ++ file-                        (if file == "-" then putStr else writeFile file) $ unlines liveFiles-            sequence_ . reverse =<< readIORef after---lineBuffering :: IO a -> IO a-lineBuffering = withBuffering stdout LineBuffering . withBuffering stderr LineBuffering---abbreviate :: [(String,String)] -> String -> String-abbreviate [] = id-abbreviate abbrev = f-    where-        -- order so longer abbreviations are preferred-        ordAbbrev = sortOn (negate . length . fst) abbrev--        f [] = []-        f x | (to,rest):_ <- [(to,rest) | (from,to) <- ordAbbrev, Just rest <- [stripPrefix from x]] = to ++ f rest-        f (x:xs) = x : f xs---runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)-runAction g l (Action x) = runRAW g l x---runAfter :: IO () -> Action ()-runAfter op = do-    Global{..} <- Action getRO-    liftIO $ atomicModifyIORef globalAfter $ \ops -> (op:ops, ())----- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel.---   This function requires that appropriate rules have been added with 'rule'.---   All @key@ values passed to 'apply' become dependencies of the 'Action'.-apply :: Rule key value => [key] -> Action [value]-apply = applyForall---- We don't want the forall in the Haddock docs--- Don't short-circuit [] as we still want error messages-applyForall :: forall key value . Rule key value => [key] -> Action [value]-applyForall ks = do-    let tk = typeOf (err "apply key" :: key)-        tv = typeOf (err "apply type" :: value)-    Global{..} <- Action getRO-    block <- Action $ getsRW localBlockApply-    whenJust block $ liftIO . errorNoApply tk (show <$> listToMaybe ks)-    case Map.lookup tk globalRules of-        Nothing -> liftIO $ errorNoRuleToBuildType tk (show <$> listToMaybe ks) (Just tv)-        Just RuleInfo{resultType=tv2} | tv /= tv2 -> liftIO $ errorRuleTypeMismatch tk (show <$> listToMaybe ks) tv2 tv-        _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks---applyKeyValue :: [Key] -> Action [Value]-applyKeyValue [] = return []-applyKeyValue ks = do-    global@Global{..} <- Action getRO-    let exec stack k continue = do-            let s = Local {localVerbosity=shakeVerbosity globalOptions, localDepends=[], localStack=stack, localBlockApply=Nothing-                          ,localDiscount=0, localTraces=[], localTrackAllows=[], localTrackUsed=[]}-            let top = showTopStack stack-            time <- offsetTime-            runAction global s (do-                liftIO $ evaluate $ rnf k-                liftIO $ globalLint $ "before building " ++ top-                putWhen Chatty $ "# " ++ show k-                res <- runExecute globalRules k-                when (Just LintFSATrace == shakeLint globalOptions) trackCheckUsed-                Action $ fmap ((,) res) getRW) $ \x -> case x of-                    Left e -> continue . Left . toException =<< shakeException global (showStack globalDatabase stack) e-                    Right (res, Local{..}) -> do-                        dur <- time-                        globalLint $ "after building " ++ top-                        let ans = (res, reverse localDepends, dur - localDiscount, reverse localTraces)-                        evaluate $ rnf ans-                        continue $ Right ans-    stack <- Action $ getsRW localStack-    (dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (Ops (runStored globalRules) (runEqual globalRules) exec) stack ks-    Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}-    return vs----- | 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 -> IO [String] -> SomeException -> IO ShakeException-shakeException Global{globalOptions=ShakeOptions{..},..} stk e@(SomeException inner) = case cast inner of-    Just e@ShakeException{} -> return e-    Nothing -> do-        stk <- stk-        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----- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,---   use 'apply' to allow parallelism.-apply1 :: Rule key value => key -> Action value-apply1 = fmap head . apply . return----- | Get the initial 'ShakeOptions', these will not change during the build process.-getShakeOptions :: Action ShakeOptions-getShakeOptions = Action $ getsRO globalOptions---- | Get the current 'Progress' structure, as would be returned by 'shakeProgress'.-getProgress :: Action Progress-getProgress = do-    res <- Action $ getsRO globalProgress-    liftIO res----- | Write an action to the trace list, along with the start/end time of running the IO action.---   The 'Development.Shake.cmd' and 'Development.Shake.command' functions automatically call 'traced'.---   The trace list is used for profile reports (see 'shakeReport').------   By default 'traced' prints some useful extra context about what---   Shake is building, e.g.:------ > # traced message (for myobject.o)------   To suppress the output of 'traced' (for example you want more control---   over the message using 'putNormal'), use the 'quietly' combinator.-traced :: String -> IO a -> Action a-traced msg act = do-    Global{..} <- Action getRO-    stack <- Action $ getsRW localStack-    start <- liftIO globalTimestamp-    putNormal $ "# " ++ msg ++ " (for " ++ showTopStack stack ++ ")"-    res <- liftIO act-    stop <- liftIO globalTimestamp-    Action $ modifyRW $ \s -> s{localTraces = Trace (pack msg) (doubleToFloat start) (doubleToFloat stop) : localTraces s}-    return res---putWhen :: Verbosity -> String -> Action ()-putWhen v msg = do-    Global{..} <- Action getRO-    verb <- getVerbosity-    when (verb >= v) $-        liftIO $ globalOutput v msg----- | Write an unimportant message to the output, only shown when 'shakeVerbosity' is higher than normal ('Loud' or above).---   The output will not be interleaved with any other Shake messages (other than those generated by system commands).-putLoud :: String -> Action ()-putLoud = putWhen Loud---- | Write a normal priority message to the output, only supressed when 'shakeVerbosity' is 'Quiet' or 'Silent'.---   The output will not be interleaved with any other Shake messages (other than those generated by system commands).-putNormal :: String -> Action ()-putNormal = putWhen Normal---- | Write an important message to the output, only supressed when 'shakeVerbosity' is 'Silent'.---   The output will not be interleaved with any other Shake messages (other than those generated by system commands).-putQuiet :: String -> Action ()-putQuiet = putWhen Quiet----- | Get the current verbosity level, originally set by 'shakeVerbosity'. If you---   want to output information to the console, you are recommended to use---   'putLoud' \/ 'putNormal' \/ 'putQuiet', which ensures multiple messages are---   not interleaved. The verbosity can be modified locally by 'withVerbosity'.-getVerbosity :: Action Verbosity-getVerbosity = Action $ getsRW localVerbosity----- | Run an action with a particular verbosity level.---   Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will---   not have any impact on 'Diagnostic' tracing.-withVerbosity :: Verbosity -> Action a -> Action a-withVerbosity new = Action . unmodifyRW f . fromAction-    where f s0 = (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity s0})----- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced'---   (including from 'Development.Shake.cmd' or 'Development.Shake.command') will not be printed to the screen.---   Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will---   not turn off any 'Diagnostic' tracing.-quietly :: Action a -> Action a-quietly = withVerbosity Quiet--------------------------------------------------------------------------- TRACKING---- | Track that a key has been used by the action preceeding it.-trackUse :: 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-    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---trackCheckUsed :: Action ()-trackCheckUsed = do-    Global{..} <- Action getRO-    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 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]-                ""----- | Track that a key has been changed by the action preceeding it.-trackChange :: 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-    Global{..} <- Action getRO-    Local{..} <- Action getRW-    liftIO $ do-        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, ())----- | Allow any matching key to violate the tracking rules.-trackAllow :: ShakeValue key => (key -> Bool) -> Action ()-trackAllow = trackAllowForall---- We don't want the forall in the Haddock docs-trackAllowForall :: forall key . ShakeValue key => (key -> Bool) -> Action ()-trackAllowForall test = Action $ modifyRW $ \s -> s{localTrackAllows = f : localTrackAllows s}-    where-        tk = typeOf (err "trackAllow key" :: key)-        f k = typeKey k == tk && test (fromKey k)--------------------------------------------------------------------------- RESOURCES---- | Create a finite resource, given a name (for error messages) and a quantity of the resource that exists.---   Shake will ensure that actions using the same finite resource do not execute in parallel.---   As an example, only one set of calls to the Excel API can occur at one time, therefore---   Excel is a finite resource of quantity 1. You can write:------ @--- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=2} $ do---    'Development.Shake.want' [\"a.xls\",\"b.xls\"]---    excel <- 'Development.Shake.newResource' \"Excel\" 1---    \"*.xls\" 'Development.Shake.%>' \\out ->---        'Development.Shake.withResource' excel 1 $---            'Development.Shake.cmd' \"excel\" out ...--- @------   Now the two calls to @excel@ will not happen in parallel.------   As another example, calls to compilers are usually CPU bound but calls to linkers are usually---   disk bound. Running 8 linkers will often cause an 8 CPU system to grid to a halt. We can limit---   ourselves to 4 linkers with:------ @--- disk <- 'Development.Shake.newResource' \"Disk\" 4--- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]--- \"*.exe\" 'Development.Shake.%>' \\out ->---     'Development.Shake.withResource' disk 1 $---         'Development.Shake.cmd' \"ld -o\" [out] ...--- \"*.o\" 'Development.Shake.%>' \\out ->---     'Development.Shake.cmd' \"cl -o\" [out] ...--- @-newResource :: String -> Int -> Rules Resource-newResource name mx = liftIO $ newResourceIO name mx----- | Create a throttled resource, given a name (for error messages) and a number of resources (the 'Int') that can be---   used per time period (the 'Double' in seconds). Shake will ensure that actions using the same throttled resource---   do not exceed the limits. As an example, let us assume that making more than 1 request every 5 seconds to---   Google results in our client being blacklisted, we can write:------ @--- google <- 'Development.Shake.newThrottle' \"Google\" 1 5--- \"*.url\" 'Development.Shake.%>' \\out -> do---     'Development.Shake.withResource' google 1 $---         'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]--- @------   Now we will wait at least 5 seconds after querying Google before performing another query. If Google change the rules to---   allow 12 requests per minute we can instead use @'Development.Shake.newThrottle' \"Google\" 12 60@, which would allow---   greater parallelisation, and avoid throttling entirely if only a small number of requests are necessary.------   In the original example we never make a fresh request until 5 seconds after the previous request has /completed/. If we instead---   want to throttle requests since the previous request /started/ we can write:------ @--- google <- 'Development.Shake.newThrottle' \"Google\" 1 5--- \"*.url\" 'Development.Shake.%>' \\out -> do---     'Development.Shake.withResource' google 1 $ return ()---     'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]--- @------   However, the rule may not continue running immediately after 'Development.Shake.withResource' completes, so while---   we will never exceed an average of 1 request every 5 seconds, we may end up running an unbounded number of---   requests simultaneously. If this limitation causes a problem in practice it can be fixed.-newThrottle :: String -> Int -> Double -> Rules Resource-newThrottle name count period = liftIO $ newThrottleIO name count period--unsafeAllowApply :: Action a -> Action a-unsafeAllowApply  = applyBlockedBy Nothing--blockApply :: String -> Action a -> Action a-blockApply = applyBlockedBy . Just--applyBlockedBy :: Maybe String -> Action a -> Action a-applyBlockedBy reason = Action . unmodifyRW f . fromAction-    where f s0 = (s0{localBlockApply=reason}, \s -> s{localBlockApply=localBlockApply s0})---- | 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 $ 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 $ show r ++ " acquired " ++ show i ++ " in " ++ showDuration offset-        Action $ modifyRW $ \s -> s{localDiscount = localDiscount s + offset}-        act-    liftIO $ releaseResource r globalPool i-    liftIO $ globalDiagnostic $ show r ++ " released " ++ show i-    Action $ either throwRAW return res----- | Run an action which uses part of several finite resources. Acquires the resources in a stable---   order, to prevent deadlock. If all rules requiring more than one resource acquire those---   resources with a single call to 'withResources', resources will not deadlock.-withResources :: [(Resource, Int)] -> Action a -> Action a-withResources res act-    | (r,i):_ <- filter ((< 0) . snd) res = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show i-    | otherwise = f $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) res-    where-        f [] = act-        f (r:rs) = withResource (fst $ head r) (sum $ map snd r) $ f rs----- | A version of 'newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.---   Most people should use 'newCache' instead.-newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v)-newCacheIO act = do-    var {- :: Var (Map k (Fence (Either SomeException ([Depends],v)))) -} <- newVar Map.empty-    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-                        pool <- Action $ getsRO globalPool-                        offset <- liftIO offsetTime-                        Action $ captureRAW $ \k -> waitFence bar $ \v ->-                            addPool pool $ 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-                    pre <- Action $ getsRW localDepends-                    res <- Action $ tryRAW $ fromAction $ act key-                    case res of-                        Left err -> do-                            liftIO $ signalFence bar $ Left err-                            Action $ throwRAW err-                        Right v -> do-                            post <- Action $ getsRW localDepends-                            let deps = take (length post - length pre) post-                            liftIO $ signalFence bar $ Right (deps, v)-                            return v---- | Given an action on a key, produce a cached version that will execute the action at most once per key.---   Using the cached result will still result include any dependencies that the action requires.---   Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'.------   This function is useful when creating files that store intermediate values,---   to avoid the overhead of repeatedly reading from disk, particularly if the file requires expensive parsing.---   As an example:------ @--- digits \<- 'newCache' $ \\file -> do---     src \<- readFile\' file---     return $ length $ filter isDigit src--- \"*.digits\" 'Development.Shake.%>' \\x -> do---     v1 \<- digits ('dropExtension' x)---     v2 \<- digits ('dropExtension' x)---     'Development.Shake.writeFile'' x $ show (v1,v2)--- @------   To create the result @MyFile.txt.digits@ the file @MyFile.txt@ will be read and counted, but only at most---   once per execution.-newCache :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)-newCache = liftIO . newCacheIO----- | Run an action without counting to the thread limit, typically used for actions that execute---   on remote machines using barely any local CPU resources.---   Unsafe as it allows the 'shakeThreads' limit to be exceeded.---   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 addPoolPriority else addPool) globalPool $ continue res----- | Execute a list of actions in parallel. In most cases 'need' will be more appropriate to benefit from parallelism.-parallel :: [Action a] -> Action [a]-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--    (locals, results) <- captureRAW $ \continue -> do-        let resume = do-                res <- liftIO $ sequence . catMaybes <$> mapM readIORef results-                continue $ fmap unzip res--        liftIO $ forM_ (zip acts results) $ \(act, result) -> do-            let act2 = do-                    b <- liftIO $ isJust <$> readVar todo-                    when (not b) $ fail "parallel, one has already failed"-                    res <- act-                    old <- Action getRW-                    return (old, res)-            addPool globalPool $ runAction global local act2 $ \res -> do-                writeIORef result $ Just res-                modifyVar_ todo $ \v -> case v of-                    Nothing -> return Nothing-                    Just i | i == 1 || isLeft res -> do resume; return Nothing-                    Just i -> return $ Just $ i - 1--    -- don't construct with RecordWildCards so any new fields raise an error-    modifyRW $ \root -> Local-        -- immutable/stack that need copying-        {localStack = localStack root-        ,localVerbosity = localVerbosity root-        ,localBlockApply = localBlockApply root-        -- mutable locals that need integrating-        ,localDepends = localDepends root ++ concatMap localDepends locals-        ,localDiscount = localDiscount root + maximum (0:map localDiscount locals)-        ,localTraces = localTraces root ++ concatMap localTraces locals-        ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows locals-        ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed locals-        }-    return results---- | 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-    pre <- getsRW localDepends-    res <- fromAction act-    modifyRW $ \s -> s{localDepends=pre}-    return res
− src/Development/Shake/Database.hs 
@@ -1,557 +0,0 @@-{-# LANGUAGE RecordWildCards, PatternGuards, ViewPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}--module Development.Shake.Database(-    Trace(..),-    Database, withDatabase, assertFinishedDatabase,-    listDepends, lookupDependencies,-    Ops(..), build, Depends,-    progress,-    Stack, emptyStack, topStack, showStack, showTopStack,-    toReport, checkValid, listLive-    ) where--import Development.Shake.Classes-import General.Binary-import Development.Shake.Pool-import Development.Shake.Value-import Development.Shake.Errors-import Development.Shake.Storage-import Development.Shake.Types-import Development.Shake.Special-import Development.Shake.Profile-import Development.Shake.Monad-import General.String-import General.Intern as 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 Data.IORef.Extra-import Data.Maybe-import Data.List-import System.Time.Extra-import Data.Monoid-import Prelude--type Map = Map.HashMap--------------------------------------------------------------------------- UTILITY TYPES--newtype Step = Step Word32 deriving (Eq,Ord,Show,Binary,NFData,Hashable,Typeable)--incStep (Step i) = Step $ i + 1--------------------------------------------------------------------------- CALL STACK--data Stack = Stack (Maybe Key) [Id] !(Set.HashSet Id)--showStack :: Database -> Stack -> IO [String]-showStack Database{..} (Stack _ xs _) = do-    status <- withLock lock $ readIORef status-    return $ reverse $ map (maybe "<unknown>" (show . fst) . flip Map.lookup status) xs--addStack :: Id -> Key -> Stack -> Stack-addStack x key (Stack _ xs set) = Stack (Just key) (x:xs) (Set.insert x set)--showTopStack :: Stack -> String-showTopStack = maybe "<unknown>" show . topStack--topStack :: Stack -> Maybe Key-topStack (Stack key _ _) = key--checkStack :: [Id] -> Stack -> Maybe Id-checkStack new (Stack _ old set)-    | bad:_ <- filter (`Set.member` set) new = Just bad-    | otherwise = Nothing--emptyStack :: Stack-emptyStack = Stack Nothing [] Set.empty--------------------------------------------------------------------------- CENTRAL TYPES--data Trace = Trace BS Float Float -- ^ (message, start, end)-    deriving Show--instance NFData Trace where-    rnf (Trace a b c) = rnf a `seq` rnf b `seq` rnf c--type StatusDB = IORef (Map Id (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 :: Step-    ,journal :: Id -> (Key, Status {- Loaded or Missing -}) -> IO ()-    ,diagnostic :: String -> IO () -- ^ logging function-    ,assume :: Maybe Assume-    }--data Status-    = Ready Result -- ^ I have a value-    | Error SomeException -- ^ I have been run and raised an error-    | Loaded Result -- ^ Loaded from the database-    | Waiting Pending (Maybe Result) -- ^ Currently checking if I am valid or building-    | Missing -- ^ I am only here because I got into the Intern table-      deriving Show--data Result = Result-    {result :: Value -- ^ the result associated with the Key-    ,built :: {-# UNPACK #-} !Step -- ^ when it was actually run-    ,changed :: {-# UNPACK #-} !Step -- ^ the step for deciding if it's valid-    ,depends :: [[Id]] -- ^ 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---newtype Pending = Pending (IORef (IO ()))-    -- you must run this action when you finish, while holding DB lock-    -- after you have set the result to Error or Ready--instance Show Pending where show _ = "Pending"---statusType Ready{} = "Ready"-statusType Error{} = "Error"-statusType Loaded{} = "Loaded"-statusType Waiting{} = "Waiting"-statusType Missing{} = "Missing"--isError Error{} = True; isError _ = False-isWaiting Waiting{} = True; isWaiting _ = False-isReady Ready{} = True; isReady _ = False----- All the waiting operations are only valid when isWaiting-type Waiting = Status--afterWaiting :: Waiting -> IO () -> IO ()-afterWaiting (Waiting (Pending p) _) act = modifyIORef' p (>> act)--newWaiting :: Maybe Result -> IO Waiting-newWaiting r = do ref <- newIORef $ return (); return $ Waiting (Pending ref) r--runWaiting :: Waiting -> IO ()-runWaiting (Waiting (Pending p) _) = join $ readIORef p---- | Wait for a set of actions to complete.---   If the action returns True, the function will not be called again.---   If the first argument is True, the thing is ended.-waitFor :: [(a, Waiting)] -> (Bool -> a -> IO Bool) -> IO ()-waitFor ws@(_:_) act = do-    todo <- newIORef $ length ws-    forM_ ws $ \(k,w) -> afterWaiting w $ do-        t <- readIORef todo-        when (t /= 0) $ do-            b <- act (t == 1) k-            writeIORef' todo $ if b then 0 else t - 1---getResult :: Status -> Maybe Result-getResult (Ready r) = Just r-getResult (Loaded r) = Just r-getResult (Waiting _ r) = r-getResult _ = Nothing--------------------------------------------------------------------------- OPERATIONS--newtype Depends = Depends {fromDepends :: [Id]}-    deriving (NFData)---data Ops = Ops-    {stored :: Key -> IO (Maybe Value)-        -- ^ Given a Key, find the value stored on disk-    ,equal :: Key -> Value -> Value -> EqualCost-        -- ^ Given both Values, see if they are equal and how expensive that check was-    ,execute :: Stack -> Key -> Capture (Either SomeException (Value, [Depends], Seconds, [Trace]))-        -- ^ Given a stack and a key, either raise an exception or successfully build it-    }---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-            modifyIORef' status $ Map.insert i (k,Missing)-            return i--queryKey :: StatusDB -> Id -> IO (Maybe (Key, Status))-queryKey status i = Map.lookup i <$> readIORef status---- | Return either an exception (crash), or (how much time you spent waiting, the value)-build :: Pool -> Database -> Ops -> Stack -> [Key] -> Capture (Either SomeException (Seconds,Depends,[Value]))-build pool database@Database{..} Ops{..} stack ks continue =-    join $ withLock lock $ do-        is <- forM ks $ internKey intern status--        whenJust (checkStack is stack) $ \bad -> do-            -- everything else gets thrown via Left and can be Staunch'd-            -- recursion in the rules is considered a worse error, so fails immediately-            status <- readIORef status-            let Stack _ xs _ = stack-            stack <- return $ reverse $ map (maybe "<unknown>" (show . fst) . flip Map.lookup status) $ bad:xs-            (tk, tname) <- return $ case Map.lookup bad status of-                Nothing -> (Nothing, Nothing)-                Just (k,_) -> (Just $ typeKey k, Just $ show k)-            errorRuleRecursion stack tk tname--        vs <- mapM (reduce stack) is-        let errs = [e | Error e <- vs]-        if all isReady vs then-            return $ continue $ Right (0, Depends is, [result r | Ready r <- vs])-         else if not $ null errs then-            return $ continue $ Left $ head errs-         else do-            time <- offsetTime-            let done x = do-                    case x of-                        Left e -> addPoolPriority pool $ continue $ Left e-                        Right v -> addPool pool $ do dur <- time; continue $ Right (dur, Depends is, v)-                    return True-            waitFor (filter (isWaiting . snd) $ zip is vs) $ \finish i -> do-                s <- readIORef status-                case Map.lookup i s of-                    Just (_, Error e) -> done $ Left e -- on error make sure we immediately kick off our parent-                    Just (_, Ready{}) | finish -> done $ Right [result r | i <- is, let Ready r = snd $ fromJust $ Map.lookup i s]-                                      | otherwise -> return False-            return $ return ()-    where-        (#=) :: Id -> (Key, Status) -> IO Status-        i #= (k,v) = do-            s <- readIORef status-            writeIORef' status $ Map.insert i (k,v) s-            diagnostic $ maybe "Missing" (statusType . snd) (Map.lookup i s) ++ " -> " ++ statusType v ++ ", " ++ maybe "<unknown>" (show . fst) (Map.lookup i s)-            return v--        atom x = let s = show x in if ' ' `elem` s then "(" ++ s ++ ")" else s--        -- Rules for each eval* function-        -- * Must NOT lock-        -- * Must have an equal return to what is stored in the db at that point-        -- * Must not return Loaded--        reduce :: Stack -> Id -> IO Status-        reduce stack i = do-            s <- queryKey status i-            case s of-                Nothing -> err $ "interned value missing from database, " ++ show i-                Just (k, Missing) -> run stack i k Nothing-                Just (k, Loaded r) -> do-                    let out b = diagnostic $ "valid " ++ show b ++ " for " ++ atom k ++ " " ++ atom (result r)-                    let continue r = out True >> check stack i k r (depends r)-                    let rebuild = out False >> run stack i k (Just r)-                    case assume of-                        Just AssumeDirty -> rebuild-                        Just AssumeSkip -> continue r-                        _ -> do-                            s <- stored k-                            case s of-                                Just s -> case equal k (result r) s of-                                    NotEqual -> rebuild-                                    EqualCheap -> continue r-                                    EqualExpensive -> do-                                        -- warning, have the db lock while appending (may harm performance)-                                        r <- return r{result=s}-                                        journal i (k, Loaded r)-                                        i #= (k, Loaded r)-                                        continue r-                                _ -> rebuild-                Just (k, res) -> return res--        run :: Stack -> Id -> Key -> Maybe Result -> IO Waiting-        run stack i k r = do-            w <- newWaiting r-            addPool pool $ do-                let reply res = do-                        ans <- withLock lock $ do-                            ans <- i #= (k, res)-                            runWaiting w-                            return ans-                        case ans of-                            Ready r -> do-                                diagnostic $ "result " ++ atom k ++ " = "++ atom (result r) ++-                                             " " ++ (if built r == changed r then "(changed)" else "(unchanged)")-                                journal i (k, Loaded r) -- we leave the DB lock before appending-                            Error _ -> do-                                diagnostic $ "result " ++ atom k ++ " = error"-                                journal i (k, Missing)-                            _ -> return ()-                let norm = execute (addStack i k stack) k $ \res ->-                        reply $ case res of-                            Left err -> Error err-                            Right (v,deps,(doubleToFloat -> execution),traces) ->-                                let c | Just r <- r, equal k (result r) v /= NotEqual = changed r-                                      | otherwise = step-                                in Ready Result{result=v,changed=c,built=step,depends=map fromDepends deps,..}--                case r of-                    Just r | assume == Just AssumeClean -> do-                            v <- stored k-                            case v of-                                Just v -> reply $ Ready r{result=v}-                                Nothing -> norm-                    _ -> norm-            i #= (k, w)--        check :: Stack -> Id -> Key -> Result -> [[Id]] -> IO Status-        check stack i k r [] =-            i #= (k, Ready r)-        check stack i k r (ds:rest) = do-            vs <- mapM (reduce (addStack i k stack)) ds-            let ws = filter (isWaiting . snd) $ zip ds vs-            if any isError vs || any (> built r) [changed | Ready Result{..} <- vs] then-                run stack i k $ Just r-             else if null ws then-                check stack i k r rest-             else do-                self <- newWaiting $ Just r-                waitFor ws $ \finish d -> do-                    s <- readIORef status-                    let buildIt = do-                            b <- run stack i k $ Just r-                            afterWaiting b $ runWaiting self-                            return True-                    case Map.lookup d s of-                        Just (_, Error{}) -> buildIt-                        Just (_, Ready r2)-                            | changed r2 > built r -> buildIt-                            | finish -> do-                                res <- check stack i k r rest-                                if not $ isWaiting res-                                    then runWaiting self-                                    else afterWaiting res $ runWaiting self-                                return True-                            | otherwise -> return False-                i #= (k, self)--------------------------------------------------------------------------- PROGRESS--progress :: Database -> IO Progress-progress Database{..} = do-    s <- readIORef status-    return $ foldl' f mempty $ map snd $ Map.elems s-    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 <- readIORef status-    let bad = [key | (_, (key, Waiting{})) <- Map.toList 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)-resultsOnly mp = Map.map (\(k, v) -> (k, let Just r = getResult v in r{depends = map (filter (isJust . flip Map.lookup keep)) $ depends r})) keep-    where keep = Map.filter (isJust . getResult . snd) mp--removeStep :: Map Id (Key, Result) -> Map Id (Key, Result)-removeStep = Map.filter (\(k,_) -> k /= stepKey)--toReport :: Database -> IO [ProfileEntry]-toReport Database{..} = do-    status <- (removeStep . resultsOnly) <$> readIORef status-    let order = let shw i = maybe "<unknown>" (show . fst) $ Map.lookup i status-                in dependencyOrder shw $ Map.map (concat . 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) (concat depends)-            ,prfExecution = floatToDouble execution-            ,prfTraces = map fromTrace traces-            }-            where fromStep i = fromJust $ Map.lookup i steps-                  fromTrace (Trace a b c) = ProfileTrace (unpack a) (floatToDouble b) (floatToDouble c)-    return [maybe (err "toReport") f $ Map.lookup i status | i <- order]---checkValid :: Database -> (Key -> IO (Maybe Value)) -> (Key -> Value -> Value -> EqualCost) -> [(Key, Key)] -> IO ()-checkValid Database{..} stored equal missing = do-    status <- readIORef status-    intern <- readIORef intern-    diagnostic "Starting validity/lint checking"--    -- Do not use a forM here as you use too much stack space-    bad <- (\f -> foldM f [] (Map.toList status)) $ \seen (i,v) -> case v of-        (key, Ready Result{..}) -> do-            now <- stored key-            let good = maybe False ((==) EqualCheap . equal key result) now-            diagnostic $ "Checking if " ++ show key ++ " is " ++ show result ++ ", " ++ if good then "passed" else "FAILED"-            return $ [(key, result, now) | not good && not (specialAlwaysRebuilds result)] ++ 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 $ maybe "<missing>" show 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 "Validity/lint check passed"---listLive :: Database -> IO [Key]-listLive Database{..} = do-    diagnostic "Listing live keys"-    status <- readIORef status-    return [k | (k, Ready{}) <- Map.elems status]---listDepends :: Database -> Depends -> IO [Key]-listDepends Database{..} (Depends xs) =-    withLock lock $ do-        status <- readIORef status-        return $ map (fst . fromJust . flip Map.lookup status) xs--lookupDependencies :: Database -> Key -> IO [Key]-lookupDependencies Database{..} k =-    withLock lock $ do-        intern <- readIORef intern-        status <- readIORef status-        let Just i = Intern.lookup k intern-        let Just (_, Ready r) = Map.lookup i status-        return $ map (fst . fromJust . flip Map.lookup status) $ concat $ depends r--------------------------------------------------------------------------- STORAGE---- To simplify journaling etc we smuggle the Step in the database, with a special StepKey-newtype StepKey = StepKey ()-    deriving (Show,Eq,Typeable,Hashable,Binary,NFData)--stepKey :: Key-stepKey = newKey $ StepKey ()--toStepResult :: Step -> Result-toStepResult i = Result (newValue i) i i [] 0 []--fromStepResult :: Result -> Step-fromStepResult = fromValue . result---withDatabase :: ShakeOptions -> (String -> IO ()) -> (Database -> IO a) -> IO a-withDatabase opts diagnostic act = do-    registerWitness $ StepKey ()-    registerWitness $ Step 0-    witness <- currentWitness-    withStorage opts diagnostic witness $ \mp2 journal -> do-        let mp1 = Intern.fromList [(k, i) | (i, (k,_)) <- Map.toList mp2]--        (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-        status <- newIORef mp2-        let step = case Map.lookup stepId mp2 of-                        Just (_, Loaded r) -> incStep $ fromStepResult r-                        _ -> Step 1-        journal stepId (stepKey, Loaded $ toStepResult step)-        lock <- newLock-        act Database{assume=shakeAssume opts,..}---instance BinaryWith Witness Result where-    putWith ws (Result x1 x2 x3 x4 x5 x6) = putWith ws x1 >> put x2 >> put x3 >> put (BinList $ map BinList x4) >> put (BinFloat x5) >> put (BinList x6)-    getWith ws = (\x1 x2 x3 (BinList x4) (BinFloat x5) (BinList x6) -> Result x1 x2 x3 (map fromBinList x4) x5 x6) <$>-        getWith ws <*> get <*> get <*> get <*> get <*> get--instance Binary Trace where-    put (Trace a b c) = put a >> put (BinFloat b) >> put (BinFloat c)-    get = (\a (BinFloat b) (BinFloat c) -> Trace a b c) <$> get <*> get <*> get--instance BinaryWith Witness Status where-    putWith ctx Missing = putWord8 0-    putWith ctx (Loaded x) = putWord8 1 >> putWith ctx x-    putWith ctx x = err $ "putWith, Cannot write Status with constructor " ++ statusType x-    getWith ctx = do i <- getWord8; if i == 0 then return Missing else Loaded <$> getWith ctx
− src/Development/Shake/Demo.hs 
@@ -1,136 +0,0 @@---- | Demo tutorial, accessed with --demo-module Development.Shake.Demo(demo) where--import Paths_shake-import Development.Shake.Command--import Control.Applicative-import Control.Exception.Extra-import Control.Monad-import Data.Char-import Data.List-import Data.Maybe-import Data.Version(showVersion)-import System.Directory-import System.Exit-import System.FilePath-import Development.Shake.FilePath(exe)-import System.IO-import System.Info.Extra-import Prelude---demo :: Bool -> IO ()-demo auto = do-    hSetBuffering stdout NoBuffering-    putStrLn $ "% Welcome to the Shake v" ++ showVersion version ++ " demo mode!"-    putStr "% Detecting machine configuration... "--    -- CONFIGURE--    manual <- getDataFileName "docs/manual"-    hasManual <- wrap $ doesDirectoryExist manual-    ghc <- findExecutable "ghc"-    gcc <- do-        v <- findExecutable "gcc"-        case v of-            Nothing | isWindows, Just ghc <- ghc -> do-                let dir = takeDirectory (takeDirectory ghc) </> "bin/mingw/gcc.exe"-                b <- wrap $ doesFileExist dir-                return $ if b then Just dir else Nothing-            _ -> return v-    shakeLib <- wrap $ fmap (not . null . words . fromStdout) (cmd "ghc-pkg list --simple-output shake")-    ninja <- findExecutable "ninja"-    putStrLn "done\n"--    let path = if isWindows then "%PATH%" else "$PATH"-    require (isJust ghc) $ "% You don't have 'ghc' on your " ++ path ++ ", which is required to run the demo."-    require (isJust gcc) $ "% You don't have 'gcc' on your " ++ path ++ ", which is required to run the demo."-    require shakeLib "% You don't have the 'shake' library installed with GHC, which is required to run the demo."-    require hasManual "% You don't have the Shake data files installed, which are required to run the demo."--    empty <- (not . any (not . all (== '.'))) <$> getDirectoryContents "."-    dir <- if empty then getCurrentDirectory else do-        home <- getHomeDirectory-        dir <- getDirectoryContents home-        return $ home </> head (map ("shake-demo" ++) ("":map show [2..]) \\ dir)--    putStrLn "% The Shake demo uses an empty directory, OK to use:"-    putStrLn $ "%     " ++ dir-    b <- yesNo auto-    require b "% Please create an empty directory to run the demo from, then run 'shake --demo' again."--    putStr "% Copying files... "-    createDirectoryIfMissing True dir-    forM_ ["Build.hs","main.c","constants.c","constants.h","build" <.> if isWindows then "bat" else "sh"] $ \file ->-        copyFile (manual </> file) (dir </> file)-    unless isWindows $ do-         p <- getPermissions $ dir </> "build.sh"-         setPermissions (dir </> "build.sh") p{executable=True}-    putStrLn "done"--    let pause = do-            putStr "% Press ENTER to continue: "-            if auto then putLine "" else getLine-    let execute x = do-            putStrLn $ "% RUNNING: " ++ x-            cmd (Cwd dir) Shell x :: IO ()-    let build = if isWindows then "build" else "./build.sh"--    putStrLn "\n% [1/5] Building an example project with Shake."-    pause-    putStrLn $ "% RUNNING: cd " ++ dir-    execute build--    putStrLn "\n% [2/5] Running the produced example."-    pause-    execute $ "_build" </> "run" <.> exe--    putStrLn "\n% [3/5] Rebuilding an example project with Shake (nothing should change)."-    pause-    execute build--    putStrLn "\n% [4/5] Cleaning the build."-    pause-    execute $ build ++ " clean"--    putStrLn "\n% [5/5] Rebuilding with 2 threads and profiling."-    pause-    execute $ build ++ " -j2 --report --report=-"-    putStrLn "\n% See the profiling summary above, or look at the HTML profile report in"-    putStrLn $ "%     " ++ dir </> "report.html"--    putStrLn "\n% Demo complete - all the examples can be run from:"-    putStrLn $ "%     " ++ dir-    putStrLn "% For more info see http://shakebuild.com"-    when (isJust ninja) $ do-        putStrLn "\n% PS. Shake can also execute Ninja build files"-        putStrLn "% For more info see http://shakebuild.com/ninja"------ | Require the user to press @y@ before continuing.-yesNo :: Bool -> IO Bool-yesNo auto = do-    putStr "% [Y/N] (then ENTER): "-    x <- if auto then putLine "y" else fmap (map toLower) getLine-    if "y" `isPrefixOf` x then-        return True-     else if "n" `isPrefixOf` x then-        return False-     else-        yesNo auto--putLine :: String -> IO String-putLine x = putStrLn x >> return x----- | Replace exceptions with 'False'.-wrap :: IO Bool -> IO Bool-wrap act = act `catch_` const (return False)----- | Require a condition to be true, or exit with a message.-require :: Bool -> String -> IO ()-require b msg = unless b $ putStrLn msg >> exitFailure
− src/Development/Shake/Derived.hs 
@@ -1,191 +0,0 @@--module Development.Shake.Derived(-    system', systemCwd, systemOutput,-    copyFile', copyFileChanged,-    readFile', readFileLines,-    writeFile', writeFileLines, writeFileChanged,-    withTempFile, withTempDir,-    getHashedShakeVersion,-    par, forP-    ) where--import Control.Applicative-import Control.Exception.Extra-import Control.Monad.Extra-import Control.Monad.IO.Class-import System.Process-import System.Directory-import System.Exit-import System.IO.Extra hiding (withTempFile, withTempDir, readFile')--import Development.Shake.Core-import Development.Shake.Rules.File-import Development.Shake.FilePath-import Development.Shake.Types-import qualified Data.ByteString as BS-import Data.Hashable-import Prelude----- | Get a checksum of a list of files, suitable for using as `shakeVersion`.---   This will trigger a rebuild when the Shake rules defined in any of the files are changed.---   For example:------ @--- main = do---     ver <- 'getHashedShakeVersion' [\"Shakefile.hs\"]---     'shakeArgs' 'shakeOptions'{'shakeVersion' = ver} ...--- @------   To automatically detect the name of the current file, turn on the @TemplateHaskell@---   extension and write @$(LitE . StringL . loc_filename \<$\> location)@.------   This feature can be turned off during development by passing---   the flag @--no-rule-version@ or setting 'shakeVersionIgnore' to 'True'.-getHashedShakeVersion :: [FilePath] -> IO String-getHashedShakeVersion files = do-    hashes <- mapM (fmap (hashWithSalt 0) . BS.readFile) files-    return $ "hash-" ++ show (hashWithSalt 0 hashes)---checkExitCode :: String -> ExitCode -> Action ()-checkExitCode _ ExitSuccess = return ()-checkExitCode cmd (ExitFailure i) = liftIO $ errorIO $ "System command failed (code " ++ show i ++ "):\n" ++ cmd--{-# DEPRECATED system' "Use 'command' or 'cmd'" #-}-{-# DEPRECATED systemCwd "Use 'command' or 'cmd' with 'Cwd'" #-}-{-# DEPRECATED systemOutput "Use 'command' or 'cmd' with 'Stdout' or 'Stderr'" #-}---- | /Deprecated:/ Please use 'command' or 'cmd' instead.---   This function will be removed in a future version.------   Execute a system command. This function will raise an error if the exit code is non-zero.---   Before running 'system'' make sure you 'need' any required files.-system' :: FilePath -> [String] -> Action ()-system' path args = do-    let path2 = toNative path-    let cmd = unwords $ path2 : args-    v <- getVerbosity-    putLoud cmd-    res <- (if v >= Loud then quietly else id) $ traced (takeBaseName path) $ rawSystem path2 args-    checkExitCode cmd res----- | /Deprecated:/ Please use 'command' or 'cmd' instead, with 'Cwd'.---   This function will be removed in a future version.------   Execute a system command with a specified current working directory (first argument).---   This function will raise an error if the exit code is non-zero.---   Before running 'systemCwd' make sure you 'need' any required files.------ @--- 'systemCwd' \"\/usr\/MyDirectory\" \"pwd\" []--- @-systemCwd :: FilePath -> FilePath -> [String] -> Action ()-systemCwd cwd path args = do-    let path2 = toNative path-    let cmd = unwords $ path2 : args-    putLoud cmd-    res <- traced (takeBaseName path) $ do-        -- FIXME: Should I be using the non-exported System.Process.syncProcess?-        --        That installs/removes signal handlers.-        hdl <- runProcess path2 args (Just cwd) Nothing Nothing Nothing Nothing-        waitForProcess hdl-    checkExitCode cmd res----- | /Deprecated:/ Please use 'command' or 'cmd' instead, with 'Stdout' or 'Stderr'.---   This function will be removed in a future version.------   Execute a system command, returning @(stdout,stderr)@.---   This function will raise an error if the exit code is non-zero.---   Before running 'systemOutput' make sure you 'need' any required files.-systemOutput :: FilePath -> [String] -> Action (String, String)-systemOutput path args = do-    let path2 = toNative path-    let cmd = unwords $ path2 : args-    putLoud cmd-    (res,stdout,stderr) <- traced (takeBaseName path) $ readProcessWithExitCode path2 args ""-    checkExitCode cmd res-    return (stdout, stderr)----- | @copyFile' old new@ copies the existing file from @old@ to @new@.---   The @old@ file will be tracked as a dependency.-copyFile' :: FilePath -> FilePath -> Action ()-copyFile' old new = do-    need [old]-    putLoud $ "Copying from " ++ old ++ " to " ++ new-    liftIO $ copyFile old new----- | @copyFileChanged old new@ copies the existing file from @old@ to @new@, if the contents have changed.---   The @old@ file will be tracked as a dependency.-copyFileChanged :: FilePath -> FilePath -> Action ()-copyFileChanged old new = do-    need [old]-    -- in newer versions of the directory package we can use copyFileWithMetadata which (we think) updates-    -- the timestamp as well and thus no need to read the source file twice.-    unlessM (liftIO $ doesFileExist new &&^ fileEq old new) $ do-        putLoud $ "Copying from " ++ old ++ " to " ++ new-        -- copyFile does a lot of clever stuff with permissions etc, so make sure we just reuse it-        liftIO $ copyFile old new----- | Read a file, after calling 'need'. The argument file will be tracked as a dependency.-readFile' :: FilePath -> Action String-readFile' x = need [x] >> liftIO (readFile x)---- | Write a file, lifted to the 'Action' monad.-writeFile' :: MonadIO m => FilePath -> String -> m ()-writeFile' name x = liftIO $ writeFile name x----- | A version of 'readFile'' which also splits the result into lines.---   The argument file will be tracked as a dependency.-readFileLines :: FilePath -> Action [String]-readFileLines = fmap lines . readFile'---- | A version of 'writeFile'' which writes out a list of lines.-writeFileLines :: MonadIO m => FilePath -> [String] -> m ()-writeFileLines name = writeFile' name . unlines----- | Write a file, but only if the contents would change.-writeFileChanged :: MonadIO m => FilePath -> String -> m ()-writeFileChanged name x = liftIO $ do-    b <- doesFileExist name-    if not b then writeFile name x else do-        -- Cannot use ByteString here, since it has different line handling-        -- semantics on Windows-        b <- withFile name ReadMode $ \h -> do-            src <- hGetContents h-            return $! src /= x-        when b $ writeFile name x----- | Create a temporary file in the temporary directory. The file will be deleted---   after the action completes (provided the file is not still open).---   The 'FilePath' will not have any file extension, will exist, and will be zero bytes long.---   If you require a file with a specific name, use 'withTempDir'.-withTempFile :: (FilePath -> Action a) -> Action a-withTempFile act = do-    (file, del) <- liftIO newTempFile-    act file `actionFinally` del----- | Create a temporary directory inside the system temporary directory.---   The directory will be deleted after the action completes.-withTempDir :: (FilePath -> Action a) -> Action a-withTempDir act = do-    (dir,del) <- liftIO newTempDir-    act dir `actionFinally` del----- | A 'parallel' version of 'forM'.-forP :: [a] -> (a -> Action b) -> Action [b]-forP xs f = parallel $ map f xs---- | Execute two operations in parallel, based on 'parallel'.-par :: Action a -> Action b -> Action (a,b)-par a b = do [Left a, Right b] <- parallel [Left <$> a, Right <$> b]; return (a,b)
− src/Development/Shake/Errors.hs 
@@ -1,151 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards, RecordWildCards, CPP #-}---- | Errors seen by the user-module Development.Shake.Errors(-    ShakeException(..),-    errorStructured, err,-    errorNoRuleToBuildType, errorRuleTypeMismatch, errorIncompatibleRules,-    errorMultipleRulesMatch, errorRuleRecursion, errorComplexRecursion, errorNoApply,-    errorDirectoryNotFile-    ) where--import Data.Tuple.Extra-import Control.Exception.Extra-import Data.Typeable-import Data.List---err :: String -> a-err msg = error $ "Development.Shake: Internal error, please report to Neil Mitchell (" ++ msg ++ ")"--alternatives = let (*) = (,) in-    ["_rule_" * "oracle"-    ,"_Rule_" * "Oracle"-    ,"_key_" * "question"-    ,"_Key_" * "Question"-    ,"_result_" * "answer"-    ,"_Result_" * "Answer"-    ,"_rule/defaultRule_" * "addOracle"-    ,"_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 ++ ":"] ++-        ["  " ++ a ++ [':' | a /= ""] ++ replicate (as - length a + 2) ' ' ++ b | (a,b) <- args2] ++-        [hint | hint /= ""]-    where-        as = maximum $ 0 : map (length . fst) args2-        args2 = [(a,b) | (a,Just b) <- args]----structured :: Bool -> String -> [(String, Maybe String)] -> String -> IO a-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 (x:xs) = x : g xs-        g [] = []---errorDirectoryNotFile :: FilePath -> IO a-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 tk k tv = structured (specialIsOracleKey tk)-    "Build system error - no _rule_ matches the _key_ type"-    [("_Key_ type", Just $ show tk)-    ,("_Key_ value", k)-    ,("_Result_ type", fmap show tv)]-    "Either you are missing a call to _rule/defaultRule_, or your call to _apply_ has the wrong _key_ type"--errorRuleTypeMismatch :: TypeRep -> Maybe String -> TypeRep -> TypeRep -> IO a-errorRuleTypeMismatch tk k tvReal tvWant = structured (specialIsOracleKey tk)-    "Build system error - _rule_ used at the wrong _result_ type"-    [("_Key_ type", Just $ show tk)-    ,("_Key_ value", k)-    ,("_Rule_ _result_ type", Just $ show tvReal)-    ,("Requested _result_ type", Just $ show tvWant)]-    "Either the function passed to _rule/defaultRule_ has the wrong _result_ type, or the result of _apply_ is used at the wrong type"--errorIncompatibleRules :: TypeRep -> TypeRep -> TypeRep -> IO a-errorIncompatibleRules tk tv1 tv2 = if specialIsOracleKey tk then errorDuplicateOracle tk Nothing [tv1,tv2] else errorStructured-    "Build system error - rule has multiple result types"-    [("Key type", Just $ show tk)-    ,("First result type", Just $ show tv1)-    ,("Second result type", Just $ show tv2)]-    "A function passed to rule/defaultRule has the wrong result type"--errorMultipleRulesMatch :: TypeRep -> String -> Int -> IO a-errorMultipleRulesMatch tk k count-    | specialIsOracleKey tk = if count == 0 then err $ "no oracle match for " ++ show tk else errorDuplicateOracle tk (Just k) []-    | 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")--errorRuleRecursion :: [String] -> Maybe TypeRep -> Maybe String -> IO a--- may involve both rules and oracle, so report as only rules-errorRuleRecursion stack tk k = throwIO $ wrap $ toException $ ErrorCall $ errorStructuredContents-    "Build system error - recursion detected"-    [("Key type",fmap show tk)-    ,("Key value",k)]-    "Rules may not be recursive"-    where-        wrap = if null stack then id else toException . ShakeException (last stack) stack--errorComplexRecursion :: [String] -> IO a-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"--errorDuplicateOracle :: TypeRep -> Maybe String -> [TypeRep] -> IO a-errorDuplicateOracle tk k tvs = errorStructured-    "Build system error - duplicate oracles for the same question type"-    ([("Question type",Just $ show tk)-     ,("Question value",k)] ++-     [("Answer type " ++ show i, Just $ show tv) | (i,tv) <- zip [1..] tvs])-    "Only one call to addOracle is allowed per question type"--errorNoApply :: TypeRep -> Maybe String -> String -> IO a-errorNoApply tk k msg = structured (specialIsOracleKey tk)-    "Build system error - cannot currently call _apply_"-    [("Reason", Just msg)-    ,("_Key_ type", Just $ show tk)-    ,("_Key_ value", k)]-    "Move the _apply_ call earlier/later"----- Should be in Special, but then we get an import cycle-specialIsOracleKey :: TypeRep -> Bool-specialIsOracleKey t = con == "OracleQ"-    where con = show $ fst $ splitTyConApp t----- | Error representing all expected exceptions thrown by Shake.---   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.-    ,shakeExceptionInner :: SomeException -- ^ The underlying exception that was raised.-    }-    deriving Typeable--instance Exception ShakeException--instance Show ShakeException where-    show ShakeException{..} = unlines $-        "Error when running Shake build system:" :-        map ("* " ++) shakeExceptionStack ++-        [displayException shakeExceptionInner]
− src/Development/Shake/FileInfo.hs 
@@ -1,177 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}--module Development.Shake.FileInfo(-    FileInfo, fileInfoEq, fileInfoNeq,-    FileSize, ModTime, FileHash,-    getFileHash, getFileInfo, getFileInfoNoDirErr-    ) where--import Control.Exception.Extra-import Development.Shake.Classes-import Development.Shake.Errors-import General.String-import qualified Data.ByteString.Lazy as LBS-import Data.Char-import Data.Word-import Numeric-import System.IO--#if defined(PORTABLE)-import System.IO.Error-import System.Directory-import Data.Time-#if __GLASGOW_HASKELL__ < 706-import System.Time-#endif--#elif defined(mingw32_HOST_OS)-import Control.Monad-import qualified Data.ByteString.Char8 as BS-import Foreign-import Foreign.C.Types-import Foreign.C.String--#else-import System.IO.Error-import System.Posix.Files.ByteString-#endif---- A piece of file information, where 0 and 1 are special (see fileInfo* functions)-newtype FileInfo a = FileInfo Word32-    deriving (Typeable,Hashable,Binary,NFData)--fileInfoEq, fileInfoNeq :: FileInfo a-fileInfoEq  = FileInfo 0   -- Equal to everything-fileInfoNeq = FileInfo 1   -- Equal to nothing--fileInfo :: Word32 -> FileInfo a-fileInfo a = FileInfo $ if a > maxBound - 2 then a else a + 2--instance Show (FileInfo a) where-    show (FileInfo x)-        | x == 0 = "EQ"-        | x == 1 = "NEQ"-        | otherwise = "0x" ++ map toUpper (showHex (x-2) "")--instance Eq (FileInfo a) where-    FileInfo a == FileInfo b-        | a == 0 || b == 0 = True-        | a == 1 || b == 1 = False-        | otherwise = a == b--data FileInfoHash; type FileHash = FileInfo FileInfoHash-data FileInfoMod ; type ModTime  = FileInfo FileInfoMod-data FileInfoSize; type FileSize = FileInfo FileInfoSize---getFileHash :: BSU -> IO FileHash-getFileHash x = withFile (unpackU x) ReadMode $ \h -> do-    s <- LBS.hGetContents h-    let res = fileInfo $ fromIntegral $ hash s-    evaluate res-    return res---- 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.--- See this blog post: http://neilmitchell.blogspot.co.uk/2015/09/three-space-leaks.html-result :: Word32 -> Word32 -> IO (Maybe (ModTime, FileSize))-result x y = do-    x <- evaluate $ fileInfo x-    y <- evaluate $ fileInfo y-    return $! Just (x, y)---getFileInfo :: BSU -> IO (Maybe (ModTime, FileSize))-getFileInfo = getFileInfoEx True--getFileInfoNoDirErr :: BSU -> IO (Maybe (ModTime, FileSize))-getFileInfoNoDirErr = getFileInfoEx False---getFileInfoEx :: Bool -> BSU -> IO (Maybe (ModTime, FileSize))--#if defined(PORTABLE)--- Portable fallback-getFileInfoEx direrr x = handleBool isDoesNotExistError (const $ return Nothing) $ do-    let file = unpackU x-    time <- getModificationTime file-    size <- withFile file ReadMode hFileSize-    result (extractFileTime time) (fromIntegral size)---- deal with difference in return type of getModificationTime between directory versions-class ExtractFileTime a where extractFileTime :: a -> Word32-#if __GLASGOW_HASKELL__ < 706-instance ExtractFileTime ClockTime where extractFileTime (TOD t _) = fromIntegral t-#endif-instance ExtractFileTime UTCTime where extractFileTime = floor . fromRational . toRational . utctDayTime---#elif defined(mingw32_HOST_OS)--- Directly against the Win32 API, twice as fast as the portable version-getFileInfoEx direrr x = BS.useAsCString (unpackU_ 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-                    (if direrr then errorDirectoryNotFile $ unpackU x else return Nothing)-                 else-                    join $ liftM2 result (peekLastWriteTimeLow fad) (peekFileSizeLow fad)-        if res then-            peek-         else if requireU x then withCWString (unpackU x) $ \file -> do-            res <- c_GetFileAttributesExW file 0 fad-            if res then peek else return Nothing-         else-            return Nothing--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV unsafe "Windows.h GetFileAttributesExA" c_GetFileAttributesExA :: Ptr CChar  -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool-foreign import CALLCONV unsafe "Windows.h GetFileAttributesExW" c_GetFileAttributesExW :: Ptr CWchar -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool--data WIN32_FILE_ATTRIBUTE_DATA--alloca_WIN32_FILE_ATTRIBUTE_DATA :: (Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO a) -> IO a-alloca_WIN32_FILE_ATTRIBUTE_DATA act = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA act-    where size_WIN32_FILE_ATTRIBUTE_DATA = 36--peekFileAttributes :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32-peekFileAttributes p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes-    where index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes = 0--peekLastWriteTimeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32-peekLastWriteTimeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime-    where index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20--peekFileSizeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32-peekFileSizeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow-    where index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow = 32---#else--- Unix version-getFileInfoEx direrr x = handleBool isDoesNotExistError (const $ return Nothing) $ do-    s <- getFileStatus $ unpackU_ x-    if isDirectory s then-        (if direrr then errorDirectoryNotFile $ unpackU x else return Nothing)-     else-        result (extractFileTime s) (fromIntegral $ fileSize s)--extractFileTime :: FileStatus -> Word32-#ifndef MIN_VERSION_unix-#define MIN_VERSION_unix(a,b,c) 0-#endif-#if MIN_VERSION_unix(2,6,0)-extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4 -- precision of 0.1ms-#else-extractFileTime x = fromIntegral $ fromEnum $ modificationTime x-#endif--#endif
− src/Development/Shake/FilePattern.hs 
@@ -1,309 +0,0 @@-{-# LANGUAGE PatternGuards, ViewPatterns #-}--module Development.Shake.FilePattern(-    -- * Primitive API, as exposed-    FilePattern, (?==), (<//>),-    -- * Optimisation opportunities-    simple,-    -- * Multipattern file rules-    compatible, extract, substitute,-    -- * Accelerated searching-    Walk(..), walk,-    -- * Testing only-    internalTest, isRelativePath, isRelativePattern-    ) where--import Development.Shake.Errors-import System.FilePath(isPathSeparator)-import Data.List.Extra-import Control.Applicative-import Control.Monad-import Data.Char-import Data.Tuple.Extra-import Data.Maybe-import System.Info.Extra-import Prelude----- | A type synonym for file patterns, containing @\/\/@ and @*@. For the syntax---   and semantics of 'FilePattern' see '?=='.------   Most 'normaliseEx'd 'FilePath' values are suitable as 'FilePattern' values which match---   only that specific file. On Windows @\\@ is treated as equivalent to @\/@.------   You can write 'FilePattern' values as a literal string, or build them---   up using the operators 'Development.Shake.FilePath.<.>', 'Development.Shake.FilePath.</>'---   and 'Development.Shake.<//>'. However, beware that:------ * On Windows, use 'Development.Shake.FilePath.<.>' from "Development.Shake.FilePath" instead of from---   "System.FilePath" - otherwise @\"\/\/*\" \<.\> exe@ results in @\"\/\/*\\\\.exe\"@.------ * If the second argument of 'Development.Shake.FilePath.</>' has a leading path separator (namely @\/@)---   then the second argument will be returned.-type FilePattern = String--infixr 5 <//>---- | Join two 'FilePattern' values by inserting two @\/@ characters between them.---   Will first remove any trailing path separators on the first argument, and any leading---   separators on the second.------ > "dir" <//> "*" == "dir//*"-(<//>) :: FilePattern -> FilePattern -> FilePattern-a <//> b = dropWhileEnd isPathSeparator a ++ "//" ++ dropWhile isPathSeparator b--------------------------------------------------------------------------- PATTERNS--data Pat = Lit String -- ^ foo-         | Star   -- ^ /*/-         | Skip -- ^ //-         | Skip1 -- ^ //, but must be at least 1 element-         | Stars String [String] String -- ^ *foo*, prefix (fixed), infix floaters, suffix-                                        -- e.g. *foo*bar = Stars "" ["foo"] "bar"-            deriving (Show,Eq,Ord)--isLit Lit{} = True; isLit _ = False-fromLit (Lit x) = x---data Lexeme = Str String | Slash | SlashSlash--lexer :: FilePattern -> [Lexeme]-lexer "" = []-lexer (x1:x2:xs) | isPathSeparator x1, isPathSeparator x2 = SlashSlash : lexer xs-lexer (x1:xs) | isPathSeparator x1 = Slash : lexer xs-lexer xs = Str a : lexer b-    where (a,b) = break isPathSeparator xs----- | Parse a FilePattern. All optimisations I can think of are invalid because they change the extracted expressions.-parse :: FilePattern -> [Pat]-parse = f False True . lexer-    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---parseLit :: String -> Pat-parseLit "*" = Star-parseLit x = case split (== '*') x of-    [x] -> Lit x-    pre:xs | Just (mid,post) <- unsnoc xs -> Stars pre mid post---internalTest :: IO ()-internalTest = do-    let x # y = when (parse x /= y) $ fail $ show ("FilePattern.internalTest",x,parse x,y)-    "" # [Lit ""]-    "x" # [Lit "x"]-    "/" # [Lit "",Lit ""]-    "x/" # [Lit "x",Lit ""]-    "/x" # [Lit "",Lit "x"]-    "x/y" # [Lit "x",Lit "y"]-    "//" # [Skip]-    "**" # [Skip]-    "//x" # [Skip, Lit "x"]-    "**/x" # [Skip, Lit "x"]-    "x//" # [Lit "x", Skip]-    "x/**" # [Lit "x", Skip]-    "x//y" # [Lit "x",Skip, Lit "y"]-    "x/**/y" # [Lit "x",Skip, Lit "y"]-    "///" # [Skip1, Lit ""]-    "**/**" # [Skip,Skip]-    "**/**/" # [Skip, Skip, Lit ""]-    "///x" # [Skip1, Lit "x"]-    "**/x" # [Skip, Lit "x"]-    "x///" # [Lit "x", Skip, Lit ""]-    "x/**/" # [Lit "x", Skip, Lit ""]-    "x///y" # [Lit "x",Skip, Lit "y"]-    "x/**/y" # [Lit "x",Skip, Lit "y"]-    "////" # [Skip, Skip]-    "**/**/**" # [Skip, Skip, Skip]-    "////x" # [Skip, Skip, Lit "x"]-    "x////" # [Lit "x", Skip, Skip]-    "x////y" # [Lit "x",Skip, Skip, Lit "y"]-    "**//x" # [Skip, Skip, Lit "x"]----- | Optimisations that may change the matched expressions-optimise :: [Pat] -> [Pat]-optimise (Skip:Skip:xs) = optimise $ Skip:xs-optimise (Skip:Star:xs) = optimise $ Skip1:xs-optimise (Star:Skip:xs) = optimise $ Skip1:xs-optimise (x:xs) = x : optimise xs-optimise [] =[]----- | A 'FilePattern' that will only match 'isRelativePath' values.-isRelativePattern :: FilePattern -> Bool-isRelativePattern ('*':'*':xs)-    | [] <- xs = True-    | x:xs <- xs, isPathSeparator x = True-isRelativePattern _ = False---- | A non-absolute 'FilePath'.-isRelativePath :: FilePath -> Bool-isRelativePath (x:_) | isPathSeparator x = False-isRelativePath (x:':':_) | isWindows, isAlpha x = False-isRelativePath _ = True----- | Given a pattern, and a list of path components, return a list of all matches---   (for each wildcard in order, what the wildcard matched).-match :: [Pat] -> [String] -> [[String]]-match (Skip:xs) (y:ys) = map ("":) (match xs (y:ys)) ++ match (Skip1:xs) (y:ys)-match (Skip1:xs) (y:ys) = [(y++"/"++r):rs | r:rs <- match (Skip:xs) ys]-match (Skip:xs) [] = map ("":) $ match xs []-match (Star:xs) (y:ys) = map (y:) $ match xs ys-match (Lit x:xs) (y:ys) | x == y = match xs ys-match (x@Stars{}:xs) (y:ys) | Just rs <- matchStars x y = map (rs ++) $ match xs ys-match [] [] = [[]]-match _ _ = []---matchOne :: Pat -> String -> Bool-matchOne (Lit x) y = x == y-matchOne x@Stars{} y = isJust $ matchStars x y-matchOne Star _ = True----- Only return the first (all patterns left-most) valid star matching-matchStars :: Pat -> String -> Maybe [String]-matchStars (Stars pre mid post) x = do-    x <- stripPrefix pre x-    x <- if null post then Just x else stripSuffix post x-    stripInfixes mid x-    where-        stripInfixes [] x = Just [x]-        stripInfixes (m:ms) x = do-            (a,x) <- stripInfix m x-            (a:) <$> stripInfixes ms x----- | Match a 'FilePattern' against a 'FilePath', There are three special forms:------ * @*@ matches an entire path component, excluding any separators.------ * @\/\/@ matches an arbitrary number of path components, including absolute path---   prefixes.------ * @**@ as a path component matches an arbitrary number of path components, but not---   absolute path prefixes.---   Currently considered experimental.------   Some examples:------ * @test.c@ matches @test.c@ and nothing else.------ * @*.c@ matches all @.c@ files in the current directory, so @file.c@ matches,---   but @file.h@ and @dir\/file.c@ don't.------ * @\/\/*.c@ matches all @.c@ files anywhere on the filesystem,---   so @file.c@, @dir\/file.c@, @dir1\/dir2\/file.c@ and @\/path\/to\/file.c@ all match,---   but @file.h@ and @dir\/file.h@ don't.------ * @dir\/*\/*@ matches all files one level below @dir@, so @dir\/one\/file.c@ and---   @dir\/two\/file.h@ match, but @file.c@, @one\/dir\/file.c@, @dir\/file.h@---   and @dir\/one\/two\/file.c@ don't.------   Patterns with constructs such as @foo\/..\/bar@ will never match---   normalised 'FilePath' values, so are unlikely to be correct.-(?==) :: FilePattern -> FilePath -> Bool-(?==) p = case optimise $ parse p of-    [x] | x == Skip || x == Skip1 -> if rp then isRelativePath else const True-    p -> let f = not . null . match p . split isPathSeparator-         in if rp then (\x -> isRelativePath x && f x) else f-    where rp = isRelativePattern p--------------------------------------------------------------------------- MULTIPATTERN COMPATIBLE SUBSTITUTIONS--specials :: FilePattern -> [Pat]-specials = concatMap f . parse-    where-        f Lit{} = []-        f Star = [Star]-        f Skip = [Skip]-        f Skip1 = [Skip]-        f (Stars _ xs _) = replicate (length xs + 1) Star---- | Is the pattern free from any * and //.-simple :: FilePattern -> Bool-simple = null . specials---- | Do they have the same * and // counts in the same order-compatible :: [FilePattern] -> Bool-compatible [] = True-compatible (x:xs) = all ((==) (specials x) . specials) xs---- | Extract the items that match the wildcards. The pair must match with '?=='.-extract :: FilePattern -> FilePath -> [String]-extract p = let pat = parse p in \x ->-    case match pat (split isPathSeparator x) of-        [] | p ?== x -> err $ "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----- | Given the result of 'extract', substitute it back in to a 'compatible' pattern.------ > p '?==' x ==> substitute (extract p x) p == x-substitute :: [String] -> FilePattern -> FilePath-substitute oms oxs = intercalate "/" $ concat $ snd $ mapAccumL f oms (parse oxs)-    where-        f ms (Lit x) = (ms, [x])-        f (m:ms) Star = (ms, [m])-        f (m:ms) Skip = (ms, split m)-        f (m:ms) Skip1 = (ms, split m)-        f ms (Stars pre mid post) = (ms2, [concat $ pre : zipWith (++) ms1 (mid++[post])])-            where (ms1,ms2) = splitAt (length mid + 1) ms-        f _ _ = error $ "Substitution failed into pattern " ++ show oxs ++ " with " ++ show (length oms) ++ " matches, namely " ++ show oms--        split = linesBy (== '/')--------------------------------------------------------------------------- EFFICIENT PATH WALKING---- | Given a list of files, return a list of things I can match in this directory---   plus a list of subdirectories and walks that apply to them.---   Use WalkTo when the list can be predicted in advance-data Walk = Walk ([String] -> ([String],[(String,Walk)]))-          | WalkTo            ([String],[(String,Walk)])--walk :: [FilePattern] -> (Bool, Walk)-walk ps = let ps2 = map (optimise . parse) ps in (any (\p -> isEmpty p || not (null $ match p [""])) ps2, f ps2)-    where-        f (nubOrd -> ps)-            | all isLit fin, all (isLit . fst) nxt = WalkTo (map fromLit fin, map (fromLit *** f) 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])-            where-                finStar = Star `elem` fin-                fin = nubOrd $ mapMaybe final ps-                nxt = groupSort $ concatMap next ps---next :: [Pat] -> [(Pat, [Pat])]-next (Skip1:xs) = [(Star,Skip:xs)]-next (Skip:xs) = (Star,Skip:xs) : next xs-next (x:xs) = [(x,xs) | not $ null xs]-next [] = []--final :: [Pat] -> Maybe Pat-final (Skip:xs) = if isEmpty xs then Just Star else final xs-final (Skip1:xs) = if isEmpty xs then Just Star else Nothing-final (x:xs) = if isEmpty xs then Just x else Nothing-final [] = Nothing--isEmpty = all (== Skip)
src/Development/Shake/Forward.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, Rank2Types, ScopedTypeVariables, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}  -- | A module for producing forward-defined build systems, in contrast to standard backwards-defined --   build systems such as shake. Based around ideas from <https://code.google.com/p/fabricate/ fabricate>.@@ -48,6 +49,7 @@ import Control.Exception.Extra import Numeric import System.IO.Unsafe+import qualified Data.ByteString as BS import qualified Data.HashMap.Strict as Map  @@ -58,32 +60,31 @@ newtype ForwardQ = ForwardQ String     deriving (Hashable,Typeable,Eq,NFData,Binary) +type instance RuleResult ForwardQ = ()+ instance Show ForwardQ where     show (ForwardQ x) = x -newtype ForwardA = ForwardA ()-    deriving (Hashable,Typeable,Eq,NFData,Binary,Show)--instance Rule ForwardQ ForwardA where-    storedValue _ _ = return $ Just $ ForwardA ()- -- | Run a forward-defined build system. shakeForward :: ShakeOptions -> Action () -> IO () shakeForward opts act = shake (forwardOptions opts) (forwardRule act) --- | Run a forward-defined build system, interpretting command-line arguments.+-- | Run a forward-defined build system, interpreting command-line arguments. shakeArgsForward :: ShakeOptions -> Action () -> IO () shakeArgsForward opts act = shakeArgs (forwardOptions opts) (forwardRule act)  -- | Given an 'Action', turn it into a 'Rules' structure which runs in forward mode. forwardRule :: Action () -> Rules () forwardRule act = do-    rule $ \k -> Just $ do-        res <- liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete k mp, Map.lookup k mp)-        case res of-            Nothing -> liftIO $ errorIO "Failed to find action name"-            Just act -> act-        return $ ForwardA ()+    addBuiltinRule noLint $ \k old dirty ->+        case old of+            Just old | not dirty -> return $ RunResult ChangedNothing old ()+            _ -> do+                res <- liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete k mp, Map.lookup k mp)+                case res of+                    Nothing -> liftIO $ errorIO "Failed to find action name"+                    Just act -> act+                return $ RunResult ChangedRecomputeSame BS.empty ()     action act  -- | Given a 'ShakeOptions', set the options necessary to execute in forward mode.@@ -96,13 +97,13 @@ cacheAction name action = do     let key = ForwardQ name     liftIO $ atomicModifyIORef forwards $ \mp -> (Map.insert key action mp, ())-    _ :: [ForwardA] <- apply [key]+    _ :: [()] <- apply [key]     liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete key mp, ())  -- | Apply caching to an external command. cache :: (forall r . CmdArguments r => r) -> Action () cache cmd = do-    let args :: [Either CmdOption String] = cmd+    let CmdArgument args = cmd     let isDull ['-',x] = 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
@@ -0,0 +1,317 @@++-- | Command line parsing flags.+module Development.Shake.Internal.Args(shakeOptDescrs, shakeArgs, shakeArgsWith) where++import Paths_shake+import Development.Shake.Internal.Options+import Development.Shake.Internal.Core.Rules+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 General.Timing+import General.GetOpt++import Data.Tuple.Extra+import Control.Concurrent+import Control.Exception.Extra+import Control.Monad+import Data.Char+import Data.Either+import Data.List+import Data.Maybe+import Data.Version(showVersion)+import System.Directory+import System.Environment+import System.Exit+import System.Time.Extra+++-- | 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@.+--   If there are no file arguments then the 'Rules' are used directly, otherwise the file arguments+--   are 'want'ed (after calling 'withoutActions'). As an example:+--+-- @+-- main = 'shakeArgs' 'shakeOptions'{'shakeFiles' = \"_make\", 'shakeProgress' = 'progressSimple'} $ do+--     'phony' \"clean\" $ 'Development.Shake.removeFilesAfter' \"_make\" [\"\/\/*\"]+--     'want' [\"_make\/neil.txt\",\"_make\/emily.txt\"]+--     \"_make\/*.txt\" '%>' \\out ->+--         ... build action here ...+-- @+--+--   This build system will default to building @neil.txt@ and @emily.txt@, while showing progress messages,+--   and putting the Shake files in locations such as @_make\/.database@. Some example command line flags:+--+-- * @main --no-progress@ will turn off progress messages.+--+-- * @main -j6@ will build on 6 threads.+--+-- * @main --help@ will display a list of supported flags.+--+-- * @main clean@ will not build anything, but will remove the @_make@ directory, including the+--   any 'shakeFiles'.+--+-- * @main _make/henry.txt@ will not build @neil.txt@ or @emily.txt@, but will instead build @henry.txt@.+shakeArgs :: ShakeOptions -> Rules () -> IO ()+shakeArgs opts rules = shakeArgsWith opts [] f+    where f _ files = return $ Just $ if null files then rules else want files >> withoutActions rules+++-- | A version of 'shakeArgs' with more flexible handling of command line arguments.+--   The caller of 'shakeArgsWith' can add additional flags (the second argument) and chose how to convert+--   the flags/arguments into rules (the third argument). Given:+--+-- @+-- 'shakeArgsWith' opts flags (\\flagValues argValues -> result)+-- @+--+-- * @opts@ is the initial 'ShakeOptions' value, which may have some fields overriden by command line flags.+--   This argument is usually 'shakeOptions', perhaps with a few fields overriden.+--+-- * @flags@ is a list of flag descriptions, which either produce a 'String' containing an error+--   message (typically for flags with invalid arguments, .e.g. @'Left' \"could not parse as int\"@), or a value+--   that is passed as @flagValues@. If you have no custom flags, pass @[]@.+--+-- * @flagValues@ is a list of custom flags that the user supplied. If @flags == []@ then this list will+--   be @[]@.+--+-- * @argValues@ is a list of non-flag arguments, which are often treated as files and passed to 'want'.+--+-- * @result@ should produce a 'Nothing' to indicate that no building needs to take place, or a 'Just'+--   providing the rules that should be used.+--+--   As an example of a build system that can use either @gcc@ or @distcc@ for compiling:+--+-- @+-- import System.Console.GetOpt+--+-- data Flags = DistCC deriving Eq+-- flags = [Option \"\" [\"distcc\"] (NoArg $ Right DistCC) \"Run distributed.\"]+--+-- main = 'shakeArgsWith' 'shakeOptions' flags $ \\flags targets -> return $ Just $ do+--     if null targets then 'want' [\"result.exe\"] else 'want' targets+--     let compiler = if DistCC \`elem\` flags then \"distcc\" else \"gcc\"+--     \"*.o\" '%>' \\out -> do+--         'need' ...+--         'cmd' compiler ...+--     ...+-- @+--+--   Now you can pass @--distcc@ to use the @distcc@ compiler.+shakeArgsWith :: ShakeOptions -> [OptDescr (Either String a)] -> ([a] -> [String] -> IO (Maybe (Rules ()))) -> IO ()+shakeArgsWith baseOpts userOptions rules = do+    addTiming "shakeArgsWith"+    args <- getArgs+    let (flag1,files,errs) = getOpt opts args+        (self,user) = partitionEithers flag1+        (flagsExtra,flagsShake) = first concat $ unzip self+        progressReplays = [x | ProgressReplay x <- flagsExtra]+        progressRecords = [x | ProgressRecord x <- flagsExtra]+        changeDirectory = listToMaybe [x | ChangeDirectory x <- flagsExtra]+        printDirectory = last $ False : [x | PrintDirectory x <- flagsExtra]+        oshakeOpts = foldl' (flip ($)) baseOpts flagsShake+        shakeOpts = oshakeOpts {shakeLintInside = map (toStandard . normalise . addTrailingPathSeparator) $+                                                  shakeLintInside oshakeOpts+                               ,shakeLintIgnore = map toStandard $+                                                  shakeLintIgnore oshakeOpts+                               ,shakeOutput     = if shakeColor oshakeOpts+                                                  then outputColor (shakeOutput oshakeOpts)+                                                  else shakeOutput oshakeOpts+                               }+    let putWhen v msg = when (shakeVerbosity oshakeOpts >= v) $ shakeOutput oshakeOpts v msg+    let putWhenLn v msg = putWhen v $ msg ++ "\n"+    let showHelp = do+            progName <- getProgName+            putWhen Normal $ unlines $ ("Usage: " ++ progName ++ " [options] [target] ...") : "Options:" : showOptDescr opts++    when (errs /= []) $ do+        putWhen Quiet $ unlines $ map ("shake: " ++) $ filter (not . null) $ lines $ unlines errs+        showHelp+        exitFailure++    if Help `elem` flagsExtra then+        showHelp+     else if Version `elem` flagsExtra then+        putWhenLn Normal $ "Shake build system, version " ++ showVersion version+     else if NumericVersion `elem` flagsExtra then+        putWhenLn Normal $ showVersion version+     else if Demo `elem` flagsExtra then+        demo $ shakeStaunch shakeOpts+     else if not $ null progressReplays then do+        dat <- forM progressReplays $ \file -> do+            src <- readFile file+            return (file, map read $ lines src)+        forM_ (if null $ shakeReport shakeOpts then ["-"] else shakeReport shakeOpts) $ \file -> do+            putWhenLn Normal $ "Writing report to " ++ file+            writeProgressReport file dat+     else do+        when (Sleep `elem` flagsExtra) $ threadDelay 1000000+        start <- offsetTime+        curdir <- getCurrentDirectory+        let redir = case changeDirectory of+                Nothing -> id+                -- get the "html" directory so it caches with the current directory+                -- required only for debug code+                Just d -> bracket_ (getDataFileName "html" >> setCurrentDirectory d) (setCurrentDirectory curdir)+        shakeOpts <- if null progressRecords then return shakeOpts else do+            t <- offsetTime+            return shakeOpts{shakeProgress = \p ->+                bracket+                    (forkIO $ shakeProgress shakeOpts p)+                    killThread+                    $ const $ progressDisplay 1 (const $ return ()) $ do+                        p <- p+                        t <- t+                        forM_ progressRecords $ \file ->+                            appendFile file $ show (t,p) ++ "\n"+                        return p+            }+        (ran,res) <- redir $ do+            when printDirectory $ putWhenLn Normal $ "shake: In directory `" ++ curdir ++ "'"+            rules <- rules user files+            case rules of+                Nothing -> return (False,Right ())+                Just rules -> do+                    res <- try_ $ shake shakeOpts $+                        if NoBuild `elem` flagsExtra then withoutActions rules else rules+                    return (True, res)++        if not ran || shakeVerbosity shakeOpts < Normal || NoTime `elem` flagsExtra then+            either throwIO return res+         else+            let esc = if shakeColor shakeOpts then escape else flip const+            in case res of+                Left err ->+                    if Exception `elem` flagsExtra then+                        throwIO err+                    else do+                        putWhenLn Quiet $ esc "31" $ show err+                        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"+    where+        opts = removeOverlap userOptions (map snd shakeOptsEx) `mergeOptDescr` userOptions+++-- | A list of command line options that can be used to modify 'ShakeOptions'. Each option returns+--   either an error message (invalid argument to the flag) or a function that changes some fields+--   in 'ShakeOptions'. The command line flags are @make@ compatible where possbile, but additional+--   flags have been added for the extra options Shake supports.+shakeOptDescrs :: [OptDescr (Either String (ShakeOptions -> ShakeOptions))]+shakeOptDescrs = [fmapOptDescr snd o | (True, o) <- shakeOptsEx]++data Extra = ChangeDirectory FilePath+           | Version+           | NumericVersion+           | PrintDirectory Bool+           | Help+           | Sleep+           | NoTime+           | Exception+           | NoBuild+           | ProgressRecord FilePath+           | ProgressReplay FilePath+           | Demo+             deriving Eq+++unescape :: String -> String+unescape ('\ESC':'[':xs) = unescape $ drop 1 $ dropWhile (not . isAlpha) xs+unescape (x:xs) = x : unescape xs+unescape [] = []++escape :: String -> String -> String+escape code x = "\ESC[" ++ code ++ "m" ++ x ++ "\ESC[0m"++outputColor :: (Verbosity -> String -> IO ()) -> Verbosity -> String -> IO ()+outputColor output v msg = output v $ escape "34" msg++-- | True if it has a potential effect on ShakeOptions+shakeOptsEx :: [(Bool, OptDescr (Either String ([Extra], ShakeOptions -> ShakeOptions)))]+shakeOptsEx =+    [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 ""  ["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."+    ,no  $ Option ""  ["demo"] (NoArg $ Right ([Demo], id)) "Run in demo mode."+    ,yes $ Option ""  ["digest"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeDigest})) "Files change when digest changes."+    ,yes $ Option ""  ["digest-and"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigest})) "Files change when modtime and digest change."+    ,yes $ Option ""  ["digest-and-input"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeAndDigestInput})) "Files change on modtime (and digest for inputs)."+    ,yes $ Option ""  ["digest-or"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtimeOrDigest})) "Files change when modtime or digest change."+    ,yes $ Option ""  ["digest-not"] (NoArg $ Right ([], \s -> s{shakeChange=ChangeModtime})) "Files change when modtime changes."+    ,no  $ Option ""  ["exception"] (NoArg $ Right ([Exception], id)) "Throw exceptions directly."+    ,yes $ Option ""  ["flush"] (intArg 1 "flush" "N" (\i s -> s{shakeFlush=Just i})) "Flush metadata every N seconds."+    ,yes $ Option ""  ["never-flush"] (noArg $ \s -> s{shakeFlush=Nothing}) "Never explicitly flush metadata."+    ,no  $ Option "h" ["help"] (NoArg $ Right ([Help],id)) "Print this message and exit."+    ,yes $ Option "j" ["jobs"] (optIntArg 0 "jobs" "N" $ \i s -> s{shakeThreads=fromMaybe 0 i}) "Allow N jobs/threads at once [default CPUs]."+    ,yes $ Option "k" ["keep-going"] (noArg $ \s -> s{shakeStaunch=True}) "Keep going when some targets can't be made."+    ,yes $ Option "l" ["lint"] (noArg $ \s -> s{shakeLint=Just LintBasic}) "Perform limited validation after the run."+    ,yes $ Option ""  ["lint-fsatrace"] (noArg $ \s -> s{shakeLint=Just LintFSATrace}) "Use fsatrace to do validation."+    ,yes $ Option ""  ["no-lint"] (noArg $ \s -> s{shakeLint=Nothing}) "Turn off --lint."+    ,yes $ Option ""  ["live"] (OptArg (\x -> Right ([], \s -> s{shakeLiveFiles=shakeLiveFiles s ++ [fromMaybe "live.txt" x]})) "FILE") "List the files that are live [to live.txt]."+    ,yes $ Option "m" ["metadata"] (reqArg "PREFIX" $ \x s -> s{shakeFiles=x}) "Prefix for storing metadata files."+    ,no  $ Option ""  ["numeric-version"] (NoArg $ Right ([NumericVersion],id)) "Print just the version number and exit."+    ,yes $ Option ""  ["skip-commands"] (noArg $ \s -> s{shakeRunCommands=False}) "Try and avoid running external programs."+    ,yes $ Option ""  ["rebuild"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNow, fromMaybe "**" x)]})) "PATTERN") "Rebuild matching files."+    ,yes $ Option ""  ["no-rebuild"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNormal, fromMaybe "**" x)]})) "PATTERN") "Rebuild matching files if necessary."+    ,yes $ Option ""  ["skip"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildLater, fromMaybe "**" x)]})) "PATTERN") "Don't rebuild matching files this run."+--    ,yes $ Option ""  ["skip-forever"] (OptArg (\x -> Right ([], \s -> s{shakeRebuild=shakeRebuild s ++ [(RebuildNever, fromMaybe "**" x)]})) "PATTERN") "Don't rebuild matching files until they change."+    ,yes $ Option "r" ["report","profile"] (OptArg (\x -> Right ([], \s -> s{shakeReport=shakeReport s ++ [fromMaybe "report.html" x]})) "FILE") "Write out profiling information [to report.html]."+    ,yes $ Option ""  ["no-reports"] (noArg $ \s -> s{shakeReport=[]}) "Turn off --report."+    ,yes $ Option ""  ["rule-version"] (reqArg "VERSION" $ \x s -> s{shakeVersion=x}) "Version of the build rules."+    ,yes $ Option ""  ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version."+    ,yes $ Option "s" ["silent"] (noArg $ \s -> s{shakeVerbosity=Silent}) "Don't print anything."+    ,no  $ Option ""  ["sleep"] (NoArg $ Right ([Sleep],id)) "Sleep for a second before building."+    ,yes $ Option "S" ["no-keep-going","stop"] (noArg $ \s -> s{shakeStaunch=False}) "Turns off -k."+    ,yes $ Option ""  ["storage"] (noArg $ \s -> s{shakeStorageLog=True}) "Write a storage log."+    ,yes $ Option "p" ["progress"] (progress $ optIntArg 1 "progress" "N" $ \i s -> s{shakeProgress=prog $ fromMaybe 5 i}) "Show progress messages [every N secs, default 5]."+    ,yes $ Option ""  ["no-progress"] (noArg $ \s -> s{shakeProgress=const $ return ()}) "Don't show progress messages."+    ,yes $ Option "q" ["quiet"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) pred}) "Don't print much."+    ,no  $ Option ""  ["no-time"] (NoArg $ Right ([NoTime],id)) "Don't print build time."+    ,yes $ Option ""  ["timings"] (noArg $ \s -> s{shakeTimings=True}) "Print phase timings."+    ,yes $ Option "V" ["verbose","trace"] (noArg $ \s -> s{shakeVerbosity=move (shakeVerbosity s) succ}) "Print tracing information."+    ,no  $ Option "v" ["version"] (NoArg $ Right ([Version],id)) "Print the version number and exit."+    ,no  $ Option "w" ["print-directory"] (NoArg $ Right ([PrintDirectory True],id)) "Print the current directory."+    ,no  $ Option ""  ["no-print-directory"] (NoArg $ Right ([PrintDirectory False],id)) "Turn off -w, even if it was turned on implicitly."+    ]+    where+        yes = (,) True+        no  = (,) False++        move :: Verbosity -> (Int -> Int) -> Verbosity+        move x by = toEnum $ min (fromEnum mx) $ max (fromEnum mn) $ by $ fromEnum x+            where (mn,mx) = (asTypeOf minBound x, asTypeOf maxBound x)++        noArg f = NoArg $ Right ([], f)+        reqArg a f = ReqArg (\x -> Right ([], f x)) a+        intArg mn flag a f = flip ReqArg a $ \x -> case reads x of+            [(i,"")] | i >= mn -> Right ([],f i)+            _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"+        optIntArg mn flag a f = flip OptArg a $ maybe (Right ([], f Nothing)) $ \x -> case reads x of+            [(i,"")] | i >= mn -> Right ([],f $ Just i)+            _ -> Left $ "the `--" ++ flag ++ "' option requires a number, " ++ show mn ++ " or above"+        pairArg flag a f = flip ReqArg a $ \x -> case break (== '=') x of+            (a,'=':b) -> Right ([],f (a,b))+            _ -> Left $ "the `--" ++ flag ++ "' option requires an = in the argument"++        progress (OptArg func msg) = flip OptArg msg $ \x -> case break (== '=') `fmap` x of+            Just ("record",file) -> Right ([ProgressRecord $ if null file then "progress.txt" else tail file], id)+            Just ("replay",file) -> Right ([ProgressReplay $ if null file then "progress.txt" else tail file], id)+            _ -> func x++        outputDebug output Nothing = output+        outputDebug output (Just file) = \v msg -> do+            when (v /= Diagnostic) $ output v msg+            appendFile file $ unescape msg ++ "\n"++        prog i p = do+            program <- progressProgram+            progressDisplay i (\s -> progressTitlebar s >> program s) p
+ src/Development/Shake/Internal/CmdOption.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Development.Shake.Internal.CmdOption(CmdOption(..)) where++import Data.Data+import qualified Data.ByteString.Lazy.Char8 as LBS++-- | Options passed to 'command' or 'cmd' to control how processes are executed.+data CmdOption+    = Cwd FilePath -- ^ Change the current directory in the spawned process. By default uses this processes current directory.+    | Env [(String,String)] -- ^ Change the environment variables in the spawned process. By default uses this processes environment.+    | AddEnv String String -- ^ Add an environment variable in the child process.+    | RemEnv String -- ^ Remove an environment variable from the child process.+    | AddPath [String] [String] -- ^ Add some items to the prefix and suffix of the @$PATH@ variable.+    | Stdin String -- ^ Given as the @stdin@ of the spawned process. By default the @stdin@ is inherited.+    | StdinBS LBS.ByteString -- ^ Given as the @stdin@ of the spawned process.+    | FileStdin FilePath -- ^ Take the @stdin@ from a file.+    | Shell -- ^ Pass the command to the shell without escaping - any arguments will be joined with spaces. By default arguments are escaped properly.+    | BinaryPipes -- ^ Treat the @stdin@\/@stdout@\/@stderr@ messages as binary. By default 'String' results use text encoding and 'ByteString' results use binary encoding.+    | Traced String -- ^ Name to use with 'traced', or @\"\"@ for no tracing. By default traces using the name of the executable.+    | Timeout Double -- ^ Abort the computation after N seconds, will raise a failure exit code. Calls 'interruptProcessGroupOf' and 'terminateProcess', but may sometimes fail to abort the process and not timeout.+    | WithStdout Bool -- ^ Should I include the @stdout@ in the exception if the command fails? Defaults to 'False'.+    | WithStderr Bool -- ^ Should I include the @stderr@ in the exception if the command fails? Defaults to 'True'.+    | EchoStdout Bool -- ^ Should I echo the @stdout@? Defaults to 'True' unless a 'Stdout' result is required or you use 'FileStdout'.+    | EchoStderr Bool -- ^ Should I echo the @stderr@? Defaults to 'True' unless a 'Stderr' result is required or you use 'FileStderr'.+    | FileStdout FilePath -- ^ Should I put the @stdout@ to a file.+    | FileStderr FilePath -- ^ Should I put the @stderr@ to a file.+    | AutoDeps -- ^ Compute dependencies automatically.+      deriving (Eq,Ord,Show,Data,Typeable)
+ src/Development/Shake/Internal/Core/Action.hs view
@@ -0,0 +1,254 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, ConstraintKinds #-}++module Development.Shake.Internal.Core.Action(+    runAction, actionOnException, actionFinally,+    getShakeOptions, getProgress, runAfter,+    trackUse, trackChange, trackAllow, trackCheckUsed,+    getVerbosity, putWhen, putLoud, putNormal, putQuiet, withVerbosity, quietly,+    blockApply, unsafeAllowApply,+    traced+    ) where++import Control.Exception.Extra+import Control.Applicative+import Control.Monad.Extra+import Control.Monad.IO.Class+import Control.DeepSeq+import Data.Typeable.Extra+import Data.Function+import Data.Either.Extra+import Data.Maybe+import Data.IORef+import Data.List+import System.IO.Extra++import Development.Shake.Internal.Core.Database+import Development.Shake.Internal.Core.Monad+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Value+import Development.Shake.Internal.Options+import Development.Shake.Internal.Errors+import General.Cleanup+import Prelude+++---------------------------------------------------------------------+-- RAW WRAPPERS++runAction :: Global -> Local -> Action a -> Capture (Either SomeException a)+runAction g l (Action x) = runRAW g l x+++---------------------------------------------------------------------+-- EXCEPTION HANDLING++actionBoom :: Bool -> Action a -> IO b -> Action a+actionBoom runOnSuccess act clean = do+    cleanup <- Action $ getsRO globalCleanup+    undo <- liftIO $ addCleanup cleanup $ void clean+    res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (mask_ undo >> clean) >> throwRAW e+    liftIO $ mask_ $ undo >> when runOnSuccess (void clean)+    return res++-- | If an exception is raised by the 'Action', perform some 'IO'.+actionOnException :: Action a -> IO b -> Action a+actionOnException = actionBoom False++-- | After an 'Action', perform some 'IO', even if there is an exception.+actionFinally :: Action a -> IO b -> Action a+actionFinally = actionBoom True+++---------------------------------------------------------------------+-- QUERIES++-- | Get the initial 'ShakeOptions', these will not change during the build process.+getShakeOptions :: Action ShakeOptions+getShakeOptions = Action $ getsRO globalOptions+++-- | Get the current 'Progress' structure, as would be returned by 'shakeProgress'.+getProgress :: Action Progress+getProgress = do+    res <- Action $ getsRO globalProgress+    liftIO res++-- | Specify an action to be run after the database has been closed, if building completes successfully.+runAfter :: IO () -> Action ()+runAfter op = do+    Global{..} <- Action getRO+    liftIO $ atomicModifyIORef globalAfter $ \ops -> (op:ops, ())+++---------------------------------------------------------------------+-- VERBOSITY++putWhen :: Verbosity -> String -> Action ()+putWhen v msg = do+    Global{..} <- Action getRO+    verb <- getVerbosity+    when (verb >= v) $+        liftIO $ globalOutput v msg+++-- | Write an unimportant message to the output, only shown when 'shakeVerbosity' is higher than normal ('Loud' or above).+--   The output will not be interleaved with any other Shake messages (other than those generated by system commands).+putLoud :: String -> Action ()+putLoud = putWhen Loud++-- | Write a normal priority message to the output, only supressed when 'shakeVerbosity' is 'Quiet' or 'Silent'.+--   The output will not be interleaved with any other Shake messages (other than those generated by system commands).+putNormal :: String -> Action ()+putNormal = putWhen Normal++-- | Write an important message to the output, only supressed when 'shakeVerbosity' is 'Silent'.+--   The output will not be interleaved with any other Shake messages (other than those generated by system commands).+putQuiet :: String -> Action ()+putQuiet = putWhen Quiet+++-- | Get the current verbosity level, originally set by 'shakeVerbosity'. If you+--   want to output information to the console, you are recommended to use+--   'putLoud' \/ 'putNormal' \/ 'putQuiet', which ensures multiple messages are+--   not interleaved. The verbosity can be modified locally by 'withVerbosity'.+getVerbosity :: Action Verbosity+getVerbosity = Action $ getsRW localVerbosity+++-- | Run an action with a particular verbosity level.+--   Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will+--   not have any impact on 'Diagnostic' tracing.+withVerbosity :: Verbosity -> Action a -> Action a+withVerbosity new = Action . unmodifyRW f . fromAction+    where f s0 = (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity s0})+++-- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced'+--   (including from 'Development.Shake.cmd' or 'Development.Shake.command') will not be printed to the screen.+--   Will not update the 'shakeVerbosity' returned by 'getShakeOptions' and will+--   not turn off any 'Diagnostic' tracing.+quietly :: Action a -> Action a+quietly = withVerbosity Quiet+++---------------------------------------------------------------------+-- BLOCK APPLY++unsafeAllowApply :: Action a -> Action a+unsafeAllowApply  = applyBlockedBy Nothing++blockApply :: String -> Action a -> Action a+blockApply = applyBlockedBy . Just++applyBlockedBy :: Maybe String -> Action a -> Action a+applyBlockedBy reason = Action . unmodifyRW f . fromAction+    where f s0 = (s0{localBlockApply=reason}, \s -> s{localBlockApply=localBlockApply s0})+++---------------------------------------------------------------------+-- TRACING++-- | Write an action to the trace list, along with the start/end time of running the IO action.+--   The 'Development.Shake.cmd' and 'Development.Shake.command' functions automatically call 'traced'.+--   The trace list is used for profile reports (see 'shakeReport').+--+--   By default 'traced' prints some useful extra context about what+--   Shake is building, e.g.:+--+-- > # traced message (for myobject.o)+--+--   To suppress the output of 'traced' (for example you want more control+--   over the message using 'putNormal'), use the 'quietly' combinator.+traced :: String -> IO a -> Action a+traced msg act = do+    Global{..} <- Action getRO+    stack <- Action $ getsRW localStack+    start <- liftIO globalTimestamp+    putNormal $ "# " ++ msg ++ " (for " ++ showTopStack stack ++ ")"+    res <- liftIO act+    stop <- liftIO globalTimestamp+    let trace = newTrace msg start stop+    liftIO $ evaluate $ rnf trace+    Action $ modifyRW $ \s -> s{localTraces = trace : localTraces s}+    return res+++---------------------------------------------------------------------+-- TRACKING++-- | Track that a key has been used by the action preceeding it.+trackUse :: 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+    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+++trackCheckUsed :: Action ()+trackCheckUsed = do+    Global{..} <- Action getRO+    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 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]+                ""+++-- | Track that a key has been changed by the action preceding it.+trackChange :: 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+    Global{..} <- Action getRO+    Local{..} <- Action getRW+    liftIO $ do+        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, ())+++-- | 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}+    where+        tk = typeRep (Proxy :: Proxy key)+        f k = typeKey k == tk && test (fromKey k)
+ src/Development/Shake/Internal/Core/Database.hs view
@@ -0,0 +1,513 @@+{-# LANGUAGE RecordWildCards, PatternGuards, DeriveFunctor #-}+{-# LANGUAGE Rank2Types, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}++module Development.Shake.Internal.Core.Database(+    Trace(..), newTrace,+    Database, withDatabase, assertFinishedDatabase,+    listDepends, lookupDependencies,+    BuildKey(..), build, Depends,+    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++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 ())+getResult (Ready r) = Just $ void r+getResult (Loaded r) = Just $ void r+getResult (Waiting _ r) = void <$> 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+++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+++-- | 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++        whenJust (checkStack is stack) $ \(badId, badKey) ->+            -- everything else gets thrown via Left and can be Staunch'd+            -- recursion in the rules is considered a worse error, so fails immediately+            errorRuleRecursion (showStack stack ++ [show badKey]) (typeKey badKey) (show badKey)++        buildMany stack is+            (\v -> case v of Error e -> Just e; _ -> Nothing)+            (\v -> return $ continue $ case v of+                Left e -> Left e+                Right rs -> Right (0, Depends is, map result rs)) $+            \go -> do+                time <- offsetTime+                go $ \x -> case x of+                    Left e -> addPoolHighPriority pool $ continue $ Left e+                    Right rs -> addPoolMediumPriority pool $ do dur <- time; continue $ Right (dur, Depends is, map result rs)+                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+            addPoolLowPriority 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 ())+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
@@ -0,0 +1,124 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Development.Shake.Internal.Core.Monad(+    RAW, Capture, runRAW,+    getRO, getRW, getsRO, getsRW, putRW, modifyRW,+    withRO, withRW,+    catchRAW, tryRAW, throwRAW,+    unmodifyRW, captureRAW,+    ) where++import Control.Exception.Extra+import Control.Monad.IO.Class+import Control.Monad.Trans.Cont+import Control.Monad.Trans.Reader+import Data.IORef+import Control.Applicative+import Control.Monad+import Prelude+++data S ro rw = S+    {handler :: IORef (SomeException -> IO ())+    ,ro :: ro+    ,rww :: IORef rw -- Read/Write Writeable var (rww)+    }++newtype RAW ro rw a = RAW {fromRAW :: ReaderT (S ro rw) (ContT () IO) a}+    deriving (Functor, Applicative, Monad, MonadIO)++type Capture a = (a -> IO ()) -> IO ()+++-- | Run and then call a continuation.+runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)+runRAW ro rw m k = do+    rww <- newIORef rw+    handler <- newIORef $ k . Left+    -- see https://ghc.haskell.org/trac/ghc/ticket/11555+    fromRAW m `runReaderT` S handler ro rww `runContT` (k . Right)+        `catch_` \e -> ($ e) =<< readIORef handler+++---------------------------------------------------------------------+-- STANDARD++getRO :: RAW ro rw ro+getRO = RAW $ asks ro++getRW :: RAW ro rw rw+getRW = RAW $ liftIO . readIORef =<< asks rww++getsRO :: (ro -> a) -> RAW ro rw a+getsRO f = fmap f getRO++getsRW :: (rw -> a) -> RAW ro rw a+getsRW f = fmap f getRW++-- | Strict version+putRW :: rw -> RAW ro rw ()+putRW rw = rw `seq` RAW $ liftIO . flip writeIORef rw =<< asks rww++withRAW :: (S ro rw -> S ro2 rw2) -> RAW ro2 rw2 a -> RAW ro rw a+withRAW f m = RAW $ withReaderT f $ fromRAW m++modifyRW :: (rw -> rw) -> RAW ro rw ()+modifyRW f = do x <- getRW; putRW $ f x++withRO :: (ro -> ro2) -> RAW ro2 rw a -> RAW ro rw a+withRO f = withRAW $ \s -> s{ro=f $ ro s}++withRW :: (rw -> rw2) -> RAW ro rw2 a -> RAW ro rw a+withRW f m = do+    rw <- getRW+    rww <- liftIO $ newIORef $ f rw+    withRAW (\s -> s{rww=rww}) m+++---------------------------------------------------------------------+-- EXCEPTIONS++catchRAW :: RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a+catchRAW m hdl = RAW $ ReaderT $ \s -> ContT $ \k -> do+    old <- readIORef $ handler s+    writeIORef (handler s) $ \e -> do+        writeIORef (handler s) old+        fromRAW (hdl e) `runReaderT` s `runContT` k `catch_`+            \e -> ($ e) =<< readIORef (handler s)+    fromRAW m `runReaderT` s `runContT` \v -> do+        writeIORef (handler s) old+        k v+++tryRAW :: RAW ro rw a -> RAW ro rw (Either SomeException a)+tryRAW m = catchRAW (fmap Right m) (return . Left)++throwRAW :: Exception e => e -> RAW ro rw a+throwRAW = liftIO . throwIO+++---------------------------------------------------------------------+-- WEIRD STUFF++-- | Apply a modification, run an action, then undo the changes after.+unmodifyRW :: (rw -> (rw, rw -> rw)) -> RAW ro rw a -> RAW ro rw a+unmodifyRW f m = do+    (s2,undo) <- fmap f getRW+    putRW s2+    res <- m+    modifyRW undo+    return res+++-- | Capture a continuation. The continuation should be called at most once.+--   Calling the same continuation, multiple times, in parallel, results in incorrect behaviour.+captureRAW :: Capture (Either SomeException a) -> RAW ro rw a+captureRAW f = RAW $ ReaderT $ \s -> ContT $ \k -> do+    old <- readIORef (handler s)+    writeIORef (handler s) throwIO+    f $ \x -> case x of+        Left e -> old e+        Right v -> do+            writeIORef (handler s) old+            k v `catch_` \e -> ($ e) =<< readIORef (handler s)+            writeIORef (handler s) throwIO
+ src/Development/Shake/Internal/Core/Pool.hs view
@@ -0,0 +1,202 @@++-- | Thread pool implementation.+module Development.Shake.Internal.Core.Pool(+    Pool, runPool,+    addPoolHighPriority, addPoolMediumPriority, addPoolLowPriority,+    increasePool+    ) where++import Control.Concurrent.Extra+import System.Time.Extra+import Control.Exception+import Control.Monad+import General.Timing+import qualified Data.HashSet as Set+import qualified Data.HashMap.Strict as Map+import System.Random+++---------------------------------------------------------------------+-- UNFAIR/RANDOM QUEUE++-- Monad for non-deterministic (but otherwise pure) computations+type NonDet a = IO a++-- Left = deterministic list, Right = non-deterministic tree+data Queue a = Queue [a] (Either [a] (Tree a))++newQueue :: Bool -> Queue a+newQueue deterministic = Queue [] $ if deterministic then Left [] else Right emptyTree++enqueuePriority :: a -> Queue a -> Queue a+enqueuePriority x (Queue p t) = Queue (x:p) t++enqueue :: a -> Queue a -> Queue a+enqueue x (Queue p (Left xs)) = Queue p $ Left $ x:xs+enqueue x (Queue p (Right t)) = Queue p $ Right $ insertTree x t++dequeue :: Queue a -> NonDet (Maybe (a, Queue a))+dequeue (Queue (p:ps) t) = return $ Just (p, Queue ps t)+dequeue (Queue [] (Left (x:xs))) = return $ Just (x, Queue [] $ Left xs)+dequeue (Queue [] (Left [])) = return Nothing+dequeue (Queue [] (Right t)) = do+    bs <- randomIO+    return $ case removeTree bs t of+        Nothing -> Nothing+        Just (x,t) -> Just (x, Queue [] $ Right t)+++---------------------------------------------------------------------+-- TREE++-- A tree where removal is random. Nodes are stored at indicies 0..n-1+data Tree a = Tree {-# UNPACK #-} !Int (Map.HashMap Int a)+++emptyTree :: Tree a+emptyTree = Tree 0 Map.empty++insertTree :: a -> Tree a -> Tree a+insertTree x (Tree n mp) = Tree (n+1) $ Map.insert n x mp++-- Remove an item at random, put the n-1 item to go in it's place+removeTree :: Int -> Tree a -> Maybe (a, Tree a)+removeTree rnd (Tree n mp)+        | n == 0 = Nothing+        | n == 1 = Just (mp Map.! 0, emptyTree)+        | i == n-1 = Just (mp Map.! i, Tree (n-1) $ Map.delete i mp)+        | otherwise = Just (mp Map.! i, Tree (n-1) $ Map.insert i (mp Map.! (n-1)) $ Map.delete (n-1) mp)+    where+        i = abs rnd `mod` n+++---------------------------------------------------------------------+-- 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+    }+++emptyS :: Int -> Bool -> S+emptyS n deterministic = S Set.empty n 0 0 $ newQueue deterministic+++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)++-- | Like 'forkFinally', but the inner thread is unmasked even if you started masked.+forkFinallyUnmasked :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinallyUnmasked act cleanup =+    mask_ $ forkIOWithUnmask $ \unmask ->+        try (unmask act) >>= cleanup++-- | Given a pool, and a function that breaks the S invariants, restore them+--   They are only allowed to touch threadsLimit or todo+step :: Pool -> (S -> NonDet S) -> IO ()+step pool@(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+++-- | Add a new task to the pool.+--   Medium priority is suitable for tasks that are resuming running after a pause.+addPoolMediumPriority :: Pool -> IO a -> IO ()+addPoolMediumPriority pool act = step pool $ \s -> do+    todo <- return $ enqueue (void act) (todo s)+    return s{todo = todo}++-- | Add a new task to the pool.+--   Low priority is suitable for new tasks that are just starting.+addPoolLowPriority :: Pool -> IO a -> IO ()+addPoolLowPriority = addPoolMediumPriority++-- | Add a new task to the pool.+--   High priority is suitable for tasks that have detected failure and are resuming to propagate that failure.+addPoolHighPriority :: Pool -> IO a -> IO ()+addPoolHighPriority pool act = step pool $ \s -> do+    todo <- return $ enqueuePriority (void act) (todo s)+    return s{todo = todo}+++-- | Temporarily increase the pool by 1 thread. Call the cleanup action to restore the value.+--   After calling cleanup you should requeue onto a new thread.+increasePool :: Pool -> IO (IO ())+increasePool pool = do+    step pool $ \s -> return s{threadsLimit = threadsLimit s + 1}+    return $ step pool $ \s -> return s{threadsLimit = threadsLimit s - 1}+++-- | Run all the tasks in the pool on the given number of works.+--   If any thread throws an exception, the exception will be reraised.+--   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+        addPoolMediumPriority 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/Development/Shake/Internal/Core/Rendezvous.hs view
@@ -0,0 +1,87 @@+{-# 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
@@ -0,0 +1,215 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-}+{-# LANGUAGE ExistentialQuantification, RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Shake.Internal.Core.Rules(+    Rules, runRules,+    RuleResult, addBuiltinRule, addBuiltinRuleEx, noLint,+    getShakeOptionsRules, userRuleMatch,+    getUserRules, addUserRule, alternatives, priority,+    action, withoutActions+    ) where++import Control.Applicative+import Data.Tuple.Extra+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 Data.Binary+import General.Binary+import Data.Typeable.Extra+import Data.Function+import Data.List.Extra+import qualified Data.HashMap.Strict as Map+import Data.Maybe+import System.IO.Extra+import System.IO.Unsafe+import Data.Monoid+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Binary.Builder as Bin+import Data.Binary.Put+import Data.Binary.Get+import General.ListBuilder++import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Monad+import Development.Shake.Internal.Value+import Development.Shake.Internal.Options+import Development.Shake.Internal.Errors+import Prelude+++---------------------------------------------------------------------+-- 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+        userRules <- Action $ getsRO globalUserRules+        return $ case Map.lookup (typeRep (Proxy :: Proxy a)) userRules of+            Nothing -> Unordered []+            Just (UserRule_ r) -> fromJust $ cast r+++-- | Get the 'ShakeOptions' that were used.+getShakeOptionsRules :: Rules ShakeOptions+getShakeOptionsRules = Rules $ lift ask++-- | 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) ++ [[]]+    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)]+++-- | 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)+    deriving (Functor, Applicative, Monad, MonadIO, MonadFix)++newRules :: SRules -> Rules ()+newRules = Rules . tell++modifyRules :: (SRules -> SRules) -> Rules () -> Rules ()+modifyRules f (Rules r) = Rules $ censor f r++runRules :: ShakeOptions -> Rules () -> IO ([Action ()], Map.HashMap TypeRep BuiltinRule, Map.HashMap TypeRep UserRule_)+runRules opts (Rules r) = do+    SRules{..} <- runReaderT (execWriterT r) opts+    return (runListBuilder actions, builtinRules, userRules)++data SRules = SRules+    {actions :: !(ListBuilder (Action ()))+    ,builtinRules :: !(Map.HashMap TypeRep{-k-} BuiltinRule)+    ,userRules :: !(Map.HashMap TypeRep{-k-} UserRule_)+    }++instance Monoid SRules where+    mempty = SRules mempty Map.empty Map.empty+    mappend (SRules x1 x2 x3) (SRules y1 y2 y3) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (Map.unionWith g x3 y3)+        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]+++instance Monoid a => Monoid (Rules a) where+    mempty = return mempty+    mappend = liftA2 mappend+++-- | Add a value of type 'UserRule'.+addUserRule :: Typeable a => a -> Rules ()+addUserRule r = newRules mempty{userRules = Map.singleton (typeOf r) $ UserRule_ $ UserRule r}++-- | A suitable 'BuiltinLint' that always succeeds.+noLint :: BuiltinLint key value+noLint _ _ = return Nothing++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+    (putEx . Bin.toLazyByteString . execPut . put)+    (runGet get . LBS.fromChunks . return)++addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, ShakeValue value, BinaryEx key) => BuiltinLint key value -> BuiltinRun key value -> Rules ()+addBuiltinRuleEx = addBuiltinRuleInternal $ BinaryOp putEx getEx+++-- | Unexpected version of 'addBuiltinRule', which also lets me set the 'BinaryOp'.+addBuiltinRuleInternal :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => BinaryOp key -> BuiltinLint key value -> BuiltinRun key value -> Rules ()+addBuiltinRuleInternal binary lint (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 binary_ = BinaryOp (putOp binary . fromKey) (newKey . getOp binary)+    newRules mempty{builtinRules = Map.singleton (typeRep k) $ BuiltinRule run_ lint_ (typeRep v) binary_}+++-- | Change the priority of a given set of rules, where higher priorities take precedence.+--   All matching rules at a given priority must be disjoint, or an error is raised.+--   All builtin Shake rules have priority between 0 and 1.+--   Excessive use of 'priority' is discouraged. As an example:+--+-- @+-- 'priority' 4 $ \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"+-- 'priority' 8 $ \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"+-- @+--+--   In this example @hello.txt@ will match the second rule, instead of raising an error about ambiguity.+--+--   The 'priority' function obeys the invariants:+--+-- @+-- '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+++-- | 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.+--+-- @+-- 'alternatives' $ do+--     \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"+--     \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"+-- @+--+--   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+++-- | Run an action, usually used for specifying top-level requirements.+--+-- @+-- main = 'Development.Shake.shake' 'shakeOptions' $ do+--    'action' $ do+--        b <- 'Development.Shake.doesFileExist' \"file.src\"+--        when b $ 'Development.Shake.need' [\"file.out\"]+-- @+--+--   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.+--+--   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}+++-- | Remove all actions specified in a set of rules, usually used for implementing+--   command line specification of what to build.+withoutActions :: Rules () -> Rules ()+withoutActions = modifyRules $ \x -> x{actions=mempty}
+ src/Development/Shake/Internal/Core/Run.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Shake.Internal.Core.Run(+    run,+    Action, actionOnException, actionFinally, apply, apply1, traced,+    getShakeOptions, getProgress,+    getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,+    Resource, newResource, newResourceIO, withResource, withResources, newThrottle, newThrottleIO,+    newCache, newCacheIO,+    unsafeExtraThread, unsafeAllowApply,+    parallel,+    orderOnlyAction,+    -- Internal stuff+    runAfter+    ) where++import Control.Exception.Extra+import Control.Applicative+import Data.Tuple.Extra+import Control.Concurrent.Extra+import Control.Monad.Extra+import Control.Monad.IO.Class+import Data.Typeable.Extra+import Data.Function+import Data.Either.Extra+import Data.List.Extra+import qualified Data.HashMap.Strict as Map+import Data.Dynamic+import Data.Maybe+import Data.IORef+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 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 Prelude++---------------------------------------------------------------------+-- MAKE++-- | Internal main function (not exported publicly)+run :: ShakeOptions -> Rules () -> IO ()+run opts@ShakeOptions{..} rs = (if shakeLineBuffering then lineBuffering else id) $ do+    opts@ShakeOptions{..} <- if shakeThreads /= 0 then return opts else do p <- getProcessorCount; return opts{shakeThreads=p}++    start <- offsetTime+    (actions, ruleinfo, userRules) <- runRules opts rs++    outputLocked <- do+        lock <- newLock+        return $ \v msg -> withLock lock $ shakeOutput v msg++    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++    curdir <- getCurrentDirectory+    diagnostic $ return "Starting run 2"+    checkShakeExtra shakeExtra++    after <- newIORef []+    absent <- newIORef []+    withCleanup $ \cleanup -> do+        _ <- addCleanup cleanup $ do+            when shakeTimings 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 1000000 $ waitBarrier wait++                addTiming "Running rules"+                runPool (shakeThreads == 1) shakeThreads $ \pool -> do+                    let s0 = Global database pool cleanup start ruleinfo output opts diagnostic curdir after absent getProgress userRules+                    let s1 = newLocal emptyStack shakeVerbosity+                    forM_ actions $ \act ->+                        addPoolLowPriority pool $ runAction s0 s1 act $ \x -> case x of+                            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++                when (null actions) $+                    putWhen Normal "Warning: No want/action statements, nothing to do"++                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+            sequence_ . reverse =<< readIORef after+++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 ()+++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)]+        ""+++lineBuffering :: IO a -> IO a+lineBuffering act = do+    -- instead of withBuffering avoid two finally handlers and stack depth+    out <- hGetBuffering stdout+    err <- hGetBuffering stderr+    hSetBuffering stdout LineBuffering+    hSetBuffering stderr LineBuffering+    act `finally` do+        hSetBuffering stdout out+        hSetBuffering stderr err+++-- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel.+--   This function requires that appropriate rules have been added with 'addUserRule'.+--   All @key@ values passed to 'apply' become dependencies of the 'Action'.+apply :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => [key] -> Action [value]+-- 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+    block <- Action $ getsRW localBlockApply+    whenJust block $ liftIO . errorNoApply tk (show <$> listToMaybe ks)+    case Map.lookup tk globalRules of+        Nothing -> liftIO $ errorNoRuleToBuildType tk (show <$> listToMaybe ks) (Just tv)+        Just BuiltinRule{builtinResult=tv2} | tv /= tv2 -> errorInternal $ "result type does not match, " ++ show tv ++ " vs " ++ show tv2 +        _ -> fmap (map fromValue) $ applyKeyValue $ map newKey ks+++applyKeyValue :: [Key] -> Action [Value]+applyKeyValue [] = return []+applyKeyValue ks = do+    global@Global{..} <- Action getRO+    stack <- Action $ getsRW localStack+    (dur, dep, vs) <- Action $ captureRAW $ build globalPool globalDatabase (BuildKey $ runKey global) stack ks+    Action $ modifyRW $ \s -> s{localDiscount=localDiscount s + dur, localDepends=dep : localDepends s}+    return vs+++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++    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 = reverse localDepends+                        ,execution = doubleToFloat $ dur - localDiscount+                        ,traces = reverse localTraces}+++runLint :: Map.HashMap TypeRep BuiltinRule -> Key -> Value -> IO (Maybe String)+runLint mp k v = case Map.lookup (typeKey k) mp of+    Nothing -> return Nothing+    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+++-- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,+--   use 'apply' to allow parallelism.+apply1 :: (RuleResult key ~ value, ShakeValue key, ShakeValue value) => key -> Action value+apply1 = fmap head . apply . return+++---------------------------------------------------------------------+-- RESOURCES++-- | Create a finite resource, given a name (for error messages) and a quantity of the resource that exists.+--   Shake will ensure that actions using the same finite resource do not execute in parallel.+--   As an example, only one set of calls to the Excel API can occur at one time, therefore+--   Excel is a finite resource of quantity 1. You can write:+--+-- @+-- 'Development.Shake.shake' 'Development.Shake.shakeOptions'{'Development.Shake.shakeThreads'=2} $ do+--    'Development.Shake.want' [\"a.xls\",\"b.xls\"]+--    excel <- 'Development.Shake.newResource' \"Excel\" 1+--    \"*.xls\" 'Development.Shake.%>' \\out ->+--        'Development.Shake.withResource' excel 1 $+--            'Development.Shake.cmd' \"excel\" out ...+-- @+--+--   Now the two calls to @excel@ will not happen in parallel.+--+--   As another example, calls to compilers are usually CPU bound but calls to linkers are usually+--   disk bound. Running 8 linkers will often cause an 8 CPU system to grid to a halt. We can limit+--   ourselves to 4 linkers with:+--+-- @+-- disk <- 'Development.Shake.newResource' \"Disk\" 4+-- 'Development.Shake.want' [show i 'Development.Shake.FilePath.<.>' \"exe\" | i <- [1..100]]+-- \"*.exe\" 'Development.Shake.%>' \\out ->+--     'Development.Shake.withResource' disk 1 $+--         'Development.Shake.cmd' \"ld -o\" [out] ...+-- \"*.o\" 'Development.Shake.%>' \\out ->+--     'Development.Shake.cmd' \"cl -o\" [out] ...+-- @+newResource :: String -> Int -> Rules Resource+newResource name mx = liftIO $ newResourceIO name mx+++-- | Create a throttled resource, given a name (for error messages) and a number of resources (the 'Int') that can be+--   used per time period (the 'Double' in seconds). Shake will ensure that actions using the same throttled resource+--   do not exceed the limits. As an example, let us assume that making more than 1 request every 5 seconds to+--   Google results in our client being blacklisted, we can write:+--+-- @+-- google <- 'Development.Shake.newThrottle' \"Google\" 1 5+-- \"*.url\" 'Development.Shake.%>' \\out -> do+--     'Development.Shake.withResource' google 1 $+--         'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]+-- @+--+--   Now we will wait at least 5 seconds after querying Google before performing another query. If Google change the rules to+--   allow 12 requests per minute we can instead use @'Development.Shake.newThrottle' \"Google\" 12 60@, which would allow+--   greater parallelisation, and avoid throttling entirely if only a small number of requests are necessary.+--+--   In the original example we never make a fresh request until 5 seconds after the previous request has /completed/. If we instead+--   want to throttle requests since the previous request /started/ we can write:+--+-- @+-- google <- 'Development.Shake.newThrottle' \"Google\" 1 5+-- \"*.url\" 'Development.Shake.%>' \\out -> do+--     'Development.Shake.withResource' google 1 $ return ()+--     'Development.Shake.cmd' \"wget\" [\"http:\/\/google.com?q=\" ++ 'Development.Shake.FilePath.takeBaseName' out] \"-O\" [out]+-- @+--+--   However, the rule may not continue running immediately after 'Development.Shake.withResource' completes, so while+--   we will never exceed an average of 1 request every 5 seconds, we may end up running an unbounded number of+--   requests simultaneously. If this limitation causes a problem in practice it can be fixed.+newThrottle :: String -> Int -> Double -> Rules Resource+newThrottle name count period = liftIO $ newThrottleIO name count period+++-- | Run an action which uses part of a finite resource. For more details see 'Resource'.+--   You cannot depend on a rule (e.g. 'need') while a resource is held.+withResource :: Resource -> Int -> Action a -> Action a+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+++-- | Run an action which uses part of several finite resources. Acquires the resources in a stable+--   order, to prevent deadlock. If all rules requiring more than one resource acquire those+--   resources with a single call to 'withResources', resources will not deadlock.+withResources :: [(Resource, Int)] -> Action a -> Action a+withResources res act+    | (r,i):_ <- filter ((< 0) . snd) res = error $ "You cannot acquire a negative quantity of " ++ show r ++ ", requested " ++ show i+    | otherwise = f $ groupBy ((==) `on` fst) $ sortBy (compare `on` fst) res+    where+        f [] = act+        f (r:rs) = withResource (fst $ head r) (sum $ map snd r) $ f rs+++-- | A version of 'newCache' that runs in IO, and can be called before calling 'Development.Shake.shake'.+--   Most people should use 'newCache' instead.+newCacheIO :: (Eq k, Hashable k) => (k -> Action v) -> IO (k -> Action v)+newCacheIO act = do+    var {- :: Var (Map k (Fence (Either SomeException ([Depends],v)))) -} <- newVar Map.empty+    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+                        pool <- Action $ getsRO globalPool+                        offset <- liftIO offsetTime+                        Action $ captureRAW $ \k -> waitFence bar $ \v ->+                            addPoolMediumPriority pool $ 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+                    pre <- Action $ getsRW localDepends+                    res <- Action $ tryRAW $ fromAction $ act key+                    case res of+                        Left err -> do+                            liftIO $ signalFence bar $ Left err+                            Action $ throwRAW err+                        Right v -> do+                            post <- Action $ getsRW localDepends+                            let deps = take (length post - length pre) post+                            liftIO $ signalFence bar $ Right (deps, v)+                            return v++-- | Given an action on a key, produce a cached version that will execute the action at most once per key.+--   Using the cached result will still result include any dependencies that the action requires.+--   Each call to 'newCache' creates a separate cache that is independent of all other calls to 'newCache'.+--+--   This function is useful when creating files that store intermediate values,+--   to avoid the overhead of repeatedly reading from disk, particularly if the file requires expensive parsing.+--   As an example:+--+-- @+-- digits \<- 'newCache' $ \\file -> do+--     src \<- readFile\' file+--     return $ length $ filter isDigit src+-- \"*.digits\" 'Development.Shake.%>' \\x -> do+--     v1 \<- digits ('dropExtension' x)+--     v2 \<- digits ('dropExtension' x)+--     'Development.Shake.writeFile'' x $ show (v1,v2)+-- @+--+--   To create the result @MyFile.txt.digits@ the file @MyFile.txt@ will be read and counted, but only at most+--   once per execution.+newCache :: (Eq k, Hashable k) => (k -> Action v) -> Rules (k -> Action v)+newCache = liftIO . newCacheIO+++-- | Run an action without counting to the thread limit, typically used for actions that execute+--   on remote machines using barely any local CPU resources.+--   Unsafe as it allows the 'shakeThreads' limit to be exceeded.+--   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 addPoolHighPriority else addPoolMediumPriority) globalPool $ continue res+++-- | Execute a list of actions in parallel. In most cases 'need' will be more appropriate to benefit from parallelism.+parallel :: [Action a] -> Action [a]+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++    (locals, results) <- captureRAW $ \continue -> do+        let resume = do+                res <- liftIO $ sequence . catMaybes <$> mapM readIORef results+                continue $ fmap unzip res++        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)+            addPoolMediumPriority globalPool $ runAction global local act2 $ \res -> do+                writeIORef result $ Just res+                modifyVar_ todo $ \v -> case v of+                    Nothing -> return Nothing+                    Just i | i == 1 || isLeft res -> do resume; return Nothing+                    Just i -> return $ Just $ i - 1++    -- don't construct with RecordWildCards so any new fields raise an error+    modifyRW $ \root -> Local+        -- immutable/stack that need copying+        {localStack = localStack root+        ,localVerbosity = localVerbosity root+        ,localBlockApply = localBlockApply root+        -- mutable locals that need integrating+        ,localDepends = localDepends root ++ concatMap localDepends locals+        ,localDiscount = localDiscount root + maximum (0:map localDiscount locals)+        ,localTraces = localTraces root ++ concatMap localTraces locals+        ,localTrackAllows = localTrackAllows root ++ concatMap localTrackAllows locals+        ,localTrackUsed = localTrackUsed root ++ concatMap localTrackUsed locals+        }+    return results+++-- | 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+    pre <- getsRW localDepends+    res <- fromAction act+    modifyRW $ \s -> s{localDepends=pre}+    return res
+ src/Development/Shake/Internal/Core/Storage.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE ScopedTypeVariables, RecordWildCards, FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-+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+-}++module Development.Shake.Internal.Core.Storage(+    withStorage+    ) where++import General.Chunks+import General.Binary+import General.Intern+import Development.Shake.Internal.Options+import General.Timing+import General.FileLock+import qualified General.Ids as Ids++import Control.Exception.Extra+import Control.Monad.Extra+import Data.Monoid+import Data.Either.Extra+import Data.Time+import Data.Char+import Data.Word+import Development.Shake.Classes+import Numeric+import General.Extra+import Data.List.Extra+import Data.Maybe+import System.Directory+import System.FilePath+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.HashMap.Strict as Map++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString as BS8+import Data.Functor+import Prelude+++-- Increment every time the on-disk format/semantics change,+-- @x@ is for the users version number+databaseVersion :: String -> String+-- 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"+    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+++-- | Storage of heterogeneous things. In the particular case of Shake,+--   k ~ TypeRep, 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+--   error witness is manufactured. If the witness ever changes the entire DB is+--   rewritten.+withStorage+    :: (Show k, Eq k, Hashable k, Show 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+    let dbfile = shakeFiles </> ".shake.database"+    createDirectoryIfMissing True shakeFiles++    -- complete a partially failed compress+    whenM (restoreChunksBackup dbfile) $ do+        unexpected "Backup file exists, restoring over the previous file\n"+        diagnostic $ return "Backup file move to original"++    addTiming "Database read"+    withChunks dbfile shakeFlush $ \h -> do++        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+            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"]+            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++                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+                                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++                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++        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+    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+++keyName :: Show k => k -> BS.ByteString+keyName = UTF8.fromString . show+++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+    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]+++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)+    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+++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
+ src/Development/Shake/Internal/Core/Types.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification, DeriveFunctor #-}++module Development.Shake.Internal.Core.Types(+    BuiltinRun, BuiltinLint, RunResult(..), RunChanged(..),+    UserRule(..), UserRule_(..),+    BuiltinRule(..), Global(..), Local(..), Action(..),+    newLocal+    ) where++import Control.DeepSeq+import Control.Monad.IO.Class+import Control.Applicative+import Data.Typeable+import General.Binary+import qualified Data.HashMap.Strict as Map+import Data.IORef+import qualified Data.ByteString as BS+import System.Time.Extra++import Development.Shake.Internal.Core.Pool+import Development.Shake.Internal.Core.Database+import Development.Shake.Internal.Core.Monad+import Development.Shake.Internal.Value+import Development.Shake.Internal.Options+import General.Cleanup+import Prelude+++---------------------------------------------------------------------+-- UNDERLYING DATA TYPE++-- | The 'Action' monad, use 'liftIO' to raise 'IO' actions into it, and 'Development.Shake.need' to execute files.+--   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)++-- | How has a rule changed.+data RunChanged+    = ChangedNothing -- ^ Nothing has changed.+    | ChangedStore -- ^ The persisted value has changed, but in a way that should be considered identical.+    | ChangedRecomputeSame -- ^ I recomputed the value and it was the same.+    | ChangedRecomputeDiff -- ^ I recomputed the value and it was different.+      deriving (Eq,Show)++instance NFData RunChanged where rnf x = x `seq` ()+++-- | The result of 'BuiltinRun'.+data RunResult value = RunResult+    {runChanged :: RunChanged+        -- ^ What has changed from the previous time.+    ,runStore :: BS.ByteString+        -- ^ Return the new value to store. Often a serialised version of 'runValue'.+    ,runValue :: value+        -- ^ Return the produced value.+    } 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:+--+-- * How to identify individual artifacts, given by the @key@ type, e.g. with file names.+--+-- * How to describe the state of an artifact, given by the @value@ type, e.g. the file modification time.+--+-- * How to persist the state of an artifact, using the 'ByteString' values, e.g. seralised @value@.+--+--   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.+type BuiltinRun key value+    = key+    -> Maybe BS.ByteString+    -> Bool+    -> Action (RunResult value)++-- | The action performed by @--lint@ for a given @key@/@value@ pair.+--   At the end of the build the lint action will be called for each @key@ that was built this run,+--   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'.+type BuiltinLint key value = key -> value -> IO (Maybe String)++data BuiltinRule = BuiltinRule+    {builtinRun :: BuiltinRun Key Value+    ,builtinLint :: BuiltinLint Key Value+    ,builtinResult :: TypeRep+    ,builtinKey :: BinaryOp Key+    }+++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+-- > priority p1 (priority p2 x) == priority p1 x+-- > priority p (x `ordered` y) = priority p x `ordered` priority p y+-- > priority p (x `unordered` y) = priority p x `unordered` priority p y+-- > ordered is associative+-- > unordered is associative and commutative+-- > alternative does not obey priorities, until picking the best one+    = UserRule a -- ^ Added to the state with @'addUserRule' :: Typeable a => a -> 'Rules' ()@.+    | 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.+      deriving (Eq,Show,Functor,Typeable)+++-- global constants of Action+data Global = Global+    {globalDatabase :: 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+    ,globalRules :: Map.HashMap TypeRep BuiltinRule -- ^ Rules for this build+    ,globalOutput :: Verbosity -> String -> IO () -- ^ Output function+    ,globalOptions  :: ShakeOptions -- ^ Shake options+    ,globalDiagnostic :: IO String -> IO () -- ^ Debugging function+    ,globalCurDir :: FilePath -- ^ getCurrentDirectory when we started+    ,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_+    }++-- local variables of Action+data Local = Local+    -- constants+    {localStack :: Stack -- ^ The stack that ran to get here.+    -- 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+    ,localTraces :: [Trace] -- ^ Traces, built in reverse+    ,localTrackAllows :: [Key -> Bool] -- ^ Things that are allowed to be used+    ,localTrackUsed :: [Key] -- ^ Things that have been used+    }++newLocal :: Stack -> Verbosity -> Local+newLocal stack verb = Local stack verb Nothing [] 0 [] [] []
+ src/Development/Shake/Internal/Demo.hs view
@@ -0,0 +1,136 @@++-- | Demo tutorial, accessed with --demo+module Development.Shake.Internal.Demo(demo) where++import Paths_shake+import Development.Shake.Command++import Control.Applicative+import Control.Exception.Extra+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Data.Version(showVersion)+import System.Directory+import System.Exit+import System.FilePath+import Development.Shake.FilePath(exe)+import System.IO+import System.Info.Extra+import Prelude+++demo :: Bool -> IO ()+demo auto = do+    hSetBuffering stdout NoBuffering+    putStrLn $ "% Welcome to the Shake v" ++ showVersion version ++ " demo mode!"+    putStr "% Detecting machine configuration... "++    -- CONFIGURE++    manual <- getDataFileName "docs/manual"+    hasManual <- wrap $ doesDirectoryExist manual+    ghc <- findExecutable "ghc"+    gcc <- do+        v <- findExecutable "gcc"+        case v of+            Nothing | isWindows, Just ghc <- ghc -> do+                let dir = takeDirectory (takeDirectory ghc) </> "bin/mingw/gcc.exe"+                b <- wrap $ doesFileExist dir+                return $ if b then Just dir else Nothing+            _ -> return v+    shakeLib <- wrap $ fmap (not . null . words . fromStdout) (cmd "ghc-pkg list --simple-output shake")+    ninja <- findExecutable "ninja"+    putStrLn "done\n"++    let path = if isWindows then "%PATH%" else "$PATH"+    require (isJust ghc) $ "% You don't have 'ghc' on your " ++ path ++ ", which is required to run the demo."+    require (isJust gcc) $ "% You don't have 'gcc' on your " ++ path ++ ", which is required to run the demo."+    require shakeLib "% You don't have the 'shake' library installed with GHC, which is required to run the demo."+    require hasManual "% You don't have the Shake data files installed, which are required to run the demo."++    empty <- (not . any (not . all (== '.'))) <$> getDirectoryContents "."+    dir <- if empty then getCurrentDirectory else do+        home <- getHomeDirectory+        dir <- getDirectoryContents home+        return $ home </> head (map ("shake-demo" ++) ("":map show [2..]) \\ dir)++    putStrLn "% The Shake demo uses an empty directory, OK to use:"+    putStrLn $ "%     " ++ dir+    b <- yesNo auto+    require b "% Please create an empty directory to run the demo from, then run 'shake --demo' again."++    putStr "% Copying files... "+    createDirectoryIfMissing True dir+    forM_ ["Build.hs","main.c","constants.c","constants.h","build" <.> if isWindows then "bat" else "sh"] $ \file ->+        copyFile (manual </> file) (dir </> file)+    unless isWindows $ do+         p <- getPermissions $ dir </> "build.sh"+         setPermissions (dir </> "build.sh") p{executable=True}+    putStrLn "done"++    let pause = do+            putStr "% Press ENTER to continue: "+            if auto then putLine "" else getLine+    let execute x = do+            putStrLn $ "% RUNNING: " ++ x+            cmd (Cwd dir) Shell x :: IO ()+    let build = if isWindows then "build" else "./build.sh"++    putStrLn "\n% [1/5] Building an example project with Shake."+    pause+    putStrLn $ "% RUNNING: cd " ++ dir+    execute build++    putStrLn "\n% [2/5] Running the produced example."+    pause+    execute $ "_build" </> "run" <.> exe++    putStrLn "\n% [3/5] Rebuilding an example project with Shake (nothing should change)."+    pause+    execute build++    putStrLn "\n% [4/5] Cleaning the build."+    pause+    execute $ build ++ " clean"++    putStrLn "\n% [5/5] Rebuilding with 2 threads and profiling."+    pause+    execute $ build ++ " -j2 --report --report=-"+    putStrLn "\n% See the profiling summary above, or look at the HTML profile report in"+    putStrLn $ "%     " ++ dir </> "report.html"++    putStrLn "\n% Demo complete - all the examples can be run from:"+    putStrLn $ "%     " ++ dir+    putStrLn "% For more info see http://shakebuild.com"+    when (isJust ninja) $ do+        putStrLn "\n% PS. Shake can also execute Ninja build files"+        putStrLn "% For more info see http://shakebuild.com/ninja"++++-- | Require the user to press @y@ before continuing.+yesNo :: Bool -> IO Bool+yesNo auto = do+    putStr "% [Y/N] (then ENTER): "+    x <- if auto then putLine "y" else fmap (map toLower) getLine+    if "y" `isPrefixOf` x then+        return True+     else if "n" `isPrefixOf` x then+        return False+     else+        yesNo auto++putLine :: String -> IO String+putLine x = putStrLn x >> return x+++-- | Replace exceptions with 'False'.+wrap :: IO Bool -> IO Bool+wrap act = act `catch_` const (return False)+++-- | Require a condition to be true, or exit with a message.+require :: Bool -> String -> IO ()+require b msg = unless b $ putStrLn msg >> exitFailure
+ src/Development/Shake/Internal/Derived.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Development.Shake.Internal.Derived(+    copyFile', copyFileChanged,+    readFile', readFileLines,+    writeFile', writeFileLines, writeFileChanged,+    withTempFile, withTempDir,+    getHashedShakeVersion,+    getShakeExtra, addShakeExtra,+    apply1,+    par, forP+    ) where++import Control.Applicative+import Control.Monad.Extra+import Control.Monad.IO.Class+import System.Directory+import General.Extra+import System.FilePath (takeDirectory)+import System.IO.Extra hiding (withTempFile, withTempDir, readFile')++import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Options+import Development.Shake.Internal.Rules.File+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as Map+import Data.Hashable+import Data.Typeable.Extra+import Data.Dynamic+import Prelude+++-- | Get a checksum of a list of files, suitable for using as `shakeVersion`.+--   This will trigger a rebuild when the Shake rules defined in any of the files are changed.+--   For example:+--+-- @+-- main = do+--     ver <- 'getHashedShakeVersion' [\"Shakefile.hs\"]+--     'shakeArgs' 'shakeOptions'{'shakeVersion' = ver} ...+-- @+--+--   To automatically detect the name of the current file, turn on the @TemplateHaskell@+--   extension and write @$(LitE . StringL . loc_filename \<$\> location)@.+--+--   This feature can be turned off during development by passing+--   the flag @--no-rule-version@ or setting 'shakeVersionIgnore' to 'True'.+getHashedShakeVersion :: [FilePath] -> IO String+getHashedShakeVersion files = do+    hashes <- mapM (fmap (hashWithSalt 0) . BS.readFile) files+    return $ "hash-" ++ show (hashWithSalt 0 hashes)+++-- | Get an item from 'shakeExtra', using the requested type as the key. Fails+-- if the value found at this key does not match the requested type.+getShakeExtra :: Typeable a => Action (Maybe a)+getShakeExtra = withResultType $ \(_ :: Maybe (Action (Maybe a))) -> do+    let want = typeRep (Proxy :: Proxy a)+    extra <- shakeExtra <$> getShakeOptions+    case Map.lookup want extra of+        Just dyn+            | Just x <- fromDynamic dyn -> return $ Just x+            | otherwise -> fail $+                "getShakeExtra: Key " ++ show want ++ " had value of unexpected type " ++ show (dynTypeRep dyn)+        Nothing -> return Nothing++-- | Add a properly structued value to 'shakeExtra' which can be retrieved with 'getShakeExtra'.+addShakeExtra :: Typeable a => a -> Map.HashMap TypeRep Dynamic -> Map.HashMap TypeRep Dynamic+addShakeExtra x = Map.insert (typeOf x) (toDyn x)+++-- | @copyFile' old new@ copies the existing file from @old@ to @new@.+--   The @old@ file will be tracked as a dependency.+--   Also creates the new directory if necessary.+copyFile' :: FilePath -> FilePath -> Action ()+copyFile' old new = do+    need [old]+    putLoud $ "Copying from " ++ old ++ " to " ++ new+    liftIO $ createDirectoryIfMissing True $ takeDirectory new+    liftIO $ copyFile old new++-- | @copyFileChanged old new@ copies the existing file from @old@ to @new@, if the contents have changed.+--   The @old@ file will be tracked as a dependency.+--   Also creates the new directory if necessary.+copyFileChanged :: FilePath -> FilePath -> Action ()+copyFileChanged old new = do+    need [old]+    -- in newer versions of the directory package we can use copyFileWithMetadata which (we think) updates+    -- the timestamp as well and thus no need to read the source file twice.+    unlessM (liftIO $ doesFileExist new &&^ fileEq old new) $ do+        putLoud $ "Copying from " ++ old ++ " to " ++ new+        liftIO $ createDirectoryIfMissing True $ takeDirectory new+        -- copyFile does a lot of clever stuff with permissions etc, so make sure we just reuse it+        liftIO $ copyFile old new+++-- | Read a file, after calling 'need'. The argument file will be tracked as a dependency.+readFile' :: FilePath -> Action String+readFile' x = need [x] >> liftIO (readFile x)++-- | Write a file, lifted to the 'Action' monad.+writeFile' :: MonadIO m => FilePath -> String -> m ()+writeFile' name x = liftIO $ writeFile name x+++-- | A version of 'readFile'' which also splits the result into lines.+--   The argument file will be tracked as a dependency.+readFileLines :: FilePath -> Action [String]+readFileLines = fmap lines . readFile'++-- | A version of 'writeFile'' which writes out a list of lines.+writeFileLines :: MonadIO m => FilePath -> [String] -> m ()+writeFileLines name = writeFile' name . unlines+++-- | Write a file, but only if the contents would change.+writeFileChanged :: MonadIO m => FilePath -> String -> m ()+writeFileChanged name x = liftIO $ do+    b <- doesFileExist name+    if not b then writeFile name x else do+        -- Cannot use ByteString here, since it has different line handling+        -- semantics on Windows+        b <- withFile name ReadMode $ \h -> do+            src <- hGetContents h+            return $! src /= x+        when b $ writeFile name x+++-- | Create a temporary file in the temporary directory. The file will be deleted+--   after the action completes (provided the file is not still open).+--   The 'FilePath' will not have any file extension, will exist, and will be zero bytes long.+--   If you require a file with a specific name, use 'withTempDir'.+withTempFile :: (FilePath -> Action a) -> Action a+withTempFile act = do+    (file, del) <- liftIO newTempFile+    act file `actionFinally` del+++-- | Create a temporary directory inside the system temporary directory.+--   The directory will be deleted after the action completes. As an example:+--+-- @+-- 'withTempDir' $ \\mydir -> do+--    'putNormal' $ \"Temp directory is \" ++ mydir+--    'writeFile'' (mydir \</\> \"test.txt\") \"writing out a temp file\"+-- @+withTempDir :: (FilePath -> Action a) -> Action a+withTempDir act = do+    (dir,del) <- liftIO newTempDir+    act dir `actionFinally` del+++-- | A 'parallel' version of 'forM'.+forP :: [a] -> (a -> Action b) -> Action [b]+forP xs f = parallel $ map f xs++-- | Execute two operations in parallel, based on 'parallel'.+par :: Action a -> Action b -> Action (a,b)+par a b = do [Left a, Right b] <- parallel [Left <$> a, Right <$> b]; return (a,b)
+ src/Development/Shake/Internal/Errors.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards, RecordWildCards, CPP #-}++-- | Errors seen by the user+module Development.Shake.Internal.Errors(+    ShakeException(..),+    errorInternal,+    errorStructured,+    errorNoRuleToBuildType, errorRuleDefinedMultipleTimes,+    errorMultipleRulesMatch, errorRuleRecursion, errorComplexRecursion, errorNoApply,+    errorDirectoryNotFile+    ) where++import Data.Tuple.Extra+import Control.Exception.Extra+import Data.Typeable+import Data.List+++errorInternal :: String -> a+errorInternal msg = error $ "Development.Shake: Internal error, please report to Neil Mitchell (" ++ msg ++ ")"++alternatives = let (*) = (,) in+    ["_rule_" * "oracle"+    ,"_Rule_" * "Oracle"+    ,"_key_" * "question"+    ,"_Key_" * "Question"+    ,"_result_" * "answer"+    ,"_Result_" * "Answer"+    ,"_addBuiltinRule_" * "addOracle"+    ,"_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 ++ ":"] +++        ["  " ++ a ++ [':' | a /= ""] ++ replicate (as - length a + 2) ' ' ++ b | (a,b) <- args2] +++        [hint | hint /= ""]+    where+        as = maximum $ 0 : map (length . fst) args2+        args2 = [(a,b) | (a,Just b) <- args]++++structured :: Bool -> String -> [(String, Maybe String)] -> String -> IO a+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 (x:xs) = x : g xs+        g [] = []+++errorDirectoryNotFile :: FilePath -> IO a+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 tk k tv = structured (specialIsOracleKey tk)+    "Build system error - no _rule_ matches the _key_ type"+    [("_Key_ type", Just $ show tk)+    ,("_Key_ value", k)+    ,("_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)+    "Build system error - _rule_ defined twice at one _key_ type"+    [("_Key_ type", Just $ show tk)]+    "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")++errorRuleRecursion :: [String] -> TypeRep -> String -> IO a+-- may involve both rules and oracle, so report as only rules+errorRuleRecursion stack tk k = throwIO $ wrap $ toException $ ErrorCall $ errorStructuredContents+    "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 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_"+    [("Reason", Just msg)+    ,("_Key_ type", Just $ show tk)+    ,("_Key_ value", k)]+    "Move the _apply_ call earlier/later"+++-- Should be in Special, but then we get an import cycle+specialIsOracleKey :: TypeRep -> Bool+specialIsOracleKey t = con == "OracleQ"+    where con = show $ fst $ splitTyConApp t+++-- | Error representing all expected exceptions thrown by Shake.+--   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.+    ,shakeExceptionInner :: SomeException -- ^ The underlying exception that was raised.+    }+    deriving Typeable++instance Exception ShakeException++instance Show ShakeException where+    show ShakeException{..} = unlines $+        "Error when running Shake build system:" :+        map ("* " ++) shakeExceptionStack +++        [displayException shakeExceptionInner]
+ src/Development/Shake/Internal/FileInfo.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, CPP, ForeignFunctionInterface #-}++module Development.Shake.Internal.FileInfo(+    FileInfo, fileInfoNoHash,+    FileSize, ModTime, FileHash,+    getFileHash, getFileInfo+    ) where++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 Data.Char+import Data.Word+import Numeric+import System.IO+import Foreign++#if defined(PORTABLE)+import System.IO.Error+import System.Directory+import Data.Time+#if __GLASGOW_HASKELL__ < 706+import System.Time+#endif++#elif defined(mingw32_HOST_OS)+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import Foreign.C.Types+import Foreign.C.String++#else+import GHC.IO.Exception+import System.IO.Error+import System.Posix.Files.ByteString+#endif++-- A piece of file information, where 0 and 1 are special (see fileInfo* functions)+newtype FileInfo a = FileInfo Word32+    deriving (Typeable,Hashable,Binary,Storable,NFData)++fileInfoNoHash :: FileInfo FileInfoHash+fileInfoNoHash = FileInfo 1   -- Equal to nothing++fileInfo :: Word32 -> FileInfo a+fileInfo a = FileInfo $ if a > maxBound - 2 then a else a + 2++instance Show (FileInfo a) where+    show (FileInfo x)+        | x == 0 = "EQ"+        | x == 1 = "NEQ"+        | otherwise = "0x" ++ map toUpper (showHex (x-2) "")++instance Eq (FileInfo a) where+    FileInfo a == FileInfo b+        | a == 0 || b == 0 = True+        | a == 1 || b == 1 = False+        | otherwise = a == b++data FileInfoHash; type FileHash = FileInfo FileInfoHash+data FileInfoMod ; type ModTime  = FileInfo FileInfoMod+data FileInfoSize; type FileSize = FileInfo FileInfoSize+++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++-- 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.+-- See this blog post: http://neilmitchell.blogspot.co.uk/2015/09/three-space-leaks.html+result :: Word32 -> Word32 -> IO (Maybe (ModTime, FileSize))+result x y = do+    x <- evaluate $ fileInfo x+    y <- evaluate $ fileInfo y+    return $ Just (x, y)+++getFileInfo :: FileName -> IO (Maybe (ModTime, FileSize))++#if defined(PORTABLE)+-- Portable fallback+getFileInfo x = handleBool isDoesNotExistError (const $ return Nothing) $ do+    let file = fileNameToString x+    time <- getModificationTime file+    size <- withFile file ReadMode hFileSize+    result (extractFileTime time) (fromIntegral size)++-- deal with difference in return type of getModificationTime between directory versions+class ExtractFileTime a where extractFileTime :: a -> Word32+#if __GLASGOW_HASKELL__ < 706+instance ExtractFileTime ClockTime where extractFileTime (TOD t _) = fromIntegral t+#endif+instance ExtractFileTime UTCTime where extractFileTime = floor . fromRational . toRational . utctDayTime+++#elif defined(mingw32_HOST_OS)+-- Directly against the Win32 API, twice as fast as the portable version+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+                 else+                    join $ liftM2 result (peekLastWriteTimeLow fad) (peekFileSizeLow fad)+        if res then+            peek+         else if BS.any (>= chr 0x80) (fileNameToByteString x) then withCWString (fileNameToString x) $ \file -> do+            res <- c_GetFileAttributesExW file 0 fad+            if res then peek else return Nothing+         else+            return Nothing++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV unsafe "Windows.h GetFileAttributesExA" c_GetFileAttributesExA :: Ptr CChar  -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool+foreign import CALLCONV unsafe "Windows.h GetFileAttributesExW" c_GetFileAttributesExW :: Ptr CWchar -> Int32 -> Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Bool++data WIN32_FILE_ATTRIBUTE_DATA++alloca_WIN32_FILE_ATTRIBUTE_DATA :: (Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO a) -> IO a+alloca_WIN32_FILE_ATTRIBUTE_DATA act = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA act+    where size_WIN32_FILE_ATTRIBUTE_DATA = 36++peekFileAttributes :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekFileAttributes p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes+    where index_WIN32_FILE_ATTRIBUTE_DATA_dwFileAttributes = 0++peekLastWriteTimeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekLastWriteTimeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+    where index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20++peekFileSizeLow :: Ptr WIN32_FILE_ATTRIBUTE_DATA -> IO Word32+peekFileSizeLow p = peekByteOff p index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow+    where index_WIN32_FILE_ATTRIBUTE_DATA_nFileSizeLow = 32+++#else+-- Unix version+getFileInfo x = handleBool isDoesNotExistError' (const $ return Nothing) $ do+    s <- getFileStatus $ fileNameToByteString x+    if isDirectory s then+        errorDirectoryNotFile $ fileNameToString x+     else+        result (extractFileTime s) (fromIntegral $ fileSize s)+    where+        isDoesNotExistError' e =+            isDoesNotExistError e || ioeGetErrorType e == InappropriateType++extractFileTime :: FileStatus -> Word32+#ifndef MIN_VERSION_unix+#define MIN_VERSION_unix(a,b,c) 0+#endif+#if MIN_VERSION_unix(2,6,0)+extractFileTime x = ceiling $ modificationTimeHiRes x * 1e4 -- precision of 0.1ms+#else+extractFileTime x = fromIntegral $ fromEnum $ modificationTime x+#endif++#endif
+ src/Development/Shake/Internal/FileName.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}++module Development.Shake.Internal.FileName(+    FileName,+    fileNameFromString, fileNameFromByteString,+    fileNameToString, fileNameToByteString,+    filepathNormalise+    ) where++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.UTF8 as UTF8+import Development.Shake.Classes+import qualified System.FilePath as Native+import General.Binary+import System.Info.Extra+import Data.List+++---------------------------------------------------------------------+-- Data.ByteString+-- Mostly because ByteString does not have an NFData instance in GHC 7.4++-- | UTF8 ByteString+newtype FileName = FileName BS.ByteString+    deriving (Hashable, Binary, BinaryEx, Eq)++instance NFData FileName where+    rnf (FileName x) = x `seq` ()++instance Show FileName where+    show = fileNameToString++instance BinaryEx [FileName] where+    putEx = putEx . map (\(FileName x) -> x)+    getEx = map FileName . getEx++fileNameToString :: FileName -> FilePath+fileNameToString = UTF8.toString . fileNameToByteString++fileNameToByteString :: FileName -> BS.ByteString+fileNameToByteString (FileName x) = x++fileNameFromString :: FilePath -> FileName+fileNameFromString = fileNameFromByteString . UTF8.fromString++fileNameFromByteString :: BS.ByteString -> FileName+fileNameFromByteString = FileName . filepathNormalise+++---------------------------------------------------------------------+-- NORMALISATION++-- | Equivalent to @toStandard . normaliseEx@ from "Development.Shake.FilePath".+filepathNormalise :: BS.ByteString -> BS.ByteString+filepathNormalise xs+    | isWindows, Just (a,xs) <- BS.uncons xs, sep a, Just (b,_) <- BS.uncons xs, sep b = '/' `BS.cons` f xs+    | otherwise = f xs+    where+        sep = Native.isPathSeparator+        f o = deslash o $ BS.concat $ (slash:) $ intersperse slash $ reverse $ (BS.empty:) $ g 0 $ reverse $ split o++        deslash o x+            | x == slash = case (pre,pos) of+                (True,True) -> slash+                (True,False) -> BS.pack "/."+                (False,True) -> BS.pack "./"+                (False,False) -> dot+            | otherwise = (if pre then id else BS.tail) $ (if pos then id else BS.init) x+            where pre = not (BS.null o) && sep (BS.head o)+                  pos = not (BS.null o) && sep (BS.last o)++        g i [] = replicate i dotDot+        g i (x:xs) | BS.null x = g i xs+        g i (x:xs) | x == dotDot = g (i+1) xs+        g i (x:xs) | x == dot = g i xs+        g 0 (x:xs) = x : g 0 xs+        g i (x:xs) = g (i-1) xs++        split = BS.splitWith sep++dotDot = BS.pack ".."+dot = BS.singleton '.'+slash = BS.singleton '/'
+ src/Development/Shake/Internal/FilePattern.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE PatternGuards, ViewPatterns #-}++module Development.Shake.Internal.FilePattern(+    -- * Primitive API, as exposed+    FilePattern, (?==), (<//>),+    -- * General API, used by other people.+    filePattern,+    -- * Optimisation opportunities+    simple,+    -- * Multipattern file rules+    compatible, extract, substitute,+    -- * Accelerated searching+    Walk(..), walk,+    -- * Testing only+    internalTest, isRelativePath, isRelativePattern+    ) where++import Development.Shake.Internal.Errors+import System.FilePath(isPathSeparator)+import Data.List.Extra+import Control.Applicative+import Control.Monad+import Data.Char+import Data.Tuple.Extra+import Data.Maybe+import System.Info.Extra+import Prelude+++-- | A type synonym for file patterns, containing @\/\/@ and @*@. For the syntax+--   and semantics of 'FilePattern' see '?=='.+--+--   Most 'normaliseEx'd 'FilePath' values are suitable as 'FilePattern' values which match+--   only that specific file. On Windows @\\@ is treated as equivalent to @\/@.+--+--   You can write 'FilePattern' values as a literal string, or build them+--   up using the operators 'Development.Shake.FilePath.<.>', 'Development.Shake.FilePath.</>'+--   and 'Development.Shake.<//>'. However, beware that:+--+-- * On Windows, use 'Development.Shake.FilePath.<.>' from "Development.Shake.FilePath" instead of from+--   "System.FilePath" - otherwise @\"\/\/*\" \<.\> exe@ results in @\"\/\/*\\\\.exe\"@.+--+-- * If the second argument of 'Development.Shake.FilePath.</>' has a leading path separator (namely @\/@)+--   then the second argument will be returned.+type FilePattern = String++infixr 5 <//>++-- | Join two 'FilePattern' values by inserting two @\/@ characters between them.+--   Will first remove any trailing path separators on the first argument, and any leading+--   separators on the second.+--+-- > "dir" <//> "*" == "dir//*"+(<//>) :: FilePattern -> FilePattern -> FilePattern+a <//> b = dropWhileEnd isPathSeparator a ++ "//" ++ dropWhile isPathSeparator b+++---------------------------------------------------------------------+-- PATTERNS++data Pat = Lit String -- ^ foo+         | Star   -- ^ /*/+         | Skip -- ^ //+         | Skip1 -- ^ //, but must be at least 1 element+         | Stars String [String] String -- ^ *foo*, prefix (fixed), infix floaters, suffix+                                        -- e.g. *foo*bar = Stars "" ["foo"] "bar"+            deriving (Show,Eq,Ord)++isLit Lit{} = True; isLit _ = False+fromLit (Lit x) = x+++data Lexeme = Str String | Slash | SlashSlash++lexer :: FilePattern -> [Lexeme]+lexer "" = []+lexer (x1:x2:xs) | isPathSeparator x1, isPathSeparator x2 = SlashSlash : lexer xs+lexer (x1:xs) | isPathSeparator x1 = Slash : lexer xs+lexer xs = Str a : lexer b+    where (a,b) = break isPathSeparator xs+++-- | Parse a FilePattern. All optimisations I can think of are invalid because they change the extracted expressions.+parse :: FilePattern -> [Pat]+parse = f False True . lexer+    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+++parseLit :: String -> Pat+parseLit "*" = Star+parseLit x = case split (== '*') x of+    [x] -> Lit x+    pre:xs | Just (mid,post) <- unsnoc xs -> Stars pre mid post+++internalTest :: IO ()+internalTest = do+    let x # y = when (parse x /= y) $ fail $ show ("FilePattern.internalTest",x,parse x,y)+    "" # [Lit ""]+    "x" # [Lit "x"]+    "/" # [Lit "",Lit ""]+    "x/" # [Lit "x",Lit ""]+    "/x" # [Lit "",Lit "x"]+    "x/y" # [Lit "x",Lit "y"]+    "//" # [Skip]+    "**" # [Skip]+    "//x" # [Skip, Lit "x"]+    "**/x" # [Skip, Lit "x"]+    "x//" # [Lit "x", Skip]+    "x/**" # [Lit "x", Skip]+    "x//y" # [Lit "x",Skip, Lit "y"]+    "x/**/y" # [Lit "x",Skip, Lit "y"]+    "///" # [Skip1, Lit ""]+    "**/**" # [Skip,Skip]+    "**/**/" # [Skip, Skip, Lit ""]+    "///x" # [Skip1, Lit "x"]+    "**/x" # [Skip, Lit "x"]+    "x///" # [Lit "x", Skip, Lit ""]+    "x/**/" # [Lit "x", Skip, Lit ""]+    "x///y" # [Lit "x",Skip, Lit "y"]+    "x/**/y" # [Lit "x",Skip, Lit "y"]+    "////" # [Skip, Skip]+    "**/**/**" # [Skip, Skip, Skip]+    "////x" # [Skip, Skip, Lit "x"]+    "x////" # [Lit "x", Skip, Skip]+    "x////y" # [Lit "x",Skip, Skip, Lit "y"]+    "**//x" # [Skip, Skip, Lit "x"]+++-- | Optimisations that may change the matched expressions+optimise :: [Pat] -> [Pat]+optimise (Skip:Skip:xs) = optimise $ Skip:xs+optimise (Skip:Star:xs) = optimise $ Skip1:xs+optimise (Star:Skip:xs) = optimise $ Skip1:xs+optimise (x:xs) = x : optimise xs+optimise [] =[]+++-- | A 'FilePattern' that will only match 'isRelativePath' values.+isRelativePattern :: FilePattern -> Bool+isRelativePattern ('*':'*':xs)+    | [] <- xs = True+    | x:xs <- xs, isPathSeparator x = True+isRelativePattern _ = False++-- | A non-absolute 'FilePath'.+isRelativePath :: FilePath -> Bool+isRelativePath (x:_) | isPathSeparator x = False+isRelativePath (x:':':_) | isWindows, isAlpha x = False+isRelativePath _ = True+++-- | Given a pattern, and a list of path components, return a list of all matches+--   (for each wildcard in order, what the wildcard matched).+match :: [Pat] -> [String] -> [[String]]+match (Skip:xs) (y:ys) = map ("":) (match xs (y:ys)) ++ match (Skip1:xs) (y:ys)+match (Skip1:xs) (y:ys) = [(y++"/"++r):rs | r:rs <- match (Skip:xs) ys]+match (Skip:xs) [] = map ("":) $ match xs []+match (Star:xs) (y:ys) = map (y:) $ match xs ys+match (Lit x:xs) (y:ys) = concat $ [match xs ys | x == y] ++ [match xs (y:ys) | x == "."]+match (x@Stars{}:xs) (y:ys) | Just rs <- matchStars x y = map (rs ++) $ match xs ys+match [] [] = [[]]+match _ _ = []+++matchOne :: Pat -> String -> Bool+matchOne (Lit x) y = x == y+matchOne x@Stars{} y = isJust $ matchStars x y+matchOne Star _ = True+++-- Only return the first (all patterns left-most) valid star matching+matchStars :: Pat -> String -> Maybe [String]+matchStars (Stars pre mid post) x = do+    x <- stripPrefix pre x+    x <- if null post then Just x else stripSuffix post x+    stripInfixes mid x+    where+        stripInfixes [] x = Just [x]+        stripInfixes (m:ms) x = do+            (a,x) <- stripInfix m x+            (a:) <$> stripInfixes ms x+++-- | Match a 'FilePattern' against a 'FilePath', There are three special forms:+--+-- * @*@ matches an entire path component, excluding any separators.+--+-- * @\/\/@ matches an arbitrary number of path components, including absolute path+--   prefixes.+--+-- * @**@ as a path component matches an arbitrary number of path components, but not+--   absolute path prefixes.+--   Currently considered experimental.+--+--   Some examples:+--+-- * @test.c@ matches @test.c@ and nothing else.+--+-- * @*.c@ matches all @.c@ files in the current directory, so @file.c@ matches,+--   but @file.h@ and @dir\/file.c@ don't.+--+-- * @\/\/*.c@ matches all @.c@ files anywhere on the filesystem,+--   so @file.c@, @dir\/file.c@, @dir1\/dir2\/file.c@ and @\/path\/to\/file.c@ all match,+--   but @file.h@ and @dir\/file.h@ don't.+--+-- * @dir\/*\/*@ matches all files one level below @dir@, so @dir\/one\/file.c@ and+--   @dir\/two\/file.h@ match, but @file.c@, @one\/dir\/file.c@, @dir\/file.h@+--   and @dir\/one\/two\/file.c@ don't.+--+--   Patterns with constructs such as @foo\/..\/bar@ will never match+--   normalised 'FilePath' values, so are unlikely to be correct.+(?==) :: FilePattern -> FilePath -> Bool+(?==) p = case optimise $ parse p of+    [x] | x == Skip || x == Skip1 -> if rp then isRelativePath else const True+    p -> let f = not . null . match p . split isPathSeparator+         in if rp then (\x -> isRelativePath x && f x) else f+    where rp = isRelativePattern p+++-- | Like '?==', but returns 'Nothing' on if there is no match, otherwise 'Just' with the list+--   of fragments matching each wildcard. For example:+--+-- @+-- 'filePattern' \"**\/*.c\" \"test.txt\" == Nothing+-- 'filePattern' \"**\/*.c\" \"foo.c\" == Just [\"",\"foo\"]+-- 'filePattern' \"**\/*.c\" \"bar\/baz\/foo.c\" == Just [\"bar\/baz/\",\"foo\"]+-- @+--+--   Note that the @**@ will often contain a trailing @\/@, and even on Windows any+--   @\\@ separators will be replaced by @\/@.+filePattern :: FilePattern -> FilePath -> Maybe [String]+filePattern p = \x -> if eq x then Just $ ex x else Nothing+    where eq = (?==) p+          ex = extract p++---------------------------------------------------------------------+-- MULTIPATTERN COMPATIBLE SUBSTITUTIONS++specials :: FilePattern -> [Pat]+specials = concatMap f . parse+    where+        f Lit{} = []+        f Star = [Star]+        f Skip = [Skip]+        f Skip1 = [Skip]+        f (Stars _ xs _) = replicate (length xs + 1) Star++-- | Is the pattern free from any * and //.+simple :: FilePattern -> Bool+simple = null . specials++-- | Do they have the same * and // counts in the same order+compatible :: [FilePattern] -> Bool+compatible [] = True+compatible (x:xs) = all ((==) (specials x) . specials) xs++-- | Extract the items that match the wildcards. The pair must match with '?=='.+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+           | otherwise -> error $ "Pattern " ++ show p ++ " does not match " ++ x ++ ", when trying to extract the FilePattern matches"+        ms:_ -> ms+++-- | Given the result of 'extract', substitute it back in to a 'compatible' pattern.+--+-- > p '?==' x ==> substitute (extract p x) p == x+substitute :: [String] -> FilePattern -> FilePath+substitute oms oxs = intercalate "/" $ concat $ snd $ mapAccumL f oms (parse oxs)+    where+        f ms (Lit x) = (ms, [x])+        f (m:ms) Star = (ms, [m])+        f (m:ms) Skip = (ms, split m)+        f (m:ms) Skip1 = (ms, split m)+        f ms (Stars pre mid post) = (ms2, [concat $ pre : zipWith (++) ms1 (mid++[post])])+            where (ms1,ms2) = splitAt (length mid + 1) ms+        f _ _ = error $ "Substitution failed into pattern " ++ show oxs ++ " with " ++ show (length oms) ++ " matches, namely " ++ show oms++        split = linesBy (== '/')+++---------------------------------------------------------------------+-- EFFICIENT PATH WALKING++-- | Given a list of files, return a list of things I can match in this directory+--   plus a list of subdirectories and walks that apply to them.+--   Use WalkTo when the list can be predicted in advance+data Walk = Walk ([String] -> ([String],[(String,Walk)]))+          | WalkTo            ([String],[(String,Walk)])++walk :: [FilePattern] -> (Bool, Walk)+walk ps = (any (\p -> isEmpty p || not (null $ match p [""])) ps2, f ps2)+    where+        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)+            | 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])+            where+                finStar = Star `elem` fin+                fin = nubOrd $ mapMaybe final ps+                nxt = groupSort $ concatMap next ps+++next :: [Pat] -> [(Pat, [Pat])]+next (Skip1:xs) = [(Star,Skip:xs)]+next (Skip:xs) = (Star,Skip:xs) : next xs+next (x:xs) = [(x,xs) | not $ null xs]+next [] = []++final :: [Pat] -> Maybe Pat+final (Skip:xs) = if isEmpty xs then Just Star else final xs+final (Skip1:xs) = if isEmpty xs then Just Star else Nothing+final (x:xs) = if isEmpty xs then Just x else Nothing+final [] = Nothing++isEmpty = all (== Skip)
+ src/Development/Shake/Internal/Options.hs view
@@ -0,0 +1,272 @@+{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}++-- | Types exposed to the user+module Development.Shake.Internal.Options(+    Progress(..), Verbosity(..), Rebuild(..), Lint(..), Change(..),+    ShakeOptions(..), shakeOptions,+    -- Internal stuff+    shakeRebuildApply, shakeAbbreviationsApply+    ) where++import Data.Data+import Data.List.Extra+import Data.Tuple.Extra+import Data.Maybe+import Data.Dynamic+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+++-- | The current assumptions made by the build system, used by 'shakeRebuild'. These options+--   allow the end user to specify that any rules run are either to be treated as clean, or as+--   dirty, regardless of what the build system thinks.+--+--   These assumptions only operate on files reached by the current 'Development.Shake.action' commands. Any+--   other files in the database are left unchanged.+data Rebuild+    = RebuildNow+        -- ^ Assume these files are dirty and require rebuilding.+        --   for benchmarking rebuild speed and for rebuilding if untracked dependencies have changed.+        --   This flag is safe, but may cause more rebuilding than necessary.+    | RebuildNormal+        -- ^ Useful to reset the rebuild status to how it was before, equivalent to passing no 'Rebuild' flags.+    | RebuildLater+        -- ^ /This assumption is unsafe, and may lead to incorrect build results in this run/.+        --   Assume these files are clean in this run, but test them normally in future runs.+{-+    | RebuildNever+        -- Add to RebuildNow: Useful to undo the results of 'RebuildNever',+        -- ^ /This assumption is unsafe, and may lead to incorrect build results in this run, and in future runs/.+        --   Assume and record that these files are clean and do not require rebuilding, provided the file+        --   has been built before. Useful if you have modified a file in some+        --   inconsequential way, such as only the comments or whitespace, and wish to avoid a rebuild.+-}+      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)+++-- | Which lint checks to perform, used by 'shakeLint'.+data Lint+    = LintBasic+        -- ^ The most basic form of linting. Checks that the current directory does not change and that results do not change after they+        --   are first written. Any calls to 'needed' will assert that they do not cause a rule to be rebuilt.+    | LintFSATrace+        -- ^ Track which files are accessed by command line programs+        -- using <https://github.com/jacereda/fsatrace fsatrace>.+      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)+++-- | How should you determine if a file has changed, used by 'shakeChange'. The most common values are+--   'ChangeModtime' (the default, very fast, @touch@ causes files to rebuild) and 'ChangeModtimeAndDigestInput'+--   (slightly slower, @touch@ and switching @git@ branches does not cause input files to rebuild).+data Change+    = ChangeModtime+        -- ^ Compare equality of modification timestamps, a file has changed if its last modified time changes.+        --   A @touch@ will force a rebuild. This mode is fast and usually sufficiently accurate, so is the default.+    | ChangeDigest+        -- ^ Compare equality of file contents digests, a file has changed if its digest changes.+        --   A @touch@ will not force a rebuild. Use this mode if modification times on your file system are unreliable.+    | ChangeModtimeAndDigest+        -- ^ A file is rebuilt if both its modification time and digest have changed. For efficiency reasons, the modification+        --   time is checked first, and if that has changed, the digest is checked.+    | ChangeModtimeAndDigestInput+        -- ^ Use 'ChangeModtimeAndDigest' for input\/source files and 'ChangeModtime' for output files.+        --   An input file is one which is a dependency but is not built by Shake as it has no+        --   matching rule and already exists on the file system.+    | ChangeModtimeOrDigest+        -- ^ A file is rebuilt if either its modification time or its digest has changed. A @touch@ will force a rebuild,+        --   but even if a files modification time is reset afterwards, changes will also cause a rebuild.+      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)+++-- | Options to control the execution of Shake, usually specified by overriding fields in+--   'shakeOptions':+--+--   @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=[\"report.html\"]} @+--+--   The 'Data' instance for this type reports the 'shakeProgress' and 'shakeOutput' fields as having the abstract type 'Hidden',+--   because 'Data' cannot be defined for functions or 'TypeRep's.+data ShakeOptions = ShakeOptions+    {shakeFiles :: FilePath+        -- ^ 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.+    ,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+        --   works well. Use @0@ to match the detected number of processors (when @0@, 'getShakeOptions' will+        --   return the number of threads used).+    ,shakeVersion :: String+        -- ^ Defaults to @"1"@. The version number of your build rules.+        --   Change the version number to force a complete rebuild, such as when making+        --   significant changes to the rules that require a wipe. The version number should be+        --   set in the source code, and not passed on the command line.+    ,shakeVerbosity :: Verbosity+        -- ^ Defaults to 'Normal'. What level of messages should be printed out.+    ,shakeStaunch :: Bool+        -- ^ Defaults to 'False'. Operate in staunch mode, where building continues even after errors,+        --   similar to @make --keep-going@.+    ,shakeReport :: [FilePath]+        -- ^ Defaults to @[]@. Write a profiling report to a file, showing which rules rebuilt,+        --   why, and how much time they took. Useful for improving the speed of your build systems.+        --   If the file extension is @.json@ it will write JSON data; if @.js@ it will write Javascript;+        --   if @.trace@ it will write trace events (load into @about:\/\/tracing@ in Chrome);+        --   otherwise it will write HTML.+    ,shakeLint :: Maybe Lint+        -- ^ Defaults to 'Nothing'. Perform sanity checks during building, see 'Lint' for details.+    ,shakeLintInside :: [FilePath]+        -- ^ Directories in which the files will be tracked by the linter.+    ,shakeLintIgnore :: [FilePattern]+        -- ^ File patterns which are ignored from linter tracking, a bit like calling 'Development.Shake.trackAllow' in every rule.+    ,shakeCommandOptions :: [CmdOption]+        -- ^ Defaults to @[]@. Additional options to be passed to all command invocations.+    ,shakeFlush :: Maybe Double+        -- ^ Defaults to @'Just' 10@. How often to flush Shake metadata files in seconds, or 'Nothing' to never flush explicitly.+        --   It is possible that on abnormal termination (not Haskell exceptions) any rules that completed in the last+        --   'shakeFlush' seconds will be lost.+    ,shakeRebuild :: [(Rebuild, FilePattern)]+        -- ^ What to rebuild+    ,shakeAbbreviations :: [(String,String)]+        -- ^ Defaults to @[]@. A list of substrings that should be abbreviated in status messages, and their corresponding abbreviation.+        --   Commonly used to replace the long paths (e.g. @.make\/i586-linux-gcc\/output@) with an abbreviation (e.g. @$OUT@).+    ,shakeStorageLog :: Bool+        -- ^ Defaults to 'False'. Write a message to @'shakeFiles'\/.shake.storage.log@ whenever a storage event happens which may impact+        --   on the current stored progress. Examples include database version number changes, database compaction or corrupt files.+    ,shakeLineBuffering :: Bool+        -- ^ Defaults to 'True'. Change 'stdout' and 'stderr' to line buffering while running Shake.+    ,shakeTimings :: Bool+        -- ^ Defaults to 'False'. Print timing information for each stage at the end.+    ,shakeRunCommands :: Bool+        -- ^ Default to 'True'. Should you run command line actions, set to 'False' to skip actions whose output streams and exit code+        --   are not used. Useful for profiling the non-command portion of the build system.+    ,shakeChange :: Change+        -- ^ Default to 'ChangeModtime'. How to check if a file has changed, see 'Change' for details.+    ,shakeCreationCheck :: Bool+        -- ^ Default to 'True'. After running a rule to create a file, is it an error if the file does not exist.+        --   Provided for compatibility with @make@ and @ninja@ (which have ugly file creation semantics).++--    ,shakeOutputCheck :: Bool+--        -- ^ Default to 'True'. If a file produced by a rule changes, should you rebuild it.+    ,shakeLiveFiles :: [FilePath]+        -- ^ Default to @[]@. After the build system completes, write a list of all files which were /live/ in that run,+        --   i.e. those which Shake checked were valid or rebuilt. Produces best answers if nothing rebuilds.+    ,shakeVersionIgnore :: Bool+        -- ^ Defaults to 'False'. Ignore any differences in 'shakeVersion'.+    ,shakeColor :: Bool+        -- ^ Defaults to 'False'. Whether to colorize the output.+    ,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.+        --   For applications that want to display progress messages, 'progressSimple' is often sufficient, but more advanced+        --   users should look at the 'Progress' data type.+    ,shakeOutput :: Verbosity -> String -> IO ()+        -- ^ Defaults to writing using 'putStrLn'. A function called to output messages from Shake, along with the 'Verbosity' at+        --   which that message should be printed. This function will be called atomically from all other 'shakeOutput' functions.+        --   The 'Verbosity' will always be greater than or higher than 'shakeVerbosity'.+    ,shakeExtra :: Map.HashMap TypeRep Dynamic+        -- ^ This a map which can be used to store arbitrary extra information that a user may need when writing rules.+        --   The key of each entry must be the 'dynTypeRep' of the value.+        --   Insert values using 'addShakeExtra' and retrieve them using 'getShakeExtra'.+        --   The correct way to use this field is to define a hidden newtype for the key, so that conflicts cannot occur.+    }+    deriving Typeable++-- | The default set of 'ShakeOptions'.+shakeOptions :: ShakeOptions+shakeOptions = ShakeOptions+    ".shake" 1 "1" Normal False [] Nothing [] [] [] (Just 10) [] [] False True False+    True ChangeModtime True [] False False+    (const $ return ())+    (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS+    Map.empty++fieldsShakeOptions =+    ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport"+    ,"shakeLint", "shakeLintInside", "shakeLintIgnore", "shakeCommandOptions"+    ,"shakeFlush", "shakeRebuild", "shakeAbbreviations", "shakeStorageLog"+    ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"+    ,"shakeLiveFiles","shakeVersionIgnore","shakeProgress", "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)++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) =+        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`+        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+    toConstr ShakeOptions{} = conShakeOptions+    dataTypeOf _ = tyShakeOptions++instance Show ShakeOptions where+    show x = "ShakeOptions {" ++ intercalate ", " inner ++ "}"+        where+            inner = zipWith (\x y -> x ++ " = " ++ y) fieldsShakeOptions $ gmapQ f x++            f x | Just x <- cast x = show (x :: Int)+                | Just x <- cast x = show (x :: FilePath)+                | Just x <- cast x = show (x :: Verbosity)+                | Just x <- cast x = show (x :: Change)+                | Just x <- cast x = show (x :: Bool)+                | Just x <- cast x = show (x :: [FilePath])+                | 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 :: [(String,String)])+                | Just x <- cast x = show (x :: Hidden (IO Progress -> IO ()))+                | Just x <- cast x = show (x :: Hidden (Verbosity -> String -> IO ()))+                | Just x <- cast x = show (x :: Hidden (Map.HashMap TypeRep Dynamic))+                | Just x <- cast x = show (x :: [CmdOption])+                | otherwise = error $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x)+++-- | Internal type, copied from Hide in Uniplate+newtype Hidden a = Hidden {fromHidden :: a}+    deriving Typeable++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"+    toConstr _ = error "Development.Shake.Types.ShakeProgress: toConstr not implemented - data type has no constructors"+    dataTypeOf _ = tyHidden++tyHidden = mkDataType "Development.Shake.Types.Hidden" []+++-- | The verbosity data type, used by 'shakeVerbosity'.+data Verbosity+    = Silent -- ^ Don't print any messages.+    | Quiet  -- ^ Only print essential messages, typically errors.+    | Normal -- ^ Print errors and @# /command-name/ (for /file-name/)@ when running a 'Development.Shake.traced' command.+    | Loud   -- ^ Print errors and full command lines when running a 'Development.Shake.command' or 'Development.Shake.cmd' command.+    | Chatty -- ^ Print errors, full command line and status messages when starting a rule.+    | Diagnostic -- ^ Print messages for virtually everything (mostly for debugging).+      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)+++-- | Apply the 'shakeRebuild' flags to a file, determining the desired behaviour+shakeRebuildApply :: ShakeOptions -> (FilePath -> Rebuild)+shakeRebuildApply ShakeOptions{shakeRebuild=rs}+    | null rs = const RebuildNormal+    | otherwise = \x -> fromMaybe RebuildNormal $ firstJust (\(r,pat) -> if pat x then Just r else Nothing) rs2+        where rs2 = map (second (?==)) $ reverse rs+++shakeAbbreviationsApply :: ShakeOptions -> String -> String+shakeAbbreviationsApply ShakeOptions{shakeAbbreviations=abbrev}+    | null abbrev = id+    | otherwise = f+        where+            -- order so longer abbreviations are preferred+            ordAbbrev = sortOn (negate . length . fst) abbrev++            f [] = []+            f x | (to,rest):_ <- [(to,rest) | (from,to) <- ordAbbrev, Just rest <- [stripPrefix from x]] = to ++ f rest+            f (x:xs) = x : f xs
+ src/Development/Shake/Internal/Profile.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE PatternGuards, RecordWildCards #-}++module Development.Shake.Internal.Profile(ProfileEntry(..), ProfileTrace(..), writeProfile) where++import General.Template+import Data.Tuple.Extra+import Data.Function+import Data.List+import Data.Version+import System.FilePath+import Numeric.Extra+import General.Extra+import Paths_shake+import System.Time.Extra+import qualified Data.ByteString.Lazy.Char8 as LBS+++data ProfileEntry = ProfileEntry+    {prfName :: String, prfBuilt :: Int, prfChanged :: Int, prfDepends :: [Int], prfExecution :: Double, prfTraces :: [ProfileTrace]}+data ProfileTrace = ProfileTrace+    {prfCommand :: String, prfStart :: Double, prfStop :: Double}+prfTime ProfileTrace{..} = prfStop - prfStart+++-- | Generates an report given some build system profiling data.+writeProfile :: FilePath -> [ProfileEntry] -> IO ()+writeProfile out xs+    | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ generateJSON xs+    | takeExtension out == ".json" = writeFile out $ generateJSON xs+    | takeExtension out == ".trace" = writeFile out $ generateTrace xs+    | out == "-" = putStr $ unlines $ generateSummary xs+    -- NOTE: On my laptop writing 1.5Mb of profile report takes 0.6s.+    --       This is fundamentals of my laptop, not a Haskell profiling issue.+    --       Verified with similar "type foo > bar" commands taking similar time.+    | otherwise = LBS.writeFile out =<< generateHTML xs+++generateSummary :: [ProfileEntry] -> [String]+generateSummary xs =+    ["* This database has tracked " ++ show (maximum (0 : map prfChanged xs) + 1) ++ " runs."+    ,let f = show . length in "* There are " ++ f xs ++ " rules (" ++ f ls ++ " rebuilt in the last run)."+    ,let f = show . sum . map (length . prfTraces) in "* Building required " ++ f xs ++ " traced commands (" ++ f ls ++ " in the last run)."+    ,"* The total (unparallelised) time is " ++ showDuration (sum $ map prfExecution xs) +++        " of which " ++ showDuration (sum $ map prfTime $ concatMap prfTraces xs) ++ " is traced commands."+    ,let f xs = if null xs then "0s" else (\(a,b) -> showDuration a ++ " (" ++ b ++ ")") $ maximumBy' (compare `on` fst) xs in+        "* The longest rule takes " ++ f (map (prfExecution &&& prfName) xs) +++        ", and the longest traced command takes " ++ f (map (prfTime &&& prfCommand) $ concatMap prfTraces xs) ++ "."+    ,let sumLast = sum $ map prfTime $ concatMap prfTraces ls+         maxStop = maximum $ 0 : map prfStop (concatMap prfTraces ls) in+        "* Last run gave an average parallelism of " ++ showDP 2 (if maxStop == 0 then 0 else sumLast / maxStop) +++        " times over " ++ showDuration maxStop ++ "."+    ]+    where ls = filter ((==) 0 . prfBuilt) xs+++generateHTML :: [ProfileEntry] -> IO LBS.ByteString+generateHTML xs = do+    htmlDir <- getDataFileName "html"+    report <- LBS.readFile $ htmlDir </> "profile.html"+    let f name | name == "profile-data.js" = return $ LBS.pack $ "var profile =\n" ++ generateJSON xs+               | name == "version.js" = return $ LBS.pack $ "var version = " ++ show (showVersion version)+               | otherwise = LBS.readFile $ htmlDir </> name+    runTemplate f report+++generateTrace :: [ProfileEntry] -> String+generateTrace xs = jsonListLines $+    showEntries 0 [y{prfCommand=prfName x} | x <- xs, y <- prfTraces x] +++    showEntries 1 (concatMap prfTraces xs)+    where+        showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortBy (compare `on` prfStart) xs+        alloc as r | (a1,an:a2) <- break (\a -> prfStop a <= prfStart r) as = (a1++r:a2, (length a1,r))+                   | otherwise = (as++[r], (length as,r))+        showEntry pid (tid, ProfileTrace{..}) = jsonObject+            [("args","{}"), ("ph",show "X"), ("cat",show "target")+            ,("name",show prfCommand), ("tid",show tid), ("pid",show pid)+            ,("ts",show $ 1000000*prfStart), ("dur",show $ 1000000*(prfStop-prfStart))]+++generateJSON :: [ProfileEntry] -> String+generateJSON = jsonListLines . map showEntry+    where+        showEntry ProfileEntry{..} = jsonObject $+            [("name", show prfName)+            ,("built", show prfBuilt)+            ,("changed", show prfChanged)+            ,("depends", show prfDepends)+            ,("execution", showDP 4 prfExecution)] +++            [("traces", jsonList $ map showTrace prfTraces) | not $ null prfTraces]+        showTrace ProfileTrace{..} = jsonObject+            [("command",show prfCommand), ("start",show prfStart), ("stop",show prfStop)]++jsonListLines xs = "[" ++ intercalate "\n," xs ++ "\n]"+jsonList xs = "[" ++ intercalate "," xs ++ "]"+jsonObject xs = "{" ++ intercalate "," [show a ++ ":" ++ b | (a,b) <- xs] ++ "}"
+ src/Development/Shake/Internal/Progress.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface #-}++-- | Progress tracking+module Development.Shake.Internal.Progress(+    Progress(..),+    progressSimple, progressDisplay, progressTitlebar, progressProgram,+    ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY+    ) where++import Control.Applicative+import Data.Tuple.Extra+import Control.Exception.Extra+import Control.Monad+import System.Environment+import System.Directory+import System.Process+import System.FilePath+import Data.Char+import Data.Data+import Data.IORef+import Data.List+import Data.Maybe+import Data.Version+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 Paths_shake+import System.Time.Extra+import Data.Monoid+import Prelude++#ifdef mingw32_HOST_OS++import Foreign+import Foreign.C.Types++#ifdef x86_64_HOST_ARCH+#define CALLCONV ccall+#else+#define CALLCONV stdcall+#endif++foreign import CALLCONV "Windows.h SetConsoleTitleA" c_setConsoleTitle :: Ptr CChar -> IO Bool++#endif+++---------------------------------------------------------------------+-- PROGRESS TYPES - exposed to the user++-- | 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 Monoid Progress where+    mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0)+    mappend 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)+        }+++---------------------------------------------------------------------+-- MEALY TYPE - for writing the progress functions+-- See <http://hackage.haskell.org/package/machines-0.2.3.1/docs/Data-Machine-Mealy.html>++-- | A machine that takes inputs and produces outputs+newtype Mealy i a = Mealy {runMealy :: i -> (a, Mealy i a)}++instance Functor (Mealy i) where+    fmap f (Mealy m) = Mealy $ \i -> case m i of+        (x, m) -> (f x, fmap f m)++instance Applicative (Mealy i) where+    pure x = let r = Mealy (const (x, r)) in r+    Mealy mf <*> Mealy mx = Mealy $ \i -> case mf i of+        (f, mf) -> case mx i of+            (x, mx) -> (f x, mf <*> mx)++echoMealy :: Mealy i i+echoMealy = Mealy $ \i -> (i, echoMealy)++scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a+scanMealy f z (Mealy m) = Mealy $ \i -> case m i of+    (x, m) -> let z2 = f z x in (z2, scanMealy f z2 m)+++---------------------------------------------------------------------+-- MEALY UTILITIES++oldMealy :: a -> Mealy i a -> Mealy i (a,a)+oldMealy old = scanMealy (\(_,old) new -> (old,new)) (old,old)++latch :: Mealy i (Bool, a) -> Mealy i a+latch s = fromJust <$> scanMealy f Nothing s+    where f old (b,v) = Just $ if b then fromMaybe v old else v++iff :: Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a+iff c t f = (\c t f -> if c then t else f) <$> c <*> t <*> f++-- decay'd division, compute a/b, with a decay of f+-- r' is the new result, r is the last result+-- r' ~= a' / b'+-- r' = r*b + f*(a'-a)+--      -------------+--      b + f*(b'-b)+-- when f == 1, r == r'+--+-- both streams must only ever increase+decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double+decay f a b = scanMealy step 0 $ (,) <$> oldMealy 0 a <*> oldMealy 0 b+    where step r ((a,a'),(b,b')) = if isNaN r then a' / b' else ((r*b) + f*(a'-a)) / (b + f*(b'-b))+++---------------------------------------------------------------------+-- MESSAGE GENERATOR++formatMessage :: Double -> Double -> String+formatMessage secs perc =+    (if isNaN secs || secs < 0 then "??s" else showMinSec $ ceiling secs) ++ " (" +++    (if isNaN perc || perc < 0 || perc > 100 then "??" else show $ floor perc) ++ "%)"++showMinSec :: Int -> String+showMinSec secs = (if m == 0 then "" else show m ++ "m" ++ ['0' | s < 10]) ++ show s ++ "s"+    where (m,s) = divMod secs 60++liftA2' :: Applicative m => m a -> m b -> (a -> b -> c) -> m c+liftA2' a b f = liftA2 f a b+++-- | return (number of seconds, percentage, explanation)+message :: Mealy (Double, Progress) (Double, Progress) -> Mealy (Double, Progress) (Double, Double, String)+message input = liftA3 (,,) time perc debug+    where+        progress = snd <$> input+        secs = fst <$> input+        debug = (\donePerSec ruleTime (todoKnown,todoUnknown) ->+            "Progress: " +++                "((known=" ++ showDP 2 todoKnown ++ "s) + " +++                "(unknown=" ++ show todoUnknown ++ " * time=" ++ showDP 2 ruleTime ++ "s)) " +++                "(rate=" ++ showDP 2 donePerSec ++ "))")+            <$> donePerSec <*> ruleTime <*> (timeTodo <$> progress)++        -- Number of seconds work completed in this build run+        -- Ignores timeSkipped which would be more truthful, but it makes the % drop sharply+        -- which isn't what users want+        done = timeBuilt <$> progress++        -- Work done per second, don't divide by 0 and don't update if 'done' doesn't change+        donePerSec = iff ((==) 0 <$> done) (pure 1) perSecStable+            where perSecStable = latch $ liftA2 (,) (uncurry (==) <$> oldMealy 0 done) perSecRaw+                  perSecRaw = decay 1.2 done secs++        -- Predicted build time for a rule that has never been built before+        -- The high decay means if a build goes in "phases" - lots of source files, then lots of compiling+        -- we reach a reasonable number fairly quickly, without bouncing too much+        ruleTime = liftA2 weightedAverage+            (f (decay 10) timeBuilt countBuilt)+            (f (liftA2 (/)) (fst . timeTodo) (\Progress{..} -> countTodo - snd timeTodo))+            -- don't call decay on todo, since it goes up and down (as things get done)+            where+                weightedAverage (w1,x1) (w2,x2)+                    | w1 == 0 && w2 == 0 = 0+                    | otherwise = ((w1 *. x1) + (w2 *. x2)) / intToDouble (w1+w2)+                    where i *. d = if i == 0 then 0 else intToDouble i * d -- since d might be NaN++                f divide time count = let xs = count <$> progress in liftA2 (,) xs $ divide (time <$> progress) (intToDouble <$> xs)++        -- Number of seconds work remaining, ignoring multiple threads+        todo = f <$> progress <*> ruleTime+            where f Progress{..} ruleTime = fst timeTodo + (fromIntegral (snd timeTodo) * ruleTime)++        -- Display information+        time = liftA2 (/) todo donePerSec+        perc = iff ((==) 0 <$> done) (pure 0) $+            liftA2' done todo $ \done todo -> 100 * done / (done + todo)+++---------------------------------------------------------------------+-- EXPOSED FUNCTIONS++-- | Given a sampling interval (in seconds) and a way to display the status message,+--   produce a function suitable for using as 'Development.Shake.shakeProgress'.+--   This function polls the progress information every /n/ seconds, produces a status+--   message and displays it using the display function.+--+--   Typical status messages will take the form of @1m25s (15%)@, indicating that the build+--   is predicted to complete in 1 minute 25 seconds (85 seconds total), and 15% of the necessary build time has elapsed.+--   This function uses past observations to predict future behaviour, and as such, is only+--   guessing. The time is likely to go up as well as down, and will be less accurate from a+--   clean build (as the system has fewer past observations).+--+--   The current implementation is to predict the time remaining (based on 'timeTodo') and the+--   work already done ('timeBuilt'). The percentage is then calculated as @remaining / (done + remaining)@,+--   while time left is calculated by scaling @remaining@ by the observed work rate in this build,+--   roughly @done / time_elapsed@.+progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()+progressDisplay sample disp prog = do+    disp "Starting..." -- no useful info at this stage+    time <- offsetTime+    catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop time $ message echoMealy) (const $ disp "Finished")+    where+        loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()+        loop time mealy = do+            sleep sample+            p <- prog+            t <- time+            ((secs,perc,debug), mealy) <- return $ runMealy mealy (t, p)+            -- putStrLn debug+            disp $ formatMessage secs perc ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)+            loop time mealy+++data ProgressEntry = ProgressEntry+    {idealSecs :: Double, idealPerc :: Double+    ,actualSecs :: Double, actualPerc :: Double+    }++isInvalid :: ProgressEntry -> Bool+isInvalid ProgressEntry{..} = isNaN actualSecs || isNaN actualPerc+++-- | Given a list of progress inputs, what would you have suggested (seconds, percentage)+progressReplay :: [(Double, Progress)] -> [ProgressEntry]+progressReplay [] = []+progressReplay ps = snd $ mapAccumL f (message echoMealy) ps+    where+        end = fst $ last ps+        f a (time,p) = (a2, ProgressEntry (end - time) (time * 100 / end) secs perc)+            where ((secs,perc,_),a2) = runMealy a (time,p)+++-- | Given a trace, display information about how well we did+writeProgressReport :: FilePath -> [(FilePath, [(Double, Progress)])] -> IO ()+writeProgressReport out (map (second progressReplay) -> xs)+    | (bad,_):_ <- filter (any isInvalid . snd) xs = errorIO $ "Progress generates NaN for " ++ bad+    | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ generateJSON xs+    | takeExtension out == ".json" = writeFile out $ generateJSON xs+    | out == "-" = putStr $ unlines $ generateSummary xs+    | otherwise = LBS.writeFile out =<< generateHTML xs+++generateSummary :: [(FilePath, [ProgressEntry])] -> [String]+generateSummary xs = flip concatMap xs $ \(file,xs) ->+    ["# " ++ file, f xs "Seconds" idealSecs actualSecs, f xs "Percent" idealPerc actualPerc]+    where+        levels = [100,90,80,50]+        f xs lbl ideal actual = lbl ++ ": " ++ intercalate ", "+            [show l ++ "% within " ++ show (ceiling $ maximum $ 0 : take ((length xs * l) `div` 100) diff) | l <- levels]+            where diff = sort [abs $ ideal x - actual x | x <- xs]+++generateHTML :: [(FilePath, [ProgressEntry])] -> IO LBS.ByteString+generateHTML xs = do+    htmlDir <- getDataFileName "html"+    report <- LBS.readFile $ htmlDir </> "progress.html"+    let f name | name == "progress-data.js" = return $ LBS.pack $ "var progress =\n" ++ generateJSON xs+               | name == "version.js" = return $ LBS.pack $ "var version = " ++ show (showVersion version)+               | otherwise = LBS.readFile $ htmlDir </> name+    runTemplate f report++generateJSON :: [(FilePath, [ProgressEntry])] -> String+generateJSON = concat . jsonList . map ((++"}") . unlines . f)+    where+        f (file,ps) =+            ("{\"name\":" ++ show (takeFileName file) ++ ", \"values\":") :+            indent (jsonList $ map g ps)++        shw = showDP 1+        g ProgressEntry{..} = jsonObject+            [("idealSecs",shw idealSecs),("idealPerc",shw idealPerc)+            ,("actualSecs",shw actualSecs),("actualPerc",shw actualPerc)]++indent = map ("  "++)+jsonList xs = zipWith (:) ('[':repeat ',') xs ++ ["]"]+jsonObject xs = "{" ++ intercalate ", " [show a ++ ":" ++ b | (a,b) <- xs] ++ "}"+++{-# NOINLINE xterm #-}+xterm :: Bool+xterm = System.IO.Unsafe.unsafePerformIO $+    -- Terminal.app uses "xterm-256color" as its env variable+    catch_ (("xterm" `isPrefixOf`) <$> getEnv "TERM") $+    \e -> return False+++-- | Set the title of the current console window to the given text. If the+--   environment variable @$TERM@ is set to @xterm@ this uses xterm escape sequences.+--   On Windows, if not detected as an xterm, this function uses the @SetConsoleTitle@ API.+progressTitlebar :: String -> IO ()+progressTitlebar x+    | xterm = BS.putStr $ BS.pack $ "\ESC]0;" ++ x ++ "\BEL"+#ifdef mingw32_HOST_OS+    | otherwise = BS.useAsCString (BS.pack x) $ \x -> c_setConsoleTitle x >> return ()+#else+    | otherwise = return ()+#endif+++-- | Call the program @shake-progress@ if it is on the @$PATH@. The program is called with+--   the following arguments:+--+-- * @--title=string@ - the string passed to @progressProgram@.+--+-- * @--state=Normal@, or one of @NoProgress@, @Normal@, or @Error@ to indicate+--   what state the progress bar should be in.+--+-- * @--value=25@ - the percent of the build that has completed, if not in @NoProgress@ state.+--+--   The program will not be called consecutively with the same @--state@ and @--value@ options.+--+--   Windows 7 or higher users can get taskbar progress notifications by placing the following+--   program in their @$PATH@: <https://github.com/ndmitchell/shake/releases>.+progressProgram :: IO (String -> IO ())+progressProgram = do+    exe <- findExecutable "shake-progress"+    case exe of+        Nothing -> return $ const $ return ()+        Just exe -> do+            ref <- newIORef Nothing+            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 ()+++-- | A simple method for displaying progress messages, suitable for using as 'Development.Shake.shakeProgress'.+--   This function writes the current progress to the titlebar every five seconds using 'progressTitlebar',+--   and calls any @shake-progress@ program on the @$PATH@ using 'progressProgram'.+progressSimple :: IO Progress -> IO ()+progressSimple p = do+    program <- progressProgram+    progressDisplay 5 (\s -> progressTitlebar s >> program s) p
+ src/Development/Shake/Internal/Resource.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE RecordWildCards, ViewPatterns #-}++module Development.Shake.Internal.Resource(+    Resource, newResourceIO, newThrottleIO, acquireResource, releaseResource+    ) where++import Data.Function+import System.IO.Unsafe+import Control.Concurrent.Extra+import Control.Exception.Extra+import Data.Tuple.Extra+import Control.Monad+import General.Bilist+import Development.Shake.Internal.Core.Pool+import System.Time.Extra+import Data.Monoid+import Prelude+++{-# NOINLINE resourceIds #-}+resourceIds :: Var Int+resourceIds = unsafePerformIO $ newVar 0++resourceId :: IO Int+resourceId = modifyVar resourceIds $ \i -> let j = i + 1 in j `seq` return (j, j)+++-- | A type representing an external resource which the build system should respect. There+--   are two ways to create 'Resource's in Shake:+--+-- * 'Development.Shake.newResource' creates a finite resource, stopping too many actions running+--   simultaneously.+--+-- * 'Development.Shake.newThrottle' creates a throttled resource, stopping too many actions running+--   over a short time period.+--+--   These resources are used with 'Development.Shake.withResource' when defining rules. Typically only+--   system commands (such as 'Development.Shake.cmd') should be run inside 'Development.Shake.withResource',+--   not commands such as 'Development.Shake.need'.+--+--   Be careful that the actions run within 'Development.Shake.withResource' do not themselves require further+--   resources, or you may get a \"thread blocked indefinitely in an MVar operation\" exception.+--   If an action requires multiple resources, use 'Development.Shake.withResources' to avoid deadlock.+data Resource = Resource+    {resourceOrd :: Int+        -- ^ 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 ()+        -- ^ Acquire the resource and call the function.+    ,releaseResource :: Pool -> Int -> IO ()+        -- ^ You should only ever releaseResource that you obtained with acquireResource.+    }++instance Show Resource where show = resourceShow+instance Eq Resource where (==) = (==) `on` resourceOrd+instance Ord Resource where compare = compare `on` resourceOrd+++---------------------------------------------------------------------+-- FINITE RESOURCES++data Finite = Finite+    {finiteAvailable :: !Int+        -- ^ number of currently available resources+    ,finiteWaiting :: Bilist (Int, IO ())+        -- ^ queue of people with how much they want and the action when it is allocated to them+    }++-- | A version of 'Development.Shake.newResource' that runs in IO, and can be called before calling 'Development.Shake.shake'.+--   Most people should use 'Development.Shake.newResource' instead.+newResourceIO :: String -> Int -> IO Resource+newResourceIO name mx = do+    when (mx < 0) $+        errorIO $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx+    key <- resourceId+    var <- newVar $ Finite mx mempty+    return $ Resource (negate key) shw (acquire var) (release var)+    where+        shw = "Resource " ++ name++        acquire :: Var Finite -> Pool -> Int -> IO () -> IO ()+        acquire var pool want continue+            | 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 $+                if want <= finiteAvailable then+                    (x{finiteAvailable = finiteAvailable - want}, continue)+                else+                    (x{finiteWaiting = finiteWaiting `snoc` (want, addPoolMediumPriority pool continue)}, return ())++        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+                    | otherwise = first (add (wi,wa)) $ f $ Finite i ws+                f (Finite i _) = (Finite i mempty, return ())+                add a s = s{finiteWaiting = a `cons` finiteWaiting s}+++---------------------------------------------------------------------+-- THROTTLE RESOURCES+++-- call a function after a certain delay+waiter :: Seconds -> IO () -> IO ()+waiter period act = void $ forkIO $ do+    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+    addPoolMediumPriority pool $ do+        cancel <- increasePool pool+        waitBarrier bar+        cancel+    return $ signalBarrier bar ()+++data Throttle+      -- | Some number of resources are available+    = ThrottleAvailable !Int+      -- | Some users are blocked (non-empty), plus an action to call once we go back to Available+    | ThrottleWaiting (IO ()) (Bilist (Int, IO ()))+++-- | A version of 'Development.Shake.newThrottle' that runs in IO, and can be called before calling 'Development.Shake.shake'.+--   Most people should use 'Development.Shake.newThrottle' instead.+newThrottleIO :: String -> Int -> Double -> IO Resource+newThrottleIO name count period = do+    when (count < 0) $+        errorIO $ "You cannot create a throttle named " ++ name ++ " with a negative quantity, you used " ++ show count+    key <- resourceId+    var <- newVar $ ThrottleAvailable count+    return $ Resource key shw (acquire var) (release var)+    where+        shw = "Throttle " ++ name++        acquire :: Var Throttle -> Pool -> Int -> IO () -> IO ()+        acquire var pool want continue+            | 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+                ThrottleAvailable i+                    | i >= want -> return (ThrottleAvailable $ i - want, continue)+                    | otherwise -> do+                        stop <- blockPool pool+                        return (ThrottleWaiting stop $ (want - i, addPoolMediumPriority pool continue) `cons` mempty, return ())+                ThrottleWaiting stop xs -> return (ThrottleWaiting stop $ xs `snoc` (want, addPoolMediumPriority pool continue), return ())++        release :: Var Throttle -> Pool -> Int -> IO ()+        release var pool n = waiter period $ join $ modifyVar var $ \x -> return $ case x of+                ThrottleAvailable i -> (ThrottleAvailable $ i+n, return ())+                ThrottleWaiting stop xs -> f stop n xs+            where+                f stop i (uncons -> Just ((wi,wa),ws))+                    | i >= wi = second (wa >>) $ f stop (i-wi) ws+                    | otherwise = (ThrottleWaiting stop $ (wi-i,wa) `cons` ws, return ())+                f stop i _ = (ThrottleAvailable i, stop)
+ src/Development/Shake/Internal/Rules/Directory.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies, ConstraintKinds #-}++-- | Both System.Directory and System.Environment wrappers+module Development.Shake.Internal.Rules.Directory(+    doesFileExist, doesDirectoryExist,+    getDirectoryContents, getDirectoryFiles, getDirectoryDirs,+    getEnv, getEnvWithDefault,+    removeFiles, removeFilesAfter,+    getDirectoryFilesIO,+    defaultRuleDirectory+    ) where++import Control.Applicative+import Control.Exception as C+import Control.Monad.Extra+import Control.Monad.IO.Class+import Data.Maybe+import Data.Binary+import Data.List+import Data.Tuple.Extra+import qualified Data.HashSet as Set+import qualified System.Directory as IO+import qualified System.Environment.Extra as IO++import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Value+import Development.Shake.Classes+import Development.Shake.FilePath+import Development.Shake.Internal.FilePattern+import General.Extra+import General.Binary+import Prelude+++---------------------------------------------------------------------+-- KEY/VALUE TYPES++type instance RuleResult DoesFileExistQ = DoesFileExistA++newtype DoesFileExistQ = DoesFileExistQ FilePath+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show DoesFileExistQ where+    show (DoesFileExistQ a) = "doesFileExist " ++ wrapQuote a++newtype DoesFileExistA = DoesFileExistA {fromDoesFileExistA :: Bool}+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show DoesFileExistA where+    show (DoesFileExistA a) = show a++type instance RuleResult DoesDirectoryExistQ = DoesDirectoryExistA++newtype DoesDirectoryExistQ = DoesDirectoryExistQ FilePath+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show DoesDirectoryExistQ where+    show (DoesDirectoryExistQ a) = "doesDirectoryExist " ++ wrapQuote a++newtype DoesDirectoryExistA = DoesDirectoryExistA {fromDoesDirectoryExistA :: Bool}+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show DoesDirectoryExistA where+    show (DoesDirectoryExistA a) = show a+++type instance RuleResult GetEnvQ = GetEnvA++newtype GetEnvQ = GetEnvQ String+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show GetEnvQ where+    show (GetEnvQ a) = "getEnv " ++ wrapQuote a++newtype GetEnvA = GetEnvA {fromGetEnvA :: Maybe String}+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show GetEnvA where+    show (GetEnvA a) = maybe "<unset>" wrapQuote a+++type instance RuleResult GetDirectoryContentsQ = GetDirectoryA+type instance RuleResult GetDirectoryFilesQ = GetDirectoryA+type instance RuleResult GetDirectoryDirsQ = GetDirectoryA++newtype GetDirectoryContentsQ = GetDirectoryContentsQ FilePath+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show GetDirectoryContentsQ where+    show (GetDirectoryContentsQ dir) = "getDirectoryContents " ++ wrapQuote dir++newtype GetDirectoryFilesQ = GetDirectoryFilesQ (FilePath, [FilePattern])+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show GetDirectoryFilesQ where+    show (GetDirectoryFilesQ (dir, pat)) = "getDirectoryFiles " ++ wrapQuote dir ++ " [" ++ unwords (map wrapQuote pat) ++ "]"++newtype GetDirectoryDirsQ = GetDirectoryDirsQ FilePath+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show GetDirectoryDirsQ where+    show (GetDirectoryDirsQ dir) = "getDirectoryDirs " ++ wrapQuote dir++newtype GetDirectoryA = GetDirectoryA {fromGetDirectoryA :: [FilePath]}+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show GetDirectoryA where+    show (GetDirectoryA xs) = unwords $ map wrapQuote xs+++---------------------------------------------------------------------+-- RULE DEFINITIONS++queryRule :: (RuleResult key ~ value, BinaryEx key, BinaryEx witness, Eq witness, ShakeValue key, ShakeValue value)+          => (value -> witness) -> (key -> IO value) -> Rules ()+queryRule witness query = addBuiltinRuleEx+    (\k old -> do+        new <- query k+        return $ if old == new then Nothing else Just $ show new)+    (\k old _ -> liftIO $ do+        new <- query k+        let wnew = witness new+        return $ case old of+            Just old | wnew == getEx old -> RunResult ChangedNothing old new+            _ -> RunResult ChangedRecomputeDiff (runBuilder $ putEx wnew) new)+++defaultRuleDirectory :: Rules ()+defaultRuleDirectory = do+    -- for things we are always going to rerun, and which might take up a lot of memory to store,+    -- we only store their hash, so we can compute change, but not know what changed happened+    queryRule id (\(DoesFileExistQ x) -> DoesFileExistA <$> IO.doesFileExist x)+    queryRule id (\(DoesDirectoryExistQ x) -> DoesDirectoryExistA <$> IO.doesDirectoryExist x)+    queryRule hash (\(GetEnvQ x) -> GetEnvA <$> IO.lookupEnv x)+    queryRule hash (\(GetDirectoryContentsQ x) -> GetDirectoryA <$> getDirectoryContentsIO x)+    queryRule hash (\(GetDirectoryFilesQ (a,b)) -> GetDirectoryA <$> getDirectoryFilesIO a b)+    queryRule hash (\(GetDirectoryDirsQ x) -> GetDirectoryA <$> getDirectoryDirsIO x)+++---------------------------------------------------------------------+-- RULE ENTRY POINTS++-- | Returns 'True' if the file exists. The existence of the file is tracked as a+--   dependency, and if the file is created or deleted the rule will rerun in subsequent builds.+--+--   You should not call 'doesFileExist' on files which can be created by the build system.+doesFileExist :: FilePath -> Action Bool+doesFileExist = fmap fromDoesFileExistA . apply1 . DoesFileExistQ . toStandard++-- | Returns 'True' if the directory exists. The existence of the directory is tracked as a+--   dependency, and if the directory is created or delete the rule will rerun in subsequent builds.+--+--   You should not call 'doesDirectoryExist' on directories which can be created by the build system.+doesDirectoryExist :: FilePath -> Action Bool+doesDirectoryExist = fmap fromDoesDirectoryExistA . apply1 . DoesDirectoryExistQ . toStandard++-- | Return 'Just' the value of the environment variable, or 'Nothing'+--   if the variable is not set. The environment variable is tracked as a+--   dependency, and if it changes the rule will rerun in subsequent builds.+--   This function is a tracked version of 'getEnv' / 'lookupEnv' from the base library.+--+-- @+-- flags <- getEnv \"CFLAGS\"+-- 'cmd' \"gcc -c\" [out] (maybe [] words flags)+-- @+getEnv :: String -> Action (Maybe String)+getEnv = fmap fromGetEnvA . apply1 . GetEnvQ++-- | Return the value of the environment variable (second argument), or the+--   default value (first argument) if it is not set. Similar to 'getEnv'.+--+-- @+-- flags <- getEnvWithDefault \"-Wall\" \"CFLAGS\"+-- 'cmd' \"gcc -c\" [out] flags+-- @+getEnvWithDefault :: String -> String -> Action String+getEnvWithDefault def var = fromMaybe def <$> getEnv var++-- | Get the contents of a directory. The result will be sorted, and will not contain+--   the entries @.@ or @..@ (unlike the standard Haskell version). The resulting paths will be relative+--   to the first argument. The result is tracked as a+--   dependency, and if it changes the rule will rerun in subsequent builds.+--+--   It is usually simpler to call either 'getDirectoryFiles' or 'getDirectoryDirs'.+getDirectoryContents :: FilePath -> Action [FilePath]+getDirectoryContents = fmap fromGetDirectoryA . apply1 . GetDirectoryContentsQ++-- | Get the files anywhere under a directory that match any of a set of patterns.+--   For the interpretation of the patterns see '?=='. All results will be+--   relative to the directory argument. The result is tracked as a+--   dependency, and if it changes the rule will rerun in subsequent builds.+--   Some examples:+--+-- > getDirectoryFiles "Config" ["//*.xml"]+-- >     -- All .xml files anywhere under the Config directory+-- >     -- If Config/foo/bar.xml exists it will return ["foo/bar.xml"]+-- > getDirectoryFiles "Modules" ["*.hs","*.lhs"]+-- >     -- All .hs or .lhs in the Modules directory+-- >     -- If Modules/foo.hs and Modules/foo.lhs exist, it will return ["foo.hs","foo.lhs"]+--+--   If you require a qualified file name it is often easier to use @\"\"@ as the 'FilePath' argument,+--   for example the following two expressions are equivalent:+--+-- > fmap (map ("Config" </>)) (getDirectoryFiles "Config" ["//*.xml"])+-- > getDirectoryFiles "" ["Config//*.xml"]+--+--   If the first argument directory does not exist it will raise an error.+--   If @foo@ does not exist, then the first of these error, but the second will not.+--+-- > getDirectoryFiles "foo" ["//*"] -- error+-- > getDirectoryFiles "" ["foo//*"] -- returns []+--+--   This function is tracked and serves as a dependency. If a rule calls+--   @getDirectoryFiles \"\" [\"*.c\"]@ and someone adds @foo.c@ to the+--   directory, that rule will rebuild. If someone changes one of the @.c@ files,+--   but the /list/ of @.c@ files doesn't change, then it will not rebuild.+--   As a consequence of being tracked, if the contents change during the build+--   (e.g. you are generating @.c@ files in this directory) then the build not reach+--   a stable point, which is an error - detected by running with @--lint@.+--   You should normally only call this function returning source files.+--+--   For an untracked variant see 'getDirectoryFilesIO'.+getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath]+getDirectoryFiles dir pat = fmap fromGetDirectoryA $ apply1 $ GetDirectoryFilesQ (dir,pat)++-- | Get the directories in a directory, not including @.@ or @..@.+--   All directories are relative to the argument directory. The result is tracked as a+--   dependency, and if it changes the rule will rerun in subsequent builds.+--   The rules about creating entries described in 'getDirectoryFiles' also apply here.+--+-- > getDirectoryDirs "/Users"+-- >    -- Return all directories in the /Users directory+-- >    -- e.g. ["Emily","Henry","Neil"]+getDirectoryDirs :: FilePath -> Action [FilePath]+getDirectoryDirs = fmap fromGetDirectoryA . apply1 . GetDirectoryDirsQ+++---------------------------------------------------------------------+-- IO ROUTINES++getDirectoryContentsIO :: FilePath -> IO [FilePath]+-- getDirectoryContents "" is equivalent to getDirectoryContents "." on Windows,+-- but raises an error on Linux. We smooth out the difference.+getDirectoryContentsIO dir = fmap (sort . filter (not . all (== '.'))) $ IO.getDirectoryContents $ if dir == "" then "." else dir+++getDirectoryDirsIO :: FilePath -> IO [FilePath]+getDirectoryDirsIO dir = filterM f =<< getDirectoryContentsIO dir+    where f x = IO.doesDirectoryExist $ dir </> x+++-- | A version of 'getDirectoryFiles' that is in IO, and thus untracked.+getDirectoryFilesIO :: FilePath -> [FilePattern] -> IO [FilePath]+-- Known infelicity: on Windows, if you search for "foo", but have the file "FOO",+-- it will match if on its own, or not if it is paired with "*", since that forces+-- a full directory scan, and then it uses Haskell equality (case sensitive)+getDirectoryFilesIO root pat = f "" $ snd $ walk pat+    where+        -- Even after we know they are there because we called contents, we still have to check they are directories/files+        -- as required+        f dir (Walk op) = f dir . WalkTo . op =<< getDirectoryContentsIO (root </> dir)+        f dir (WalkTo (files, dirs)) = do+            files <- filterM (IO.doesFileExist . (root </>)) $ map (dir </>) files+            dirs <- concatMapM (uncurry f) =<< filterM (IO.doesDirectoryExist . (root </>) . fst) (map (first (dir </>)) dirs)+            return $ files ++ dirs+++---------------------------------------------------------------------+-- REMOVE UTILITIES++-- | Remove all files and directories that match any of the patterns within a directory.+--   Some examples:+--+-- @+-- 'removeFiles' \"output\" [\"\/\/*\"]        -- delete everything inside \'output\'+-- 'removeFiles' \"output\" [\"\/\/\"]         -- delete \'output\' itself+-- 'removeFiles' \".\" [\"\/\/*.hi\",\"\/\/*.o\"] -- delete all \'.hi\' and \'.o\' files+-- @+--+--   If the argument directory is missing no error is raised.+--   This function will follow symlinks, so should be used with care.+--+--   This function is often useful when writing a @clean@ action for your build system,+--   often as a 'phony' rule.+removeFiles :: FilePath -> [FilePattern] -> IO ()+removeFiles dir pat =+    whenM (IO.doesDirectoryExist dir) $ do+        let (b,w) = walk pat+        if b then removeDir dir else f dir w+    where+        f dir (Walk op) = f dir . WalkTo . op =<< getDirectoryContentsIO dir+        f dir (WalkTo (files, dirs)) = do+            forM_ files $ \fil ->+                try $ removeItem $ dir </> fil :: IO (Either IOException ())+            let done = Set.fromList files+            forM_ (filter (not . flip Set.member done . fst) dirs) $ \(d,w) -> do+                let dir2 = dir </> d+                whenM (IO.doesDirectoryExist dir2) $ f dir2 w++        removeItem :: FilePath -> IO ()+        removeItem x = IO.removeFile x `C.catch` \(_ :: IOException) -> removeDir x++        -- In newer GHC's removeDirectoryRecursive is probably better, but doesn't follow+        -- symlinks, so it's got different behaviour+        removeDir :: FilePath -> IO ()+        removeDir x = do+            mapM_ (removeItem . (x </>)) =<< getDirectoryContentsIO x+            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.+removeFilesAfter :: FilePath -> [FilePattern] -> Action ()+removeFilesAfter a b = do+    putLoud $ "Will remove " ++ unwords b ++ " from " ++ a+    runAfter $ removeFiles a b
+ src/Development/Shake/Internal/Rules/File.hs view
@@ -0,0 +1,477 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns, RecordWildCards, FlexibleInstances, TypeFamilies #-}++module Development.Shake.Internal.Rules.File(+    need, needBS, needed, neededBS, want,+    trackRead, trackWrite, trackAllow,+    defaultRuleFile,+    (%>), (|%>), (?>), phony, (~>), phonys,+    -- * Internal only+    FileQ(..), FileA, fileStoredValue, fileEqualValue, EqualCost(..), fileForward+    ) where++import Control.Applicative+import Control.Monad.Extra+import Control.Monad.IO.Class+import System.Directory+import Data.Typeable+import Data.List+import Data.Bits+import Data.Maybe+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashSet as Set+import Foreign.Storable+import Data.Word+import Data.Monoid+import General.Binary++import Development.Shake.Internal.Core.Types+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.FileName+import Development.Shake.Internal.Rules.Rerun+import Development.Shake.Classes+import Development.Shake.FilePath(toStandard)+import Development.Shake.Internal.FilePattern+import Development.Shake.Internal.FileInfo+import Development.Shake.Internal.Options+import Development.Shake.Internal.Errors++import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong+import System.IO.Unsafe(unsafeInterleaveIO)+++infix 1 %>, ?>, |%>, ~>++---------------------------------------------------------------------+-- TYPES++type instance RuleResult FileQ = Maybe FileA++-- | The unique key we use to index File rules, to avoid name clashes.+newtype FileQ = FileQ {fromFileQ :: FileName}+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++-- | Raw information about a file.+data FileA = FileA {-# UNPACK #-} !ModTime {-# UNPACK #-} !FileSize FileHash+    deriving (Typeable,Eq)++-- | The types of file rule that occur.+data Mode+    = ModePhony (Action ()) -- ^ An action with no file value+    | ModeDirect (Action ()) -- ^ An action that produces this file+    | ModeForward (Action FileA) -- ^ An action that looks up a file someone else produced++-- | The results of the various 'Mode' rules.+data Result+    = ResultPhony+    | ResultDirect FileA+    | ResultForward FileA++-- | The use rules we use.+newtype FileRule = FileRule (FilePath -> Maybe Mode)+    deriving Typeable+++---------------------------------------------------------------------+-- INSTANCES++instance Show FileQ where show (FileQ x) = fileNameToString x++instance BinaryEx [FileQ] where+    putEx = putEx . map fromFileQ+    getEx = map FileQ . getEx++instance Hashable FileA where+    hashWithSalt salt (FileA a b c) = hashWithSalt salt a `xor` hashWithSalt salt b `xor` hashWithSalt salt c++instance NFData FileA where+    rnf (FileA a b c) = rnf a `seq` rnf b `seq` rnf c++instance Binary FileA where+    put (FileA a b c) = put a >> put b >> put c+    get = liftA3 FileA get get get++instance Show FileA where+    show (FileA m s h) = "File {mod=" ++ show m ++ ",size=" ++ show s ++ ",digest=" ++ show h ++ "}"++instance Storable FileA where+    sizeOf _ = 4 * 3 -- 4 Word32's+    alignment _ = alignment (undefined :: ModTime)+    peekByteOff p i = FileA <$> peekByteOff p i <*> peekByteOff p (i+4) <*> peekByteOff p (i+8)+    pokeByteOff p i (FileA a b c) = pokeByteOff p i a >> pokeByteOff p (i+4) b >> pokeByteOff p (i+8) c++instance BinaryEx FileA where+    putEx = putExStorable+    getEx = getExStorable++instance BinaryEx [FileA] where+    putEx = putExStorableList+    getEx = getExStorableList++fromResult :: Result -> Maybe FileA+fromResult ResultPhony = Nothing+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++    getEx x = case BS.length x of+        0 -> ResultPhony+        12 -> ResultDirect $ getEx x+        13 -> ResultForward $ getEx $ BS.tail x+++---------------------------------------------------------------------+-- FILE CHECK QUERIES++-- | An equality check and a cost.+data EqualCost+    = EqualCheap -- ^ The equality check was cheap.+    | EqualExpensive -- ^ The equality check was expensive, as the results are not trivially equal.+    | NotEqual -- ^ The values are not equal.+      deriving (Eq,Ord,Show,Read,Typeable,Enum,Bounded)++fileStoredValue :: ShakeOptions -> FileQ -> IO (Maybe FileA)+fileStoredValue ShakeOptions{shakeChange=c} (FileQ x) = do+    res <- getFileInfo x+    case res of+        Nothing -> return Nothing+        Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size fileInfoNoHash+        Just (time,size) -> do+            hash <- unsafeInterleaveIO $ getFileHash x+            return $ Just $ FileA time size hash+++fileEqualValue :: ShakeOptions -> FileA -> FileA -> EqualCost+fileEqualValue ShakeOptions{shakeChange=c} (FileA x1 x2 x3) (FileA y1 y2 y3) = case c of+    ChangeModtime -> bool $ x1 == y1+    ChangeDigest -> bool $ x2 == y2 && x3 == y3+    ChangeModtimeOrDigest -> bool $ x1 == y1 && x2 == y2 && x3 == y3+    _ | x1 == y1 -> EqualCheap+      | x2 == y2 && x3 == y3 -> EqualExpensive+      | otherwise -> NotEqual+    where bool b = if b then EqualCheap else NotEqual+++-- | Arguments: options; is the file an input; a message for failure if the file does not exist; filename+storedValueError :: ShakeOptions -> Bool -> String -> FileQ -> IO (Maybe FileA)+{-+storedValueError opts False msg x | False && not (shakeOutputCheck opts) = do+    when (shakeCreationCheck opts) $ do+        whenM (isNothing <$> (storedValue opts x :: IO (Maybe FileA))) $ error $ msg ++ "\n  " ++ unpackU (fromFileQ x)+    return $ FileA fileInfoEq fileInfoEq fileInfoEq+-}+storedValueError opts input msg x = maybe def Just <$> fileStoredValue opts2 x+    where def = if shakeCreationCheck opts || input then error err else Nothing+          err = msg ++ "\n  " ++ fileNameToString (fromFileQ x)+          opts2 = if not input && shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts+++---------------------------------------------------------------------+-- THE DEFAULT RULE++defaultRuleFile :: Rules ()+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)++ruleLint :: ShakeOptions -> BuiltinLint FileQ (Maybe FileA) +ruleLint opts k Nothing = return Nothing+ruleLint opts k (Just v) = do+    now <- fileStoredValue opts k+    return $ case now of+        Nothing -> Just "<missing>"+        Just now | fileEqualValue opts v now == EqualCheap -> Nothing+                 | otherwise -> Just $ show now++ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FileQ (Maybe FileA)+ruleRun opts@ShakeOptions{..} rebuildFlags o@(FileQ x) oldBin@(fmap getEx -> old) dirtyChildren = do+    -- for One, rebuild makes perfect sense+    -- for Forward, we expect the child will have already rebuilt - Rebuild just lets us deal with code changes+    -- for Phony, it doesn't make that much sense, but probably isn't harmful?+    let r = rebuildFlags $ fileNameToString x+    case old of+        _ | r == RebuildNow -> rebuild+        _ | r == RebuildLater -> case old of+            Just old ->+                -- ignoring the currently stored value, which may trigger lint has changed+                -- so disable lint on this file+                unLint <$> retOld ChangedNothing+            Nothing -> do+                -- i don't have a previous value, so assume this is a source node, and mark rebuild in future+                now <- liftIO $ fileStoredValue opts o+                case now of+                    Nothing -> rebuild+                    Just now -> do alwaysRerun; retNew ChangedStore $ ResultDirect now+        {-+        _ | r == RebuildNever -> do+            now <- liftIO $ fileStoredValue opts o+            case now of+                Nothing -> rebuild+                Just now -> do+                    let diff | Just (ResultDirect old) <- old, fileEqualValue opts old now /= NotEqual = ChangedRecomputeSame+                                | otherwise = ChangedRecomputeDiff+                    retNew diff $ ResultDirect now+        -}+        Just (ResultDirect old) | not dirtyChildren -> do+            now <- liftIO $ fileStoredValue opts o+            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+        _ -> 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 _) = RunResult a b Nothing++        retNew :: RunChanged -> Result -> Action (RunResult (Maybe FileA))+        retNew c v = return $ RunResult c (runBuilder $ putEx v) (asLint v)++        retOld :: RunChanged -> Action (RunResult (Maybe FileA))+        retOld c = return $ RunResult c (fromJust oldBin) $ asLint $ fromJust old++        -- 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)+            let answer ctor new = do+                    let b = case () of+                                _ | Just old <- old+                                    , Just old <- fromResult old+                                    , fileEqualValue opts old new /= NotEqual -> ChangedRecomputeSame+                                _ -> ChangedRecomputeDiff+                    retNew b $ ctor new+            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) ->+                    answer ResultForward =<< act+                Just (ModeDirect act) -> do+                    act+                    new <- liftIO $ storedValueError opts False "Error, rule failed to build file:" o+                    case new of+                        Nothing -> retNew ChangedRecomputeDiff ResultPhony+                        Just new -> answer ResultDirect new+                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,+                    -- so insert a fake dependency that cuts the process dead.+                    alwaysRerun+                    act+                    retNew ChangedRecomputeDiff ResultPhony+++apply_ :: (a -> FileName) -> [a] -> Action [Maybe FileA]+apply_ f = apply . map (FileQ . f)+++---------------------------------------------------------------------+-- OPTIONS ON TOP++-- | Internal method for adding forwarding actions+fileForward :: (FilePath -> Maybe (Action FileA)) -> Rules ()+fileForward act = addUserRule $ FileRule $ fmap ModeForward . act +++-- | Add a dependency on the file arguments, ensuring they are built before continuing.+--   The file arguments may be built in parallel, in any order. This function is particularly+--   necessary when calling 'Development.Shake.cmd' or 'Development.Shake.command'. As an example:+--+-- @+-- \"\/\/*.rot13\" '%>' \\out -> do+--     let src = 'Development.Shake.FilePath.dropExtension' out+--     'need' [src]+--     'Development.Shake.cmd' \"rot13\" [src] \"-o\" [out]+-- @+--+--   Usually @need [foo,bar]@ is preferable to @need [foo] >> need [bar]@ as the former allows greater+--   parallelism, while the latter requires @foo@ to finish building before starting to build @bar@.+--+--   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++needBS :: [BS.ByteString] -> Action ()+needBS = void . apply_ fileNameFromByteString+++-- | Like 'need', but if 'shakeLint' is set, check that the file does not rebuild.+--   Used for adding dependencies on files that have already been used in this rule.+needed :: [FilePath] -> Action ()+needed xs = do+    opts <- getShakeOptions+    if isNothing $ shakeLint opts then need xs else neededCheck $ map fileNameFromString xs+++neededBS :: [BS.ByteString] -> Action ()+neededBS xs = do+    opts <- getShakeOptions+    if isNothing $ shakeLint opts then needBS xs else neededCheck $ map fileNameFromByteString xs+++neededCheck :: [FileName] -> Action ()+neededCheck xs = 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, Just b) <- zip3 xs pre post, maybe NotEqual (\a -> fileEqualValue opts a b) a == NotEqual]+    case bad of+        [] -> return ()+        (file,msg):_ -> liftIO $ errorStructured+            "Lint checking error - 'needed' file required rebuilding"+            [("File", Just $ fileNameToString file)+            ,("Error",Just msg)]+            ""+++-- | Track that a file was read by the action preceeding it. If 'shakeLint' is activated+--   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)++-- | 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)++-- | 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+++-- | Require that the argument files are built by the rules, used to specify the target.+--+-- @+-- main = 'Development.Shake.shake' 'shakeOptions' $ do+--    'want' [\"Main.exe\"]+--    ...+-- @+--+--   This program will build @Main.exe@, given sufficient rules. All arguments to all 'want' calls+--   may be built in parallel, in any order.+--+--   This function is defined in terms of 'action' and 'need', use 'action' if you need more complex+--   targets than 'want' allows.+want :: [FilePath] -> Rules ()+want [] = return ()+want xs = 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+    liftIO $ createDirectoryIfMissing True $ takeDirectory x+    act x+++-- | Declare a Make-style phony action.  A phony target does not name+--   a file (despite living in the same namespace as file rules);+--   rather, it names some action to be executed when explicitly+--   requested.  You can demand 'phony' rules using 'want'. (And 'need',+--   although that's not recommended.)+--+--   Phony actions are intended to define recipes that can be executed+--   by the user. If you 'need' a phony action in a rule then every+--   execution where that rule is required will rerun both the rule and+--   the phony action.  However, note that phony actions are never+--   executed more than once in a single build run.+--+--   In make, the @.PHONY@ attribute on non-file-producing rules has a+--   similar effect.  However, while in make it is acceptable to omit+--   the @.PHONY@ attribute as long as you don't create the file in+--   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++-- | 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++-- | Infix operator alias for 'phony', for sake of consistency with normal+--   rules.+(~>) :: String -> Action () -> Rules ()+(~>) = phony+++-- | Define a rule to build files. If the first argument returns 'True' for a given file,+--   the second argument will be used to build it. Usually '%>' is sufficient, but '?>' gives+--   additional power. For any file used by the build system, only one rule should return 'True'.+--   This function will create the directory for the result file, if necessary.+--+-- @+-- (all isUpper . 'Development.Shake.FilePath.takeBaseName') '?>' \\out -> do+--     let src = 'Development.Shake.FilePath.replaceBaseName' out $ map toLower $ takeBaseName out+--     'Development.Shake.writeFile'' out . map toUpper =<< 'Development.Shake.readFile'' src+-- @+--+--   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+++-- | Define a set of patterns, and if any of them match, run the associated rule. Defined in terms of '%>'.+--   Think of it as the OR (@||@) equivalent of '%>'.+(|%>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()+(|%>) pats act = do+    let (simp,other) = partition simple pats+    case 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+    unless (null other) $+        let ps = map (?==) other in priority 0.5 $ root "with |%>" (\x -> any ($ x) ps) act++-- | Define a rule that matches a 'FilePattern', see '?==' for the pattern rules.+--   Patterns with no wildcards have higher priority than those with wildcards, and no file+--   required by the system may be matched by more than one pattern at the same priority+--   (see 'priority' and 'alternatives' to modify this behaviour).+--   This function will create the directory for the result file, if necessary.+--+-- @+-- \"*.asm.o\" '%>' \\out -> do+--     let src = 'Development.Shake.FilePath.dropExtension' out+--     'need' [src]+--     'Development.Shake.cmd' \"as\" [src] \"-o\" [out]+-- @+--+--   To define a build system for multiple compiled languages, we recommend using @.asm.o@,+--   @.cpp.o@, @.hs.o@, to indicate which language produces an object file.+--   I.e., the file @foo.cpp@ produces object file @foo.cpp.o@.+--+--   Note that matching is case-sensitive, even on Windows.+--+--   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
+ src/Development/Shake/Internal/Rules/Files.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns, TypeFamilies #-}++module Development.Shake.Internal.Rules.Files(+    (&?>), (&%>), defaultRuleFiles+    ) where++import Control.Monad+import Control.Monad.IO.Class+import Data.Maybe+import Data.List.Extra+import System.Directory+import Control.Applicative+import Data.Typeable.Extra+import General.Binary+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.Rules+import General.Extra+import Development.Shake.Internal.FileName+import Development.Shake.Classes+import Development.Shake.Internal.Rules.Rerun+import Development.Shake.Internal.Rules.File+import Development.Shake.Internal.FilePattern+import Development.Shake.FilePath+import Development.Shake.Internal.Options+++infix 1 &?>, &%>+++type instance RuleResult FilesQ = FilesA++newtype FilesQ = FilesQ {fromFilesQ :: [FileQ]}+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++newtype FilesA = FilesA [FileA]+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)++instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs++instance Show FilesQ where show (FilesQ xs) = unwords $ map (wrapQuote . show) xs+++filesStoredValue :: ShakeOptions -> FilesQ -> IO (Maybe FilesA)+filesStoredValue opts (FilesQ xs) = fmap FilesA . sequence <$> mapM (fileStoredValue opts) xs++filesEqualValue :: ShakeOptions -> FilesA -> FilesA -> EqualCost+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+              and_ EqualCheap x = x+              and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive++defaultRuleFiles :: Rules ()+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)++ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA+ruleLint opts k (FilesA []) = return Nothing -- in the case of disabling lint+ruleLint opts k v = do+    now <- filesStoredValue opts k+    return $ case now of+        Nothing -> Just "<missing>"+        Just now | filesEqualValue opts v now == EqualCheap -> Nothing+                 | otherwise -> Just $ show now++ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA+ruleRun opts rebuildFlags k o@(fmap getEx -> old) dirtyChildren = do+    let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k+    case old of+        _ | RebuildNow `elem` r -> rebuild+        _ | RebuildLater `elem` r -> case old of+            Just old ->+                -- ignoring the currently stored value, which may trigger lint has changed+                -- so disable lint on this file+                return $ RunResult ChangedNothing (fromJust o) $ FilesA []+            Nothing -> do+                -- i don't have a previous value, so assume this is a source node, and mark rebuild in future+                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+            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+                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++++-- | Define a rule for building multiple files at the same time.+--   Think of it as the AND (@&&@) equivalent of '%>'.+--   As an example, a single invocation of GHC produces both @.hi@ and @.o@ files:+--+-- @+-- [\"*.o\",\"*.hi\"] '&%>' \\[o,hi] -> do+--     let hs = o 'Development.Shake.FilePath.-<.>' \"hs\"+--     'Development.Shake.need' ... -- all files the .hs import+--     'Development.Shake.cmd' \"ghc -c\" [hs]+-- @+--+--   However, in practice, it's usually easier to define rules with '%>' and make the @.hi@ depend+--   on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must+--   have the same sequence of @\/\/@ and @*@ wildcards in the same order.+--   This function will create directories for the result files, if necessary.+(&%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()+[p] &%> act = 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) ->+            (if simple p then id else priority 0.5) $+                fileForward $ 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 $ res !! i+        (if all simple ps then id else priority 0.5) $+            addUserRule $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in+                if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do+                    liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs+                    trackAllow xs+                    act xs+                    getFileTimes "&%>" xs_+++-- | Define a rule for building multiple files at the same time, a more powerful+--   and more dangerous version of '&%>'. Think of it as the AND (@&&@) equivalent of '?>'.+--+--   Given an application @test &?> ...@, @test@ should return @Just@ if the rule applies, and should+--   return the list of files that will be produced. This list /must/ include the file passed as an argument and should+--   obey the invariant:+--+-- > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys+--+--   As an example of a function satisfying the invariaint:+--+-- @+-- test x | 'Development.Shake.FilePath.takeExtension' x \`elem\` [\".hi\",\".o\"]+--        = Just ['Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"hi\", 'Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"o\"]+-- test _ = Nothing+-- @+--+--   Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.+(&?>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()+(&?>) test act = priority 0.5 $ do+    let inputOutput suf inp out =+            ["Input" ++ suf ++ ":", "  " ++ inp] +++            ["Output" ++ suf ++ ":"] ++ map ("  "++) out+    let normTest = fmap (map $ toStandard . normaliseEx) . test+    let checkedTest x = case normTest x of+            Nothing -> Nothing+            Just ys | x `notElem` ys -> error $ unlines $+                "Invariant broken in &?>, did not return the input (after normalisation)." :+                inputOutput "" x ys+            Just ys | bad:_ <- filter ((/= Just ys) . normTest) ys -> error $ unlines $+                ["Invariant broken in &?>, not equalValue for all arguments (after normalisation)."] +++                inputOutput "1" x ys +++                inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad)+            Just ys -> Just ys++    fileForward $ \x -> case checkedTest x of+        Nothing -> Nothing+        Just ys -> Just $ do+            FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString) ys+            return $ res !! fromJust (elemIndex x ys)++    addUserRule $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in+        case checkedTest x of+            Just ys | ys == xs -> Just $ do+                liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs+                act xs+                getFileTimes "&?>" xs_+            Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys+            Nothing -> Nothing+++getFileTimes :: String -> [FileQ] -> Action FilesA+getFileTimes name xs = do+    opts <- getShakeOptions+    let opts2 = if shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts+    ys <- liftIO $ mapM (fileStoredValue opts2) xs+    case sequence ys of+        Just ys -> return $ FilesA ys+        Nothing | not $ shakeCreationCheck opts -> return $ FilesA []+        Nothing -> do+            let missing = length $ filter isNothing ys+            error $ "Error, " ++ name ++ " rule failed to build " ++ show missing +++                    " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" +++                    concat ["\n  " ++ fileNameToString x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zip xs ys]
+ src/Development/Shake/Internal/Rules/Oracle.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies, ConstraintKinds #-}++module Development.Shake.Internal.Rules.Oracle(+    addOracle, askOracle, askOracleWith+    ) 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.Value+import Development.Shake.Classes+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Binary+import Control.Applicative+import Prelude+++-- Use short type names, since the names appear in the Haddock, and are too long if they are in full+newtype OracleQ question = OracleQ question+    deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+newtype OracleA answer = OracleA answer+    deriving (Show,Typeable,Eq,Hashable,Binary,NFData)++type instance RuleResult (OracleQ a) = OracleA (RuleResult a)+++-- | Add extra information which rules can depend on.+--   An oracle is a function from a question type @q@, to an answer type @a@.+--   As an example, we can define an oracle allowing you to depend on the current version of GHC:+--+-- @+-- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+-- type instance RuleResult GhcVersion = String+-- rules = do+--     'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\" :: Action String+--     ... rules ...+-- @+--+--   If a rule calls @'askOracle' (GhcVersion ())@, that rule will be rerun whenever the GHC version changes.+--   Some notes:+--+-- * We define @GhcVersion@ with a @newtype@ around @()@, allowing the use of @GeneralizedNewtypeDeriving@.+--   All the necessary type classes are exported from "Development.Shake.Classes".+--+-- * The @type instance@ requires the extension @TypeFamilies@.+--+-- * Each call to 'addOracle' must use a different type of question.+--+-- * Actions passed to 'addOracle' will be run in every build they are required, even if nothing else changes,+--   so be careful of slow actions.+--   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:+--+-- @+-- newtype GhcPkgList = GhcPkgList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+-- type instance RuleResult GhcPkgList = [(String, String)]+-- newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+-- type instance RuleResult GhcPkgVersion = Maybe String+--+-- rules = do+--     getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do+--         Stdout out <- 'Development.Shake.cmd' \"ghc-pkg list --simple-output\"+--         return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]+--+--     getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do+--         pkgs <- getPkgList $ GhcPkgList ()+--         return $ lookup pkg pkgs+--+--     \"myrule\" %> \\_ -> do+--         getPkgVersion $ GhcPkgVersion \"shake\"+--         ... rule using the shake version ...+-- @+--+--   Using these definitions, any rule depending on the version of @shake@+--   should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.+addOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a)+addOracle 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 _ -> case old of+            Just old | skip ->+                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+        return askOracle+    where+        encode' :: Binary a => a -> BS.ByteString+        encode' = BS.concat . LBS.toChunks . encode++        decode' :: Binary a => BS.ByteString -> a+        decode' = decode . LBS.fromChunks . return+++-- | Get information previously added with 'addOracle'. The question/answer types must match those provided+--   to 'addOracle'.+askOracle :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> Action a+askOracle question = do OracleA answer <- apply1 $ OracleQ question; return answer++-- | Get information previously added with 'addOracle'. The second argument is not used, but can+--   be useful to fix the answer type, avoiding ambiguous type error messages.+--+--   Since the 'RuleResult' type family now fixes the result type, 'askOracle' should be used instead.+askOracleWith :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> a -> Action a+askOracleWith question _ = askOracle question
+ src/Development/Shake/Internal/Rules/OrderOnly.hs view
@@ -0,0 +1,30 @@++module Development.Shake.Internal.Rules.OrderOnly(+     orderOnly, orderOnlyBS+    ) where++import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Rules.File+import qualified Data.ByteString.Char8 as BS+++-- | Define order-only dependencies, these are dependencies that will always+--   be built before continuing, but which aren't dependencies of this action.+--   Mostly useful for defining generated dependencies you think might be real dependencies.+--   If they turn out to be real dependencies, you should add an explicit dependency afterwards.+--+-- @+-- \"source.o\" %> \\out -> do+--     'orderOnly' [\"header.h\"]+--     'cmd_' \"gcc -c source.c -o source.o -MMD -MF source.m\"+--     'neededMakefileDependencies' \"source.m\"+-- @+--+--   If @header.h@ is included by @source.c@ then the call to 'needMakefileDependencies' will cause+--   it to be added as a real dependency. If it isn't, then the rule won't rebuild if it changes.+orderOnly :: [FilePath] -> Action ()+orderOnly = orderOnlyAction . need+++orderOnlyBS :: [BS.ByteString] -> Action ()+orderOnlyBS = orderOnlyAction . needBS
+ src/Development/Shake/Internal/Rules/Rerun.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Development.Shake.Internal.Rules.Rerun(+    defaultRuleRerun, alwaysRerun+    ) where++import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Rules+import Development.Shake.Internal.Core.Types+import Development.Shake.Classes+import qualified Data.ByteString as BS+import General.Binary+++newtype AlwaysRerunQ = AlwaysRerunQ ()+    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)+instance Show AlwaysRerunQ where show _ = "alwaysRerun"++type instance RuleResult AlwaysRerunQ = ()+++-- | Always rerun the associated action. Useful for defining rules that query+--   the environment. For example:+--+-- @+-- \"ghcVersion.txt\" 'Development.Shake.%>' \\out -> do+--     'alwaysRerun'+--     'Development.Shake.Stdout' stdout <- 'Development.Shake.cmd' \"ghc --numeric-version\"+--     'Development.Shake.writeFileChanged' out stdout+-- @+--+--   In make, the @.PHONY@ attribute on file-producing rules has a similar effect.+--+--   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 ()++defaultRuleRerun :: Rules ()+defaultRuleRerun =+    addBuiltinRuleEx noLint $+        \AlwaysRerunQ{} _ _ -> return $ RunResult ChangedRecomputeDiff BS.empty ()
+ src/Development/Shake/Internal/Shake.hs view
@@ -0,0 +1,30 @@++-- | 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
@@ -0,0 +1,122 @@+{-# LANGUAGE ExistentialQuantification, RecordWildCards, ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds, GeneralizedNewtypeDeriving #-}++-- | 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+    ) where++import Development.Shake.Classes+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 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.+--+--   To define your own values meeting the necessary constraints it is convenient to use the extensions+--   @GeneralizedNewtypeDeriving@ and @DeriveDataTypeable@ to write:+--+-- > newtype MyType = MyType (String, Bool) deriving (Show, Typeable, Eq, Hashable, Binary, NFData)+--+--   Shake needs these instances on keys and values. They are used for:+--+-- * 'Show' is used to print out keys in errors, profiling, progress messages+--   and diagnostics.+--+-- * 'Typeable' is used because Shake indexes its database by the+--   type of the key and value involved in the rule (overlap is not+--   allowed for type classes and not allowed in Shake either).+--+-- * 'Eq' and 'Hashable' are used on keys in order to build hash maps+--   from keys to values.  'Eq' is used on values to test if the value+--   has changed or not (this is used to support unchanging rebuilds,+--   where Shake can avoid rerunning rules if it runs a dependency,+--   but it turns out that no changes occurred.)  The 'Hashable'+--   instances are only use at runtime (never serialised to disk),+--   so they do not have to be stable across runs.+--   Hashable on values is not used, and only required for a consistent interface.+--+-- * 'Binary' is used to serialize keys and values into Shake's+--   build database; this lets Shake cache values across runs and+--   implement unchanging rebuilds.+--+-- * 'NFData' is used to avoid space and thunk leaks, especially+--   when Shake is parallelized.+type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a)++-- We deliberately avoid Typeable instances on Key/Value to stop them accidentally+-- being used inside themselves+data Key = forall a . Key+    {keyType :: TypeRep+    ,keyShow :: a -> String+    ,keyRnf :: a -> ()+    ,keyEq :: a -> a -> Bool+    ,keyHash :: Int -> a -> Int+    ,keyValue :: a+    }++data Value = forall a . Value+    {valueType :: TypeRep+    ,valueShow :: a -> String+    ,valueRnf :: a -> ()+    ,valueValue :: a+    }+++newKey :: forall a . ShakeValue a => a -> Key+newKey = Key (typeRep (Proxy :: Proxy a)) show rnf (==) hashWithSalt++newValue :: forall a . ShakeValue a => a -> Value+newValue = Value (typeRep (Proxy :: Proxy a)) show rnf++typeKey :: Key -> TypeRep+typeKey Key{..} = keyType++fromKey :: forall a . Typeable a => Key -> a+fromKey Key{..}+    | keyType == resType = unsafeCoerce keyValue+    | otherwise = 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+    where resType = typeRep (Proxy :: Proxy a)++instance Show Key where+    show Key{..} = keyShow keyValue++instance Show Value where+    show Value{..} = valueShow valueValue++instance NFData Key where+    rnf Key{..} = keyRnf keyValue++instance NFData Value where+    rnf Value{..} = valueRnf valueValue++instance Hashable Key where+    hashWithSalt salt Key{..} = hashWithSalt salt keyType `xor` keyHash salt keyValue++instance Eq Key where+    Key{keyType=at,keyValue=a,keyEq=eq} == Key{keyType=bt,keyValue=b}+        | at /= bt = False+        | otherwise = eq a (unsafeCoerce b)
− src/Development/Shake/Monad.hs 
@@ -1,128 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Development.Shake.Monad(-    RAW, Capture, runRAW,-    getRO, getRW, getsRO, getsRW, putRW, modifyRW,-    withRO, withRW,-    catchRAW, tryRAW, throwRAW,-    unmodifyRW, captureRAW,-    ) where--import Control.Exception.Extra-import Control.Monad.IO.Class-import Control.Monad.Trans.Cont-import Control.Monad.Trans.Reader-import Data.IORef-import Control.Applicative-import Control.Monad-import Prelude---data S ro rw = S-    {handler :: IORef (SomeException -> IO ())-    ,ro :: ro-    ,rww :: IORef rw -- Read/Write Writeable var (rww)-    }--newtype RAW ro rw a = RAW {fromRAW :: ReaderT (S ro rw) (ContT () IO) a}-    deriving (Functor, Applicative, Monad, MonadIO)--type Capture a = (a -> IO ()) -> IO ()----- See https://ghc.haskell.org/trac/ghc/ticket/11555-catchSafe :: IO a -> (SomeException -> IO a) -> IO a-catchSafe = catch_---- | Run and then call a continuation.-runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)-runRAW ro rw m k = do-    rww <- newIORef rw-    handler <- newIORef $ k . Left-    -- see https://ghc.haskell.org/trac/ghc/ticket/11555-    fromRAW m `runReaderT` S handler ro rww `runContT` (k . Right)-        `catchSafe` \e -> ($ e) =<< readIORef handler--------------------------------------------------------------------------- STANDARD--getRO :: RAW ro rw ro-getRO = RAW $ asks ro--getRW :: RAW ro rw rw-getRW = RAW $ liftIO . readIORef =<< asks rww--getsRO :: (ro -> a) -> RAW ro rw a-getsRO f = fmap f getRO--getsRW :: (rw -> a) -> RAW ro rw a-getsRW f = fmap f getRW---- | Strict version-putRW :: rw -> RAW ro rw ()-putRW rw = rw `seq` RAW $ liftIO . flip writeIORef rw =<< asks rww--withRAW :: (S ro rw -> S ro2 rw2) -> RAW ro2 rw2 a -> RAW ro rw a-withRAW f m = RAW $ withReaderT f $ fromRAW m--modifyRW :: (rw -> rw) -> RAW ro rw ()-modifyRW f = do x <- getRW; putRW $ f x--withRO :: (ro -> ro2) -> RAW ro2 rw a -> RAW ro rw a-withRO f = withRAW $ \s -> s{ro=f $ ro s}--withRW :: (rw -> rw2) -> RAW ro rw2 a -> RAW ro rw a-withRW f m = do-    rw <- getRW-    rww <- liftIO $ newIORef $ f rw-    withRAW (\s -> s{rww=rww}) m--------------------------------------------------------------------------- EXCEPTIONS--catchRAW :: RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a-catchRAW m hdl = RAW $ ReaderT $ \s -> ContT $ \k -> do-    old <- readIORef $ handler s-    writeIORef (handler s) $ \e -> do-        writeIORef (handler s) old-        fromRAW (hdl e) `runReaderT` s `runContT` k `catchSafe`-            \e -> ($ e) =<< readIORef (handler s)-    fromRAW m `runReaderT` s `runContT` \v -> do-        writeIORef (handler s) old-        k v---tryRAW :: RAW ro rw a -> RAW ro rw (Either SomeException a)-tryRAW m = catchRAW (fmap Right m) (return . Left)--throwRAW :: Exception e => e -> RAW ro rw a-throwRAW = liftIO . throwIO--------------------------------------------------------------------------- WEIRD STUFF---- | Apply a modification, run an action, then undo the changes after.-unmodifyRW :: (rw -> (rw, rw -> rw)) -> RAW ro rw a -> RAW ro rw a-unmodifyRW f m = do-    (s2,undo) <- fmap f getRW-    putRW s2-    res <- m-    modifyRW undo-    return res----- | Capture a continuation. The continuation should be called at most once.---   Calling the same continuation, multiple times, in parallel, results in incorrect behaviour.-captureRAW :: Capture (Either SomeException a) -> RAW ro rw a-captureRAW f = RAW $ ReaderT $ \s -> ContT $ \k -> do-    old <- readIORef (handler s)-    writeIORef (handler s) throwIO-    f $ \x -> case x of-        Left e -> old e-        Right v -> do-            writeIORef (handler s) old-            k v `catchSafe` \e -> ($ e) =<< readIORef (handler s)-            writeIORef (handler s) throwIO
− src/Development/Shake/Pool.hs 
@@ -1,189 +0,0 @@---- | Thread pool implementation.-module Development.Shake.Pool(-    Pool, runPool,-    addPool, addPoolPriority,-    increasePool-    ) where--import Control.Concurrent.Extra-import System.Time.Extra-import Control.Exception-import Control.Monad-import General.Timing-import qualified Data.HashSet as Set-import qualified Data.HashMap.Strict as Map-import System.Random--------------------------------------------------------------------------- UNFAIR/RANDOM QUEUE---- Monad for non-deterministic (but otherwise pure) computations-type NonDet a = IO a---- Left = deterministic list, Right = non-deterministic tree-data Queue a = Queue [a] (Either [a] (Tree a))--newQueue :: Bool -> Queue a-newQueue deterministic = Queue [] $ if deterministic then Left [] else Right emptyTree--enqueuePriority :: a -> Queue a -> Queue a-enqueuePriority x (Queue p t) = Queue (x:p) t--enqueue :: a -> Queue a -> Queue a-enqueue x (Queue p (Left xs)) = Queue p $ Left $ x:xs-enqueue x (Queue p (Right t)) = Queue p $ Right $ insertTree x t--dequeue :: Queue a -> NonDet (Maybe (a, Queue a))-dequeue (Queue (p:ps) t) = return $ Just (p, Queue ps t)-dequeue (Queue [] (Left (x:xs))) = return $ Just (x, Queue [] $ Left xs)-dequeue (Queue [] (Left [])) = return Nothing-dequeue (Queue [] (Right t)) = do-    bs <- randomIO-    return $ case removeTree bs t of-        Nothing -> Nothing-        Just (x,t) -> Just (x, Queue [] $ Right t)--------------------------------------------------------------------------- TREE---- A tree where removal is random. Nodes are stored at indicies 0..n-1-data Tree a = Tree {-# UNPACK #-} !Int (Map.HashMap Int a)---emptyTree :: Tree a-emptyTree = Tree 0 Map.empty--insertTree :: a -> Tree a -> Tree a-insertTree x (Tree n mp) = Tree (n+1) $ Map.insert n x mp---- Remove an item at random, put the n-1 item to go in it's place-removeTree :: Int -> Tree a -> Maybe (a, Tree a)-removeTree rnd (Tree n mp)-        | n == 0 = Nothing-        | n == 1 = Just (mp Map.! 0, emptyTree)-        | i == n-1 = Just (mp Map.! i, Tree (n-1) $ Map.delete i mp)-        | otherwise = Just (mp Map.! i, Tree (n-1) $ Map.insert i (mp Map.! (n-1)) $ Map.delete (n-1) mp)-    where-        i = abs rnd `mod` n--------------------------------------------------------------------------- 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--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-    }---emptyS :: Int -> Bool -> S-emptyS n deterministic = S Set.empty n 0 0 $ newQueue deterministic---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)----- | Given a pool, and a function that breaks the S invariants, restore them---   They are only allowed to touch threadsLimit or todo-step :: Pool -> (S -> NonDet S) -> IO ()-step pool@(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 <- forkFinally (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----- | Add a new task to the pool, may be cancelled by sending it an exception-addPool :: Pool -> IO a -> IO ()-addPool pool act = step pool $ \s -> do-    todo <- return $ enqueue (void act) (todo s)-    return s{todo = todo}---- | Add a new task to the pool, may be cancelled by sending it an exception.---   Takes priority over everything else.-addPoolPriority :: Pool -> IO a -> IO ()-addPoolPriority pool act = step pool $ \s -> do-    todo <- return $ enqueuePriority (void act) (todo s)-    return s{todo = todo}----- | Temporarily increase the pool by 1 thread. Call the cleanup action to restore the value.---   After calling cleanup you should requeue onto a new thread.-increasePool :: Pool -> IO (IO ())-increasePool pool = do-    step pool $ \s -> return s{threadsLimit = threadsLimit s + 1}-    return $ step pool $ \s -> return s{threadsLimit = threadsLimit s - 1}----- | Run all the tasks in the pool on the given number of works.---   If any thread throws an exception, the exception will be reraised.-runPool :: Bool -> Int -> (Pool -> IO ()) -> IO () -- run all tasks in the pool-runPool deterministic n act = do-    s <- newVar $ Just $ emptyS 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 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/Development/Shake/Profile.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE PatternGuards, RecordWildCards #-}--module Development.Shake.Profile(ProfileEntry(..), ProfileTrace(..), writeProfile) where--import General.Template-import Data.Tuple.Extra-import Data.Function-import Data.List-import Data.Version-import System.FilePath-import Numeric.Extra-import General.Extra-import Paths_shake-import System.Time.Extra-import qualified Data.ByteString.Lazy.Char8 as LBS---data ProfileEntry = ProfileEntry-    {prfName :: String, prfBuilt :: Int, prfChanged :: Int, prfDepends :: [Int], prfExecution :: Double, prfTraces :: [ProfileTrace]}-data ProfileTrace = ProfileTrace-    {prfCommand :: String, prfStart :: Double, prfStop :: Double}-prfTime ProfileTrace{..} = prfStop - prfStart----- | Generates an report given some build system profiling data.-writeProfile :: FilePath -> [ProfileEntry] -> IO ()-writeProfile out xs-    | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ generateJSON xs-    | takeExtension out == ".json" = writeFile out $ generateJSON xs-    | takeExtension out == ".trace" = writeFile out $ generateTrace xs-    | out == "-" = putStr $ unlines $ generateSummary xs-    | otherwise = LBS.writeFile out =<< generateHTML xs---generateSummary :: [ProfileEntry] -> [String]-generateSummary xs =-    ["* This database has tracked " ++ show (maximum (0 : map prfChanged xs) + 1) ++ " runs."-    ,let f = show . length in "* There are " ++ f xs ++ " rules (" ++ f ls ++ " rebuilt in the last run)."-    ,let f = show . sum . map (length . prfTraces) in "* Building required " ++ f xs ++ " traced commands (" ++ f ls ++ " in the last run)."-    ,"* The total (unparallelised) time is " ++ showDuration (sum $ map prfExecution xs) ++-        " of which " ++ showDuration (sum $ map prfTime $ concatMap prfTraces xs) ++ " is traced commands."-    ,let f xs = if null xs then "0s" else (\(a,b) -> showDuration a ++ " (" ++ b ++ ")") $ maximumBy' (compare `on` fst) xs in-        "* The longest rule takes " ++ f (map (prfExecution &&& prfName) xs) ++-        ", and the longest traced command takes " ++ f (map (prfTime &&& prfCommand) $ concatMap prfTraces xs) ++ "."-    ,let sumLast = sum $ map prfTime $ concatMap prfTraces ls-         maxStop = maximum $ 0 : map prfStop (concatMap prfTraces ls) in-        "* Last run gave an average parallelism of " ++ showDP 2 (if maxStop == 0 then 0 else sumLast / maxStop) ++-        " times over " ++ showDuration maxStop ++ "."-    ]-    where ls = filter ((==) 0 . prfBuilt) xs---generateHTML :: [ProfileEntry] -> IO LBS.ByteString-generateHTML xs = do-    htmlDir <- getDataFileName "html"-    report <- LBS.readFile $ htmlDir </> "profile.html"-    let f name | name == "profile-data.js" = return $ LBS.pack $ "var profile =\n" ++ generateJSON xs-               | name == "version.js" = return $ LBS.pack $ "var version = " ++ show (showVersion version)-               | otherwise = LBS.readFile $ htmlDir </> name-    runTemplate f report---generateTrace :: [ProfileEntry] -> String-generateTrace xs = jsonListLines $-    showEntries 0 [y{prfCommand=prfName x} | x <- xs, y <- prfTraces x] ++-    showEntries 1 (concatMap prfTraces xs)-    where-        showEntries pid xs = map (showEntry pid) $ snd $ mapAccumL alloc [] $ sortBy (compare `on` prfStart) xs-        alloc as r | (a1,an:a2) <- break (\a -> prfStop a <= prfStart r) as = (a1++r:a2, (length a1,r))-                   | otherwise = (as++[r], (length as,r))-        showEntry pid (tid, ProfileTrace{..}) = jsonObject-            [("args","{}"), ("ph",show "X"), ("cat",show "target")-            ,("name",show prfCommand), ("tid",show tid), ("pid",show pid)-            ,("ts",show $ 1000000*prfStart), ("dur",show $ 1000000*(prfStop-prfStart))]---generateJSON :: [ProfileEntry] -> String-generateJSON = jsonListLines . map showEntry-    where-        showEntry ProfileEntry{..} = jsonObject $-            [("name", show prfName)-            ,("built", show prfBuilt)-            ,("changed", show prfChanged)-            ,("depends", show prfDepends)-            ,("execution", showDP 4 prfExecution)] ++-            [("traces", jsonList $ map showTrace prfTraces) | not $ null prfTraces]-        showTrace ProfileTrace{..} = jsonObject-            [("command",show prfCommand), ("start",show prfStart), ("stop",show prfStop)]--jsonListLines xs = "[" ++ intercalate "\n," xs ++ "\n]"-jsonList xs = "[" ++ intercalate "," xs ++ "]"-jsonObject xs = "{" ++ intercalate "," [show a ++ ":" ++ b | (a,b) <- xs] ++ "}"
− src/Development/Shake/Progress.hs 
@@ -1,364 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface #-}---- | Progress tracking-module Development.Shake.Progress(-    Progress(..),-    progressSimple, progressDisplay, progressTitlebar, progressProgram,-    ProgressEntry(..), progressReplay, writeProgressReport -- INTERNAL USE ONLY-    ) where--import Control.Applicative-import Data.Tuple.Extra-import Control.Exception.Extra-import Control.Monad-import System.Environment-import System.Directory-import System.Process-import System.FilePath-import Data.Char-import Data.Data-import Data.IORef-import Data.List-import Data.Maybe-import Data.Version-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 Paths_shake-import System.Time.Extra-import Data.Monoid-import Prelude--#ifdef mingw32_HOST_OS--import Foreign-import Foreign.C.Types--#ifdef x86_64_HOST_ARCH-#define CALLCONV ccall-#else-#define CALLCONV stdcall-#endif--foreign import CALLCONV "Windows.h SetConsoleTitleA" c_setConsoleTitle :: Ptr CChar -> IO Bool--#endif--------------------------------------------------------------------------- PROGRESS TYPES - exposed to the user---- | 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 Monoid Progress where-    mempty = Progress Nothing 0 0 0 0 0 0 0 (0,0)-    mappend 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)-        }--------------------------------------------------------------------------- MEALY TYPE - for writing the progress functions--- See <http://hackage.haskell.org/package/machines-0.2.3.1/docs/Data-Machine-Mealy.html>---- | A machine that takes inputs and produces outputs-newtype Mealy i a = Mealy {runMealy :: i -> (a, Mealy i a)}--instance Functor (Mealy i) where-    fmap f (Mealy m) = Mealy $ \i -> case m i of-        (x, m) -> (f x, fmap f m)--instance Applicative (Mealy i) where-    pure x = let r = Mealy (const (x, r)) in r-    Mealy mf <*> Mealy mx = Mealy $ \i -> case mf i of-        (f, mf) -> case mx i of-            (x, mx) -> (f x, mf <*> mx)--echoMealy :: Mealy i i-echoMealy = Mealy $ \i -> (i, echoMealy)--scanMealy :: (a -> b -> a) -> a -> Mealy i b -> Mealy i a-scanMealy f z (Mealy m) = Mealy $ \i -> case m i of-    (x, m) -> let z2 = f z x in (z2, scanMealy f z2 m)--------------------------------------------------------------------------- MEALY UTILITIES--oldMealy :: a -> Mealy i a -> Mealy i (a,a)-oldMealy old = scanMealy (\(_,old) new -> (old,new)) (old,old)--latch :: Mealy i (Bool, a) -> Mealy i a-latch s = fromJust <$> scanMealy f Nothing s-    where f old (b,v) = Just $ if b then fromMaybe v old else v--iff :: Mealy i Bool -> Mealy i a -> Mealy i a -> Mealy i a-iff c t f = (\c t f -> if c then t else f) <$> c <*> t <*> f---- decay'd division, compute a/b, with a decay of f--- r' is the new result, r is the last result--- r' ~= a' / b'--- r' = r*b + f*(a'-a)---      ----------------      b + f*(b'-b)--- when f == 1, r == r'------ both streams must only ever increase-decay :: Double -> Mealy i Double -> Mealy i Double -> Mealy i Double-decay f a b = scanMealy step 0 $ (,) <$> oldMealy 0 a <*> oldMealy 0 b-    where step r ((a,a'),(b,b')) = if isNaN r then a' / b' else ((r*b) + f*(a'-a)) / (b + f*(b'-b))--------------------------------------------------------------------------- MESSAGE GENERATOR--formatMessage :: Double -> Double -> String-formatMessage secs perc =-    (if isNaN secs || secs < 0 then "??s" else showMinSec $ ceiling secs) ++ " (" ++-    (if isNaN perc || perc < 0 || perc > 100 then "??" else show $ floor perc) ++ "%)"--showMinSec :: Int -> String-showMinSec secs = (if m == 0 then "" else show m ++ "m" ++ ['0' | s < 10]) ++ show s ++ "s"-    where (m,s) = divMod secs 60--liftA2' :: Applicative m => m a -> m b -> (a -> b -> c) -> m c-liftA2' a b f = liftA2 f a b----- | return (number of seconds, percentage, explanation)-message :: Mealy (Double, Progress) (Double, Progress) -> Mealy (Double, Progress) (Double, Double, String)-message input = liftA3 (,,) time perc debug-    where-        progress = snd <$> input-        secs = fst <$> input-        debug = (\donePerSec ruleTime (todoKnown,todoUnknown) ->-            "Progress: " ++-                "((known=" ++ showDP 2 todoKnown ++ "s) + " ++-                "(unknown=" ++ show todoUnknown ++ " * time=" ++ showDP 2 ruleTime ++ "s)) " ++-                "(rate=" ++ showDP 2 donePerSec ++ "))")-            <$> donePerSec <*> ruleTime <*> (timeTodo <$> progress)--        -- Number of seconds work completed in this build run-        -- Ignores timeSkipped which would be more truthful, but it makes the % drop sharply-        -- which isn't what users want-        done = timeBuilt <$> progress--        -- Work done per second, don't divide by 0 and don't update if 'done' doesn't change-        donePerSec = iff ((==) 0 <$> done) (pure 1) perSecStable-            where perSecStable = latch $ liftA2 (,) (uncurry (==) <$> oldMealy 0 done) perSecRaw-                  perSecRaw = decay 1.2 done secs--        -- Predicted build time for a rule that has never been built before-        -- The high decay means if a build goes in "phases" - lots of source files, then lots of compiling-        -- we reach a reasonable number fairly quickly, without bouncing too much-        ruleTime = liftA2 weightedAverage-            (f (decay 10) timeBuilt countBuilt)-            (f (liftA2 (/)) (fst . timeTodo) (\Progress{..} -> countTodo - snd timeTodo))-            -- don't call decay on todo, since it goes up and down (as things get done)-            where-                weightedAverage (w1,x1) (w2,x2)-                    | w1 == 0 && w2 == 0 = 0-                    | otherwise = ((w1 *. x1) + (w2 *. x2)) / intToDouble (w1+w2)-                    where i *. d = if i == 0 then 0 else intToDouble i * d -- since d might be NaN--                f divide time count = let xs = count <$> progress in liftA2 (,) xs $ divide (time <$> progress) (intToDouble <$> xs)--        -- Number of seconds work remaining, ignoring multiple threads-        todo = f <$> progress <*> ruleTime-            where f Progress{..} ruleTime = fst timeTodo + (fromIntegral (snd timeTodo) * ruleTime)--        -- Display information-        time = liftA2 (/) todo donePerSec-        perc = iff ((==) 0 <$> done) (pure 0) $-            liftA2' done todo $ \done todo -> 100 * done / (done + todo)--------------------------------------------------------------------------- EXPOSED FUNCTIONS---- | Given a sampling interval (in seconds) and a way to display the status message,---   produce a function suitable for using as 'Development.Shake.shakeProgress'.---   This function polls the progress information every /n/ seconds, produces a status---   message and displays it using the display function.------   Typical status messages will take the form of @1m25s (15%)@, indicating that the build---   is predicted to complete in 1 minute 25 seconds (85 seconds total), and 15% of the necessary build time has elapsed.---   This function uses past observations to predict future behaviour, and as such, is only---   guessing. The time is likely to go up as well as down, and will be less accurate from a---   clean build (as the system has fewer past observations).------   The current implementation is to predict the time remaining (based on 'timeTodo') and the---   work already done ('timeBuilt'). The percentage is then calculated as @remaining / (done + remaining)@,---   while time left is calculated by scaling @remaining@ by the observed work rate in this build,---   roughly @done / time_elapsed@.-progressDisplay :: Double -> (String -> IO ()) -> IO Progress -> IO ()-progressDisplay sample disp prog = do-    disp "Starting..." -- no useful info at this stage-    time <- offsetTime-    catchJust (\x -> if x == ThreadKilled then Just () else Nothing) (loop time $ message echoMealy) (const $ disp "Finished")-    where-        loop :: IO Double -> Mealy (Double, Progress) (Double, Double, String) -> IO ()-        loop time mealy = do-            sleep sample-            p <- prog-            t <- time-            ((secs,perc,debug), mealy) <- return $ runMealy mealy (t, p)-            -- putStrLn debug-            disp $ formatMessage secs perc ++ maybe "" (\err -> ", Failure! " ++ err) (isFailure p)-            loop time mealy---data ProgressEntry = ProgressEntry-    {idealSecs :: Double, idealPerc :: Double-    ,actualSecs :: Double, actualPerc :: Double-    }--isInvalid :: ProgressEntry -> Bool-isInvalid ProgressEntry{..} = isNaN actualSecs || isNaN actualPerc----- | Given a list of progress inputs, what would you have suggested (seconds, percentage)-progressReplay :: [(Double, Progress)] -> [ProgressEntry]-progressReplay [] = []-progressReplay ps = snd $ mapAccumL f (message echoMealy) ps-    where-        end = fst $ last ps-        f a (time,p) = (a2, ProgressEntry (end - time) (time * 100 / end) secs perc)-            where ((secs,perc,_),a2) = runMealy a (time,p)----- | Given a trace, display information about how well we did-writeProgressReport :: FilePath -> [(FilePath, [(Double, Progress)])] -> IO ()-writeProgressReport out (map (second progressReplay) -> xs)-    | (bad,_):_ <- filter (any isInvalid . snd) xs = errorIO $ "Progress generates NaN for " ++ bad-    | takeExtension out == ".js" = writeFile out $ "var shake = \n" ++ generateJSON xs-    | takeExtension out == ".json" = writeFile out $ generateJSON xs-    | out == "-" = putStr $ unlines $ generateSummary xs-    | otherwise = LBS.writeFile out =<< generateHTML xs---generateSummary :: [(FilePath, [ProgressEntry])] -> [String]-generateSummary xs = flip concatMap xs $ \(file,xs) ->-    ["# " ++ file, f xs "Seconds" idealSecs actualSecs, f xs "Percent" idealPerc actualPerc]-    where-        levels = [100,90,80,50]-        f xs lbl ideal actual = lbl ++ ": " ++ intercalate ", "-            [show l ++ "% within " ++ show (ceiling $ maximum $ 0 : take ((length xs * l) `div` 100) diff) | l <- levels]-            where diff = sort [abs $ ideal x - actual x | x <- xs]---generateHTML :: [(FilePath, [ProgressEntry])] -> IO LBS.ByteString-generateHTML xs = do-    htmlDir <- getDataFileName "html"-    report <- LBS.readFile $ htmlDir </> "progress.html"-    let f name | name == "progress-data.js" = return $ LBS.pack $ "var progress =\n" ++ generateJSON xs-               | name == "version.js" = return $ LBS.pack $ "var version = " ++ show (showVersion version)-               | otherwise = LBS.readFile $ htmlDir </> name-    runTemplate f report--generateJSON :: [(FilePath, [ProgressEntry])] -> String-generateJSON = concat . jsonList . map ((++"}") . unlines . f)-    where-        f (file,ps) =-            ("{\"name\":" ++ show (takeFileName file) ++ ", \"values\":") :-            indent (jsonList $ map g ps)--        shw = showDP 1-        g ProgressEntry{..} = jsonObject-            [("idealSecs",shw idealSecs),("idealPerc",shw idealPerc)-            ,("actualSecs",shw actualSecs),("actualPerc",shw actualPerc)]--indent = map ("  "++)-jsonList xs = zipWith (:) ('[':repeat ',') xs ++ ["]"]-jsonObject xs = "{" ++ intercalate ", " [show a ++ ":" ++ b | (a,b) <- xs] ++ "}"---{-# NOINLINE xterm #-}-xterm :: Bool-xterm = unsafePerformIO $-    -- Terminal.app uses "xterm-256color" as its env variable-    catch_ (("xterm" `isPrefixOf`) <$> getEnv "TERM") $-    \e -> return False----- | Set the title of the current console window to the given text. If the---   environment variable @$TERM@ is set to @xterm@ this uses xterm escape sequences.---   On Windows, if not detected as an xterm, this function uses the @SetConsoleTitle@ API.-progressTitlebar :: String -> IO ()-progressTitlebar x-    | xterm = BS.putStr $ BS.pack $ "\ESC]0;" ++ x ++ "\BEL"-#ifdef mingw32_HOST_OS-    | otherwise = BS.useAsCString (BS.pack x) $ \x -> c_setConsoleTitle x >> return ()-#else-    | otherwise = return ()-#endif----- | Call the program @shake-progress@ if it is on the @$PATH@. The program is called with---   the following arguments:------ * @--title=string@ - the string passed to @progressProgram@.------ * @--state=Normal@, or one of @NoProgress@, @Normal@, or @Error@ to indicate---   what state the progress bar should be in.------ * @--value=25@ - the percent of the build that has completed, if not in @NoProgress@ state.------   The program will not be called consecutively with the same @--state@ and @--value@ options.------   Windows 7 or higher users can get taskbar progress notifications by placing the following---   program in their @$PATH@: <https://github.com/ndmitchell/shake/releases>.-progressProgram :: IO (String -> IO ())-progressProgram = do-    exe <- findExecutable "shake-progress"-    case exe of-        Nothing -> return $ const $ return ()-        Just exe -> do-            ref <- newIORef Nothing-            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 ()----- | A simple method for displaying progress messages, suitable for using as 'Development.Shake.shakeProgress'.---   This function writes the current progress to the titlebar every five seconds using 'progressTitlebar',---   and calls any @shake-progress@ program on the @$PATH@ using 'progressProgram'.-progressSimple :: IO Progress -> IO ()-progressSimple p = do-    program <- progressProgram-    progressDisplay 5 (\s -> progressTitlebar s >> program s) p
− src/Development/Shake/Resource.hs 
@@ -1,162 +0,0 @@-{-# LANGUAGE RecordWildCards, ViewPatterns #-}--module Development.Shake.Resource(-    Resource, newResourceIO, newThrottleIO, acquireResource, releaseResource-    ) where--import Data.Function-import System.IO.Unsafe-import Control.Concurrent.Extra-import Control.Exception.Extra-import Data.Tuple.Extra-import Control.Monad-import General.Bilist-import Development.Shake.Pool-import System.Time.Extra-import Data.Monoid-import Prelude---{-# NOINLINE resourceIds #-}-resourceIds :: Var Int-resourceIds = unsafePerformIO $ newVar 0--resourceId :: IO Int-resourceId = modifyVar resourceIds $ \i -> let j = i + 1 in j `seq` return (j, j)----- | A type representing an external resource which the build system should respect. There---   are two ways to create 'Resource's in Shake:------ * 'Development.Shake.newResource' creates a finite resource, stopping too many actions running---   simultaneously.------ * 'Development.Shake.newThrottle' creates a throttled resource, stopping too many actions running---   over a short time period.------   These resources are used with 'Development.Shake.withResource' when defining rules. Typically only---   system commands (such as 'Development.Shake.cmd') should be run inside 'Development.Shake.withResource',---   not commands such as 'Development.Shake.need'.------   Be careful that the actions run within 'Development.Shake.withResource' do not themselves require further---   resources, or you may get a \"thread blocked indefinitely in an MVar operation\" exception.---   If an action requires multiple resources, use 'Development.Shake.withResources' to avoid deadlock.-data Resource = Resource-    {resourceOrd :: Int-        -- ^ 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 ()-        -- ^ Acquire the resource and call the function.-    ,releaseResource :: Pool -> Int -> IO ()-        -- ^ You should only ever releaseResource that you obtained with acquireResource.-    }--instance Show Resource where show = resourceShow-instance Eq Resource where (==) = (==) `on` resourceOrd-instance Ord Resource where compare = compare `on` resourceOrd--------------------------------------------------------------------------- FINITE RESOURCES--data Finite = Finite-    {finiteAvailable :: !Int-        -- ^ number of currently available resources-    ,finiteWaiting :: Bilist (Int, IO ())-        -- ^ queue of people with how much they want and the action when it is allocated to them-    }---- | A version of 'Development.Shake.newResource' that runs in IO, and can be called before calling 'Development.Shake.shake'.---   Most people should use 'Development.Shake.newResource' instead.-newResourceIO :: String -> Int -> IO Resource-newResourceIO name mx = do-    when (mx < 0) $-        errorIO $ "You cannot create a resource named " ++ name ++ " with a negative quantity, you used " ++ show mx-    key <- resourceId-    var <- newVar $ Finite mx mempty-    return $ Resource (negate key) shw (acquire var) (release var)-    where-        shw = "Resource " ++ name--        acquire :: Var Finite -> Pool -> Int -> IO () -> IO ()-        acquire var pool want continue-            | 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 $-                if want <= finiteAvailable then-                    (x{finiteAvailable = finiteAvailable - want}, continue)-                else-                    (x{finiteWaiting = finiteWaiting `snoc` (want, addPool pool continue)}, return ())--        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-                    | otherwise = first (add (wi,wa)) $ f $ Finite i ws-                f (Finite i _) = (Finite i mempty, return ())-                add a s = s{finiteWaiting = a `cons` finiteWaiting s}--------------------------------------------------------------------------- THROTTLE RESOURCES----- call a function after a certain delay-waiter :: Seconds -> IO () -> IO ()-waiter period act = void $ forkIO $ do-    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-    addPool pool $ do-        cancel <- increasePool pool-        waitBarrier bar-        cancel-    return $ signalBarrier bar ()---data Throttle-      -- | Some number of resources are available-    = ThrottleAvailable !Int-      -- | Some users are blocked (non-empty), plus an action to call once we go back to Available-    | ThrottleWaiting (IO ()) (Bilist (Int, IO ()))----- | A version of 'Development.Shake.newThrottle' that runs in IO, and can be called before calling 'Development.Shake.shake'.---   Most people should use 'Development.Shake.newThrottle' instead.-newThrottleIO :: String -> Int -> Double -> IO Resource-newThrottleIO name count period = do-    when (count < 0) $-        errorIO $ "You cannot create a throttle named " ++ name ++ " with a negative quantity, you used " ++ show count-    key <- resourceId-    var <- newVar $ ThrottleAvailable count-    return $ Resource key shw (acquire var) (release var)-    where-        shw = "Throttle " ++ name--        acquire :: Var Throttle -> Pool -> Int -> IO () -> IO ()-        acquire var pool want continue-            | 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-                ThrottleAvailable i-                    | i >= want -> return (ThrottleAvailable $ i - want, continue)-                    | otherwise -> do-                        stop <- blockPool pool-                        return (ThrottleWaiting stop $ (want - i, addPool pool continue) `cons` mempty, return ())-                ThrottleWaiting stop xs -> return (ThrottleWaiting stop $ xs `snoc` (want, addPool pool continue), return ())--        release :: Var Throttle -> Pool -> Int -> IO ()-        release var pool n = waiter period $ join $ modifyVar var $ \x -> return $ case x of-                ThrottleAvailable i -> (ThrottleAvailable $ i+n, return ())-                ThrottleWaiting stop xs -> f stop n xs-            where-                f stop i (uncons -> Just ((wi,wa),ws))-                    | i >= wi = second (wa >>) $ f stop (i-wi) ws-                    | otherwise = (ThrottleWaiting stop $ (wi-i,wa) `cons` ws, return ())-                f stop i _ = (ThrottleAvailable i, stop)
src/Development/Shake/Rule.hs view
@@ -2,21 +2,18 @@ -- | 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. module Development.Shake.Rule(-    Rule(..), EqualCost(..), rule, apply, apply1,-    trackUse, trackChange, trackAllow,-    -- * Deprecated-    defaultRule+    -- * Defining builtin rules+    addBuiltinRule,+    BuiltinLint, noLint, BuiltinRun, RunChanged(..), RunResult(..),+    -- * Calling builtin rules+    apply, apply1,+    -- * User rules+    UserRule(..), addUserRule, getUserRules, userRuleMatch,+    -- * Lint integration+    trackUse, trackChange, trackAllow     ) where -import Development.Shake.Core-import Development.Shake.Types--{-# DEPRECATED defaultRule "Use 'rule' with 'priority' 0" #-}---- | A deprecated way of defining a low priority rule. Defined as:------ @--- defaultRule = 'priority' 0 . 'rule'--- @-defaultRule :: Rule key value => (key -> Maybe (Action value)) -> Rules ()-defaultRule = priority 0 . rule+import Development.Shake.Internal.Core.Types+import Development.Shake.Internal.Core.Action+import Development.Shake.Internal.Core.Run+import Development.Shake.Internal.Core.Rules
− src/Development/Shake/Rules/Directory.hs 
@@ -1,320 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable, RecordWildCards, FlexibleContexts #-}---- | Both System.Directory and System.Environment wrappers-module Development.Shake.Rules.Directory(-    doesFileExist, doesDirectoryExist,-    getDirectoryContents, getDirectoryFiles, getDirectoryDirs,-    getEnv, getEnvWithDefault,-    removeFiles, removeFilesAfter,-    getDirectoryFilesIO,-    defaultRuleDirectory-    ) where--import Control.Applicative-import Control.Exception as C-import Control.Monad.Extra-import Control.Monad.IO.Class-import Data.Maybe-import Data.Binary-import Data.List-import Data.Tuple.Extra-import qualified Data.HashSet as Set-import qualified System.Directory as IO-import qualified System.Environment.Extra as IO--import Development.Shake.Core-import Development.Shake.Classes-import Development.Shake.FilePath-import Development.Shake.FilePattern-import General.Extra-import Prelude---newtype DoesFileExistQ = DoesFileExistQ FilePath-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesFileExistQ where-    show (DoesFileExistQ a) = "doesFileExist " ++ showQuote a--newtype DoesFileExistA = DoesFileExistA Bool-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesFileExistA where-    show (DoesFileExistA a) = show a---newtype DoesDirectoryExistQ = DoesDirectoryExistQ FilePath-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesDirectoryExistQ where-    show (DoesDirectoryExistQ a) = "doesDirectoryExist " ++ showQuote a--newtype DoesDirectoryExistA = DoesDirectoryExistA Bool-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show DoesDirectoryExistA where-    show (DoesDirectoryExistA a) = show a---newtype GetEnvQ = GetEnvQ String-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show GetEnvQ where-    show (GetEnvQ a) = "getEnv " ++ showQuote a--newtype GetEnvA = GetEnvA (Maybe String)-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show GetEnvA where-    show (GetEnvA a) = maybe "<unset>" showQuote a---data GetDirectoryQ-    = GetDir {dir :: FilePath}-    | GetDirFiles {dir :: FilePath, pat :: [FilePattern]}-    | GetDirDirs {dir :: FilePath}-    deriving (Typeable,Eq)--newtype GetDirectoryA = GetDirectoryA [FilePath]-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show GetDirectoryQ where-    show (GetDir x) = "getDirectoryContents " ++ showQuote x-    show (GetDirFiles a b) = "getDirectoryFiles " ++ showQuote a ++ " [" ++ unwords (map showQuote b) ++ "]"-    show (GetDirDirs x) = "getDirectoryDirs " ++ showQuote x--instance Show GetDirectoryA where-    show (GetDirectoryA xs) = unwords $ map showQuote xs--instance NFData GetDirectoryQ where-    rnf (GetDir a) = rnf a-    rnf (GetDirFiles a b) = rnf a `seq` rnf b-    rnf (GetDirDirs a) = rnf a--instance Hashable GetDirectoryQ where-    hashWithSalt salt = hashWithSalt salt . f-        where f (GetDir x) = (0 :: Int, x, [])-              f (GetDirFiles x y) = (1, x, y)-              f (GetDirDirs x) = (2, x, [])--instance Binary GetDirectoryQ where-    get = do-        i <- getWord8-        case i of-            0 -> GetDir <$> get-            1 -> GetDirFiles <$> get <*> get-            2 -> GetDirDirs <$> get--    put (GetDir x) = putWord8 0 >> put x-    put (GetDirFiles x y) = putWord8 1 >> put x >> put y-    put (GetDirDirs x) = putWord8 2 >> put x---instance Rule DoesFileExistQ DoesFileExistA where-    storedValue _ (DoesFileExistQ x) = (Just . DoesFileExistA) <$> IO.doesFileExist x--instance Rule DoesDirectoryExistQ DoesDirectoryExistA where-    storedValue _ (DoesDirectoryExistQ x) = (Just . DoesDirectoryExistA) <$> IO.doesDirectoryExist x--instance Rule GetEnvQ GetEnvA where-    storedValue _ (GetEnvQ x) = (Just . GetEnvA) <$> IO.lookupEnv x--instance Rule GetDirectoryQ GetDirectoryA where-    storedValue _ x = Just <$> getDir x----- | This function is not actually exported, but Haddock is buggy. Please ignore.-defaultRuleDirectory :: Rules ()-defaultRuleDirectory = do-    rule $ \(DoesFileExistQ x) -> Just $-        liftIO $ DoesFileExistA <$> IO.doesFileExist x-    rule $ \(DoesDirectoryExistQ x) -> Just $-        liftIO $ DoesDirectoryExistA <$> IO.doesDirectoryExist x-    rule $ \(x :: GetDirectoryQ) -> Just $-        liftIO $ getDir x-    rule $ \(GetEnvQ x) -> Just $-        liftIO $ GetEnvA <$> IO.lookupEnv x----- | Returns 'True' if the file exists. The existence of the file is tracked as a---   dependency, and if the file is created or deleted the rule will rerun in subsequent builds.------   You should not call 'doesFileExist' on files which can be created by the build system.-doesFileExist :: FilePath -> Action Bool-doesFileExist file = do-    DoesFileExistA res <- apply1 $ DoesFileExistQ $ toStandard file-    return res---- | Returns 'True' if the directory exists. The existence of the directory is tracked as a---   dependency, and if the directory is created or delete the rule will rerun in subsequent builds.------   You should not call 'doesDirectoryExist' on directories which can be created by the build system.-doesDirectoryExist :: FilePath -> Action Bool-doesDirectoryExist file = do-    DoesDirectoryExistA res <- apply1 $ DoesDirectoryExistQ $ toStandard file-    return res---- | Return 'Just' the value of the environment variable, or 'Nothing'---   if the variable is not set. The environment variable is tracked as a---   dependency, and if it changes the rule will rerun in subsequent builds.---   This function is a tracked version of 'getEnv'/'lookupEnv' from the base library.------ @--- flags <- getEnv \"CFLAGS\"--- 'cmd' \"gcc -c\" [out] (maybe [] words flags)--- @-getEnv :: String -> Action (Maybe String)-getEnv var = do-    GetEnvA res <- apply1 $ GetEnvQ var-    return res---- | Return the value of the environment variable (second argument), or the---   default value (first argument) if it is not set. Similar to 'getEnv'.------ @--- flags <- getEnvWithDefault \"-Wall\" \"CFLAGS\"--- 'cmd' \"gcc -c\" [out] flags--- @-getEnvWithDefault :: String -> String -> Action String-getEnvWithDefault def var = fromMaybe def <$> getEnv var---- | Get the contents of a directory. The result will be sorted, and will not contain---   the entries @.@ or @..@ (unlike the standard Haskell version). The resulting paths will be relative---   to the first argument. The result is tracked as a---   dependency, and if it changes the rule will rerun in subsequent builds.------   It is usually simpler to call either 'getDirectoryFiles' or 'getDirectoryDirs'.-getDirectoryContents :: FilePath -> Action [FilePath]-getDirectoryContents x = getDirAction $ GetDir x---- | Get the files anywhere under a directory that match any of a set of patterns.---   For the interpretation of the patterns see '?=='. All results will be---   relative to the directory argument. The result is tracked as a---   dependency, and if it changes the rule will rerun in subsequent builds.---   Some examples:------ > getDirectoryFiles "Config" ["//*.xml"]--- >     -- All .xml files anywhere under the Config directory--- >     -- If Config/foo/bar.xml exists it will return ["foo/bar.xml"]--- > getDirectoryFiles "Modules" ["*.hs","*.lhs"]--- >     -- All .hs or .lhs in the Modules directory--- >     -- If Modules/foo.hs and Modules/foo.lhs exist, it will return ["foo.hs","foo.lhs"]------   If you require a qualified file name it is often easier to use @\"\"@ as the 'FilePath' argument,---   for example the following two expressions are equivalent:------ > fmap (map ("Config" </>)) (getDirectoryFiles "Config" ["//*.xml"])--- > getDirectoryFiles "" ["Config//*.xml"]------   If the first argument directory does not exist it will raise an error.---   If @foo@ does not exist, then the first of these error, but the second will not.------ > getDirectoryFiles "foo" ["//*"] -- error--- > getDirectoryFiles "" ["foo//*"] -- returns []------   This function is tracked and serves as a dependency. If a rule calls---   @getDirectoryFiles \"\" [\"*.c\"]@ and someone adds @foo.c@ to the---   directory, that rule will rebuild. If someone changes one of the @.c@ files,---   but the /list/ of @.c@ files doesn't change, then it will not rebuild.---   As a consequence of being tracked, if the contents change during the build---   (e.g. you are generating @.c@ files in this directory) then the build not reach---   a stable point, which is an error - detected by running with @--lint@.---   You should only call this function returning source files.------   For an untracked variant see 'getDirectoryFilesIO'.-getDirectoryFiles :: FilePath -> [FilePattern] -> Action [FilePath]-getDirectoryFiles x f = getDirAction $ GetDirFiles x f---- | Get the directories in a directory, not including @.@ or @..@.---   All directories are relative to the argument directory. The result is tracked as a---   dependency, and if it changes the rule will rerun in subsequent builds.---   The rules about creating entries described in 'getDirectoryFiles' also apply here.------ > getDirectoryDirs "/Users"--- >    -- Return all directories in the /Users directory--- >    -- e.g. ["Emily","Henry","Neil"]-getDirectoryDirs :: FilePath -> Action [FilePath]-getDirectoryDirs x = getDirAction $ GetDirDirs x--getDirAction x = do GetDirectoryA y <- apply1 x; return y--contents :: FilePath -> IO [FilePath]--- getDirectoryContents "" is equivalent to getDirectoryContents "." on Windows,--- but raises an error on Linux. We smooth out the difference.-contents x = fmap (filter $ not . all (== '.')) $ IO.getDirectoryContents $ if x == "" then "." else x---answer :: [FilePath] -> GetDirectoryA-answer = GetDirectoryA . sort--getDir :: GetDirectoryQ -> IO GetDirectoryA-getDir GetDir{..} = answer <$> contents dir--getDir GetDirDirs{..} = fmap answer $ filterM f =<< contents dir-    where f x = IO.doesDirectoryExist $ dir </> x--getDir GetDirFiles{..} = answer <$> getDirectoryFilesIO dir pat----- | A version of 'getDirectoryFiles' that is in IO, and thus untracked.-getDirectoryFilesIO :: FilePath -> [FilePattern] -> IO [FilePath]--- Known infelicity: on Windows, if you search for "foo", but have the file "FOO",--- it will match if on its own, or not if it is paired with "*", since that forces--- a full directory scan, and then it uses Haskell equality (case sensitive)-getDirectoryFilesIO root pat = f "" $ snd $ walk pat-    where-        -- Even after we know they are there because we called contents, we still have to check they are directories/files-        -- as required-        f dir (Walk op) = f dir . WalkTo . op =<< contents (root </> dir)-        f dir (WalkTo (files, dirs)) = do-            files <- filterM (IO.doesFileExist . (root </>)) $ map (dir </>) files-            dirs <- concatMapM (uncurry f) =<< filterM (IO.doesDirectoryExist . (root </>) . fst) (map (first (dir </>)) dirs)-            return $ files ++ dirs----- | Remove all files and directories that match any of the patterns within a directory.---   Some examples:------ @--- 'removeFiles' \"output\" [\"\/\/*\"]        -- delete everything inside \'output\'--- 'removeFiles' \"output\" [\"\/\/\"]         -- delete \'output\' itself--- 'removeFiles' \".\" [\"\/\/*.hi\",\"\/\/*.o\"] -- delete all \'.hi\' and \'.o\' files--- @------   If the argument directory is missing no error is raised.---   This function will follow symlinks, so should be used with care.------   This function is often useful when writing a @clean@ action for your build system,---   often as a 'phony' rule.-removeFiles :: FilePath -> [FilePattern] -> IO ()-removeFiles dir pat =-    whenM (IO.doesDirectoryExist dir) $ do-        let (b,w) = walk pat-        if b then removeDir dir else f dir w-    where-        f dir (Walk op) = f dir . WalkTo . op =<< contents dir-        f dir (WalkTo (files, dirs)) = do-            forM_ files $ \fil ->-                try $ removeItem $ dir </> fil :: IO (Either IOException ())-            let done = Set.fromList files-            forM_ (filter (not . flip Set.member done . fst) dirs) $ \(d,w) -> do-                let dir2 = dir </> d-                whenM (IO.doesDirectoryExist dir2) $ f dir2 w--        removeItem :: FilePath -> IO ()-        removeItem x = IO.removeFile x `C.catch` \(_ :: IOException) -> removeDir x--        -- In newer GHC's removeDirectoryRecursive is probably better, but doesn't follow-        -- symlinks, so it's got different behaviour-        removeDir :: FilePath -> IO ()-        removeDir x = do-            mapM_ (removeItem . (x </>)) =<< contents x-            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.-removeFilesAfter :: FilePath -> [FilePattern] -> Action ()-removeFilesAfter a b = do-    putLoud $ "Will remove " ++ unwords b ++ " from " ++ a-    runAfter $ removeFiles a b
− src/Development/Shake/Rules/File.hs 
@@ -1,306 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--module Development.Shake.Rules.File(-    need, needBS, needed, neededBS, needNorm, want,-    trackRead, trackWrite, trackAllow,-    defaultRuleFile,-    (%>), (|%>), (?>), phony, (~>), phonys,-    -- * Internal only-    FileQ(..), FileA-    ) where--import Control.Applicative-import Control.Monad.Extra-import Control.Monad.IO.Class-import System.Directory-import qualified Data.ByteString.Char8 as BS-import qualified Data.HashSet as Set--import Development.Shake.Core hiding (trackAllow)-import qualified Development.Shake.Core as S-import General.String-import Development.Shake.ByteString-import Development.Shake.Classes-import Development.Shake.FilePath(toStandard)-import Development.Shake.FilePattern-import Development.Shake.FileInfo-import Development.Shake.Types-import Development.Shake.Errors--import Data.Bits-import Data.List-import Data.Maybe-import System.FilePath(takeDirectory) -- important that this is the system local filepath, or wrong slashes go wrong-import System.IO.Unsafe(unsafeInterleaveIO)---infix 1 %>, ?>, |%>, ~>---newtype FileQ = FileQ {fromFileQ :: BSU}-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show FileQ where show (FileQ x) = unpackU x--data FileA = FileA {-# UNPACK #-} !ModTime {-# UNPACK #-} !FileSize FileHash-    deriving (Typeable,Eq)--instance Hashable FileA where-    hashWithSalt salt (FileA a b c) = hashWithSalt salt a `xor` hashWithSalt salt b `xor` hashWithSalt salt c--instance NFData FileA where-    rnf (FileA a b c) = rnf a `seq` rnf b `seq` rnf c--instance Binary FileA where-    put (FileA a b c) = put a >> put b >> put c-    get = liftA3 FileA get get get--instance Show FileA where-    show (FileA m s h) = "File {mod=" ++ show m ++ ",size=" ++ show s ++ ",digest=" ++ show h ++ "}"--instance Rule FileQ FileA where-    storedValue ShakeOptions{shakeChange=c} (FileQ x) = do-        res <- getFileInfoNoDirErr x-        case res of-            Nothing -> return Nothing-            Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size fileInfoNeq-            Just (time,size) -> do-                hash <- unsafeInterleaveIO $ getFileHash x-                return $ Just $ FileA (if c == ChangeDigest then fileInfoNeq else time) size hash--    equalValue ShakeOptions{shakeChange=c} q (FileA x1 x2 x3) (FileA y1 y2 y3) = case c of-        ChangeModtime -> bool $ x1 == y1-        ChangeDigest -> bool $ x2 == y2 && x3 == y3-        ChangeModtimeOrDigest -> bool $ x1 == y1 && x2 == y2 && x3 == y3-        _ | x1 == y1 -> EqualCheap-          | x2 == y2 && x3 == y3 -> EqualExpensive-          | otherwise -> NotEqual-        where bool b = if b then EqualCheap else NotEqual---storedValueErrDir :: ShakeOptions -> FileQ -> IO (Maybe FileA)-storedValueErrDir ShakeOptions{shakeChange=c} (FileQ x) = do-    res <- getFileInfo x-    case res of-        Nothing -> return Nothing-        Just (time,size) | c == ChangeModtime -> return $ Just $ FileA time size fileInfoNeq-        Just (time,size) -> do-            hash <- unsafeInterleaveIO $ getFileHash x-            return $ Just $ FileA (if c == ChangeDigest then fileInfoNeq else time) size hash------ | Arguments: options; is the file an input; a message for failure if the file does not exist; filename-storedValueError :: ShakeOptions -> Bool -> String -> FileQ -> IO FileA-{--storedValueError opts False msg x | False && not (shakeOutputCheck opts) = do-    when (shakeCreationCheck opts) $ do-        whenM (isNothing <$> (storedValue opts x :: IO (Maybe FileA))) $ error $ msg ++ "\n  " ++ unpackU (fromFileQ x)-    return $ FileA fileInfoEq fileInfoEq fileInfoEq--}-storedValueError opts input msg x = fromMaybe def <$> storedValueErrDir opts2 x-    where def = if shakeCreationCheck opts || input then error err else FileA fileInfoNeq fileInfoNeq fileInfoNeq-          err = msg ++ "\n  " ++ unpackU (fromFileQ x)-          opts2 = if not input && shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts----- | This function is not actually exported, but Haddock is buggy. Please ignore.-defaultRuleFile :: Rules ()-defaultRuleFile = priority 0 $ rule $ \x -> Just $ do-    opts <- getShakeOptions-    liftIO $ storedValueError opts True "Error, file does not exist and no rule available:" x----- | Add a dependency on the file arguments, ensuring they are built before continuing.---   The file arguments may be built in parallel, in any order. This function is particularly---   necessary when calling 'Development.Shake.cmd' or 'Development.Shake.command'. As an example:------ @--- \"\/\/*.rot13\" '%>' \\out -> do---     let src = 'Development.Shake.FilePath.dropExtension' out---     'need' [src]---     'Development.Shake.cmd' \"rot13\" [src] \"-o\" [out]--- @------   Usually @need [foo,bar]@ is preferable to @need [foo] >> need [bar]@ as the former allows greater---   parallelism, while the latter requires @foo@ to finish building before starting to build @bar@.------   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 xs = (apply $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU) xs :: Action [FileA]) >> return ()--needNorm :: [FilePath] -> Action ()-needNorm xs = (apply $ map (FileQ . packU) xs :: Action [FileA]) >> return ()--needBS :: [BS.ByteString] -> Action ()-needBS xs = (apply $ map (FileQ . packU_ . filepathNormalise) xs :: Action [FileA]) >> return ()----- | Like 'need', but if 'shakeLint' is set, check that the file does not rebuild.---   Used for adding dependencies on files that have already been used in this rule.-needed :: [FilePath] -> Action ()-needed xs = do-    opts <- getShakeOptions-    if isNothing $ shakeLint opts then need xs else neededCheck $ map packU xs---neededBS :: [BS.ByteString] -> Action ()-neededBS xs = do-    opts <- getShakeOptions-    if isNothing $ shakeLint opts then needBS xs else neededCheck $ map packU_ xs---neededCheck :: [BSU] -> Action ()-neededCheck (map (packU_ . filepathNormalise . unpackU_) -> xs) = do-    opts <- getShakeOptions-    pre <- liftIO $ mapM (storedValueErrDir opts . FileQ) xs-    post <- apply $ map FileQ xs :: Action [FileA]-    let bad = [ (x, if isJust a then "File change" else "File created")-              | (x, a, b) <- zip3 xs pre post, maybe NotEqual (\a -> equalValue opts (FileQ x) a b) a == NotEqual]-    case bad of-        [] -> return ()-        (file,msg):_ -> liftIO $ errorStructured-            "Lint checking error - 'needed' file required rebuilding"-            [("File", Just $ unpackU file)-            ,("Error",Just msg)]-            ""----- | Track that a file was read by the action preceeding it. If 'shakeLint' is activated---   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 . packU)---- | 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 . packU)---- | 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 (?== unpackU x) ps----- | Require that the argument files are built by the rules, used to specify the target.------ @--- main = 'Development.Shake.shake' 'shakeOptions' $ do---    'want' [\"Main.exe\"]---    ...--- @------   This program will build @Main.exe@, given sufficient rules. All arguments to all 'want' calls---   may be built in parallel, in any order.------   This function is defined in terms of 'action' and 'need', use 'action' if you need more complex---   targets than 'want' allows.-want :: [FilePath] -> Rules ()-want [] = return ()-want xs = action $ need xs---root :: String -> (FilePath -> Bool) -> (FilePath -> Action ()) -> Rules ()-root help test act = rule $ \(FileQ x_) -> let x = unpackU x_ in-    if not $ test x then Nothing else Just $ do-        liftIO $ createDirectoryIfMissing True $ takeDirectory x-        act x-        opts <- getShakeOptions-        liftIO $ storedValueError opts False ("Error, rule " ++ help ++ " failed to build file:") $ FileQ x_----- | Declare a Make-style phony action.  A phony target does not name---   a file (despite living in the same namespace as file rules);---   rather, it names some action to be executed when explicitly---   requested.  You can demand 'phony' rules using 'want'. (And 'need',---   although that's not recommended.)------   Phony actions are intended to define recipes that can be executed---   by the user. If you 'need' a phony action in a rule then every---   execution where that rule is required will rerun both the rule and---   the phony action.  However, note that phony actions are never---   executed more than once in a single build run.------   In make, the @.PHONY@ attribute on non-file-producing rules has a---   similar effect.  However, while in make it is acceptable to omit---   the @.PHONY@ attribute as long as you don't create the file in---   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---- | A predicate version of 'phony', return 'Just' with the 'Action' for the matching rules.-phonys :: (String -> Maybe (Action ())) -> Rules ()-phonys act = rule $ \(FileQ x_) -> case act $ unpackU x_ of-    Nothing -> Nothing-    Just act -> Just $ do-        act-        return $ FileA fileInfoNeq fileInfoNeq fileInfoNeq---- | Infix operator alias for 'phony', for sake of consistency with normal---   rules.-(~>) :: String -> Action () -> Rules ()-(~>) = phony----- | Define a rule to build files. If the first argument returns 'True' for a given file,---   the second argument will be used to build it. Usually '%>' is sufficient, but '?>' gives---   additional power. For any file used by the build system, only one rule should return 'True'.---   This function will create the directory for the result file, if necessary.------ @--- (all isUpper . 'Development.Shake.FilePath.takeBaseName') '?>' \\out -> do---     let src = 'Development.Shake.FilePath.replaceBaseName' out $ map toLower $ takeBaseName out---     'Development.Shake.writeFile'' out . map toUpper =<< 'Development.Shake.readFile'' src--- @------   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----- | Define a set of patterns, and if any of them match, run the associated rule. Defined in terms of '%>'.---   Think of it as the OR (@||@) equivalent of '%>'.-(|%>) :: [FilePattern] -> (FilePath -> Action ()) -> Rules ()-(|%>) pats act = do-    let (simp,other) = partition simple pats-    case 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-    unless (null other) $-        let ps = map (?==) other in priority 0.5 $ root "with |%>" (\x -> any ($ x) ps) act---- | Define a rule that matches a 'FilePattern', see '?==' for the pattern rules.---   Patterns with no wildcards have higher priority than those with wildcards, and no file---   required by the system may be matched by more than one pattern at the same priority---   (see 'priority' and 'alternatives' to modify this behaviour).---   This function will create the directory for the result file, if necessary.------ @--- \"*.asm.o\" '%>' \\out -> do---     let src = 'Development.Shake.FilePath.dropExtension' out---     'need' [src]---     'Development.Shake.cmd' \"as\" [src] \"-o\" [out]--- @------   To define a build system for multiple compiled languages, we recommend using @.asm.o@,---   @.cpp.o@, @.hs.o@, to indicate which language produces an object file.---   I.e., the file @foo.cpp@ produces object file @foo.cpp.o@.------   Note that matching is case-sensitive, even on Windows.------   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
− src/Development/Shake/Rules/Files.hs 
@@ -1,150 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}--module Development.Shake.Rules.Files(-    (&?>), (&%>)-    ) where--import Control.Monad-import Control.Monad.IO.Class-import Data.Maybe-import Data.List.Extra-import System.Directory-import Control.Applicative-import Prelude--import Development.Shake.Core hiding (trackAllow)-import General.Extra-import General.String-import Development.Shake.Classes-import Development.Shake.Rules.File-import Development.Shake.FilePattern-import Development.Shake.FilePath-import Development.Shake.Types-import Development.Shake.ByteString---infix 1 &?>, &%>---newtype FilesQ = FilesQ [FileQ]-    deriving (Typeable,Eq,Hashable,Binary,NFData)----newtype FilesA = FilesA [FileA]-    deriving (Typeable,Eq,Hashable,Binary,NFData)--instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs--instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . show) xs---instance Rule FilesQ FilesA where-    storedValue opts (FilesQ xs) = (fmap FilesA . sequence) <$> mapM (storedValue opts) xs-    equalValue opts (FilesQ qs) (FilesA xs) (FilesA ys)-        | let n = length qs in n /= length xs || n /= length ys = NotEqual-        | otherwise = foldr and_ EqualCheap (zipWith3 (equalValue opts) qs xs ys)-            where and_ NotEqual x = NotEqual-                  and_ EqualCheap x = x-                  and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive----- | Define a rule for building multiple files at the same time.---   Think of it as the AND (@&&@) equivalent of '%>'.---   As an example, a single invocation of GHC produces both @.hi@ and @.o@ files:------ @--- [\"*.o\",\"*.hi\"] '&%>' \\[o,hi] -> do---     let hs = o 'Development.Shake.FilePath.-<.>' \"hs\"---     'Development.Shake.need' ... -- all files the .hs import---     'Development.Shake.cmd' \"ghc -c\" [hs]--- @------   However, in practice, it's usually easier to define rules with '%>' and make the @.hi@ depend---   on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must---   have the same sequence of @\/\/@ and @*@ wildcards in the same order.---   This function will create directories for the result files, if necessary.-(&%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()-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_ ps $ \p ->-            p %> \file -> do-                _ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU . substitute (extract p file)) ps-                return ()-        (if all simple ps then id else priority 0.5) $-            rule $ \(FilesQ xs_) -> let xs = map (unpackU . fromFileQ) xs_ in-                if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do-                    liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs-                    trackAllow xs-                    act xs-                    getFileTimes "&%>" xs_----- | Define a rule for building multiple files at the same time, a more powerful---   and more dangerous version of '&%>'. Think of it as the AND (@&&@) equivalent of '?>'.------   Given an application @test &?> ...@, @test@ should return @Just@ if the rule applies, and should---   return the list of files that will be produced. This list /must/ include the file passed as an argument and should---   obey the invariant:------ > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys------   As an example of a function satisfying the invariaint:------ @--- test x | 'Development.Shake.FilePath.takeExtension' x \`elem\` [\".hi\",\".o\"]---        = Just ['Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"hi\", 'Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"o\"]--- test _ = Nothing--- @------   Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.-(&?>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()-(&?>) test act = priority 0.5 $ do-    let norm = toStandard . normaliseEx-    let inputOutput suf inp out =-            ["Input" ++ suf ++ ":", "  " ++ inp] ++-            ["Output" ++ suf ++ ":"] ++ map ("  "++) out-    let normTest = fmap (map norm) . test-    let checkedTest x = case normTest x of-            Nothing -> Nothing-            Just ys | x `notElem` ys -> error $ unlines $-                "Invariant broken in &?>, did not return the input (after normalisation)." :-                inputOutput "" x ys-            Just ys | bad:_ <- filter ((/= Just ys) . normTest) ys -> error $ unlines $-                ["Invariant broken in &?>, not equal for all arguments (after normalisation)."] ++-                inputOutput "1" x ys ++-                inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad)-            Just ys -> Just ys--    isJust . checkedTest ?> \x -> do-        -- FIXME: Could optimise this test by calling rule directly and returning FileA Eq Eq Eq-        --        But only saves noticable time on uncommon Change modes-        _ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU) $ fromJust $ test x-        return ()--    rule $ \(FilesQ xs_) -> let xs@(x:_) = map (unpackU . fromFileQ) xs_ in-        case checkedTest x of-            Just ys | ys == xs -> Just $ do-                liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs-                act xs-                getFileTimes "&?>" xs_-            Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys-            Nothing -> Nothing---getFileTimes :: String -> [FileQ] -> Action FilesA-getFileTimes name xs = do-    opts <- getShakeOptions-    let opts2 = if shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts-    ys <- liftIO $ mapM (storedValue opts2) xs-    case sequence ys of-        Just ys -> return $ FilesA ys-        Nothing | not $ shakeCreationCheck opts -> return $ FilesA []-        Nothing -> do-            let missing = length $ filter isNothing ys-            error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++-                    " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++-                    concat ["\n  " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zip xs ys]
− src/Development/Shake/Rules/Oracle.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables, ConstraintKinds #-}-{-# LANGUAGE UndecidableInstances #-}--module Development.Shake.Rules.Oracle(-    addOracle, askOracle, askOracleWith-    ) where--import Development.Shake.Core-import Development.Shake.Classes-import Control.Applicative-import Prelude----- Use short type names, since the names appear in the Haddock, and are too long if they are in full-newtype OracleQ question = OracleQ question-    deriving (Show,Typeable,Eq,Hashable,Binary,NFData)-newtype OracleA answer = OracleA answer-    deriving (Show,Typeable,Eq,Hashable,Binary,NFData)--instance (ShakeValue q, ShakeValue a) => Rule (OracleQ q) (OracleA a) where-    storedValue _ _ = return Nothing----- | Add extra information which rules can depend on.---   An oracle is a function from a question type @q@, to an answer type @a@.---   As an example, we can define an oracle allowing you to depend on the current version of GHC:------ @--- newtype GhcVersion = GhcVersion () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)--- rules = do---     'addOracle' $ \\(GhcVersion _) -> fmap 'Development.Shake.fromStdout' $ 'Development.Shake.cmd' \"ghc --numeric-version\" :: Action String---     ... rules ...--- @------   If a rule calls @'askOracle' (GhcVersion ())@, that rule will be rerun whenever the GHC version changes.---   Some notes:------ * We define @GhcVersion@ with a @newtype@ around @()@, allowing the use of @GeneralizedNewtypeDeriving@.---   All the necessary type classes are exported from "Development.Shake.Classes".------ * Each call to 'addOracle' must use a different type of question.------ * Actions passed to 'addOracle' will be run in every build they are required, even if nothing else changes,---   so be careful of slow actions.---   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:------ @--- newtype GhcPkgList = GhcPkgList () deriving (Show,Typeable,Eq,Hashable,Binary,NFData)--- newtype GhcPkgVersion = GhcPkgVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)------ rules = do---     getPkgList \<- 'addOracle' $ \\GhcPkgList{} -> do---         Stdout out <- 'Development.Shake.cmd' \"ghc-pkg list --simple-output\"---         return [(reverse b, reverse a) | x <- words out, let (a,_:b) = break (== \'-\') $ reverse x]------     getPkgVersion \<- 'addOracle' $ \\(GhcPkgVersion pkg) -> do---         pkgs <- getPkgList $ GhcPkgList ()---         return $ lookup pkg pkgs------     \"myrule\" %> \\_ -> do---         getPkgVersion $ GhcPkgVersion \"shake\"---         ... rule using the shake version ...--- @------   Using these definitions, any rule depending on the version of @shake@---   should call @getPkgVersion $ GhcPkgVersion \"shake\"@ to rebuild when @shake@ is upgraded.-addOracle :: (ShakeValue q, ShakeValue a) => (q -> Action a) -> Rules (q -> Action a)-addOracle act = do-    rule $ \(OracleQ q) -> Just $ OracleA <$> act q-    return askOracle----- | Get information previously added with 'addOracle'. The question/answer types must match those provided---   to 'addOracle'.-askOracle :: (ShakeValue q, ShakeValue a) => q -> Action a-askOracle question = do OracleA answer <- apply1 $ OracleQ question; return answer---- | Get information previously added with 'addOracle'. The second argument is not used, but can---   be useful to fix the answer type, avoiding ambiguous type error messages.-askOracleWith :: (ShakeValue q, ShakeValue a) => q -> a -> Action a-askOracleWith question _ = askOracle question
− src/Development/Shake/Rules/OrderOnly.hs 
@@ -1,30 +0,0 @@--module Development.Shake.Rules.OrderOnly(-     orderOnly, orderOnlyBS-    ) where--import Development.Shake.Core-import Development.Shake.Rules.File-import qualified Data.ByteString.Char8 as BS----- | Define order-only dependencies, these are dependencies that will always---   be built before continuing, but which aren't dependencies of this action.---   Mostly useful for defining generated dependencies you think might be real dependencies.---   If they turn out to be real dependencies, you should add an explicit dependency afterwards.------ @--- \"source.o\" %> \\out -> do---     'orderOnly' [\"header.h\"]---     () <- 'cmd' \"gcc -c source.c -o source.o -MMD -MF source.m\"---     'neededMakefileDependencies' \"source.m\"--- @------   If @header.h@ is included by @source.c@ then the call to 'needMakefileDependencies' will cause---   it to be added as a real dependency. If it isn't, then the rule won't rebuild if it changes.-orderOnly :: [FilePath] -> Action ()-orderOnly = orderOnlyAction . need---orderOnlyBS :: [BS.ByteString] -> Action ()-orderOnlyBS = orderOnlyAction . needBS
− src/Development/Shake/Rules/Rerun.hs 
@@ -1,42 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}--module Development.Shake.Rules.Rerun(-    defaultRuleRerun, alwaysRerun-    ) where--import Development.Shake.Core-import Development.Shake.Classes---newtype AlwaysRerunQ = AlwaysRerunQ ()-    deriving (Typeable,Eq,Hashable,Binary,NFData)-instance Show AlwaysRerunQ where show _ = "alwaysRerun"--newtype AlwaysRerunA = AlwaysRerunA ()-    deriving (Typeable,Hashable,Binary,NFData)-instance Show AlwaysRerunA where show _ = "<none>"-instance Eq AlwaysRerunA where a == b = False--instance Rule AlwaysRerunQ AlwaysRerunA where-    storedValue _ _ = return Nothing----- | Always rerun the associated action. Useful for defining rules that query---   the environment. For example:------ @--- \"ghcVersion.txt\" 'Development.Shake.%>' \\out -> do---     'alwaysRerun'---     'Development.Shake.Stdout' stdout <- 'Development.Shake.cmd' \"ghc --numeric-version\"---     'Development.Shake.writeFileChanged' out stdout--- @------   In make, the @.PHONY@ attribute on file-producing rules has a similar effect.------   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 = do AlwaysRerunA _ <- apply1 $ AlwaysRerunQ (); return ()--defaultRuleRerun :: Rules ()-defaultRuleRerun = rule $ \AlwaysRerunQ{} -> Just $ return $ AlwaysRerunA()
− src/Development/Shake/Shake.hs 
@@ -1,27 +0,0 @@---- | The main entry point that calls all the default rules-module Development.Shake.Shake(shake) where--import Development.Shake.Types-import General.Timing-import Development.Shake.Core--import Development.Shake.Rules.Directory-import Development.Shake.Rules.File-import Development.Shake.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-        defaultRuleDirectory-        defaultRuleRerun-    return ()
− src/Development/Shake/Special.hs 
@@ -1,20 +0,0 @@---- | This module contains rule types that have special behaviour in some way.---   Everything in this module is a hack.-module Development.Shake.Special(-    specialAlwaysRebuilds,-    specialIsFileKey-    ) where--import Development.Shake.Value-import Data.Typeable---specialAlwaysRebuilds :: Value -> Bool-specialAlwaysRebuilds v = con `elem` ["AlwaysRerunA","OracleA"] || (con == "FileA" && show v == "File {mod=NEQ,size=NEQ,digest=NEQ}")-    where con = show $ fst $ splitTyConApp $ typeValue v---specialIsFileKey :: TypeRep -> Bool-specialIsFileKey t = con == "FileQ"-    where con = show $ fst $ splitTyConApp t
− src/Development/Shake/Storage.hs 
@@ -1,256 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternGuards, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-}-{--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--}--module Development.Shake.Storage(-    withStorage-    ) where--import General.Binary-import Development.Shake.Types-import General.Timing-import General.FileLock--import Data.Tuple.Extra-import Control.Exception.Extra-import Control.Monad.Extra-import Control.Concurrent.Extra-import Data.Binary.Get-import Data.Binary.Put-import Data.Time-import Data.Char-import Development.Shake.Classes-import qualified Data.HashMap.Strict as Map-import Data.List-import Numeric-import System.Directory-import System.Exit-import System.FilePath-import System.IO--import qualified Data.ByteString.Lazy.Char8 as LBS-import qualified Data.ByteString.Lazy as LBS8---type Map = Map.HashMap---- Increment every time the on-disk format/semantics change,--- @x@ is for the users version number-databaseVersion :: String -> String--- 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-11-" ++ 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---- Split the version off a file-splitVersion :: LBS.ByteString -> (LBS.ByteString, LBS.ByteString)-splitVersion abc = (a `LBS.append` b, c)-    where (a,bc) = LBS.break (== '\r') abc-          (b,c) = LBS.splitAt 2 bc---withStorage-    :: (Show k, Show v, Eq w, Eq k, Hashable k-       ,Binary w, BinaryWith w k, BinaryWith w v)-    => ShakeOptions             -- ^ Storage options-    -> (String -> IO ())        -- ^ Logging function-    -> w                        -- ^ Witness-    -> (Map k v -> (k -> v -> IO ()) -> IO a)  -- ^ Execute-    -> IO a-withStorage ShakeOptions{..} diagnostic witness act = do-  diagnostic $ "Before fileLock on " ++ shakeFiles </> ".shake.lock"-  withLockFile (shakeFiles </> ".shake.lock") $ do-    diagnostic "After fileLock"-    let dbfile = shakeFiles </> ".shake.database"-        bupfile = shakeFiles </> ".shake.backup"-    createDirectoryIfMissing True shakeFiles--    -- complete a partially failed compress-    b <- doesFileExist bupfile-    when b $ do-        unexpected "Backup file exists, restoring over the previous file\n"-        diagnostic "Backup file move to original"-        ignore $ removeFile dbfile-        renameFile bupfile dbfile--    addTiming "Database read"-    withBinaryFile dbfile ReadWriteMode $ \h -> do-        n <- hFileSize h-        diagnostic $ "Reading file of size " ++ show n-        (oldVer,src) <- fmap splitVersion $ LBS.hGet h $ fromInteger n--        verEqual <- evaluate $ ver == oldVer -- force it so we don't leak the bytestring-        if not verEqual && not shakeVersionIgnore then do-            unless (n == 0) $ 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 (LBS.unpack ver)-                    ,"  Found:     " ++ disp (limit $ LBS.unpack oldVer)-                    ,"All rules will be rebuilt"]-            continue h Map.empty-         else-            -- make sure you are not handling exceptions from inside-            join $ handleBool (not . asyncException) (\err -> do-                msg <- showException err-                outputErr $ unlines $-                    ("Error when reading Shake database " ++ dbfile) :-                    map ("  "++) (lines msg) ++-                    ["All files will be rebuilt"]-                when shakeStorageLog $ do-                    hSeek h AbsoluteSeek 0-                    i <- hFileSize h-                    bs <- LBS.hGet h $ fromInteger i-                    let cor = shakeFiles </> ".shake.corrupt"-                    LBS.writeFile cor bs-                    unexpected $ "Backup of corrupted file stored at " ++ cor ++ ", " ++ show i ++ " bytes\n"--                -- exitFailure -- should never happen without external corruption-                               -- add back to check during random testing-                return $ continue h Map.empty) $-                case readChunks src of-                    ([], slop) -> do-                        when (LBS.length slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n"-                        diagnostic $ "Read 0 chunks, plus " ++ show slop ++ " slop"-                        return $ continue h Map.empty-                    (w:xs, slopRaw) -> do-                        let slop = fromIntegral $ LBS.length slopRaw-                        when (slop > 0) $ unexpected $ "Last " ++ show slop ++ " bytes do not form a whole record\n"-                        diagnostic $ "Read " ++ show (length xs + 1) ++ " chunks, plus " ++ show slop ++ " slop"-                        let ws = decode w-                            f mp (k, v) = Map.insert k v mp-                            ents = map (runGet $ getWith ws) xs-                            mp = foldl' f Map.empty ents--                        when (shakeVerbosity == Diagnostic) $ do-                            let raw x = "[len " ++ show (LBS.length x) ++ "] " ++ concat-                                        [['0' | length c == 1] ++ c | x <- LBS8.unpack x, let c = showHex x ""]-                            let pretty (Left x) = "FAILURE: " ++ show x-                                pretty (Right x) = x-                            diagnostic $ "Witnesses " ++ raw w-                            forM_ (zip3 [1..] xs ents) $ \(i,x,ent) -> do-                                x2 <- try_ $ evaluate $ let s = show ent in rnf s `seq` s-                                diagnostic $ "Chunk " ++ show i ++ " " ++ raw x ++ " " ++ pretty x2-                            diagnostic $ "Slop " ++ raw slopRaw--                        diagnostic $ "Found " ++ show (Map.size mp) ++ " real entries"--                        -- if mp is null, continue will reset it, so no need to clean up-                        if verEqual && (Map.null mp || (ws == witness && Map.size mp * 2 > length xs - 2)) then do-                            -- make sure we reset to before the slop-                            when (not (Map.null mp) && slop /= 0) $ do-                                diagnostic $ "Dropping last " ++ show slop ++ " bytes of database (incomplete)"-                                now <- hFileSize h-                                hSetFileSize h $ now - slop-                                hSeek h AbsoluteSeek $ now - slop-                                hFlush h-                                diagnostic "Drop complete"-                            return $ continue h mp-                         else do-                            addTiming "Database compression"-                            unexpected "Compressing database\n"-                            diagnostic "Compressing database"-                            hClose h -- two hClose are fine-                            return $ do-                                renameFile dbfile bupfile-                                withBinaryFile dbfile ReadWriteMode $ \h -> do-                                    reset h mp-                                    removeFile bupfile-                                    diagnostic "Compression complete"-                                    continue h mp-    where-        unexpected x = when shakeStorageLog $ do-            t <- getCurrentTime-            appendFile (shakeFiles </> ".shake.storage.log") $ "\n[" ++ show t ++ "]: " ++ x-        outputErr x = do-            when (shakeVerbosity >= Quiet) $ shakeOutput Quiet x-            unexpected x--        ver = LBS.pack $ databaseVersion shakeVersion--        writeChunk h s = do-            diagnostic $ "Writing chunk " ++ show (LBS.length s)-            LBS.hPut h $ toChunk s--        reset h mp = do-            diagnostic $ "Resetting database to " ++ show (Map.size mp) ++ " elements"-            hSetFileSize h 0-            hSeek h AbsoluteSeek 0-            LBS.hPut h ver-            writeChunk h $ encode witness-            mapM_ (writeChunk h . runPut . putWith witness) $ Map.toList mp-            hFlush h-            diagnostic "Flush"--        -- continuation (since if we do a compress, h changes)-        continue h mp = do-            when (Map.null mp) $-                reset h mp -- might as well, no data to lose, and need to ensure a good witness table-                           -- also lets us recover in the case of corruption-            flushThread shakeFlush h $ \out -> do-                addTiming "With database"-                act mp $ \k v -> out $ toChunk $ runPut $ putWith witness (k, v)----- We avoid calling flush too often on SSD drives, as that can be slow--- Make sure all exceptions happen on the caller, so we don't have to move exceptions back--- Make sure we only write on one thread, otherwise async exceptions can cause partial writes-flushThread :: Maybe Double -> Handle -> ((LBS.ByteString -> IO ()) -> IO a) -> IO a-flushThread flush h act = do-    chan <- newChan -- operations to perform on the file-    kick <- newEmptyMVar -- kicked whenever something is written-    died <- newBarrier -- has the writing thread finished--    flusher <- case flush of-        Nothing -> return Nothing-        Just flush -> fmap Just $ forkIO $ forever $ do-            takeMVar kick-            threadDelay $ ceiling $ flush * 1000000-            tryTakeMVar kick-            writeChan chan $ hFlush h >> return True--    root <- myThreadId-    writer <- forkIO $ handle_ (\e -> signalBarrier died () >> throwTo root e) $-        -- only one thread ever writes, ensuring only the final write can be torn-        whileM $ join $ readChan chan--    (act $ \s -> do-            evaluate $ LBS.length s -- ensure exceptions occur on this thread-            writeChan chan $ LBS.hPut h s >> tryPutMVar kick () >> return True)-        `finally` do-            maybe (return ()) killThread flusher-            writeChan chan $ signalBarrier died () >> return False-            waitBarrier died----- Return the amount of junk at the end, along with all the chunk-readChunks :: LBS.ByteString -> ([LBS.ByteString], LBS.ByteString)-readChunks x-    | Just (n, x) <- grab 4 x-    , Just (y, x) <- grab (fromIntegral (decode n :: Word32)) x-    = first (y :) $ readChunks x-    | otherwise = ([], x)-    where-        grab i x | LBS.length a == i = Just (a, b)-                 | otherwise = Nothing-            where (a,b) = LBS.splitAt i x---toChunk :: LBS.ByteString -> LBS.ByteString-toChunk x = n `LBS.append` x-    where n = encode (fromIntegral $ LBS.length x :: Word32)----- | Is the exception asyncronous, not a "coding error" that should be ignored-asyncException :: SomeException -> Bool-asyncException e-    | Just (_ :: AsyncException) <- fromException e = True-    | Just (_ :: ExitCode) <- fromException e = True-    | otherwise = False
− src/Development/Shake/Types.hs 
@@ -1,248 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}---- | Types exposed to the user-module Development.Shake.Types(-    Progress(..), Verbosity(..), Assume(..), Lint(..), Change(..), EqualCost(..),-    ShakeOptions(..), shakeOptions-    ) where--import Data.Data-import Data.List-import Data.Dynamic-import qualified Data.HashMap.Strict as HashMap-import Development.Shake.Progress-import Development.Shake.FilePattern-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.UTF8 as UTF8-import Development.Shake.CmdOption----- | The current assumptions made by the build system, used by 'shakeAssume'. These options---   allow the end user to specify that any rules run are either to be treated as clean, or as---   dirty, regardless of what the build system thinks.------   These assumptions only operate on files reached by the current 'Development.Shake.action' commands. Any---   other files in the database are left unchanged.-data Assume-    = AssumeDirty-        -- ^ Assume that all rules reached are dirty and require rebuilding, equivalent to 'Development.Shake.Rule.storedValue' always-        --   returning 'Nothing'. Useful to undo the results of 'AssumeClean', for benchmarking rebuild speed and-        --   for rebuilding if untracked dependencies have changed. This assumption is safe, but may cause-        --   more rebuilding than necessary.-    | AssumeClean-        -- ^ /This assumption is unsafe, and may lead to incorrect build results in this run, and in future runs/.-        --   Assume and record that all rules reached are clean and do not require rebuilding, provided the rule-        --   has a 'Development.Shake.Rule.storedValue' and has been built before. Useful if you have modified a file in some-        --   inconsequential way, such as only the comments or whitespace, and wish to avoid a rebuild.-    | AssumeSkip-        -- ^ /This assumption is unsafe, and may lead to incorrect build results in this run/.-        --   Assume that all rules reached are clean in this run. Only useful for benchmarking, to remove any overhead-        --   from running 'Development.Shake.Rule.storedValue' operations.-      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)----- | Which lint checks to perform, used by 'shakeLint'.-data Lint-    = LintBasic-        -- ^ The most basic form of linting. Checks that the current directory does not change and that results do not change after they-        --   are first written. Any calls to 'needed' will assert that they do not cause a rule to be rebuilt.-    | LintFSATrace-        -- ^ Track which files are accessed by command line programs-        -- using <https://github.com/jacereda/fsatrace fsatrace>.-      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)----- | How should you determine if a file has changed, used by 'shakeChange'. The most common values are---   'ChangeModtime' (very fast, @touch@ causes files to rebuild) and 'ChangeModtimeAndDigestInput'---   (a bit slower, @touch@ does not cause input files to rebuild).-data Change-    = ChangeModtime-        -- ^ Compare equality of modification timestamps, a file has changed if its last modified time changes.-        --   A @touch@ will force a rebuild. This mode is fast and usually sufficiently accurate, so is the default.-    | ChangeDigest-        -- ^ Compare equality of file contents digests, a file has changed if its digest changes.-        --   A @touch@ will not force a rebuild. Use this mode if modification times on your file system are unreliable.-    | ChangeModtimeAndDigest-        -- ^ A file is rebuilt if both its modification time and digest have changed. For efficiency reasons, the modification-        --   time is checked first, and if that has changed, the digest is checked.-    | ChangeModtimeAndDigestInput-        -- ^ Use 'ChangeModtimeAndDigest' for input\/source files and 'ChangeModtime' for output files.-    | ChangeModtimeOrDigest-        -- ^ A file is rebuilt if either its modification time or its digest has changed. A @touch@ will force a rebuild,-        --   but even if a files modification time is reset afterwards, changes will also cause a rebuild.-      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)----- | Options to control the execution of Shake, usually specified by overriding fields in---   'shakeOptions':------   @ 'shakeOptions'{'shakeThreads'=4, 'shakeReport'=[\"report.html\"]} @------   The 'Data' instance for this type reports the 'shakeProgress' and 'shakeOutput' fields as having the abstract type 'Hidden',---   because 'Data' cannot be defined for functions or 'TypeRep's.-data ShakeOptions = ShakeOptions-    {shakeFiles :: FilePath-        -- ^ 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.-    ,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-        --   works well. Use @0@ to match the detected number of processors (when @0@, 'getShakeOptions' will-        --   return the number of threads used).-    ,shakeVersion :: String-        -- ^ Defaults to @"1"@. The version number of your build rules.-        --   Change the version number to force a complete rebuild, such as when making-        --   significant changes to the rules that require a wipe. The version number should be-        --   set in the source code, and not passed on the command line.-    ,shakeVerbosity :: Verbosity-        -- ^ Defaults to 'Normal'. What level of messages should be printed out.-    ,shakeStaunch :: Bool-        -- ^ Defaults to 'False'. Operate in staunch mode, where building continues even after errors,-        --   similar to @make --keep-going@.-    ,shakeReport :: [FilePath]-        -- ^ Defaults to @[]@. Write a profiling report to a file, showing which rules rebuilt,-        --   why, and how much time they took. Useful for improving the speed of your build systems.-        --   If the file extension is @.json@ it will write JSON data; if @.js@ it will write Javascript;-        --   if @.trace@ it will write trace events (load into @about:\/\/tracing@ in Chrome);-        --   otherwise it will write HTML.-    ,shakeLint :: Maybe Lint-        -- ^ Defaults to 'Nothing'. Perform sanity checks during building, see 'Lint' for details.-    ,shakeLintInside :: [FilePath]-        -- ^ Directories in which the files will be tracked by the linter.-    ,shakeLintIgnore :: [FilePattern]-        -- ^ File patterns which are ignored from linter tracking, a bit like calling 'Development.Shake.trackAllow' in every rule.-    ,shakeCommandOptions :: [CmdOption]-        -- ^ Defaults to @[]@. Additional options to be passed to all command invocations.-    ,shakeFlush :: Maybe Double-        -- ^ Defaults to @'Just' 10@. How often to flush Shake metadata files in seconds, or 'Nothing' to never flush explicitly.-        --   It is possible that on abnormal termination (not Haskell exceptions) any rules that completed in the last-        --   'shakeFlush' seconds will be lost.-    ,shakeAssume :: Maybe Assume-        -- ^ Defaults to 'Nothing'. Assume all build objects are clean/dirty, see 'Assume' for details.-        --   Can be used to implement @make --touch@.-    ,shakeAbbreviations :: [(String,String)]-        -- ^ Defaults to @[]@. A list of substrings that should be abbreviated in status messages, and their corresponding abbreviation.-        --   Commonly used to replace the long paths (e.g. @.make\/i586-linux-gcc\/output@) with an abbreviation (e.g. @$OUT@).-    ,shakeStorageLog :: Bool-        -- ^ Defaults to 'False'. Write a message to @'shakeFiles'\/.shake.storage.log@ whenever a storage event happens which may impact-        --   on the current stored progress. Examples include database version number changes, database compaction or corrupt files.-    ,shakeLineBuffering :: Bool-        -- ^ Defaults to 'True'. Change 'stdout' and 'stderr' to line buffering while running Shake.-    ,shakeTimings :: Bool-        -- ^ Defaults to 'False'. Print timing information for each stage at the end.-    ,shakeRunCommands :: Bool-        -- ^ Default to 'True'. Should you run command line actions, set to 'False' to skip actions whose output streams and exit code-        --   are not used. Useful for profiling the non-command portion of the build system.-    ,shakeChange :: Change-        -- ^ Default to 'ChangeModtime'. How to check if a file has changed, see 'Change' for details.-    ,shakeCreationCheck :: Bool-        -- ^ Default to 'True'. After running a rule to create a file, is it an error if the file does not exist.-        --   Provided for compatibility with @make@ and @ninja@ (which have ugly file creation semantics).----    ,shakeOutputCheck :: Bool---        -- ^ Default to 'True'. If a file produced by a rule changes, should you rebuild it.-    ,shakeLiveFiles :: [FilePath]-        -- ^ Default to @[]@. After the build system completes, write a list of all files which were /live/ in that run,-        --   i.e. those which Shake checked were valid or rebuilt. Produces best answers if nothing rebuilds.-    ,shakeVersionIgnore :: Bool-        -- ^ Defaults to 'False'. Ignore any differences in 'shakeVersion'.-    ,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.-        --   For applications that want to display progress messages, 'progressSimple' is often sufficient, but more advanced-        --   users should look at the 'Progress' data type.-    ,shakeOutput :: Verbosity -> String -> IO ()-        -- ^ Defaults to writing using 'putStrLn'. A function called to output messages from Shake, along with the 'Verbosity' at-        --   which that message should be printed. This function will be called atomically from all other 'shakeOutput' functions.-        --   The 'Verbosity' will always be greater than or higher than 'shakeVerbosity'.-    ,shakeExtra :: HashMap.HashMap TypeRep Dynamic-        -- ^ This a map which can be used to store arbitrary extra-        --   information that a user may need when writing 'Rule's.  The-        --   correct way to use this is to define a (hidden) newtype to-        --   use as a key, so that conflicts cannot occur.-    }-    deriving Typeable---- | The default set of 'ShakeOptions'.-shakeOptions :: ShakeOptions-shakeOptions = ShakeOptions-    ".shake" 1 "1" Normal False [] Nothing [] [] [] (Just 10) Nothing [] False True False-    True ChangeModtime True [] False-    (const $ return ())-    (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS-    HashMap.empty--fieldsShakeOptions =-    ["shakeFiles", "shakeThreads", "shakeVersion", "shakeVerbosity", "shakeStaunch", "shakeReport"-    ,"shakeLint", "shakeLintInside", "shakeLintIgnore", "shakeCommandOptions"-    ,"shakeFlush", "shakeAssume", "shakeAbbreviations", "shakeStorageLog"-    ,"shakeLineBuffering", "shakeTimings", "shakeRunCommands", "shakeChange", "shakeCreationCheck"-    ,"shakeLiveFiles","shakeVersionIgnore","shakeProgress", "shakeOutput", "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 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 (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 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`-        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 $ z unhide-    toConstr ShakeOptions{} = conShakeOptions-    dataTypeOf _ = tyShakeOptions--instance Show ShakeOptions where-    show x = "ShakeOptions {" ++ intercalate ", " inner ++ "}"-        where-            inner = zipWith (\x y -> x ++ " = " ++ y) fieldsShakeOptions $ gmapQ f x--            f x | Just x <- cast x = show (x :: Int)-                | Just x <- cast x = show (x :: FilePath)-                | Just x <- cast x = show (x :: Verbosity)-                | Just x <- cast x = show (x :: Change)-                | Just x <- cast x = show (x :: Bool)-                | Just x <- cast x = show (x :: [FilePath])-                | Just x <- cast x = show (x :: Maybe Assume)-                | Just x <- cast x = show (x :: Maybe Lint)-                | Just x <- cast x = show (x :: Maybe Double)-                | 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 ()))-                | Just x <- cast x = show (x :: Hidden (HashMap.HashMap TypeRep Dynamic))-                | Just x <- cast x = show (x :: [CmdOption])-                | otherwise = error $ "Error while showing ShakeOptions, missing alternative for " ++ show (typeOf x)----- | Internal type, copied from Hide in Uniplate-newtype Hidden a = Hidden {fromHidden :: a}-    deriving Typeable--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"-    toConstr _ = error "Development.Shake.Types.ShakeProgress: toConstr not implemented - data type has no constructors"-    dataTypeOf _ = tyHidden--tyHidden = mkDataType "Development.Shake.Types.Hidden" []----- | The verbosity data type, used by 'shakeVerbosity'.-data Verbosity-    = Silent -- ^ Don't print any messages.-    | Quiet  -- ^ Only print essential messages, typically errors.-    | Normal -- ^ Print errors and @# /command-name/ (for /file-name/)@ when running a 'Development.Shake.traced' command.-    | Loud   -- ^ Print errors and full command lines when running a 'Development.Shake.command' or 'Development.Shake.cmd' command.-    | Chatty -- ^ Print errors, full command line and status messages when starting a rule.-    | Diagnostic -- ^ Print messages for virtually everything (mostly for debugging).-      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)---- | An equality check and a cost.-data EqualCost-    = EqualCheap -- ^ The equality check was cheap.-    | EqualExpensive -- ^ The equality check was expensive, as the results are not trivially equal.-    | NotEqual -- ^ The values are not equal.-      deriving (Eq,Ord,Show,Read,Typeable,Data,Enum,Bounded)
src/Development/Shake/Util.hs view
@@ -6,13 +6,13 @@     ) where  import Development.Shake-import Development.Shake.Rules.File+import Development.Shake.Internal.Rules.File import qualified Data.ByteString.Char8 as BS-import qualified Development.Shake.ByteString as BS+import qualified General.Makefile as BS import Data.Tuple.Extra import Control.Applicative import Data.List-import System.Console.GetOpt+import General.GetOpt import Data.IORef import Data.Maybe import Control.Monad.Extra@@ -76,7 +76,7 @@ -- | A version of 'shakeArgsPrune' that also takes a list of extra options to use. shakeArgsPruneWith :: ShakeOptions -> ([FilePath] -> IO ()) -> [OptDescr (Either String a)] -> ([a] -> [String] -> IO (Maybe (Rules ()))) -> IO () shakeArgsPruneWith opts prune flags act = do-    let flags2 = Option "P" ["prune"] (NoArg $ Right Nothing) "Remove stale files" : map (fmapOptDescr $ fmap Just) flags+    let flags2 = Option "P" ["prune"] (NoArg $ Right Nothing) "Remove stale files" : map (fmapOptDescr Just) flags     pruning <- newIORef False     shakeArgsWith opts flags2 $ \opts args ->         if any isNothing opts then do@@ -90,12 +90,3 @@                 act (catMaybes opts) args             src <- lines <$> IO.readFile' file             prune src---- fmap is only an instance in later GHC versions, so fake our own version-fmapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b-fmapOptDescr f (Option a b argDescr c) = Option a b (fmapArgDescr f argDescr) c--fmapArgDescr :: (a -> b) -> ArgDescr a -> ArgDescr b-fmapArgDescr f (NoArg a)    = NoArg (f a)-fmapArgDescr f (ReqArg g s) = ReqArg (f . g) s-fmapArgDescr f (OptArg g s) = OptArg (f . g) s
− src/Development/Shake/Value.hs 
@@ -1,172 +0,0 @@-{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ConstraintKinds #-}--{- |-This module implements the Key/Value types, to abstract over hetrogenous data types.--}-module Development.Shake.Value(-    Value, newValue, fromValue, typeValue,-    Key, newKey, fromKey, typeKey,-    Witness, currentWitness, registerWitness,-    ShakeValue-    ) where--import General.Binary-import Development.Shake.Classes-import Development.Shake.Errors-import Data.Typeable--import Data.Bits-import Data.Function-import Data.IORef-import Data.List-import Data.Maybe-import qualified Data.HashMap.Strict as Map-import qualified Data.ByteString.Char8 as BS-import System.IO.Unsafe---- | Define an alias for the six type classes required for things involved in Shake 'Development.Shake.Rule's.---   Using this alias requires the @ConstraintKinds@ extension.------   To define your own values meeting the necessary constraints it is convenient to use the extensions---   @GeneralizedNewtypeDeriving@ and @DeriveDataTypeable@ to write:------ > newtype MyType = MyType (String, Bool) deriving (Show, Typeable, Eq, Hashable, Binary, NFData)------   Shake needs these instances on keys and values. They are used for:------ * 'Show' is used to print out keys in errors, profiling, progress messages---   and diagnostics.------ * 'Typeable' is used because Shake indexes its database by the---   type of the key and value involved in the rule (overlap is not---   allowed for type classes and not allowed in Shake either).------ * 'Eq' and 'Hashable' are used on keys in order to build hash maps---   from keys to values.  'Eq' is used on values to test if the value---   has changed or not (this is used to support unchanging rebuilds,---   where Shake can avoid rerunning rules if it runs a dependency,---   but it turns out that no changes occurred.)  The 'Hashable'---   instances are only use at runtime (never serialised to disk),---   so they do not have to be stable across runs.---   Hashable on values is not used, and only required for a consistent interface.------ * 'Binary' is used to serialize keys and values into Shake's---   build database; this lets Shake cache values across runs and---   implement unchanging rebuilds.------ * 'NFData' is used to avoid space and thunk leaks, especially---   when Shake is parallelized.-type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, Binary a, NFData a)---- We deliberately avoid Typeable instances on Key/Value to stop them accidentally--- being used inside themselves-newtype Key = Key Value-    deriving (Eq,Hashable,NFData,BinaryWith Witness)--data Value = forall a . ShakeValue a => Value a---newKey :: ShakeValue a => a -> Key-newKey = Key . newValue--newValue :: ShakeValue a => a -> Value-newValue = Value--typeKey :: Key -> TypeRep-typeKey (Key v) = typeValue v--typeValue :: Value -> TypeRep-typeValue (Value x) = typeOf x--fromKey :: Typeable a => Key -> a-fromKey (Key v) = fromValue v--fromValue :: Typeable a => Value -> a-fromValue (Value x) = fromMaybe (err "fromValue, bad cast") $ cast x--instance Show Key where-    show (Key a) = show a--instance Show Value where-    show (Value a) = show a--instance NFData Value where-    rnf (Value a) = rnf a--instance Hashable Value where-    hashWithSalt salt (Value a) = hashWithSalt salt (typeOf a) `xor` hashWithSalt salt a--instance Eq Value where-    Value a == Value b = maybe False (a ==) $ cast b-    Value a /= Value b = maybe True (a /=) $ cast b--------------------------------------------------------------------------- BINARY INSTANCES--{-# NOINLINE witness #-}-witness :: IORef (Map.HashMap TypeRep Value)-witness = unsafePerformIO $ newIORef Map.empty--registerWitness :: ShakeValue a => a -> IO ()-registerWitness x = atomicModifyIORef witness $ \mp -> (Map.insert (typeOf x) (Value $ err msg `asTypeOf` x) mp, ())-    where msg = "registerWitness, type " ++ show (typeOf x)----- Produce a list in a predictable order from a Map TypeRep, which should be consistent regardless of the order--- elements were added and stable between program executions.--- Cannot rely on hash (not pure in hashable-1.2) or compare (not available before 7.2)-toStableList :: Map.HashMap TypeRep v -> [(TypeRep,v)]-toStableList = sortBy (compare `on` show . fst) . Map.toList---data Witness = Witness-    {typeNames :: [String] -- the canonical data, the names of the types-    ,witnessIn :: Map.HashMap Word16 Value -- for reading in, the find the values (some may be missing)-    ,witnessOut :: Map.HashMap TypeRep Word16 -- for writing out, find the value-    } deriving Show--instance Eq Witness where-    -- Type names are produced by toStableList so should to remain consistent-    -- regardless of the order of registerWitness calls.-    a == b = typeNames a == typeNames b--currentWitness :: IO Witness-currentWitness = do-    ws <- readIORef witness-    let (ks,vs) = unzip $ toStableList ws-    return $ Witness (map show ks) (Map.fromList $ zip [0..] vs) (Map.fromList $ zip ks [0..])---instance Binary Witness where-    put (Witness ts _ _) = put $ BS.unlines $ map BS.pack ts-    get = do-        ts <- fmap (map BS.unpack . BS.lines) get-        let ws = toStableList $ unsafePerformIO $ readIORefAfter ts witness-        let (is,ks,vs) = unzip3 [(i,k,v) | (i,t) <- zip [0..] ts, (k,v):_ <- [filter ((==) t . show . fst) ws]]-        return $ Witness ts (Map.fromList $ zip is vs) (Map.fromList $ zip ks is)-        where-            -- Read an IORef after examining a variable, used to avoid GHC over-optimisation-            {-# NOINLINE readIORefAfter #-}-            readIORefAfter :: a -> IORef b -> IO b-            readIORefAfter v ref = v `seq` readIORef ref---instance BinaryWith Witness Value where-    putWith ws (Value x) = do-        let msg = "no witness for " ++ show (typeOf x)-        put $ fromMaybe (error msg) $ Map.lookup (typeOf x) (witnessOut ws)-        put x--    getWith ws = do-        h <- get-        case Map.lookup h $ witnessIn ws of-            Nothing | h >= 0 && h < genericLength (typeNames ws) -> error $-                "Failed to find a type " ++ (typeNames ws !! fromIntegral h) ++ " which is stored in the database.\n" ++-                "The most likely cause is that your build tool has changed significantly."-            Nothing -> error $-                -- should not happen, unless proper data corruption-                "Corruption when reading Value, got type " ++ show h ++ ", but should be in range 0.." ++ show (length (typeNames ws) - 1)-            Just (Value t) -> do-                x <- get-                return $ Value $ x `asTypeOf` t
src/General/Bilist.hs view
@@ -1,4 +1,5 @@ +-- | List type that supports O(1) amortized 'cons', 'snoc', 'uncons' and 'isEmpty'. module General.Bilist(     Bilist, cons, snoc, uncons, toList, isEmpty     ) where
src/General/Binary.hs view
@@ -1,63 +1,222 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE FlexibleInstances, ExplicitForAll, ScopedTypeVariables, Rank2Types #-}  module General.Binary(-    BinaryWith(..), module Data.Binary,-    BinList(..), BinFloat(..)+    BinaryOp(..),+    binarySplit, binarySplit2, binarySplit3, unsafeBinarySplit,+    Builder(..), runBuilder, sizeBuilder,+    BinaryEx(..),+    putExStorable, getExStorable, putExStorableList, getExStorableList,+    putExList, getExList, putExN, getExN     ) where -import Control.Applicative import Control.Monad import Data.Binary-import Data.List-import Foreign+import Data.List.Extra+import Data.Tuple.Extra+import Foreign.Storable+import Foreign.Ptr import System.IO.Unsafe as U+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.UTF8 as UTF8+import Data.Functor+import Data.Monoid+import Prelude  -class BinaryWith ctx a where-    putWith :: ctx -> a -> Put-    getWith :: ctx -> Get a+---------------------------------------------------------------------+-- STORE TYPE -instance (BinaryWith ctx a, BinaryWith ctx b) => BinaryWith ctx (a,b) where-    putWith ctx (a,b) = putWith ctx a >> putWith ctx b-    getWith ctx = liftA2 (,) (getWith ctx) (getWith ctx)+-- | An explicit and more efficient version of Binary+data BinaryOp v = BinaryOp+    {putOp :: v -> Builder+    ,getOp :: BS.ByteString -> v+    } -instance BinaryWith ctx a => BinaryWith ctx [a] where-    putWith ctx xs = put (length xs) >> mapM_ (putWith ctx) xs-    getWith ctx = do n <- get; replicateM n $ getWith ctx+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 -instance BinaryWith ctx a => BinaryWith ctx (Maybe a) where-    putWith _ Nothing = putWord8 0-    putWith ctx (Just x) = putWord8 1 >> putWith ctx x-    getWith ctx = do i <- getWord8; if i == 0 then return Nothing else Just <$> getWith ctx+binarySplit2 :: forall a b . (Storable a, Storable b) => BS.ByteString -> (a, b, BS.ByteString)+binarySplit2 bs | BS.length bs < sizeOf (undefined :: a) + sizeOf (undefined :: b) = error "Reading from ByteString, insufficient left"+                | (a,bs) <- unsafeBinarySplit bs, (b,bs) <- unsafeBinarySplit bs = (a,b,bs) +binarySplit3 :: forall a b c . (Storable a, Storable b, Storable c) => BS.ByteString -> (a, b, c, BS.ByteString)+binarySplit3 bs | BS.length bs < sizeOf (undefined :: a) + sizeOf (undefined :: b) + sizeOf (undefined :: c) = error "Reading from ByteString, insufficient left"+                | (a,bs) <- unsafeBinarySplit bs, (b,bs) <- unsafeBinarySplit bs, (c,bs) <- unsafeBinarySplit bs = (a,b,c,bs) -newtype BinList a = BinList {fromBinList :: [a]} -instance Show a => Show (BinList a) where show = show . fromBinList+unsafeBinarySplit :: Storable a => BS.ByteString -> (a, BS.ByteString)+unsafeBinarySplit bs = (v, BS.unsafeDrop (sizeOf v) bs)+    where v = unsafePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> peek (castPtr ptr) -instance Binary a => Binary (BinList a) where-    put (BinList xs) = case splitAt 254 xs of-        (_, []) -> putWord8 (genericLength xs) >> mapM_ put xs-        (a, b) -> putWord8 255 >> mapM_ put a >> put (BinList b)-    get = do-        x <- getWord8-        case x of-            255 -> do xs <- replicateM 254 get; BinList ys <- get; return $ BinList $ xs ++ ys-            n -> BinList <$> replicateM (fromInteger $ toInteger n) get +-- forM for zipWith+for2M_ as bs f = zipWithM_ f as bs -newtype BinFloat = BinFloat {fromBinFloat :: Float}+---------------------------------------------------------------------+-- BINARY SERIALISATION -instance Show BinFloat where show = show . fromBinFloat+-- We can't use the Data.ByteString builder as that doesn't track the size of the chunk.+data Builder = Builder {-# UNPACK #-} !Int (forall a . Ptr a -> Int -> IO ()) -instance Binary BinFloat where-    put (BinFloat x) = put (convert x :: Word32)-    get = fmap (BinFloat . convert) (get :: Get Word32)+sizeBuilder :: Builder -> Int+sizeBuilder (Builder i _) = i +runBuilder :: Builder -> BS.ByteString+runBuilder (Builder i f) = unsafePerformIO $ BS.create i $ \ptr -> f ptr 0 --- Originally from data-binary-ieee754 package+instance Monoid Builder where+    mempty = Builder 0 $ \_ _ -> return ()+    mappend (Builder x1 x2) (Builder y1 y2) = Builder (x1+y1) $ \p i -> do x2 p i; y2 p $ i+x1 -convert :: (Storable a, Storable b) => a -> b-convert x = U.unsafePerformIO $ alloca $ \buf -> do-    poke (castPtr buf) x-    peek buf++-- | Methods for Binary serialisation that go directly between strict ByteString values.+--   When the Database is read each key/value will be loaded as a separate ByteString,+--   and for certain types (e.g. file rules) this may remain the preferred format for storing keys.+--   Optimised for performance.+class BinaryEx a where+    putEx :: a -> Builder+    getEx :: BS.ByteString -> a++instance BinaryEx BS.ByteString where+    putEx x = Builder n $ \ptr i -> BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)+        where n = BS.length x+    getEx = id++instance BinaryEx LBS.ByteString where+    putEx x = Builder (fromIntegral $ LBS.length x) $ \ptr i -> do+        let go i [] = return ()+            go i (x:xs) = do+                let n = BS.length x+                BS.useAsCString x $ \bs -> BS.memcpy (ptr `plusPtr` i) (castPtr bs) (fromIntegral n)+                go (i+n) xs+        go i $ LBS.toChunks x+    getEx = LBS.fromChunks . return++instance BinaryEx [BS.ByteString] where+    -- Format:+    -- n :: Word32 - number of strings+    -- ns :: [Word32]{n} - length of each string+    -- contents of each string concatenated (sum ns bytes)+    putEx xs = Builder (4 + (n * 4) + sum ns) $ \p i -> do+        pokeByteOff p i (fromIntegral n :: Word32)+        for2M_ [4+i,8+i..] ns $ \i x -> pokeByteOff p i (fromIntegral x :: Word32)+        p <- return $ p `plusPtr` (i + 4 + (n * 4))+        for2M_ (scanl (+) 0 ns) xs $ \i x -> BS.useAsCStringLen x $ \(bs, n) ->+            BS.memcpy (p `plusPtr` i) (castPtr bs) (fromIntegral n)+        where ns = map BS.length xs+              n = length ns++    getEx bs = unsafePerformIO $ BS.useAsCString bs $ \p -> do+        n <- fromIntegral <$> (peekByteOff p 0 :: IO Word32)+        ns :: [Word32] <- forM [1..fromIntegral n] $ \i -> peekByteOff p (i * 4)+        return $ snd $ mapAccumL (\bs i -> swap $ BS.splitAt (fromIntegral i) bs) (BS.drop (4 + (n * 4)) bs) ns++instance BinaryEx () where+    putEx () = mempty+    getEx _ = ()++instance BinaryEx String where+    putEx = putEx . UTF8.fromString+    getEx = UTF8.toString++instance BinaryEx (Maybe String) where+    putEx Nothing = mempty+    putEx (Just xs) = putEx $ UTF8.fromString $ '\0' : xs+    getEx = fmap snd . uncons . UTF8.toString++instance BinaryEx [String] where+    putEx = putEx . map UTF8.fromString+    getEx = map UTF8.toString . getEx++instance BinaryEx (String, [String]) where+    putEx (a,bs) = putEx $ a:bs+    getEx x = let a:bs = getEx x in (a,bs)++instance BinaryEx Bool where+    putEx False = Builder 1 $ \ptr i -> pokeByteOff ptr i (0 :: Word8)+    putEx True = mempty+    getEx = BS.null++instance BinaryEx Word8 where+    putEx = putExStorable+    getEx = getExStorable++instance BinaryEx Word16 where+    putEx = putExStorable+    getEx = getExStorable++instance BinaryEx Word32 where+    putEx = putExStorable+    getEx = getExStorable++instance BinaryEx Int where+    putEx = putExStorable+    getEx = getExStorable++instance BinaryEx Float where+    putEx = putExStorable+    getEx = getExStorable+++putExStorable :: forall a . Storable a => a -> Builder+putExStorable x = Builder (sizeOf x) $ \p i -> pokeByteOff p i x++getExStorable :: forall a . Storable a => BS.ByteString -> a+getExStorable = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) ->+        if size /= n then error "size mismatch" else peek (castPtr p)+    where n = sizeOf (undefined :: a)+++putExStorableList :: forall a . Storable a => [a] -> Builder+putExStorableList xs = Builder (n * length xs) $ \ptr i ->+    for2M_ [i,i+n..] xs $ \i x -> pokeByteOff ptr i x+    where n = sizeOf (undefined :: a)++getExStorableList :: forall a . Storable a => BS.ByteString -> [a]+getExStorableList = \bs -> unsafePerformIO $ BS.useAsCStringLen bs $ \(p, size) ->+    let (d,m) = size `divMod` n in+    if m /= 0 then error "size mismatch" else forM [0..d-1] $ \i -> peekElemOff (castPtr p) i+    where n = sizeOf (undefined :: a)+++-- repeating:+--     Word32, length of BS+--     BS+putExList :: [Builder] -> Builder+putExList xs = Builder (sum $ map (\b -> sizeBuilder b + 4) xs) $ \p i -> do+    let go i [] = return ()+        go i (Builder n b:xs) = do+            pokeByteOff p i (fromIntegral n :: Word32)+            b p (i+4)+            go (i+4+n) xs+    go i xs++getExList :: BS.ByteString -> [BS.ByteString]+getExList bs+    | len == 0 = []+    | len >= 4+    , (n :: Word32, bs) <- unsafeBinarySplit bs+    , n <- fromIntegral n+    , (len - 4) >= n+    = BS.unsafeTake n bs : getExList (BS.unsafeDrop n bs)+    | otherwise = error "getList, corrupted binary"+    where len = BS.length bs++putExN :: Builder -> Builder+putExN (Builder n old) = Builder (n+4) $ \p i -> do+    pokeByteOff p i (fromIntegral n :: Word32)+    old p $ i+4++getExN :: BS.ByteString -> (BS.ByteString, BS.ByteString)+getExN bs+    | len >= 4+    , (n :: Word32, bs) <- unsafeBinarySplit bs+    , n <- fromIntegral n+    , (len - 4) >= n+    = (BS.unsafeTake n bs, BS.unsafeDrop n bs)+    | otherwise = error "getList, corrupted binary"+    where len = BS.length bs
+ src/General/Chunks.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}++module General.Chunks(+    Chunks,+    readChunk, readChunkMax, writeChunks, writeChunk,+    restoreChunksBackup, withChunks, resetChunksCompact, resetChunksCorrupt+    ) where++import System.Time.Extra+import System.FilePath+import Control.Concurrent.Extra+import Control.Monad.Extra+import Control.Exception.Extra+import System.IO+import System.Directory+import qualified Data.ByteString as BS+import Data.Word+import Data.Monoid+import General.Binary+++data Chunks = Chunks+    {chunksFileName :: FilePath+    ,chunksFlush :: Maybe Seconds+    ,chunksHandle :: MVar Handle+    }+++---------------------------------------------------------------------+-- READ/WRITE OPERATIONS++readChunk :: Chunks -> IO (Either BS.ByteString BS.ByteString)+readChunk c = readChunkMax c maxBound++-- | 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+    let slop x = do+            unless (BS.null x) $ hSetFileSize h . subtract (toInteger $ BS.length x) =<< hFileSize h+            return $ Left x+    n <- BS.hGet h 4+    if BS.length n < 4 then slop n else do+        let count = fromIntegral $ min mx $ fst $ unsafeBinarySplit n+        v <- BS.hGet h count+        if BS.length v < count then slop (n `BS.append` v) else return $ Right v++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+-- 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+    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++    root <- myThreadId+    writer <- flip forkFinally (\e -> do signalBarrier died (); either (throwTo root) (const $ return ()) e) $+        -- only one thread ever writes, ensuring only the final write can be torn+        whileM $ join $ readChan chan++    (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++writeChunk :: Chunks -> Builder -> IO ()+writeChunk Chunks{..} x = withMVar chunksHandle $ \h -> writeChunkDirect h x+++---------------------------------------------------------------------+-- FILENAME OPERATIONS++backup x = x <.> "backup"++restoreChunksBackup :: FilePath -> IO Bool+restoreChunksBackup file = do+    -- complete a partially failed compress+    b <- doesFileExist $ backup file+    if not b then return False else do+        handle (\(_ :: IOError) -> return ()) $ removeFile file+        renameFile (backup file) file+        return True+++withChunks :: FilePath -> Maybe Seconds -> (Chunks -> IO a) -> IO a+withChunks file flush act = do+    h <- newEmptyMVar+    bracket_+        (putMVar h =<< openFile file ReadWriteMode)+        (hClose =<< takeMVar h) $+        act $ Chunks file flush h+++-- | The file is being compacted, if the process fails, use a backup.+resetChunksCompact :: Chunks -> ((Builder -> IO ()) -> IO a) -> IO a+resetChunksCompact Chunks{..} act = mask $ \restore -> do+    h <- takeMVar chunksHandle+    flip onException (putMVar chunksHandle h) $ restore $ do+        hClose h+        copyFile chunksFileName $ backup chunksFileName+    h <- openFile chunksFileName ReadWriteMode+    flip finally (putMVar chunksHandle h) $ restore $ do+        hSetFileSize h 0+        hSeek h AbsoluteSeek 0+        res <- act $ writeChunkDirect h+        hFlush h+        removeFile $ backup chunksFileName+        return res+++-- | The file got corrupted, return a new version.+resetChunksCorrupt :: Maybe FilePath -> Chunks -> IO ()+resetChunksCorrupt copy Chunks{..} = mask $ \restore -> do+    h <- takeMVar chunksHandle+    case copy of+        Nothing -> return h+        Just copy -> do+            flip onException (putMVar chunksHandle h) $ restore $ do+                hClose h+                copyFile chunksFileName copy+            openFile chunksFileName ReadWriteMode+    flip finally (putMVar chunksHandle h) $ do+        hSetFileSize h 0+        hSeek h AbsoluteSeek 0
src/General/Cleanup.hs view
@@ -5,7 +5,6 @@     ) where  import Control.Exception as E-import Control.Monad import qualified Data.HashMap.Strict as Map import Data.Function import Data.IORef@@ -27,12 +26,9 @@         mapM_ snd $ sortBy (compare `on` negate . fst) $ Map.toList items  --- | Add a cleanup action to a 'Cleanup' scope. If the return action is not run by the time---   'withCleanup' terminates then it will be run then. The argument 'Bool' is 'True' to say---   run the action, 'False' to say ignore the action (and never run it).-addCleanup :: Cleanup -> IO () -> IO (Bool -> IO ())+-- | Add a cleanup action to a 'Cleanup' scope, returning a way to remove 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)) $ \b ->-        join $ atomicModifyIORef ref $ \s -> case Map.lookup i $ items s of-            Nothing -> (s, return ())-            Just act -> (s{items = Map.delete i $ items s}, when b act)+    (,) (S (unique s + 1) (Map.insert i act $ items s)) $+        atomicModifyIORef ref $ \s -> (s{items = Map.delete i $ items s}, ())
src/General/Extra.hs view
@@ -1,10 +1,14 @@+{-# LANGUAGE ScopedTypeVariables #-}  module General.Extra(     getProcessorCount,+    withResultType,     randomElem,-    showQuote,+    wrapQuote, showBracket,     withs,-    maximum', maximumBy'+    maximum', maximumBy',+    fastAt,+    isAsyncException     ) where  import Control.Exception.Extra@@ -14,18 +18,59 @@ import System.IO.Extra import System.IO.Unsafe import System.Random+import System.Exit import Control.Concurrent-import GHC.Conc+import Data.Functor+import Data.Primitive.Array+import Control.Monad+import Control.Monad.ST+import GHC.Conc(getNumProcessors)+import Prelude   ---------------------------------------------------------------------+-- Prelude++-- See https://ghc.haskell.org/trac/ghc/ticket/10830 - they broke maximumBy+maximumBy' :: (a -> a -> Ordering) -> [a] -> a+maximumBy' cmp = foldl1' $ \x y -> if cmp x y == GT then x else y++maximum' :: Ord a => [a] -> a+maximum' = maximumBy' compare+++--------------------------------------------------------------------- -- Data.List -showQuote :: String -> String-showQuote xs | any isSpace xs = "\"" ++ concatMap (\x -> if x == '\"' then "\"\"" else [x]) xs ++ "\""+-- | If a string has any spaces then put quotes around and double up all internal quotes.+--   Roughly the inverse of Windows command line parsing.+wrapQuote :: String -> String+wrapQuote xs | any isSpace xs = "\"" ++ concatMap (\x -> if x == '\"' then "\"\"" else [x]) xs ++ "\""              | otherwise = xs +-- | If a string has any spaces then put brackets around it.+wrapBracket :: String -> String+wrapBracket xs | any isSpace xs = "(" ++ xs ++ ")"+               | otherwise = xs +-- | Alias for @wrapBracket . show@.+showBracket :: Show a => a -> String+showBracket = wrapBracket . show+++-- | Version of '!!' which is fast and returns 'Nothing' if the index is not present.+fastAt :: [a] -> (Int -> Maybe a)+fastAt xs = \i -> if i < 0 || i >= n then Nothing else Just $ indexArray arr i+    where+        n = length xs+        arr = runST $ do+            let n = length xs+            arr <- newArray n undefined+            forM_ (zip [0..] xs) $ \(i,x) ->+                writeArray arr i x+            unsafeFreezeArray arr++ --------------------------------------------------------------------- -- System.Info @@ -36,7 +81,7 @@     where         act =             if rtsSupportsBoundThreads then-                fmap fromIntegral $ getNumProcessors+                fromIntegral <$> getNumProcessors             else                 handle_ (const $ return 1) $ do                     env <- lookupEnv "NUMBER_OF_PROCESSORS"@@ -64,9 +109,20 @@ withs (f:fs) act = f $ \a -> withs fs $ \as -> act $ a:as  --- See https://ghc.haskell.org/trac/ghc/ticket/10830 - they broke maximumBy-maximumBy' :: (a -> a -> Ordering) -> [a] -> a-maximumBy' cmp = foldl1' $ \x y -> if cmp x y == GT then x else y+---------------------------------------------------------------------+-- Control.Exception -maximum' :: Ord a => [a] -> a-maximum' = maximumBy' compare+-- | Is the exception asynchronous, not a "coding error" that should be ignored+isAsyncException :: SomeException -> Bool+isAsyncException e+    | Just (_ :: AsyncException) <- fromException e = True+    | Just (_ :: ExitCode) <- fromException e = True+    | otherwise = False+++---------------------------------------------------------------------+-- Data.Proxy++-- Should be Proxy, but that's not available in older GHC 7.6 and before+withResultType :: (Maybe a -> a) -> a+withResultType f = f Nothing
+ src/General/GetOpt.hs view
@@ -0,0 +1,68 @@++module General.GetOpt(+    OptDescr(..), ArgDescr(..),+    getOpt,+    fmapOptDescr,+    showOptDescr,+    mergeOptDescr,+    removeOverlap,+    optionsEnum,+    optionsEnumDesc+    ) where++import qualified System.Console.GetOpt as O+import System.Console.GetOpt hiding (getOpt)+import qualified Data.HashSet as Set+import Data.Maybe+import Data.Either+import Data.List.Extra+++getOpt :: [OptDescr (Either String a)] -> [String] -> ([a], [String], [String])+getOpt opts args = (flagGood, files, flagBad ++ errs)+    where (flags, files, errs) = O.getOpt O.Permute opts args+          (flagBad, flagGood) = partitionEithers flags+++-- fmap is only an instance in later GHC 7.8 and above, so fake our own version+fmapOptDescr :: (a -> b) -> OptDescr (Either String a) -> OptDescr (Either String b)+fmapOptDescr f (Option a b c d) = Option a b (g c) d+    where g (NoArg a) = NoArg $ fmap f a+          g (ReqArg a b) = ReqArg (fmap f . a) b+          g (OptArg a b) = OptArg (fmap f . a) b+++showOptDescr :: [OptDescr a] -> [String]+showOptDescr xs = concat+    [ if nargs <= 26 then ["  " ++ args ++ replicate (28 - nargs) ' ' ++ desc]+                     else ["  " ++ args, replicate 30 ' ' ++ desc]+    | Option s l arg desc <- xs+    , let args = intercalate ", " $ map (short arg) s ++ map (long arg) l+    , let nargs = length args]+    where short NoArg{} x = "-" ++ [x]+          short (ReqArg _ b) x = "-" ++ [x] ++ " " ++ b+          short (OptArg _ b) x = "-" ++ [x] ++ "[" ++ b ++ "]"+          long NoArg{} x = "--" ++ x+          long (ReqArg _ b) x = "--" ++ x ++ "=" ++ b+          long (OptArg _ b) x = "--" ++ x ++ "[=" ++ b ++ "]"+++-- | Remove flags from the first field that are present in the second+removeOverlap :: [OptDescr b] -> [OptDescr a] -> [OptDescr a]+removeOverlap bad = mapMaybe f+    where+        short = Set.fromList $ concat [x | Option x _ _ _ <- bad]+        long  = Set.fromList $ concat [x | Option _ x _ _ <- bad]+        f (Option a b c d) | null a2 && null b2 = Nothing+                           | otherwise = Just $ Option a2 b2 c d+            where a2 = filter (not . flip Set.member short) a+                  b2 = filter (not . flip Set.member long) b++mergeOptDescr :: [OptDescr (Either String a)] -> [OptDescr (Either String b)] -> [OptDescr (Either String (Either a b))]+mergeOptDescr xs ys = map (fmapOptDescr Left) xs ++ map (fmapOptDescr Right) ys++optionsEnum :: (Enum a, Bounded a, Show a) => [OptDescr (Either String a)]+optionsEnum = optionsEnumDesc [(x, "Flag " ++ lower (show x) ++ ".") | x <- [minBound..maxBound]]++optionsEnumDesc :: Show a => [(a, String)] -> [OptDescr (Either String a)]+optionsEnumDesc xs = [Option "" [lower $ show x] (NoArg $ Right x) d | (x,d) <- xs]
+ src/General/Ids.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE RecordWildCards, BangPatterns, GADTs, UnboxedTuples #-}++-- Note that argument order is more like IORef than Map, because its mutable+module General.Ids(+    Ids, Id,+    empty, insert, lookup,+    null, size, sizeUpperBound,+    forWithKeyM_, for,+    toList, toMap+    ) where++import Data.IORef.Extra+import Data.Primitive.Array+import Control.Exception+import General.Intern(Id(..))+import Control.Monad.Extra+import Data.Maybe+import Data.Functor+import qualified Data.HashMap.Strict as Map+import Prelude hiding (lookup, null)+import GHC.IO(IO(..))+import GHC.Exts(RealWorld)+++newtype Ids a = Ids (IORef (S a))++data S a = S+    {capacity :: {-# UNPACK #-} !Int -- ^ Number of entries in values, initially 0+    ,used :: {-# UNPACK #-} !Int -- ^ Capacity that has been used, assuming no gaps from index 0, initially 0+    ,values :: {-# UNPACK #-} !(MutableArray RealWorld (Maybe a))+    }+++empty :: IO (Ids a)+empty = do+    let capacity = 0+    let used = 0+    values <- newArray capacity Nothing+    Ids <$> newIORef S{..}+++sizeUpperBound :: Ids a -> IO Int+sizeUpperBound (Ids ref) = do+    S{..} <- readIORef ref+    return used+++size :: Ids a -> IO Int+size (Ids ref) = do+    S{..} <- readIORef ref+    let go !acc i+            | i < 0 = return acc+            | otherwise = do+                v <- readArray values i+                if isJust v then go (acc+1) (i-1) else go acc (i-1)+    go 0 (used-1)+++toMap :: Ids a -> IO (Map.HashMap Id a)+toMap ids = do+    mp <- Map.fromList <$> toListUnsafe ids+    return $! mp++forWithKeyM_ :: Ids a -> (Id -> a -> IO ()) -> IO ()+forWithKeyM_ (Ids ref) f = do+    S{..} <- readIORef ref+    let go !i | i >= used = return ()+              | otherwise = do+                v <- readArray values i+                whenJust v $ f $ Id $ fromIntegral i+                go $ i+1+    go 0++for :: Ids a -> (a -> b) -> IO (Ids b)+for (Ids ref) f = do+    S{..} <- readIORef ref+    values2 <- newArray capacity Nothing+    let go !i | i >= used = return ()+              | otherwise = do+                v <- readArray values i+                whenJust v $ \v -> writeArray values2 i $ Just $ f v+                go $ i+1+    go 0+    Ids <$> newIORef (S capacity used values2)+++toListUnsafe :: Ids a -> IO [(Id, a)]+toListUnsafe (Ids ref) = do+    S{..} <- readIORef ref++    -- execute in O(1) stack+    -- see http://neilmitchell.blogspot.co.uk/2015/09/making-sequencemapm-for-io-take-o1-stack.html+    let index r 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)++    IO $ \r -> (# r, index r 0 #)+++toList :: Ids a -> IO [(Id, a)]+toList ids = do+    xs <- toListUnsafe ids+    let demand (x:xs) = demand xs+        demand [] = ()+    evaluate $ demand xs+    return xs+++null :: Ids a -> IO Bool+null ids = (== 0) <$> sizeUpperBound ids+++insert :: Ids a -> Id -> a -> IO ()+insert (Ids ref) (Id i) v = do+    S{..} <- readIORef ref+    let ii = fromIntegral i+    if ii < capacity then do+        writeArray values ii $ Just v+        when (ii >= used) $ writeIORef' ref S{used=ii+1,..}+     else do+        c2 <- return $ max (capacity * 2) (ii + 10000)+        v2 <- newArray c2 Nothing+        copyMutableArray v2 0 values 0 capacity+        writeArray v2 ii $ Just v+        writeIORef' ref $ S c2 (ii+1) v2++lookup :: Ids a -> Id -> IO (Maybe a)+lookup (Ids ref) (Id i) = do+    S{..} <- readIORef ref+    let ii = fromIntegral i+    if ii < used then+        readArray values ii+     else+        return Nothing
src/General/Intern.hs view
@@ -1,12 +1,13 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module General.Intern(     Intern, Id(..),     empty, insert, add, lookup, toList, fromList     ) where -import General.Binary import Development.Shake.Classes+import Foreign.Storable+import Data.Word import Prelude hiding (lookup) import qualified Data.HashMap.Strict as Map import Data.List(foldl')@@ -16,12 +17,7 @@ data Intern a = Intern {-# UNPACK #-} !Word32 !(Map.HashMap a Id)  newtype Id = Id Word32-    deriving (Eq,Hashable,Binary,Show,NFData)--instance BinaryWith w Id where-    putWith ctx = put-    getWith ctx = get-+    deriving (Eq,Hashable,Binary,Show,NFData,Storable)  empty :: Intern a empty = Intern 0 Map.empty
+ src/General/ListBuilder.hs view
@@ -0,0 +1,28 @@++module General.ListBuilder(+    ListBuilder, runListBuilder, newListBuilder+    ) where++import Data.Monoid+import Prelude()++data ListBuilder a+    = Zero+    | One a+    | Add (ListBuilder a) (ListBuilder a)++instance Monoid (ListBuilder a) where+    mempty = Zero+    mappend Zero x = x+    mappend x Zero = x+    mappend x y = Add x y++newListBuilder :: a -> ListBuilder a+newListBuilder = One++runListBuilder :: ListBuilder a -> [a]+runListBuilder x = f x []+    where+        f Zero acc = []+        f (One x) acc = x : acc+        f (Add x y) acc = f x (f y acc)
+ src/General/Makefile.hs view
@@ -0,0 +1,40 @@++module General.Makefile(parseMakefile) where++import qualified Data.ByteString.Char8 as BS+import Data.Char+++endsSlash :: BS.ByteString -> Bool+endsSlash = BS.isSuffixOf (BS.singleton '\\')++wordsMakefile :: BS.ByteString -> [BS.ByteString]+wordsMakefile = f . BS.splitWith isSpace+    where+        f (x:xs) | BS.null x = f xs+        f (x:y:xs) | endsSlash x = f $ BS.concat [BS.init x, BS.singleton ' ', y] : xs+        f (x:xs) = x : f xs+        f [] = []++parseMakefile :: BS.ByteString -> [(BS.ByteString, [BS.ByteString])]+parseMakefile = concatMap f . join . linesCR+    where+        join xs = case span endsSlash xs of+            ([], []) -> []+            (xs, []) -> [BS.unwords $ map BS.init xs]+            ([], y:ys) -> y : join ys+            (xs, y:ys) -> BS.unwords (map BS.init xs ++ [y]) : join ys++        f x = [(a, wordsMakefile $ BS.drop 1 b) | a <- wordsMakefile a]+            where (a,b) = BS.break (== ':') $ BS.takeWhile (/= '#') x+++-- | This is a hot-spot, so optimised+linesCR :: BS.ByteString -> [BS.ByteString]+linesCR x = case BS.split '\n' x of+    x:xs | Just ('\r',x) <- unsnoc x -> x : map (\x -> case unsnoc x of Just ('\r',x) -> x; _ -> x) xs+    xs -> xs+    where+        -- the ByteString unsnoc was introduced in a newer version+        unsnoc x | BS.null x = Nothing+                 | otherwise = Just (BS.last x, BS.init x)
src/General/Process.hs view
@@ -21,8 +21,8 @@ import System.Time.Extra import Data.Unique import Data.IORef-import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Internal as BS(createAndTrim)+import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy as LBS import General.Extra import Prelude@@ -182,7 +182,7 @@                             DestString x -> addBuffer x . (if isWindows then replace "\r\n" "\n" else id) . BS.unpack                             DestBytes x -> addBuffer x                         forkWait $ whileM $ do-                            src <- bs_hGetSome h 4096+                            src <- bsHGetSome h 4096                             mapM_ ($ src) dest                             notM $ hIsEOF h                      else if isTied then do@@ -219,7 +219,7 @@ --------------------------------------------------------------------- -- COMPATIBILITY --- available in bytestring-0.9.1.10 and above+-- available in bytestring-0.9.1.10, GHC 7.8 and above -- implementation copied below-bs_hGetSome :: Handle -> Int -> IO BS.ByteString-bs_hGetSome h i = BS.createAndTrim i $ \p -> hGetBufSome h p i+bsHGetSome :: Handle -> Int -> IO BS.ByteString+bsHGetSome h i = BS.createAndTrim i $ \p -> hGetBufSome h p i
− src/General/String.hs 
@@ -1,67 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module General.String(-    BS, pack, unpack, pack_, unpack_,-    BSU, packU, unpackU, packU_, unpackU_, requireU-    ) where--import qualified Data.ByteString as BS (any)-import qualified Data.ByteString.Char8 as BS hiding (any)-import qualified Data.ByteString.UTF8 as UTF8-import Development.Shake.Classes--------------------------------------------------------------------------- Data.ByteString--- Mostly because ByteString does not have an NFData instance in GHC 7.4---- | ASCII ByteString-newtype BS = BS BS.ByteString-    deriving (Hashable, Binary, Eq)--instance Show BS where-    show (BS x) = show x--instance NFData BS where-    -- some versions of ByteString do not have NFData instances, but seq is equivalent-    -- for a strict bytestring. Therefore, we write our own instance.-    rnf (BS x) = x `seq` ()----- | UTF8 ByteString-newtype BSU = BSU BS.ByteString-    deriving (Hashable, Binary, Eq)--instance NFData BSU where-    rnf (BSU x) = x `seq` ()--instance Show BSU where-    show = unpackU---pack :: String -> BS-pack = pack_ . BS.pack--unpack :: BS -> String-unpack = BS.unpack . unpack_--pack_ :: BS.ByteString -> BS-pack_ = BS--unpack_ :: BS -> BS.ByteString-unpack_ (BS x) = x--packU :: String -> BSU-packU = packU_ . UTF8.fromString--unpackU :: BSU -> String-unpackU = UTF8.toString . unpackU_--unpackU_ :: BSU -> BS.ByteString-unpackU_ (BSU x) = x--packU_ :: BS.ByteString -> BSU-packU_ = BSU--requireU :: BSU -> Bool-requireU = BS.any (>= 0x80) . unpackU_
src/General/Template.hs view
@@ -4,7 +4,6 @@  import System.FilePath.Posix import Control.Exception.Extra-import Control.Monad import Control.Monad.IO.Class import Data.Char import qualified Data.ByteString.Lazy.Char8 as LBS@@ -23,14 +22,15 @@ -- * <script src="foo"></script> ==> <script>[[foo]]</script> -- -- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>-runTemplate :: MonadIO m => (FilePath -> m LBS.ByteString) -> LBS.ByteString -> m LBS.ByteString-runTemplate ask = liftM LBS.unlines . mapM f . LBS.lines+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     where         link = LBS.pack "<link href=\""         script = LBS.pack "<script src=\"" -        f x | Just file <- lbs_stripPrefix script y = do res <- grab file; return $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"-            | Just file <- lbs_stripPrefix link y = do res <- grab file; return $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"+        f x | Just file <- lbsStripPrefix script y = do res <- grab file; return $ LBS.pack "<script>\n" `LBS.append` res `LBS.append` LBS.pack "\n</script>"+            | Just file <- lbsStripPrefix link y = do res <- grab file; return $ LBS.pack "<style type=\"text/css\">\n" `LBS.append` res `LBS.append` LBS.pack "\n</style>"             | otherwise = return x             where                 y = LBS.dropWhile isSpace x@@ -42,6 +42,11 @@         asker x = ask x  -lbs_stripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString-lbs_stripPrefix prefix text = if a == prefix then Just b else Nothing+---------------------------------------------------------------------+-- COMPATIBILITY++-- available in bytestring-0.10.8.0, GHC 8.0 and above+-- alternative implementation below+lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString+lbsStripPrefix prefix text = if a == prefix then Just b else Nothing     where (a,b) = LBS.splitAt (LBS.length prefix) text
src/Paths.hs view
@@ -1,6 +1,6 @@ -- | Fake cabal module for local building -module Paths_shake where+module Paths_shake(getDataFileName, version) where  import Data.Version.Extra import System.IO.Unsafe
src/Run.hs view
@@ -1,21 +1,18 @@  module Run(main) where -import Development.Make.All import Development.Ninja.All import System.Environment import Development.Shake import Development.Shake.FilePath import General.Timing(resetTimings)-import Control.Applicative import Control.Monad.Extra import Control.Exception.Extra import Data.Maybe import qualified System.Directory as IO-import System.Console.GetOpt+import General.GetOpt import System.Process import System.Exit-import Prelude   main :: IO ()@@ -38,14 +35,11 @@                     makefile <- case reverse [x | UseMakefile x <- opts] of                         x:_ -> return x                         _ -> do-                            res <- findFile ["makefile","Makefile","build.ninja"]+                            res <- findFile ["build.ninja"]                             case res of                                 Just x -> return x-                                Nothing -> errorIO "Could not find `makefile', `Makefile' or `build.ninja'"-                    case () of-                        _ | takeExtension makefile == ".ninja" -> runNinja makefile targets tool-                        _ | isJust tool -> error "--tool flag is not supported without a .ninja Makefile"-                        _ -> Just <$> runMakefile makefile targets+                                Nothing -> errorIO "Could not find `build.ninja'"+                    runNinja makefile targets tool   data Flag = UseMakefile FilePath
src/Test.hs view
@@ -7,14 +7,14 @@ import Data.Maybe import System.Environment.Extra import General.Timing-import Development.Shake.FileInfo-import General.String+import Development.Shake.Internal.FileInfo+import Development.Shake.Internal.FileName import qualified Data.ByteString.Char8 as BS import Test.Type(sleepFileTimeCalibrate) import Control.Concurrent import Prelude -import qualified Test.Assume as Assume+import qualified Test.Rebuild as Rebuild import qualified Test.Basic as Basic import qualified Test.Benchmark as Benchmark import qualified Test.C as C@@ -25,6 +25,7 @@ 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.Files as Files import qualified Test.FilePath as FilePath@@ -33,7 +34,6 @@ import qualified Test.Journal as Journal import qualified Test.Lint as Lint import qualified Test.Live as Live-import qualified Test.Makefile as Makefile import qualified Test.Manual as Manual import qualified Test.Match as Match import qualified Test.Monad as Monad@@ -62,12 +62,14 @@ mains = ["tar" * Tar.main, "self" * Self.main, "c" * C.main         ,"basic" * Basic.main, "cache" * Cache.main, "command" * Command.main         ,"config" * Config.main, "digest" * Digest.main, "directory" * Directory.main-        ,"docs" * Docs.main, "errors" * Errors.main, "orderonly" * OrderOnly.main+        ,"docs" * Docs.main+        ,"errors" * Errors.main, "existence" * Existence.main+        ,"orderonly" * OrderOnly.main         ,"filepath" * FilePath.main, "filepattern" * FilePattern.main, "files" * Files.main, "filelock" * FileLock.main         ,"forward" * Forward.main, "match" * Match.main-        ,"journal" * Journal.main, "lint" * Lint.main, "live" * Live.main, "makefile" * Makefile.main, "manual" * Manual.main+        ,"journal" * Journal.main, "lint" * Lint.main, "live" * Live.main, "manual" * Manual.main         ,"monad" * Monad.main, "parallel" * Parallel.main, "pool" * Pool.main, "random" * Random.main, "ninja" * Ninja.main-        ,"resources" * Resources.main, "assume" * Assume.main, "benchmark" * Benchmark.main+        ,"resources" * Resources.main, "rebuild" * Rebuild.main, "benchmark" * Benchmark.main         ,"oracle" * Oracle.main, "progress" * Progress.main, "unicode" * Unicode.main, "util" * Util.main         ,"verbosity" * Verbosity.main, "version" * Version.main, "tup" * Tup.main]     where (*) = (,)@@ -120,7 +122,7 @@     vars <- forM [a,b,c,d] $ \xs -> do         mvar <- newEmptyMVar         forkIO $ do-            mapM_ (getFileInfo . packU_) xs+            mapM_ (getFileInfo . fileNameFromByteString) xs             putMVar mvar ()         return $ takeMVar mvar     sequence_ vars
− src/Test/Assume.hs 
@@ -1,45 +0,0 @@--module Test.Assume(main) where--import Development.Shake-import Test.Type-import Control.Monad-import Development.Shake.FilePath---main = shakenCwd test $ \args obj -> do-    want $ map obj args-    obj "*.out" %> \out -> do-        cs <- mapM (readFile' . obj . (:".src")) $ takeBaseName out-        writeFile' out $ concat cs---test build obj = do-    let set file c = writeFile (obj $ file : ".src") [c]-    let ask file c = do src <- readFile (obj $ file ++ ".out"); src === c--    forM_ ['a'..'f'] $ \c -> set c c-    build ["--sleep","abc.out"]-    ask "abc" "abc"--    set 'b' 'd'-    build ["--sleep","abc.out"]-    ask "abc" "adc"-    set 'b' 'p'-    build ["--sleep","abc.out","--touch"]-    build ["abc.out"]-    ask "abc" "adc"-    set 'c' 'z'-    build ["--sleep","abc.out"]-    ask "abc" "apz"--    build ["bc.out","c.out"]-    ask "bc" "pz"-    set 'b' 'r'-    set 'c' 'n'-    build ["--sleep","abc.out","--touch"]-    ask "abc" "apz"-    build ["ab.out","--always-make"]-    ask "ab" "ar"-    build ["c.out"]-    ask "c" "z"
src/Test/Basic.hs view
@@ -9,179 +9,202 @@ import Data.Maybe import Control.Monad import General.Extra+import Data.Functor+import Prelude  -main = shaken test $ \args obj -> do-    want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args--    obj "AB.txt" %> \out -> do-        need [obj "A.txt", obj "B.txt"]-        text1 <- readFile' $ obj "A.txt"-        text2 <- readFile' $ obj "B.txt"+main = shakeTest_ test $ do+    "AB.txt" %> \out -> do+        need ["A.txt", "B.txt"]+        text1 <- readFile' "A.txt"+        text2 <- readFile' "B.txt"         writeFile' out $ text1 ++ text2 -    obj "twice.txt" %> \out -> do-        let src = obj "once.txt"+    "twice.txt" %> \out -> do+        let src = "once.txt"         need [src, src]         copyFile' src out -    obj "once.txt" %> \out -> do-        src <- readFile' $ obj "zero.txt"+    "once.txt" %> \out -> do+        src <- readFile' "zero.txt"         writeFile' out src      phonys $ \x -> if x /= "halfclean" then Nothing else Just $-        removeFilesAfter (obj "") ["//*e.txt"]+        removeFilesAfter "dir" ["//*e.txt"]      phony "cleaner" $-        removeFilesAfter (obj "") ["//*"]+        removeFilesAfter "dir" ["//*"] -    phony (obj "configure") $-        liftIO $ appendFile (obj "configure") "1"+    phony "configure" $+        liftIO $ appendFile "configure" "1"      phony "install" $ do-        need [obj "configure",obj "once.txt"]-        liftIO $ appendFile (obj "install") "1"+        need ["configure","once.txt"]+        liftIO $ appendFile "install" "1"      phony "duplicate1" $ need ["duplicate2","duplicate3"]     phony "duplicate2" $ need ["duplicate3"]-    phony "duplicate3" $ liftIO $ appendFile (obj "duplicate") "1"+    phony "duplicate3" $ liftIO $ appendFile "duplicate" "1"      phony "dummy" $-        liftIO $ appendFile (obj "dummy") "1"+        liftIO $ appendFile "dummy" "1"      phony "threads" $ do         x <- getShakeOptions-        writeFile' (obj "threads.txt") $ show $ shakeThreads x+        writeFile' "threads.txt" $ show $ shakeThreads x      phony ("slash" </> "platform") $ return ()-    phony ("slash/forward") $ return ()+    phony "slash/forward" $ return () -    obj "dummer.txt" %> \out -> do+    "dummer.txt" %> \out -> do         need ["dummy","dummy"]         need ["dummy"]         liftIO $ appendFile out "1"      r <- newResource ".log file" 1-    let trace x = withResource r 1 $ liftIO $ appendFile (obj ".log") x-    obj "*.par" %> \out -> do+    let trace x = withResource r 1 $ liftIO $ appendFile ".log" x+    "*.par" %> \out -> do         trace "["         (if "unsafe" `isInfixOf` out then unsafeExtraThread else id) $ liftIO $ sleep 0.1         trace "]"         writeFile' out out -    obj "sep" </> "1.txt" %> \out -> writeFile' out ""-    obj "sep/2.txt" %> \out -> writeFile' out ""-    [obj "sep" </> "3.txt", obj "sep" </> "4.txt", obj "sep" </> "5.*", obj "sep/6.txt"] |%> \out -> writeFile' out ""-    [obj "sep" </> "7.txt"] |%> \out -> writeFile' out ""+    "sep" </> "1.txt" %> \out -> writeFile' out ""+    "sep/2.txt" %> \out -> writeFile' out ""+    ["sep" </> "3.txt", "sep" </> "4.txt", "sep" </> "5.*", "sep/6.txt"] |%> \out -> writeFile' out ""+    ["sep" </> "7.txt"] |%> \out -> writeFile' out "" -    obj "ids/source" %> \out -> return ()-    obj "ids/out" %> \out -> do need =<< readFileLines (obj "ids/source"); writeFile' out ""-    obj "ids/*" %> \out -> do alwaysRerun; trace (takeFileName out); writeFile' out $ takeFileName out+    "ids/source" %> \out -> return ()+    "ids/out" %> \out -> do need =<< readFileLines "ids/source"; writeFile' out ""+    "ids/*" %> \out -> do alwaysRerun; trace (takeFileName out); writeFile' out $ takeFileName out -    phony (obj "foo") $ do-        liftIO $ createDirectoryIfMissing True $ obj "foo"+    "rerun" %> \out -> do alwaysRerun; liftIO $ appendFile out "." -test build obj = do-    writeFile (obj "A.txt") "AAA"-    writeFile (obj "B.txt") "BBB"+    phony "foo" $+        liftIO $ createDirectoryIfMissing True "foo"++    phony "ordering2" $+        liftIO $ appendFile "order.log" "X"+    phony "ordering" $ do+        liftIO $ appendFile "order.log" "Y"+        need ["ordering2"]++test build = do+    build ["clean"]+    writeFile "A.txt" "AAA"+    writeFile "B.txt" "BBB"     build ["AB.txt","--sleep"]-    assertContents (obj "AB.txt") "AAABBB"-    appendFile (obj "A.txt") "aaa"+    assertContents "AB.txt" "AAABBB"+    appendFile "A.txt" "aaa"     build ["AB.txt"]-    assertContents (obj "AB.txt") "AAAaaaBBB"-    removeFile $ obj "AB.txt"+    assertContents "AB.txt" "AAAaaaBBB"+    removeFile "AB.txt"     build ["AB.txt"]-    assertContents (obj "AB.txt") "AAAaaaBBB"+    assertContents "AB.txt" "AAAaaaBBB" -    writeFile (obj "zero.txt") "xxx"+    writeFile "zero.txt" "xxx"     build ["twice.txt","--sleep"]-    assertContents (obj "twice.txt") "xxx"-    writeFile (obj "zero.txt") "yyy"+    assertContents "twice.txt" "xxx"+    writeFile "zero.txt" "yyy"     build ["once.txt","--sleep"]-    assertContents (obj "twice.txt") "xxx"-    assertContents (obj "once.txt") "yyy"-    writeFile (obj "zero.txt") "zzz"+    assertContents "twice.txt" "xxx"+    assertContents "once.txt" "yyy"+    writeFile "zero.txt" "zzz"     build ["once.txt","twice.txt","--sleep"]-    assertContents (obj "twice.txt") "zzz"-    assertContents (obj "once.txt") "zzz"+    assertContents "twice.txt" "zzz"+    assertContents "once.txt" "zzz" -    removeFile $ obj "twice.txt"+    removeFile "twice.txt"     build ["twice.txt"]-    assertContents (obj "twice.txt") "zzz"+    assertContents "twice.txt" "zzz"      show shakeOptions === show shakeOptions -    build ["!halfclean"]-    b <- IO.doesDirectoryExist (obj "")-    assert b "Directory should exist, cleaner should not have removed it"+    createDirectoryIfMissing True "dir"+    writeFile "dir/ae.txt" ""+    writeFile "dir/ea.txt" ""+    build ["halfclean"]+    assertBoolIO (IO.doesDirectoryExist "dir") "Directory should exist, cleaner should not have removed it" -    build ["!cleaner"]+    build ["cleaner"]     sleep 1 -- sometimes takes a while for the file system to notice-    b <- IO.doesDirectoryExist (obj "")-    assert (not b) "Directory should not exist, cleaner should have removed it"+    assertBoolIO (not <$> IO.doesDirectoryExist "dir") "Directory should not exist, cleaner should have removed it" -    IO.createDirectory $ obj ""-    writeFile (obj "zero.txt") ""+    writeFile "zero.txt" ""+    writeFile "configure" ""+    writeFile "install" ""     build ["configure"]-    build ["!install"]-    build ["!install"]-    assertContents (obj "configure") "111"-    assertContents (obj "install") "11"+    build ["install"]+    build ["install"]+    assertContents "configure" "111"+    assertContents "install" "11" -    writeFile (obj "dummy.txt") ""-    build ["!dummy"]-    assertContents (obj "dummy") "1"-    build ["!dummy"]-    assertContents (obj "dummy") "11"-    build ["!dummy","!dummy"]-    assertContents (obj "dummy") "111"+    build ["dummy"]+    assertContents "dummy" "1"+    build ["dummy"]+    assertContents "dummy" "11"+    build ["dummy","dummy"]+    assertContents "dummy" "111" -    writeFile (obj "dummer.txt") ""+    writeFile "dummer.txt" ""     build ["dummer.txt"]-    assertContents (obj "dummer.txt") "1"+    assertContents "dummer.txt" "1"     build ["dummer.txt"]-    assertContents (obj "dummer.txt") "11"+    assertContents "dummer.txt" "11"      build ["1.par","2.par","-j1"]-    assertContents (obj ".log") "[][]"-    writeFile (obj ".log") ""+    assertContents ".log" "[][]"+    writeFile ".log" ""     build ["3.par","4.par","-j2"]-    assertContents (obj ".log") "[[]]"-    writeFile (obj ".log") ""+    assertContents ".log" "[[]]"+    writeFile ".log" ""     processors <- getProcessorCount     putStrLn $ "getProcessorCount returned " ++ show processors     when (processors > 1) $ do         build ["5.par","6.par","-j0"]-        assertContents (obj ".log") "[[]]"+        assertContents ".log" "[[]]" -    writeFile (obj ".log") ""+    writeFile ".log" ""     build ["unsafe1.par","unsafe2.par","-j2"]-    assertContents (obj ".log") "[[]]"+    assertContents ".log" "[[]]" -    build ["!threads","-j3"]-    assertContents (obj "threads.txt") "3"-    build ["!threads","-j0"]-    assertContents (obj "threads.txt") (show processors)+    build ["threads","-j3"]+    assertContents "threads.txt" "3"+    build ["threads","-j0"]+    assertContents "threads.txt" (show processors) -    writeFile (obj "duplicate") ""-    build ["!duplicate1","!duplicate3"]-    assertContents (obj "duplicate") "1"+    writeFile "duplicate" ""+    build ["duplicate1","duplicate3"]+    assertContents "duplicate" "1"      build $ concat [["sep/" ++ show i ++ ".txt", "sep" </> show i ++ ".txt"] | i <- [1..7]] -    build ["!slash" </> "platform","!slash" </> "forward"]-    build ["!slash/platform","!slash/forward"]+    build ["slash" </> "platform","slash" </> "forward"]+    build ["slash/platform","slash/forward"] -    createDirectoryIfMissing True (obj "ids")-    writeFile (obj "ids/source") (obj "ids/a")+    createDirectoryIfMissing True "ids"+    writeFile "ids/source" "ids/a"     build ["ids/out","--sleep"]-    writeFile (obj ".log") ""-    writeFile (obj "ids/source") (obj "ids/b")+    writeFile ".log" ""+    writeFile "ids/source" "ids/b"     build ["ids/out","-j4"]     -- if you collapse depends to [Id] then this ends up asking for the stale 'a'-    assertContents (obj ".log") "b"+    assertContents ".log" "b" +    writeFile "rerun" ""+    build ["rerun"]+    assertContents "rerun" "."+    build ["rerun","rerun"]+    assertContents "rerun" ".."+     build ["foo"]     build ["foo"]      build [] -- should say "no want/action statements, nothing to do" (checked manually)++    -- #523, #524 - phony children should not run first+    writeFile "order.log" ""+    build ["ordering"]+    assertContents "order.log" "YX"+    build ["ordering"]+    assertContents "order.log" "YXYX"
src/Test/Benchmark.hs view
@@ -1,27 +1,30 @@  module Test.Benchmark(main) where +import General.GetOpt import Development.Shake import Test.Type-import Data.List+import Text.Read.Extra import Development.Shake.FilePath  +data Opts = Depth Int | Breadth Int+opts = [Option "" ["depth"  ] (ReqArg (fmap Depth   . readEither) "INT") ""+       ,Option "" ["breadth"] (ReqArg (fmap Breadth . readEither) "INT") ""]+ -- | Given a breadth and depth come up with a set of build files-main = shakenCwd test $ \args obj -> do-    let get ty = head $ [read $ drop (length ty + 1) a | a <- args, (ty ++ "=") `isPrefixOf` a] ++-                        error ("Could not find argument, expected " ++ ty ++ "=Number")-        depth = get "depth"-        breadth = get "breadth"+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] -    want [obj $ "0." ++ show i | i <- [1..breadth]]-    obj "*" %> \out -> do+    want ["0." ++ show i | i <- [1..breadth]]+    "*" %> \out -> do         let d = read $ takeBaseName out-        need [obj $ show (d + 1) ++ "." ++ show i | d < depth, i <- [1..breadth]]+        need [show (d + 1) ++ "." ++ show i | d < depth, i <- [1..breadth]]         writeFile' out "" -test build obj = do+test build = do     -- these help to test the stack limit     build ["clean"]-    build ["breadth=75","depth=75"]-    build ["breadth=75","depth=75"]+    build ["--breadth=75","--depth=75"]+    build ["--breadth=75","--depth=75"]
src/Test/C.hs view
@@ -5,17 +5,17 @@ import Development.Shake.FilePath import Test.Type -main = shaken noTest $ \args obj -> do-    let src = "src/Test/C"-    want [obj "Main.exe"]+main = shakeTest_ noTest $ do+    let src = root </> "src/Test/C"+    want ["Main.exe"] -    obj "Main.exe" %> \out -> do+    "Main.exe" %> \out -> do         cs <- getDirectoryFiles src ["*.c"]-        let os = map (obj . (<.> "o")) cs+        let os = map (<.> "o") cs         need os         cmd "gcc -o" [out] os -    obj "*.c.o" %> \out -> do+    "*.c.o" %> \out -> do         let c = src </> takeBaseName out         need [c]         headers <- cIncludes c
src/Test/Cache.hs view
@@ -7,33 +7,32 @@ import Test.Type  -main = shakenCwd test $ \args obj -> do-    want $ map obj args+main = shakeTest_ test $ do     vowels <- newCache $ \file -> do         src <- readFile' file-        liftIO $ appendFile (obj "trace.txt") "1"+        liftIO $ appendFile "trace.txt" "1"         return $ length $ filter isDigit src-    obj "*.out*" %> \x ->+    "*.out*" %> \x ->         writeFile' x . show =<< vowels (dropExtension x <.> "txt")  -test build obj = do-    writeFile (obj "trace.txt") ""-    writeFile (obj "vowels.txt") "abc123a"+test build = do+    writeFile "trace.txt" ""+    writeFile "vowels.txt" "abc123a"     build ["vowels.out1","vowels.out2","-j3","--sleep"]-    assertContents (obj "trace.txt") "1"-    assertContents (obj "vowels.out1") "3"-    assertContents (obj "vowels.out2") "3"+    assertContents "trace.txt" "1"+    assertContents "vowels.out1" "3"+    assertContents "vowels.out2" "3"      build ["vowels.out2","-j3"]-    assertContents (obj "trace.txt") "1"-    assertContents (obj "vowels.out1") "3"+    assertContents "trace.txt" "1"+    assertContents "vowels.out1" "3" -    writeFile (obj "vowels.txt") "12xyz34"+    writeFile "vowels.txt" "12xyz34"     build ["vowels.out2","-j3","--sleep"]-    assertContents (obj "trace.txt") "11"-    assertContents (obj "vowels.out2") "4"+    assertContents "trace.txt" "11"+    assertContents "vowels.out2" "4"      build ["vowels.out1","-j3","--sleep"]-    assertContents (obj "trace.txt") "111"-    assertContents (obj "vowels.out1") "4"+    assertContents "trace.txt" "111"+    assertContents "vowels.out1" "4"
src/Test/Command.hs view
@@ -21,11 +21,11 @@ import Prelude  -main = shakenCwd test $ \args obj -> do+main = shakeTest_ test $ do     -- shake_helper must be in a subdirectory so we can test placing that subdir on the $PATH-    let helper = toNative $ obj "helper/shake_helper" <.> exe-    let name !> test = do want [name | null args || name `elem` args]-                          name ~> do need [obj "helper/shake_helper" <.> exe]; test+    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"@@ -51,12 +51,12 @@             ,"        hFlush stderr"             ] -    obj "shake_helper.hs" %> \out -> do+    "shake_helper.hs" %> \out -> do         need ["../../src/Test/Command.hs"]         writeFileChanged out helper_source-    [obj "helper/shake_helper" <.> exe, obj "shake_helper.o", obj "shake_helper.hi"] &%> \_ -> do-        need [obj "shake_helper.hs"]-        cmd (Cwd $ obj "") "ghc --make" "shake_helper.hs -o helper/shake_helper"+    ["helper/shake_helper" <.> exe, "shake_helper.o", "shake_helper.hi"] &%> \_ -> do+        need ["shake_helper.hs"]+        cmd "ghc --make" "shake_helper.hs -o helper/shake_helper"      "capture" !> do         (Stderr err, Stdout out) <- cmd helper ["ostuff goes here","eother stuff here"]@@ -74,10 +74,10 @@      "cwd" !> do         -- FIXME: Linux searches the Cwd argument for the file, Windows searches getCurrentDirectory-        helper <- liftIO $ canonicalizePath $ obj "helper/shake_helper" <.> exe-        Stdout out <- cmd (Cwd $ obj "") helper "c"+        helper <- liftIO $ canonicalizePath $ "helper/shake_helper" <.> exe+        Stdout out <- cmd (Cwd "helper") helper "c"         let norm = fmap dropTrailingPathSeparator . canonicalizePath . trim-        liftIO $ join $ liftM2 (===) (norm out) (norm $ obj "")+        liftIO $ join $ liftM2 (===) (norm out) (norm "helper")      "timeout" !> do         opts <- getShakeOptions@@ -108,15 +108,15 @@             fail $ "Invalid CmdLine, " ++ x      "path" !> do-        let path = AddPath [dropTrailingPathSeparator $ obj "helper"] []-        unit $ cmd $ obj "helper/shake_helper"-        unit $ cmd $ obj "helper/shake_helper" <.> exe-        unit $ cmd path Shell "shake_helper"-        unit $ cmd path "shake_helper"+        let path = AddPath [dropTrailingPathSeparator "helper"] []+        cmd_ "helper/shake_helper"+        cmd_ $ "helper/shake_helper" <.> exe+        cmd_ path Shell "shake_helper"+        cmd_ path "shake_helper"      "file" !> do-        let file = obj "file.txt"-        unit $ cmd helper (FileStdout file) (FileStderr file) (EchoStdout False) (EchoStderr False) (WithStderr False) "ofoo ebar obaz"+        let file = "file.txt"+        cmd_ helper (FileStdout file) (FileStderr file) (EchoStdout False) (EchoStderr False) (WithStderr False) "ofoo ebar obaz"         liftIO $ assertContents file "foo\nbar\nbaz\n"         liftIO $ waits $ \w -> do             Stderr err <- cmd helper (FileStdout file) (FileStderr file) ["ofoo",w,"ebar",w,"obaz"]@@ -147,14 +147,14 @@             liftIO $ x === "hello world"      "async" !> do-        let file = obj "async.txt"+        let file = "async.txt"         pid <- cmd helper (FileStdout file) "w2" "ohello"         Nothing <- liftIO $ getProcessExitCode pid         ExitSuccess <- liftIO $ waitForProcess pid         liftIO $ assertContents file "hello\n"  -test build obj = do+test build = do     -- reduce the overhead by running all the tests in parallel     -- lint can make a big different to the command lines, so test with and without     whenM hasTracker $
src/Test/Config.hs view
@@ -8,54 +8,51 @@ import Data.Char import qualified Data.HashMap.Strict as Map import Data.Maybe-import System.Directory  -main = shakenCwd test $ \args obj -> do-    want $ map obj ["hsflags.var","cflags.var","none.var","keys"]-    usingConfigFile $ obj "config"-    obj "*.var" %> \out -> do+main = shakeTest_ test $ do+    want ["hsflags.var","cflags.var","none.var","keys"]+    usingConfigFile "config"+    "*.var" %> \out -> do         cfg <- getConfig $ map toUpper $ takeBaseName out         liftIO $ appendFile (out -<.> "times") "X"         writeFile' out $ fromMaybe "" cfg-    obj "keys" %> \out -> do-        liftIO $ appendFile (obj "keys.times") "X"+    "keys" %> \out -> do+        liftIO $ appendFile "keys.times" "X"         liftIO . writeFile out . unwords =<< getConfigKeys  -test build obj = do+test build = do     build ["clean"]-    createDirectoryIfMissing True $ obj ""-    writeFile (obj "config") $ unlines+    writeFile "config" $ unlines         ["HEADERS_DIR = /path/to/dir"         ,"CFLAGS = -O2 -I${HEADERS_DIR} -g"         ,"HSFLAGS = -O2"]     build []-    assertContents (obj "cflags.var") "-O2 -I/path/to/dir -g"-    assertContents (obj "hsflags.var") "-O2"-    assertContents (obj "none.var") ""-    assertContents (obj "keys") "CFLAGS HEADERS_DIR HSFLAGS"+    assertContents "cflags.var" "-O2 -I/path/to/dir -g"+    assertContents "hsflags.var" "-O2"+    assertContents "none.var" ""+    assertContents "keys" "CFLAGS HEADERS_DIR HSFLAGS" -    appendFile (obj "config") $ unlines+    appendFile "config" $ unlines         ["CFLAGS = $CFLAGS -w"]     build []-    assertContents (obj "cflags.var") "-O2 -I/path/to/dir -g -w"-    assertContents (obj "hsflags.var") "-O2"-    assertContents (obj "cflags.times") "XX"-    assertContents (obj "hsflags.times") "X"-    assertContents (obj "keys.times") "X"+    assertContents "cflags.var" "-O2 -I/path/to/dir -g -w"+    assertContents "hsflags.var" "-O2"+    assertContents "cflags.times" "XX"+    assertContents "hsflags.times" "X"+    assertContents "keys.times" "X"      -- Test readConfigFileWithEnv-    writeFile (obj "config") $ unlines+    writeFile "config" $ unlines       ["HEADERS_DIR = ${SOURCE_DIR}/path/to/dir"       ,"CFLAGS = -O2 -I${HEADERS_DIR} -g"]-    vars <- readConfigFileWithEnv [("SOURCE_DIR", "/path/to/src")]-                                  (obj "config")-    assert (Map.lookup "HEADERS_DIR" vars == Just "/path/to/src/path/to/dir")+    vars <- readConfigFileWithEnv [("SOURCE_DIR", "/path/to/src")] "config"+    assertBool (Map.lookup "HEADERS_DIR" vars == Just "/path/to/src/path/to/dir")         $ "readConfigFileWithEnv:"             ++ " Expected: " ++ show (Just "/path/to/src/path/to/dir")             ++ " Got: " ++ show (Map.lookup "HEADERS_DIR" vars)-    assert (Map.lookup "CFLAGS" vars == Just "-O2 -I/path/to/src/path/to/dir -g")+    assertBool (Map.lookup "CFLAGS" vars == Just "-O2 -I/path/to/src/path/to/dir -g")         $ "readConfigFileWithEnv:"             ++ " Expected: " ++ show (Just "-O2 -I/path/to/src/path/to/dir -g")             ++ " Got: " ++ show (Map.lookup "CFLAGS" vars)
src/Test/Digest.hs view
@@ -6,32 +6,36 @@ import Test.Type  -main = shakenCwd test $ \args obj -> do-    if null args then want [obj "Out.txt",obj "Out2.txt"] else want $ map obj args+main = shakeTest_ test $ do+    want ["Out.txt","Out2.txt"] -    obj "Out.txt" %> \out -> do-        txt <- readFile' $ obj "In.txt"+    "Out.txt" %> \out -> do+        txt <- readFile' "In.txt"         liftIO $ appendFile out txt -    [obj "Out1.txt",obj "Out2.txt"] &%> \[out1,out2] -> do-        txt <- readFile' $ obj "In.txt"+    ["Out1.txt","Out2.txt"] &%> \[out1,out2] -> do+        txt <- readFile' "In.txt"         liftIO $ appendFile out1 txt         liftIO $ appendFile out2 txt -    [obj "Bug1.txt",obj "Bug2.txt"] &%> \[out1,out2] -> do-        need [obj "Bug3.txt"]+    ["Bug1.txt","Bug2.txt"] &%> \[out1,out2] -> do+        need ["Bug3.txt"]         writeFile' out1 "X"         writeFile' out2 "Y"      "leaf" ~> return ()-    obj "node1.txt" %> \file -> do need ["leaf"]; writeFile' file "x"-    obj "node2.txt" %> \file -> do need [obj "node1.txt"]; liftIO $ appendFile file "x"+    "node1.txt" %> \file -> do need ["leaf"]; writeFile' file "x"+    "node2.txt" %> \file -> do need ["node1.txt"]; liftIO $ appendFile file "x" +    ["rewrite1","rewrite2"] &%> \outs -> do+        alwaysRerun+        forM_ outs $ \out -> writeFile' out "rewrite" -test build obj = do-    let outs = take 1 $ map obj ["Out.txt","Out1.txt","Out2.txt"]++test build = do+    let outs = ["Out.txt","Out1.txt","Out2.txt"]     let writeOut x = forM_ outs $ \out -> writeFile out x-    let writeIn = writeFile (obj "In.txt")+    let writeIn = writeFile "In.txt"     let assertOut x = forM_ outs $ \out -> assertContents out x      writeOut ""@@ -88,12 +92,16 @@      -- test for #218     forM_ [("--digest",1),("--digest-and",1),("--digest-or",2),("--digest-and-input",2),("",2)] $ \(flag,count) -> do-        writeFile (obj "node2.txt") "y"+        writeFile "node2.txt" "y"         replicateM_ 2 $ build $ ["node2.txt","--sleep"] ++ [flag | flag /= ""]-        assertContents (obj "node2.txt") $ 'y' : replicate count 'x'+        assertContents "node2.txt" $ 'y' : replicate count 'x'      -- test for #296-    writeFile (obj "Bug3.txt") "X"+    writeFile "Bug3.txt" "X"     build ["--digest-and-input","Bug1.txt","--sleep"]-    writeFile (obj "Bug3.txt") "Y"+    writeFile "Bug3.txt" "Y"     build ["--digest-and-input","Bug1.txt","--lint"]++    -- test for #427+    build ["rewrite1","--digest-and"]+    build ["rewrite1","--digest-and","--lint","--sleep"]
src/Test/Directory.hs view
@@ -7,7 +7,7 @@ import Data.List import Data.Function import Control.Monad-import System.Directory(getCurrentDirectory, setCurrentDirectory, createDirectory, createDirectoryIfMissing)+import System.Directory(getCurrentDirectory, createDirectory, createDirectoryIfMissing) import qualified System.Directory as IO import qualified System.IO.Extra as IO @@ -26,49 +26,45 @@           f x = [x]  -main = shakenCwd test $ \args obj -> do-    let unobj = id-    want $ map obj args-    obj "*.contents" %> \out ->-        writeFileLines out =<< getDirectoryContents (obj $ readEsc $ dropExtension $ unobj out)-    obj "*.dirs" %> \out ->-        writeFileLines out =<< getDirectoryDirs (obj $ readEsc $ dropExtension $ unobj out)-    obj "*.files" %> \out -> do-        let pats = readEsc $ dropExtension $ unobj out+main = shakeTest_ test $ do+    "*.contents" %> \out ->+        writeFileLines out =<< getDirectoryContents (readEsc $ dropExtension out)+    "*.dirs" %> \out ->+        writeFileLines out =<< getDirectoryDirs (readEsc $ dropExtension out)+    "*.files" %> \out -> do+        let pats = readEsc $ dropExtension out         let (x:xs) = ["" | " " `isPrefixOf` pats] ++ words pats-        writeFileLines out . map toStandard =<< getDirectoryFiles (obj x) xs+        writeFileLines out . map toStandard =<< getDirectoryFiles x xs -    obj "*.exist" %> \out -> do-        let xs = map obj $ words $ readEsc $ dropExtension $ unobj out+    "*.exist" %> \out -> do+        let xs = words $ readEsc $ dropExtension out         fs <- mapM doesFileExist xs         ds <- mapM doesDirectoryExist xs         let bool x = if x then "1" else "0"         writeFileLines out $ zipWith ((++) `on` bool) fs ds -    obj "dots" %> \out -> do+    "dots" %> \out -> do         cwd <- liftIO getCurrentDirectory-        liftIO $ setCurrentDirectory $ obj ""         b1 <- liftM2 (==) (getDirectoryContents ".") (getDirectoryContents "")         b2 <- liftM2 (==) (getDirectoryDirs ".") (getDirectoryDirs "")         b3 <- liftM2 (==) (getDirectoryFiles "." ["*.txt"]) (getDirectoryFiles "" ["*.txt"])         b4 <- liftM2 (==) (getDirectoryFiles "." ["C.txt/*.txt"]) (getDirectoryFiles "" ["C.txt/*.txt"])         b5 <- liftM2 (==) (getDirectoryFiles "." ["//*.txt"]) (getDirectoryFiles "" ["//*.txt"])-        liftIO $ setCurrentDirectory cwd         writeFileLines out $ map show [b1,b2,b3,b4,b5] -test build obj = do-    let demand x ys = let f = showEsc x in do build [f]; assertContents (obj f) $ unlines $ words ys+test build = do+    let demand x ys = let f = showEsc x in do build [f]; assertContents f $ unlines $ words ys     build ["clean"]     demand " *.txt.files" ""     demand " //*.txt.files" ""     demand ".dirs" ""     demand "A.txt B.txt C.txt.exist" "00 00 00" -    writeFile (obj "A.txt") ""-    writeFile (obj "B.txt") ""-    createDirectory (obj "C.txt")-    writeFile (obj "C.txt/D.txt") ""-    writeFile (obj "C.txt/E.xtx") ""+    writeFile "A.txt" ""+    writeFile "B.txt" ""+    createDirectory "C.txt"+    writeFile "C.txt/D.txt" ""+    writeFile "C.txt/E.xtx" ""     demand " *.txt.files" "A.txt B.txt"     demand ".dirs" "C.txt"     demand "A.txt B.txt C.txt.exist" "10 10 01"@@ -83,7 +79,7 @@     assertException ["missing_dir","does not exist"] $ build ["--quiet",showEsc "missing_dir *.files"]      build ["dots","--no-lint"]-    assertContents (obj "dots") $ unlines $ words "True True True True True"+    assertContents "dots" $ unlines $ words "True True True True True"      let removeTest pat del keep =             IO.withTempDir $ \dir -> do
src/Test/Docs.hs view
@@ -4,6 +4,7 @@  import Development.Shake import Development.Shake.FilePath+import System.Directory import Test.Type import Control.Monad import Data.Char@@ -13,57 +14,61 @@ import Data.Version.Extra  --- Older versions of Haddock garbage the --@ markup-brokenHaddock = compilerVersion < makeVersion [7,8]--main = shaken (\a b -> unless brokenHaddock $ noTest a b) $ \args obj -> do-    let index = obj "dist/doc/html/shake/index.html"-    let config = obj "dist/setup-config"-    want [obj "Success.txt"]+-- Older versions of Haddock garbage the --@ markup and have ambiguity errors+brokenHaddock = compilerVersion < makeVersion [8] -    want $ map (\x -> fromMaybe (obj x) $ stripPrefix "!" x) args+main = shakeTest_ (unless brokenHaddock . noTest) $ do+    let index = "dist/doc/html/shake/index.html"+    let config = "dist/setup-config"+    want ["Success.txt"] -    let needSource = need =<< getDirectoryFiles "." ["src/Development/Shake.hs","src/Development/Shake//*.hs","src/Development/Ninja/*.hs","src/General//*.hs"]+    let needSource = need =<< getDirectoryFiles "." (map (root </>)+            ["src/Development/Shake.hs","src/Development/Shake//*.hs","src/Development/Ninja/*.hs","src/General//*.hs"])      config %> \_ -> do-        need ["shake.cabal","Setup.hs"]+        need $ map (root </>) ["shake.cabal","Setup.hs"]         -- Make Cabal and Stack play nicely         path <- getEnv "GHC_PACKAGE_PATH"-        unit $ cmd (RemEnv "GHC_PACKAGE_PATH") "runhaskell Setup.hs configure"-            ["--builddir=" ++ obj "dist","--user"]+        liftIO $ createDirectoryIfMissing True "dist"+        dist <- liftIO $ canonicalizePath "dist" -- make sure it works even if we cwd+        cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd root) "runhaskell Setup.hs configure"+            ["--builddir=" ++ dist,"--user"]             -- package-db is very sensitive, see #267             ["--package-db=" ++ x | x <- maybe [] (filter (`notElem` [".",""]) . splitSearchPath) path]-        trackAllow [obj "dist//*"]+        trackAllow ["dist//*"]      index %> \_ -> do-        need [config,"shake.cabal","Setup.hs","README.md","CHANGES.txt"]+        need $ config : map (root </>) ["shake.cabal","Setup.hs","README.md","CHANGES.txt"]         needSource-        trackAllow [obj "dist//*"]-        cmd "runhaskell Setup.hs haddock" ["--builddir=" ++ obj "dist"]+        trackAllow ["dist//*"]+        dist <- liftIO $ canonicalizePath "dist"+        cmd (Cwd root) "runhaskell Setup.hs haddock" ["--builddir=" ++ dist] -    obj "Paths_shake.hs" %> \out ->-        copyFile' "src/Paths.hs" out+    "Paths_shake.hs" %> \out ->+        copyFile' (root </> "src/Paths.hs") out -    obj "Part_*.hs" %> \out -> do-        need ["src/Test/Docs.hs"] -- so much of the generator is in this module+    "Part_*.hs" %> \out -> do+        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' $ "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md"+            fmap (findCodeMarkdown . lines . noR) $ readFile' $ root </> "docs/" ++ drop 5 (reverse (drop 3 $ reverse $ takeBaseName out)) ++ ".md"          else-            fmap (findCodeHaddock . noR) $ readFile' $ obj $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html"+            fmap (findCodeHaddock . noR) $ readFile' $ "dist/doc/html/shake/" ++ replace "_" "-" (drop 5 $ takeBaseName out) ++ ".html"          let (imports,rest) = partition ("import " `isPrefixOf`) $ showCode src         writeFileChanged out $ unlines $-            ["{-# LANGUAGE DeriveDataTypeable, RankNTypes, MultiParamTypeClasses, ExtendedDefaultRules, GeneralizedNewtypeDeriving #-}"-            ,"{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables, ConstraintKinds #-}"+            ["{-# LANGUAGE DeriveDataTypeable, RankNTypes, ExtendedDefaultRules, GeneralizedNewtypeDeriving #-}"+            ,"{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables, ConstraintKinds, FlexibleContexts, TypeFamilies #-}"             ,"{-# OPTIONS_GHC -w #-}"             ,"module " ++ takeBaseName out ++ "() where"             ,"import Control.Applicative"             ,"import Control.Concurrent"+            ,"import Control.Exception"             ,"import Control.Monad"             ,"import Data.ByteString(ByteString)"             ,"import Data.Char"             ,"import Data.Data"+            ,"import Data.Dynamic"             ,"import Data.List.Extra"             ,"import System.Time.Extra"             ,"import Data.Maybe"@@ -76,6 +81,7 @@             ,"import System.Console.GetOpt"             ,"import System.Directory(setCurrentDirectory)"             ,"import qualified System.Directory"+            ,"import System.Environment(lookupEnv)"             ,"import System.Process"             ,"import System.Exit"             ,"import Control.Applicative"@@ -111,32 +117,34 @@             ,"(r1,r2) = (return () :: Rules(), return () :: Rules())"             ,"xs = []"             ,"ys = []"+            ,"os = [\"file.o\"]"             ,"out = \"\""             ,"str1 = \"\""             ,"str2 = \"\""             ,"str = \"\""] ++             rest -    obj "Files.lst" %> \out -> do-        need ["src/Test/Docs.hs"] -- so much of the generator is in this module-        need [index,obj "Paths_shake.hs"]-        filesHs <- getDirectoryFiles (obj "dist/doc/html/shake") ["Development-*.html"]-        filesMd <- getDirectoryFiles "docs" ["*.md"]+    "Files.lst" %> \out -> do+        need [root </> "src/Test/Docs.hs"] -- so much of the generator is in this module+        need [index,"Paths_shake.hs"]+        filesHs <- getDirectoryFiles "dist/doc/html/shake" ["Development-*.html"]+        filesMd <- getDirectoryFiles (root </> "docs") ["*.md"]         writeFileChanged out $ unlines $             ["Part_" ++ replace "-" "_" (takeBaseName x) | x <- filesHs, not $ "-Classes.html" `isSuffixOf` x] ++             ["Part_" ++ takeBaseName x ++ "_md" | x <- filesMd, takeBaseName x `notElem` ["Developing","Model"]] -    let needModules = do mods <- readFileLines $ obj "Files.lst"; need [obj m <.> "hs" | m <- mods]; return mods+    let needModules = do mods <- readFileLines "Files.lst"; need [m <.> "hs" | m <- mods]; return mods -    obj "Main.hs" %> \out -> do+    "Main.hs" %> \out -> do         mods <- needModules         writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m | m <- mods] ++ ["main = return ()"] -    obj "Success.txt" %> \out -> do+    "Success.txt" %> \out -> do+        putNormal . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst"         needModules-        need [obj "Main.hs", obj "Paths_shake.hs"]+        need ["Main.hs", "Paths_shake.hs"]         needSource-        unit $ cmd "runhaskell -ignore-package=hashmap " ["-i" ++ obj "","-isrc",obj "Main.hs"]+        cmd_ "ghc -fno-code -ignore-package=hashmap " ["-i.","-i" ++ root </> "src","Main.hs"]         writeFile' out ""  @@ -158,7 +166,7 @@ findCodeMarkdown :: [String] -> [Code] findCodeMarkdown (x:xs) | indented x && not (isBlank x) =     let (a,b) = span (\x -> indented x || isBlank x) (x:xs)-    in Code (unindent a) : findCodeMarkdown b+    in Code (dropWhileEnd isBlank $ unindent a) : findCodeMarkdown b     where         indented x = length (takeWhile isSpace x) >= 4 findCodeMarkdown (x:xs) = map (Code . return) (evens $ splitOn "`" x) ++ findCodeMarkdown xs@@ -176,18 +184,19 @@     where         f i (Code x) | "#" `isPrefixOf` concat x = []                      | all whitelist x = []-                     | otherwise = showStmt i $ filter (not . isBlank . dropComment) $ map (fixCmd . undefDots) x+                     | otherwise = showStmt i $ filter (not . isBlank . dropComment) $ fixCmd $ map undefDots x  -fixCmd :: String -> String-fixCmd x | "cmd " `isPrefixOf` x || "command " `isPrefixOf` x = "unit $ " ++ x-fixCmd x = replace "Stdout out" "Stdout (out :: String)" $ replace "Stderr err" "Stderr (err :: String)" x+fixCmd :: [String] -> [String]+fixCmd xs+    | all ("cmd_ " `isPrefixOf`) xs = xs ++ ["return () :: IO () "]+    | otherwise = map (replace "Stdout out" "Stdout (out :: String)" . replace "Stderr err" "Stderr (err :: String)") xs  -- | Replace ... with undefined (don't use undefined with cmd; two ...'s should become one replacement) undefDots :: String -> String undefDots x | Just x <- stripSuffix "..." x, Just (x,_) <- stripInfix "..." x = x ++ new             | otherwise = replace "..." new x-    where new = if words x `disjoint` ["cmd","Development.Shake.cmd"] then "undefined" else "[\"\"]"+    where new = if words x `disjoint` ["cmd","cmd_","Development.Shake.cmd","Development.Shake.cmd_"] then "undefined" else "[\"\"]"  showStmt :: Int -> [String] -> [String] showStmt i [] = []@@ -256,10 +265,11 @@ types :: [String] types = words $     "MVar IO String FilePath Maybe [String] Char ExitCode Change " ++-    "Action Resource Assume FilePattern Development.Shake.FilePattern " +++    "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"+    "CmdResult ByteString ProcessHandle Rule Monad Monoid Data TypeRep " +++    "BuiltinRun BuiltinLint"  -- | Duplicated identifiers which require renaming dupes :: [String]@@ -267,7 +277,7 @@   isFilePath :: String -> Bool-isFilePath x = all validChar  x && ("foo/" `isPrefixOf` x || takeExtension x `elem` exts)+isFilePath x = "C:\\" `isPrefixOf` x || (all validChar  x && ("foo/" `isPrefixOf` x || takeExtension x `elem` exts))     where         validChar x = isAlphaNum x || x `elem` "_./*"         exts = words $ ".txt .hi .hs .o .exe .tar .cpp .cfg .dep .out .deps .m .h .c .html .zip " ++@@ -275,7 +285,7 @@  isCmdFlag :: String -> Bool isCmdFlag "+RTS" = True-isCmdFlag x = length a >= 1 && length a <= 2 && all (\x -> isAlphaNum x || x `elem` "-=/_[]") b+isCmdFlag x = length a `elem` [1,2] && all (\x -> isAlphaNum x || x `elem` "-=/_[]") b     where (a,b) = span (== '-') x  isCmdFlags :: String -> Bool@@ -290,7 +300,7 @@  isProgram :: String -> Bool isProgram (words -> x:xs) = x `elem` programs && all (\x -> isCmdFlag x || isFilePath x || all isAlpha x || x == "&&") xs-    where programs = words "excel gcc cl make ghc cabal distcc build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack"+    where programs = words "excel gcc cl make ghc cabal distcc build tar git fsatrace ninja touch pwd runhaskell rot13 main shake stack rm cat sed sh"  -- | Should a fragment be whitelisted and not checked whitelist :: String -> Bool@@ -298,7 +308,7 @@ whitelist x | elem x $ words $     "newtype do a q m c x value key os contents clean _make " ++     ".. /. // \\ //* dir/*/* dir " ++-    "ConstraintKinds TemplateHaskell GeneralizedNewtypeDeriving DeriveDataTypeable SetConsoleTitle " +++    "ConstraintKinds TemplateHaskell GeneralizedNewtypeDeriving DeriveDataTypeable TypeFamilies SetConsoleTitle " ++     "Data.List System.Directory Development.Shake.FilePath run " ++     "NoProgress Error src about://tracing " ++     ".make/i586-linux-gcc/output build " ++@@ -308,14 +318,16 @@     "_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"     = True whitelist x = x `elem`     ["[Foo.hi, Foo.o]"     ,"shake-progress"+    ,"type instance"     ,"1m25s (15%)"     ,"3m12s (82%)"     ,"getPkgVersion $ GhcPkgVersion \"shake\""+    ,"ghc --make MyBuildSystem -threaded -rtsopts \"-with-rtsopts=-I0 -qg qb\""     ,"# command-name (for file-name)"     ,"<i>build rules</i>"     ,"<i>actions</i>"@@ -326,7 +338,8 @@     ,"#!/bin/sh"     ,"shake-build-system"     ,"\"_build\" </> x -<.> \"o\""-    ,"cmd \"gcc -o\" [out] os"     ,"[item1,item2,item2]"     ,"$(LitE . StringL . loc_filename <$> location)"+    ,"-d[ FILE], --debug[=FILE]"+    ,"-r[ FILE], --report[=FILE], --profile[=FILE]"     ]
src/Test/Errors.hs view
@@ -7,41 +7,45 @@ import Data.List import Control.Monad import Control.Concurrent+import General.GetOpt import Control.Exception.Extra hiding (assert) import System.Directory as IO+import System.Time.Extra import qualified System.IO.Extra as IO+import Data.Functor+import Prelude +data Args = Die deriving (Eq,Enum,Bounded,Show) -main = shakenCwd test $ \args obj -> do-    want args-    obj "norule" %> \_ ->-        need [obj "norule_isavailable"]+main = shakeTest test optionsEnum $ \args -> do+    "norule" %> \_ ->+        need ["norule_isavailable"] -    obj "failcreate" %> \_ ->+    "failcreate" %> \_ ->         return () -    [obj "failcreates", obj "failcreates2"] &%> \_ ->-        writeFile' (obj "failcreates") ""+    ["failcreates", "failcreates2"] &%> \_ ->+        writeFile' "failcreates" "" -    obj "recursive_" %> \out -> need [obj "intermediate_"]-    obj "intermediate_" %> \out -> need [obj "recursive_"]+    "recursive_" %> \out -> need ["intermediate_"]+    "intermediate_" %> \out -> need ["recursive_"]      "rec1" %> \out -> need ["rec2"]     "rec2" %> \out -> need ["rec1"] -    obj "systemcmd" %> \_ ->+    "systemcmd" %> \_ ->         cmd "random_missing_command" -    obj "stack1" %> \_ -> need [obj "stack2"]-    obj "stack2" %> \_ -> need [obj "stack3"]-    obj "stack3" %> \_ -> error "crash"+    "stack1" %> \_ -> need ["stack2"]+    "stack2" %> \_ -> need ["stack3"]+    "stack3" %> \_ -> error "crash" -    obj "staunch1" %> \out -> do+    "staunch1" %> \out -> do         liftIO $ sleep 0.1         writeFile' out "test"-    obj "staunch2" %> \_ -> error "crash"+    "staunch2" %> \_ -> error "crash" -    let catcher out op = obj out %> \out -> do+    let catcher out op = out %> \out -> do             writeFile' out "0"             op $ do src <- IO.readFile' out; writeFile out $ show (read src + 1 :: Int)     catcher "finally1" $ actionFinally $ fail "die"@@ -53,20 +57,20 @@     catcher "exception2" $ actionOnException $ return ()      res <- newResource "resource_name" 1-    obj "resource" %> \out ->+    "resource" %> \out ->         withResource res 1 $             need ["resource-dep"] -    obj "overlap.txt" %> \out -> writeFile' out "overlap.txt"-    obj "overlap.t*" %> \out -> writeFile' out "overlap.t*"-    obj "overlap.*" %> \out -> writeFile' out "overlap.*"+    "overlap.txt" %> \out -> writeFile' out "overlap.txt"+    "overlap.t*" %> \out -> writeFile' out "overlap.t*"+    "overlap.*" %> \out -> writeFile' out "overlap.*" -    obj "chain.2" %> \out -> do-        src <- readFile' $ obj "chain.1"+    "chain.2" %> \out -> do+        src <- readFile' "chain.1"         if src == "err" then error "err_chain" else writeFileChanged out src-    obj "chain.3" %> \out -> copyFile' (obj "chain.2") out+    "chain.3" %> \out -> copyFile' "chain.2" out -    obj "tempfile" %> \out -> do+    "tempfile" %> \out -> do         file <- withTempFile $ \file -> do             liftIO $ assertExists file             return file@@ -76,7 +80,7 @@             writeFile' out file             fail "tempfile-died" -    obj "tempdir" %> \out -> do+    "tempdir" %> \out -> do         file <- withTempDir $ \dir -> do             let file = dir </> "foo.txt"             liftIO $ writeFile (dir </> "foo.txt") ""@@ -88,27 +92,47 @@     phony "fail1" $ fail "die1"     phony "fail2" $ fail "die2" -    when ("die" `elem` args) $ action $ error "death error"+    when (Die `elem` args) $ action $ error "death error" -    obj "fresh_dir" %> \out -> liftIO $ createDirectoryIfMissing True out-    obj "need_dir" %> \out -> do-        liftIO $ createDirectoryIfMissing True $ obj "existing_dir"-        need [obj "existing_dir"]+    "fresh_dir" %> \out -> liftIO $ createDirectoryIfMissing True out+    "need_dir" %> \out -> do+        liftIO $ createDirectoryIfMissing True "existing_dir"+        need ["existing_dir"]         writeFile' out "" +    "persist_failure.1" %> \out -> do+        liftIO $ appendFile "persist_failure.log" "[pre]"+        need ["persist_failure.2"]+        liftIO $ appendFile "persist_failure.log" "[post]"+        writeFile' out ""+    "persist_failure.2" %> \out -> do+        src <- readFile' "persist_failure.3"+        liftIO $ print ("persist_failure.3", src)+        if src == "die" then do+            liftIO $ appendFile "persist_failure.log" "[err]"+            fail "die"+        else+            writeFileChanged out src +    "fast_failure" %> \out -> do+        liftIO $ sleep 0.1+        fail "die"+    "slow_success" %> \out -> do+        liftIO $ sleep 20+        writeFile' out ""+     -- 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 obj = do+test build = do     let crash args parts = assertException parts (build $ "--quiet" : args)     build ["clean"]     build ["--sleep"] -    writeFile (obj "chain.1") "x"+    writeFile "chain.1" "x"     build ["chain.3","--sleep"]-    writeFile (obj "chain.1") "err"+    writeFile "chain.1" "err"     crash ["chain.3"] ["err_chain"]      crash ["norule"] ["norule_isavailable"]@@ -119,52 +143,68 @@     crash ["systemcmd"] ["systemcmd","random_missing_command"]     crash ["stack1"] ["stack1","stack2","stack3","crash"] -    b <- IO.doesFileExist $ obj "staunch1"-    when b $ removeFile $ obj "staunch1"+    b <- IO.doesFileExist "staunch1"+    when b $ removeFile "staunch1"     crash ["staunch1","staunch2","-j2"] ["crash"]-    b <- IO.doesFileExist $ obj "staunch1"-    assert (not b) "File should not exist, should have crashed first"+    assertBoolIO (not <$> IO.doesFileExist "staunch1") "File should not exist, should have crashed first"     crash ["staunch1","staunch2","-j2","--keep-going","--silent"] ["crash"]-    b <- IO.doesFileExist $ obj "staunch1"-    assert b "File should exist, staunch should have let it be created"+    assertBoolIO (IO.doesFileExist "staunch1") "File should exist, staunch should have let it be created"      crash ["finally1"] ["die"]-    assertContents (obj "finally1") "1"+    assertContents "finally1" "1"     build ["finally2"]-    assertContents (obj "finally2") "1"+    assertContents "finally2" "1"     crash ["exception1"] ["die"]-    assertContents (obj "exception1") "1"+    assertContents "exception1" "1"     build ["exception2"]-    assertContents (obj "exception2") "0"+    assertContents "exception2" "0"      forM_ ["finally3","finally4"] $ \name -> do         t <- forkIO $ ignore $ build [name,"--exception"]-        retry 10 $ sleep 0.1 >> assertContents (obj name) "0"+        retry 10 $ sleep 0.1 >> assertContents name "0"         throwTo t (IndexOutOfBounds "test")-        retry 10 $ sleep 0.1 >> assertContents (obj name) "1"+        retry 10 $ sleep 0.1 >> assertContents name "1"      crash ["resource"] ["cannot currently call apply","withResource","resource_name"]      build ["overlap.foo"]-    assertContents (obj "overlap.foo") "overlap.*"+    assertContents "overlap.foo" "overlap.*"     build ["overlap.txt"]-    assertContents (obj "overlap.txt") "overlap.txt"-    crash ["overlap.txx"] ["key matches multiple rules","overlap.txx"]+    assertContents "overlap.txt" "overlap.txt"+    crash ["overlap.txx"] ["key matches multiple rules","2","overlap.txx"]      crash ["tempfile"] ["tempfile-died"]-    src <- readFile $ obj "tempfile"+    src <- readFile "tempfile"     assertMissing src     build ["tempdir"] -    crash ["die"] ["Shake","action","death error"]+    crash ["--die"] ["Shake","action","death error"]      putStrLn "## BUILD errors"     (out,_) <- IO.captureOutput $ build []-    assert ("nothing to do" `isInfixOf` out) $ "Expected 'nothing to do', but got: " ++ out+    assertBool ("nothing to do" `isInfixOf` out) $ "Expected 'nothing to do', but got: " ++ out      putStrLn "## BUILD errors fail1 fail2 -k -j2"     (out,_) <- IO.captureOutput $ try_ $ build ["fail1","fail2","-k","-j2",""]-    assert ("die1" `isInfixOf` out && "die2" `isInfixOf` out) $ "Expected 'die1' and 'die2', but got: " ++ out+    assertBool ("die1" `isInfixOf` out && "die2" `isInfixOf` out) $ "Expected 'die1' and 'die2', but got: " ++ out      crash ["fresh_dir"] ["expected a file, got a directory","fresh_dir"]     crash ["need_dir"] ["expected a file, got a directory","existing_dir"]++    -- check errors don't persist to the database, #428+    writeFile "persist_failure.log" ""+    writeFile "persist_failure.3" "test"+    build ["persist_failure.1","--sleep"]+    writeFile "persist_failure.3" "die"+    crash ["persist_failure.1","--sleep"] []+    assertContents "persist_failure.log" "[pre][post][err][pre]"+    writeFile "persist_failure.3" "test"+    build ["persist_failure.1","--sleep"]+    assertContents "persist_failure.log" "[pre][post][err][pre]"+    writeFile "persist_failure.3" "more"+    build ["persist_failure.1"]+    assertContents "persist_failure.log" "[pre][post][err][pre][pre][post]"++    -- check a fast failure aborts a slow success+    (t, _) <- duration $ crash ["fast_failure","slow_success","-j2"] ["die"]+    assertBool (t < 10) $ "Took too long, expected < 10, got " ++ show t
+ src/Test/Existence.hs view
@@ -0,0 +1,27 @@+module Test.Existence(main) where++import           Development.Shake                   (getDirectoryFilesIO)+import           Development.Shake.Internal.FileInfo (getFileInfo)+import           Development.Shake.Internal.FileName (fileNameFromString)+import           System.Directory                    (getCurrentDirectory)+import           System.FilePath                     ((</>))++main :: IO () -> IO ()+main _ = do+    cwd <- getCurrentDirectory+    someFiles <- getDirectoryFilesIO cwd ["*"]+    let someFile = head someFiles+    assertIsJust . getFileInfo $ fileNameFromString someFile++    let fileThatCantExist = someFile </> "fileThatCantExist"+    assertIsNothing . getFileInfo $ fileNameFromString fileThatCantExist++assertIsJust :: IO (Maybe a) -> IO ()+assertIsJust action = do+    Just _ <- action+    return ()++assertIsNothing :: IO (Maybe a) -> IO ()+assertIsNothing action = do+    Nothing <- action+    return ()
src/Test/FileLock.hs view
@@ -10,14 +10,14 @@ import Test.Type  -main = shaken test $ \args obj ->+main = shakeTest_ test $     action $ do         putNormal "Starting sleep"         liftIO $ sleep 5         putNormal "Finished sleep"  -test build obj = do+test build = do     -- check it fails exactly once     time <- offsetTime     lock <- newLock@@ -31,6 +31,6 @@     b <- try_ b     out "after try b"     when (length (filter isLeft [a,b]) /= 1) $-        error $ "Expected one success and one failure, got " ++ show [a,b]+        fail $ "Expected one success and one failure, got " ++ show [a,b]     -- check it succeeds after the lock has been held     build []
src/Test/FilePath.hs view
@@ -9,11 +9,11 @@ import Control.Monad import Data.List import qualified Data.ByteString.Char8 as BS-import qualified Development.Shake.ByteString as BS+import qualified Development.Shake.Internal.FileName as BS import System.Info.Extra  -main = shakenCwd test $ \args obj -> return ()+main = shakeTest_ test $ return ()   newtype File = File String deriving Show@@ -23,7 +23,7 @@     shrink (File x) = map File $ shrink x  -test build obj = do+test build = do     let a === b = a Test.Type.=== b -- duplicate definition in QuickCheck 2.7 and above      let norm x =@@ -66,7 +66,7 @@         let y = norm x             sep = Native.isPathSeparator             noDrive = if isWindows then drop 1 else id-            ps = [length y >= 1+            ps = [y /= ""                  ,null x || (sep (head x) == sep (head y) && sep (last x) == sep (last y))                  ,not $ "/./" `isInfixOf` y                  ,not isWindows || '\\' `notElem` y
src/Test/FilePattern.hs view
@@ -1,7 +1,7 @@  module Test.FilePattern(main) where -import Development.Shake.FilePattern+import Development.Shake.Internal.FilePattern import Development.Shake.FilePath import Control.Monad import System.IO.Unsafe@@ -10,7 +10,7 @@ import Test.Type import Test.QuickCheck hiding ((===)) -main = shakenCwd test $ \args obj -> return ()+main = shakeTest_ test $ return ()   newtype Pattern = Pattern FilePattern deriving (Show,Eq)@@ -27,12 +27,13 @@     shrink (Path x) = map Path $ shrinkList (\x -> ['/' | x == '\\']) x  -test build obj = do+test build = do     internalTest+    let norm = filter (/= ".") . split isPathSeparator     let f b pat file = do-            assert (b == (pat ?== file)) $ show pat ++ " ?== " ++ show file ++ "\nEXPECTED: " ++ show b-            assert (b == (pat `walker` file)) $ show pat ++ " `walker` " ++ show file ++ "\nEXPECTED: " ++ show b-            when b $ assert (toStandard (substitute (extract pat file) pat) == toStandard file) $+            assertBool (b == (pat ?== file)) $ show pat ++ " ?== " ++ show file ++ "\nEXPECTED: " ++ show b+            assertBool (b == (pat `walker` file)) $ show pat ++ " `walker` " ++ show file ++ "\nEXPECTED: " ++ show b+            when b $ assertBool (norm (substitute (extract pat file) pat) == norm file) $                 "FAILED substitute/extract property\nPattern: " ++ show pat ++ "\nFile: " ++ show file ++ "\n" ++                 "Extracted: " ++ show (extract pat file) ++ "\nSubstitute: " ++ show (substitute (extract pat file) pat) @@ -130,6 +131,19 @@     f (not isWindows) "**" "C:\\drive"     f (not isWindows) "**" "C:drive" +    -- We support ignoring '.' values in FilePath as they are inserted by @filepath@ a lot+    f True "./file" "file"+    f True ("" </> "file") "file"+    f True "foo/./bar" "foo/bar"+    f True "foo/./bar" "foo/./bar"+    f False "foo/./bar" "foo/bob"++    filePattern "**/*.c" "test.txt" === Nothing+    filePattern "**/*.c" "foo.c" === Just ["","foo"]+    filePattern "**/*.c" "bar/baz/foo.c" === Just ["bar/baz/","foo"]+    filePattern "**/*.c" "bar\\baz\\foo.c" === Just+        (if isWindows then ["bar/baz/","foo"] else ["","bar\\baz\\foo"])+     simple "a*b" === False     simple "a//b" === False     simple "a/**/b" === False@@ -137,12 +151,12 @@     simple "a///b" === False     simple "a/**/b" === False -    assert (compatible []) "compatible"-    assert (compatible ["//*a.txt","foo//a*.txt"]) "compatible"-    assert (compatible ["**/*a.txt","foo/**/a*.txt"]) "compatible"-    assert (compatible ["//*a.txt","foo/**/a*.txt"]) "compatible"-    assert (not $ compatible ["//*a.txt","foo//a*.*txt"]) "compatible"-    assert (not $ compatible ["**/*a.txt","foo/**/a*.*txt"]) "compatible"+    assertBool (compatible []) "compatible"+    assertBool (compatible ["//*a.txt","foo//a*.txt"]) "compatible"+    assertBool (compatible ["**/*a.txt","foo/**/a*.txt"]) "compatible"+    assertBool (compatible ["//*a.txt","foo/**/a*.txt"]) "compatible"+    assertBool (not $ compatible ["//*a.txt","foo//a*.*txt"]) "compatible"+    assertBool (not $ compatible ["**/*a.txt","foo/**/a*.*txt"]) "compatible"     extract "//*a.txt" "foo/bar/testa.txt" === ["foo/bar/","test"]     extract "**/*a.txt" "foo/bar/testa.txt" === ["foo/bar/","test"]     extract "//*a.txt" "testa.txt" === ["","test"]@@ -195,6 +209,7 @@ walker a b | isRelativePattern a, not $ isRelativePath b = False walker a b = f (split isPathSeparator b) $ snd $ walk [a]     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
src/Test/Files.hs view
@@ -3,27 +3,40 @@  import Development.Shake import Development.Shake.FilePath+import System.Directory import Test.Type import Control.Monad import Data.List+import General.GetOpt +data Args = UsePredicate deriving (Eq,Show,Bounded,Enum) -main = shakenCwd test $ \args obj -> do-    let fun = "@" `elem` args-    let rest = delete "@" args-    want $ map obj $ if null rest then ["even.txt","odd.txt"] else rest+main = shakeTest test optionsEnum $ \opts -> do+    want ["even.txt","odd.txt"] +    "A1-plus-B" %> \out -> do+        a1 <- readFileLines "A1"+        b  <- readFileLines "B"+        writeFileLines out $ a1 ++ b++    ["A1", "A2"] &%> \[o1, o2] -> do+        writeFileLines o1 ["This is", "A1"]+        writeFileLines o2 ["This is", "A2"]++    "B" %> \out ->+        writeFileLines out ["This is", "B"]+     -- Since &?> and &%> are implemented separately we test everything in both modes-    let deps &?%> act | fun = (\x -> if x `elem` deps then Just deps else Nothing) &?> act+    let deps &?%> act | UsePredicate `elem` opts = (\x -> if x `elem` deps then Just deps else Nothing) &?> act                       | otherwise = deps &%> act -    map obj ["even.txt","odd.txt"] &?%> \[evens,odds] -> do-        src <- readFileLines $ obj "numbers.txt"+    ["even.txt","odd.txt"] &?%> \[evens,odds] -> do+        src <- readFileLines "numbers.txt"         let (es,os) = partition even $ map read src         writeFileLines evens $ map show es         writeFileLines odds  $ map show os -    map obj ["dir1/out.txt","dir2/out.txt"] &?%> \[a,b] -> do+    ["dir1/out.txt","dir2/out.txt"] &?%> \[a,b] -> do         writeFile' a "a"         writeFile' b "b" @@ -32,15 +45,20 @@         mapM_ (`writeFile'` "") outs  -test build obj = do-    forM_ [[],["@"]] $ \args -> do+test build = do+    forM_ [[],["--usepredicate"]] $ \args -> do         let nums = unlines . map show-        writeFile (obj "numbers.txt") $ nums [1,2,4,5,2,3,1]+        writeFile "numbers.txt" $ nums [1,2,4,5,2,3,1]         build ("--sleep":args)-        assertContents (obj "even.txt") $ nums [2,4,2]-        assertContents (obj "odd.txt" ) $ nums [1,5,3,1]+        assertContents "even.txt" $ nums [2,4,2]+        assertContents "odd.txt"  $ nums [1,5,3,1]         build ["clean"]         build ["--no-build","--report=-"]         build ["dir1/out.txt"]      build ["pred/a.txt"]++    -- Test #496+    build ["A1-plus-B"]+    removeFile "A2"+    build ["A1-plus-B"]
src/Test/Forward.hs view
@@ -7,16 +7,16 @@ import Control.Monad.Extra import Test.Type -main = shaken test $ \args obj -> forwardRule $ do-    let src = "src/Test/C"+main = shakeTest_ test $ forwardRule $ do+    let src = root </> "src/Test/C"     cs <- getDirectoryFiles src ["*.c"]     os <- forP cs $ \c -> do-        let o = obj c <.> "o"+        let o = c <.> "o"         cache $ cmd "gcc -c" [src </> c] "-o" [o]         return o-    cache $ cmd "gcc -o" [obj "Main" <.> exe] os+    cache $ cmd "gcc -o" ["Main" <.> exe] os -test build obj = do+test build =     whenM hasTracker $ do         build ["--forward","--clean"]         build ["--forward","-j2"]
src/Test/Journal.hs view
@@ -14,16 +14,15 @@ rebuilt = unsafePerformIO $ newIORef 0  -main = shakenCwd test $ \args obj -> do-    want $ map obj ["a.out","b.out","c.out"]-    obj "*.out" %> \out -> do+main = shakeTest_ test $ do+    want ["a.out","b.out","c.out"]+    "*.out" %> \out -> do         liftIO $ atomicModifyIORef rebuilt $ \a -> (a+1,())         copyFile' (out -<.> "in") out  -test build obj = do-    -    let change x = writeFile (obj $ x <.> "in") x+test build = do+    let change x = writeFile (x <.> "in") x     let count x = do             before <- readIORef rebuilt             build ["--sleep"]
src/Test/Lint.hs view
@@ -1,110 +1,113 @@+{-# LANGUAGE TypeFamilies, GeneralizedNewtypeDeriving, DeriveDataTypeable #-}  module Test.Lint(main) where  import Development.Shake+import Development.Shake.Classes import Development.Shake.FilePath import Test.Type-import Control.Exception hiding (assert)+import Control.Exception import System.Directory as IO import System.Info.Extra import Control.Monad.Extra +newtype Zero = Zero () deriving (Eq, Show, NFData, Typeable, Hashable, Binary) -main = shaken test $ \args obj -> do-    want $ map obj args+type instance RuleResult Zero = Zero -    addOracle $ \() -> do-        liftIO $ createDirectoryIfMissing True $ obj "dir"-        liftIO $ setCurrentDirectory $ obj "dir"-        return ()+main = shakeTest_ test $ do+    addOracle $ \Zero{} -> do+        liftIO $ createDirectoryIfMissing True "dir"+        liftIO $ setCurrentDirectory "dir"+        return $ Zero () -    obj "changedir" %> \out -> do-        () <- askOracle ()+    "changedir" %> \out -> do+        Zero () <- askOracle $ Zero ()         writeFile' out "" -    obj "pause.*" %> \out -> do+    "pause.*" %> \out -> do         liftIO $ sleep 0.1-        need [obj "cdir" <.> takeExtension out]+        need ["cdir" <.> takeExtension out]         writeFile' out "" -    obj "cdir.*" %> \out -> do+    "cdir.*" %> \out -> do         pwd <- liftIO getCurrentDirectory-        let dir2 = obj $ "dir" ++ takeExtension out+        let dir2 = "dir" ++ takeExtension out         liftIO $ createDirectoryIfMissing True dir2         liftIO $ setCurrentDirectory dir2         liftIO $ sleep 0.2         liftIO $ setCurrentDirectory pwd         writeFile' out "" -    obj "createonce" %> \out ->+    "createonce" %> \out ->         writeFile' out "X" -    obj "createtwice" %> \out -> do-        need [obj "createonce"]+    "createtwice" %> \out -> do+        need ["createonce"]         liftIO sleepFileTime-        writeFile' (obj "createonce") "Y"+        writeFile' "createonce" "Y"         writeFile' out "" -    obj "listing" %> \out -> do+    "listing" %> \out -> do         writeFile' (out <.> "ls1") ""-        getDirectoryFiles (obj "") ["//*.ls*"]+        getDirectoryFiles "" ["//*.ls*"]         writeFile' (out <.> "ls2") ""         writeFile' out "" -    obj "existance" %> \out -> do-        Development.Shake.doesFileExist $ obj "exists"-        writeFile' (obj "exists") ""+    "existance" %> \out -> do+        Development.Shake.doesFileExist "exists"+        writeFile' "exists" ""         writeFile' out "" -    obj "gen*" %> \out ->+    "gen*" %> \out ->         writeFile' out out -    obj "needed1" %> \out -> do-        needed [obj "gen1"]+    "needed1" %> \out -> do+        needed ["gen1"]         writeFile' out "" -    obj "needed2" %> \out -> do-        orderOnly [obj "gen2"]-        needed [obj "gen2"]+    "needed2" %> \out -> do+        orderOnly ["gen2"]+        needed ["gen2"]         writeFile' out "" -    obj "tracker-write1" %> \out -> do+    "tracker-write1" %> \out -> do         gen "x" $ out <.> "txt"         need [out <.> "txt"]         writeFile' out "" -    obj "tracker-write2" %> \out -> do+    "tracker-write2" %> \out -> do         gen "x" $ out <.> "txt"         writeFile' out "" -    obj "tracker-source2" %> \out -> copyFile' (obj "tracker-source1") out-    obj "tracker-read1" %> \out -> do-        access $ obj "tracker-source1"+    "tracker-source2" %> \out -> copyFile' "tracker-source1" out+    "tracker-read1" %> \out -> do+        access "tracker-source1"         writeFile' out ""-    obj "tracker-read2" %> \out -> do-        access $ obj "tracker-source1"-        need [obj "tracker-source1"]+    "tracker-read2" %> \out -> do+        access "tracker-source1"+        need ["tracker-source1"]         writeFile' out ""-    obj "tracker-read3" %> \out -> do-        access $ obj "tracker-source2"-        need [obj "tracker-source2"]+    "tracker-read3" %> \out -> do+        access "tracker-source2"+        need ["tracker-source2"]         writeFile' out "" -    obj "tracker-compile.o" %> \out -> do-        need [obj "tracker-source.c", obj "tracker-source.h"]-        cmd "gcc" ["-c", obj "tracker-source.c", "-o", out]+    "tracker-compile.o" %> \out -> do+        need ["tracker-source.c", "tracker-source.h"]+        cmd "gcc" ["-c", "tracker-source.c", "-o", out] -    obj "tracker-compile-auto.o" %> \out -> do-        need [obj "tracker-source.c"]-        cmd AutoDeps "gcc" ["-c", obj "tracker-source.c", "-o", out]+    "tracker-compile-auto.o" %> \out -> do+        need ["tracker-source.c"]+        cmd AutoDeps "gcc" ["-c", "tracker-source.c", "-o", out] -    where gen t f = unit $ cmd Shell "echo" t ">" (toNative f)-          access f = unit $ if isWindows-                            then cmd Shell "type" (toNative f) "> nul"-                            else cmd Shell "cat" f "> /dev/null"+    where gen t f = cmd Shell "echo" t ">" (toNative f) :: Action ()+          access f = if isWindows+                     then cmd_ Shell "type" (toNative f) "> nul"+                     else cmd_ Shell "cat" f "> /dev/null"  -test build obj = do+test build = do     dir <- getCurrentDirectory     let crash args parts =             assertException parts (build $ "--quiet" : args)@@ -113,22 +116,22 @@     crash ["changedir"] ["current directory has changed"]     build ["cdir.1","cdir.2","-j1"]     build ["--clean","cdir.1","pause.2","-j1"]-    crash ["--clean","cdir.1","pause.2","-j2"] ["before building output/lint/","current directory has changed"]+    crash ["--clean","cdir.1","pause.2","-j2"] ["output","lint","current directory has changed"]     crash ["existance"] ["changed since being depended upon"]     crash ["createtwice"] ["changed since being depended upon"]-    crash ["listing"] ["changed since being depended upon","output/lint"]+    crash ["listing"] ["changed since being depended upon","listing.ls2"]     crash ["--clean","listing","existance"] ["changed since being depended upon"]     crash ["needed1"] ["'needed' file required rebuilding"]     build ["needed2"]     whenM hasTracker $ do-        writeFile (obj "tracker-source1") ""-        writeFile (obj "tracker-source2") ""-        writeFile (obj "tracker-source.c") "#include <stdio.h>\n#include \"tracker-source.h\"\n"-        writeFile (obj "tracker-source.h") ""-        crash ["tracker-write1"] ["not have its creation tracked","lint/tracker-write1","lint/tracker-write1.txt"]+        writeFile "tracker-source1" ""+        writeFile "tracker-source2" ""+        writeFile "tracker-source.c" "#include <stdio.h>\n#include \"tracker-source.h\"\n"+        writeFile "tracker-source.h" ""+        crash ["tracker-write1"] ["not have its creation tracked","tracker-write1","tracker-write1.txt"]         build ["tracker-write2"]-        crash ["tracker-read1"] ["used but not depended upon","lint/tracker-source1"]+        crash ["tracker-read1"] ["used but not depended upon","tracker-source1"]         build ["tracker-read2"]-        crash ["tracker-read3"] ["depended upon after being used","lint/tracker-source2"]+        crash ["tracker-read3"] ["depended upon after being used","tracker-source2"]         build ["tracker-compile.o"]         build ["tracker-compile-auto.o"]
src/Test/Live.hs view
@@ -5,24 +5,22 @@ import Test.Type  -main = shakenCwd test $ \args obj -> do-    want $ map obj args--    obj "foo" %> \ out -> do-        need [obj "bar"]+main = shakeTest_ test $ do+    "foo" %> \ out -> do+        need ["bar"]         writeFile' out "" -    obj "bar" %> \out -> writeFile' out ""-    obj "baz" %> \out -> writeFile' out ""+    "bar" %> \out -> writeFile' out ""+    "baz" %> \out -> writeFile' out ""  -test build obj = do+test build = do     build ["clean"]-    build ["foo","baz","--live=" ++ obj "live.txt"]-    assertContentsUnordered (obj "live.txt") $ map obj $ words "foo bar baz"-    build ["foo","baz","--live=" ++ obj "live.txt"]-    assertContentsUnordered (obj "live.txt") $ map obj $ words "foo bar baz"-    build ["foo","--live=" ++ obj "live.txt"]-    assertContentsUnordered (obj "live.txt") $ map obj $ words "foo bar"-    build ["bar","--live=" ++ obj "live.txt"]-    assertContentsUnordered (obj "live.txt") $ map obj $ words "bar"+    build ["foo","baz","--live=live.txt"]+    assertContentsUnordered "live.txt" $ words "foo bar baz"+    build ["foo","baz","--live=live.txt"]+    assertContentsUnordered "live.txt" $ words "foo bar baz"+    build ["foo","--live=live.txt"]+    assertContentsUnordered "live.txt" $ words "foo bar"+    build ["bar","--live=live.txt"]+    assertContentsUnordered "live.txt" $ words "bar"
− src/Test/MakeTutor/Makefile 
@@ -1,17 +0,0 @@-# From http://www.cs.colby.edu/maxwell/courses/tutorials/maketutor/, Makefile 4--CC=gcc-CFLAGS=-I.-DEPS = hellomake.h-OBJ = hellomake.o hellofunc.o --hellomake$(EXE): $(OBJ)-	$(CC) -o $@ $^ $(CFLAGS)--%.o: %.c $(DEPS)-	$(CC) -c -o $@ $< $(CFLAGS)--.PHONY: clean-clean:-	rm hellomake$(EXE)-	rm *.o
− src/Test/MakeTutor/hellofunc.c 
@@ -1,9 +0,0 @@-#include <stdio.h>-#include <hellomake.h>--void myPrintHelloMake(void) {--  printf("Hello makefiles!\n");--  return;-}
− src/Test/MakeTutor/hellomake.c 
@@ -1,8 +0,0 @@-#include <hellomake.h>--int main() {-  // call a function in another file-  myPrintHelloMake();--  return(0);-}
− src/Test/MakeTutor/hellomake.h 
@@ -1,5 +0,0 @@-/*-example include file-*/--void myPrintHelloMake(void);
− src/Test/Makefile.hs 
@@ -1,28 +0,0 @@--module Test.Makefile(main) where--import Development.Shake(action, liftIO)-import qualified Run as Makefile-import System.Environment-import Test.Type-import Control.Monad-import Data.List-import Data.Maybe---main = shaken test $ \args obj ->-    action $ liftIO $ do-        unless (["@@"] `isPrefixOf` args) $-            error "The 'makefile' example should only be used in test mode, to test using a makefile use the 'make' example."-        withArgs [fromMaybe x $ stripPrefix "@" x | x <- drop 1 args] Makefile.main---test build obj = do-    copyDirectoryChanged "src/Test/MakeTutor" $ obj "MakeTutor"-    build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]-    build ["@@","--directory=" ++ obj "MakeTutor","--no-report"]-    build ["@@","--directory=" ++ obj "MakeTutor","@clean","--no-report"]-    writeFile (obj "output.txt") "goodbye"-    writeFile (obj "Shakefile.hs") "main = writeFile \"output.txt\" \"hello\""-    build ["@@","--directory=" ++ obj ""]-    assertContents (obj "output.txt") "hello"
src/Test/Manual.hs view
@@ -7,17 +7,20 @@ import System.Info.Extra  -main = shaken test $ \args obj ->-    action $ liftIO $ error "The 'manual' example should only be used in test mode"+main = shakeTest_ test $+    action $ fail "The 'manual' example should only be used in test mode" -test build obj = do-    copyDirectoryChanged "docs/manual" $ obj "manual"-    copyDirectoryChanged "src/Development" $ obj "manual/Development"-    copyDirectoryChanged "src/General" $ obj "manual/General"-    copyFileChanged "src/Paths.hs" $ obj "manual/Paths_shake.hs"+test build = 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"     let cmdline = if isWindows then "build.bat" else "/bin/sh build.sh"-    () <- cmd [Cwd $ obj "manual", Shell] cmdline "-j2"-    assertExists $ obj "manual/_build/run" <.> exe-    () <- cmd [Cwd $ obj "manual", Shell] cmdline-    () <- cmd [Cwd $ obj "manual", Shell] [cmdline,"clean"]-    assertMissing $ obj "manual/_build/run" <.> exe+    cmd_ [Cwd dest, Shell] cmdline "-j2"+    assertExists $ dest </> "_build/run" <.> exe+    cmd_ [Cwd dest, Shell] cmdline+    cmd_ [Cwd dest, Shell] [cmdline,"clean"]+    assertMissing $ dest </> "_build/run" <.> exe
src/Test/Match.hs view
@@ -6,58 +6,58 @@ import Test.Type  -main = shakenCwd test $ \args obj -> do-    want $ map obj args-    let output x = \file -> writeFile' file x+main = shakeTest_ test $ do+    let output x file = writeFile' file x      ["or*","*or"] |%> output ""      alternatives $ do-        obj "alternative.t*" %> output "alternative.t*"-        obj "alternative.*" %> output "alternative.*"+        "alternative.t*" %> output "alternative.t*"+        "alternative.*" %> output "alternative.*" -    priority 100 $ priority 0 $ obj "priority.txt" %> output "100"-    priority 50 $ obj "priority.txt" %> output "50"+    priority 100 $ priority 0 $ "priority.txt" %> output "100"+    priority 50 $ "priority.txt" %> output "50"      alternatives $ do-        priority 20 $ obj "altpri.txt" %> output "20"-        priority 40 $ obj "altpri.txt" %> output "40"-    priority 30 $ obj "altpri.txt" %> output "30"+        priority 20 $ "altpri.txt" %> output "20"+        priority 40 $ "altpri.txt" %> output "40"+    priority 30 $ "altpri.txt" %> output "30"      alternatives $ do-        priority 21 $ obj "altpri2.txt" %> output "21"-        priority 22 $ obj "altpri2.txt" %> output "22"-    priority 23 $ obj "altpri2.txt" %> output "23"+        priority 21 $ "altpri2.txt" %> output "21"+        priority 22 $ "altpri2.txt" %> output "22"+    priority 23 $ "altpri2.txt" %> output "23" -    priority 55 $ alternatives $ obj "x" %> output "55"-    priority 51 $ obj "x" %> output "51"+    priority 55 $ alternatives $ "x" %> output "55"+    priority 51 $ "x" %> output "51" -    priority 42 $ alternatives $ obj "xx" %> output "42"-    priority 43 $ obj "xx" %> output "43"+    priority 42 $ alternatives $ "xx" %> output "42"+    priority 43 $ "xx" %> output "43"      priority 10 $ do-        priority 7 $ obj "change" %> output "7"-        priority 8 $ obj "change" %> output "8"-    priority 9 $ obj "change" %> output "9"+        priority 6 $ "change" %> output "6"+        priority 7 $ "change" %> output "7"+        priority 8 $ "change" %> output "8"+    priority 9 $ "change" %> output "9"  -test build obj = do+test build = do     build ["clean"]     build ["or"]      build ["alternative.foo","alternative.txt"]-    assertContents (obj "alternative.foo") "alternative.*"-    assertContents (obj "alternative.txt") "alternative.t*"+    assertContents "alternative.foo" "alternative.*"+    assertContents "alternative.txt" "alternative.t*"      build ["priority.txt"]-    assertContents (obj "priority.txt") "100"+    assertContents "priority.txt" "100"      build ["altpri.txt","altpri2.txt"]-    assertContents (obj "altpri.txt") "20"-    assertContents (obj "altpri2.txt") "23"+    assertContents "altpri.txt" "20"+    assertContents "altpri2.txt" "23"      build ["x","xx"]-    assertContents (obj "x") "55"-    assertContents (obj "xx") "43"+    assertContents "x" "55"+    assertContents "xx" "43" -    assertException ["matches multiple rules"] $ build ["change","--quiet"]+    assertException ["matches multiple rules","3"] $ build ["change","--quiet"]
src/Test/Monad.hs view
@@ -2,16 +2,16 @@ module Test.Monad(main) where  import Test.Type-import Development.Shake.Monad+import Development.Shake.Internal.Core.Monad  import Data.IORef import Control.Concurrent-import Control.Exception hiding (assert)+import Control.Exception import Control.Monad import Control.Monad.IO.Class  -main = shakenCwd test $ \args obj -> return ()+main = shakeTest_ test $ return ()   run :: ro -> rw -> RAW ro rw a -> IO a@@ -21,7 +21,7 @@     either throwIO return =<< readMVar res  -test build obj = do+test build = do     let conv x = either (Left . fromException) Right x :: Either (Maybe ArithException) Int     let dump ro rw = do liftIO . (=== ro) =<< getRO; liftIO . (=== rw) =<< getRW
src/Test/Ninja.hs view
@@ -6,6 +6,7 @@ import System.Directory(copyFile, createDirectoryIfMissing, removeFile) import Control.Applicative import Control.Monad+import General.GetOpt import Test.Type import qualified Data.HashMap.Strict as Map import Data.List@@ -15,75 +16,76 @@ import System.Environment import Prelude +opts = Option "" ["arg"] (ReqArg Right "") "" -main = shaken test $ \args obj -> do-    let args2 = ("-C" ++ obj "") : map tail (filter ("@" `isPrefixOf`) args)-    let real = "real" `elem` args+main = shakeTest test [opts] $ \opts -> do+    let args2 = "-C." : opts+    let real = "real" `elem` args2     action $         if real then cmd "ninja" args2 else liftIO $ withArgs args2 Run.main  -test build obj = do-    -- when calling run anything with a leading @ gets given to Shake, anything without gets given to Ninja-    let run xs = build $ "--exception" : map (\x -> fromMaybe ('@':x) $ stripPrefix "@" x) (words xs)-    let runFail xs bad = assertException [bad] $ run $ xs ++ " --quiet"+test build = do+    let runEx ninja shake = build $ "--exception" : map ("--arg=" ++) (words ninja) ++ words shake+    let run ninja = runEx ninja []+    let runFail ninja bad = assertException [bad] $ runEx ninja "--quiet"      build ["clean"]     run "-f../../src/Test/Ninja/test1.ninja"-    assertExists $ obj "out1.txt"+    assertExists "out1.txt"      run "-f../../src/Test/Ninja/test2.ninja"-    assertExists $ obj "out2.2"-    assertMissing $ obj "out2.1"+    assertExists "out2.2"+    assertMissing "out2.1"     build ["clean"]     run "-f../../src/Test/Ninja/test2.ninja out2.1"-    assertExists $ obj "out2.1"-    assertMissing $ obj "out2.2"+    assertExists "out2.1"+    assertMissing "out2.2" -    copyFile "src/Test/Ninja/test3-sub.ninja" $ obj "test3-sub.ninja"-    copyFile "src/Test/Ninja/test3-inc.ninja" $ obj "test3-inc.ninja"-    createDirectoryIfMissing True $ obj "subdir"-    copyFile "src/Test/Ninja/subdir/1.ninja" $ obj "subdir/1.ninja"-    copyFile "src/Test/Ninja/subdir/2.ninja" $ obj "subdir/2.ninja"+    copyFile "../../src/Test/Ninja/test3-sub.ninja" "test3-sub.ninja"+    copyFile "../../src/Test/Ninja/test3-inc.ninja" "test3-inc.ninja"+    createDirectoryIfMissing True "subdir"+    copyFile "../../src/Test/Ninja/subdir/1.ninja" "subdir/1.ninja"+    copyFile "../../src/Test/Ninja/subdir/2.ninja" "subdir/2.ninja"     run "-f../../src/Test/Ninja/test3.ninja"-    assertContentsWords (obj "out3.1") "g4+b1+++i1"-    assertContentsWords (obj "out3.2") "g4++++i1"-    assertContentsWords (obj "out3.3") "g4++++i1"-    assertContentsWords (obj "out3.4") "g4+++s1+s2"+    assertContentsWords "out3.1" "g4+b1+++i1"+    assertContentsWords "out3.2" "g4++++i1"+    assertContentsWords "out3.3" "g4++++i1"+    assertContentsWords "out3.4" "g4+++s1+s2"      run "-f../../src/Test/Ninja/test4.ninja out"-    assertExists $ obj "out.txt"-    assertExists $ obj "out2.txt"+    assertExists "out.txt"+    assertExists "out2.txt"      run "-f../../src/Test/Ninja/test5.ninja"-    assertExists $ obj "output file"+    assertExists "output file" -    writeFile (obj "nocreate.log") ""-    writeFile (obj "nocreate.in") ""+    writeFile "nocreate.log" ""+    writeFile "nocreate.in" ""     run "-f../../src/Test/Ninja/nocreate.ninja"-    assertContentsWords (obj "nocreate.log") "x"+    assertContentsWords "nocreate.log" "x"     run "-f../../src/Test/Ninja/nocreate.ninja"     run "-f../../src/Test/Ninja/nocreate.ninja"-    assertContentsWords (obj "nocreate.log") "x x x"+    assertContentsWords "nocreate.log" "x x x" -    writeFile (obj "input") ""+    writeFile "input" ""     runFail "-f../../src/Test/Ninja/lint.ninja bad --lint" "'needed' file required rebuilding"     run "-f../../src/Test/Ninja/lint.ninja good --lint"     runFail "-f../../src/Test/Ninja/lint.ninja bad --lint" "not a pre-dependency" -    res <- fmap (drop 1 . lines . fst) $ captureOutput $ run "-f../../src/Test/Ninja/compdb.ninja -t compdb cxx @--no-report @--quiet"-    want <- lines <$> readFile "src/Test/Ninja/compdb.output"+    res <- fmap (drop 1 . lines . fst) $ captureOutput $ runEx "-f../../src/Test/Ninja/compdb.ninja -t compdb cxx" "--no-report --quiet"+    want <- lines <$> readFile "../../src/Test/Ninja/compdb.output"     let eq a b | (a1,'*':a2) <- break (== '*') a = unless (a1 `isPrefixOf` b && a2 `isSuffixOf` b) $ a === b                | otherwise = a === b     length want === length res     zipWithM_ eq want res      -- Test initial variable bindings and variables in include/subninja statements-    let test6 = obj "test6"+    let test6 = "test6" -    copyFile "src/Test/Ninja/test6-sub.ninja" $ test6 ++ "-sub.ninja"-    copyFile "src/Test/Ninja/test6-inc.ninja" $ test6 ++ "-inc.ninja"-    copyFile "src/Test/Ninja/test6.ninja" $ test6 ++ ".ninja"+    copyFile "../../src/Test/Ninja/test6-sub.ninja" $ test6 ++ "-sub.ninja"+    copyFile "../../src/Test/Ninja/test6-inc.ninja" $ test6 ++ "-inc.ninja"+    copyFile "../../src/Test/Ninja/test6.ninja" $ test6 ++ ".ninja"      config <- Config.readConfigFileWithEnv [("v1", test6)] $ test6 ++ ".ninja"     -- The file included by subninja should have a separate variable scope@@ -93,21 +95,21 @@      -- tests from ninjasmith: https://github.com/ndmitchell/ninjasmith/     run "-f../../src/Test/Ninja/redefine.ninja"-    assertContentsWords (obj "redefine.txt") "version3 version2"+    assertContentsWords "redefine.txt" "version3 version2"      run "-f../../src/Test/Ninja/buildseparate.ninja"-    assertContentsWords (obj "buildseparate.txt") "XX"+    assertContentsWords "buildseparate.txt" "XX"      run "-f../../src/Test/Ninja/lexical.ninja"-    assertContentsWords (obj "lexical.txt") "XFoo_BarXXFooX.bar"+    assertContentsWords "lexical.txt" "XFoo_BarXXFooX.bar"      when False $ do         -- currently fails because Shake doesn't match Ninja here         run "-f../../src/Test/Ninja/outputtouch.ninja"-        assertContentsWords (obj "outputtouch.txt") "hello"-        writeFile (obj "outputtouch.txt") "goodbye"+        assertContentsWords "outputtouch.txt" "hello"+        writeFile "outputtouch.txt" "goodbye"         run "-f../../src/Test/Ninja/outputtouch.ninja"-        assertContentsWords (obj "outputtouch.txt") "goodbye"-        removeFile (obj "outputtouch.txt")+        assertContentsWords "outputtouch.txt" "goodbye"+        removeFile "outputtouch.txt"         run "-f../../src/Test/Ninja/outputtouch.ninja"-        assertContentsWords (obj "outputtouch.txt") "hello"+        assertContentsWords "outputtouch.txt" "hello"
src/Test/Oracle.hs view
@@ -1,76 +1,88 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies, ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}  module Test.Oracle(main) where  import Development.Shake-import Test.Type+import Development.Shake.Classes+import Development.Shake.FilePath+import General.GetOpt+import Data.List.Extra+import Data.Tuple.Extra+import Test.Type hiding (RandomType)+import qualified Test.Type as T import Control.Monad +-- These are instances we'll compute over+type instance RuleResult String = String+type instance RuleResult Int = String+type instance RuleResult () = String -main = shakenCwd test $ \args obj -> do-    let f name lhs rhs = (,) name-            (do addOracle $ \k -> let _ = k `asTypeOf` lhs in return rhs; return ()-            ,let o = obj name ++ ".txt" in do want [o]; o %> \_ -> do v <- askOracleWith lhs rhs; writeFile' o $ show v)-    let tbl = [f "str-bool" "" True-              ,f "str-int" "" (0::Int)-              ,f "bool-str" True ""-              ,f "int-str" (0::Int) ""]+type instance RuleResult Bool = Bool -- test results don't have to be a boolean -    forM_ args $ \a -> case a of-        '+':x | Just (add,_) <- lookup x tbl -> add-        '*':x | Just (_,use) <- lookup x tbl -> use-        '@':key -> do addOracle $ \() -> return key; return ()-        '%':name -> let o = obj "unit.txt" in do want [o]; o %> \_ -> do {askOracleWith () ""; writeFile' o name}-        '!':name -> do want [obj "rerun"]; obj "rerun" %> \out -> do alwaysRerun; writeFile' out name+newtype RandomType = RandomType (BinarySentinel String)+    deriving (Eq,Show,NFData,Typeable,Hashable,Binary) -test build obj = do+type instance RuleResult RandomType = Int+type instance RuleResult T.RandomType = Int++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+    addOracle $ \(T.RandomType _) -> return 42+    addOracle $ \(RandomType _) -> return (-42)+    "randomtype.txt" %> \out -> do+        a <- askOracle $ T.RandomType $ BinarySentinel ()+        b <- askOracle $ RandomType $ BinarySentinel ()+        writeFile' out $ show (a,b)++    addOracle $ \b -> return $ not b+    "true.txt" %> \out -> writeFile' out . show =<< askOracle False++    let add :: (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+    add "string" ""+    add "unit" ()+    add "int" (0 :: Int)++test build = do     build ["clean"] +    build ["randomtype.txt"]+    assertContents "randomtype.txt" "(42,-42)"+     -- check it rebuilds when it should-    build ["@key","%name"]-    assertContents (obj "unit.txt") "name"-    build ["@key","%test"]-    assertContents (obj "unit.txt") "name"-    build ["@foo","%test"]-    assertContents (obj "unit.txt") "test"+    writeFile ".log" ""+    build ["--def=string=name","string.txt"]+    assertContents "string.txt" "name"+    build ["--def=string=name","string.txt"]+    assertContents "string.txt" "name"+    build ["--def=string=test","string.txt"]+    assertContents "string.txt" "test"+    assertContents ".log" ".."      -- check adding/removing redundant oracles does not trigger a rebuild-    build ["@foo","%newer","+str-bool"]-    assertContents (obj "unit.txt") "test"-    build ["@foo","%newer","+str-int"]-    assertContents (obj "unit.txt") "test"-    build ["@foo","%newer"]-    assertContents (obj "unit.txt") "test"--    -- check always run works-    build ["!foo"]-    assertContents (obj "rerun") "foo"-    build ["!bar"]-    assertContents (obj "rerun") "bar"+    build ["--def=string=test","string.txt","--def=unit=bob"]+    build ["--def=string=test","string.txt","--def=int=fred"]+    build ["--def=string=test","string.txt"]+    assertContents "string.txt" "test"+    assertContents ".log" ".."      -- check error messages are good     let errors args err = assertException [err] $ build $ "--quiet" : args -    build ["+str-int","*str-int"]-    errors ["*str-int"] -- Building with an an Oracle that has been removed+    build ["--def=unit=test","unit.txt"]+    errors ["unit.txt"] -- Building with an an Oracle that has been removed         "missing a call to addOracle" -    errors ["*str-bool"] -- Building with an Oracle that I know nothing about+    errors ["int.txt"] -- Building with an Oracle that I know nothing about         "missing a call to addOracle" -    build ["+str-int","*str-int"]-    errors ["+str-bool","*str-int"] -- Building with an Oracle that has changed type-        "askOracle is used at the wrong type"--    errors ["+str-int","+str-bool"] -- Two Oracles with the same question type-        "Only one call to addOracle is allowed"--    errors ["+str-int","*str-bool"] -- Using an Oracle at the wrong answer type-        "askOracle is used at the wrong type"--    build ["+str-int","+str-int"] -- Two Oracles work if they aren't used-    errors ["+str-int","+str-int","*str-int"] -- Two Oracles fail if they are used-        "Only one call to addOracle is allowed"--    errors ["+str-int","+str-bool"] -- Two Oracles with the same answer type-        "Only one call to addOracle is allowed"+    errors ["--def=string=1","--def=string=1"] -- Two Oracles defined in one go+        "oracle defined twice"
src/Test/OrderOnly.hs view
@@ -7,56 +7,54 @@ import Control.Exception.Extra  -main = shakenCwd test $ \args obj -> do-    want $ map obj args--    obj "bar.txt" %> \out -> do+main = shakeTest_ test $ do+    "bar.txt" %> \out -> do         alwaysRerun-        writeFile' out =<< liftIO (readFile $ obj "bar.in")+        writeFile' out =<< liftIO (readFile "bar.in") -    obj "foo.txt" %> \out -> do-        let src = obj "bar.txt"+    "foo.txt" %> \out -> do+        let src = "bar.txt"         orderOnly [src]         writeFile' out =<< liftIO (readFile src)         need [src] -    obj "baz.txt" %> \out -> do-        let src = obj "bar.txt"+    "baz.txt" %> \out -> do+        let src = "bar.txt"         orderOnly [src]         liftIO $ appendFile out "x" -    obj "primary.txt" %> \out -> do-        need [obj "source.txt"]-        orderOnly [obj "intermediate.txt"]-        writeFile' out =<< liftIO (readFile $ obj "intermediate.txt")+    "primary.txt" %> \out -> do+        need ["source.txt"]+        orderOnly ["intermediate.txt"]+        writeFile' out =<< liftIO (readFile "intermediate.txt") -    obj "intermediate.txt" %> \out ->-        copyFile' (obj "source.txt") out+    "intermediate.txt" %> \out ->+        copyFile' "source.txt" out  -test build obj = do-    writeFile (obj "bar.in") "in"+test build = do+    writeFile "bar.in" "in"     build ["foo.txt","--sleep"]-    assertContents (obj "foo.txt") "in"-    writeFile (obj "bar.in") "out"+    assertContents "foo.txt" "in"+    writeFile "bar.in" "out"     build ["foo.txt","--sleep"]-    assertContents (obj "foo.txt") "out"+    assertContents "foo.txt" "out" -    writeFile (obj "baz.txt") ""-    writeFile (obj "bar.in") "in"+    writeFile "baz.txt" ""+    writeFile "bar.in" "in"     build ["baz.txt","--sleep"]-    assertContents (obj "baz.txt") "x"-    writeFile (obj "bar.in") "out"+    assertContents "baz.txt" "x"+    writeFile "bar.in" "out"     build ["baz.txt"]-    assertContents (obj "baz.txt") "x"+    assertContents "baz.txt" "x" -    ignore $ removeFile $ obj "intermediate.txt"-    writeFile (obj "source.txt") "x"+    ignore $ removeFile "intermediate.txt"+    writeFile "source.txt" "x"     build ["primary.txt","--sleep"]-    assertContents (obj "intermediate.txt") "x"-    removeFile $ obj "intermediate.txt"+    assertContents "intermediate.txt" "x"+    removeFile "intermediate.txt"     build ["primary.txt","--sleep"]-    assertMissing $ obj "intermediate.txt"-    writeFile (obj "source.txt") "y"+    assertMissing "intermediate.txt"+    writeFile "source.txt" "y"     build ["primary.txt","--sleep"]-    assertContents (obj "intermediate.txt") "y"+    assertContents "intermediate.txt" "y"
src/Test/Parallel.hs view
@@ -9,17 +9,20 @@ import Data.IORef  -main = shakenCwd test $ \args obj -> do-    want args+main = shakeTest_ test $ do+    "AB.txt" %> \out -> do+        -- need [obj "A.txt", obj "B.txt"]+        (text1,text2) <- readFile' "A.txt" `par` readFile' "B.txt"+        writeFile' out $ text1 ++ text2      phony "cancel" $ do-        writeFile' (obj "cancel") ""+        writeFile' "cancel" ""         done <- liftIO $ newIORef 0         lock <- liftIO newLock         void $ parallel $ replicate 5 $ liftIO $ do             x <- atomicModifyIORef done $ dupe . succ             when (x == 3) $ do sleep 0.1; fail "boom"-            withLock lock $ appendFile (obj "cancel") "x"+            withLock lock $ appendFile "cancel" "x"      phony "parallel" $ do         active <- liftIO $ newIORef 0@@ -30,13 +33,21 @@             sleep 0.1             atomicModifyIORef active $ dupe . pred         peak <- liftIO $ readIORef peak-        writeFile' (obj "parallel") $ show peak+        writeFile' "parallel" $ show peak  -test build obj = do+test build = do+    writeFile "A.txt" "AAA"+    writeFile "B.txt" "BBB"+    build ["AB.txt","--sleep"]+    assertContents "AB.txt" "AAABBB"+    appendFile "A.txt" "aaa"+    build ["AB.txt"]+    assertContents "AB.txt" "AAAaaaBBB"+     assertException ["boom"] $ build ["cancel","-j1","--quiet"]-    assertContents (obj "cancel") "xx"+    assertContents "cancel" "xx"     build ["parallel","-j1"]-    assertContents (obj "parallel") "1"+    assertContents "parallel" "1"     build ["parallel","-j5"]-    assertContents (obj "parallel") "5"+    assertContents "parallel" "5"
src/Test/Pool.hs view
@@ -2,20 +2,23 @@ module Test.Pool(main) where  import Test.Type-import Development.Shake.Pool+import Development.Shake.Internal.Core.Pool -import Control.Concurrent-import Control.Exception hiding (assert)+import Control.Concurrent.Extra+import Control.Exception.Extra import Control.Monad  -main = shakenCwd test $ \args obj -> return ()+main = shakeTest_ test $ return ()  -test build obj = do-    let wait = sleep 0.01-    forM_ [False,True] $ \deterministic -> do+test build = do+    -- See #474, we should never be running pool actions masked+    let addPool pool act = addPoolMediumPriority 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)@@ -23,46 +26,50 @@                 forM_ [1..5] $ \i ->                     addPool pool $ do                         modifyMVar_ var $ \(mx,now) -> return (max (now+1) mx, now+1)-                        wait+                        -- requires that all tasks get spawned within 0.1s+                        sleep 0.1                         modifyMVar_ var $ \(mx,now) -> return (mx,now-1)             res <- takeMVar var             res === (min n 5, 0)          -- check that exceptions are immediate-        self <- myThreadId-        handle (\(ErrorCall msg) -> msg === "pass") $-            runPool deterministic 3 $ \pool -> do+        good <- newVar True+        started <- newBarrier+        stopped <- newBarrier+        res <- try_ $ runPool deterministic 3 $ \pool -> do                 addPool pool $ do-                    wait+                    waitBarrier started                     error "pass"-                addPool pool $ do-                    wait >> wait-                    throwTo self $ ErrorCall "fail" -        wait >> wait -- give chance for a delayed exception+                addPool pool $+                    flip finally (signalBarrier stopped ()) $ do+                        signalBarrier started ()+                        sleep 10+                        modifyVar_ good $ const $ return False+        -- note that the pool finishing means we started killing our threads+        -- not that they have actually died+        case res of+            Left e | Just (ErrorCall "pass") <- fromException e -> return ()+            _ -> fail $ "Wrong type of result, got " ++ show res+        waitBarrier stopped+        assertBoolIO (readVar good) "Must be true"          -- check someone spawned when at zero todo still gets run-        done <- newMVar False+        done <- newBarrier         runPool deterministic 1 $ \pool ->-            addPool pool $ do-                wait-                addPool pool $ do-                    wait-                    modifyMVar_ done $ const $ return True-        done <- readMVar done-        assert done "Waiting on someone"+            addPool pool $+                addPool pool $+                    signalBarrier done ()+        assertWithin 1 $ waitBarrier done          -- check that killing a thread pool stops the tasks, bug 545-        thread <- newEmptyMVar-        done <- newEmptyMVar-        res <- newMVar True-        t <- forkIO $ flip finally (putMVar done ()) $ runPool deterministic 1 $ \pool ->-            addPool pool $ do-                t <- takeMVar thread-                killThread t-                wait -- allow the thread to die first-                modifyMVar_ res (const $ return False)-        putMVar thread t-        takeMVar done-        wait >> wait >> wait -- allow the bad thread to continue-        res <- readMVar res-        assert res "Early termination"+        thread <- newBarrier+        died <- newBarrier+        done <- newBarrier+        t <- forkIO $ flip finally (signalBarrier died ()) $ runPool deterministic 1 $ \pool ->+            addPool pool $+                flip onException (signalBarrier done ()) $ do+                    killThread =<< waitBarrier thread+                    sleep 10+        signalBarrier thread t+        assertWithin 1 $ waitBarrier done+        assertWithin 1 $ waitBarrier died
src/Test/Progress.hs view
@@ -1,14 +1,14 @@ module Test.Progress(main) where -import Development.Shake.Progress+import Development.Shake.Internal.Progress import Test.Type-import System.Directory+import System.Directory.Extra import System.FilePath import Data.Monoid import Prelude  -main = shaken test $ \args obj -> return ()+main = shakeTest_ test $ return ()   -- | Given a list of todo times, get out a list of how long is predicted@@ -23,7 +23,7 @@     return $ (0/0) : map ((/ resolution) . actualSecs) res  -test build obj = do+test build = do     -- perfect functions should match perfectly     xs <- prog [10,9..1]     drop 2 xs === [8,7..1]@@ -41,13 +41,13 @@      -- the first value must be plausible, or missing     xs <- prog [187]-    assert (isNaN $ head xs) "No first value"+    assertBool (isNaN $ head xs) "No first value"      -- desirable properties, could be weakened     xs <- progEx 2 $ 100:map (*2) [10,9..1]     drop 5 xs === [6,5..1]     xs <- progEx 1 [10,9,100,8,7,6,5,4,3,2,1]-    assert (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close"+    assertBool (all (<= 1.5) $ map abs $ zipWith (-) (drop 5 xs) [6,5..1]) "Close"      -- if no progress is made, don't keep the time going up     xs <- prog [10,9,8,7,7,7,7,7]@@ -55,8 +55,8 @@      -- if the work rate changes, should somewhat reflect that     xs <- prog [10,9,8,7,6.5,6,5.5,5]-    assert (last xs > 7.1) "Some discounting (factor=0 would give 7)"+    assertBool (last xs > 7.1) "Some discounting (factor=0 would give 7)" -    xs <- getDirectoryContents "src/Test/Progress"-    build $ ["--progress=replay=src/Test/Progress/" ++ x | x <- xs, takeExtension x == ".prog"] ++-            ["--no-report","--report=-","--report=" ++ obj "progress.html"]+    xs <- listFiles $ root </> "src/Test/Progress"+    build $ ["--progress=replay=" ++ x | x <- xs, takeExtension x == ".prog"] +++            ["--no-report","--report=-","--report=" ++ "progress.html"]
src/Test/Random.hs view
@@ -10,6 +10,7 @@ import Control.Monad import Data.List import Data.Maybe+import General.GetOpt import System.Environment import System.Exit import System.Random@@ -31,10 +32,11 @@            | Want [Int]     deriving (Read,Show) +arg = [Option "" ["arg"] (ReqArg Right "") ""] -main = shaken test $ \args obj -> do-    let toFile (Input i) = obj $ "input-" ++ show i ++ ".txt"-        toFile (Output i) = obj $ "output-" ++ show i ++ ".txt"+main = shakeTest test arg $ \args -> do+    let toFile (Input i) = "input-" ++ show i ++ ".txt"+        toFile (Output i) = "output-" ++ show i ++ ".txt"         toFile Bang = error "BANG"      let randomSleep = liftIO $ do@@ -59,7 +61,7 @@     | otherwise = Nothing  -test build obj = do+test build = do     limit <- do         args <- getArgs         let bound = listToMaybe $ reverse $ mapMaybe asDuration args@@ -74,18 +76,18 @@         build ["clean"]         build [] -- to create the directory         forM_ inputRange $ \i ->-            writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i+            writeFile ("input-" ++ show i ++ ".txt") $ show $ Single i         logic <- randomLogic         runLogic [] logic         chng <- filterM (const randomIO) inputRange            forM_ chng $ \i ->-            writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single $ negate i+            writeFile ("input-" ++ show i ++ ".txt") $ show $ Single $ negate i         runLogic chng logic         forM_ inputRange $ \i ->-            writeFile (obj $ "input-" ++ show i ++ ".txt") $ show $ Single i+            writeFile ("input-" ++ show i ++ ".txt") $ show $ Single i         logicBang <- addBang =<< addBang logic         j <- randomRIO (1::Int,8)-        res <- try_ $ build $ "--exception" : ("-j" ++ show j) : map show (logicBang ++ [Want [i | Logic i _ <- logicBang]])+        res <- try_ $ build $ "--exception" : ("-j" ++ show j) : map ((++) "--arg=" . show) (logicBang ++ [Want [i | Logic i _ <- logicBang]])         case res of             Left err                 | "BANG" `isInfixOf` show err -> return () -- error I expected@@ -102,7 +104,7 @@                     replicateM i $ randomElem poss                 sleepFileTime                 j <- randomRIO (1::Int,8)-                build $ ("-j" ++ show j) : map show (xs ++ map Want wants)+                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@@ -110,7 +112,7 @@                             Output i -> value i                 forM_ (concat wants) $ \i -> do                     let wanted = value i-                    got <- fmap read $ IO.readFile' $ obj $ "output-" ++ show i ++ ".txt"+                    got <- fmap read $ IO.readFile' $ "output-" ++ show i ++ ".txt"                     when (wanted /= got) $                         error $ "INCORRECT VALUE for " ++ show i
+ src/Test/Rebuild.hs view
@@ -0,0 +1,65 @@++module Test.Rebuild(main) where++import Development.Shake+import Test.Type+import Text.Read.Extra+import Control.Monad+import General.GetOpt++data Opt = Timestamp String | Pattern Pat++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+    let timestamp = concat [x | Timestamp x <- args]+    let p = last $ PatWildcard : [x | Pattern x <- args]+    want ["a.txt"]+    pat p "a.txt" $ \out -> do+        src <- readFile' "b.txt"+        writeFile' out $ src ++ timestamp++    pat p "b.txt" $ \out -> do+        src <- readFile' "c.txt"+        writeFile' out $ src ++ timestamp++test build =+    forM_ [minBound..maxBound :: Pat] $ \pat -> do+        build ["clean"]+        let go arg c b a flags = do+                writeFileChanged "c.txt" c+                build $ ["--timestamp=" ++ arg, "--sleep","--no-reports","--pattern=" ++ show pat] ++ flags+                assertContents "b.txt" b+                assertContents "a.txt" a++        -- check rebuild works+        go "1" "x" "x1" "x11" []+        go "2" "x" "x1" "x11" []+        go "3" "x" "x1" "x13" ["--rebuild=a.*"]+        go "4" "x" "x1" "x13" []+        go "5" "x" "x5" "x55" ["--rebuild=b.*"]+        go "6" "x" "x6" "x66" ["--rebuild"]+        go "7" "x" "x6" "x66" []+        go "8" "y" "y8" "y88" []++        -- check skip works+        go "1" "x" "x1" "x11" []+        go "2" "y" "y2" "x11" ["--skip=a.*"]+        go "3" "y" "y2" "y23" []+        go "4" "z" "y2" "y23" ["--skip=b.*"]+        go "5" "z" "y2" "y23" ["--skip=b.*"]+        go "6" "z" "z6" "z66" []+        go "7" "a" "z6" "z66" ["--skip=c.*"]+        go "8" "a" "z6" "z66" ["--skip=b.*"]+        go "9" "a" "a9" "z66" ["--skip=a.*"]+        go "0" "a" "a9" "a90" []++    {-+        -- check skip-forever works+        -- currently it does not work properly+        go "1" "x" "x1" "x11" []+        go "2" "y" "y2" "x11" ["--skip-forever=a.*"]+        go "3" "y" "y2" "x11" []+        go "4" "z" "z4" "z44" []+    -}
src/Test/Resources.hs view
@@ -5,31 +5,30 @@ import Test.Type import Data.List import System.FilePath-import Control.Exception.Extra hiding (assert)+import Control.Exception.Extra import System.Time.Extra import Control.Monad import Data.IORef  -main = shakenCwd test $ \args obj -> do+main = shakeTest_ test $ do     -- test I have good Ord and Show-    want args     do         r1 <- newResource "test" 2         r2 <- newResource "special" 67-        unless (r1 < r2 || r2 < r1) $ error "Resources should have a good ordering"-        unless ("special" `isInfixOf` show r2) $ error "Resource should contain their name when shown"+        unless (r1 < r2 || r2 < r1) $ fail "Resources should have a good ordering"+        unless ("special" `isInfixOf` show r2) $ fail "Resource should contain their name when shown"      -- test you are capped to a maximum value     do         let cap = 2         inside <- liftIO $ newIORef 0         res <- newResource "test" cap-        phony "cap" $ need [obj $ "c_file" ++ show i ++ ".txt" | i <- [1..4]]-        obj "c_*.txt" %> \out ->+        phony "cap" $ need ["c_file" ++ show i ++ ".txt" | i <- [1..4]]+        "c_*.txt" %> \out ->             withResource res 1 $ do                 old <- liftIO $ atomicModifyIORef inside $ \i -> (i+1,i)-                when (old >= cap) $ error "Too many resources in use at one time"+                when (old >= cap) $ fail "Too many resources in use at one time"                 liftIO $ sleep 0.1                 liftIO $ atomicModifyIORef inside $ \i -> (i-1,i)                 writeFile' out ""@@ -38,31 +37,31 @@     do         done <- liftIO $ newIORef 0         lock <- newResource "lock" 1-        phony "schedule" $ do-            need $ map (\x -> obj $ "s_" ++ x) $ "lock1":"done":["free" ++ show i | i <- [1..10]] ++ ["lock2"]-        obj "s_done" %> \out -> do-            need [obj "s_lock1",obj "s_lock2"]+        phony "schedule" $+            need $ map ("s_" ++) $ "lock1":"done":["free" ++ show i | i <- [1..10]] ++ ["lock2"]+        "s_done" %> \out -> do+            need ["s_lock1","s_lock2"]             done <- liftIO $ readIORef done-            when (done < 10) $ error "Not all managed to schedule while waiting"+            when (done < 10) $ fail "Not all managed to schedule while waiting"             writeFile' out ""-        obj "s_lock*" %> \out -> do+        "s_lock*" %> \out -> do             withResource lock 1 $ liftIO $ sleep 0.5             writeFile' out ""-        obj "s_free*" %> \out -> do+        "s_free*" %> \out -> do             liftIO $ atomicModifyIORef done $ \i -> (i+1,())             writeFile' out ""      -- test that throttle works properly     do         res <- newThrottle "throttle" 2 0.4-        phony "throttle" $ need $ map obj ["t_file1.1","t_file2.1","t_file3.2","t_file4.1","t_file5.2"]-        obj "t_*.*" %> \out -> do+        phony "throttle" $ need ["t_file1.1","t_file2.1","t_file3.2","t_file4.1","t_file5.2"]+        "t_*.*" %> \out -> do             withResource res (read $ drop 1 $ takeExtension out) $                 when (takeBaseName out == "t_file3") $ liftIO $ sleep 0.2             writeFile' out ""  -test build obj = do+test build = do     build ["-j2","cap","--clean"]     build ["-j4","cap","--clean"]     build ["-j10","cap","--clean"]@@ -75,5 +74,5 @@             (s, _) <- duration $ build [flags,"throttle","--no-report","--clean"]             -- the 0.1s cap is a guess at an upper bound for how long everything else should take             -- and should be raised on slower machines-            assert (s >= 1.4 && s < 1.6) $+            assertBool (s >= 1.4 && s < 1.6) $                 "Bad throttling, expected to take 1.4s + computation time (cap of 0.2s), took " ++ show s ++ "s"
src/Test/Self.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-}  module Test.Self(main) where @@ -19,10 +19,12 @@ 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 = shaken noTest $ \args obj -> do-    let moduleToFile ext xs = map (\x -> if x == '.' then '/' else x) xs <.> ext-    want $ if null args then [obj "Main" <.> exe] else args+main = shakeTest_ 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@@ -32,7 +34,7 @@         return $ words out      ghcFlags <- addOracle $ \GhcFlags{} -> do-        pkgs <- readFileLines $ obj ".pkgs"+        pkgs <- readFileLines ".pkgs"         return $ map ("-package=" ++) pkgs      let ghc args = do@@ -41,35 +43,35 @@             flags <- ghcFlags $ GhcFlags ()             cmd "ghc" flags args -    obj "Main" <.> exe %> \out -> do-        src <- readFileLines $ obj "Run.deps"-        let os = map (obj . moduleToFile "o") $ "Run" : src+    "Main" <.> exe %> \out -> do+        src <- readFileLines "Run.deps"+        let os = map (moduleToFile "o") $ "Run" : src         need os         ghc $ ["-o",out] ++ os -    obj "//*.deps" %> \out -> do+    "//*.deps" %> \out -> do         dep <- readFileLines $ out -<.> "dep"-        let xs = map (obj . moduleToFile "deps") dep+        let xs = map (moduleToFile "deps") dep         need xs         ds <- nubOrd . sort . (++) dep <$> concatMapM readFileLines xs         writeFileLines out ds -    obj "//*.dep" %> \out -> do-        src <- readFile' $ "src" </> fixPaths (unobj $ out -<.> "hs")+    "//*.dep" %> \out -> do+        src <- readFile' $ root </> "src" </> fixPaths (out -<.> "hs")         let xs = hsImports src-        xs <- filterM (doesFileExist . ("src" </>) . fixPaths . moduleToFile "hs") xs+        xs <- filterM (doesFileExist . (\x -> root </> "src" </> x) . fixPaths . moduleToFile "hs") xs         writeFileLines out xs -    [obj "//*.o",obj "//*.hi"] &%> \[out,_] -> do+    ["//*.o","//*.hi"] &%> \[out,_] -> do         deps <- readFileLines $ out -<.> "deps"-        let hs = "src" </> fixPaths (unobj $ out -<.> "hs")-        need $ hs : map (obj . moduleToFile "hi") deps-        ghc $ ["-c",hs,"-isrc","-main-is","Run.main"-              ,"-hide-all-packages","-odir=output/self","-hidir=output/self","-i=output/self"] ++-              ["-DPORTABLE","-fwarn-unused-imports"] -- to test one CPP branch+        let hs = root </> "src" </> fixPaths (out -<.> "hs")+        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 -    obj ".pkgs" %> \out -> do-        src <- readFile' "shake.cabal"+    ".pkgs" %> \out -> do+        src <- readFile' $ root </> "shake.cabal"         writeFileLines out $ sort $ cabalBuildDepends src  @@ -86,6 +88,6 @@ cabalBuildDepends _ = packages ++ ["unix" | os /= "mingw32"]  packages = words-    ("base transformers binary unordered-containers hashable time bytestring " +++    ("base transformers binary unordered-containers hashable time bytestring primitive " ++      "filepath directory process deepseq random utf8-string extra js-jquery js-flot") ++     ["old-time" | compilerVersion < makeVersion [7,6]]
src/Test/Tar.hs view
@@ -2,12 +2,13 @@ module Test.Tar(main) where  import Development.Shake+import System.FilePath import Test.Type  -main = shaken noTest $ \args obj -> do-    want [obj "result.tar"]-    obj "result.tar" %> \out -> do-        contents <- readFileLines "src/Test/Tar/list.txt"+main = shakeTest_ noTest $ do+    want ["result.tar"]+    "result.tar" %> \out -> do+        contents <- fmap (map (root </>)) $ readFileLines $ root </> "src/Test/Tar/list.txt"         need contents         cmd "tar -cf" [out] contents
src/Test/Tup.hs view
@@ -11,17 +11,17 @@ import Prelude  -main = shaken noTest $ \args obj -> do+main = shakeTest_ noTest $ do     -- Example inspired by http://gittup.org/tup/ex_multiple_directories.html-    usingConfigFile "src/Test/Tup/root.cfg"+    usingConfigFile $ root </> "src/Test/Tup/root.cfg"      action $ do         keys <- getConfigKeys-        need [obj $ x -<.> exe | x <- keys, takeExtension x == ".exe"]+        need [x -<.> exe | x <- keys, takeExtension x == ".exe"]      let objects dir key = do-            let f x | takeExtension x == ".c" = obj $ dir </> x -<.> "o"-                    | takeExtension x == ".a" = obj $ takeBaseName x </> "lib" ++ x+            let f x | takeExtension x == ".c" = dir </> x -<.> "o"+                    | takeExtension x == ".a" = takeBaseName x </> "lib" ++ x                     | otherwise = error $ "Unknown extension, " ++ x             x <- fromMaybe (error $ "Missing config key, " ++ key) <$> getConfig key             return $ map f $ words x@@ -31,13 +31,13 @@         need os         cmd "gcc" os "-o" [out] -    obj "//lib*.a" %> \out -> do+    "//lib*.a" %> \out -> do         os <- objects (drop 3 $ takeBaseName out) $ drop 3 $ takeFileName out         need os         cmd "ar crs" [out] os -    obj "//*.o" %> \out -> do-        let src = "src/Test/Tup" </> unobj out -<.> "c"+    "//*.o" %> \out -> do+        let src = root </> "src/Test/Tup" </> out -<.> "c"         need [src]-        () <- cmd "gcc -c -MMD -MF" [out -<.> "d"] [src] "-o" [out] "-O2 -Wall -Isrc/Test/Tup/newmath"+        cmd_ "gcc -c -MMD -MF" [out -<.> "d"] [src] "-o" [out] "-O2 -Wall" ["-I" ++ root </> "src/Test/Tup/newmath"]         neededMakefileDependencies $ out -<.> "d"
src/Test/Tup/root.cfg view
@@ -1,4 +1,4 @@  hello.exe = hello.c newmath.a -include src/Test/Tup/newmath/root.cfg+include ../../src/Test/Tup/newmath/root.cfg
src/Test/Type.hs view
@@ -1,80 +1,107 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-} -module Test.Type(sleep, module Test.Type) where+module Test.Type(+    sleep, sleepFileTime, sleepFileTimeCalibrate,+    shakeTest, shakeTest_,+    root,+    noTest, hasTracker,+    copyDirectoryChanged, copyFileChanged,+    assertWithin,+    assertBool, assertBoolIO, assertException,+    assertContents, assertContentsUnordered, assertContentsWords,+    assertExists, assertMissing,+    (===),+    Pat(PatWildcard), pat,+    BinarySentinel(..), RandomType(..),+    ) where  import Development.Shake hiding (copyFileChanged)+import Development.Shake.Classes import Development.Shake.Forward-import Development.Shake.Rule() -- ensure the module gets imported, and thus tested-import General.String+import Development.Shake.Internal.FileName import General.Extra-import Development.Shake.FileInfo+import Development.Shake.Internal.FileInfo import Development.Shake.FilePath import Paths_shake -import Control.Exception.Extra hiding (assert)+import Control.Exception.Extra import Control.Monad.Extra import Data.List 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-import System.Console.GetOpt+import General.GetOpt import System.IO.Extra as IO import System.Time.Extra import Prelude  -shaken, shakenCwd-    :: (([String] -> IO ()) -> (String -> String) -> IO ())-    -> ([String] -> (String -> String) -> Rules ())+shakeTest+    :: (([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+    (\os args -> if null args then g os else want args >> withoutActions (g os))++shakeTest_+    :: (([String] -> IO ()) -> IO ()) -- ^ The test driver+    -> Rules () -- ^ The Shake script under test+    -> IO () -- ^ Sleep function, driven by passing @--sleep@     -> IO ()-shaken = shakenEx False-shakenCwd = shakenEx True+shakeTest_ f g = shakeTest f [] (const g)  shakenEx     :: Bool-    -> (([String] -> IO ()) -> (String -> String) -> IO ())-    -> ([String] -> (String -> String) -> Rules ())+    -> [OptDescr (Either String a)]+    -> (([String] -> IO ()) -> IO ())+    -> ([a] -> [String] -> Rules ())     -> IO ()     -> IO ()-shakenEx changeDir test rules sleeper = do+shakenEx reenter options test rules sleeper = do     -- my debug getDataFileName (in Paths) uses a cache of the Cwd     -- make sure we force the cache before changing directory     getDataFileName ""      name:args <- getArgs-    when ("--sleep" `elem` args) sleeper     putStrLn $ "## BUILD " ++ unwords (name:args)     let forward = "--forward" `elem` args-    args <- return $ args \\ ["--sleep","--forward"]+    args <- return $ delete "--forward" args     cwd <- getCurrentDirectory     let out = "output/" ++ name ++ "/"-    let obj x | changeDir = if null x then "." else x-              | otherwise = if "/" `isPrefixOf` x || null x then init out ++ x else out ++ x-    let change = if changeDir then withCurrentDirectory out else id-    let unchange act = do-            new <- getCurrentDirectory-            withCurrentDirectory cwd $ do act; createDirectoryIfMissing True new -- to deal with clean-    createDirectoryIfMissing True out+    let obj x = if null x then "." else x+    let change = if not reenter then withCurrentDirectory out else id+    let clean = do+            now <- getCurrentDirectory+            when (takeBaseName now /= name) $+                fail $ "Clean went horribly wrong! Dangerous deleting: " ++ show now+            withCurrentDirectory (now </> "..") $ do+                removeDirectoryRecursive now+                createDirectoryIfMissing True now+    unless reenter $ createDirectoryIfMissing True out     case args of         "test":extra -> do             putStrLn $ "## TESTING " ++ name             -- if the extra arguments are not --quiet/--loud it's probably going to go wrong-            change $ test (\args -> withArgs (name:args ++ extra) $ unchange $ shakenEx changeDir test rules sleeper) obj+            -- 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)             putStrLn $ "## FINISHED TESTING " ++ name -        "clean":_ -> removeDirectoryRecursive out+        "clean":_ -> change clean          "perturb":args -> forever $ do             del <- removeFilesRandom out             threads <- randomRIO (1,4)             putStrLn $ "## TESTING PERTURBATION (" ++ show del ++ " files, " ++ show threads ++ " threads)"-            shake shakeOptions{shakeFiles=out, shakeThreads=threads, shakeVerbosity=Quiet} $ rules args (out++)+            shake shakeOptions{shakeFiles=out, shakeThreads=threads, shakeVerbosity=Quiet} $ rules [] args          args -> do             t <- tracker-            let (_,files,_) = getOpt Permute [] args             opts <- return $ shakeOptions                 {shakeFiles = obj ""                 ,shakeReport = [obj "report.html"]}@@ -82,14 +109,26 @@                 {shakeLint = Just t                 ,shakeLintInside = [cwd]                 ,shakeLintIgnore = map (cwd </>) [".cabal-sandbox//",".stack-work//"]}-            withArgs (args \\ files) $-                change $ shakeWithClean-                    (unchange $ removeDirectoryRecursive out)-                    opts-                    -- if you have passed sleep, supress the "no errors" warning-                    (do rules files obj; when ("--sleep" `elem` args) $ action $ return ())+            withArgs args $ do+                let cleanOpt = optionsEnumDesc+                        [(Clean, "Clean before building.")+                        ,(Sleep, "Pause before executing.")]+                change $ shakeArgsWith opts (cleanOpt `mergeOptDescr` options) $ \extra files -> do+                    let (extra1, extra2) = partitionEithers extra+                    when (Clean `elem` extra1) clean+                    when (Sleep `elem` extra1) sleeper+                    if "clean" `elem` files then+                        clean >> return Nothing+                    else return $ Just $ do+                        -- if you have passed sleep, supress the "no actions" warning+                        when (Sleep `elem` extra1) $ action $ return ()+                        rules extra2 files +data Flags = Clean | Sleep deriving (Eq,Show) +root :: FilePath+root = "../.."+ tracker :: IO Lint tracker = do   fsatrace <- findExecutable $ "fsatrace" <.> exe@@ -103,61 +142,47 @@   return $ t == LintFSATrace  -shakeWithClean :: IO () -> ShakeOptions -> Rules () -> IO ()-shakeWithClean clean opts rules = shakeArgsWith opts [cleanOpt] f-    where-        cleanOpt = Option "c" ["clean"] (NoArg $ Right ()) "Clean before building."--        f extra files = do-            when (extra /= []) clean-            if "clean" `elem` files then-                clean >> return Nothing-             else-                return $ Just $ if null files then rules else want files >> withoutActions rules---unobj :: FilePath -> FilePath-unobj = dropDirectory1 . dropDirectory1+assertBool :: Bool -> String -> IO ()+assertBool b msg = unless b $ error $ "ASSERTION FAILED: " ++ msg -assert :: Bool -> String -> IO ()-assert b msg = unless b $ error $ "ASSERTION FAILED: " ++ msg+assertBoolIO :: IO Bool -> String -> IO ()+assertBoolIO b msg = do b <- b; assertBool b msg  infix 4 ===  (===) :: (Show a, Eq a) => a -> a -> IO ()-a === b = assert (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b+a === b = assertBool (a == b) $ "failed in ===\nLHS: " ++ show a ++ "\nRHS: " ++ show b   assertExists :: FilePath -> IO () assertExists file = do     b <- IO.doesFileExist file-    assert b $ "File was expected to exist, but is missing: " ++ file+    assertBool b $ "File was expected to exist, but is missing: " ++ file  assertMissing :: FilePath -> IO () assertMissing file = do     b <- IO.doesFileExist file-    assert (not b) $ "File was expected to be missing, but exists: " ++ file+    assertBool (not b) $ "File was expected to be missing, but exists: " ++ file +assertWithin :: Seconds -> IO () -> IO ()+assertWithin n act = do+    t <- timeout n act+    when (isNothing t) $ assertBool False $ "Expected to complete within " ++ show n ++ " seconds, but did not"+ assertContents :: FilePath -> String -> IO () assertContents file want = do     got <- IO.readFile' file-    assert (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got+    assertBool (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got  assertContentsOn :: (String -> String) -> FilePath -> String -> IO () assertContentsOn f file want = do     got <- IO.readFile' file-    assert (f want == f got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got ++-                               "\nWANT (transformed): " ++ f want ++ "\nGOT (transformed): " ++ f got+    assertBool (f want == f got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got +++                                   "\nWANT (transformed): " ++ f want ++ "\nGOT (transformed): " ++ f got  assertContentsWords :: FilePath -> String -> IO () assertContentsWords = assertContentsOn (unwords . words) --assertContentsInfix :: FilePath -> String -> IO ()-assertContentsInfix file want = do-    got <- IO.readFile' file-    assert (want `isInfixOf` got) $ "File contents are wrong: " ++ file ++ "\nWANT (anywhere): " ++ want ++ "\nGOT: " ++ got- assertContentsUnordered :: FilePath -> [String] -> IO () assertContentsUnordered file xs = assertContentsOn (unlines . sort . lines) file (unlines xs) @@ -166,12 +191,12 @@     res <- try_ act     case res of         Left err -> let s = show err in forM_ parts $ \p ->-            assert (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p+            assertBool (p `isInfixOf` s) $ "Incorrect exception, missing part:\nGOT: " ++ s ++ "\nWANTED: " ++ p         Right _ -> error $ "Expected an exception containing " ++ show parts ++ ", but succeeded"  -noTest :: ([String] -> IO ()) -> (String -> String) -> IO ()-noTest build obj = do+noTest :: ([String] -> IO ()) -> IO ()+noTest build = do     build ["--abbrev=output=$OUT","-j3"]     build ["--no-build","--report=-"]     build []@@ -190,7 +215,8 @@     -- if it rounds to a second then 1st will be a fraction, but 2nd will be full second     mtimes <- forM [1..2] $ \i -> fmap fst $ duration $ do         writeFile file $ show i-        let time = fmap (fst . fromMaybe (error "File missing during sleepFileTimeCalibrate")) $ getFileInfo $ packU file+        let time = fmap (fst . fromMaybe (error "File missing during sleepFileTimeCalibrate")) $+                        getFileInfo $ fileNameFromString file         t1 <- time         flip loopM 0 $ \j -> do             writeFile file $ show (i,j)@@ -231,3 +257,36 @@     good <- IO.doesFileExist new     good <- if not good then return False else liftM2 (==) (BS.readFile old) (BS.readFile new)     unless good $ copyFile old new++-- The operators %> ?> &*> &?> |?> |*> all have an isomorphism+data Pat = PatWildcard | PatPredicate | PatOrWildcard | PatAndWildcard | PatAndPredicate+    deriving (Read, Show, Enum, Bounded)++pat :: Pat -> FilePattern -> (FilePath -> Action ()) -> Rules ()+pat PatWildcard p act = p %> act+pat PatPredicate p act = (p ?==) ?> act+pat PatOrWildcard p act = [p] |%> act+pat PatAndWildcard p act =+    -- single wildcard shortcircuits, so we use multiple to avoid that+    -- and thus have to fake writing an extra file+    [p, p ++ "'"] &%> \[x,x'] -> do act x; writeFile' x' ""+pat PatAndPredicate p act = (\x -> if p ?== x then Just [x] else Nothing) &?> \[x] -> act x+++---------------------------------------------------------------------+-- TEST MATERIAL+-- Some errors require multiple modules to replicate (e.g. #506), so put that here++newtype BinarySentinel a = BinarySentinel ()+    deriving (Eq,Show,NFData,Typeable,Hashable)++instance forall a . Typeable a => Binary (BinarySentinel a) where+    put (BinarySentinel x) = put $ show (typeRep (Proxy :: Proxy a))+    get = do+        x <- get+        let want = show (typeRep (Proxy :: Proxy a))+        if x == want then return $ BinarySentinel () else+            error $ "BinarySentinel failed, got " ++ show x ++ " but wanted " ++ show want++newtype RandomType = RandomType (BinarySentinel ())+    deriving (Eq,Show,NFData,Typeable,Hashable,Binary)
src/Test/Unicode.hs view
@@ -4,9 +4,9 @@ import Development.Shake import Development.Shake.FilePath import Test.Type+import General.GetOpt import Control.Exception.Extra import Control.Monad-import System.Directory(createDirectoryIfMissing)   -- | Decode a dull ASCII string to certain unicode points, necessary because@@ -17,44 +17,47 @@ decode (x:xs) = x : decode xs decode [] = [] +data Arg = Prefix String | Want String+opts =+    [Option "" ["prefix"] (ReqArg (Right . Prefix) "") ""+    ,Option "" ["want"] (ReqArg (Right . Want) "") ""] -main = shakenCwd test $ \xs obj -> do-    let pre:args = map decode xs-    want $ map obj args+main = shakeTest test opts $ \xs -> do+    let pre = last $ "" : [decode x | Prefix x <- xs :: [Arg]]+    want [decode x | Want x <- xs] -    obj (pre ++ "dir/*") %> \out -> do+    pre ++ "dir/*" %> \out -> do         let src = takeDirectory (takeDirectory out) </> takeFileName out         copyFile' src out -    obj (pre ++ ".out") %> \out -> do-        a <- readFile' $ obj $ pre ++ "dir" </> pre <.> "source"-        b <- readFile' $ obj pre <.> "multi1"+    pre ++ ".out" %> \out -> do+        a <- readFile' $ pre ++ "dir" </> pre <.> "source"+        b <- readFile' $ pre <.> "multi1"         writeFile' out $ a ++ b -    map obj ["*.multi1","*.multi2"] &%> \[m1,m2] -> do+    ["*.multi1","*.multi2"] &%> \[m1,m2] -> do         b <- doesFileExist $ m1 -<.> "exist"         writeFile' m1 $ show b         writeFile' m2 $ show b  -test build obj = do+test build = do     build ["clean"]     -- Useful, if the error message starts crashing...     -- IO.hSetEncoding IO.stdout IO.char8     -- IO.hSetEncoding IO.stderr IO.char8     forM_ ["normal","e^",":)","e^-:)"] $ \pre -> do-        createDirectoryIfMissing True $ obj ""-        let ext x = obj $ decode pre <.> x+        let ext x = decode pre <.> x         res <- try_ $ writeFile (ext "source") "x"         case res of             Left err ->                 putStrLn $ "WARNING: Failed to write file " ++ pre ++ ", skipping unicode test (LANG=C ?)"             Right _ -> do-                build [pre,pre <.> "out","--sleep"]+                build ["--prefix=" ++ pre, "--want=" ++ pre <.> "out", "--sleep"]                 assertContents (ext "out") $ "x" ++ "False"                 writeFile (ext "source") "y"-                build [pre,pre <.> "out","--sleep"]+                build ["--prefix=" ++ pre, "--want=" ++ pre <.> "out", "--sleep"]                 assertContents (ext "out") $ "y" ++ "False"                 writeFile (ext "exist") ""-                build [pre,pre <.> "out"]+                build ["--prefix=" ++ pre, "--want=" ++ pre <.> "out"]                 assertContents (ext "out") $ "y" ++ "True"
src/Test/Util.hs view
@@ -5,10 +5,10 @@ import Test.Type  -main = shakenCwd test $ \args obj -> return ()+main = shakeTest_ test $ return ()  -test build obj = do+test build = 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,19 +5,17 @@ import Test.Type  -main = shakenCwd test $ \args obj -> do-    want $ map obj args--    obj "in.txt" %> \out -> do+main = shakeTest_ test $ do+    "in.txt" %> \out -> do         a <- getVerbosity         b <- withVerbosity Normal getVerbosity         writeFile' out $ unwords $ map show [a,b] -    obj "out.txt" %> \out -> do+    "out.txt" %> \out -> do         x <- getVerbosity         ys <- withVerbosity Loud $ do             a <- getVerbosity-            need [obj "in.txt"] -- make sure the inherited verbosity does not get passed along+            need ["in.txt"] -- make sure the inherited verbosity does not get passed along             b <- getVerbosity             c <- quietly getVerbosity             d <- fmap shakeVerbosity getShakeOptions@@ -25,15 +23,15 @@         z <- getVerbosity         writeFile' out $ unwords $ map show $ [x] ++ ys ++ [z] -test build obj = do+test build = do     build ["out.txt","--clean"]-    assertContents (obj "in.txt") "Normal Normal"-    assertContents (obj "out.txt") "Normal Loud Loud Quiet Normal Normal"+    assertContents "in.txt" "Normal Normal"+    assertContents "out.txt" "Normal Loud Loud Quiet Normal Normal"      build ["out.txt","--clean","--verbose"]-    assertContents (obj "in.txt") "Loud Normal"-    assertContents (obj "out.txt") "Loud Loud Loud Quiet Loud Loud"+    assertContents "in.txt" "Loud Normal"+    assertContents "out.txt" "Loud Loud Loud Quiet Loud Loud"      build ["out.txt","--clean","--quiet"]-    assertContents (obj "in.txt") "Quiet Normal"-    assertContents (obj "out.txt") "Quiet Loud Loud Quiet Quiet Quiet"+    assertContents "in.txt" "Quiet Normal"+    assertContents "out.txt" "Quiet Loud Loud Quiet Quiet Quiet"
src/Test/Version.hs view
@@ -5,29 +5,29 @@ import Test.Type  -main = shakenCwd test $ \args obj -> do-    want [obj "foo.txt"]-    obj "foo.txt" %> \file -> liftIO $ appendFile file "x"+main = shakeTest_ test $ do+    want ["foo.txt"]+    "foo.txt" %> \file -> liftIO $ appendFile file "x" -test build obj = do-    writeFile (obj "foo.txt") ""-    v1 <- getHashedShakeVersion [obj "foo.txt"]-    writeFile (obj "foo.txt") "y"-    v2 <- getHashedShakeVersion [obj "foo.txt"]-    assert (v1 /= v2) "Hashes must not be equal"+test build = do+    writeFile "foo.txt" ""+    v1 <- getHashedShakeVersion ["foo.txt"]+    writeFile "foo.txt" "y"+    v2 <- getHashedShakeVersion ["foo.txt"]+    assertBool (v1 /= v2) "Hashes must not be equal"      build ["clean"]     build []-    assertContents (obj "foo.txt") "x"+    assertContents "foo.txt" "x"     build ["--rule-version=new","--silent"]-    assertContents (obj "foo.txt") "xx"+    assertContents "foo.txt" "xx"     build ["--rule-version=new"]-    assertContents (obj "foo.txt") "xx"+    assertContents "foo.txt" "xx"     build ["--rule-version=extra","--silent"]-    assertContents (obj "foo.txt") "xxx"+    assertContents "foo.txt" "xxx"     build ["--rule-version=more","--no-rule-version"]-    assertContents (obj "foo.txt") "xxx"+    assertContents "foo.txt" "xxx"     build ["--rule-version=more"]-    assertContents (obj "foo.txt") "xxx"+    assertContents "foo.txt" "xxx"     build ["--rule-version=final","--silent"]-    assertContents (obj "foo.txt") "xxxx"+    assertContents "foo.txt" "xxxx"