From ffe8d2c3560d344656a16213f5080f8ec82381e6 Mon Sep 17 00:00:00 2001 From: Andrea Bedini Date: Mon, 12 Feb 2024 14:05:21 +0800 Subject: [PATCH] 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 802a326fd40bd6f1470114317a807f6c3b198dfa 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. --- .../src/Distribution/Client/CmdInstall.hs | 312 ++++++++++-------- .../CmdInstall/ClientInstallTargetSelector.hs | 21 +- .../src/Distribution/Client/CmdSdist.hs | 7 +- .../src/Distribution/Client/CmdUpdate.hs | 5 +- .../src/Distribution/Client/ProjectConfig.hs | 35 +- .../src/Distribution/Client/ScriptUtils.hs | 6 +- 6 files changed, 205 insertions(+), 181 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index f4afb68868a..af998699b15 100644 --- 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 diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs index c6939729f61..8ee00cd3e10 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs @@ -4,6 +4,7 @@ module Distribution.Client.CmdInstall.ClientInstallTargetSelector , woPackageNames , woPackageTargets , woPackageSpecifiers + , specFromPkgId ) where import Distribution.Client.Compat.Prelude @@ -57,15 +58,15 @@ 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 (specFromPkgId pid) +woPackageSpecifiers (WoPackageComponent pid _) = Right (specFromPkgId 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)) - ] +specFromPkgId :: PackageId -> PackageSpecifier pkg +specFromPkgId pkgId = + NamedPackage + (pkgName pkgId) + ( if pkgVersion pkgId == nullVersion + then [] + else [PackagePropertyVersion (thisVersion (pkgVersion pkgId))] + ) diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index c77c1eae910..a1142b06a27 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/CmdUpdate.hs b/cabal-install/src/Distribution/Client/CmdUpdate.hs index c0f4e05a137..052c8d60edd 100644 --- a/cabal-install/src/Distribution/Client/CmdUpdate.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index b4d20e317cc..777238d2516 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -621,32 +621,25 @@ 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) @@ -654,8 +647,8 @@ withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do , 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 diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index e66117414a8..1793f6aa07d 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/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 ':'.