Merge pull request #11731 from sheaf/hooks-recomp

Implement recompilation checking for pre-build rules

Author: mergify[bot]

Cabal-hooks/src/Distribution/Simple/SetupHooks.hs

@@ -237,7 +237,7 @@ import Data.Map.Strict as Map
 A Cabal package with @Hooks@ @build-type@ must define the Haskell module
 @SetupHooks@ which defines a value @setupHooks :: 'SetupHooks'@.
 
-These *setup hooks* allow package authors to customise the configuration and
+These __setup hooks__ allow package authors to customise the configuration and
 building of a package by providing certain hooks that get folded into the
 general package configuration and building logic within @Cabal@.
 
@@ -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.)

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.
 

Cabal/src/Distribution/Simple/SetupHooks/Internal.hs

@@ -2,17 +2,20 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 
 -- |
 -- 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
@@ -109,20 +112,27 @@ import qualified Distribution.Simple.SetupHooks.Rule as Rule
 import Distribution.Simple.Utils
 import Distribution.System (Platform (..))
 import Distribution.Utils.Path
+import Distribution.Utils.Structured
+  ( structuredDecodeOrFailIO
+  , structuredEncodeFile
+  )
 
 import qualified Distribution.Types.BuildInfo.Lens as BI (buildInfo)
 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 System.Directory (doesFileExist)
+import System.Directory (doesFileExist, getModificationTime)
 
 --------------------------------------------------------------------------------
 -- SetupHooks
@@ -849,7 +859,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 +872,12 @@ 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 <- handleDoesNotExist Map.empty $ do
+    -- NB: do a strict read to avoid retaining the file handle.
+    bs <- BS.readFile rulesCacheFile
+    fromRight Map.empty <$> structuredDecodeOrFailIO (LBS.fromStrict bs)
   -- Compute all extra dynamic dependency edges.
   dynDepsEdges <-
     flip Map.traverseMaybeWithKey allRules $
@@ -939,37 +959,39 @@ 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
-          let ( r@Rule
-                  { ruleCommands = cmds
-                  , staticDependencies = staticDeps
-                  , results = reslts
-                  }
-                , rId
-                , _staticRuleDepIds
-                ) =
-                  ruleFromVertex ruleVertex
-              mbDyn = Map.lookup rId dynDepsEdges
-              allDeps = staticDeps ++ maybe [] fst mbDyn
+          let (r, rId, _staticRuleDepIds) = ruleFromVertex ruleVertex
+              Rule{ruleCommands, staticDependencies, results} = r
+              mbDynDeps = Map.lookup rId dynDepsEdges
+              allDeps = staticDependencies ++ maybe [] fst mbDynDeps
           -- Check that the dependencies the rule expects are indeed present.
           resolvedDeps <- traverse (resolveDependency verbosity rId allRules) allDeps
           missingRuleDeps <- filterM (missingDep mbWorkDir) resolvedDeps
           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 mbDynDeps
+              ruleUpToDate mbWorkDir oldRules staleRulesRef rId r dynDeps >>= \case
+                True ->
+                  info verbosity $
+                    "Rule " ++ show rId ++ " is up to date; skipping."
+                False -> do
+                  modifyIORef' staleRulesRef (Set.insert rId)
+                  runCmdData rId $ ruleExecCmd scope ruleCommands (snd <$> mbDynDeps)
+                  -- 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 results
+                  for_ (NE.nonEmpty missingRuleResults) $ \missingResults ->
+                    errorOut $ MissingRuleOutputs (toRuleBinary r) missingResults
+      -- 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 +1000,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 +1010,59 @@ directRuleDependencyMaybe :: Rule.Dependency -> Maybe RuleId
 directRuleDependencyMaybe (RuleDependency dep) = Just $ outputOfRule dep
 directRuleDependencyMaybe (FileDependency{}) = 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
+      let maybeModTime fp = handleDoesNotExist Nothing $ Just <$> getModificationTime fp
+      outMtimes <- traverse maybeModTime 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

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)

cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/A.myPP

@@ -0,0 +1 @@
+a = True

cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/B.myPP

@@ -0,0 +1 @@
+b = False

cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/C.myPP

@@ -0,0 +1 @@
+c = 'x'

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