Refactor CmdInstall / fix bug in #9697

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

@@ -18,8 +18,6 @@ import Distribution.Compat.CharParsing (char, optional)
 import Distribution.Package
 import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName))
 import Distribution.Simple.Utils (dieWithException)
-import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
-import Distribution.Version
 
 data WithoutProjectTargetSelector
   = WoPackageId PackageId
@@ -57,15 +55,6 @@ woPackageTargets (WoURI _) =
   TargetAllPackages (Just ExeKind)
 
 woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)
-woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid)
-woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid)
+woPackageSpecifiers (WoPackageId pid) = Right (mkNamedPackage pid)
+woPackageSpecifiers (WoPackageComponent pid _) = Right (mkNamedPackage pid)
 woPackageSpecifiers (WoURI uri) = Left uri
-
-pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg
-pidPackageSpecifiers pid
-  | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) []
-  | otherwise =
-      NamedPackage
-        (pkgName pid)
-        [ PackagePropertyVersion (thisVersion (pkgVersion pid))
-        ]

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

@@ -32,6 +32,7 @@ import Distribution.Client.ProjectConfig
   , commandLineFlagsToProjectConfig
   , projectConfigConfigFile
   , projectConfigShared
+  , withGlobalConfig
   , withProjectOrGlobalConfig
   )
 import Distribution.Client.ProjectFlags
@@ -219,7 +220,11 @@ sdistOptions showOrParseArgs =
 
 sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()
 sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
-  (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject
+  (baseCtx, distDirLayout) <-
+    withProjectOrGlobalConfig
+      flagIgnoreProject
+      withProject
+      (withGlobalConfig verbosity globalConfigFlag withoutProject)
 
   let localPkgs = localPackages baseCtx
 

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

@@ -48,6 +48,7 @@ import Distribution.Client.ProjectConfig
   ( ProjectConfig (..)
   , ProjectConfigShared (projectConfigConfigFile)
   , projectConfigWithSolverRepoContext
+  , withGlobalConfig
   , withProjectOrGlobalConfig
   )
 import Distribution.Client.ProjectFlags
@@ -162,11 +163,9 @@ updateAction flags@NixStyleFlags{..} extraArgs globalFlags = do
 
   projectConfig <-
     withProjectOrGlobalConfig
-      verbosity
       ignoreProject
-      globalConfigFlag
       (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)
-      (\globalConfig -> return $ globalConfig <> cliConfig)
+      (withGlobalConfig verbosity globalConfigFlag $ \globalConfig -> return $ globalConfig <> cliConfig)
 
   projectConfigWithSolverRepoContext
     verbosity

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

@@ -621,41 +621,34 @@ withGlobalConfig verbosity gcf with = do
   with globalConfig
 
 withProjectOrGlobalConfig
-  :: Verbosity
-  -- ^ verbosity
-  -> Flag Bool
+  :: Flag Bool
   -- ^ whether to ignore local project (--ignore-project flag)
-  -> Flag FilePath
-  -- ^ @--cabal-config@
   -> IO a
-  -- ^ with project
-  -> (ProjectConfig -> IO a)
-  -- ^ without project
+  -- ^ continuation with project
   -> IO a
-withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do
-  globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf
-  without globalConfig
-withProjectOrGlobalConfig verbosity _ignorePrj gcf with without =
-  withProjectOrGlobalConfig' verbosity gcf with without
+  -- ^ continuation without project
+  -> IO a
+withProjectOrGlobalConfig (Flag True) _with without = do
+  without
+withProjectOrGlobalConfig _ignorePrj with without =
+  withProjectOrGlobalConfig' with without
 
 withProjectOrGlobalConfig'
-  :: Verbosity
-  -> Flag FilePath
+  :: IO a
+  -- ^ continuation with project
   -> IO a
-  -> (ProjectConfig -> IO a)
+  -- ^ continuation without project
   -> IO a
-withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do
-  globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
-
+withProjectOrGlobalConfig' with without = do
   catch with $
     \case
       (BadPackageLocations prov locs)
         | prov == Set.singleton Implicit
         , let
             isGlobErr (BadLocGlobEmptyMatch _) = True
             isGlobErr _ = False
-        , any isGlobErr locs ->
-            without globalConfig
+        , any isGlobErr locs -> do
+            without
       err -> throwIO err
 
 -- | Read all the config relevant for a project. This includes the project
@@ -956,7 +949,7 @@ renderBadPackageLocationMatch bplm = case bplm of
       ++ "' contains multiple "
       ++ ".cabal files (which is not currently supported)."
 
--- | Given the project config,
+-- | Determines the location of all packages mentioned in the project configuration.
 --
 -- Throws 'BadPackageLocations'.
 findProjectPackages
@@ -986,11 +979,7 @@ findProjectPackages
       findPackageLocation
         :: Bool
         -> String
-        -> Rebuild
-            ( Either
-                BadPackageLocation
-                [ProjectPackageLocation]
-            )
+        -> Rebuild (Either BadPackageLocation [ProjectPackageLocation])
       findPackageLocation _required@True pkglocstr =
         -- strategy: try first as a file:// or http(s):// URL.
         -- then as a file glob (usually encompassing single file)
@@ -1011,13 +1000,7 @@ findProjectPackages
         , checkIsFileGlobPackage
         , checkIsSingleFilePackage
           :: String
-          -> Rebuild
-              ( Maybe
-                  ( Either
-                      BadPackageLocation
-                      [ProjectPackageLocation]
-                  )
-              )
+          -> Rebuild (Maybe (Either BadPackageLocation [ProjectPackageLocation]))
       checkIsUriPackage pkglocstr =
         case parseAbsoluteURI pkglocstr of
           Just

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

@@ -237,6 +237,9 @@ data ProjectBaseContext = ProjectBaseContext
   , cabalDirLayout :: CabalDirLayout
   , projectConfig :: ProjectConfig
   , localPackages :: [PackageSpecifier UnresolvedSourcePackage]
+  -- ^ Note: these are all the packages mentioned in the project configuration.
+  -- Whether or not they will be considered local to the project will be decided
+  -- by `shouldBeLocal` in ProjectPlanning.
   , buildSettings :: BuildTimeSettings
   , currentCommand :: CurrentCommand
   , installedPackages :: Maybe InstalledPackageIndex

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

@@ -409,6 +409,8 @@ rebuildProjectConfig
       -- Look for all the cabal packages in the project
       -- some of which may be local src dirs, tarballs etc
       --
+      -- 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
         :: ProjectConfig
         -> Rebuild [PackageSpecifier UnresolvedSourcePackage]

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

@@ -292,7 +292,11 @@ withContextAndSelectors
   -> IO b
 withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act =
   withTemporaryTempDirectory $ \mkTmpDir -> do
-    (tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject (withoutProject mkTmpDir)
+    (tc, ctx) <-
+      withProjectOrGlobalConfig
+        ignoreProject
+        withProject
+        (withGlobalConfig verbosity globalConfigFlag $ withoutProject mkTmpDir)
 
     (tc', ctx', sels) <- case targetStrings of
       -- Only script targets may contain spaces and or end with ':'.

cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs

@@ -5,14 +5,15 @@ module Distribution.Client.Types.PackageSpecifier
   ( PackageSpecifier (..)
   , pkgSpecifierTarget
   , pkgSpecifierConstraints
+  , mkNamedPackage
   ) where
 
 import Distribution.Client.Compat.Prelude
 import Prelude ()
 
-import Distribution.Package (Package (..), packageName, packageVersion)
+import Distribution.Package (Package (..), PackageIdentifier (..), packageName, packageVersion)
 import Distribution.Types.PackageName (PackageName)
-import Distribution.Version (thisVersion)
+import Distribution.Version (nullVersion, thisVersion)
 
 import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.LabeledPackageConstraint
@@ -53,3 +54,12 @@ pkgSpecifierConstraints (SpecificSourcePackage pkg) =
       PackageConstraint
         (ScopeTarget $ packageName pkg)
         (PackagePropertyVersion $ thisVersion (packageVersion pkg))
+
+mkNamedPackage :: PackageIdentifier -> PackageSpecifier pkg
+mkNamedPackage pkgId =
+  NamedPackage
+    (pkgName pkgId)
+    ( if pkgVersion pkgId == nullVersion
+        then []
+        else [PackagePropertyVersion (thisVersion (pkgVersion pkgId))]
+    )