Merge branch 'master' into add_profiling_guide

.github/mergify.yml

@@ -97,10 +97,6 @@ pull_request_rules:
       - label=merge delay passed
       - '#approved-reviews-by>=2'
       - '-label~=^blocked:'
-      # unlike the others, we need to force this one to be up to date
-      # because it's intended for when Mergify doesn't have permission
-      # to rebase
-      - '#commits-behind=0'
 
   # merge strategy for release branches
   - actions:

Cabal/src/Distribution/Simple/Utils.hs

@@ -534,7 +534,7 @@ verbosityHandle verbosity
 warn :: Verbosity -> String -> IO ()
 warn verbosity msg = warnMessage "Warning" verbosity msg
 
--- | Like 'warn', but prepend @Error: …@ instead of @Waring: …@ before the
+-- | Like 'warn', but prepend @Error: …@ instead of @Warning: …@ before the
 -- the message. Useful when you want to highlight the condition is an error
 -- but do not want to quit the program yet.
 warnError :: Verbosity -> String -> IO ()

Makefile

@@ -49,12 +49,18 @@ whitespace: ## Run fix-whitespace in check mode
 fix-whitespace: ## Run fix-whitespace in fix mode
 	fix-whitespace --verbose
 
+.PHONY: lint
+lint: ## Run HLint
+	hlint -j .
+
+.PHONY: lint-json
+lint-json: ## Run HLint in JSON mode
+	hlint -j --json -- .
+
 # local checks
 
 .PHONY: checks
-checks: whitespace style
-	# this should probably be a rule
-	hlint -j --json -- .
+checks: whitespace style lint-json
 
 # source generation: SPDX
 

cabal-install-solver/src/Distribution/Solver/Types/ProjectConfigPath.hs

@@ -16,6 +16,7 @@ module Distribution.Solver.Types.ProjectConfigPath
 
     -- * Checks and Normalization
     , isCyclicConfigPath
+    , isTopLevelConfigPath
     , canonicalizeConfigPath
     ) where
 
@@ -138,6 +139,11 @@ nullProjectConfigPath = ProjectConfigPath $ "unused" :| []
 isCyclicConfigPath :: ProjectConfigPath -> Bool
 isCyclicConfigPath (ProjectConfigPath p) = length p /= length (NE.nub p)
 
+-- | Check if the project config path is top-level, meaning it was not included by
+-- some other project config.
+isTopLevelConfigPath :: ProjectConfigPath -> Bool
+isTopLevelConfigPath (ProjectConfigPath p) = NE.length p == 1
+
 -- | Prepends the path of the importee to the importer path.
 consProjectConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath
 consProjectConfigPath p ps = ProjectConfigPath (p <| coerce ps)

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

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

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

@@ -95,7 +95,7 @@ pathCommand :: CommandUI (NixStyleFlags PathFlags)
 pathCommand =
   CommandUI
     { commandName = "path"
-    , commandSynopsis = "Query for simple project information"
+    , commandSynopsis = "Query for simple project information."
     , commandDescription = Just $ \_ ->
         wrapText $
           "Query for configuration and project information such as project GHC.\n"

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

@@ -457,8 +457,8 @@ readRepoIndex verbosity repoCtxt repo idxState =
       if isDoesNotExistError e
         then do
           case repo of
-            RepoRemote{..} -> dieWithException verbosity $ MissingPackageList repoRemote
-            RepoSecure{..} -> dieWithException verbosity $ MissingPackageList repoRemote
+            RepoRemote{..} -> warn verbosity $ exceptionMessageCabalInstall $ MissingPackageList repoRemote
+            RepoSecure{..} -> warn verbosity $ exceptionMessageCabalInstall $ MissingPackageList repoRemote
             RepoLocalNoIndex local _ ->
               warn verbosity $
                 "Error during construction of local+noindex "

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

@@ -142,6 +142,7 @@ import Distribution.Solver.Types.PkgConfigDb
 import Distribution.Solver.Types.Settings
 import Distribution.Solver.Types.SourcePackage as SourcePackage
 
+import Distribution.Client.ProjectConfig
 import Distribution.Client.Utils
   ( MergeResult (..)
   , ProgressPhase (..)
@@ -1443,7 +1444,7 @@ performInstallations
       if parallelInstall
         then newParallelJobControl numJobs
         else newSerialJobControl
-    fetchLimit <- newJobLimit (min numJobs numFetchJobs)
+    fetchLimit <- newJobLimit (min numJobs maxNumFetchJobs)
     installLock <- newLock -- serialise installation
     cacheLock <- newLock -- serialise access to setup exe cache
     executeInstallPlan
@@ -1486,7 +1487,6 @@ performInstallations
       cinfo = compilerInfo comp
 
       numJobs = determineNumJobs (installNumJobs installFlags)
-      numFetchJobs = 2
       parallelInstall = numJobs >= 2
       keepGoing = fromFlag (installKeepGoing installFlags)
       distPref =

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

@@ -31,6 +31,11 @@ module Distribution.Client.JobControl
   , Lock
   , newLock
   , criticalSection
+
+    -- * Higher level utils
+  , newJobControlFromParStrat
+  , withJobControl
+  , mapConcurrentWithJobs
   ) where
 
 import Distribution.Client.Compat.Prelude
@@ -40,11 +45,14 @@ import Control.Concurrent (forkIO, forkIOWithUnmask, threadDelay)
 import Control.Concurrent.MVar
 import Control.Concurrent.STM (STM, TVar, atomically, modifyTVar', newTVarIO, readTVar)
 import Control.Concurrent.STM.TChan
-import Control.Exception (bracket_, mask_, try)
+import Control.Exception (bracket, bracket_, mask_, try)
 import Control.Monad (forever, replicateM_)
 import Distribution.Client.Compat.Semaphore
+import Distribution.Client.Utils (numberOfProcessors)
 import Distribution.Compat.Stack
+import Distribution.Simple.Compiler
 import Distribution.Simple.Utils
+import Distribution.Types.ParStrat
 import System.Semaphore
 
 -- | A simple concurrency abstraction. Jobs can be spawned and can complete
@@ -262,3 +270,38 @@ newLock = fmap Lock $ newMVar ()
 
 criticalSection :: Lock -> IO a -> IO a
 criticalSection (Lock lck) act = bracket_ (takeMVar lck) (putMVar lck ()) act
+
+--------------------------------------------------------------------------------
+-- More high level utils
+--------------------------------------------------------------------------------
+
+newJobControlFromParStrat
+  :: Verbosity
+  -> Compiler
+  -> 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
+  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."
+        newParallelJobControl (capJobs n)
+  where
+    capJobs n = min (fromMaybe maxBound numJobsCap) n
+
+withJobControl :: IO (JobControl IO a) -> (JobControl IO a -> IO b) -> IO b
+withJobControl mkJC = bracket mkJC cleanupJobControl
+
+-- | Concurrently execute actions on a list using the given JobControl.
+-- The maximum number of concurrent jobs is tied to the JobControl instance.
+-- The resulting list does /not/ preserve the original order!
+mapConcurrentWithJobs :: JobControl IO b -> (a -> IO b) -> [a] -> IO [b]
+mapConcurrentWithJobs jobControl f xs = do
+  traverse_ (spawnJob jobControl . f) xs
+  traverse (const $ collectJob jobControl) xs

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

@@ -236,6 +236,7 @@ import Distribution.Simple.Utils
   , notice
   , topHandler
   , tryFindPackageDesc
+  , warn
   )
 import Distribution.Text
   ( display
@@ -1343,6 +1344,7 @@ checkAction checkFlags extraArgs _globalFlags = do
 formatAction :: Flag Verbosity -> [String] -> Action
 formatAction verbosityFlag extraArgs _globalFlags = do
   let verbosity = fromFlag verbosityFlag
+  warn verbosity "This command is not a full formatter yet"
   path <- case extraArgs of
     [] -> relativeSymbolicPath <$> tryFindPackageDesc verbosity Nothing
     (p : _) -> return $ makeSymbolicPath p

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

@@ -1,6 +1,8 @@
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 -----------------------------------------------------------------------------
 
@@ -53,6 +55,7 @@ import Distribution.Deprecated.ParseUtils
   ( Field (..)
   , FieldDescr (..)
   , LineNo
+  , PError (..)
   , ParseResult (..)
   , liftField
   , lineNo
@@ -292,13 +295,16 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
     setField a (F line name value) =
       case Map.lookup name fieldMap of
         Just (FieldDescr _ _ set) -> set line value a
-        Nothing -> do
-          warning $
-            "Unrecognized field '"
-              ++ name
-              ++ "' on line "
-              ++ show line
-          return a
+        Nothing ->
+          case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of
+            Just _ -> ParseFailed $ FieldShouldBeStanza name line
+            Nothing -> do
+              warning $
+                "Unrecognized field '"
+                  ++ name
+                  ++ "' on line "
+                  ++ show line
+              return a
     setField a (Section line name param fields) =
       case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of
         Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do

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

@@ -88,7 +88,7 @@ import qualified Data.Set as Set
 
 import qualified Text.PrettyPrint as Disp
 
-import Control.Exception (assert, bracket, handle)
+import Control.Exception (assert, handle)
 import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
 import System.FilePath (makeRelative, normalise, takeDirectory, (<.>), (</>))
 import System.Semaphore (SemaphoreName (..))
@@ -98,7 +98,6 @@ import Distribution.Simple.Flag (fromFlagOrDefault)
 
 import Distribution.Client.ProjectBuilding.PackageFileMonitor
 import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage)
-import Distribution.Client.Utils (numberOfProcessors)
 
 ------------------------------------------------------------------------------
 
@@ -355,17 +354,6 @@ rebuildTargets
     }
     | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
     | otherwise = do
-        -- Concurrency control: create the job controller and concurrency limits
-        -- for downloading, building and installing.
-        mkJobControl <- case buildSettingNumJobs of
-          Serial -> newSerialJobControl
-          NumJobs n -> newParallelJobControl (fromMaybe numberOfProcessors n)
-          UseSem n ->
-            if jsemSupported compiler
-              then newSemaphoreJobControl verbosity n
-              else do
-                warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
-                newParallelJobControl n
         registerLock <- newLock -- serialise registration
         cacheLock <- newLock -- serialise access to setup exe cache
         -- TODO: [code cleanup] eliminate setup exe cache
@@ -380,7 +368,9 @@ rebuildTargets
         createDirectoryIfMissingVerbose verbosity True distTempDirectory
         traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
 
-        bracket (pure mkJobControl) cleanupJobControl $ \jobControl -> do
+        -- Concurrency control: create the job controller and concurrency limits
+        -- for downloading, building and installing.
+        withJobControl (newJobControlFromParStrat verbosity 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
@@ -391,7 +381,7 @@ rebuildTargets
             $ \downloadMap ->
               -- For each package in the plan, in dependency order, but in parallel...
               InstallPlan.execute
-                mkJobControl
+                jobControl
                 keepGoing
                 (BuildFailure Nothing . DependentFailed . packageId)
                 installPlan