shake 0.18.3 → 0.18.4
raw patch · 53 files changed
+722/−315 lines, 53 filesdep +file-embeddep +template-haskell
Dependencies added: file-embed, template-haskell
Files
- CHANGES.txt +17/−0
- docs/Manual.md +14/−14
- docs/manual/Build.hs +0/−24
- docs/manual/Shakefile.hs +24/−0
- docs/manual/build.bat +1/−1
- docs/manual/build.sh +1/−1
- shake.cabal +26/−4
- src/Development/Ninja/All.hs +1/−1
- src/Development/Shake.hs +39/−8
- src/Development/Shake/Command.hs +22/−17
- src/Development/Shake/Forward.hs +42/−7
- src/Development/Shake/Internal/Args.hs +29/−16
- src/Development/Shake/Internal/CmdOption.hs +2/−1
- src/Development/Shake/Internal/CompactUI.hs +1/−1
- src/Development/Shake/Internal/Core/Action.hs +59/−38
- src/Development/Shake/Internal/Core/Build.hs +3/−3
- src/Development/Shake/Internal/Core/Database.hs +3/−2
- src/Development/Shake/Internal/Core/Monad.hs +6/−2
- src/Development/Shake/Internal/Core/Rules.hs +32/−21
- src/Development/Shake/Internal/Core/Run.hs +17/−17
- src/Development/Shake/Internal/Core/Storage.hs +1/−1
- src/Development/Shake/Internal/Core/Types.hs +5/−5
- src/Development/Shake/Internal/Derived.hs +3/−3
- src/Development/Shake/Internal/Errors.hs +1/−1
- src/Development/Shake/Internal/History/Cloud.hs +1/−1
- src/Development/Shake/Internal/History/Shared.hs +31/−5
- src/Development/Shake/Internal/History/Symlink.hs +1/−1
- src/Development/Shake/Internal/Options.hs +14/−10
- src/Development/Shake/Internal/Paths.hs +48/−11
- src/Development/Shake/Internal/Rules/Directory.hs +7/−2
- src/Development/Shake/Internal/Rules/File.hs +3/−3
- src/Development/Shake/Internal/Rules/Files.hs +1/−1
- src/Development/Shake/Internal/Rules/Oracle.hs +1/−1
- src/General/Binary.hs +1/−1
- src/General/Process.hs +2/−1
- src/General/Template.hs +28/−8
- src/General/Wait.hs +8/−4
- src/Run.hs +1/−1
- src/Test.hs +4/−2
- src/Test/Basic.hs +1/−1
- src/Test/Batch.hs +1/−1
- src/Test/CloseFileHandles.hs +69/−0
- src/Test/Command.hs +1/−1
- src/Test/Deprioritize.hs +0/−27
- src/Test/Docs.hs +29/−12
- src/Test/Errors.hs +6/−5
- src/Test/FileLock.hs +3/−2
- src/Test/Forward.hs +50/−6
- src/Test/Reschedule.hs +27/−0
- src/Test/Targets.hs +6/−0
- src/Test/Type.hs +12/−5
- src/Test/Unicode.hs +9/−7
- src/Test/Verbosity.hs +8/−8
CHANGES.txt view
@@ -1,5 +1,22 @@ Changelog for Shake (* = breaking change) +0.18.4, released 2019-12-15+ #734, add Forward.cacheActionWith+ #734, make forward fail if shakeLintInside is empty+* #701, make shakeSymlink=False the default+ #694, embed data files in the binary (use embed-files Cabal flag)+ #722, don't close file handles in cmd unless CloseFileHandles+ #727, add actionBracket for bracket-like operations+ #720, add --share-sanity to sanity check shared cache contents+ #719, write history key after cached files to ensure it is coherent+ #703, print rebuild warnings in yellow and errors in red+ #706, rename Verbosity's constructors and add Warn+ #443, add getEnvError+ #662, add Partial to command/cmd+ #708, rename deprioritize to reschedule+ #689, allow adding help messages at the end using addHelpSuffix+ #686, rename Build.hs to Shakefile.hs+ #690, make Ninja mode use -j0 by default (more like Ninja) 0.18.3, released 2019-07-01 Add shakeSymlink to enable/disable symlinks in the shared cache Improve cmd on async exceptions with nested processes on Windows
docs/Manual.md view
@@ -14,7 +14,7 @@ want ["_build/run" <.> exe] phony "clean" $ do- putNormal "Cleaning files in _build"+ putInfo "Cleaning files in _build" removeFilesAfter "_build" ["//*"] "_build/run" <.> exe %> \out -> do@@ -27,7 +27,7 @@ let c = dropDirectory1 $ out -<.> "c" let m = out -<.> "m" cmd_ "gcc -c" [c] "-o" [out] "-MMD -MF" [m]- needMakefileDependencies m+ neededMakefileDependencies 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. @@ -37,7 +37,7 @@ 1. Install the [Haskell Stack](https://haskellstack.org/), which provides a Haskell compiler and package manager. 2. Type `stack install shake`, to build and install Shake and all its dependencies.-3. Type `stack exec -- shake --demo`, which will create a directory containing a sample project, the above Shake script (named `Build.hs`), and execute it (which can be done by `runhaskell Build.hs`). For more details see a [trace of `shake --demo`](Demo.md).+3. Type `stack exec -- shake --demo`, which will create a directory containing a sample project, the above Shake script (named `Shakefile.hs`), and execute it (which can be done by `runhaskell Shakefile.hs`). For more details see a [trace of `shake --demo`](Demo.md). ## Basic syntax @@ -224,7 +224,7 @@ That will compile `main.c` to `main.o`, and also produce a file `main.m` containing the dependencies. To add these dependencies as dependencies of this rule we can call: - needMakefileDependencies "main.m"+ neededMakefileDependencies "main.m" Now, if either `main.c` or any headers transitively imported by `main.c` change, the file will be rebuilt. In the initial example the complete rule is: @@ -232,9 +232,9 @@ let c = dropDirectory1 $ out -<.> "c" let m = out -<.> "m" cmd_ "gcc -c" [c] "-o" [out] "-MMD -MF" [m]- needMakefileDependencies m+ neededMakefileDependencies 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`.+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 `neededMakefileDependencies`. #### Top-level variables @@ -258,10 +258,10 @@ A standard clean command is defined as: phony "clean" $ do- putNormal "Cleaning files in _build"+ putInfo "Cleaning files in _build" removeFilesAfter "_build" ["//*"] -Running the build system with the `clean` argument, e.g. `runhaskell Build.hs clean` will remove all files under the `_build` directory. This clean command is formed from two separate pieces. Firstly, we can define `phony` commands as:+Running the build system with the `clean` argument, e.g. `runhaskell Shakefile.hs clean` will remove all files under the `_build` directory. This clean command is formed from two separate pieces. Firstly, we can define `phony` commands as: <pre> phony "<i>name</i>" $ do@@ -270,7 +270,7 @@ Where <tt><i>name</i></tt> is the name used on the command line to invoke the actions, and <tt><i>actions</i></tt> are the list of things to do in response. These names are not dependency tracked and are run afresh each time they are requested. -The <tt><i>actions</i></tt> can be any standard build actions, although for a `clean` rule, `removeFilesAfter` is typical. This function waits until after any files have finished building (which will be none, if you do `runhaskell Build.hs clean`) then deletes all files matching `//*` in the `_build` directory. The `putNormal` function writes out a message to the console, as long as `--quiet` was not passed.+The <tt><i>actions</i></tt> can be any standard build actions, although for a `clean` rule, `removeFilesAfter` is typical. This function waits until after any files have finished building (which will be none, if you do `runhaskell Shakefile.hs clean`) then deletes all files matching `//*` in the `_build` directory. The `putInfo` function writes out a message to the console, as long as `--quiet` was not passed. ## Running @@ -278,13 +278,13 @@ #### Compiling the build system -As shown before, we can use `runhaskell Build.hs` to execute our build system, but doing so causes the build script to be compiled afresh each time. A more common approach is to add a shell script that compiles the build system and runs it. In the example directory you will find `build.sh` (Linux) and `build.bat` (Windows), both of which execute the same interesting commands. Looking at `build.sh`:+As shown before, we can use `runhaskell Shakefile.hs` to execute our build system, but doing so causes the build script to be compiled afresh each time. A more common approach is to add a shell script that compiles the build system and runs it. In the example directory you will find `build.sh` (Linux) and `build.bat` (Windows), both of which execute the same interesting commands. Looking at `build.sh`: #!/bin/sh mkdir -p _shake- ghc --make Build.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@"+ ghc --make Shakefile.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](https://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/).+This script creates a folder named `_shake` for the build system objects to live in, then runs `ghc --make Shakefile.hs` to produce `_shake/build`, then executes `_shake/build` with all arguments it was given. The `-with-rtsopts` flag instructs the Haskell compiler to disable "idle garbage collection", making more CPU available for the commands you are running, as [explained here](https://stackoverflow.com/questions/34588057/why-does-shake-recommend-disabling-idle-garbage-collection/). Now you can run a build by typing `stack exec ./build.sh` on Linux, or `stack exec build.bat` on Windows. On Linux you may want to alias `build` to `stack exec ./build.sh`. For the rest of this document we will assume `build` runs the build system. @@ -342,8 +342,8 @@ * Run in single-threaded mode (`-j1`) to make any output clearer by not interleaving commands. * By default a Shake build system prints out a message every time it runs a command. Use verbose mode (`--verbose`) to print more information to the screen, such as which rule is being run. Additional `--verbose` flags increase the verbosity. Three verbosity flags produce output intended for someone debugging the Shake library itself, rather than a build system based on it. * To raise a build error call `error "error message"`. Shake will abort, showing the error message.-* To output additional information use `putNormal "output message"`. This message will be printed to the console when it is reached.-* To show additional information with either `error` or `putNormal`, use `error $ show ("message", myVariable)`. This allows you to show any local variables.+* To output additional information use `putInfo "output message"`. This message will be printed to the console when it is reached.+* To show additional information with either `error` or `putInfo`, use `error $ show ("message", myVariable)`. This allows you to show any local variables. ## Extensions
− docs/manual/Build.hs
@@ -1,24 +0,0 @@-import Development.Shake-import Development.Shake.Command-import Development.Shake.FilePath-import Development.Shake.Util--main :: IO ()-main = shakeArgs shakeOptions{shakeFiles="_build"} $ do- want ["_build/run" <.> exe]-- phony "clean" $ do- putNormal "Cleaning files in _build"- removeFilesAfter "_build" ["//*"]-- "_build/run" <.> exe %> \out -> do- cs <- getDirectoryFiles "" ["//*.c"]- let os = ["_build" </> c -<.> "o" | c <- cs]- need os- cmd "gcc -o" [out] os-- "_build//*.o" %> \out -> do- let c = dropDirectory1 $ out -<.> "c"- let m = out -<.> "m"- () <- cmd "gcc -c" [c] "-o" [out] "-MMD -MF" [m]- needMakefileDependencies m
+ docs/manual/Shakefile.hs view
@@ -0,0 +1,24 @@+import Development.Shake+import Development.Shake.Command+import Development.Shake.FilePath+import Development.Shake.Util++main :: IO ()+main = shakeArgs shakeOptions{shakeFiles="_build"} $ do+ want ["_build/run" <.> exe]++ phony "clean" $ do+ putInfo "Cleaning files in _build"+ removeFilesAfter "_build" ["//*"]++ "_build/run" <.> exe %> \out -> do+ cs <- getDirectoryFiles "" ["//*.c"]+ let os = ["_build" </> c -<.> "o" | c <- cs]+ need os+ cmd_ "gcc -o" [out] os++ "_build//*.o" %> \out -> do+ let c = dropDirectory1 $ out -<.> "c"+ let m = out -<.> "m"+ cmd_ "gcc -c" [c] "-o" [out] "-MMD -MF" [m]+ neededMakefileDependencies m
docs/manual/build.bat view
@@ -1,2 +1,2 @@ @mkdir _shake 2> nul -@ghc --make Build.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake\build %* +@ghc --make Shakefile.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 -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@"+ghc --make Shakefile.hs -rtsopts -threaded -with-rtsopts=-I0 -outputdir=_shake -o _shake/build && _shake/build "$@"
shake.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: shake-version: 0.18.3+version: 0.18.4 license: BSD3 license-file: LICENSE category: Development, Shake@@ -30,7 +30,7 @@ (e.g. compiler version). homepage: https://shakebuild.com bug-reports: https://github.com/ndmitchell/shake/issues-tested-with: GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3+tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3 extra-doc-files: CHANGES.txt README.md@@ -53,7 +53,7 @@ src/Test/Tup/root.cfg data-files: docs/manual/build.bat- docs/manual/Build.hs+ docs/manual/Shakefile.hs docs/manual/build.sh docs/manual/constants.c docs/manual/constants.h@@ -76,6 +76,11 @@ manual: True description: Enable cloud build features +flag embed-files+ default: False+ manual: True+ description: Embed data files into the shake library+ library default-language: Haskell2010 hs-source-dirs: src@@ -101,6 +106,12 @@ unordered-containers >= 0.2.7, utf8-string >= 0.3 + if flag(embed-files)+ cpp-options: -DFILE_EMBED+ build-depends:+ file-embed >= 0.0.11,+ template-haskell+ if flag(portable) cpp-options: -DPORTABLE else@@ -208,6 +219,7 @@ extra >= 1.6.14, filepath, filepattern,+ file-embed >= 0.0.11, hashable >= 1.1.2.3, heaps >= 0.3.6.1, js-dgtable,@@ -216,11 +228,14 @@ primitive, process >= 1.1, random,+ template-haskell, time, transformers >= 0.2, unordered-containers >= 0.2.7, utf8-string >= 0.3 + cpp-options: -DFILE_EMBED+ if flag(portable) cpp-options: -DPORTABLE else@@ -339,6 +354,12 @@ unordered-containers >= 0.2.7, utf8-string >= 0.3 + if flag(embed-files)+ cpp-options: -DFILE_EMBED+ build-depends:+ file-embed >= 0.0.11,+ template-haskell+ if flag(portable) cpp-options: -DPORTABLE else@@ -437,10 +458,10 @@ Test.C Test.Cache Test.Cleanup+ Test.CloseFileHandles Test.Command Test.Config Test.Database- Test.Deprioritize Test.Digest Test.Directory Test.Docs@@ -466,6 +487,7 @@ Test.Progress Test.Random Test.Rebuild+ Test.Reschedule Test.Resources Test.Self Test.SelfMake
src/Development/Ninja/All.hs view
@@ -132,7 +132,7 @@ Nothing -> liftIO $ errorIO $ "Ninja pool named " ++ BS.unpack pool ++ " not found, required to build " ++ BS.unpack (BS.unwords out) Just r -> withResource r 1 act - when (description /= "") $ putNormal description+ when (description /= "") $ putInfo description let (cmdOpts, cmdProg, cmdArgs) = toCommand commandline if deps == "msvc" then do Stdout stdout <- withPool $ command cmdOpts cmdProg cmdArgs
src/Development/Shake.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TypeFamilies, ConstraintKinds #-}+{-# LANGUAGE TypeFamilies, ConstraintKinds, PatternSynonyms #-} -- | This module is used for defining Shake build systems. As a simple example of a Shake build system, -- let us build the file @result.tar@ from the files listed by @result.txt@:@@ -54,20 +54,20 @@ shakeOptions, Rules, action, withoutActions, alternatives, priority, versioned, Action, traced,- liftIO, actionOnException, actionFinally, actionCatch, actionRetry, runAfter,+ liftIO, actionOnException, actionFinally, actionBracket, actionCatch, actionRetry, runAfter, ShakeException(..), -- * Configuration ShakeOptions(..), Rebuild(..), Lint(..), Change(..), getShakeOptions, getShakeOptionsRules, getHashedShakeVersion, getShakeExtra, getShakeExtraRules, addShakeExtra, -- ** Command line- shakeArgs, shakeArgsWith, shakeArgsOptionsWith, shakeOptDescrs,+ shakeArgs, shakeArgsWith, shakeArgsOptionsWith, shakeOptDescrs, addHelpSuffix, -- ** Targets getTargets, addTarget, withTargetDocs, withoutTargets, -- ** Progress reporting Progress(..), progressSimple, progressDisplay, progressTitlebar, progressProgram, getProgress, -- ** Verbosity- Verbosity(..), getVerbosity, putLoud, putNormal, putQuiet, withVerbosity, quietly,+ Verbosity(..), getVerbosity, putVerbose, putInfo, putWarn, putError, withVerbosity, quietly, -- * Running commands command, command_, cmd, cmd_, unit, Stdout(..), StdoutTrim(..), Stderr(..), Stdouterr(..), Exit(..), Process(..), CmdTime(..), CmdLine(..), FSATrace(..),@@ -92,7 +92,7 @@ doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs, getDirectoryFilesIO, -- * Environment rules- getEnv, getEnvWithDefault,+ getEnv, getEnvWithDefault, getEnvError, -- * Oracle rules ShakeValue, RuleResult, addOracle, addOracleCache, addOracleHash, askOracle, askOracles, -- * Special rules@@ -108,14 +108,17 @@ needHasChanged, resultHasChanged, batch,- deprioritize,+ reschedule, -- * Deprecated (*>), (|*>), (&*>), (**>), (*>>), (?>>),- askOracleWith+ askOracleWith,+ deprioritize,+ pattern Quiet, pattern Normal, pattern Loud, pattern Chatty,+ putLoud, putNormal, putQuiet ) where -import Prelude(Maybe, FilePath) -- Since GHC 7.10 duplicates *>+import Prelude(Maybe, FilePath, Double, String) -- Since GHC 7.10 duplicates *> -- 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.@@ -267,3 +270,31 @@ -- since the 'RuleResult' type family now fixes the result type. askOracleWith :: (RuleResult q ~ a, ShakeValue q, ShakeValue a) => q -> a -> Action a askOracleWith question _ = askOracle question++---------------------------------------------------------------------+-- DEPRECATED SINCE 0.18.4, JUL 2019++-- | /Deprecated:/ Alias for 'reschedule'.+deprioritize :: Double -> Action ()+deprioritize = reschedule++-- | /Deprecated:/ A bidirectional pattern synonym for 'Error'.+pattern Quiet :: Verbosity+pattern Quiet = Error+-- | /Deprecated:/ A bidirectional pattern synonym for 'Info'.+pattern Normal :: Verbosity+pattern Normal = Info+-- | /Deprecated:/ A bidirectional pattern synonym for 'Verbose'.+pattern Loud :: Verbosity+pattern Loud = Verbose+-- | /Deprecated:/ A bidirectional pattern synonym for 'Verbose'.+pattern Chatty :: Verbosity+pattern Chatty = Verbose++putLoud, putNormal, putQuiet :: String -> Action ()+-- | /Deprecated:/ Alias for 'putVerbose'.+putLoud = putVerbose+-- | /Deprecated:/ Alias for 'putInfo'.+putNormal = putInfo+-- | /Deprecated:/ Alias for 'putError'.+putQuiet = putError
src/Development/Shake/Command.hs view
@@ -254,7 +254,7 @@ -- ACTION EXPLICIT OPERATION -- | Given explicit operations, apply the Action ones, like skip/trace/track/autodep-commandExplicitAction :: Params -> Action [Result]+commandExplicitAction :: Partial => Params -> Action [Result] commandExplicitAction oparams = do ShakeOptions{shakeCommandOptions,shakeRunCommands,shakeLint,shakeLintInside} <- getShakeOptions params@Params{..} <- return $ oparams{opts = shakeCommandOptions ++ opts oparams}@@ -263,12 +263,12 @@ let verboser act = do let cwd = listToMaybe $ reverse [x | Cwd x <- opts]- putLoud $+ putVerbose $ maybe "" (\x -> "cd " ++ x ++ "; ") cwd ++ last (showCommandForUser2 prog args : [x | UserCommand x <- opts]) verb <- getVerbosity- -- run quietly to supress the tracer (don't want to print twice)- (if verb >= Loud then quietly else id) act+ -- run quietly to suppress the tracer (don't want to print twice)+ (if verb >= Verbose then quietly else id) act let tracer act = do -- note: use the oparams - find a good tracing before munging it for shell stuff@@ -277,7 +277,7 @@ let async = ResultProcess PID0 `elem` results let tracker act- | AutoDeps `elem` opts = if async then fail "Can't use AutoDeps and asyncronous execution" else autodeps act+ | AutoDeps `elem` opts = if async then liftIO $ errorIO "Can't use AutoDeps and asyncronous execution" else autodeps act | shakeLint == Just LintFSATrace && not async = fsalint act | otherwise = act params @@ -285,7 +285,9 @@ ResultFSATrace pxs : res <- act params{opts = addFSAOptions "r" opts, results = ResultFSATrace [] : results} xs <- liftIO $ filterM doesFileExist [x | FSARead x <- pxs] cwd <- liftIO getCurrentDirectory- unsafeAllowApply . need =<< fixPaths cwd xs+ temp <- fixPaths cwd xs+ liftIO $ print ("AutoDeps", pxs, cwd, xs, temp) -- DEBUGGING+ unsafeAllowApply $ need temp return res fixPaths cwd xs = liftIO $ do@@ -314,7 +316,7 @@ -- IO EXPLICIT OPERATION -- | Given a very explicit set of CmdOption, translate them to a General.Process structure-commandExplicitIO :: Params -> IO [Result]+commandExplicitIO :: Partial => Params -> IO [Result] commandExplicitIO params = removeOptionShell params $ \params -> removeOptionFSATrace params $ \Params{..} -> do let (grabStdout, grabStderr) = both or $ unzip $ flip map results $ \r -> case r of ResultStdout{} -> (True, False)@@ -340,6 +342,7 @@ let optEchoStderr = last $ (not grabStderr && null optFileStderr) : [x | EchoStderr x <- opts] let optRealCommand = showCommandForUser2 prog args let optUserCommand = last $ optRealCommand : [x | UserCommand x <- opts]+ let optCloseFds = CloseFileHandles `elem` opts let bufLBS f = do (a,b) <- buf $ LBS LBS.empty; return (a, (\(LBS x) -> f x) <$> b) buf Str{} | optBinary = bufLBS (Str . LBS.unpack)@@ -366,6 +369,7 @@ ,poStdout = [DestEcho | optEchoStdout] ++ map DestFile optFileStdout ++ [DestString exceptionBuffer | optWithStdout && not optAsync] ++ concat dStdout ,poStderr = [DestEcho | optEchoStderr] ++ map DestFile optFileStderr ++ [DestString exceptionBuffer | optWithStderr && not optAsync] ++ concat dStderr ,poAsync = optAsync+ ,poCloseFds = optCloseFds } (dur,(pid,exit)) <- duration $ process po if exit == ExitSuccess || ResultCode ExitSuccess `elem` results then@@ -378,7 +382,8 @@ Just v -> do v <- canonicalizePath v `catchIO` const (return v) return $ "Current directory: " ++ v ++ "\n"- fail $+ -- FIXME: switch to errorIO once extra-1.6.18 is available everywhere+ liftIO $ error $ "Development.Shake." ++ funcName ++ ", system command failed\n" ++ "Command line: " ++ optRealCommand ++ "\n" ++ (if optRealCommand /= optUserCommand then "Original command line: " ++ optUserCommand ++ "\n" else "") ++@@ -602,14 +607,14 @@ -- By default the @stderr@ stream will be captured for use in error messages, and also echoed. To only echo -- pass @'WithStderr' 'False'@, which causes no streams to be captured by Shake, and certain programs (e.g. @gcc@) -- to detect they are running in a terminal.-command :: CmdResult r => [CmdOption] -> String -> [String] -> Action r-command opts x xs = b <$> commandExplicitAction (Params "command" opts a x xs)+command :: (Partial, CmdResult r) => [CmdOption] -> String -> [String] -> Action r+command opts x xs = withFrozenCallStack $ b <$> commandExplicitAction (Params "command" opts a x xs) where (a,b) = cmdResult -- | A version of 'command' where you do not require any results, used to avoid errors about being unable -- to deduce 'CmdResult'.-command_ :: [CmdOption] -> String -> [String] -> Action ()-command_ opts x xs = void $ commandExplicitAction (Params "command_" opts [] x xs)+command_ :: Partial => [CmdOption] -> String -> [String] -> Action ()+command_ opts x xs = withFrozenCallStack $ void $ commandExplicitAction (Params "command_" opts [] x xs) ---------------------------------------------------------------------@@ -662,13 +667,13 @@ -- @ -- 'cmd' ('Cwd' \"generated\") 'Shell' \"gcc -c myfile.c\" :: IO () -- @-cmd :: CmdArguments args => args :-> Action r-cmd = cmdArguments mempty+cmd :: (Partial, CmdArguments args) => args :-> Action r+cmd = withFrozenCallStack $ 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+cmd_ :: (Partial, CmdArguments args, Unit args) => args :-> Action ()+cmd_ = withFrozenCallStack cmd -- | The arguments to 'cmd' - see 'cmd' for examples and semantics. newtype CmdArgument = CmdArgument [Either CmdOption String]@@ -677,7 +682,7 @@ -- | The arguments to 'cmd' - see 'cmd' for examples and semantics. class CmdArguments t where -- | Arguments to cmd- cmdArguments :: CmdArgument -> t+ cmdArguments :: Partial => 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
src/Development/Shake/Forward.hs view
@@ -31,16 +31,25 @@ -- * Where Haskell performs real computation, if zero-build performance is insufficient, use 'cacheAction'. -- -- All forward-defined systems use 'AutoDeps', which requires @fsatrace@ to be on the @$PATH@.--- You can obtain @fsatrace@ from <https://github.com/jacereda/fsatrace>.+-- You can obtain @fsatrace@ from <https://github.com/jacereda/fsatrace>. You must set+-- 'shakeLintInside' to specify where 'AutoDeps' will look for dependencies - if you want all dependencies+-- everywhere use @[\"\"]@. ----- This module is considered experimental - it has not been battle tested.--- A possible alternative is available at <http://hackage.haskell.org/package/pier/docs/Pier-Core-Artifact.html>.+-- This module is considered experimental - it has not been battle tested. There are now a few possible+-- alternatives in this space:+--+-- * Pier <http://hackage.haskell.org/package/pier/docs/Pier-Core-Artifact.html> (built on Shake).+--+-- * Rattle <https://github.com/ndmitchell/rattle> (by the same author as Shake).+--+-- * Stroll <https://github.com/snowleopard/stroll>. module Development.Shake.Forward( shakeForward, shakeArgsForward, forwardOptions, forwardRule,- cache, cacheAction+ cache, cacheAction, cacheActionWith, ) where +import Control.Monad import Development.Shake import Development.Shake.Rule import Development.Shake.Command@@ -70,7 +79,7 @@ mkForward :: (Typeable a, Show a, Binary a) => a -> Forward mkForward x = Forward (show $ typeOf x, show x, encode' x) -unForward :: forall a . (Typeable a, Show a, Binary a) => Forward -> a+unForward :: forall a . (Typeable a, Binary a) => Forward -> a unForward (Forward (got,_,x)) | got /= want = error $ "Failed to match forward type, wanted " ++ show want ++ ", got " ++ show got | otherwise = decode' x@@ -98,6 +107,9 @@ -- | Given an 'Action', turn it into a 'Rules' structure which runs in forward mode. forwardRule :: Action () -> Rules () forwardRule act = do+ opts <- getShakeOptionsRules+ when (null $ shakeLintInside opts) $+ fail "When running in forward mode you must set shakeLintInside to specify where to detect dependencies" addBuiltinRule noLint noIdentity $ \k old mode -> case old of Just old | mode == RunDependenciesSame -> return $ RunResult ChangedNothing old (decode' old)@@ -115,7 +127,10 @@ forwardOptions opts = opts{shakeCommandOptions=[AutoDeps]} --- | Cache an action. The name of the action must be unique for all different actions.+-- | Cache an action, given a key and an 'Action'. Each call in your program should specify a different+-- key, but the key should remain consistent between runs. Ideally, the 'Action' will gather all its dependencies+-- with tracked operations, e.g. 'readFile\''. However, if information is accessed from the environment+-- (e.g. the action is a closure), you should call 'cacheActionWith' being explicit about what is captured. cacheAction :: (Typeable a, Binary a, Show a, Typeable b, Binary b, Show b) => a -> Action b -> Action b cacheAction (mkForward -> key) (action :: Action b) = do liftIO $ atomicModifyIORef forwards $ \mp -> (Map.insert key (mkForward <$> action) mp, ())@@ -123,7 +138,27 @@ liftIO $ atomicModifyIORef forwards $ \mp -> (Map.delete key mp, ()) return $ unForward res --- | Apply caching to an external command.+newtype With a = With a+ deriving (Typeable, Binary, Show)++-- | Like 'cacheAction', but also specify which information is captured by the closure of the 'Action'. If that+-- information changes, the 'Action' will be rerun.+cacheActionWith :: (Typeable a, Binary a, Show a, Typeable b, Binary b, Show b, Typeable c, Binary c, Show c) => a -> b -> Action c -> Action c+cacheActionWith key argument action = do+ cacheAction (With argument) $ do+ alwaysRerun+ return argument+ cacheAction key $ do+ apply1 $ mkForward $ With argument+ action++-- | Apply caching to an external command using the same arguments as 'cmd'.+--+-- > cache $ cmd "gcc -c" ["foo.c"] "-o" ["foo.o"]+--+-- This command will be cached, with the inputs/outputs traced. If any of the+-- files used by this command (e.g. @foo.c@ or header files it imports) then+-- the command will rerun. cache :: (forall r . CmdArguments r => r) -> Action () cache cmd = do let CmdArgument args = cmd
src/Development/Shake/Internal/Args.hs view
@@ -160,38 +160,40 @@ let putWhenLn v msg = putWhen v $ msg ++ "\n" let showHelp long = do progName <- getProgName- targets <- if not long then return [] else- handleSynchronous (\e -> do putWhenLn Normal $ "Failure to collect targets: " ++ show e; return []) $ do+ (targets, helpSuffix) <- if not long then return ([], []) else+ handleSynchronous (\e -> do putWhenLn Info $ "Failure to collect targets: " ++ show e; return ([], [])) $ do -- run the rules as simply as we can rs <- rules shakeOpts [] [] case rs of Just (_, rs) -> do xs <- getTargets shakeOpts rs- evaluate $ force [" - " ++ a ++ maybe "" (" - " ++) b | (a,b) <- xs]- _ -> return []+ helpSuffix <- getHelpSuffix shakeOpts rs+ evaluate $ force ([" - " ++ a ++ maybe "" (" - " ++) b | (a,b) <- xs], helpSuffix)+ _ -> return ([], []) changes <- return $ let as = shakeOptionsFields baseOpts bs = shakeOptionsFields oshakeOpts in [" - " ++ lbl ++ ": " ++ v1 ++ " => " ++ v2 | long, ((lbl, v1), (_, v2)) <- zip as bs, v1 /= v2] - putWhen Quiet $ unlines $+ putWhen Error $ unlines $ ("Usage: " ++ progName ++ " [options] [target] ...") : (if null baseOpts2 then [] else "" : (if null userOptions then "Options:" else "Standard options:") : showOptDescr baseOpts2) ++ (if null userOptions then [] else "" : "Extra options:" : showOptDescr userOptions) ++ (if null changes then [] else "" : "Changed ShakeOptions:" : changes) ++- (if null targets then [] else "" : "Targets:" : targets)+ (if null targets then [] else "" : "Targets:" : targets) +++ (if null helpSuffix then [] else "" : helpSuffix) when (errs /= []) $ do- putWhen Quiet $ unlines $ map ("shake: " ++) $ filter (not . null) $ lines $ unlines errs+ putWhen Error $ unlines $ map ("shake: " ++) $ filter (not . null) $ lines $ unlines errs showHelp False exitFailure if Help `elem` flagsExtra then showHelp True else if Version `elem` flagsExtra then- putWhenLn Normal $ "Shake build system, version " ++ shakeVersionString+ putWhenLn Info $ "Shake build system, version " ++ shakeVersionString else if NumericVersion `elem` flagsExtra then- putWhenLn Normal shakeVersionString+ putWhenLn Info shakeVersionString else if Demo `elem` flagsExtra then demo $ shakeStaunch shakeOpts else if not $ null progressReplays then do@@ -199,7 +201,7 @@ 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+ putWhenLn Info $ "Writing report to " ++ file writeProgressReport file dat else do when (Sleep `elem` flagsExtra) $ sleep 1@@ -220,7 +222,7 @@ (ran,shakeOpts,res) <- redir $ do when printDirectory $ do curdir <- getCurrentDirectory- putWhenLn Normal $ "shake: In directory `" ++ curdir ++ "'"+ putWhenLn Info $ "shake: In directory `" ++ curdir ++ "'" (shakeOpts, ui) <- do let compact = last $ No : [x | Compact x <- flagsExtra] use <- if compact == Auto then checkEscCodes else return $ compact == Yes@@ -234,18 +236,22 @@ res <- try_ $ shake shakeOpts $ if NoBuild `elem` flagsExtra then withoutActions rules- else if ShareList `elem` flagsExtra || not (null shareRemoves) then do+ else if ShareList `elem` flagsExtra ||+ not (null shareRemoves) ||+ ShareSanity `elem` flagsExtra then do action $ do unless (null shareRemoves) $ actionShareRemove shareRemoves when (ShareList `elem` flagsExtra) actionShareList+ when (ShareSanity `elem` flagsExtra)+ actionShareSanity withoutActions rules else rules return (True, shakeOpts, res) - if not ran || shakeVerbosity shakeOpts < Normal || NoTime `elem` flagsExtra then+ if not ran || shakeVerbosity shakeOpts < Info || NoTime `elem` flagsExtra then either throwIO return res else let esc = if shakeColor shakeOpts then escape else flip const@@ -254,11 +260,11 @@ if Exception `elem` flagsExtra then throwIO err else do- putWhenLn Quiet $ esc Red $ show err+ putWhenLn Error $ esc Red $ show err exitFailure Right () -> do tot <- start- putWhenLn Normal $ esc Green $ "Build completed in " ++ showDuration tot+ putWhenLn Info $ esc Green $ "Build completed in " ++ showDuration tot -- | A list of command line options that can be used to modify 'ShakeOptions'. Each option returns@@ -281,6 +287,7 @@ | ProgressReplay FilePath | Demo | ShareList+ | ShareSanity | ShareRemove String | Compact Auto deriving Eq@@ -292,7 +299,12 @@ escape color x = escForeground color ++ x ++ escNormal outputColor :: (Verbosity -> String -> IO ()) -> Verbosity -> String -> IO ()-outputColor output v msg = output v $ escape Blue msg+outputColor output v msg = output v $ color msg+ where color = case v of+ Silent -> id+ Error -> escape Red+ Warn -> escape Yellow+ _ -> escape Blue -- | True if it has a potential effect on ShakeOptions shakeOptsEx :: [(Bool, OptDescr (Either String ([Extra], ShakeOptions -> ShakeOptions)))]@@ -336,6 +348,7 @@ ,opts $ Option "" ["no-rule-version"] (noArg $ \s -> s{shakeVersionIgnore=True}) "Ignore the build rules version." ,opts $ Option "" ["share"] (optArg "DIRECTORY" $ \x s -> s{shakeShare=Just $ fromMaybe "" x, shakeChange=ensureHash $ shakeChange s}) "Shared cache location." ,hide $ Option "" ["share-list"] (noArg ([ShareList], ensureShare)) "List the shared cache files."+ ,hide $ Option "" ["share-sanity"] (noArg ([ShareSanity], ensureShare)) "Sanity check the shared cache files." ,hide $ Option "" ["share-remove"] (OptArg (\x -> Right ([ShareRemove $ fromMaybe "**" x], ensureShare)) "SUBSTRING") "Remove the shared cache keys." ,opts $ Option "" ["share-copy"] (noArg $ \s -> s{shakeSymlink=False}) "Copy files into the cache." ,opts $ Option "" ["share-symlink"] (noArg $ \s -> s{shakeSymlink=True}) "Symlink files into the cache."
src/Development/Shake/Internal/CmdOption.hs view
@@ -25,7 +25,8 @@ | 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.+ | AutoDeps -- ^ Compute dependencies automatically. Only works if 'shakeLintInside' has been set to the files where autodeps might live. | UserCommand String -- ^ The command the user thinks about, before any munging. Defaults to the actual command. | FSAOptions String -- ^ Options to @fsatrace@, a list of strings with characters such as @\"r\"@ (reads) @\"w\"@ (writes). Defaults to @\"rwmdqt\"@ if the output of @fsatrace@ is required.+ | CloseFileHandles -- ^ Before starting the command in the child process, close all file handles except stdin, stdout, stderr in the child process. Uses @close_fds@ from package process and comes with the same caveats, i.e. runtime is linear with the maximum number of open file handles (@RLIMIT_NOFILE@, see @man 2 getrlimit@ on Linux). deriving (Eq,Ord,Show,Data,Typeable)
src/Development/Shake/Internal/CompactUI.hs view
@@ -71,7 +71,7 @@ ,shakeOutput = \a b -> tweak (addOutput a b) ,shakeProgress = \x -> void $ progressDisplay 1 (tweak . addProgress) x `withThreadsBoth` shakeProgress opts x ,shakeCommandOptions = [EchoStdout False, EchoStderr False] ++ shakeCommandOptions opts- ,shakeVerbosity = Quiet+ ,shakeVerbosity = Error } let tick = do t <- time; mask_ $ putStr =<< atomicModifyIORef ref (display t) return (opts, forever (tick >> sleep 0.4) `finally` tick)
src/Development/Shake/Internal/Core/Action.hs view
@@ -1,23 +1,23 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, ConstraintKinds, TupleSections, ViewPatterns #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, ConstraintKinds, TupleSections #-} module Development.Shake.Internal.Core.Action(- actionOnException, actionFinally, actionCatch, actionRetry,+ actionOnException, actionFinally, actionBracket, actionCatch, actionRetry, getShakeOptions, getProgress, runAfter, lintTrackRead, lintTrackWrite, lintTrackAllow,- getVerbosity, putWhen, putLoud, putNormal, putQuiet, withVerbosity, quietly,+ getVerbosity, putWhen, putVerbose, putInfo, putWarn, putError, withVerbosity, quietly, orderOnlyAction, newCacheIO, unsafeExtraThread, parallel, batch,- deprioritize,+ reschedule, historyDisable, traced, -- Internal only producesChecked, producesUnchecked, producesCheck, lintCurrentDirectory, lintWatch, blockApply, unsafeAllowApply, shakeException, lintTrackFinished, getCurrentKey, getLocal,- actionShareList, actionShareRemove+ actionShareList, actionShareRemove, actionShareSanity ) where import Control.Exception@@ -60,8 +60,8 @@ -- | Apply a modification, run an action, then run an undo action after. -- Doesn't actually require exception handling because we don't have the ability to catch exceptions to the user.-actionBracket :: (Local -> (Local, Local -> Local)) -> Action a -> Action a-actionBracket f m = Action $ do+actionThenUndoLocal :: (Local -> (Local, Local -> Local)) -> Action a -> Action a+actionThenUndoLocal f m = Action $ do s <- getRW let (s2,undo) = f s putRW s2@@ -81,28 +81,36 @@ Just (e :: ShakeException) -> return e Nothing -> do e <- return $ exceptionStack stk e- when (shakeStaunch && shakeVerbosity >= Quiet) $- globalOutput Quiet $ show e ++ "Continuing due to staunch mode"+ when (shakeStaunch && shakeVerbosity >= Error) $+ globalOutput Error $ show e ++ "Continuing due to staunch mode" return e -actionBoom :: Bool -> Action a -> IO b -> Action a-actionBoom runOnSuccess act (void -> clean) = do+actionBracketEx :: Bool -> IO a -> (a -> IO b) -> (a -> Action c) -> Action c+actionBracketEx runOnSuccess alloc free act = do Global{..} <- Action getRO- key <- liftIO $ register globalCleanup clean- -- important to mask_ the undo/clean combo so either both happen or neither- res <- Action $ catchRAW (fromAction act) $ \e -> liftIO (release key) >> throwRAW e+ (v, key) <- liftIO $ mask_ $ do+ v <- alloc+ key <- liftIO $ register globalCleanup $ void $ free v+ return (v, key)+ res <- Action $ catchRAW (fromAction $ act v) $ \e -> liftIO (release key) >> throwRAW e liftIO $ if runOnSuccess then release key else unprotect key return res -- | If an exception is raised by the 'Action', perform some 'IO' then reraise the exception. actionOnException :: Action a -> IO b -> Action a-actionOnException = actionBoom False+actionOnException act free = actionBracketEx False (return ()) (const free) (const act) -- | After an 'Action', perform some 'IO', even if there is an exception. actionFinally :: Action a -> IO b -> Action a-actionFinally = actionBoom True+actionFinally act free = actionBracket (return ()) (const free) (const act) +-- | Like `bracket`, but where the inner operation is of type 'Action'. Usually used as+-- @'actionBracket' alloc free use@.+actionBracket :: IO a -> (a -> IO b) -> (a -> Action c) -> Action c+actionBracket = actionBracketEx True++ -- | If a syncronous exception is raised by the 'Action', perform some handler. -- Note that there is no guarantee that the handler will run on shutdown (use 'actionFinally' for that), -- and that 'actionCatch' /cannot/ catch exceptions thrown by dependencies, e.g. raised by 'need'@@ -158,25 +166,30 @@ liftIO $ globalOutput v msg --- | Write an unimportant message to the output, only shown when 'shakeVerbosity' is higher than normal ('Loud' or above).+-- | Write an unimportant message to the output, only shown when 'shakeVerbosity' is higher than normal ('Verbose' 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+putVerbose :: String -> Action ()+putVerbose = putWhen Verbose --- | Write a normal priority message to the output, only supressed when 'shakeVerbosity' is 'Quiet' or 'Silent'.+-- | Write a normal priority message to the output, only suppressed when 'shakeVerbosity' is 'Error', 'Warn' 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+putInfo :: String -> Action ()+putInfo = putWhen Info --- | Write an important message to the output, only supressed when 'shakeVerbosity' is 'Silent'.+-- | Write a semi important message to the output, only suppressed when 'shakeVerbosity' is 'Error' or '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+putWarn :: String -> Action ()+putWarn = putWhen Warn +-- | Write an important message to the output, only suppressed when 'shakeVerbosity' is 'Silent'.+-- The output will not be interleaved with any other Shake messages (other than those generated by system commands).+putError :: String -> Action ()+putError = putWhen Error + -- | 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+-- 'putVerbose' \/ 'putInfo' \/ 'putError', which ensures multiple messages are -- not interleaved. The verbosity can be modified locally by 'withVerbosity'. getVerbosity :: Action Verbosity getVerbosity = Action $ localVerbosity <$> getRW@@ -186,16 +199,16 @@ -- 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 = actionBracket $ \s0 ->+withVerbosity new = actionThenUndoLocal $ \s0 -> (s0{localVerbosity=new}, \s -> s{localVerbosity=localVerbosity s0}) --- | Run an action with 'Quiet' verbosity, in particular messages produced by 'traced'+-- | Run an action with 'Error' 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+quietly = withVerbosity Error ---------------------------------------------------------------------@@ -208,7 +221,7 @@ blockApply = applyBlockedBy . Just applyBlockedBy :: Maybe String -> Action a -> Action a-applyBlockedBy reason = actionBracket $ \s0 ->+applyBlockedBy reason = actionThenUndoLocal $ \s0 -> (s0{localBlockApply=reason}, \s -> s{localBlockApply=localBlockApply s0}) @@ -225,7 +238,7 @@ -- > # 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.+-- over the message using 'putInfo'), use the 'quietly' combinator. -- -- It is recommended that the string passed to 'traced' is short and that only a small number of unique strings -- are used (makes profiling work better).@@ -236,7 +249,7 @@ Local{localStack} <- Action getRW start <- liftIO globalTimestamp let key = showTopStack localStack- putNormal $ "# " ++ msg ++ " (for " ++ key ++ ")"+ putInfo $ "# " ++ msg ++ " (for " ++ key ++ ")" res <- liftIO $ (shakeTrace globalOptions key msg True >> act) `finally` shakeTrace globalOptions key msg False@@ -250,7 +263,7 @@ --------------------------------------------------------------------- -- TRACKING --- | Track that a key has been used/read by the action preceeding it when 'shakeLint' is active.+-- | Track that a key has been used/read by the action preceding it when 'shakeLint' is active. lintTrackRead :: ShakeValue key => [key] -> Action () -- One of the following must be true: -- 1) you are the one building this key (e.g. key == topStack)@@ -561,12 +574,12 @@ liftIO $ mapM_ (flip signalFence res . thd3) now --- | Given a running task, deprioritize so it only continues after all other pending tasks,--- and all deprioritized tasks with a higher priority. Note that due to parallelism there is no guarantee--- that all actions of a higher priority will have /completed/ before the action resumes.+-- | Given a running task, reschedule so it only continues after all other pending tasks,+-- and all rescheduled tasks with a higher pool priority. Note that due to parallelism there is no guarantee+-- that all actions of a higher pool priority will have /completed/ before the action resumes. -- Only useful if the results are being interactively reported or consumed.-deprioritize :: Double -> Action ()-deprioritize x = do+reschedule :: Double -> Action ()+reschedule x = do (wait, _) <- actionAlwaysRequeuePriority (PoolDeprioritize $ negate x) $ return () Action $ modifyRW $ addDiscount wait @@ -592,3 +605,11 @@ case globalShared of Nothing -> throwM $ errorInternal "actionShareList with no shared" Just x -> liftIO $ listShared x++-- | Hooked up to --share-sanity+actionShareSanity :: Action ()+actionShareSanity = do+ Global{..} <- Action getRO+ case globalShared of+ Nothing -> throwM $ errorInternal "actionShareSanity with no shared"+ Just x -> liftIO $ sanityShared x
src/Development/Shake/Internal/Core/Build.hs view
@@ -78,13 +78,13 @@ Nothing -> Now $ Left $ errorStructured "Shake Id no longer exists" [("Id", Just $ show i)] "" Just (k, s) -> case s of Ready r -> Now $ Right r- Error e _ -> Now $ Left e+ Failed e _ -> Now $ Left e Running{} | Left e <- addStack i k stack -> Now $ Left e _ -> Later $ \continue -> do Just (_, s) <- liftIO $ getKeyValueFromId database i case s of Ready r -> continue $ Right r- Error e _ -> continue $ Left e+ Failed e _ -> continue $ Left e Running (NoShow w) r -> do let w2 v = w v >> continue v setMem database i k $ Running (NoShow w2) r@@ -117,7 +117,7 @@ Right RunResult{..} | runChanged /= ChangedNothing -> setDisk database i k $ Loaded runValue{result=runStore} _ -> return () where- mkError e = if globalOneShot then Error e Nothing else Error e r+ mkError e = Failed e $ if globalOneShot then Nothing else r -- | Compute the value for a given RunMode and a restore function to run
src/Development/Shake/Internal/Core/Database.hs view
@@ -9,6 +9,7 @@ setMem, setDisk, modifyAllMem ) where +import Data.Tuple.Extra import Data.IORef.Extra import General.Intern(Id, Intern) import Development.Shake.Classes@@ -18,7 +19,7 @@ import Control.Monad.IO.Class import qualified General.Ids as Ids -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail #endif @@ -107,7 +108,7 @@ setMem Database{..} i k v = liftIO $ Ids.insert status i (k,v) modifyAllMem :: DatabasePoly k v -> (v -> v) -> Locked ()-modifyAllMem Database{..} f = liftIO $ Ids.forMutate status $ \(k, s) -> (k, f s)+modifyAllMem Database{..} f = liftIO $ Ids.forMutate status $ second f setDisk :: DatabasePoly k v -> Id -> k -> v -> IO () setDisk = journal
src/Development/Shake/Internal/Core/Monad.hs view
@@ -18,7 +18,7 @@ import Data.Semigroup import Prelude -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail #endif @@ -54,9 +54,13 @@ instance MonadIO (RAW k v ro rw) where liftIO = LiftIO -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 instance MonadFail (RAW k v ro rw) where fail = liftIO . Control.Monad.Fail.fail+#endif+#if __GLASGOW_HASKELL__ >= 808+instance MonadFail (RAW k v ro rw) where+ fail = liftIO . Prelude.fail #endif instance Semigroup a => Semigroup (RAW k v ro rw a) where
src/Development/Shake/Internal/Core/Rules.hs view
@@ -1,17 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds, NamedFieldPuns #-} {-# LANGUAGE ExistentialQuantification, RankNTypes #-} {-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-} module Development.Shake.Internal.Core.Rules(- Rules, runRules,+ Rules, SRules(..), runRules, RuleResult, addBuiltinRule, addBuiltinRuleEx, noLint, noIdentity, getShakeOptionsRules, getUserRuleInternal, getUserRuleOne, getUserRuleList, getUserRuleMaybe, addUserRule, alternatives, priority, versioned, getTargets, addTarget, withTargetDocs, withoutTargets,+ addHelpSuffix, getHelpSuffix, action, withoutActions ) where @@ -40,7 +42,7 @@ import General.ListBuilder import Prelude -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail #endif @@ -113,17 +115,17 @@ -- | 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 (ReaderT (ShakeOptions, IORef SRules) IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars)+newtype Rules a = Rules (ReaderT (ShakeOptions, IORef (SRules ListBuilder)) IO a) -- All IO must be associative/commutative (e.g. creating IORef/MVars) deriving (Functor, Applicative, Monad, MonadIO, MonadFix #if __GLASGOW_HASKELL__ >= 800 ,MonadFail #endif ) -newRules :: SRules -> Rules ()+newRules :: SRules ListBuilder -> Rules () newRules x = Rules $ liftIO . flip modifyIORef' (<> x) =<< asks snd -modifyRulesScoped :: (SRules -> SRules) -> Rules a -> Rules a+modifyRulesScoped :: (SRules ListBuilder -> SRules ListBuilder) -> Rules a -> Rules a modifyRulesScoped f (Rules r) = Rules $ do (opts, refOld) <- ask liftIO $ do@@ -133,12 +135,12 @@ modifyIORef' refOld (<> f rules) return res -runRules :: ShakeOptions -> Rules () -> IO ([(Stack, Action ())], Map.HashMap TypeRep BuiltinRule, TMap.Map UserRuleVersioned, [Target])+runRules :: ShakeOptions -> Rules () -> IO (SRules []) runRules opts (Rules r) = do ref <- newIORef mempty runReaderT r (opts, ref) SRules{..} <- readIORef ref- return (runListBuilder actions, builtinRules, userRules, runListBuilder targets)+ return $ SRules (runListBuilder actions) builtinRules userRules (runListBuilder targets) (runListBuilder helpSuffix) -- | Get all targets registered in the given rules. The names in -- 'Development.Shake.phony' and 'Development.Shake.~>' as well as the file patterns@@ -147,27 +149,33 @@ -- Returns the command, paired with the documentation (if any). getTargets :: ShakeOptions -> Rules () -> IO [(String, Maybe String)] getTargets opts rs = do- (_actions, _ruleinfo, _userRules, targets) <- runRules opts rs+ SRules{targets} <- runRules opts rs return [(target, documentation) | Target{..} <- targets] +getHelpSuffix :: ShakeOptions -> Rules () -> IO [String]+getHelpSuffix opts rs = do+ SRules{helpSuffix} <- runRules opts rs+ return helpSuffix+ data Target = Target {target :: !String ,documentation :: !(Maybe String) } deriving (Eq,Ord,Show,Read,Data,Typeable) -data SRules = SRules- {actions :: !(ListBuilder (Stack, Action ()))+data SRules list = SRules+ {actions :: !(list (Stack, Action ())) ,builtinRules :: !(Map.HashMap TypeRep{-k-} BuiltinRule) ,userRules :: !(TMap.Map UserRuleVersioned)- ,targets :: !(ListBuilder Target)+ ,targets :: !(list Target)+ ,helpSuffix :: !(list String) } -instance Semigroup SRules where- (SRules x1 x2 x3 x4) <> (SRules y1 y2 y3 y4) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (TMap.unionWith (<>) x3 y3) (mappend x4 y4)+instance Semigroup (SRules ListBuilder) where+ (SRules x1 x2 x3 x4 x5) <> (SRules y1 y2 y3 y4 y5) = SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (TMap.unionWith (<>) x3 y3) (mappend x4 y4) (mappend x5 y5) where f k a b = throwImpure $ errorRuleDefinedMultipleTimes k [builtinLocation a, builtinLocation b] -instance Monoid SRules where- mempty = SRules mempty Map.empty TMap.empty mempty+instance Monoid (SRules ListBuilder) where+ mempty = SRules mempty Map.empty TMap.empty mempty mempty mappend = (<>) instance Semigroup a => Semigroup (Rules a) where@@ -190,7 +198,7 @@ addTarget :: String -> Rules () addTarget t = newRules mempty{targets = newListBuilder $ Target t Nothing} --- | For all 'addTarget' targets within the 'Rules' prodivde the specified documentation, if they+-- | For all 'addTarget' targets within the 'Rules' provide the specified documentation, if they -- don't already have documentation. withTargetDocs :: String -> Rules () -> Rules () withTargetDocs d = modifyRulesScoped $ \x -> x{targets = f <$> targets x}@@ -201,6 +209,9 @@ withoutTargets :: Rules a -> Rules a withoutTargets = modifyRulesScoped $ \x -> x{targets=mempty} +-- | Adds some extra information at the end of @--help@.+addHelpSuffix :: String -> Rules ()+addHelpSuffix s = newRules mempty{helpSuffix = newListBuilder s} -- | A suitable 'BuiltinLint' that always succeeds. noLint :: BuiltinLint key value@@ -209,16 +220,16 @@ -- | A suitable 'BuiltinIdentity' that always fails with a runtime error, incompatible with 'shakeShare'. -- Use this function if you don't care about 'shakeShare', or if your rule provides a dependency that can -- never be cached (in which case you should also call 'Development.Shake.historyDisable').-noIdentity :: Typeable key => BuiltinIdentity key value+noIdentity :: BuiltinIdentity key value noIdentity _ _ = Nothing -- | The type mapping between the @key@ or a rule and the resulting @value@.--- See 'addBuiltinRule' and 'apply'.+-- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'. type family RuleResult key -- = value -- | Define a builtin rule, passing the functions to run in the right circumstances.--- The @key@ and @value@ types will be what is used by 'Development.Shake.apply'.+-- The @key@ and @value@ types will be what is used by 'Development.Shake.Rule.apply'. -- As a start, you can use 'noLint' and 'noIdentity' as the first two functions, -- but are required to supply a suitable 'BuiltinRun'. --@@ -249,7 +260,7 @@ newRules mempty{builtinRules = Map.singleton (typeRep k) $ BuiltinRule lint_ check_ run_ binary_ (Ver 0) callStackTop} --- | Change the priority of a given set of rules, where higher priorities take precedence.+-- | Change the priority of a given set of rules, where higher values 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:
src/Development/Shake/Internal/Core/Run.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE ConstraintKinds, TupleSections, ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeFamilies, NamedFieldPuns #-} module Development.Shake.Internal.Core.Run( RunState,@@ -60,7 +60,7 @@ data RunState = RunState {opts :: ShakeOptions- ,ruleinfo :: Map.HashMap TypeRep BuiltinRule+ ,builtinRules :: Map.HashMap TypeRep BuiltinRule ,userRules :: TMap.Map UserRuleVersioned ,database :: Database ,curdir :: FilePath@@ -73,18 +73,18 @@ open :: Cleanup -> ShakeOptions -> Rules () -> IO RunState open cleanup opts rs = withInit opts $ \opts@ShakeOptions{..} diagnostic _ -> do diagnostic $ return "Starting run"- (actions, ruleinfo, userRules, _targets) <- runRules opts rs+ SRules{actions, builtinRules, userRules} <- runRules opts rs diagnostic $ return $ "Number of actions = " ++ show (length actions)- diagnostic $ return $ "Number of builtin rules = " ++ show (Map.size ruleinfo) ++ " " ++ show (Map.keys ruleinfo)+ diagnostic $ return $ "Number of builtin rules = " ++ show (Map.size builtinRules) ++ " " ++ show (Map.keys builtinRules) diagnostic $ return $ "Number of user rule types = " ++ show (TMap.size userRules) diagnostic $ return $ "Number of user rules = " ++ show (sum (TMap.toList (userRuleSize . userRuleContents) userRules)) checkShakeExtra shakeExtra curdir <- getCurrentDirectory - database <- usingDatabase cleanup opts diagnostic ruleinfo- (shared, cloud) <- loadSharedCloud database opts ruleinfo+ database <- usingDatabase cleanup opts diagnostic builtinRules+ (shared, cloud) <- loadSharedCloud database opts builtinRules return RunState{..} @@ -94,7 +94,7 @@ modifyAllMem database f where f (Ready r) = Loaded (snd <$> r)- f (Error _ x) = maybe Missing Loaded x+ f (Failed _ x) = maybe Missing Loaded x f (Running _ x) = maybe Missing Loaded x -- shouldn't ever happen, but Loaded is least worst f x = x @@ -110,7 +110,7 @@ res <- withCleanup $ \cleanup -> do register cleanup $ do- when (shakeTimings && shakeVerbosity >= Normal) $+ when (shakeTimings && shakeVerbosity >= Info) $ writeIORef timingsToShow . Just =<< getTimings resetTimings @@ -141,7 +141,7 @@ addTiming "Running rules" locals <- newIORef [] runPool (shakeThreads == 1) shakeThreads $ \pool -> do- let global = Global applyKeyValue database pool cleanup start ruleinfo output opts diagnostic ruleFinished after absent getProgress userRules shared cloud step oneshot+ let global = Global applyKeyValue database pool cleanup start builtinRules output opts diagnostic ruleFinished after absent getProgress userRules shared cloud step oneshot -- give each action a stack to start with! forM_ (actions ++ map (emptyStack,) actions2) $ \(stack, act) -> do let local = newLocal stack shakeVerbosity@@ -156,26 +156,26 @@ locals <- readIORef locals end <- start if null actions && null actions2 then- putWhen Normal "Warning: No want/action statements, nothing to do"+ putWhen Info "Warning: No want/action statements, nothing to do" else recordRoot step locals end database when (isJust shakeLint) $ do addTiming "Lint checking" lintCurrentDirectory curdir "After completion"- checkValid diagnostic database (runLint ruleinfo) =<< readIORef absent- putWhen Loud "Lint checking succeeded"+ checkValid diagnostic database (runLint builtinRules) =<< readIORef absent+ putWhen Verbose "Lint checking succeeded" when (shakeReport /= []) $ do addTiming "Profile report" forM_ shakeReport $ \file -> do- putWhen Normal $ "Writing report to " ++ file+ putWhen Info $ "Writing report to " ++ file writeProfile file database when (shakeLiveFiles /= []) $ do addTiming "Listing live" diagnostic $ return "Listing live keys" xs <- liveFiles database forM_ shakeLiveFiles $ \file -> do- putWhen Normal $ "Writing live list to " ++ file+ putWhen Info $ "Writing live list to " ++ file (if file == "-" then putStr else writeFile file) $ unlines xs res <- readIORef after@@ -196,7 +196,7 @@ let n = show $ length after diagnostic $ return $ "Running " ++ n ++ " after actions" (time, _) <- duration $ sequence_ $ reverse after- when (shakeTimings && shakeVerbosity >= Normal) $+ when (shakeTimings && shakeVerbosity >= Info) $ putStrLn $ "(+ running " ++ show n ++ " after actions in " ++ showDuration time ++ ")" @@ -274,7 +274,7 @@ errorsState :: RunState -> IO [(String, SomeException)] errorsState RunState{..} = do status <- getKeyValues database- return [(show k, e) | (k, Error e _) <- status]+ return [(show k, e) | (k, Failed e _) <- status] checkValid :: (IO String -> IO ()) -> Database -> (Key -> Value -> IO (Maybe String)) -> [(Key, Key)] -> IO ()@@ -348,7 +348,7 @@ recordRoot :: Step -> [Local] -> Seconds -> Database -> IO () recordRoot step locals (doubleToFloat -> end) db = runLocked db $ do rootId <- mkId db rootKey- let local = localMergeMutable (newLocal emptyStack Normal) locals+ let local = localMergeMutable (newLocal emptyStack Info) locals let rootRes = Result {result = (newValue (), BS.empty) ,changed = step
src/Development/Shake/Internal/Core/Storage.hs view
@@ -196,7 +196,7 @@ t <- getCurrentTime appendFile (shakeFiles </> ".shake.storage.log") $ "\n[" ++ show t ++ "]: " ++ trimEnd x ++ "\n" outputErr x = do- when (shakeVerbosity >= Quiet) $ shakeOutput Quiet $ unlines x+ when (shakeVerbosity >= Warn) $ shakeOutput Warn $ unlines x unexpected $ unlines x
src/Development/Shake/Internal/Core/Types.hs view
@@ -49,7 +49,7 @@ import General.Cleanup import Prelude -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail #endif @@ -216,7 +216,7 @@ data Status = Ready (Result (Value, OneShot BS_Store)) -- ^ I have a value- | Error SomeException (OneShot (Maybe (Result BS_Store))) -- ^ I have been run and raised an error+ | Failed SomeException (OneShot (Maybe (Result BS_Store))) -- ^ I have been run and raised an error | Loaded (Result BS_Store) -- ^ Loaded from the database | Running (NoShow (Either SomeException (Result (Value, BS_Store)) -> Locked ())) (Maybe (Result BS_Store)) -- ^ Currently in the process of being checked or built | Missing -- ^ I am only here because I got into the Intern table@@ -225,7 +225,7 @@ instance NFData Status where rnf x = case x of Ready x -> rnf x- Error x y -> rnfException x `seq` rnf y+ Failed x y -> rnfException x `seq` rnf y Loaded x -> rnf x Running _ x -> rnf x -- Can't RNF a waiting, but also unnecessary Missing -> ()@@ -248,7 +248,7 @@ rnf (Result a _ _ b _ c) = rnf a `seq` rnf b `seq` rnf c statusType Ready{} = "Ready"-statusType Error{} = "Error"+statusType Failed{} = "Failed" statusType Loaded{} = "Loaded" statusType Running{} = "Running" statusType Missing{} = "Missing"@@ -411,7 +411,7 @@ ,globalShared :: Maybe Shared -- ^ The active shared state, if any ,globalCloud :: Maybe Cloud ,globalStep :: {-# UNPACK #-} !Step- ,globalOneShot :: Bool -- ^ I am running in one-shot mode so don't need to store BS's for Result/Error+ ,globalOneShot :: Bool -- ^ I am running in one-shot mode so don't need to store BS's for Result/Failed } -- local variables of Action
src/Development/Shake/Internal/Derived.hs view
@@ -90,7 +90,7 @@ copyFile' :: Partial => FilePath -> FilePath -> Action () copyFile' old new = do need [old]- putLoud $ "Copying from " ++ old ++ " to " ++ new+ putVerbose $ "Copying from " ++ old ++ " to " ++ new liftIO $ do createDirectoryRecursive $ takeDirectory new removeFile_ new -- symlink safety@@ -105,7 +105,7 @@ -- 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 &&^ IO.fileEq old new) $ do- putLoud $ "Copying from " ++ old ++ " to " ++ new+ putVerbose $ "Copying from " ++ old ++ " to " ++ new liftIO $ do createDirectoryRecursive $ takeDirectory new -- copyFile does a lot of clever stuff with permissions etc, so make sure we just reuse it@@ -172,7 +172,7 @@ -- -- @ -- 'withTempDir' $ \\mydir -> do--- 'putNormal' $ \"Temp directory is \" ++ mydir+-- 'putInfo' $ \"Temp directory is \" ++ mydir -- 'writeFile'' (mydir \</\> \"test.txt\") \"writing out a temp file\" -- @ withTempDir :: (FilePath -> Action a) -> Action a
src/Development/Shake/Internal/Errors.hs view
@@ -128,7 +128,7 @@ -- | 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.+ {shakeExceptionTarget :: String -- ^ The target that was being built when the exception occurred. ,shakeExceptionStack :: [String] -- ^ A description of the call stack, one entry per line. ,shakeExceptionInner :: SomeException -- ^ The underlying exception that was raised. }
src/Development/Shake/Internal/History/Cloud.hs view
@@ -38,7 +38,7 @@ _ -> def return fence -laterFence :: (Applicative m, MonadIO m) => Fence m a -> Wait m a+laterFence :: MonadIO m => Fence m a -> Wait m a laterFence fence = do res <- liftIO $ testFence fence case res of
@@ -3,7 +3,8 @@ module Development.Shake.Internal.History.Shared( Shared, newShared, addShared, lookupShared,- removeShared, listShared+ removeShared, listShared,+ sanityShared ) where import Control.Exception@@ -105,7 +106,7 @@ return $ if valid then Just e else Nothing --- | Given a way to get the identity, see if you can a stored cloud version+-- | Given a way to get the identity, see if you can find a stored cloud version lookupShared :: Shared -> (Key -> Wait Locked (Maybe BS_Identity)) -> Key -> Ver -> Ver -> Wait Locked (Maybe (BS_Store, [[Key]], IO ())) lookupShared shared ask key builtinVersion userVersion = do ents <- liftIO $ loadSharedEntry shared key builtinVersion userVersion@@ -130,12 +131,13 @@ saveSharedEntry shared entry = do let dir = sharedFileDir shared (entryKey entry) createDirectoryRecursive dir- let v = runBuilder $ putEntry (keyOp shared) entry- createDirectoryRecursive $ dir </> "_key"- BS.writeFile (dir </> "_key" </> hexed v) v forM_ (entryFiles entry) $ \(file, hash) -> unlessM (doesFileExist_ $ dir </> show hash) $ copyFileLink (useSymlink shared) file (dir </> show hash)+ -- Write key after files to make sure cache is always useable+ let v = runBuilder $ putEntry (keyOp shared) entry+ createDirectoryRecursive $ dir </> "_key"+ BS.writeFile (dir </> "_key" </> hexed v) v addShared :: Shared -> Key -> Ver -> Ver -> [[(Key, BS_Identity)]] -> BS_Store -> [FilePath] -> IO ()@@ -167,3 +169,27 @@ putStrLn $ " Key: " ++ show entryKey forM_ entryFiles $ \(file,_) -> putStrLn $ " File: " ++ file++sanityShared :: Shared -> IO ()+sanityShared Shared{..} = do+ dirs <- listDirectories $ sharedRoot </> ".shake.cache"+ forM_ dirs $ \dir -> do+ putStrLn $ "Directory: " ++ dir+ keys <- sharedFileKeys dir+ forM_ keys $ \key ->+ handleSynchronous (\e -> putStrLn $ "Warning: " ++ show e) $ do+ Entry{..} <- getEntry keyOp <$> BS.readFile key+ putStrLn $ " Key: " ++ show entryKey+ putStrLn $ " Key file: " ++ key+ forM_ entryFiles $ \(file,hash) ->+ checkFile file dir hash+ where+ checkFile filename dir keyHash = do+ let cachefile = dir </> show keyHash+ putStrLn $ " File: " ++ filename+ putStrLn $ " Cache file: " ++ cachefile+ ifM (not <$> doesFileExist_ cachefile)+ (putStrLn " Error: cache file does not exist") $+ ifM ((/= keyHash) <$> getFileHash (fileNameFromString cachefile))+ (putStrLn " Error: cache file hash does not match stored hash")+ (putStrLn " OK")
src/Development/Shake/Internal/History/Symlink.hs view
@@ -49,7 +49,7 @@ b <- createLinkMaybe from to whenJust b $ \_ -> copyFile from to- -- making files read only stops them from inadvertantly mutating the cache+ -- making files read only stops them from inadvertently mutating the cache forM_ [from, to] $ \x -> do perm <- getPermissions x setPermissions x perm{writable=False}
src/Development/Shake/Internal/Options.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable, PatternGuards #-}+{-# LANGUAGE CPP, DeriveDataTypeable, PatternGuards #-} -- | Types exposed to the user module Development.Shake.Internal.Options(@@ -150,7 +150,7 @@ -- 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.+ -- ^ Defaults to 'Info'. 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@.@@ -206,7 +206,10 @@ ,shakeCloud :: [String] -- ^ Defaults to @[]@. Cloud servers to talk to forming a shared cache. ,shakeSymlink :: Bool- -- ^ Defaults to @True@. Use symlinks if they are available.+ -- ^ Defaults to @False@. Use symlinks for 'shakeShare' if they are available.+ -- If this setting is @True@ (even if symlinks are not available) then files will be+ -- made read-only to avoid inadvertantly poisoning the shared cache.+ -- Note the links are actually hard links, not symlinks. ,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.@@ -230,8 +233,8 @@ -- | 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 Nothing [] True+ ".shake" 1 "1" Info False [] Nothing [] [] [] [] (Just 10) [] [] False True False+ True ChangeModtime True [] False False Nothing [] False (const $ return ()) (const $ BS.putStrLn . UTF8.fromString) -- try and output atomically using BS (\_ _ _ -> return ())@@ -301,11 +304,12 @@ -- | 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.+ = Silent -- ^ Don't print any messages.+ | Error -- ^ Only print error messages.+ | Warn -- ^ Print errors and warnings.+ | Info -- ^ Print errors, warnings and @# /command-name/ (for /file-name/)@ when running a 'Development.Shake.traced' command.+ | Verbose -- ^ Print errors, warnings, full command lines when running a 'Development.Shake.command' or+ -- 'Development.Shake.cmd' command 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)
src/Development/Shake/Internal/Paths.hs view
@@ -1,4 +1,9 @@+{-# LANGUAGE CPP #-} +#ifdef FILE_EMBED+{-# LANGUAGE TemplateHaskell #-}+#endif+ -- | The information from Paths_shake cleaned up module Development.Shake.Internal.Paths( shakeVersionString,@@ -7,23 +12,58 @@ readDataFileHTML ) where -import Paths_shake-import Control.Exception import Control.Monad.Extra import Data.Version-import System.Directory import System.FilePath-import System.Info.Extra-import System.IO.Unsafe-import System.Environment import General.Extra import qualified Data.ByteString.Lazy as LBS+import Paths_shake +#ifdef FILE_EMBED+import qualified Data.ByteString as BS+import Data.FileEmbed+#else+import Control.Exception+import System.Directory+import System.Info.Extra+import System.IO.Unsafe+import System.Environment+#endif shakeVersionString :: String shakeVersionString = showVersion version +#ifdef FILE_EMBED +initDataDirectory :: IO ()+initDataDirectory = return ()++htmlDataFiles :: [(FilePath, BS.ByteString)]+htmlDataFiles =+ [ ("profile.html", $(embedFile "html/profile.html"))+ , ("progress.html", $(embedFile "html/progress.html"))+ , ("shake.js", $(embedFile "html/shake.js"))+ ]++readDataFileHTML :: FilePath -> IO LBS.ByteString+readDataFileHTML file = do+ case lookup file htmlDataFiles of+ Nothing -> fail $ "Could not find data file " ++ file ++ " in embedded data files!"+ Just x -> return (LBS.fromStrict x)++manualDirData :: [(FilePath, BS.ByteString)]+manualDirData = $(embedDir "docs/manual")++hasManualData :: IO Bool+hasManualData = return True++copyManualData :: FilePath -> IO ()+copyManualData dest = do+ createDirectoryRecursive dest+ forM_ manualDirData $ \(file, bs) -> do+ BS.writeFile (dest </> file) bs++#else -- We want getDataFileName to be relative to the current directory on program startup, -- even if we issue a change directory command. Therefore, first call caches, future ones read. {-# NOINLINE dataDirs #-}@@ -34,12 +74,10 @@ curdir <- getCurrentDirectory return $ [datdir] ++ [exedir | exedir /= ""] ++ [curdir] - -- The data files may be located relative to the current directory, if so cache it in advance initDataDirectory :: IO () initDataDirectory = void $ evaluate dataDirs - getDataFile :: FilePath -> IO FilePath getDataFile file = do let poss = map (</> file) dataDirs@@ -51,13 +89,11 @@ hasDataFile :: FilePath -> IO Bool hasDataFile file = anyM (\dir -> doesFileExist_ $ dir </> file) dataDirs - readDataFileHTML :: FilePath -> IO LBS.ByteString readDataFileHTML file = LBS.readFile =<< getDataFile ("html" </> file) - manualFiles :: [FilePath]-manualFiles = map ("docs/manual" </>) ["Build.hs","main.c","constants.c","constants.h","build" <.> if isWindows then "bat" else "sh"]+manualFiles = map ("docs/manual" </>) ["Shakefile.hs","main.c","constants.c","constants.h","build" <.> if isWindows then "bat" else "sh"] hasManualData :: IO Bool hasManualData = allM hasDataFile manualFiles@@ -68,3 +104,4 @@ forM_ manualFiles $ \file -> do src <- getDataFile file copyFile src (dest </> takeFileName file)+#endif
src/Development/Shake/Internal/Rules/Directory.hs view
@@ -5,12 +5,13 @@ module Development.Shake.Internal.Rules.Directory( doesFileExist, doesDirectoryExist, getDirectoryContents, getDirectoryFiles, getDirectoryDirs,- getEnv, getEnvWithDefault,+ getEnv, getEnvWithDefault, getEnvError, removeFiles, removeFilesAfter, getDirectoryFilesIO, defaultRuleDirectory ) where +import Control.Exception.Extra import Control.Monad.Extra import Control.Monad.IO.Class import Data.Maybe@@ -181,6 +182,10 @@ getEnvWithDefault :: String -> String -> Action String getEnvWithDefault def var = fromMaybe def <$> getEnv var +-- | A partial variant of 'getEnv' that returns the environment variable variable or fails.+getEnvError :: Partial => String -> Action String+getEnvError name = getEnvWithDefault (error $ "getEnvError: Environment variable " ++ name ++ " is undefined") name+ -- | 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.@@ -322,5 +327,5 @@ -- Where possible, delete the files as a normal part of the build, e.g. using @'liftIO' $ 'removeFiles' dir pats@. removeFilesAfter :: FilePath -> [FilePattern] -> Action () removeFilesAfter a b = do- putLoud $ "Will remove " ++ unwords b ++ " from " ++ a+ putVerbose $ "Will remove " ++ unwords b ++ " from " ++ a runAfter $ removeFiles a b
src/Development/Shake/Internal/Rules/File.hs view
@@ -215,7 +215,7 @@ (ruleVer, ruleAct, ruleErr) <- getUserRuleInternal o (\(FileRule s _) -> Just s) $ \(FileRule _ f) -> f xStr let verEq v = Just v == ruleVer || case ruleAct of [] -> v == Ver 0; [(v2,_)] -> v == Ver v2; _ -> False let rebuild = do- putWhen Chatty $ "# " ++ show o+ putWhen Verbose $ "# " ++ show o case ruleAct of [] -> rebuildWith Nothing [x] -> rebuildWith $ Just x@@ -457,14 +457,14 @@ tracker $ map (FileQ . fileNameFromString) ys --- | Track that a file was read by the action preceeding it. If 'shakeLint' is activated+-- | Track that a file was read by the action preceding 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 = track lintTrackRead --- | Track that a file was written by the action preceeding it. If 'shakeLint' is activated+-- | Track that a file was written by the action preceding 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 ()
src/Development/Shake/Internal/Rules/Files.hs view
@@ -96,7 +96,7 @@ (ruleVer, ruleAct, ruleErr) <- getUserRuleInternal k (\(FilesRule s _) -> Just s) $ \(FilesRule _ f) -> f k let verEq v = Just v == ruleVer || map (Ver . fst) ruleAct == [v] let rebuild = do- putWhen Chatty $ "# " ++ show k+ putWhen Verbose $ "# " ++ show k case ruleAct of [x] -> rebuildWith x _ -> throwM ruleErr
src/Development/Shake/Internal/Rules/Oracle.hs view
@@ -82,7 +82,7 @@ -- 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+-- 'addOracle' $ \\(GhcVersion _) -> 'Development.Shake.fromStdout' \<$\> 'Development.Shake.cmd' \"ghc --numeric-version\" :: Action String -- ... rules ... -- @ --
src/General/Binary.hs view
@@ -35,7 +35,7 @@ ,getOp :: BS.ByteString -> v } -binaryOpMap :: (Eq a, Hashable a, BinaryEx a) => (a -> BinaryOp b) -> BinaryOp (a, b)+binaryOpMap :: BinaryEx a => (a -> BinaryOp b) -> BinaryOp (a, b) binaryOpMap mp = BinaryOp {putOp = \(a, b) -> putExN (putEx a) <> putOp (mp a) b ,getOp = \bs -> let (bs1,bs2) = getExN bs; a = getEx bs1 in (a, getOp (mp a) bs2)
src/General/Process.hs view
@@ -71,6 +71,7 @@ ,poStdout :: [Destination] ,poStderr :: [Destination] ,poAsync :: Bool+ ,poCloseFds :: Bool } @@ -152,7 +153,7 @@ let outFiles = nubOrd [x | DestFile x <- poStdout ++ poStderr] let inFiles = nubOrd [x | SrcFile x <- poStdin] withFiles WriteMode outFiles $ \outHandle -> withFiles ReadMode inFiles $ \inHandle -> do- let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = True, close_fds = True+ let cp = (cmdSpec poCommand){cwd = poCwd, env = poEnv, create_group = True, close_fds = poCloseFds ,std_in = fst $ stdIn inHandle poStdin ,std_out = stdStream outHandle poStdout poStderr, std_err = stdStream outHandle poStderr poStdout} withCreateProcessCompat cp $ \inh outh errh pid ->
src/General/Template.hs view
@@ -1,5 +1,10 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} +#ifdef FILE_EMBED+{-# LANGUAGE TemplateHaskell #-}+#endif+ module General.Template(runTemplate) where import System.FilePath.Posix@@ -13,12 +18,26 @@ import qualified Language.Javascript.Flot as Flot import qualified Language.Javascript.JQuery as JQuery +#ifdef FILE_EMBED+import Data.FileEmbed+import Language.Haskell.TH.Syntax ( runIO )+#endif +{- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion++-- Very hard to abstract over TH, so we do it with CPP+#ifdef FILE_EMBED+#define FILE(x) (return (LBS.fromStrict $(embedFile =<< runIO (x))))+#else+#define FILE(x) (LBS.readFile =<< (x))+#endif++libraries :: [(String, IO LBS.ByteString)] libraries =- [("jquery.js", JQuery.file)- ,("jquery.dgtable.js", DGTable.file)- ,("jquery.flot.js", Flot.file Flot.Flot)- ,("jquery.flot.stack.js", Flot.file Flot.FlotStack)+ [("jquery.js", FILE(JQuery.file))+ ,("jquery.dgtable.js", FILE(DGTable.file))+ ,("jquery.flot.js", FILE(Flot.file Flot.Flot))+ ,("jquery.flot.stack.js", FILE(Flot.file Flot.FlotStack)) ] @@ -40,9 +59,11 @@ y = LBS.dropWhile isSpace x grab = asker . takeWhile (/= '\"') . LBS.unpack - asker o@(splitFileName -> ("lib/",x)) = case lookup x libraries of- Just act -> LBS.readFile =<< act- Nothing -> errorIO $ "Template library, unknown library: " ++ o+ asker o@(splitFileName -> ("lib/",x)) =+ case lookup x libraries of+ Nothing -> errorIO $ "Template library, unknown library: " ++ o+ Just act -> act+ asker "shake.js" = readDataFileHTML "shake.js" asker "data/metadata.js" = do time <- getCurrentTime@@ -50,7 +71,6 @@ "var version = " ++ show shakeVersionString ++ "\nvar generated = " ++ show (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) time) asker x = ask x- -- Perform a mapM on each line and put the result back together again lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString
src/General/Wait.hs view
@@ -13,7 +13,7 @@ import Data.Primitive.Array import GHC.Exts(RealWorld) -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail #endif @@ -58,10 +58,14 @@ instance (MonadIO m, Applicative m) => MonadIO (Wait m) where liftIO = Lift . liftIO . fmap Now -#if __GLASGOW_HASKELL__ >= 800+#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 808 instance MonadFail m => MonadFail (Wait m) where fail = Lift . Control.Monad.Fail.fail #endif+#if __GLASGOW_HASKELL__ >= 808+instance MonadFail m => MonadFail (Wait m) where+ fail = Lift . Prelude.fail+#endif firstJustWaitUnordered :: MonadIO m => (a -> Wait m (Maybe b)) -> [a] -> Wait m (Maybe b)@@ -91,7 +95,7 @@ when (old == 1) $ callback Nothing -firstLeftWaitUnordered :: (Applicative m, MonadIO m) => (a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b])+firstLeftWaitUnordered :: MonadIO m => (a -> Wait m (Either e b)) -> [a] -> Wait m (Either e [b]) firstLeftWaitUnordered f xs = do let n = length xs mut <- liftIO $ newArray n undefined@@ -101,7 +105,7 @@ Nothing -> liftIO $ Right <$> mapM (readArray mut) [0..n-1] where -- keep a list of those things we might visit later, and ask for each we see in turn- go :: (Applicative m, MonadIO m) => MutableArray RealWorld b -> [(Int, (Either e b -> m ()) -> m ())] -> [(Int, Wait m (Either e b))] -> Wait m (Maybe e)+ go :: MonadIO m => MutableArray RealWorld b -> [(Int, (Either e b -> m ()) -> m ())] -> [(Int, Wait m (Either e b))] -> Wait m (Maybe e) go mut later ((i,x):xs) = case x of Now (Left e) -> Now $ Just e Now (Right b) -> do
src/Run.hs view
@@ -30,7 +30,7 @@ e <- rawSystem prog args when (e /= ExitSuccess) $ exitWith e Nothing -> do- let go = shakeArgsWith shakeOptions{shakeCreationCheck=False} flags $ \opts targets -> do+ let go = shakeArgsWith shakeOptions{shakeThreads=0,shakeCreationCheck=False} flags $ \opts targets -> do let tool = listToMaybe [x | Tool x <- opts] makefile <- case reverse [x | UseMakefile x <- opts] of x:_ -> return x
src/Test.hs view
@@ -20,6 +20,7 @@ import qualified Test.C import qualified Test.Cache import qualified Test.Cleanup+import qualified Test.CloseFileHandles import qualified Test.Command import qualified Test.Config import qualified Test.Database@@ -48,7 +49,7 @@ import qualified Test.Progress import qualified Test.Random import qualified Test.Rebuild-import qualified Test.Deprioritize+import qualified Test.Reschedule import qualified Test.Resources import qualified Test.Self import qualified Test.SelfMake@@ -75,10 +76,10 @@ ,"c" * Test.C.main ,"cache" * Test.Cache.main ,"cleanup" * Test.Cleanup.main+ ,"closefilehandles" * Test.CloseFileHandles.main ,"command" * Test.Command.main ,"config" * Test.Config.main ,"database" * Test.Database.main- ,"deprioritize" * Test.Deprioritize.main ,"digest" * Test.Digest.main ,"directory" * Test.Directory.main ,"docs" * Test.Docs.main@@ -104,6 +105,7 @@ ,"progress" * Test.Progress.main ,"random" * Test.Random.main ,"rebuild" * Test.Rebuild.main+ ,"reschedule" * Test.Reschedule.main ,"resources" * Test.Resources.main ,"self" * Test.Self.main ,"selfmake" * Test.SelfMake.main
src/Test/Basic.hs view
@@ -58,7 +58,7 @@ phony "options" $ do opts <- getShakeOptions- putNormal $ show opts+ putInfo $ show opts "dummer.txt" %> \out -> do need ["dummy","dummy"]
src/Test/Batch.hs view
@@ -15,7 +15,7 @@ batch 3 ("*.out" %>) (\out -> do need [inp out]; return out) $ \outs -> do liftIO $ assertBool (length outs <= 3) "length outs <= 3" withResource file 1 $ liftIO $ appendFile "log.txt" $ show (length outs) ++ "\n"- putNormal $ "Building batch: " ++ unwords outs+ putInfo $ "Building batch: " ++ unwords outs forM_ outs $ \out -> liftIO $ copyFile (inp out) out want [show i <.> "out" | i <- [1..6]]
+ src/Test/CloseFileHandles.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP #-}+module Test.CloseFileHandles(main) where++import Test.Type++#ifdef mingw32_HOST_OS++main = testNone -- don't know how to do this on windows++#else++import Development.Shake+import Development.Shake.FilePath+import System.Posix.IO+import Control.Monad.Extra+import System.Exit+import System.IO++main = testBuild test $ do+ let helper = toNative $ "helper/close_file_handles_helper" <.> exe+ let name !> test = do want [name]+ name ~> do need ["helper/close_file_handles_helper" <.> exe]; test++ let helper_source = unlines+ ["import System.Environment"+ ,"import System.Posix.IO"+ ,"import System.IO"+ ,"import System.Exit"+ ,""+ ,"main = do"+ ," args <- getArgs"+ ," case args of"+ ," [fdString] -> do"+ ," handle <- fdToHandle (read fdString)"+ ," hClose handle"+ ," exitSuccess"+ ," _ -> do"+ ," progName <- getProgName"+ ," hPutStrLn stderr (\"usage: \" ++ progName ++ \" <file descriptor number>\\n tries closing the file descriptor number\\n exits successful, if the file descriptor was open\")"+ ," exitWith (ExitFailure 3)"]++ "close_file_handles_helper.hs" %> \out -> do+ need ["../../src/Test/CloseFileHandles.hs"]+ writeFileChanged out helper_source++ ["helper/close_file_handles_helper"<.>exe, "close_file_handles_helper.hi", "close_file_handles_helper.o"] &%> \_ -> do+ need ["close_file_handles_helper.hs"]+ cmd "ghc --make" "close_file_handles_helper.hs -o helper/close_file_handles_helper"++ let callWithOpenFile cmdWithOpts = withTempFile $+ \file -> actionBracket (openFile file AppendMode) hClose $+ \h -> do fd <- liftIO $ handleToFd h+ (Exit c, Stdout _, Stderr _) <- cmdWithOpts helper (show fd) :: Action (Exit, Stdout String, Stderr String)+ return c++ "defaultbehaviour" !> do+ c <- callWithOpenFile cmd+ liftIO $ assertBool (c == ExitSuccess) "handle closed without option CloseFileHandles"++ "closing" !> do+ c <- callWithOpenFile (cmd CloseFileHandles)+ liftIO $ assertBool (c /= ExitSuccess) "handle not closed with option CloseFileHandles"++test build = do+ whenM hasTracker $+ build ["-j4", "--no-lint"]+ build ["-j4"]++#endif
src/Test/Command.hs view
@@ -89,7 +89,7 @@ offset <- liftIO offsetTime act t <- liftIO offset- putNormal $ "Timed out in " ++ showDuration t+ putInfo $ "Timed out in " ++ showDuration t when (t < 2 || t > 8) $ error $ "failed to timeout, took " ++ show t "timeout1" !> checkTimeout (do
− src/Test/Deprioritize.hs
@@ -1,27 +0,0 @@--module Test.Deprioritize(main) where--import Development.Shake-import Test.Type---main = testBuild test $ do- file <- newResource "log.txt" 1- let log x = withResource file 1 $ liftIO $ appendFile "log.txt" x- "*.p0" %> \out -> do- log "0"- writeFile' out ""- "*.p1" %> \out -> do- deprioritize 1- log "1"- writeFile' out ""- "*.p2" %> \out -> do- deprioritize 2- log "2"- writeFile' out ""---test build = do- build ["clean"]- build ["foo.p1","bar.p1","baz.p0","qux.p2"]- assertContents "log.txt" "0211"
src/Test/Docs.hs view
@@ -9,18 +9,19 @@ import Test.Type import Control.Monad import Data.Char-import General.Extra import Data.List.Extra import Data.Maybe import System.Info import Data.Version.Extra --- Older versions of Haddock garbage the --@ markup and have ambiguity errors-brokenHaddock = compilerVersion < makeVersion [8]+-- Older versions of Haddock (GHC 7.10 and below) garbage the --@ markup and have ambiguity errors+-- GHC 8.0 has a segfault when linking Setup+brokenHaddock = compilerVersion < makeVersion [8,2] main = testBuild (unless brokenHaddock . defaultTest) $ do let index = "dist/doc/html/shake/index.html"+ let setup = "dist/setup.exe" let config = "dist/setup-config" want ["Success.txt"] let trackIgnore = trackAllow ["dist/**"]@@ -28,18 +29,33 @@ let needSource = need =<< getDirectoryFiles "." (map (shakeRoot </>) ["src/Development/Shake.hs","src/Development/Shake//*.hs","src/Development/Ninja/*.hs","src/General//*.hs"]) - config %> \_ -> do+ let runSetup :: [String] -> Action ()+ runSetup args = do+ trackIgnore+ need [setup]+ -- Make Cabal and Stack play nicely with GHC_PACKAGE_PATH+ setup <- liftIO $ canonicalizePath setup+ cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) setup args++ setup %> \_ -> do+ -- Important to compile the setup binary, or we run foul of+ -- https://gitlab.haskell.org/ghc/ghc/issues/17575 trackIgnore- need $ map (shakeRoot </>) ["shake.cabal","Setup.hs"]- -- Make Cabal and Stack play nicely+ need [shakeRoot </> "Setup.hs"]+ setup <- liftIO $ canonicalizePath setup+ curdir <- liftIO $ canonicalizePath "dist"+ cmd_ (Cwd shakeRoot) "ghc -package=Cabal Setup.hs -o" [setup] "-outputdir" [curdir]++ config %> \_ -> do path <- getEnv "GHC_PACKAGE_PATH"- liftIO $ createDirectoryRecursive "dist" dist <- liftIO $ canonicalizePath "dist" -- make sure it works even if we cwd- cmd_ (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) "runhaskell -package=Cabal Setup.hs configure"- ["--builddir=" ++ dist,"--user"]+ need [shakeRoot </> "shake.cabal"]+ runSetup $+ ["configure","--builddir=" ++ dist,"--user"] ++ -- package-db is very sensitive, see #267 -- note that the reverse ensures the behaviour is consistent between the flags and the env variable ["--package-db=" ++ x | x <- maybe [] (reverse . filter (`notElem` [".",""]) . splitSearchPath) path]+ -- Paths_shake is only created by "Setup build" (which we want to skip), and required by "Setup haddock", so we fake it copyFile' (shakeRoot </> "src/Paths.hs") "dist/build/autogen/Paths_shake.hs" copyFile' (shakeRoot </> "src/Paths.hs") "dist/build/shake/autogen/Paths_shake.hs"@@ -51,7 +67,7 @@ needSource trackIgnore dist <- liftIO $ canonicalizePath "dist"- cmd (RemEnv "GHC_PACKAGE_PATH") (Cwd shakeRoot) "runhaskell -package=Cabal Setup.hs haddock" ["--builddir=" ++ dist]+ runSetup ["haddock", "--builddir=" ++ dist] "Part_*.hs" %> \out -> do need [shakeRoot </> "src/Test/Docs.hs"] -- so much of the generator is in this module@@ -161,7 +177,7 @@ writeFileLines out $ ["module Main(main) where"] ++ ["import " ++ m ++ "()" | m <- mods] ++ ["main = return ()"] "Success.txt" %> \out -> do- putNormal . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst"+ putInfo . ("Checking documentation for:\n" ++) =<< readFile' "Files.lst" needModules need ["Main.hs"] trackIgnore@@ -347,7 +363,7 @@ "@ndm_haskell file-name .PHONY filepath trim base stack extra #include " ++ "*> BuiltinRun BuiltinLint BuiltinIdentity RuleResult " ++ "oldStore mode node_modules llbuild Makefile " ++- "RebuildNever"+ "RebuildNever RLIMIT_NOFILE " = True whitelist x = x `elem` ["[Foo.hi, Foo.o]"@@ -371,6 +387,7 @@ ,"$(LitE . StringL . loc_filename <$> location)" ,"-d[ FILE], --debug[=FILE]" ,"-r[ FILE], --report[=FILE], --profile[=FILE]"+ ,"man 2 getrlimit" ] blacklist :: [String]
src/Test/Errors.hs view
@@ -179,6 +179,8 @@ liftIO $ putStrLn $ let x = x in x test build = do+ let hasLocations = compilerVersion >= readVersion "8.0" -- when GHC got support for locations+ -- on Windows, file paths may end up with \ separators, make sure we can still match them let crash args parts = assertExceptionAfter (replace "\\" "/") parts (build $ "--quiet" : args) build ["clean"]@@ -193,7 +195,7 @@ crash ["failcreates"] ["failcreates"] crash ["recursive_"] ["recursive_","intermediate_","recursive"] crash ["rec1","rec2"] ["rec1","rec2","indirect recursion","recursive"]- crash ["systemcmd"] ["systemcmd","random_missing_command"]+ crash ["systemcmd"] $ ["systemcmd","random_missing_command"] ++ ["at cmd, called at" | hasLocations] crash ["stack1"] ["stack1","stack2","stack3","crash"] b <- IO.doesFileExist "staunch1"@@ -230,15 +232,14 @@ assertContents "overlap.txt" "overlap.txt" crash ["overlap.txx"] $ ["key matches multiple rules","matched: 4","overlap.txx","overlap.t*","overlap.*","*.tox"] ++- ["Test/Errors.hs" | compilerVersion >= readVersion "8.0"] -- when GHC got support for locations+ ["Test/Errors.hs" | hasLocations] crash ["tempfile"] ["tempfile-died"] src <- readFile "tempfile" assertMissing src build ["tempdir"] - crash ["--die"] $ ["Shake","death error"] ++- ["Test/Errors.hs" | compilerVersion >= readVersion "8.0"] -- when GHC got support for locations+ crash ["--die"] $ ["Shake","death error"] ++ ["Test/Errors.hs" | hasLocations] putStrLn "## BUILD errors" (out,_) <- IO.captureOutput $ build []@@ -294,6 +295,6 @@ assertContents "finalfinal" "XY" build ["catch1"]- assertContents "catch1" "magic1"+ assertContentsInfix "catch1" "magic1" crash ["catch2"] [show ThreadKilled] crash ["catch3.2"] ["magic3"]
src/Test/FileLock.hs view
@@ -13,12 +13,13 @@ main = testBuild test $ action $ do- putNormal "Starting sleep"+ putInfo "Starting sleep" liftIO $ sleep 5- putNormal "Finished sleep"+ putInfo "Finished sleep" -- Disabled under Mac because it fails, see #560+-- Reported as working locally under APFS, so may just be the older HFS+ as used by Travis CI test build = unless isMac $ do -- check it fails exactly once time <- offsetTime
src/Test/Forward.hs view
@@ -1,21 +1,65 @@ module Test.Forward(main) where +import Data.Char+import Data.List.Extra import Development.Shake+import System.Info.Extra import Development.Shake.Forward import Development.Shake.FilePath import Test.Type+import System.IO.Extra as IO + main = testBuild test $ forwardRule $ do- let src = shakeRoot </> "src/Test/C"- cs <- getDirectoryFiles src ["*.c"]+ cs <- getDirectoryFiles "" ["*.c"] os <- forP cs $ \c -> do let o = c <.> "o"- cache $ cmd "gcc -c" [src </> c] "-o" [o]+ cache $ cmd "gcc -c" [c] "-o" [o] return o cache $ cmd "gcc -o" ["Main" <.> exe] os+ cache $ cmd ["." </> "Main" <.> exe] (FileStdout "output.txt") -test build = do+ -- Doing this way to test cacheAction with arguments+ -- any real code should use a tracked readFile and avoid passing arguments to the closure+ src <- liftIO $ IO.readFile' "output.txt"+ cacheActionWith "reducer" src $ writeFile' "out.txt" $ filter isUpper src+++checkVaild act = do b <- hasTracker- build $ "--clean" : ["--forward" | b]- build $ "-j2" : ["--forward" | b]+ if not b then+ putStrLn "Warning: Not running forward test (no tracker)"+ else if isMac then+ putStrLn "Warning: Not running forward test (doesn't work on Mac)"+ else+ act++test build = checkVaild $ do+ -- first clean then copy the source files over+ build ["clean"]+ copyDirectoryChanged (shakeRoot </> "src/Test/C") "."++ -- build and rebuild+ build ["--forward"]+ assertContents "output.txt" "Hello Shake Users!\n"+ assertContents "out.txt" "HSU"++ -- check that cacheAction doesn't rerun when it shouldn't+ writeFile "out.txt" "HHH"+ build ["-j2","--forward"]+ assertContents "output.txt" "Hello Shake Users!\n"+ assertContents "out.txt" "HHH"++ -- modify the constants+ orig <- IO.readFile' "constants.c"+ writeFile "constants.c" $ replace "Shake" "Rattle" orig+ build ["-j2","--forward"]+ assertContents "output.txt" "Hello Rattle Users!\n"+ assertContents "out.txt" "HRU"++ -- put it back+ writeFile "constants.c" orig+ build ["-j2","--forward"]+ assertContents "output.txt" "Hello Shake Users!\n"+ assertContents "out.txt" "HSU"
+ src/Test/Reschedule.hs view
@@ -0,0 +1,27 @@++module Test.Reschedule(main) where++import Development.Shake+import Test.Type+++main = testBuild test $ do+ file <- newResource "log.txt" 1+ let log x = withResource file 1 $ liftIO $ appendFile "log.txt" x+ "*.p0" %> \out -> do+ log "0"+ writeFile' out ""+ "*.p1" %> \out -> do+ reschedule 1+ log "1"+ writeFile' out ""+ "*.p2" %> \out -> do+ reschedule 2+ log "2"+ writeFile' out ""+++test build = do+ build ["clean"]+ build ["foo.p1","bar.p1","baz.p0","qux.p2"]+ assertContents "log.txt" "0211"
src/Test/Targets.hs view
@@ -1,12 +1,15 @@ module Test.Targets(main) where import Development.Shake+import Development.Shake.Internal.Core.Rules (getHelpSuffix) import Test.Type main :: IO () -> IO () main _sleeper = do targets <- getTargets shakeOptions rules targets === expected+ helpSuffix <- getHelpSuffix shakeOptions rules+ helpSuffix === ["Don't Panic", "Know where your towel is"] rules :: Rules () rules = do@@ -26,6 +29,9 @@ withTargetDocs "awesome files" $ ["file12", "file13"] &%> \_ -> return () phony "Foo" $ return () withoutTargets $ phony "Bar" $ return ()++ addHelpSuffix "Don't Panic"+ addHelpSuffix "Know where your towel is" expected :: [(String, Maybe String)]
src/Test/Type.hs view
@@ -2,13 +2,13 @@ module Test.Type( sleep, sleepFileTime, sleepFileTimeCalibrate,- testBuildArgs, testBuild, testSimple,+ testBuildArgs, testBuild, testSimple, testNone, shakeRoot, defaultTest, hasTracker, copyDirectoryChanged, copyFileChangedIO, assertWithin, assertBool, assertBoolIO, assertException, assertExceptionAfter,- assertContents, assertContentsUnordered, assertContentsWords,+ assertContents, assertContentsUnordered, assertContentsWords, assertContentsInfix, assertExists, assertMissing, (===), (&?%>),@@ -58,6 +58,8 @@ testSimple :: IO () -> IO () -> IO () testSimple act = testBuild (const act) (return ()) +testNone :: IO () -> IO ()+testNone _ = return () shakenEx :: Bool@@ -97,13 +99,13 @@ 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+ shake shakeOptions{shakeFiles=out, shakeThreads=threads, shakeVerbosity=Error} $ rules [] args args -> change $ do t <- tracker opts <- return shakeOptions{shakeFiles = "."} cwd <- getCurrentDirectory- opts <- return $ if forward then forwardOptions opts else opts+ opts <- return $ if forward then forwardOptions opts{shakeLintInside=[""]} else opts {shakeLint = Just t ,shakeLintInside = [cwd </> ".." </> ".."] ,shakeLintIgnore = [".cabal-sandbox/**",".stack-work/**","../../.stack-work/**"]}@@ -121,7 +123,7 @@ if "clean" `elem` files then clean >> return Nothing else return $ Just $ (,) so $ do- -- if you have passed sleep, supress the "no actions" warning+ -- if you have passed sleep, suppress the "no actions" warning when (Sleep `elem` extra1) $ action $ return () rules extra2 files @@ -190,6 +192,11 @@ assertContents file want = do got <- IO.readFile' file assertBool (want == got) $ "File contents are wrong: " ++ file ++ "\nWANT: " ++ want ++ "\nGOT: " ++ got++assertContentsInfix :: FilePath -> String -> IO ()+assertContentsInfix file want = do+ got <- IO.readFile' file+ assertBool (want `isInfixOf` got) $ "File contents are wrong: " ++ file ++ "\nWANT (infix): " ++ want ++ "\nGOT: " ++ got assertContentsOn :: (String -> String) -> FilePath -> String -> IO () assertContentsOn f file want = do
src/Test/Unicode.hs view
@@ -5,8 +5,8 @@ import Development.Shake.FilePath import Test.Type import General.GetOpt-import Control.Exception.Extra import Control.Monad+import GHC.IO.Encoding -- | Decode a dull ASCII string to certain unicode points, necessary because@@ -47,12 +47,14 @@ -- IO.hSetEncoding IO.stdout IO.char8 -- IO.hSetEncoding IO.stderr IO.char8 forM_ ["normal","e^",":)","e^-:)"] $ \pre -> do- let ext x = decode pre <.> x- res <- try_ $ writeFile (ext "source") "x"- case res of- Left _ ->- putStrLn $ "WARNING: Failed to write file " ++ pre ++ ", skipping unicode test (LANG=C ?)"- Right _ -> do+ -- If you aren't on UTF-8 file encoding it goes wrong, see+ -- https://github.com/ndmitchell/shake/pull/681+ enc <- liftIO getFileSystemEncoding+ if textEncodingName enc /= "UTF-8"+ then putStrLn "WARNING: filesystem encoding is not UTF-8, skipping unicode test (LANG=C ?)"+ else do+ let ext x = decode pre <.> x+ writeFile (ext "source") "x" build ["--prefix=" ++ pre, "--want=" ++ pre <.> "out", "--sleep"] assertContents (ext "out") $ "x" ++ "False" writeFile (ext "source") "y"
src/Test/Verbosity.hs view
@@ -8,12 +8,12 @@ main = testBuild test $ do "in.txt" %> \out -> do a <- getVerbosity- b <- withVerbosity Normal getVerbosity+ b <- withVerbosity Info getVerbosity writeFile' out $ unwords $ map show [a,b] "out.txt" %> \out -> do x <- getVerbosity- ys <- withVerbosity Loud $ do+ ys <- withVerbosity Verbose $ do a <- getVerbosity need ["in.txt"] -- make sure the inherited verbosity does not get passed along b <- getVerbosity@@ -25,13 +25,13 @@ test build = do build ["out.txt","--clean"]- assertContents "in.txt" "Normal Normal"- assertContents "out.txt" "Normal Loud Loud Quiet Normal Normal"+ assertContents "in.txt" "Info Info"+ assertContents "out.txt" "Info Verbose Verbose Error Info Info" build ["out.txt","--clean","--verbose"]- assertContents "in.txt" "Loud Normal"- assertContents "out.txt" "Loud Loud Loud Quiet Loud Loud"+ assertContents "in.txt" "Verbose Info"+ assertContents "out.txt" "Verbose Verbose Verbose Error Verbose Verbose" build ["out.txt","--clean","--quiet"]- assertContents "in.txt" "Quiet Normal"- assertContents "out.txt" "Quiet Loud Loud Quiet Quiet Quiet"+ assertContents "in.txt" "Warn Info"+ assertContents "out.txt" "Warn Verbose Verbose Error Warn Warn"