From 4d55140caab923044b56414fe7e241f6689111d6 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 specFromPkgId (renamed from pidPackageSpecifiers). - Avoid trying withProject a second time in case no target is specified. - 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. - Document the interaction between cabal v2-install and local configuration and add few comments. --- .../src/Distribution/Client/CmdInstall.hs | 367 ++++++++++-------- .../CmdInstall/ClientInstallTargetSelector.hs | 15 +- .../src/Distribution/Client/CmdSdist.hs | 7 +- .../src/Distribution/Client/CmdUpdate.hs | 5 +- .../src/Distribution/Client/ProjectConfig.hs | 51 +-- .../Client/ProjectOrchestration.hs | 3 + .../Distribution/Client/ProjectPlanning.hs | 2 + .../src/Distribution/Client/ScriptUtils.hs | 6 +- .../Client/Types/PackageSpecifier.hs | 14 +- 9 files changed, 253 insertions(+), 217 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index f4afb68868a..0fe76ceacae 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 @@ -105,6 +106,7 @@ import Distribution.Client.Types , PackageSpecifier (..) , SourcePackageDb (..) , UnresolvedSourcePackage + , mkNamedPackage , pkgSpecifierTarget ) import Distribution.Client.Types.OverwritePolicy @@ -344,153 +346,60 @@ 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 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 + -- 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. - 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 + -- 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. - let - (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss - packageTargets = map woPackageTargets tss - - return (packageSpecifiers, uris, packageTargets, projectConfig) - - (specs, uris, targetSelectors, baseConfig) <- - withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject - - -- 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 + (pkgSpecs, uris, targetSelectors, config) <- + let + with = do + (pkgSpecs, targetSelectors, baseConfig) <- + withProject verbosity cliConfig normalisedTargetStrings installLibs + -- No URIs in this case, see note above + return (pkgSpecs, [], targetSelectors, baseConfig) + + without = + withGlobalConfig verbosity globalConfigFlag $ \globalConfig -> + withoutProject verbosity (globalConfig <> cliConfig) normalisedTargetStrings + in + -- If there's no targets it does not make sense to not be in a project. + if null targetStrings + then with + else withProjectOrGlobalConfig ignoreProject with without + + -- NOTE: CmdInstall and project local packages. + -- + -- CmdInstall always installs packages from a source distribution that, in case of unpackage + -- pacakges, is created automatically. This is implemented in getSpecsAndTargetSelectors. + -- + -- This has the inconvenience that the planner will consider all packages as non-local + -- (see `ProjectPlanning.shouldBeLocal`) and that any project or cli configuration will + -- not apply to them. + -- + -- We rectify this here. In the project configuration, we copy projectConfigLocalPackages to a + -- new projectConfigSpecificPackage entry for each package corresponding to a target selector. + -- + -- See #8637 and later #7297, #8909, #7236. let - config = addLocalConfigToPkgs baseConfig (map pkgSpecifierTarget specs ++ concatMap (targetPkgNames localPkgs) targetSelectors) - ProjectConfig { projectConfigBuildOnly = ProjectConfigBuildOnly @@ -525,12 +434,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt $ configProgDb -- progDb is a program database with compiler tools configured properly - ( compiler@Compiler - { compilerId = CompilerId compilerFlavor compilerVersion - } - , platform - , progDb - ) <- + (compiler@Compiler{compilerId = CompilerId compilerFlavor compilerVersion}, platform, progDb) <- configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity let @@ -567,7 +471,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName getPackageName (NamedPackage pn _) = pn getPackageName (SpecificSourcePackage (SourcePackage pkgId _ _ _)) = pkgName pkgId - targetNames = S.fromList $ map getPackageName (specs ++ uriSpecs) + targetNames = S.fromList $ map getPackageName (pkgSpecs ++ uriSpecs) envNames = S.fromList $ map getPackageName envSpecs forceInstall = fromFlagOrDefault False $ installOverrideReinstall installFlags nameIntersection = S.intersection targetNames envNames @@ -584,7 +488,8 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt in pure (es, nge) else dieWithException verbosity $ PackagesAlreadyExistInEnvfile envFile (map prettyShow $ S.toList nameIntersection) - -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that we can solve with regards to packages installed locally but not in the upstream repo + -- we construct an installed index of files in the cleaned target environment (absent overwrites) so that + -- we can solve with regards to packages installed locally but not in the upstream repo let installedPacks = PI.allPackagesByName installedIndex newEnvNames = S.fromList $ map getPackageName envSpecs' installedIndex' = PI.fromList . concatMap snd . filter (\p -> fst p `S.member` newEnvNames) $ installedPacks @@ -594,7 +499,7 @@ installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetSt verbosity config distDirLayout - (envSpecs' ++ specs ++ uriSpecs) + (envSpecs' ++ pkgSpecs ++ uriSpecs) InstallCommand buildCtx <- constructProjectBuildContext verbosity (baseCtx{installedPackages = Just installedIndex'}) targetSelectors @@ -635,12 +540,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 +555,143 @@ 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 + + (pkgSpecs, targetSelectors) <- + -- If every target is already resolved to a package id, we can return without any further parsing. + if null unresolvedTargetStrings + then return (parsedPkgSpecs, parsedTargets) + else do + -- Anything that could not be parsed as a packageId (e.g. a pacakge name with not version or + -- a target syntax using colons) must be resolved inside the project context. + (resolvedPkgSpecs, resolvedTargets) <- + resolveTargetSelectorsInProjectBaseContext verbosity baseCtx unresolvedTargetStrings targetFilter + return (resolvedPkgSpecs ++ parsedPkgSpecs, resolvedTargets ++ parsedTargets) + + -- Apply the local configuration (e.g. cli flags) to all direct targets of install command, see note + -- in 'installAction'. + -- + -- NOTE: If a target string had to be resolved inside the project conterxt, then pkgSpecs will include + -- the project packages turned into source distributions (getSpecsAndTargetSelectors does this). + -- We want to apply the local configuration only to the actual targets. + let config = + addLocalConfigToPkgs (projectConfig baseCtx) $ + concatMap (targetPkgNames $ localPackages baseCtx) targetSelectors + return (pkgSpecs, targetSelectors, config) + where + reducedVerbosity = lessVerbose verbosity + + -- We take the targets and try to parse them as package ids (with name and version). + -- The ones who don't parse will have to be resolved in the project context. + (unresolvedTargetStrings, parsedPackageIds) = + partitionEithers $ + flip map targetStrings $ \s -> + case eitherParsec s of + Right pkgId@PackageIdentifier{pkgVersion} + | pkgVersion /= nullVersion -> + pure pkgId + _ -> Left s + + -- For each packageId, we output a NamedPackage specifier (i.e. a package only known by + -- its name) and a target selector. + (parsedPkgSpecs, parsedTargets) = + unzip + [ (mkNamedPackage pkgId, 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 + + sourcePkgDb <- + 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 + sourcePkgDb + 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 + packageSpecifiers :: [PackageSpecifier UnresolvedSourcePackage] + (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss + packageTargets = map woPackageTargets tss + + -- Apply the local configuration (e.g. cli flags) to all direct targets of install command, + -- see note in 'installAction' + let config = addLocalConfigToPkgs globalConfig (concatMap woPackageNames tss) + return (packageSpecifiers, uris, packageTargets, config) + addLocalConfigToPkgs :: ProjectConfig -> [PackageName] -> ProjectConfig addLocalConfigToPkgs config pkgs = config @@ -692,6 +734,7 @@ verifyPreconditionsOrDie verbosity configFlags = do when (configBenchmarks configFlags == Flag True) $ dieWithException verbosity ConfigBenchmarks +-- | Apply the given 'ClientInstallFlags' on top of one coming from the global configuration. getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do let configFileFlag = globalConfigFile globalFlags @@ -707,28 +750,27 @@ getSpecsAndTargetSelectors -> ProjectBaseContext -> Maybe ComponentKindFilter -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) -getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = - withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do +getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelectors distDirLayout baseCtx targetFilter = + withInstallPlan reducedVerbosity baseCtx $ \elaboratedPlan _ -> do -- Split into known targets and hackage packages. - (targets, hackageNames) <- + (targetsMap, hackageNames) <- partitionToKnownTargetsAndHackagePackages verbosity - pkgDb + sourcePkgDb elaboratedPlan targetSelectors let planMap = InstallPlan.toMap elaboratedPlan - targetIds = Map.keys targets 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 + localPkgs = sdistize <$> localPackages baseCtx gatherTargets :: UnitId -> TargetSelector gatherTargets targetId = TargetPackageNamed pkgName targetFilter @@ -736,30 +778,29 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors loca targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap PackageIdentifier{..} = packageId targetUnit - targets' = fmap gatherTargets targetIds + localTargets = map gatherTargets (Map.keys targetsMap) hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] - hackagePkgs = flip NamedPackage [] <$> hackageNames + hackagePkgs = [NamedPackage pn [] | pn <- hackageNames] hackageTargets :: [TargetSelector] - hackageTargets = - flip TargetPackageNamed targetFilter <$> hackageNames + hackageTargets = [TargetPackageNamed pn targetFilter | pn <- hackageNames] - createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) + createDirectoryIfMissing True (distSdistDirectory distDirLayout) - unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of + unless (Map.null targetsMap) $ 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 - if null targets + if null targetsMap then return (hackagePkgs, hackageTargets) - else return (local ++ hackagePkgs, targets' ++ hackageTargets) + else return (localPkgs ++ hackagePkgs, localTargets ++ hackageTargets) -- | Partitions the target selectors into known local targets and hackage packages. partitionToKnownTargetsAndHackagePackages diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs index c6939729f61..7879602a913 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs +++ b/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)) - ] 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..c2d6610707c 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 @@ -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 diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index db99b2576b9..b65f39526a0 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/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 diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index ad9e507ae5c..3a4e6f96bf8 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/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] 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 ':'. diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs index 5f25be4aa77..a803a85b429 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs +++ b/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))] + )