project planning: fix haskell#10686 regression

We previously only fetched the compiler in
`instantiateProjectConfigSkeletonFetchingCompiler` if
`null (toListOf traverseCondTreeV skel)` was false.

c89ab54 changed this to always
configure the compiler, such that it could be later re-used when
determining whether jsem was supported to clone git submodules
concurrently.

This patch allows for the JobControl concurrency mechanism to be
controlled without a compiler (which assumes -jsem is not supported),
and restores the behaviour of not always configuring the compiler.

Fixes haskell#10686

Author: alt-romes

cabal-install/src/Distribution/Client/CmdInstall.hs

@@ -467,7 +467,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project
         fetchAndReadSourcePackages
           verbosity
           distDirLayout
-          compiler
+          (Just compiler)
           (projectConfigShared config)
           (projectConfigBuildOnly config)
           [ProjectPackageRemoteTarball uri | uri <- uris]

cabal-install/src/Distribution/Client/JobControl.hs

@@ -277,20 +277,28 @@ criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
 
 newJobControlFromParStrat
   :: Verbosity
-  -> Compiler
+  -> Maybe Compiler
+  -- ^ The compiler, used to determine whether Jsem is supported.
+  -- When Nothing, Jsem is assumed to be unsupported.
   -> ParStratInstall
   -- ^ The parallel strategy
   -> Maybe Int
   -- ^ A cap on the number of jobs (e.g. to force a maximum of 2 concurrent downloads despite a -j8 parallel strategy)
   -> IO (JobControl IO a)
-newJobControlFromParStrat verbosity compiler parStrat numJobsCap = case parStrat of
+newJobControlFromParStrat verbosity mcompiler parStrat numJobsCap = case parStrat of
   Serial -> newSerialJobControl
   NumJobs n -> newParallelJobControl (capJobs (fromMaybe numberOfProcessors n))
   UseSem n ->
-    if jsemSupported compiler
-      then newSemaphoreJobControl verbosity (capJobs n)
-      else do
-        warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
+    case mcompiler of
+      Just compiler
+        | jsemSupported compiler ->
+            newSemaphoreJobControl verbosity (capJobs n)
+        | otherwise ->
+            do
+              warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
+              newParallelJobControl (capJobs n)
+      Nothing ->
+        -- Don't warn in the Nothing case, as there isn't really a "selected" compiler.
         newParallelJobControl (capJobs n)
   where
     capJobs n = min (fromMaybe maxBound numJobsCap) n

cabal-install/src/Distribution/Client/ProjectBuilding.hs

@@ -369,7 +369,7 @@ rebuildTargets
 
         -- Concurrency control: create the job controller and concurrency limits
         -- for downloading, building and installing.
-        withJobControl (newJobControlFromParStrat verbosity compiler buildSettingNumJobs Nothing) $ \jobControl -> do
+        withJobControl (newJobControlFromParStrat verbosity (Just compiler) buildSettingNumJobs Nothing) $ \jobControl -> do
           -- Before traversing the install plan, preemptively find all packages that
           -- will need to be downloaded and start downloading them.
           asyncDownloadPackages

cabal-install/src/Distribution/Client/ProjectConfig.hs

@@ -1261,7 +1261,7 @@ mplusMaybeT ma mb = do
 fetchAndReadSourcePackages
   :: Verbosity
   -> DistDirLayout
-  -> Compiler
+  -> Maybe Compiler
   -> ProjectConfigShared
   -> ProjectConfigBuildOnly
   -> [ProjectPackageLocation]
@@ -1425,7 +1425,7 @@ fetchAndReadSourcePackageRemoteTarball
 syncAndReadSourcePackagesRemoteRepos
   :: Verbosity
   -> DistDirLayout
-  -> Compiler
+  -> Maybe Compiler
   -> ProjectConfigShared
   -> ProjectConfigBuildOnly
   -> Bool

cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs

@@ -84,9 +84,11 @@ import Distribution.PackageDescription
   )
 import Distribution.PackageDescription.Configuration (simplifyWithSysParams)
 import Distribution.Simple.Compiler
-  ( CompilerInfo (..)
+  ( Compiler (..)
+  , CompilerInfo (..)
   , DebugInfoLevel (..)
   , OptimisationLevel (..)
+  , compilerInfo
   , interpretPackageDB
   )
 import Distribution.Simple.InstallDirs (CopyDest (NoCopyDest))
@@ -216,10 +218,13 @@ type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigPath] ProjectConfig
 singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
 singletonProjectConfigSkeleton x = CondNode x mempty mempty
 
-instantiateProjectConfigSkeletonFetchingCompiler :: (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
-instantiateProjectConfigSkeletonFetchingCompiler (os, arch, impl) flags skel
-  | null (toListOf traverseCondTreeV skel) = fst (ignoreConditions skel)
-  | otherwise = instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
+instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, Compiler) -> FlagAssignment -> ProjectConfigSkeleton -> m (ProjectConfig, Maybe Compiler)
+instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel
+  | null (toListOf traverseCondTreeV skel) = pure (fst (ignoreConditions skel), Nothing)
+  | otherwise = do
+      (os, arch, comp) <- fetch
+      let conf = instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo comp) flags skel
+      pure (conf, Just comp)
 
 instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
 instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel

cabal-install/src/Distribution/Client/ProjectPlanning.hs

@@ -394,11 +394,13 @@ rebuildProjectConfig
           liftIO $ info verbosity "Project settings changed, reconfiguring..."
           projectConfigSkeleton <- phaseReadProjectConfig
 
-          -- have to create the cache directory before configuring the compiler
-          liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
-          (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
+          let fetchCompiler = do
+                -- have to create the cache directory before configuring the compiler
+                liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
+                (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout (fst (PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
+                pure (os, arch, compiler)
 
-          let projectConfig = instantiateProjectConfigSkeletonFetchingCompiler (os, arch, compilerInfo compiler) mempty projectConfigSkeleton
+          (projectConfig, compiler) <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
           when (projectConfigDistDir (projectConfigShared $ projectConfig) /= NoFlag) $
             liftIO $
               warn verbosity "The builddir option is not supported in project and config files. It will be ignored."
@@ -434,7 +436,7 @@ rebuildProjectConfig
       -- NOTE: These are all packages mentioned in the project configuration.
       -- Whether or not they will be considered local to the project will be decided by `shouldBeLocal`.
       phaseReadLocalPackages
-        :: Compiler
+        :: Maybe Compiler
         -> ProjectConfig
         -> Rebuild [PackageSpecifier UnresolvedSourcePackage]
       phaseReadLocalPackages

cabal-install/src/Distribution/Client/ScriptUtils.hs

@@ -117,7 +117,6 @@ import qualified Distribution.SPDX.License as SPDX
 import Distribution.Simple.Compiler
   ( Compiler (..)
   , OptimisationLevel (..)
-  , compilerInfo
   )
 import Distribution.Simple.Flag
   ( flagToMaybe
@@ -381,7 +380,7 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo
           createDirectoryIfMissingVerbose verbosity True (distProjectCacheDirectory $ distDirLayout ctx)
           (compiler, platform@(Platform arch os), _) <- runRebuild projectRoot $ configureCompiler verbosity (distDirLayout ctx) (fst (ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
 
-          let projectCfg = instantiateProjectConfigSkeletonFetchingCompiler (os, arch, compilerInfo compiler) mempty projectCfgSkeleton
+          (projectCfg, _) <- instantiateProjectConfigSkeletonFetchingCompiler (pure (os, arch, compiler)) mempty projectCfgSkeleton
 
           let ctx' = ctx & lProjectConfig %~ (<> projectCfg)