diff --git a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs index d17b1ac5851..ed4266cf98f 100644 --- a/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs +++ b/Cabal-hooks/src/Distribution/Simple/SetupHooks.hs @@ -359,8 +359,8 @@ following conditions apply: [N] the rule is new, or [S] the rule matches with an old rule, and either: - [S1] a file dependency of the rule has been modified/created/deleted, or - a (transitive) rule dependency of the rule is itself stale, or + [S1] a file dependency of the rule has been modified\/created\/deleted, + or a (transitive) rule dependency of the rule is itself stale, or [S2] the rule is different from the old rule, e.g. the argument stored in the rule command has changed, or the pointer to the action to run the rule has changed. (This is determined using the @Eq Rule@ instance.) diff --git a/Cabal/src/Distribution/Simple/BuildPaths.hs b/Cabal/src/Distribution/Simple/BuildPaths.hs index 279d605f1e7..54472859339 100644 --- a/Cabal/src/Distribution/Simple/BuildPaths.hs +++ b/Cabal/src/Distribution/Simple/BuildPaths.hs @@ -27,6 +27,7 @@ module Distribution.Simple.BuildPaths , haddockPref , autogenPackageModulesDir , autogenComponentModulesDir + , preBuildRulesCacheFile , autogenPathsModuleName , autogenPackageInfoModuleName , cppHeaderName @@ -160,6 +161,15 @@ autogenPackageModulesDir lbi = buildDir lbi makeRelativePathEx "global-autog autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> SymbolicPath Pkg (Dir Source) autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi makeRelativePathEx "autogen" +-- | The path to the pre-build rules cache file for a component, used to +-- compute rule staleness across runs. +preBuildRulesCacheFile + :: LocalBuildInfo + -> ComponentLocalBuildInfo + -> SymbolicPath Pkg File +preBuildRulesCacheFile lbi clbi = + componentBuildDir lbi clbi makeRelativePathEx "setup-hooks-rules.cache" + -- NB: Look at 'checkForeignDeps' for where a simplified version of this -- has been copy-pasted. diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs index 2de7ff1f622..01ea689a4f1 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Internal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -12,7 +13,8 @@ -- | -- Module: Distribution.Simple.SetupHooks.Internal -- --- Internal implementation module. +-- Internal implementation module for 'SetupHooks'. +-- -- Users of @build-type: Hooks@ should import "Distribution.Simple.SetupHooks" -- instead. module Distribution.Simple.SetupHooks.Internal @@ -115,14 +117,20 @@ import Distribution.Types.LocalBuildConfig as LBC import Distribution.Types.TargetInfo import Distribution.Verbosity +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Coerce (coerce) +import Data.Either (fromRight) import qualified Data.Graph as Graph +import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set +import Data.Time (UTCTime) + +import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncodeFile) -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, getModificationTime) -------------------------------------------------------------------------------- -- SetupHooks @@ -849,7 +857,11 @@ executeRules = -- an external hooks executable. executeRulesUserOrSystem :: forall userOrSystem - . SScope userOrSystem + . ( Binary (RuleData userOrSystem) + , Structured (RuleData userOrSystem) + , Eq (RuleData userOrSystem) + ) + => SScope userOrSystem -> (RuleId -> RuleDynDepsCmd userOrSystem -> IO (Maybe ([Rule.Dependency], LBS.ByteString))) -> (RuleId -> RuleExecCmd userOrSystem -> IO ()) -> Verbosity @@ -858,6 +870,16 @@ executeRulesUserOrSystem -> Map RuleId (RuleData userOrSystem) -> IO () executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo allRules = do + -- Load the rule cache from the previous build. + -- Used to detect when rule definitions have changed. + oldRules <- do + cacheExists <- doesFileExist rulesCacheFile + if cacheExists + then do + -- NB: do a strict read to avoid retaining the file handle. + bs <- BS.readFile rulesCacheFile + fromRight Map.empty <$> structuredDecodeOrFailIO (LBS.fromStrict bs) + else return Map.empty -- Compute all extra dynamic dependency edges. dynDepsEdges <- flip Map.traverseMaybeWithKey allRules $ @@ -939,7 +961,8 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a , " it is not in the appropriate 'autogenComponentModules' directory)" ] - -- Run all the demanded rules, in dependency order. + -- Run all the demanded rules, in dependency order, propagating staleness. + staleRulesRef <- newIORef Set.empty for_ sccs $ \(Graph.Node ruleVertex _) -> -- Don't run a rule unless it is demanded. unless (ruleVertex `Set.member` nonDemandedRuleVerts) $ do @@ -960,16 +983,27 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a case NE.nonEmpty missingRuleDeps of Just missingDeps -> errorOut $ CantFindSourceForRuleDependencies (toRuleBinary r) missingDeps - -- Dependencies OK: run the associated action. + -- Dependencies OK: check whether the rule is up to date before + -- deciding to run it. Nothing -> do - let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn) - runCmdData rId execCmd - -- Throw an error if running the action did not result in - -- the generation of outputs that we expected it to. - missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts - for_ (NE.nonEmpty missingRuleResults) $ \missingResults -> - errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults - return () + let dynDeps = maybe [] fst (Map.lookup rId dynDepsEdges) + upToDate <- ruleUpToDate mbWorkDir oldRules staleRulesRef rId r dynDeps + if upToDate + then + info verbosity $ + "Rule " ++ show rId ++ " is up to date; skipping." + else do + modifyIORef' staleRulesRef (Set.insert rId) + let execCmd = ruleExecCmd scope cmds (snd <$> mbDyn) + runCmdData rId execCmd + -- Throw an error if running the action did not result in + -- the generation of outputs that we expected it to. + missingRuleResults <- filterM (missingDep mbWorkDir) $ NE.toList reslts + for_ (NE.nonEmpty missingRuleResults) $ \missingResults -> + errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults + return () + -- Save the current rules to the cache for use in the next build. + structuredEncodeFile rulesCacheFile allRules where toRuleBinary :: RuleData userOrSystem -> RuleBinary toRuleBinary = case scope of @@ -978,6 +1012,7 @@ executeRulesUserOrSystem scope runDepsCmdData runCmdData verbosity lbi tgtInfo a clbi = targetCLBI tgtInfo mbWorkDir = mbWorkDirLBI lbi compAutogenDir = autogenComponentModulesDir lbi clbi + rulesCacheFile = interpretSymbolicPath mbWorkDir (preBuildRulesCacheFile lbi clbi) errorOut e = dieWithException verbosity $ SetupHooksException $ @@ -987,6 +1022,65 @@ directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep directRuleDependencyMaybe (FileDependency{}) = Nothing +mtimeIfExists :: FilePath -> IO (Maybe UTCTime) +mtimeIfExists fp = do + ex <- doesFileExist fp + if ex + then Just <$> getModificationTime fp + else return Nothing + +-- | Is the rule up to date (so that we can skip re-running it)? +-- +-- As per the SetupHooks documentation, a rule must be re-run if: +-- +-- - [N] the rule is new, or +-- - [S] the rule matches with an old rule, and either: +-- - [S1] an input to the rule has changed (either a file or rule dependency) +-- - [S2] the rule itself has changed +ruleUpToDate + :: Eq (RuleData userOrSystem) + => Maybe (SymbolicPath CWD (Dir Pkg)) + -- ^ working directory + -> Map RuleId (RuleData userOrSystem) + -- ^ old rules from the previous build + -> IORef (Set RuleId) + -- ^ rules that have been re-run + -> RuleId + -> RuleData userOrSystem + -> [Rule.Dependency] + -- ^ dynamic dependencies of this rule + -> IO Bool +ruleUpToDate mbWorkDir oldRules staleRulesRef rId rule dynDeps = do + staleRules <- readIORef staleRulesRef + if ruleChanged || any (`Set.member` staleRules) ruleDeps + then return False + else do + outMtimes <- traverse mtimeIfExists outputPaths + case sequenceA outMtimes of + -- At least one output is missing: must run the rule. + Nothing -> return False + Just outs -> + -- Re-run if an input is more recent than the oldest output. + case inputPaths of + [] -> return True + _ -> do + inMtimes <- traverse getModificationTime inputPaths + return (minimum outs >= maximum inMtimes) + where + i (Location dir file) = interpretSymbolicPath mbWorkDir (dir file) + allDeps = staticDependencies rule ++ dynDeps + ruleDeps = [outputOfRule ro | RuleDependency ro <- allDeps] + fileDeps = [loc | FileDependency loc <- allDeps] + inputPaths = map i fileDeps + outputPaths = fmap i (results rule) + ruleChanged = + case Map.lookup rId oldRules of + Just oldRule -> + -- Use the Eq instance to determine if the rule has changed + -- (as documented in the API). + oldRule /= rule + Nothing -> True + resolveDependency :: Verbosity -> RuleId -> Map RuleId (RuleData scope) -> Rule.Dependency -> IO Location resolveDependency verbosity rId allRules = \case FileDependency l -> return l diff --git a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs index 53b89a1e41a..a3ac58573d1 100644 --- a/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs +++ b/Cabal/src/Distribution/Simple/SetupHooks/Rule.hs @@ -267,6 +267,8 @@ deriving stock instance Eq (RuleData User) deriving stock instance Eq (RuleData System) deriving anyclass instance Binary (RuleData User) deriving anyclass instance Binary (RuleData System) +deriving anyclass instance Structured (RuleData User) +deriving anyclass instance Structured (RuleData System) -- | Trimmed down 'Show' instance, mostly for error messages. instance Show RuleBinary where @@ -1081,6 +1083,35 @@ instance -- that involve existential quantification. data family Tok (arg :: Symbol) :: k +instance + (Typeable scope, Typeable ruleCmd, Typeable deps) + => Structured (RuleCommands scope deps ruleCmd) + where + structure _ = + Structure + tr + 0 + (show tr) + [ + ( "StaticRuleCommand" + , + [ nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (IO ())) + , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "arg" :: Hs.Type)) + ] + ) + , + ( "DynamicRuleCommands" + , + [ nominalStructure $ Proxy @(Static scope (Dict (Binary (Tok "depsRes"), Show (Tok "depsRes"), Eq (Tok "depsRes")))) + , nominalStructure $ Proxy @(deps scope (Tok "depsArg") (Tok "depsRes")) + , nominalStructure $ Proxy @(ruleCmd scope (Tok "arg") (Tok "depsRes" -> IO ())) + , nominalStructure $ Proxy @(Typeable.TypeRep (Tok "depsArg", Tok "depsRes", Tok "arg")) + ] + ) + ] + where + tr = Typeable.SomeTypeRep $ Typeable.typeRep @(RuleCommands scope deps ruleCmd) + instance ( forall res. Binary (ruleCmd System LBS.ByteString res) , Binary (deps System LBS.ByteString LBS.ByteString) diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP new file mode 100644 index 00000000000..442abf888c7 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP @@ -0,0 +1 @@ +a = True diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP new file mode 100644 index 00000000000..72b3e397d8b --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP @@ -0,0 +1 @@ +b = False diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP new file mode 100644 index 00000000000..e18e4f45023 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP @@ -0,0 +1 @@ +c = 'x' diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/Setup.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/Setup.hs new file mode 100644 index 00000000000..bfa0675fc95 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple ( defaultMainWithSetupHooks ) +import SetupHooks ( setupHooks ) + +main :: IO () +main = defaultMainWithSetupHooks setupHooks diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/SetupHooks.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/SetupHooks.hs new file mode 100644 index 00000000000..59f68797f60 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/SetupHooks.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StaticPointers #-} + +module SetupHooks where + +-- Cabal +import Distribution.Compat.Binary +import Distribution.Parsec + ( simpleParsec ) +import Distribution.Simple.LocalBuildInfo + ( interpretSymbolicPathLBI ) +import Distribution.Simple.Utils + ( warn, rewriteFileEx ) +import Distribution.Utils.Path +import Distribution.Verbosity + +-- Cabal-hooks +import Distribution.Simple.SetupHooks + +-- base +import Control.Monad.IO.Class + ( liftIO ) +import Data.Foldable + ( for_ ) +import Data.List + ( isSuffixOf ) +import qualified Data.List.NonEmpty as NE + ( NonEmpty(..) ) +import Data.String + ( fromString ) +import GHC.Generics + +-- directory +import System.Directory + ( listDirectory ) + +-- filepath +import System.FilePath + ( dropExtension ) + +-------------------------------------------------------------------------------- + +setupHooks :: SetupHooks +setupHooks = + noSetupHooks + { buildHooks = + noBuildHooks + { preBuildComponentRules = Just $ rules (static ()) preBuildRules + } + } + +preBuildRules :: PreBuildComponentInputs -> RulesM () +preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = do + let verbosityFlags = buildingWhatVerbosity what + clbi = targetCLBI tgt + autogenDir = autogenComponentModulesDir lbi clbi + srcDir = sameDirectory + + -- Monitor .myPP files in the package directory. + let myPPGlob = + case simpleParsec "*.myPP" of + Just g -> g + Nothing -> error "SetupHooksRecompRules: failed to parse *.myPP glob" + addRuleMonitors [ monitorFileGlobExistence myPPGlob ] + + -- Scan the package directory for .myPP files and register one + -- preprocessing rule per file. + allFiles <- liftIO $ listDirectory (interpretSymbolicPathLBI lbi srcDir) + for_ (filter (".myPP" `isSuffixOf`) allFiles) $ \fileName -> do + let baseName = dropExtension fileName + -- For A and B, bake in a constant verbosity so that their rules are + -- unaffected by the --verbose flag. C uses the actual verbosity, so + -- its rule changes when the verbosity changes. + ruleVerbosityFlags + | baseName `elem` ["A", "B"] = normal + | otherwise = verbosityFlags + registerRule_ (fromString $ "myPP " ++ baseName) $ + staticRule + (mkCommand (static Dict) (static runMyPP) $ + MyPPInput + { ppVerbosityFlags = ruleVerbosityFlags + , ppSrcDir = srcDir + , ppAutogenDir = autogenDir + , ppBaseName = baseName + }) + [ FileDependency $ Location srcDir (makeRelativePathEx fileName) ] + ( Location autogenDir (makeRelativePathEx baseName <.> "hs") NE.:| [] ) + +-- | Preprocess a single .myPP file into a .hs module. +runMyPP :: MyPPInput -> IO () +runMyPP (MyPPInput {..}) = do + let verbosity = mkVerbosity defaultVerbosityHandles ppVerbosityFlags + warn verbosity $ "Running myPP preprocessor for " ++ ppBaseName + content <- readFile (getSymbolicPath ppSrcDir ppBaseName <.> "myPP") + rewriteFileEx verbosity (getSymbolicPath ppAutogenDir ppBaseName <.> "hs") $ + "module " ++ ppBaseName ++ " where\n" ++ content + +data MyPPInput + = MyPPInput + { ppVerbosityFlags :: VerbosityFlags + , ppSrcDir :: SymbolicPath Pkg (Dir Source) + , ppAutogenDir :: SymbolicPath Pkg (Dir Source) + , ppBaseName :: String + } + deriving stock ( Show, Generic ) + deriving anyclass Binary diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/cabal.project b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/cabal.project new file mode 100644 index 00000000000..e6fdbadb439 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/cabal.project @@ -0,0 +1 @@ +packages: . diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup-hooks-recomp-rules-test.cabal b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup-hooks-recomp-rules-test.cabal new file mode 100644 index 00000000000..2482faa3607 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup-hooks-recomp-rules-test.cabal @@ -0,0 +1,28 @@ +cabal-version: 3.14 +name: setup-hooks-recomp-rules-test +version: 0.1.0.0 +synopsis: Test recompilation checking for pre-build rules +license: BSD-3-Clause +author: NA +maintainer: NA +category: Testing +build-type: Hooks + +custom-setup + setup-depends: + Cabal + , Cabal-hooks + + , base + , filepath + , directory + +library + autogen-modules: + A, B, C + exposed-modules: + A, B, C + build-depends: + base + default-language: + Haskell2010 diff --git a/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup.test.hs b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup.test.hs new file mode 100644 index 00000000000..ea2ad7365a1 --- /dev/null +++ b/cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/setup.test.hs @@ -0,0 +1,27 @@ +import Test.Cabal.Prelude + +main :: IO () +main = setupTest $ recordMode DoNotRecord $ do + setup "configure" [] + + -- First build: should run rules for A, B and C. + build1 <- setup' "build" ["--verbose=1"] + assertOutputContains "Running myPP preprocessor for A" build1 + assertOutputContains "Running myPP preprocessor for B" build1 + assertOutputContains "Running myPP preprocessor for C" build1 + + -- Modify A.myPP, leaving other files alone. + writeSourceFile "A.myPP" "a = 42\n" + + -- Check we only re-run the preprocessor for A (file dependency changed). + build2 <- setup' "build" ["--verbose=1"] + assertOutputContains "Running myPP preprocessor for A" build2 + assertOutputDoesNotContain "Running myPP preprocessor for B" build2 + assertOutputDoesNotContain "Running myPP preprocessor for C" build2 + + -- Change verbosity. C's rule stores the actual verbosity, while A and B + -- bake in a constant verbosity. Thus we should only re-run the rule for C. + build3 <- setup' "build" ["--verbose=2"] + assertOutputDoesNotContain "Running myPP preprocessor for A" build3 + assertOutputDoesNotContain "Running myPP preprocessor for B" build3 + assertOutputContains "Running myPP preprocessor for C" build3 diff --git a/changelog.d/hooks-recomp.md b/changelog.d/hooks-recomp.md new file mode 100644 index 00000000000..4fccd057be6 --- /dev/null +++ b/changelog.d/hooks-recomp.md @@ -0,0 +1,22 @@ +--- +synopsis: Recompilation checking for SetupHooks pre-build rules +packages: [Cabal, Cabal-hooks] +prs: 11731 +issues: 11730 +--- + +Pre-build rules are now only re-run when stale, according to the conditions +described in the [SetupHooks API](https://hackage.haskell.org/package/Cabal-hooks/docs/Distribution-Simple-SetupHooks.html). That is, a rule is re-run if any of the following conditions are +satisfied: + + - The rule is new, or + - A dependency of the rule is stale. + That is, either we have re-run another rule that this rule depends on, + or one of the file inputs to the rule is newer than the oldest output of the + rule (or the rule output doesn't exist at all), or + - The rule itself has changed, e.g. the parameters stored in `RuleData` + have changed. + +In particular, Cabal will now write per-component caches of pre-build rules +in order to compute which rules have changed across run, with file name +"setup-hooks-rules.cache".