Implement recompilation checking for pre-build rules

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.)

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,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

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

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

cabal-testsuite/PackageTests/SetupHooks/SetupHooksRecompRules/cabal.project

@@ -0,0 +1 @@
+packages: .