WIP: cabal-install integration of SetupHooks

haskell · Apr 11, 2024 · 253e4d5 · 253e4d5
1 parent cd6d1c6
commit 253e4d5
Show file tree

Hide file tree

Showing 25 changed files with 1,661 additions and 330 deletions.
diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs
@@ -111,7 +111,6 @@ import Distribution.Simple.SetupHooks.Internal
   )
 import Distribution.Simple.Test
 import Distribution.Simple.Utils
-import Distribution.Types.LocalBuildInfo (buildDirPBD)
 import qualified Distribution.Types.LocalBuildConfig as LBC
 import Distribution.Utils.Path
 import Distribution.Verbosity
@@ -171,7 +170,7 @@ defaultMainWithSetupHooksArgs setupHooks =
       -> BuildFlags
       -> IO ()
     setup_buildHook pkg_descr lbi hooks flags =
-      build_setupHooks
+      void $ build_setupHooks
         (SetupHooks.buildHooks setupHooks)
         pkg_descr
         lbi
@@ -224,7 +223,7 @@ defaultMainWithSetupHooksArgs setupHooks =
       -> HaddockFlags
       -> IO ()
     setup_haddockHook pkg_descr lbi hooks flags =
-      haddock_setupHooks
+      void $ haddock_setupHooks
         (SetupHooks.buildHooks setupHooks)
         pkg_descr
         lbi

diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs
@@ -26,6 +26,8 @@ module Distribution.Simple.Build
   ( -- * Build
     build
   , build_setupHooks
+  , buildComponent
+  , runPostBuildHooks
 
     -- * Repl
   , repl
@@ -34,6 +36,7 @@ module Distribution.Simple.Build
 
     -- * Build preparation
   , preBuildComponent
+  , runPreBuildHooks
   , AutogenFile (..)
   , AutogenFileContents
   , writeBuiltinAutogenFiles
@@ -86,6 +89,7 @@ import Distribution.Simple.BuildPaths
 import Distribution.Simple.BuildTarget
 import Distribution.Simple.BuildToolDepends
 import Distribution.Simple.Configure
+import Distribution.Simple.Errors
 import Distribution.Simple.Flag
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.PreProcess
@@ -101,9 +105,11 @@ import Distribution.Simple.Setup.Repl
 import Distribution.Simple.SetupHooks.Internal
   ( BuildHooks (..)
   , BuildingWhat (..)
+  , buildingWhatVerbosity
   , noBuildHooks
   )
 import qualified Distribution.Simple.SetupHooks.Internal as SetupHooks
+import qualified Distribution.Simple.SetupHooks.Rule as SetupHooks
 import Distribution.Simple.ShowBuildInfo
 import Distribution.Simple.Test.LibV09
 import Distribution.Simple.Utils
@@ -120,7 +126,6 @@ import Distribution.Compat.Graph (IsNode (..))
 import Control.Monad
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Map as Map
-import Distribution.Simple.Errors
 import System.Directory (doesFileExist, removeFile)
 import System.FilePath (takeDirectory)
 
@@ -137,7 +142,8 @@ build
   -> [PPSuffixHandler]
   -- ^ preprocessors to run before compiling
   -> IO ()
-build = build_setupHooks noBuildHooks
+build pkg lbi flags suffixHandlers =
+  void $ build_setupHooks noBuildHooks pkg lbi flags suffixHandlers
 
 build_setupHooks
   :: BuildHooks
@@ -149,13 +155,15 @@ build_setupHooks
   -- ^ Flags that the user passed to build
   -> [PPSuffixHandler]
   -- ^ preprocessors to run before compiling
-  -> IO ()
+  -> IO [SetupHooks.MonitorFilePath]
 build_setupHooks
   (BuildHooks{preBuildComponentRules = mbPbcRules, postBuildComponentHook = mbPostBuild})
   pkg_descr
   lbi
   flags
   suffixHandlers = do
+    let verbosity = fromFlag $ buildVerbosity flags
+        distPref = fromFlag $ buildDistPref flags
     checkSemaphoreSupport verbosity (compiler lbi) flags
     targets <- readTargetInfos verbosity pkg_descr lbi (buildTargets flags)
     let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
@@ -180,7 +188,7 @@ build_setupHooks
     dumpBuildInfo verbosity distPref (configDumpBuildInfo (configFlags lbi)) pkg_descr lbi flags
 
     -- Now do the actual building
-    (\f -> foldM_ f (installedPkgs lbi) componentsToBuild) $ \index target -> do
+    (mons, _) <- (\f -> foldM f ([], installedPkgs lbi) componentsToBuild) $ \(monsAcc, index) target -> do
       let comp = targetComponent target
           clbi = targetCLBI target
           bi = componentBuildInfo comp
@@ -191,18 +199,13 @@ build_setupHooks
               , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
               , installedPkgs = index
               }
-          runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
-          runPreBuildHooks lbi2 tgt =
-            let inputs =
-                  SetupHooks.PreBuildComponentInputs
-                    { SetupHooks.buildingWhat = BuildNormal flags
-                    , SetupHooks.localBuildInfo = lbi2
-                    , SetupHooks.targetInfo = tgt
-                    }
-             in for_ mbPbcRules $ \pbcRules ->
-                  SetupHooks.executeRules verbosity lbi2 tgt pbcRules inputs
-      preBuildComponent runPreBuildHooks verbosity lbi' target
-
+          runPreBuildHooksNormal :: IO [SetupHooks.MonitorFilePath]
+          runPreBuildHooksNormal =
+            case mbPbcRules of
+              Nothing -> return []
+              Just pbcRules ->
+                runPreBuildHooks (BuildNormal flags) lbi target pbcRules
+      mons <- preBuildComponent runPreBuildHooksNormal verbosity lbi target
       let numJobs = buildNumJobs flags
       par_strat <-
         toFlag <$> case buildUseSemaphore flags of
@@ -231,12 +234,41 @@ build_setupHooks
               , SetupHooks.targetInfo = target
               }
       for_ mbPostBuild ($ postBuildInputs)
-      return (maybe index (Index.insert `flip` index) mb_ipi)
+      return (monsAcc ++ mons, maybe index (Index.insert `flip` index) mb_ipi)
+    return mons
 
-    return ()
-    where
-      distPref = fromFlag (buildDistPref flags)
-      verbosity = fromFlag (buildVerbosity flags)
+runPreBuildHooks
+  :: BuildingWhat
+  -> LocalBuildInfo
+  -> TargetInfo
+  -> SetupHooks.Rules SetupHooks.PreBuildComponentInputs
+  -> IO [SetupHooks.MonitorFilePath]
+runPreBuildHooks what lbi tgt pbRules = do
+  let inputs =
+        SetupHooks.PreBuildComponentInputs
+          { SetupHooks.buildingWhat = what
+          , SetupHooks.localBuildInfo = lbi
+          , SetupHooks.targetInfo = tgt
+          }
+      verbosity = buildingWhatVerbosity what
+  (rules, monitors) <- SetupHooks.computeRules verbosity inputs pbRules
+  SetupHooks.executeRules verbosity lbi tgt rules
+  return monitors
+
+runPostBuildHooks
+  :: BuildFlags
+  -> LocalBuildInfo
+  -> TargetInfo
+  -> (SetupHooks.PostBuildComponentInputs -> IO ())
+  -> IO ()
+runPostBuildHooks flags lbi tgt postBuild =
+  let inputs =
+        SetupHooks.PostBuildComponentInputs
+          { SetupHooks.buildFlags = flags
+          , SetupHooks.localBuildInfo = lbi
+          , SetupHooks.targetInfo = tgt
+          }
+   in postBuild inputs
 
 -- | Check for conditions that would prevent the build from succeeding.
 checkSemaphoreSupport
@@ -378,24 +410,18 @@ repl_setupHooks
                   (componentBuildInfo comp)
                   (withPrograms lbi')
             }
-        runPreBuildHooks :: LocalBuildInfo -> TargetInfo -> IO ()
-        runPreBuildHooks lbi2 tgt =
-          let inputs =
-                SetupHooks.PreBuildComponentInputs
-                  { SetupHooks.buildingWhat = BuildRepl flags
-                  , SetupHooks.localBuildInfo = lbi2
-                  , SetupHooks.targetInfo = tgt
-                  }
-           in for_ mbPbcRules $ \pbcRules ->
-                SetupHooks.executeRules verbosity lbi2 tgt pbcRules inputs
+        runPreBuildHooksRepl :: TargetInfo -> IO ()
+        runPreBuildHooksRepl tgt =
+          for_ mbPbcRules $
+            void . runPreBuildHooks (BuildRepl flags) lbi tgt
 
     -- build any dependent components
     sequence_
       [ do
         let clbi = targetCLBI subtarget
             comp = targetComponent subtarget
             lbi' = lbiForComponent comp lbi
-        preBuildComponent runPreBuildHooks verbosity lbi' subtarget
+        preBuildComponent (runPreBuildHooksRepl subtarget) verbosity lbi subtarget
         buildComponent
           (mempty{buildCommonFlags = mempty{setupVerbosity = toFlag verbosity}})
           NoFlag
@@ -412,7 +438,7 @@ repl_setupHooks
     let clbi = targetCLBI target
         comp = targetComponent target
         lbi' = lbiForComponent comp lbi
-    preBuildComponent runPreBuildHooks verbosity lbi' target
+    preBuildComponent (runPreBuildHooksRepl target) verbosity lbi target
     replComponent flags verbosity pkg_descr lbi' suffixHandlers comp clbi distPref
 
 -- | Start an interpreter without loading any package files.
@@ -1029,19 +1055,19 @@ replFLib flags pkg_descr lbi exe clbi =
 -- | Creates the autogenerated files for a particular configured component,
 -- and runs the pre-build hook.
 preBuildComponent
-  :: (LocalBuildInfo -> TargetInfo -> IO ())
+  :: IO r
   -- ^ pre-build hook
   -> Verbosity
   -> LocalBuildInfo
   -- ^ Configuration information
   -> TargetInfo
-  -> IO ()
+  -> IO r
 preBuildComponent preBuildHook verbosity lbi tgt = do
   let pkg_descr = localPkgDescr lbi
       clbi = targetCLBI tgt
   createDirectoryIfMissingVerbose verbosity True (interpretSymbolicPathLBI lbi $ componentBuildDir lbi clbi)
   writeBuiltinAutogenFiles verbosity pkg_descr lbi clbi
-  preBuildHook lbi tgt
+  preBuildHook
 
 -- | Generate and write to disk all built-in autogenerated files
 -- for the specified component. These files will be put in the