Use SetupHooks for Configure build-type

sheaf · sheaf · commit d1dce352dc8f · 2024-04-16T11:30:49.000+02:00
diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs
@@ -67,6 +67,7 @@ module Distribution.Simple
     -- ** Standard sets of hooks
   , simpleUserHooks
   , autoconfUserHooks
+  , autoconfSetupHooks
   , emptyUserHooks
   ) where
 
@@ -110,6 +111,8 @@ 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
 import Distribution.Version
@@ -935,16 +938,11 @@ autoconfUserHooks =
         let common = configCommonFlags flags
             verbosity = fromFlag $ setupVerbosity common
             mbWorkDir = flagToMaybe $ setupWorkingDir common
-            baseDir = packageRoot common
-        confExists <- doesFileExist $ baseDir </> "configure"
-        if confExists
-          then
-            runConfigureScript
-              verbosity
-              flags
-              lbi
-          else dieWithException verbosity ConfigureScriptNotFound
-
+        runConfigureScript
+          flags
+          (flagAssignment lbi)
+          (withPrograms lbi)
+          (hostPlatform lbi)
         pbi <- getHookedBuildInfo verbosity mbWorkDir (buildDir lbi)
         sanityCheckHookedBuildInfo verbosity pkg_descr pbi
         let pkg_descr' = updatePackageDescription pbi pkg_descr
@@ -991,6 +989,65 @@ getHookedBuildInfo verbosity mbWorkDir build_dir = do
       info verbosity $ "Reading parameters from " ++ getSymbolicPath infoFile
       readHookedBuildInfo verbosity mbWorkDir infoFile
 
+autoconfSetupHooks :: SetupHooks
+autoconfSetupHooks =
+  SetupHooks.noSetupHooks
+    { SetupHooks.configureHooks =
+        SetupHooks.noConfigureHooks
+          { SetupHooks.postConfPackageHook = Just post_conf_pkg
+          , SetupHooks.preConfComponentHook = Just pre_conf_comp
+          }
+    }
+  where
+    post_conf_pkg
+      :: SetupHooks.PostConfPackageInputs
+      -> IO ()
+    post_conf_pkg
+      ( SetupHooks.PostConfPackageInputs
+          { SetupHooks.localBuildConfig =
+            LBC.LocalBuildConfig{LBC.withPrograms = progs}
+          , SetupHooks.packageBuildDescr =
+            LBC.PackageBuildDescr
+              { LBC.configFlags = cfg
+              , LBC.flagAssignment = flagAssignment
+              , LBC.hostPlatform = plat
+              }
+          }
+        ) = runConfigureScript cfg flagAssignment progs plat
+
+    pre_conf_comp
+      :: SetupHooks.PreConfComponentInputs
+      -> IO SetupHooks.PreConfComponentOutputs
+    pre_conf_comp
+      ( SetupHooks.PreConfComponentInputs
+          { SetupHooks.packageBuildDescr =
+            LBC.PackageBuildDescr
+              { LBC.configFlags = cfg
+              , localPkgDescr = pkg_descr
+              }
+          , SetupHooks.component = component
+          }
+        ) = do
+        let verbosity = fromFlag $ configVerbosity cfg
+            mbWorkDir = flagToMaybe $ configWorkingDir cfg
+            distPref = configDistPref cfg
+        dist_dir <- findDistPrefOrDefault distPref
+        -- Read the ".buildinfo" file and use that to update
+        -- the components (main library + executables only).
+        hbi <- getHookedBuildInfo verbosity mbWorkDir (dist_dir </> makeRelativePathEx "build")
+        sanityCheckHookedBuildInfo verbosity pkg_descr hbi
+        -- SetupHooks TODO: we are reading getHookedBuildInfo once
+        -- for each component. I think this is inherent to the SetupHooks
+        -- approach.
+        let comp_name = componentName component
+        diff <- case SetupHooks.hookedBuildInfoComponentDiff_maybe hbi comp_name of
+          Nothing -> return $ SetupHooks.emptyComponentDiff comp_name
+          Just do_diff -> do_diff
+        return $
+          SetupHooks.PreConfComponentOutputs
+            { SetupHooks.componentDiff = diff
+            }
+
 defaultTestHook
   :: Args
   -> PackageDescription
diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
@@ -23,19 +24,20 @@ import Prelude ()
 -- local
 import Distribution.PackageDescription
 import Distribution.Pretty
+import Distribution.Simple.Configure (findDistPrefOrDefault)
 import Distribution.Simple.Errors
 import Distribution.Simple.LocalBuildInfo
 import Distribution.Simple.Program
 import Distribution.Simple.Program.Db
 import Distribution.Simple.Setup.Common
 import Distribution.Simple.Setup.Config
 import Distribution.Simple.Utils
-import Distribution.System (buildPlatform)
+import Distribution.System (Platform, buildPlatform)
 import Distribution.Utils.NubList
 import Distribution.Utils.Path
-import Distribution.Verbosity
 
 -- Base
+import System.Directory (createDirectoryIfMissing, doesFileExist)
 import qualified System.FilePath as FilePath
 #ifdef mingw32_HOST_OS
 import System.FilePath    (normalise, splitDrive)
@@ -48,14 +50,24 @@ import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
 
 runConfigureScript
-  :: Verbosity
-  -> ConfigFlags
-  -> LocalBuildInfo
+  :: ConfigFlags
+  -> FlagAssignment
+  -> ProgramDb
+  -> Platform -- ^ host platform
   -> IO ()
-runConfigureScript verbosity flags lbi = do
+runConfigureScript cfg flags programDb hp = do
+  let commonCfg = configCommonFlags cfg
+      verbosity = fromFlag $ setupVerbosity commonCfg
+  dist_dir <- findDistPrefOrDefault $ setupDistPref commonCfg
+  let build_dir = dist_dir </> makeRelativePathEx "build"
+      mbWorkDir = flagToMaybe $ setupWorkingDir commonCfg
+      configureScriptPath = packageRoot commonCfg </> "configure"
+  confExists <- doesFileExist configureScriptPath
+  unless confExists $
+    dieWithException verbosity (ConfigureScriptNotFound configureScriptPath)
+  configureFile <-
+    makeAbsolute $ configureScriptPath
   env <- getEnvironment
-  let commonFlags = configCommonFlags flags
-      programDb = withPrograms lbi
   (ccProg, ccFlags) <- configureCCompiler verbosity programDb
   ccProgShort <- getShortPathName ccProg
   -- The C compiler's compilation and linker flags (e.g.
@@ -64,8 +76,8 @@ runConfigureScript verbosity flags lbi = do
   -- to ccFlags
   -- We don't try and tell configure which ld to use, as we don't have
   -- a way to pass its flags too
-  configureFile <-
-    makeAbsolute $ packageRoot commonFlags </> "configure"
+
+  let configureFile' = toUnix configureFile
   -- autoconf is fussy about filenames, and has a set of forbidden
   -- characters that can't appear in the build directory, etc:
   -- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions
@@ -79,7 +91,6 @@ runConfigureScript verbosity flags lbi = do
   -- TODO: We don't check for colons, tildes or leading dashes. We
   -- also should check the builddir's path, destdir, and all other
   -- paths as well.
-  let configureFile' = toUnix configureFile
   for_ badAutoconfCharacters $ \(c, cname) ->
     when (c `elem` FilePath.dropDrive configureFile') $
       warn verbosity $
@@ -111,7 +122,7 @@ runConfigureScript verbosity flags lbi = do
       Map.fromListWith
         (<>)
         [ (flagEnvVar flag, (flag, bool) :| [])
-        | (flag, bool) <- unFlagAssignment $ flagAssignment lbi
+        | (flag, bool) <- unFlagAssignment flags
         ]
   -- A map from env vars to flag names to the single flag we will go with
   cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-
@@ -143,10 +154,10 @@ runConfigureScript verbosity flags lbi = do
         ]
           ++ [
                ( "CABAL_FLAGS"
-               , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi]
+               , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment flags]
                )
              ]
-  let extraPath = fromNubList $ configProgramPathExtra flags
+  let extraPath = fromNubList $ configProgramPathExtra cfg
   let cflagsEnv =
         maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $
           lookup "CFLAGS" env
@@ -160,7 +171,6 @@ runConfigureScript verbosity flags lbi = do
         ("CFLAGS", Just cflagsEnv)
           : [("PATH", Just pathEnv) | not (null extraPath)]
           ++ cabalFlagEnv
-      hp = hostPlatform lbi
       maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)]
       args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag
       shProg = simpleProgram "sh"
@@ -169,14 +179,16 @@ runConfigureScript verbosity flags lbi = do
     lookupProgram shProg
       `fmap` configureProgram verbosity shProg progDb
   case shConfiguredProg of
-    Just sh ->
+    Just sh -> do
+      let build_in = interpretSymbolicPath mbWorkDir build_dir
+      createDirectoryIfMissing True build_in
       runProgramInvocation verbosity $
         (programInvocation (sh{programOverrideEnv = overEnv}) args')
-          { progInvokeCwd = Just (interpretSymbolicPathLBI lbi $ buildDir lbi)
+          { progInvokeCwd = Just build_in
           }
     Nothing -> dieWithException verbosity NotFoundMsg
   where
-    args = configureArgs backwardsCompatHack flags
+    args = configureArgs backwardsCompatHack cfg
     backwardsCompatHack = False
 
 -- | Convert Windows path to Unix ones
diff --git a/Cabal/src/Distribution/Simple/Errors.hs b/Cabal/src/Distribution/Simple/Errors.hs
@@ -114,7 +114,7 @@ data CabalException
   | CheckSemaphoreSupport
   | NoLibraryForPackage
   | SanityCheckHookedBuildInfo UnqualComponentName
-  | ConfigureScriptNotFound
+  | ConfigureScriptNotFound FilePath
   | NoValidComponent
   | ConfigureEitherSingleOrAll
   | ConfigCIDValidForPreComponent
@@ -512,7 +512,7 @@ exceptionMessage e = case e of
       ++ prettyShow exe1
       ++ "' but the package does not have a "
       ++ "executable with that name."
-  ConfigureScriptNotFound -> "configure script not found."
+  ConfigureScriptNotFound fp -> "configure script not found at " ++ fp ++ "."
   NoValidComponent -> "No valid component targets found"
   ConfigureEitherSingleOrAll -> "Can only configure either single component or all of them"
   ConfigCIDValidForPreComponent -> "--cid is only supported for per-component configure"
diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs
@@ -1470,8 +1470,8 @@ actAsSetupAction actAsSetupFlags args _globalFlags =
    in case bt of
         Simple -> Simple.defaultMainArgs args
         Configure ->
-          Simple.defaultMainWithHooksArgs
-            Simple.autoconfUserHooks
+          Simple.defaultMainWithSetupHooksArgs
+            Simple.autoconfSetupHooks
             args
         Make -> Make.defaultMainArgs args
         Hooks -> error "actAsSetupAction Hooks"
diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs
@@ -555,8 +555,8 @@ internalSetupMethod verbosity options bt args = do
 buildTypeAction :: BuildType -> ([String] -> IO ())
 buildTypeAction Simple = Simple.defaultMainArgs
 buildTypeAction Configure =
-  Simple.defaultMainWithHooksArgs
-    Simple.autoconfUserHooks
+  Simple.defaultMainWithSetupHooksArgs
+    Simple.autoconfSetupHooks
 buildTypeAction Make = Make.defaultMainArgs
 buildTypeAction Hooks  = error "buildTypeAction Hooks"
 buildTypeAction Custom = error "buildTypeAction Custom"
@@ -860,7 +860,7 @@ getExternalSetupMethod verbosity options pkg bt = do
     buildTypeScript cabalLibVersion = case bt of
       Simple -> "import Distribution.Simple; main = defaultMain\n"
       Configure
-        | cabalLibVersion >= mkVersion [1, 3, 10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"
+        | cabalLibVersion >= mkVersion [1, 3, 10] -> "import Distribution.Simple; main = defaultMainWithSetupHooks autoconfSetupHooks\n"
         | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"
       Make -> "import Distribution.Make; main = defaultMain\n"
       Hooks -> "import Distribution.Simple; import SetupHooks; main = defaultMainWithSetupHooks setupHooks\n"
