diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for Shake (* = breaking change) +0.19.3, released 2021-01-14 + #789, add overrideBuiltinRule + #787, more documentation on doesFileExist 0.19.2, released 2020-11-15 #780, Autodeps should consider a rename as a write to the destination #778, AutoDeps shouldn't trigger for files read and written diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2011-2020. +Copyright Neil Mitchell 2011-2021. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# Shake [![Hackage version](https://img.shields.io/hackage/v/shake.svg?label=Hackage)](https://hackage.haskell.org/package/shake) [![Stackage version](https://www.stackage.org/package/shake/badge/nightly?label=Stackage)](https://www.stackage.org/package/shake) [![Linux build status](https://img.shields.io/travis/ndmitchell/shake/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/shake) [![Windows build status](https://img.shields.io/appveyor/ci/ndmitchell/shake/master.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/shake) +# Shake [![Hackage version](https://img.shields.io/hackage/v/shake.svg?label=Hackage)](https://hackage.haskell.org/package/shake) [![Stackage version](https://www.stackage.org/package/shake/badge/nightly?label=Stackage)](https://www.stackage.org/package/shake) [![Build status](https://img.shields.io/github/workflow/status/ndmitchell/shake/ci.svg)](https://github.com/ndmitchell/shake/actions) Shake is a tool for writing build systems - an alternative to make, Scons, Ant etc. Shake has been used commercially for over five years, running thousands of builds per day. The website for Shake users is at [shakebuild.com](https://shakebuild.com). diff --git a/shake.cabal b/shake.cabal --- a/shake.cabal +++ b/shake.cabal @@ -1,13 +1,13 @@ cabal-version: >= 1.18 build-type: Simple name: shake -version: 0.19.2 +version: 0.19.3 license: BSD3 license-file: LICENSE category: Development, Shake author: Neil Mitchell maintainer: Neil Mitchell -copyright: Neil Mitchell 2011-2020 +copyright: Neil Mitchell 2011-2021 synopsis: Build system library, like Make, but more accurate dependencies. description: Shake is a Haskell library for writing build systems - designed as a @@ -457,6 +457,7 @@ Test.Batch Test.Benchmark Test.Builtin + Test.BuiltinOverride Test.C Test.Cache Test.Cleanup diff --git a/src/Development/Shake/Internal/Core/Rules.hs b/src/Development/Shake/Internal/Core/Rules.hs --- a/src/Development/Shake/Internal/Core/Rules.hs +++ b/src/Development/Shake/Internal/Core/Rules.hs @@ -6,7 +6,8 @@ module Development.Shake.Internal.Core.Rules( Rules, SRules(..), runRules, - RuleResult, addBuiltinRule, addBuiltinRuleEx, + RuleResult, + addBuiltinRule, overrideBuiltinRule, addBuiltinRuleEx, noLint, noIdentity, getShakeOptionsRules, getUserRuleInternal, getUserRuleOne, getUserRuleList, getUserRuleMaybe, @@ -132,7 +133,7 @@ ref <- newIORef mempty runReaderT r (opts, ref) SRules{..} <- readIORef ref - pure $ SRules (runListBuilder actions) builtinRules userRules (runListBuilder targets) (runListBuilder helpSuffix) + pure $ SRules (runListBuilder actions) builtinRules userRules (runListBuilder targets) (runListBuilder helpSuffix) override -- | Get all targets registered in the given rules. The names in -- 'Development.Shake.phony' and 'Development.Shake.~>' as well as the file patterns @@ -160,14 +161,20 @@ ,userRules :: !(TMap.Map UserRuleVersioned) ,targets :: !(list Target) ,helpSuffix :: !(list String) + ,override :: Bool } 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] + (SRules x1 x2 x3 x4 x5 x6) <> (SRules y1 y2 y3 y4 y5 y6) = + SRules (mappend x1 y1) (Map.unionWithKey f x2 y2) (TMap.unionWith (<>) x3 y3) (mappend x4 y4) (mappend x5 y5) pleaseOverwrite + where + pleaseOverwrite = x6 || y6 + f k a b + | pleaseOverwrite = b + | otherwise = throwImpure $ errorRuleDefinedMultipleTimes k [builtinLocation a, builtinLocation b] instance Monoid (SRules ListBuilder) where - mempty = SRules mempty Map.empty TMap.empty mempty mempty + mempty = SRules mempty Map.empty TMap.empty mempty mempty False mappend = (<>) instance Semigroup a => Semigroup (Rules a) where @@ -220,6 +227,19 @@ -- See 'addBuiltinRule' and 'Development.Shake.Rule.apply'. type family RuleResult key -- = value +addBuiltinRuleCanOverride :: + (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial) => + Bool -> + BuiltinLint key value -> + BuiltinIdentity key value -> + BuiltinRun key value -> + Rules () +addBuiltinRuleCanOverride canOverride = + withFrozenCallStack $ + addBuiltinRuleInternal canOverride $ + BinaryOp + (putEx . Bin.toLazyByteString . execPut . put) + (runGet get . LBS.fromChunks . pure) -- | Before looking at this function, you should read the warnings at the top of this module. -- This function is not often necessary in build systems. -- @@ -234,27 +254,39 @@ addBuiltinRule :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial) => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules () -addBuiltinRule = withFrozenCallStack $ addBuiltinRuleInternal $ BinaryOp - (putEx . Bin.toLazyByteString . execPut . put) - (runGet get . LBS.fromChunks . pure) +addBuiltinRule = addBuiltinRuleCanOverride False +-- | Like 'addBuiltinRule' but doesn't raise an error if a rule already exists. +-- In most cases 'addBuiltinRule' should be used. +overrideBuiltinRule :: + (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial) => + BuiltinLint key value -> + BuiltinIdentity key value -> + BuiltinRun key value -> + Rules () +overrideBuiltinRule = addBuiltinRuleCanOverride True + addBuiltinRuleEx :: (RuleResult key ~ value, ShakeValue key, BinaryEx key, Typeable value, NFData value, Show value, Partial) => BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules () -addBuiltinRuleEx = addBuiltinRuleInternal $ BinaryOp putEx getEx +addBuiltinRuleEx = addBuiltinRuleInternal False $ BinaryOp putEx getEx -- | Unexpected version of 'addBuiltinRule', which also lets me set the 'BinaryOp'. addBuiltinRuleInternal :: (RuleResult key ~ value, ShakeValue key, Typeable value, NFData value, Show value, Partial) - => BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules () -addBuiltinRuleInternal binary lint check (run :: BuiltinRun key value) = do + => Bool -> BinaryOp key -> BuiltinLint key value -> BuiltinIdentity key value -> BuiltinRun key value -> Rules () +addBuiltinRuleInternal override binary lint check (run :: BuiltinRun key value) = do let k = Proxy :: Proxy key let lint_ k v = lint (fromKey k) (fromValue v) let check_ k v = check (fromKey k) (fromValue v) let run_ k v b = fmap newValue <$> run (fromKey k) v b let binary_ = BinaryOp (putOp binary . fromKey) (newKey . getOp binary) - newRules mempty{builtinRules = Map.singleton (typeRep k) $ BuiltinRule lint_ check_ run_ binary_ (Ver 0) callStackTop} + newRules + mempty + { builtinRules = Map.singleton (typeRep k) $ BuiltinRule lint_ check_ run_ binary_ (Ver 0) callStackTop, + override + } -- | Change the priority of a given set of rules, where higher values take precedence. diff --git a/src/Development/Shake/Internal/Derived.hs b/src/Development/Shake/Internal/Derived.hs --- a/src/Development/Shake/Internal/Derived.hs +++ b/src/Development/Shake/Internal/Derived.hs @@ -17,7 +17,7 @@ import Control.Monad.IO.Class import System.Directory import System.FilePath (takeDirectory) -import System.IO +import System.IO (IOMode (..), hGetContents, withFile) import qualified System.IO.Extra as IO import Development.Shake.Internal.Errors diff --git a/src/Development/Shake/Internal/Rules/Directory.hs b/src/Development/Shake/Internal/Rules/Directory.hs --- a/src/Development/Shake/Internal/Rules/Directory.hs +++ b/src/Development/Shake/Internal/Rules/Directory.hs @@ -148,15 +148,38 @@ -- | Returns 'True' if the file exists. The existence of the file is tracked as a -- dependency, and if the file is created or deleted the rule will rerun in subsequent builds. +-- Usually used to implement include paths. For example, given a include path of @foo@ and @bar@, +-- and a file @hello.txt@, you might write: -- +-- @ +-- b <- 'doesFileExist' \"foo\/hello.txt\" +-- let file = if b then \"foo\/hello.txt\" else "\bar\/hello.txt\" +-- @ +-- +-- Now if the user had a file @bar\/hello.txt@, and then creates a file @foo\/hello.txt@, the +-- rule would correctly rerun, as while the @hello.txt@ that was used didn't change, which +-- file should be used has changed. +-- -- You should not call 'doesFileExist' on files which can be created by the build system. +-- The reason is that Shake operations such as this one are both cached for the duration of the build, +-- and may be run preemptively during a recheck. That means you can't control the time at which +-- 'doesFileExist' is called. For that to be consistent, 'doesFileExist' must return the same result at the +-- start and end of the build, a property that is partially checked by the @--lint@ flag. Given a +-- file created by the build system, a build from clean will return 'False' at the beginning and 'True' +-- at the end, leading to a change, and thus rebuilds in subsequent runs. +-- +-- If you do want to know whether a file exists separate to the build system, e.g. you can perfectly +-- predict the files contents and can save some meaningful work if the file already exists, you should +-- use the untracked "System.Directory" version. Such calls are not tracked by the file system, and you +-- should take care not to result in unpredictable results. doesFileExist :: FilePath -> Action Bool doesFileExist = fmap fromDoesFileExistA . apply1 . DoesFileExistQ . toStandard -- | Returns 'True' if the directory exists. The existence of the directory is tracked as a -- dependency, and if the directory is created or delete the rule will rerun in subsequent builds. -- --- You should not call 'doesDirectoryExist' on directories which can be created by the build system. +-- You should not call 'doesDirectoryExist' on directories which can be created by the build system, +-- for reasons explained in 'doesFileExist'. doesDirectoryExist :: FilePath -> Action Bool doesDirectoryExist = fmap fromDoesDirectoryExistA . apply1 . DoesDirectoryExistQ . toStandard diff --git a/src/Development/Shake/Rule.hs b/src/Development/Shake/Rule.hs --- a/src/Development/Shake/Rule.hs +++ b/src/Development/Shake/Rule.hs @@ -16,7 +16,7 @@ -- * Defining builtin rules -- | Functions and types for defining new types of Shake rules. - addBuiltinRule, + addBuiltinRule, overrideBuiltinRule, BuiltinLint, noLint, BuiltinIdentity, noIdentity, BuiltinRun, RunMode(..), RunChanged(..), RunResult(..), -- * Calling builtin rules -- | Wrappers around calling Shake rules. In general these should be specialised to a builtin rule. diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -14,6 +14,7 @@ import General.GetOpt import System.Process import System.Exit +import Data.Either.Extra main :: IO () @@ -51,4 +52,4 @@ ] findFile :: [FilePath] -> IO (Maybe FilePath) -findFile = findM (fmap (either (const False) id) . tryIO . IO.doesFileExist) +findFile = findM (fmap (fromRight False) . tryIO . IO.doesFileExist) diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -18,6 +18,7 @@ import qualified Test.Batch import qualified Test.Benchmark import qualified Test.Builtin +import qualified Test.BuiltinOverride import qualified Test.C import qualified Test.Cache import qualified Test.Cleanup @@ -74,6 +75,7 @@ ,"batch" * Test.Batch.main ,"benchmark" * Test.Benchmark.main ,"builtin" * Test.Builtin.main + ,"builtinOverride" * Test.BuiltinOverride.main ,"c" * Test.C.main ,"cache" * Test.Cache.main ,"cleanup" * Test.Cleanup.main diff --git a/src/Test/BuiltinOverride.hs b/src/Test/BuiltinOverride.hs new file mode 100644 --- /dev/null +++ b/src/Test/BuiltinOverride.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.BuiltinOverride (main) where + +import Control.Concurrent +import Development.Shake +import Development.Shake.Classes +import Development.Shake.Rule +import Test.Type + +newtype Key = Key Int + deriving (Show, Eq, Hashable, Binary, NFData, Typeable) + +type instance RuleResult Key = () + +main sleep = do + store <- newEmptyMVar + + testBuild (test store) (setRules store) sleep + +setRules resultsStore = do + addBuiltinRule noLint noIdentity $ \(Key n) _ _ -> do + liftIO $ putMVar resultsStore n + pure $ RunResult ChangedRecomputeDiff mempty () + overrideBuiltinRule noLint noIdentity $ \(Key n) _ _ -> do + liftIO $ putMVar resultsStore (n + 1) + pure $ RunResult ChangedRecomputeDiff mempty () + action $ apply1 $ Key 1 + +test store build = do + build [] + + res <- takeMVar store + assertBool (res == 2) "Rule was not overriden" diff --git a/src/Test/Command.hs b/src/Test/Command.hs --- a/src/Test/Command.hs +++ b/src/Test/Command.hs @@ -27,9 +27,9 @@ name ~> do need ["helper/shake_helper" <.> exe]; test let helper_source = unlines - ["import System.Time.Extra" - ,"import System.Process" + ["import System.Process" ,"import Control.Monad" + ,"import Control.Concurrent" ,"import System.Directory" ,"import System.Environment" ,"import System.Exit" @@ -45,7 +45,7 @@ ," 'x' -> exitFailure" ," 'c' -> putStrLn =<< getCurrentDirectory" ," 'v' -> putStrLn =<< getEnv rg" - ," 'w' -> sleep (read rg :: Double)" + ," 'w' -> threadDelay $ ceiling $ (read rg :: Double) * 1000000" ," 'r' -> LBS.putStr $ LBS.replicate (read rg) 'x'" ," 'i' -> putStr =<< getContents" ," 's' -> void $ readProcess exe [rg] \"\"" diff --git a/src/Test/Docs.hs b/src/Test/Docs.hs --- a/src/Test/Docs.hs +++ b/src/Test/Docs.hs @@ -18,7 +18,7 @@ -- GHC 8.0 has a segfault when linking Setup brokenHaddock = compilerVersion < makeVersion [8,2] -main = testBuild (unless brokenHaddock . defaultTest) $ do +main = testBuild (notCI . unless brokenHaddock . defaultTest) $ do let index = "dist/doc/html/shake/index.html" let setup = "dist/setup.exe" let config = "dist/setup-config" diff --git a/src/Test/Errors.hs b/src/Test/Errors.hs --- a/src/Test/Errors.hs +++ b/src/Test/Errors.hs @@ -195,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"] ++ ["at cmd, called at" | hasLocations] + notCI $ crash ["systemcmd"] $ ["systemcmd","random_missing_command"] ++ ["at cmd, called at" | hasLocations] crash ["stack1"] ["stack1","stack2","stack3","crash"] b <- IO.doesFileExist "staunch1" diff --git a/src/Test/Self.hs b/src/Test/Self.hs --- a/src/Test/Self.hs +++ b/src/Test/Self.hs @@ -35,6 +35,7 @@ map ("-package=" ++) <$> readFileLines ".pkgs" let ghc args = do + trackAllow ["**/package.cache", "**/.ghc.environment.*"] -- since ghc-pkg includes the ghc package, it changes if the version does ghcPkg $ GhcPkg () flags <- ghcFlags $ GhcFlags () diff --git a/src/Test/SelfMake.hs b/src/Test/SelfMake.hs --- a/src/Test/SelfMake.hs +++ b/src/Test/SelfMake.hs @@ -31,6 +31,7 @@ map ("-package=" ++) <$> readFileLines ".pkgs" let ghc args = do + trackAllow ["**/package.cache", "**/.ghc.environment.*"] -- since ghc-pkg includes the ghc package, it changes if the version does ghcPkg $ GhcPkg () flags <- ghcFlags $ GhcFlags () diff --git a/src/Test/Tup.hs b/src/Test/Tup.hs --- a/src/Test/Tup.hs +++ b/src/Test/Tup.hs @@ -7,9 +7,12 @@ import Development.Shake.Util import Test.Type import Data.Maybe +import Control.Monad +import System.Info.Extra -main = testBuild defaultTest $ do +-- Running ar on Mac seems to break in CI - not sure why +main = testBuild (unless isMac . defaultTest) $ do -- Example inspired by http://gittup.org/tup/ex_multiple_directories.html usingConfigFile $ shakeRoot "src/Test/Tup/root.cfg" diff --git a/src/Test/Type.hs b/src/Test/Type.hs --- a/src/Test/Type.hs +++ b/src/Test/Type.hs @@ -4,7 +4,7 @@ sleep, sleepFileTime, sleepFileTimeCalibrate, testBuildArgs, testBuild, testSimple, testNone, shakeRoot, - defaultTest, hasTracker, + defaultTest, hasTracker, notCI, copyDirectoryChanged, copyFileChangedIO, assertWithin, assertBool, assertBoolIO, assertException, assertExceptionAfter, @@ -39,6 +39,7 @@ import General.GetOpt import System.IO.Extra as IO import System.Time.Extra +import System.Info.Extra testBuildArgs @@ -153,10 +154,17 @@ fsatrace <- findExecutable $ "fsatrace" <.> exe pure $ if isJust fsatrace then LintFSATrace else LintBasic +-- Tests that don't currently work on CI +notCI :: IO () -> IO () +notCI act = do + b <- lookupEnv "CI" + when (isNothing b) act + hasTracker :: IO Bool hasTracker = do t <- tracker - pure $ t == LintFSATrace + -- Tracking on a Mac is pretty unreliable + pure $ not isMac && t == LintFSATrace assertFail :: String -> IO a assertFail msg = error $ "ASSERTION FAILED: " ++ msg