Refactor CmdInstall

CmdInstall.installAction is ~300 lines long and full of nested scopes and ad-hoc logic. This change hopes to make it more readable and understandable. - Lift withProject and withoutProject out of installAction and split their relative concerns. E.g. not parsing URIs is installAction's concern not withProject's (which would just return a constant []). - Split an intermediate step into a separate function, resolveTargetSelectorsInProjectBaseContext. - Reuse withGlobalConfig and fromPkgId (renamed) - Fix a bug introduced in 802a326 where establishProjectBaseContext is called in a non-project setting. Also simplify its original implementation by moving the change into withProject rather than calling establishProjectBaseContext a second time.
andreabedini · Feb 12, 2024 · ffe8d2c · ffe8d2c
1 parent 0a0b339
commit ffe8d2c
Show file tree

Hide file tree

Showing 6 changed files with 205 additions and 181 deletions.
diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -70,6 +70,7 @@ import Distribution.Client.ProjectConfig
   , fetchAndReadSourcePackages
   , projectConfigWithBuilderRepoContext
   , resolveBuildTimeSettings
+  , withGlobalConfig
   , withProjectOrGlobalConfig
   )
 import Distribution.Client.ProjectConfig.Types
@@ -344,153 +345,47 @@ installCommand =
 -- For more details on how this works, see the module
 -- "Distribution.Client.ProjectOrchestration"
 installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()
-installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetStrings globalFlags = do
+installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, projectFlags} targetStrings globalFlags = do
   -- Ensure there were no invalid configuration options specified.
   verifyPreconditionsOrDie verbosity configFlags'
 
   -- We cannot use establishDummyProjectBaseContext to get these flags, since
   -- it requires one of them as an argument. Normal establishProjectBaseContext
   -- does not, and this is why this is done only for the install command
-  clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'
-
+  clientInstallFlags <- getClientInstallFlags verbosity globalFlags extraFlags
+  -- FIXME: below commandLineFlagsToProjectConfig uses extraFlags
   let
     installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
-    targetFilter = if installLibs then Just LibKind else Just ExeKind
-    targetStrings' = if null targetStrings then ["."] else targetStrings
-
-    -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris.
-    -- However, we want install to also take uri arguments. Hence, we only parse uri arguments in the case where
-    -- no project file is present (including an implicit one derived from being in a package directory)
-    -- or where the --ignore-project flag is passed explicitly. In such a case we only parse colon-free target selectors
-    -- as selectors, and otherwise parse things as URIs.
-
-    -- However, in the special case where --ignore-project is passed with no selectors, we want to act as though this is
-    -- a "normal" ignore project that actually builds and installs the selected package.
-
-    withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
-    withProject = do
-      let reducedVerbosity = lessVerbose verbosity
-
-      -- First, we need to learn about what's available to be installed.
-      localBaseCtx <-
-        establishProjectBaseContext reducedVerbosity baseCliConfig InstallCommand
-      let localDistDirLayout = distDirLayout localBaseCtx
-      pkgDb <-
-        projectConfigWithBuilderRepoContext
-          reducedVerbosity
-          (buildSettings localBaseCtx)
-          (getSourcePackages verbosity)
-
-      let
-        (targetStrings'', packageIds) =
-          partitionEithers
-            . flip fmap targetStrings'
-            $ \str -> case simpleParsec str of
-              Just (pkgId :: PackageId)
-                | pkgVersion pkgId /= nullVersion -> Right pkgId
-              _ -> Left str
-        packageSpecifiers =
-          flip fmap packageIds $ \case
-            PackageIdentifier{..}
-              | pkgVersion == nullVersion -> NamedPackage pkgName []
-              | otherwise ->
-                  NamedPackage
-                    pkgName
-                    [ PackagePropertyVersion
-                        (thisVersion pkgVersion)
-                    ]
-        packageTargets =
-          flip TargetPackageNamed targetFilter . pkgName <$> packageIds
-
-      if null targetStrings'' -- if every selector is already resolved as a packageid, return without further parsing.
-        then return (packageSpecifiers, [], packageTargets, projectConfig localBaseCtx)
-        else do
-          targetSelectors <-
-            either (reportTargetSelectorProblems verbosity) return
-              =<< readTargetSelectors
-                (localPackages localBaseCtx)
-                Nothing
-                targetStrings''
-
-          (specs, selectors) <-
-            getSpecsAndTargetSelectors
-              verbosity
-              reducedVerbosity
-              pkgDb
-              targetSelectors
-              localDistDirLayout
-              localBaseCtx
-              targetFilter
-
-          return
-            ( specs ++ packageSpecifiers
-            , []
-            , selectors ++ packageTargets
-            , projectConfig localBaseCtx
-            )
-
-    withoutProject :: ProjectConfig -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
-    withoutProject _ | null targetStrings = withProject -- if there's no targets, we don't parse specially, but treat it as install in a standard cabal package dir
-    withoutProject globalConfig = do
-      tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings'
-      let
-        projectConfig = globalConfig <> baseCliConfig
-
-        ProjectConfigBuildOnly
-          { projectConfigLogsDir
-          } = projectConfigBuildOnly projectConfig
-
-        ProjectConfigShared
-          { projectConfigStoreDir
-          } = projectConfigShared projectConfig
 
-        mlogsDir = flagToMaybe projectConfigLogsDir
-        mstoreDir = flagToMaybe projectConfigStoreDir
-      cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
+    normalisedTargetStrings = if null targetStrings then ["."] else targetStrings
 
-      let
-        buildSettings =
-          resolveBuildTimeSettings
-            verbosity
-            cabalDirLayout
-            projectConfig
-
-      SourcePackageDb{packageIndex} <-
-        projectConfigWithBuilderRepoContext
-          verbosity
-          buildSettings
-          (getSourcePackages verbosity)
-
-      for_ (concatMap woPackageNames tss) $ \name -> do
-        when (null (lookupPackageName packageIndex name)) $ do
-          let xs = searchByName packageIndex (unPackageName name)
-          let emptyIf True _ = []
-              emptyIf False zs = zs
-              str2 =
-                emptyIf
-                  (null xs)
-                  [ "Did you mean any of the following?\n"
-                  , unlines (("- " ++) . unPackageName . fst <$> xs)
-                  ]
-          dieWithException verbosity $ WithoutProject (unPackageName name) str2
-
-      let
-        (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
-        packageTargets = map woPackageTargets tss
-
-      return (packageSpecifiers, uris, packageTargets, projectConfig)
+  -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris.
+  -- However, we want install to also take uri arguments. Hence, we only parse uri arguments in the case where
+  -- no project file is present (including an implicit one derived from being in a package directory)
+  -- or where the --ignore-project flag is passed explicitly. In such a case we only parse colon-free target selectors
+  -- as selectors, and otherwise parse things as URIs.
 
-  (specs, uris, targetSelectors, baseConfig) <-
-    withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject
+  -- However, in the special case where --ignore-project is passed with no selectors, we want to act as though this is
+  -- a "normal" ignore project that actually builds and installs the selected package.
 
-  -- We compute the base context again to determine packages available in the
-  -- project to be installed, so we can list the available package names when
-  -- the "all:..." variants of the target selectors are used.
-  localPkgs <- localPackages <$> establishProjectBaseContext verbosity baseConfig InstallCommand
+  (specs, uris, targetSelectors, config) <-
+    let
+      with = do
+        (specs, targetSelectors, baseConfig) <-
+          withProject verbosity cliConfig normalisedTargetStrings installLibs
+        -- no URIs in this case
+        return (specs, [], targetSelectors, baseConfig)
+
+      without =
+        withGlobalConfig verbosity globalConfigFlag $ \globalConfig ->
+          withoutProject verbosity (globalConfig <> cliConfig) normalisedTargetStrings
+     in
+      -- if there's no targets, we don't parse specially, but treat it as install in a standard cabal package dir
+      if null targetStrings
+        then with
+        else withProjectOrGlobalConfig ignoreProject with without
 
   let
-    config = addLocalConfigToPkgs baseConfig (map pkgSpecifierTarget specs ++ concatMap (targetPkgNames localPkgs) targetSelectors)
-
     ProjectConfig
       { projectConfigBuildOnly =
         ProjectConfigBuildOnly
@@ -635,12 +530,13 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
     configFlags' = disableTestsBenchsByDefault configFlags
     verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
     ignoreProject = flagIgnoreProject projectFlags
-    baseCliConfig =
+    cliConfig =
       commandLineFlagsToProjectConfig
         globalFlags
         flags{configFlags = configFlags'}
-        clientInstallFlags'
-    globalConfigFlag = projectConfigConfigFile (projectConfigShared baseCliConfig)
+        extraFlags
+
+    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
 
     -- Do the install action for each executable in the install configuration.
     traverseInstall :: InstallAction -> InstallCfg -> IO ()
@@ -649,7 +545,133 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt
       actionOnExe <- action v overwritePolicy <$> prepareExeInstall cfg
       traverse_ actionOnExe . Map.toList $ targetsMap buildCtx
 
--- | Treat all direct targets of install command as local packages: #8637 and later #7297, #8909, #7236.
+withProject
+  :: Verbosity
+  -> ProjectConfig
+  -> [String]
+  -> Bool
+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig)
+withProject verbosity cliConfig targetStrings installLibs = do
+  -- First, we need to learn about what's available to be installed.
+  baseCtx <- establishProjectBaseContext reducedVerbosity cliConfig InstallCommand
+
+  (specs, selectors) <-
+    -- if every selector is already resolved as a packageid, return without further parsing.
+    if null unresolvedTargetStrings
+      then return (parsedSpecifiers, parsedTargets)
+      else do
+        (resolvedSpecifiers, resolvedTargets) <-
+          resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targetFilter
+        return (resolvedSpecifiers ++ parsedSpecifiers, resolvedTargets ++ parsedTargets)
+
+  -- Treat all direct targets of install command as local packages: #8637 and later #7297, #8909, #7236.
+  let config =
+        addLocalConfigToPkgs (projectConfig baseCtx) $
+          -- specifiers
+          map pkgSpecifierTarget specs
+            -- selectors
+            ++ concatMap (targetPkgNames $ localPackages baseCtx) selectors
+
+  return (specs, selectors, config)
+  where
+    reducedVerbosity = lessVerbose verbosity
+
+    (unresolvedTargetStrings, parsedPackageIds) =
+      partitionEithers $
+        flip map targetStrings $ \s ->
+          case eitherParsec s of
+            Right pkgId@PackageIdentifier{pkgVersion}
+              | pkgVersion /= nullVersion ->
+                  pure pkgId
+            _ -> Left s
+
+    parsedSpecifiers :: [PackageSpecifier pkg]
+    parsedSpecifiers = map specFromPkgId parsedPackageIds
+
+    parsedTargets :: [TargetSelector]
+    parsedTargets =
+      [TargetPackageNamed (pkgName pkgId) targetFilter | pkgId <- parsedPackageIds]
+
+    targetFilter = if installLibs then Just LibKind else Just ExeKind
+
+resolveTargetSelectorsInProjectBaseContext
+  :: Verbosity
+  -> ProjectBaseContext
+  -> [String]
+  -> Maybe ComponentKindFilter
+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
+resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targetFilter = do
+  let reducedVerbosity = lessVerbose verbosity
+
+  pkgDb <-
+    projectConfigWithBuilderRepoContext
+      reducedVerbosity
+      (buildSettings baseCtx)
+      (getSourcePackages verbosity)
+
+  targetSelectors <-
+    readTargetSelectors (localPackages baseCtx) Nothing targetStrings
+      >>= \case
+        Left problems -> reportTargetSelectorProblems verbosity problems
+        Right ts -> return ts
+
+  getSpecsAndTargetSelectors
+    verbosity
+    reducedVerbosity
+    pkgDb
+    targetSelectors
+    (distDirLayout baseCtx)
+    baseCtx
+    targetFilter
+
+withoutProject
+  :: Verbosity
+  -> ProjectConfig
+  -> [String]
+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
+withoutProject verbosity globalConfig targetStrings = do
+  tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings
+  let
+    ProjectConfigBuildOnly
+      { projectConfigLogsDir
+      } = projectConfigBuildOnly globalConfig
+
+    ProjectConfigShared
+      { projectConfigStoreDir
+      } = projectConfigShared globalConfig
+
+    mlogsDir = flagToMaybe projectConfigLogsDir
+    mstoreDir = flagToMaybe projectConfigStoreDir
+
+  cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
+
+  let buildSettings = resolveBuildTimeSettings verbosity cabalDirLayout globalConfig
+
+  SourcePackageDb{packageIndex} <-
+    projectConfigWithBuilderRepoContext
+      verbosity
+      buildSettings
+      (getSourcePackages verbosity)
+
+  for_ (concatMap woPackageNames tss) $ \name -> do
+    when (null (lookupPackageName packageIndex name)) $ do
+      let xs = searchByName packageIndex (unPackageName name)
+      let emptyIf True _ = []
+          emptyIf False zs = zs
+          str2 =
+            emptyIf
+              (null xs)
+              [ "Did you mean any of the following?\n"
+              , unlines (("- " ++) . unPackageName . fst <$> xs)
+              ]
+      dieWithException verbosity $ WithoutProject (unPackageName name) str2
+
+  let
+    (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
+    packageTargets = map woPackageTargets tss
+
+  return (packageSpecifiers, uris, packageTargets, globalConfig)
+
 addLocalConfigToPkgs :: ProjectConfig -> [PackageName] -> ProjectConfig
 addLocalConfigToPkgs config pkgs =
   config
@@ -707,8 +729,8 @@ getSpecsAndTargetSelectors
   -> ProjectBaseContext
   -> Maybe ComponentKindFilter
   -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
-getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =
-  withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do
+getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors distDirLayout baseCtx targetFilter =
+  withInstallPlan reducedVerbosity baseCtx $ \elaboratedPlan _ -> do
     -- Split into known targets and hackage packages.
     (targets, hackageNames) <-
       partitionToKnownTargetsAndHackagePackages
@@ -724,11 +746,11 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors loca
       sdistize (SpecificSourcePackage spkg) =
         SpecificSourcePackage spkg'
         where
-          sdistPath = distSdistFile localDistDirLayout (packageId spkg)
+          sdistPath = distSdistFile distDirLayout (packageId spkg)
           spkg' = spkg{srcpkgSource = LocalTarballPackage sdistPath}
       sdistize named = named
 
-      local = sdistize <$> localPackages localBaseCtx
+      local = sdistize <$> localPackages baseCtx
 
       gatherTargets :: UnitId -> TargetSelector
       gatherTargets targetId = TargetPackageNamed pkgName targetFilter
@@ -745,15 +767,15 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors loca
       hackageTargets =
         flip TargetPackageNamed targetFilter <$> hackageNames
 
-    createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)
+    createDirectoryIfMissing True (distSdistDirectory distDirLayout)
 
-    unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of
+    unless (Map.null targets) $ for_ (localPackages baseCtx) $ \case
       SpecificSourcePackage pkg ->
         packageToSdist
           verbosity
-          (distProjectRootDirectory localDistDirLayout)
+          (distProjectRootDirectory distDirLayout)
           TarGzArchive
-          (distSdistFile localDistDirLayout (packageId pkg))
+          (distSdistFile distDirLayout (packageId pkg))
           pkg
       NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName