diff --git a/cabal-install-solver/cabal-install-solver.cabal b/cabal-install-solver/cabal-install-solver.cabal index a96b787f55e..cd588ffeaf1 100644 --- a/cabal-install-solver/cabal-install-solver.cabal +++ b/cabal-install-solver/cabal-install-solver.cabal @@ -76,11 +76,13 @@ library Distribution.Solver.Modular.WeightedPSQ Distribution.Solver.Types.ComponentDeps Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.WithConstraintSource Distribution.Solver.Types.DependencyResolver Distribution.Solver.Types.Flag Distribution.Solver.Types.InstalledPreference Distribution.Solver.Types.InstSolverPackage Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.NamedPackage Distribution.Solver.Types.OptionalStanza Distribution.Solver.Types.PackageConstraint Distribution.Solver.Types.PackageFixedDeps diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index cb91bc742b4..01082be62cd 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -6,7 +6,8 @@ module Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Compat.Prelude import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath) -import Text.PrettyPrint (render) +import Distribution.Pretty (Pretty(pretty), prettyShow) +import Text.PrettyPrint (text) -- | Source of a 'PackageConstraint'. data ConstraintSource = @@ -55,31 +56,40 @@ data ConstraintSource = -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion - deriving (Eq, Show, Generic) + + -- | An implicit constraint added by Cabal. + | ConstraintSourceImplicit + deriving (Show, Eq, Ord, Generic, Typeable) instance Binary ConstraintSource instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String -showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path -showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ render (docProjectConfigPath path) -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path -showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" -showConstraintSource ConstraintSourceUserTarget = "user target" -showConstraintSource ConstraintSourceNonReinstallablePackage = - "non-reinstallable package" -showConstraintSource ConstraintSourceFreeze = "cabal freeze" -showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" -showConstraintSource ConstraintSourceMultiRepl = - "--enable-multi-repl" -showConstraintSource ConstraintSourceProfiledDynamic = - "--enable-profiling-shared" -showConstraintSource ConstraintSourceUnknown = "unknown source" -showConstraintSource ConstraintSetupCabalMinVersion = - "minimum version of Cabal used by Setup.hs" -showConstraintSource ConstraintSetupCabalMaxVersion = - "maximum version of Cabal used by Setup.hs" +showConstraintSource = prettyShow + +instance Pretty ConstraintSource where + pretty constraintSource = case constraintSource of + (ConstraintSourceMainConfig path) -> + text "main config" <+> text path + (ConstraintSourceProjectConfig path) -> + text "project config" <+> docProjectConfigPath path + (ConstraintSourceUserConfig path)-> text "user config " <+> text path + ConstraintSourceCommandlineFlag -> text "command line flag" + ConstraintSourceUserTarget -> text "user target" + ConstraintSourceNonReinstallablePackage -> + text "non-reinstallable package" + ConstraintSourceFreeze -> text "cabal freeze" + ConstraintSourceConfigFlagOrTarget -> + text "config file, command line flag, or user target" + ConstraintSourceMultiRepl -> + text "--enable-multi-repl" + ConstraintSourceProfiledDynamic -> + text "--enable-profiling-shared" + ConstraintSourceUnknown -> text "unknown source" + ConstraintSetupCabalMinVersion -> + text "minimum version of Cabal used by Setup.hs" + ConstraintSetupCabalMaxVersion -> + text "maximum version of Cabal used by Setup.hs" + ConstraintSourceImplicit -> + text "implicit target" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs new file mode 100644 index 00000000000..e76cee7c4b0 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} + +module Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + , NamedPackageConstraint + ) where + +import Distribution.Solver.Compat.Prelude +import Prelude () + +import Distribution.Types.PackageName (PackageName) +import Distribution.Solver.Types.PackageConstraint (PackageProperty) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource) +import Distribution.Pretty (Pretty (pretty), commaSpaceSep) +import Text.PrettyPrint + +-- | A package, identified by a name and properties. +data NamedPackage = NamedPackage PackageName [PackageProperty] + deriving (Show, Eq, Ord, Generic, Typeable) + +instance Binary NamedPackage +instance Structured NamedPackage + +instance Pretty NamedPackage where + pretty (NamedPackage name properties) = + pretty name <+> parens (commaSpaceSep properties) + +type NamedPackageConstraint = WithConstraintSource NamedPackage diff --git a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs index fbe56380e81..2c00d9592fa 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -11,9 +11,7 @@ module Distribution.Solver.Types.PackageConstraint ( scopeToPackageName, constraintScopeMatches, PackageProperty(..), - dispPackageProperty, PackageConstraint(..), - dispPackageConstraint, showPackageConstraint, packageConstraintToDependency ) where @@ -23,7 +21,7 @@ import Prelude () import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) -import Distribution.Pretty (flatStyle, pretty) +import Distribution.Pretty (flatStyle, Pretty(pretty)) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) import Distribution.Version (VersionRange, simplifyVersionRange) @@ -82,12 +80,11 @@ constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' --- | Pretty-prints a constraint scope. -dispConstraintScope :: ConstraintScope -> Disp.Doc -dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn -dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn -dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn -dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn +instance Pretty ConstraintScope where + pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn + pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn + pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn + pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. data PackageProperty @@ -96,29 +93,27 @@ data PackageProperty | PackagePropertySource | PackagePropertyFlags FlagAssignment | PackagePropertyStanzas [OptionalStanza] - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary PackageProperty instance Structured PackageProperty --- | Pretty-prints a package property. -dispPackageProperty :: PackageProperty -> Disp.Doc -dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange -dispPackageProperty PackagePropertyInstalled = Disp.text "installed" -dispPackageProperty PackagePropertySource = Disp.text "source" -dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags -dispPackageProperty (PackagePropertyStanzas stanzas) = - Disp.hsep $ map (Disp.text . showStanza) stanzas +instance Pretty PackageProperty where + pretty (PackagePropertyVersion verrange) = pretty verrange + pretty PackagePropertyInstalled = Disp.text "installed" + pretty PackagePropertySource = Disp.text "source" + pretty (PackagePropertyFlags flags) = dispFlagAssignment flags + pretty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty deriving (Eq, Show) --- | Pretty-prints a package constraint. -dispPackageConstraint :: PackageConstraint -> Disp.Doc -dispPackageConstraint (PackageConstraint scope prop) = - dispConstraintScope scope <+> dispPackageProperty prop +instance Pretty PackageConstraint where + pretty (PackageConstraint scope prop) = + pretty scope <+> pretty prop -- | Alternative textual representation of a package constraint -- for debugging purposes (slightly more verbose than that @@ -126,7 +121,7 @@ dispPackageConstraint (PackageConstraint scope prop) = -- showPackageConstraint :: PackageConstraint -> String showPackageConstraint pc@(PackageConstraint scope prop) = - Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 + Disp.renderStyle flatStyle . postprocess $ pretty pc2 where pc2 = case prop of PackagePropertyVersion vr -> diff --git a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs new file mode 100644 index 00000000000..8f6b72496e4 --- /dev/null +++ b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + , showWithConstraintSource + , withUnknownConstraint + ) where + +import Distribution.Solver.Compat.Prelude + +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..), showConstraintSource) +import Distribution.Pretty (Pretty (pretty)) +import Text.PrettyPrint + +-- | A package bundled with a `ConstraintSource`. +data WithConstraintSource pkg = + WithConstraintSource + { constraintPackage :: pkg + -- ^ The package. + , constraintConstraint :: ConstraintSource + -- ^ The constraint source for the package. + } + deriving (Show, Functor, Eq, Ord, Traversable, Foldable, Generic, Typeable) + +instance Binary pkg => Binary (WithConstraintSource pkg) +instance Structured pkg => Structured (WithConstraintSource pkg) + +withUnknownConstraint :: pkg -> WithConstraintSource pkg +withUnknownConstraint constraintPackage = + WithConstraintSource + { constraintPackage + , constraintConstraint = ConstraintSourceUnknown + } + +showWithConstraintSource :: (pkg -> String) -> WithConstraintSource pkg -> String +showWithConstraintSource + showPackage + (WithConstraintSource { constraintPackage, constraintConstraint }) = + showPackage constraintPackage ++ " (" ++ showConstraintSource constraintConstraint ++ ")" + +instance Pretty pkg => Pretty (WithConstraintSource pkg) where + pretty (WithConstraintSource { constraintPackage, constraintConstraint = ConstraintSourceUnknown }) + = pretty constraintPackage + pretty (WithConstraintSource { constraintPackage, constraintConstraint }) + = pretty constraintPackage + <+> parens (text "from" <+> pretty constraintConstraint) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 68845e4b8b4..35395f91ee1 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -243,6 +243,7 @@ library zlib >= 0.5.3 && < 0.8, hackage-security >= 0.6.2.0 && < 0.7, text >= 1.2.3 && < 1.3 || >= 2.0 && < 2.2, + transformers >= 0.2 && <0.7, parsec >= 3.1.13.0 && < 3.2, open-browser >= 0.2.1.0 && < 0.3, regex-base >= 0.94.0.0 && <0.95, diff --git a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs index 34f2c380035..47b0b2ae612 100644 --- a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs +++ b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs @@ -39,6 +39,9 @@ import Distribution.Client.Types import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Compiler ( CompilerId (..) @@ -200,8 +203,16 @@ fromPlanPackage , extractRepo srcPkg ) where - extractRepo (SourcePackage{srcpkgSource = RepoTarballPackage repo _ _}) = - Just repo + extractRepo + ( SourcePackage + { srcpkgSource = + WithConstraintSource + { constraintPackage = + RepoTarballPackage repo _ _ + } + } + ) = + Just repo extractRepo _ = Nothing fromPlanPackage _ _ _ _ = Nothing diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs index 05634141288..639bd647ff8 100644 --- a/cabal-install/src/Distribution/Client/CmdBench.hs +++ b/cabal-install/src/Distribution/Client/CmdBench.hs @@ -56,6 +56,12 @@ import Distribution.Simple.Utils , warn , wrapText ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Verbosity ( normal ) @@ -115,8 +121,11 @@ benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings + either (reportTargetSelectorProblems verbosity . map constraintPackage) return + =<< readTargetSelectors + (localPackages baseCtx) + (Just BenchKind) + (map (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) targetStrings) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -131,7 +140,7 @@ benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do -- Interpret the targets on the command line as bench targets -- (as opposed to say build or haddock targets). targets <- - either (reportTargetProblems verbosity) return $ + either (reportTargetProblems verbosity . map constraintPackage) return $ resolveTargets selectPackageTargets selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 44f1c4e0f27..43fe3beb648 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -25,6 +25,12 @@ import Distribution.Client.TargetProblem ( TargetProblem (..) , TargetProblem' ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import qualified Data.Map as Map import Distribution.Client.Errors @@ -135,7 +141,7 @@ defaultBuildFlags = -- "Distribution.Client.ProjectOrchestration" buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO () buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globalFlags = - withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do + withContextAndSelectors RejectNoTargets Nothing flags (map (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) targetStrings) globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do -- TODO: This flags defaults business is ugly let onlyConfigure = fromFlag @@ -156,7 +162,7 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globa -- Interpret the targets on the command line as build targets -- (as opposed to say repl or haddock targets). targets <- - either (reportBuildTargetProblems verbosity) return $ + either (reportBuildTargetProblems verbosity . map constraintPackage) return $ resolveTargets selectPackageTargets selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index 29718b5d441..f3998f17c75 100644 --- a/cabal-install/src/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs @@ -38,6 +38,9 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint ( PackageProperty (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Client.Setup ( CommonSetupFlags (setupVerbosity) @@ -192,7 +195,7 @@ projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = -- solver picks the same solution again in future in different environments. projectFreezeConstraints :: ElaboratedInstallPlan - -> Map PackageName [(UserConstraint, ConstraintSource)] + -> Map PackageName [WithConstraintSource UserConstraint] projectFreezeConstraints plan = -- -- TODO: [required eventually] this is currently an underapproximation @@ -211,14 +214,14 @@ projectFreezeConstraints plan = deleteLocalPackagesVersionConstraints (Map.unionWith (++) versionConstraints flagConstraints) where - versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + versionConstraints :: Map PackageName [WithConstraintSource UserConstraint] versionConstraints = Map.mapWithKey ( \p v -> - [ - ( UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v) - , ConstraintSourceFreeze - ) + [ WithConstraintSource + { constraintPackage = UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v) + , constraintConstraint = ConstraintSourceFreeze + } ] ) versionRanges @@ -234,14 +237,14 @@ projectFreezeConstraints plan = | InstallPlan.Configured pkg <- InstallPlan.toList plan ] - flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] + flagConstraints :: Map PackageName [WithConstraintSource UserConstraint] flagConstraints = Map.mapWithKey ( \p f -> - [ - ( UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f) - , ConstraintSourceFreeze - ) + [ WithConstraintSource + { constraintPackage = UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f) + , constraintConstraint = ConstraintSourceFreeze + } ] ) flagAssignments @@ -259,12 +262,12 @@ projectFreezeConstraints plan = -- As described above, remove the version constraints on local packages, -- but leave any flag constraints. deleteLocalPackagesVersionConstraints - :: Map PackageName [(UserConstraint, ConstraintSource)] - -> Map PackageName [(UserConstraint, ConstraintSource)] + :: Map PackageName [WithConstraintSource UserConstraint] + -> Map PackageName [WithConstraintSource UserConstraint] deleteLocalPackagesVersionConstraints = Map.mergeWithKey ( \_pkgname () constraints -> - case filter (not . isVersionConstraint . fst) constraints of + case filter (not . isVersionConstraint . constraintPackage) constraints of [] -> Nothing constraints' -> Just constraints' ) diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index 8ecc5487798..e3399f421d2 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -65,6 +65,12 @@ import Distribution.Simple.Utils , notice , wrapText ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Verbosity ( normal ) @@ -163,8 +169,11 @@ haddockAction relFlags targetStrings globalFlags = do let baseCtx = relBaseCtx{projectConfig = absProjectConfig} targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + either (reportTargetSelectorProblems verbosity . map constraintPackage) return + =<< readTargetSelectors + (localPackages baseCtx) + Nothing + (map (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) targetStrings) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -174,7 +183,7 @@ haddockAction relFlags targetStrings globalFlags = do -- When we interpret the targets on the command line, interpret them as -- haddock targets targets <- - either (reportBuildDocumentationTargetProblems verbosity) return $ + either (reportBuildDocumentationTargetProblems verbosity . map constraintPackage) return $ resolveTargets (selectPackageTargets haddockFlags) selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index 0635a77d68e..7b3ddd54c57 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -51,6 +51,12 @@ import Distribution.Client.Setup , GlobalFlags (..) ) import Distribution.Client.TargetProblem (TargetProblem (..)) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Simple.BuildPaths ( haddockBenchmarkDirPath @@ -127,7 +133,7 @@ haddockProjectAction flags _extraArgs globalFlags = do RejectNoTargets Nothing (commandDefaultFlags CmdBuild.buildCommand) - ["all"] + [WithConstraintSource{constraintPackage = "all", constraintConstraint = ConstraintSourceImplicit}] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index a5df21b185b..26091a6453d 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -175,6 +175,12 @@ import Distribution.Simple.Utils , withTempDirectory , wrapText ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty (..) ) @@ -185,6 +191,10 @@ import Distribution.Solver.Types.PackageIndex import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + , withUnknownConstraint + ) import Distribution.System ( OS (Windows) , Platform @@ -259,7 +269,7 @@ type InstallAction = Verbosity -> OverwritePolicy -> InstallExe - -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)]) + -> (UnitId, [(ComponentTarget, NonEmpty (WithConstraintSource TargetSelector))]) -> IO () data InstallCfg = InstallCfg @@ -359,7 +369,23 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project let installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) - normalisedTargetStrings = if null targetStrings then ["."] else targetStrings + normalisedTargetStrings = + if null targetStrings + then + [ WithConstraintSource + { constraintPackage = "." + , constraintConstraint = ConstraintSourceImplicit + } + ] + else + map + ( \target -> + WithConstraintSource + { constraintPackage = target + , constraintConstraint = ConstraintSourceCommandlineFlag + } + ) + 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 @@ -470,7 +496,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project compiler (projectConfigShared config) (projectConfigBuildOnly config) - [ProjectPackageRemoteTarball uri | uri <- uris] + (map (fmap ProjectPackageRemoteTarball) uris) -- check for targets already in env let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName @@ -563,9 +589,9 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project withProject :: Verbosity -> ProjectConfig - -> [String] + -> [WithConstraintSource String] -> Bool - -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig) + -> IO ([PackageSpecifier UnresolvedSourcePackage], [WithConstraintSource 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 @@ -589,7 +615,7 @@ withProject verbosity cliConfig targetStrings installLibs = do -- We want to apply the local configuration only to the actual targets. let config = addLocalConfigToPkgs (projectConfig baseCtx) $ - concatMap (targetPkgNames $ localPackages baseCtx) targetSelectors + concatMap (targetPkgNames (localPackages baseCtx) . constraintPackage) targetSelectors return (pkgSpecs, targetSelectors, config) where reducedVerbosity = lessVerbose verbosity @@ -598,19 +624,28 @@ withProject verbosity cliConfig targetStrings installLibs = do -- 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 + flip map targetStrings $ \target -> + case eitherParsec $ constraintPackage target of Right pkgId@PackageIdentifier{pkgVersion} | pkgVersion /= nullVersion -> - pure pkgId - _ -> Left s + pure $ target{constraintPackage = pkgId} + _ -> Left target -- 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 + [ ( mkNamedPackage src pkgId + , withConstraint + { constraintPackage = + TargetPackageNamed (pkgName pkgId) targetFilter + } + ) + | withConstraint@WithConstraintSource + { constraintPackage = pkgId + , constraintConstraint = src + } <- + parsedPackageIds ] targetFilter = if installLibs then Just LibKind else Just ExeKind @@ -618,9 +653,9 @@ withProject verbosity cliConfig targetStrings installLibs = do resolveTargetSelectorsInProjectBaseContext :: Verbosity -> ProjectBaseContext - -> [String] + -> [WithConstraintSource String] -> Maybe ComponentKindFilter - -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) + -> IO ([PackageSpecifier UnresolvedSourcePackage], [WithConstraintSource TargetSelector]) resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targetFilter = do let reducedVerbosity = lessVerbose verbosity @@ -633,7 +668,7 @@ resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targe targetSelectors <- readTargetSelectors (localPackages baseCtx) Nothing targetStrings >>= \case - Left problems -> reportTargetSelectorProblems verbosity problems + Left problems -> reportTargetSelectorProblems verbosity (map constraintPackage problems) Right ts -> return ts getSpecsAndTargetSelectors @@ -648,10 +683,20 @@ resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targe withoutProject :: Verbosity -> ProjectConfig - -> [String] - -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig) + -> [WithConstraintSource String] + -> IO + ( [PackageSpecifier UnresolvedSourcePackage] + , [WithConstraintSource URI] + , [WithConstraintSource TargetSelector] + , ProjectConfig + ) withoutProject verbosity globalConfig targetStrings = do - tss <- traverse (parseWithoutProjectTargetSelector verbosity) targetStrings + tss <- + traverse + ( sequenceA + . fmap (parseWithoutProjectTargetSelector verbosity) + ) + targetStrings let ProjectConfigBuildOnly { projectConfigLogsDir @@ -674,7 +719,7 @@ withoutProject verbosity globalConfig targetStrings = do buildSettings (getSourcePackages verbosity) - for_ (concatMap woPackageNames tss) $ \name -> do + for_ (concatMap (woPackageNames . constraintPackage) tss) $ \name -> do when (null (lookupPackageName packageIndex name)) $ do let xs = searchByName packageIndex (unPackageName name) let emptyIf True _ = [] @@ -688,14 +733,20 @@ withoutProject verbosity globalConfig targetStrings = do dieWithException verbosity $ WithoutProject (unPackageName name) str2 let - packageSpecifiers :: [PackageSpecifier UnresolvedSourcePackage] - (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss - packageTargets = map woPackageTargets tss + outerEither :: WithConstraintSource (Either a b) -> Either (WithConstraintSource a) (WithConstraintSource b) + outerEither (withConstraint@WithConstraintSource{constraintPackage = either'}) = + case either' of + Left inner -> Left (withConstraint{constraintPackage = inner}) + Right inner -> Right (withConstraint{constraintPackage = inner}) + + packageSpecifiers :: [WithConstraintSource (PackageSpecifier UnresolvedSourcePackage)] + (uris, packageSpecifiers) = partitionEithers $ map (outerEither . fmap woPackageSpecifiers) tss + packageTargets = map (fmap 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) + let config = addLocalConfigToPkgs globalConfig (concatMap (woPackageNames . constraintPackage) tss) + return (map constraintPackage packageSpecifiers, uris, packageTargets, config) addLocalConfigToPkgs :: ProjectConfig -> [PackageName] -> ProjectConfig addLocalConfigToPkgs config pkgs = @@ -750,11 +801,11 @@ getSpecsAndTargetSelectors :: Verbosity -> Verbosity -> SourcePackageDb - -> [TargetSelector] + -> [WithConstraintSource TargetSelector] -> DistDirLayout -> ProjectBaseContext -> Maybe ComponentKindFilter - -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) + -> IO ([PackageSpecifier UnresolvedSourcePackage], [WithConstraintSource TargetSelector]) getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelectors distDirLayout baseCtx targetFilter = withInstallPlan reducedVerbosity baseCtx $ \elaboratedPlan _ -> do -- Split into known targets and hackage packages. @@ -772,7 +823,13 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector SpecificSourcePackage spkg' where sdistPath = distSdistFile distDirLayout (packageId spkg) - spkg' = spkg{srcpkgSource = LocalTarballPackage sdistPath} + spkg' = + spkg + { srcpkgSource = + (srcpkgSource spkg) + { constraintPackage = LocalTarballPackage sdistPath + } + } sdistize named = named localPkgs = sdistize <$> localPackages baseCtx @@ -783,13 +840,19 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap PackageIdentifier{..} = packageId targetUnit - localTargets = map gatherTargets (Map.keys targetsMap) + localTargets = map (withUnknownConstraint . gatherTargets) (Map.keys targetsMap) hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] - hackagePkgs = [NamedPackage pn [] | pn <- hackageNames] + hackagePkgs = + [ Named (withConstraint{constraintPackage = NamedPackage packageName []}) + | withConstraint@WithConstraintSource{constraintPackage = packageName} <- hackageNames + ] - hackageTargets :: [TargetSelector] - hackageTargets = [TargetPackageNamed pn targetFilter | pn <- hackageNames] + hackageTargets :: [WithConstraintSource TargetSelector] + hackageTargets = + [ withConstraint{constraintPackage = TargetPackageNamed packageName targetFilter} + | withConstraint@WithConstraintSource{constraintPackage = packageName} <- hackageNames + ] createDirectoryIfMissing True (distSdistDirectory distDirLayout) @@ -801,7 +864,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector TarGzArchive (distSdistFile distDirLayout (packageId pkg)) pkg - NamedPackage _ _ -> + Named _ -> -- This may happen if 'extra-packages' are listed in the project file. -- We don't need to do extra work for NamedPackages since they will be -- fetched from Hackage rather than locally 'sdistize'-d. Note how, @@ -821,8 +884,8 @@ partitionToKnownTargetsAndHackagePackages :: Verbosity -> SourcePackageDb -> ElaboratedInstallPlan - -> [TargetSelector] - -> IO (TargetsMap, [PackageName]) + -> [WithConstraintSource TargetSelector] + -> IO (TargetsMap, [WithConstraintSource PackageName]) partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do let mTargets = resolveTargets @@ -838,8 +901,8 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS Left errs -> do -- Not everything is local. let - (errs', hackageNames) = partitionEithers . flip fmap errs $ \case - TargetAvailableInIndex name -> Right name + (errs', hackageNames) = partitionEithers . flip fmap errs $ \problem -> case constraintPackage problem of + TargetAvailableInIndex name -> Right problem{constraintPackage = name} err -> Left err -- report incorrect case for known package. @@ -854,17 +917,17 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS when (not . null $ errs') $ reportBuildTargetProblems verbosity errs' let - targetSelectors' = flip filter targetSelectors $ \case + targetSelectors' = flip filter targetSelectors $ \target -> case constraintPackage target of TargetComponentUnknown name _ _ - | name `elem` hackageNames -> False + | name `elem` (map constraintPackage hackageNames) -> False TargetPackageNamed name _ - | name `elem` hackageNames -> False + | name `elem` (map constraintPackage hackageNames) -> False _ -> True -- This can't fail, because all of the errors are -- removed (or we've given up). targets <- - either (reportBuildTargetProblems verbosity) return $ + either (reportBuildTargetProblems verbosity . map constraintPackage) return $ resolveTargets selectPackageTargets selectComponentTarget @@ -878,13 +941,13 @@ constructProjectBuildContext :: Verbosity -> ProjectBaseContext -- ^ The synthetic base context to use to produce the full build context. - -> [TargetSelector] + -> [WithConstraintSource TargetSelector] -> IO ProjectBuildContext constructProjectBuildContext verbosity baseCtx targetSelectors = do runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do -- Interpret the targets on the command line as build targets targets <- - either (reportBuildTargetProblems verbosity) return $ + either (reportBuildTargetProblems verbosity . map constraintPackage) return $ resolveTargets selectPackageTargets selectComponentTarget @@ -1046,11 +1109,11 @@ warnIfNoExes verbosity buildCtx = <> "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" <> "* You might have wanted to add them as dependencies to your package." <> " In this case add \"" - <> intercalate ", " (showTargetSelector <$> selectors) + <> intercalate ", " (map (showTargetSelector . constraintPackage) selectors) <> "\" to the build-depends field(s) of your package's .cabal file.\n" <> "* You might have wanted to add them to a GHC environment. In this case" <> " use \"cabal install --lib " - <> unwords (showTargetSelector <$> selectors) + <> unwords (map (showTargetSelector . constraintPackage) selectors) <> "\". " <> " The \"--lib\" flag is provisional: see" <> " https://github.com/haskell/cabal/issues/6481 for more information." @@ -1092,7 +1155,17 @@ environmentFileToSpecifiers ipi = foldMap $ \case NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] -> - ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)]) + ( + [ Named + ( WithConstraintSource + { constraintPackage = + pkgSpec + , constraintConstraint = ConstraintSourceUnknown + } + ) + ] + , [(pkgName, GhcEnvFilePackageId installedUnitId)] + ) _ -> ([], []) -- | Disables tests and benchmarks if they weren't explicitly enabled. @@ -1253,13 +1326,13 @@ installBuiltExe entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry FilePath] entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] where - hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool + hasLib :: (ComponentTarget, NonEmpty (WithConstraintSource TargetSelector)) -> Bool hasLib (ComponentTarget (CLibName _) _, _) = True hasLib _ = False go :: UnitId - -> [(ComponentTarget, NonEmpty TargetSelector)] + -> [(ComponentTarget, NonEmpty (WithConstraintSource TargetSelector))] -> [GhcEnvironmentFileEntry FilePath] go unitId targets | any hasLib targets = [GhcEnvFilePackageId unitId] diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs index 7879602a913..82d8c0939aa 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs @@ -18,6 +18,7 @@ import Distribution.Compat.CharParsing (char, optional) import Distribution.Package import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName)) import Distribution.Simple.Utils (dieWithException) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) data WithoutProjectTargetSelector = WoPackageId PackageId @@ -55,6 +56,6 @@ woPackageTargets (WoURI _) = TargetAllPackages (Just ExeKind) woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg) -woPackageSpecifiers (WoPackageId pid) = Right (mkNamedPackage pid) -woPackageSpecifiers (WoPackageComponent pid _) = Right (mkNamedPackage pid) +woPackageSpecifiers (WoPackageId pid) = Right (mkNamedPackage ConstraintSourceUnknown pid) +woPackageSpecifiers (WoPackageComponent pid _) = Right (mkNamedPackage ConstraintSourceUnknown pid) woPackageSpecifiers (WoURI uri) = Left uri diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index e53100122e9..f48ae093cbb 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -64,6 +64,8 @@ import Distribution.Client.Errors import qualified Distribution.Client.InstallPlan as IP import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) ------------------------------------------------------------------------------- -- Command @@ -96,8 +98,14 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do [x] -> return x _ -> dieWithException verbosity OneTargetRequired + let targetProvenance = + WithConstraintSource + { constraintPackage = target + , constraintConstraint = ConstraintSourceCommandlineFlag + } + -- configure and elaborate target selectors - withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do + withContextAndSelectors RejectNoTargets (Just ExeKind) flags [targetProvenance] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do baseCtx <- case targetCtx of ProjectContext -> return ctx GlobalContext -> return ctx @@ -108,7 +116,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -- Interpret the targets on the command line as build targets -- (as opposed to say repl or haddock targets). targets <- - either (reportTargetProblems verbosity) return $ + either (reportTargetProblems verbosity . map constraintPackage) return $ resolveTargets selectPackageTargets selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal-install/src/Distribution/Client/CmdOutdated.hs index 7674e67286f..06a5ee79982 100644 --- a/cabal-install/src/Distribution/Client/CmdOutdated.hs +++ b/cabal-install/src/Distribution/Client/CmdOutdated.hs @@ -68,6 +68,9 @@ import Distribution.Client.Types.SourcePackageDb as SourcePackageDb import Distribution.Solver.Types.PackageConstraint ( packageConstraintToDependency ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Utils.Generic ( safeLast , wrapText @@ -401,7 +404,7 @@ depsFromFreezeFile verbosity = do cwd <- getCurrentDirectory userConfig <- loadUserConfig verbosity cwd Nothing let ucnstrs = - map fst . configExConstraints . savedConfigureExFlags $ + map constraintPackage . configExConstraints . savedConfigureExFlags $ userConfig deps = userConstraintsToDependencies ucnstrs debug verbosity "Reading the list of dependencies from the freeze file" @@ -422,7 +425,7 @@ depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mproje pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs let ucnstrs = - map fst . projectConfigConstraints . projectConfigShared $ + map constraintPackage . projectConfigConstraints . projectConfigShared $ projectConfig deps = userConstraintsToDependencies ucnstrs freezeFile = distProjectFile distDirLayout "freeze" diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index f762c3d72bf..d393e3c987b 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -113,7 +113,7 @@ import Distribution.Simple.Utils , wrapText ) import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource (ConstraintSourceMultiRepl) + ( ConstraintSource (..) ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty (PackagePropertyVersion) @@ -121,6 +121,9 @@ import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Types.BuildInfo ( BuildInfo (..) , emptyBuildInfo @@ -285,220 +288,230 @@ multiReplDecision ctx compiler flags = -- "Distribution.Client.ProjectOrchestration" replAction :: NixStyleFlags ReplFlags -> [String] -> GlobalFlags -> IO () replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings globalFlags = - withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do - when (buildSettingOnlyDeps (buildSettings ctx)) $ - dieWithException verbosity ReplCommandDoesn'tSupport - let projectRoot = distProjectRootDirectory $ distDirLayout ctx - distDir = distDirectory $ distDirLayout ctx - - baseCtx <- case targetCtx of - ProjectContext -> return ctx - GlobalContext -> do - unless (null targetStrings) $ - dieWithException verbosity $ - ReplTakesNoArguments targetStrings - let - sourcePackage = - fakeProjectSourcePackage projectRoot - & lSrcpkgDescription . L.condLibrary - .~ Just (CondNode library [baseDep] []) - library = emptyLibrary{libBuildInfo = lBuildInfo} - lBuildInfo = - emptyBuildInfo - { targetBuildDepends = [baseDep] - , defaultLanguage = Just Haskell2010 - } - baseDep = Dependency "base" anyVersion mainLibSet - - updateContextAndWriteProjectFile' ctx sourcePackage - ScriptContext scriptPath scriptExecutable -> do - unless (length targetStrings == 1) $ - dieWithException verbosity $ - ReplTakesSingleArgument targetStrings - existsScriptPath <- doesFileExist scriptPath - unless existsScriptPath $ - dieWithException verbosity $ - ReplTakesSingleArgument targetStrings - - updateContextAndWriteProjectFile ctx scriptPath scriptExecutable - - -- If multi-repl is used, we need a Cabal recent enough to handle it. - -- We need to do this before solving, but the compiler version is only known - -- after solving (phaseConfigureCompiler), so instead of using - -- multiReplDecision we just check the flag. - let baseCtx' = - if fromFlagOrDefault False $ - projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx) - <> replUseMulti - then - baseCtx - & lProjectConfig . lProjectConfigShared . lProjectConfigConstraints - %~ (multiReplCabalConstraint :) - else baseCtx - - (originalComponent, baseCtx'') <- - if null (envPackages replEnvFlags) - then return (Nothing, baseCtx') - else -- Unfortunately, the best way to do this is to let the normal solver - -- help us resolve the targets, but that isn't ideal for performance, - -- especially in the no-project case. - withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do - -- targets should be non-empty map, but there's no NonEmptyMap yet. - targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors + withContextAndSelectors + AcceptNoTargets + (Just LibKind) + flags + ( map + (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) + targetStrings + ) + globalFlags + ReplCommand + $ \targetCtx ctx targetSelectors -> do + when (buildSettingOnlyDeps (buildSettings ctx)) $ + dieWithException verbosity ReplCommandDoesn'tSupport + let projectRoot = distProjectRootDirectory $ distDirLayout ctx + distDir = distDirectory $ distDirLayout ctx + + baseCtx <- case targetCtx of + ProjectContext -> return ctx + GlobalContext -> do + unless (null targetStrings) $ + dieWithException verbosity $ + ReplTakesNoArguments targetStrings + let + sourcePackage = + fakeProjectSourcePackage projectRoot + & lSrcpkgDescription . L.condLibrary + .~ Just (CondNode library [baseDep] []) + library = emptyLibrary{libBuildInfo = lBuildInfo} + lBuildInfo = + emptyBuildInfo + { targetBuildDepends = [baseDep] + , defaultLanguage = Just Haskell2010 + } + baseDep = Dependency "base" anyVersion mainLibSet + + updateContextAndWriteProjectFile' ctx sourcePackage + ScriptContext scriptPath scriptExecutable -> do + unless (length targetStrings == 1) $ + dieWithException verbosity $ + ReplTakesSingleArgument targetStrings + existsScriptPath <- doesFileExist scriptPath + unless existsScriptPath $ + dieWithException verbosity $ + ReplTakesSingleArgument targetStrings + + updateContextAndWriteProjectFile ctx scriptPath scriptExecutable + + -- If multi-repl is used, we need a Cabal recent enough to handle it. + -- We need to do this before solving, but the compiler version is only known + -- after solving (phaseConfigureCompiler), so instead of using + -- multiReplDecision we just check the flag. + let baseCtx' = + if fromFlagOrDefault False $ + projectConfigMultiRepl (projectConfigShared $ projectConfig baseCtx) + <> replUseMulti + then + baseCtx + & lProjectConfig . lProjectConfigShared . lProjectConfigConstraints + %~ (multiReplCabalConstraint :) + else baseCtx + + (originalComponent, baseCtx'') <- + if null (envPackages replEnvFlags) + then return (Nothing, baseCtx') + else -- Unfortunately, the best way to do this is to let the normal solver + -- help us resolve the targets, but that isn't ideal for performance, + -- especially in the no-project case. + withInstallPlan (lessVerbose verbosity) baseCtx' $ \elaboratedPlan sharedConfig -> do + -- targets should be non-empty map, but there's no NonEmptyMap yet. + targets <- validatedTargets (projectConfigShared (projectConfig ctx)) (pkgConfigCompiler sharedConfig) elaboratedPlan targetSelectors + + let + (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets + originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId + oci = OriginalComponentInfo unitId originalDeps + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId + baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx' + + return (Just oci, baseCtx'') + + -- Now, we run the solver again with the added packages. While the graph + -- won't actually reflect the addition of transitive dependencies, + -- they're going to be available already and will be offered to the REPL + -- and that's good enough. + -- + -- In addition, to avoid a *third* trip through the solver, we are + -- replicating the second half of 'runProjectPreBuildPhase' by hand + -- here. + (buildCtx, compiler, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ + \elaboratedPlan elaboratedShared' -> do + let ProjectBaseContext{..} = baseCtx'' + + -- Recalculate with updated project. + targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors let - (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets - originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId - oci = OriginalComponentInfo unitId originalDeps - pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId - baseCtx'' = addDepsToProjectTarget (envPackages replEnvFlags) pkgId baseCtx' - - return (Just oci, baseCtx'') - - -- Now, we run the solver again with the added packages. While the graph - -- won't actually reflect the addition of transitive dependencies, - -- they're going to be available already and will be offered to the REPL - -- and that's good enough. - -- - -- In addition, to avoid a *third* trip through the solver, we are - -- replicating the second half of 'runProjectPreBuildPhase' by hand - -- here. - (buildCtx, compiler, replOpts', targets) <- withInstallPlan verbosity baseCtx'' $ - \elaboratedPlan elaboratedShared' -> do - let ProjectBaseContext{..} = baseCtx'' - - -- Recalculate with updated project. - targets <- validatedTargets (projectConfigShared projectConfig) (pkgConfigCompiler elaboratedShared') elaboratedPlan targetSelectors - - let - elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan - includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) - - pkgsBuildStatus <- - rebuildTargetsDryRun - distDirLayout - elaboratedShared' - elaboratedPlan' - - let elaboratedPlan'' = - improveInstallPlanWithUpToDatePackages - pkgsBuildStatus - elaboratedPlan' - debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'') - - let - buildCtx = - ProjectBuildContext - { elaboratedPlanOriginal = elaboratedPlan - , elaboratedPlanToExecute = elaboratedPlan'' - , elaboratedShared = elaboratedShared' - , pkgsBuildStatus - , targetsMap = targets - } + elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + includeTransitive = fromFlagOrDefault True (envIncludeTransitive replEnvFlags) + + pkgsBuildStatus <- + rebuildTargetsDryRun + distDirLayout + elaboratedShared' + elaboratedPlan' + + let elaboratedPlan'' = + improveInstallPlanWithUpToDatePackages + pkgsBuildStatus + elaboratedPlan' + debugNoWrap verbosity (showElaboratedInstallPlan elaboratedPlan'') - ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared' - - repl_flags = case originalComponent of - Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci - Nothing -> [] - - return (buildCtx, compiler, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) - - -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for - -- a high-level overview about how everything fits together. - if Set.size (distinctTargetComponents targets) > 1 - then withTempDirectoryEx verbosity tempFileOptions distDir "multi-out" $ \dir' -> do - -- multi target repl - dir <- makeAbsolute dir' - -- Modify the replOptions so that the ./Setup repl command will write options - -- into the multi-out directory. - replOpts'' <- case targetCtx of - ProjectContext -> return $ replOpts'{replOptionsFlagOutput = Flag dir} - _ -> usingGhciScript compiler projectRoot replOpts' - - let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' - printPlan verbosity baseCtx'' buildCtx' - - -- The project build phase will call `./Setup repl` but write the options - -- out into a file without starting a repl. - buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' - runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes - - -- calculate PATH, we construct a PATH which is the union of all paths from - -- the units which have been loaded. This is not quite right but usually works fine. - path_files <- listDirectory (dir "paths") - - -- Note: decode is partial. Should we use Structured here? - -- This might blow up with @build-type: Custom@ stuff. - ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir "paths" f)) path_files - - let all_paths = concatMap programOverrideEnv ghcProgs - let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths))) - -- HACK: Just combine together all env overrides, placing the most common things last - - -- ghc program with overriden PATH - (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) - let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} - - -- Find what the unit files are, and start a repl based on all the response - -- files which have been created in the directory. - -- unit files for components - unit_files <- listDirectory dir - - -- Order the unit files so that the find target becomes the active unit - let active_unit_fp :: Maybe FilePath - active_unit_fp = do - -- Get the first target selectors from the cli - activeTarget <- safeHead targetSelectors - -- Lookup the targets :: Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] - unitId <- - Map.toList targets - -- Keep the UnitId matching the desired target selector - & find (\(_, xs) -> any (\(_, selectors) -> activeTarget `elem` selectors) xs) - & fmap fst - -- Convert to filename (adapted from 'storePackageDirectory') - pure (prettyShow unitId) - unit_files_ordered :: [FilePath] - unit_files_ordered = - let (active_unit_files, other_units) = partition (\fp -> Just fp == active_unit_fp) unit_files - in -- GHC considers the last unit passed to be the active one - other_units ++ active_unit_files - - render_j Serial = "1" - render_j (UseSem n) = show @Int n - render_j (NumJobs mn) = maybe "" (show @Int) mn - - -- run ghc --interactive with - runProgramInvocation verbosity $ - programInvocation ghcProg' $ - concat $ - [ "--interactive" - , "-package-env" - , "-" -- to ignore ghc.environment.* files - , "-j" - , render_j (buildSettingNumJobs (buildSettings ctx)) - ] - : [ ["-unit", "@" ++ dir unit] - | unit <- unit_files_ordered - , unit /= "paths" - ] - - pure () - else do - -- single target repl - replOpts'' <- case targetCtx of - ProjectContext -> return replOpts' - _ -> usingGhciScript compiler projectRoot replOpts' - - let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' - printPlan verbosity baseCtx'' buildCtx' - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' - runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes + let + buildCtx = + ProjectBuildContext + { elaboratedPlanOriginal = elaboratedPlan + , elaboratedPlanToExecute = elaboratedPlan'' + , elaboratedShared = elaboratedShared' + , pkgsBuildStatus + , targetsMap = targets + } + + ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared' + + repl_flags = case originalComponent of + Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci + Nothing -> [] + + return (buildCtx, compiler, configureReplOptions & lReplOptionsFlags %~ (++ repl_flags), targets) + + -- Multi Repl implemention see: https://well-typed.com/blog/2023/03/cabal-multi-unit/ for + -- a high-level overview about how everything fits together. + if Set.size (distinctTargetComponents targets) > 1 + then withTempDirectoryEx verbosity tempFileOptions distDir "multi-out" $ \dir' -> do + -- multi target repl + dir <- makeAbsolute dir' + -- Modify the replOptions so that the ./Setup repl command will write options + -- into the multi-out directory. + replOpts'' <- case targetCtx of + ProjectContext -> return $ replOpts'{replOptionsFlagOutput = Flag dir} + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx'' buildCtx' + + -- The project build phase will call `./Setup repl` but write the options + -- out into a file without starting a repl. + buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' + runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes + + -- calculate PATH, we construct a PATH which is the union of all paths from + -- the units which have been loaded. This is not quite right but usually works fine. + path_files <- listDirectory (dir "paths") + + -- Note: decode is partial. Should we use Structured here? + -- This might blow up with @build-type: Custom@ stuff. + ghcProgs <- mapM (\f -> decode @ConfiguredProgram <$> BS.readFile (dir "paths" f)) path_files + + let all_paths = concatMap programOverrideEnv ghcProgs + let sp = intercalate [searchPathSeparator] (map fst (sortBy (comparing @Int snd) $ Map.toList (combine_search_paths all_paths))) + -- HACK: Just combine together all env overrides, placing the most common things last + + -- ghc program with overriden PATH + (ghcProg, _) <- requireProgram verbosity ghcProgram (pkgConfigCompilerProgs (elaboratedShared buildCtx')) + let ghcProg' = ghcProg{programOverrideEnv = [("PATH", Just sp)]} + + -- Find what the unit files are, and start a repl based on all the response + -- files which have been created in the directory. + -- unit files for components + unit_files <- listDirectory dir + + -- Order the unit files so that the find target becomes the active unit + let active_unit_fp :: Maybe FilePath + active_unit_fp = do + -- Get the first target selectors from the cli + activeTarget <- safeHead targetSelectors + -- Lookup the targets :: Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] + unitId <- + Map.toList targets + -- Keep the UnitId matching the desired target selector + & find (\(_, xs) -> any (\(_, selectors) -> activeTarget `elem` selectors) xs) + & fmap fst + -- Convert to filename (adapted from 'storePackageDirectory') + pure (prettyShow unitId) + unit_files_ordered :: [FilePath] + unit_files_ordered = + let (active_unit_files, other_units) = partition (\fp -> Just fp == active_unit_fp) unit_files + in -- GHC considers the last unit passed to be the active one + other_units ++ active_unit_files + + render_j Serial = "1" + render_j (UseSem n) = show @Int n + render_j (NumJobs mn) = maybe "" (show @Int) mn + + -- run ghc --interactive with + runProgramInvocation verbosity $ + programInvocation ghcProg' $ + concat $ + [ "--interactive" + , "-package-env" + , "-" -- to ignore ghc.environment.* files + , "-j" + , render_j (buildSettingNumJobs (buildSettings ctx)) + ] + : [ ["-unit", "@" ++ dir unit] + | unit <- unit_files_ordered + , unit /= "paths" + ] + + pure () + else do + -- single target repl + replOpts'' <- case targetCtx of + ProjectContext -> return replOpts' + _ -> usingGhciScript compiler projectRoot replOpts' + + let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts'' + printPlan verbosity baseCtx'' buildCtx' + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx'' buildCtx' + runProjectPostBuildPhase verbosity baseCtx'' buildCtx' buildOutcomes where combine_search_paths paths = foldl' go Map.empty paths @@ -514,7 +527,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- Interpret the targets on the command line as repl targets -- (as opposed to say build or haddock targets). targets <- - either (reportTargetProblems verbosity) return $ + either (reportTargetProblems verbosity . map constraintPackage) return $ resolveTargets (selectPackageTargets multi_repl_enabled) selectComponentTarget @@ -538,11 +551,13 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- but that would require another solver run for marginal advantages that -- will further shrink as 3.11 is adopted. multiReplCabalConstraint = - ( UserConstraint - (UserAnySetupQualifier (mkPackageName "Cabal")) - (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11]) - , ConstraintSourceMultiRepl - ) + WithConstraintSource + { constraintPackage = + UserConstraint + (UserAnySetupQualifier (mkPackageName "Cabal")) + (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11]) + , constraintConstraint = ConstraintSourceMultiRepl + } -- | First version of GHC which supports multiple home packages minMultipleHomeUnitsVersion :: Version @@ -866,6 +881,6 @@ lProjectConfigShared :: Lens' ProjectConfig ProjectConfigShared lProjectConfigShared f s = fmap (\x -> s{projectConfigShared = x}) (f (projectConfigShared s)) {-# INLINE lProjectConfigShared #-} -lProjectConfigConstraints :: Lens' ProjectConfigShared [(UserConstraint, ConstraintSource)] +lProjectConfigConstraints :: Lens' ProjectConfigShared [WithConstraintSource UserConstraint] lProjectConfigConstraints f s = fmap (\x -> s{projectConfigConstraints = x}) (f (projectConfigConstraints s)) {-# INLINE lProjectConfigConstraints #-} diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 5c481ae1c76..d4ee7af2c30 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -114,6 +114,8 @@ import Distribution.Simple.Utils , wrapText ) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) import Distribution.Types.ComponentName ( componentNameRaw ) @@ -208,159 +210,169 @@ runCommand = -- "Distribution.Client.ProjectOrchestration" runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = - withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do - (baseCtx, defaultVerbosity) <- case targetCtx of - ProjectContext -> return (ctx, normal) - GlobalContext -> return (ctx, normal) - ScriptContext path exemeta -> (,silent) <$> updateContextAndWriteProjectFile ctx path exemeta - - let verbosity = fromFlagOrDefault defaultVerbosity (setupVerbosity $ configCommonFlags configFlags) - - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - dieWithException verbosity NoSupportForRunCommand - - fullArgs <- getFullArgs - when (occursOnlyOrBefore fullArgs "+RTS" "--") $ - warn verbosity $ - giveRTSWarning "run" - - -- Interpret the targets on the command line as build targets - -- (as opposed to say repl or haddock targets). - targets <- - either (reportTargetProblems verbosity) return $ - resolveTargets - selectPackageTargets - selectComponentTarget + withContextAndSelectors + RejectNoTargets + (Just ExeKind) + flags + ( map + (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) + targetStr + ) + globalFlags + OtherCommand + $ \targetCtx ctx targetSelectors -> do + (baseCtx, defaultVerbosity) <- case targetCtx of + ProjectContext -> return (ctx, normal) + GlobalContext -> return (ctx, normal) + ScriptContext path exemeta -> (,silent) <$> updateContextAndWriteProjectFile ctx path exemeta + + let verbosity = fromFlagOrDefault defaultVerbosity (setupVerbosity $ configCommonFlags configFlags) + + buildCtx <- + runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + dieWithException verbosity NoSupportForRunCommand + + fullArgs <- getFullArgs + when (occursOnlyOrBefore fullArgs "+RTS" "--") $ + warn verbosity $ + giveRTSWarning "run" + + -- Interpret the targets on the command line as build targets + -- (as opposed to say repl or haddock targets). + targets <- + either (reportTargetProblems verbosity . map constraintPackage) return $ + resolveTargets + selectPackageTargets + selectComponentTarget + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + -- + -- Note that we discard the target and return the whole 'TargetsMap', + -- so this check will be repeated (and must succeed) after + -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. + _ <- + singleExeOrElse + ( reportTargetProblems + verbosity + [multipleTargetsProblem targets] + ) + targets + + let elaboratedPlan' = + pruneInstallPlanToTargets + TargetActionBuild + targets + elaboratedPlan + return (elaboratedPlan', targets) + + (selectedUnitId, selectedComponent) <- + -- Slight duplication with 'runProjectPreBuildPhase'. + singleExeOrElse + ( dieWithException verbosity RunPhaseReached + ) + $ targetsMap buildCtx + + printPlan verbosity baseCtx buildCtx + + buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx + runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + let elaboratedPlan = elaboratedPlanToExecute buildCtx + matchingElaboratedConfiguredPackages = + matchingPackagesByUnitId + selectedUnitId elaboratedPlan - Nothing - targetSelectors - - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - -- - -- Note that we discard the target and return the whole 'TargetsMap', - -- so this check will be repeated (and must succeed) after - -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this. - _ <- - singleExeOrElse - ( reportTargetProblems - verbosity - [multipleTargetsProblem targets] - ) - targets - let elaboratedPlan' = - pruneInstallPlanToTargets - TargetActionBuild - targets - elaboratedPlan - return (elaboratedPlan', targets) - - (selectedUnitId, selectedComponent) <- - -- Slight duplication with 'runProjectPreBuildPhase'. - singleExeOrElse - ( dieWithException verbosity RunPhaseReached - ) - $ targetsMap buildCtx - - printPlan verbosity baseCtx buildCtx - - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes - - let elaboratedPlan = elaboratedPlanToExecute buildCtx - matchingElaboratedConfiguredPackages = - matchingPackagesByUnitId - selectedUnitId - elaboratedPlan - - let exeName = unUnqualComponentName selectedComponent - - -- In the common case, we expect @matchingElaboratedConfiguredPackages@ - -- to consist of a single element that provides a single way of building - -- an appropriately-named executable. In that case we take that - -- package and continue. - -- - -- However, multiple packages/components could provide that - -- executable, or it's possible we don't find the executable anywhere - -- in the build plan. I suppose in principle it's also possible that - -- a single package provides an executable in two different ways, - -- though that's probably a bug if. Anyway it's a good lint to report - -- an error in all of these cases, even if some seem like they - -- shouldn't happen. - pkg <- case matchingElaboratedConfiguredPackages of - [] -> dieWithException verbosity $ UnknownExecutable exeName selectedUnitId - [elabPkg] -> do - info verbosity $ - "Selecting " - ++ prettyShow selectedUnitId - ++ " to supply " - ++ exeName - return elabPkg - elabPkgs -> - dieWithException verbosity $ - MultipleMatchingExecutables exeName (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) - - let defaultExePath = - binDirectoryFor - (distDirLayout baseCtx) - (elaboratedShared buildCtx) - pkg - exeName - exeName - exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) - - let dryRun = - buildSettingDryRun (buildSettings baseCtx) - || buildSettingOnlyDownload (buildSettings baseCtx) - - let - -- HACK alert: when doing a per-package build (e.g. with a Custom setup), - -- 'elabExeDependencyPaths' will not contain any internal executables - -- (they are deliberately filtered out; and even if they weren't, they have the wrong paths). - -- We add them back in here to ensure that any "build-tool-depends" of - -- the current executable is available in PATH at runtime. - internalToolDepsOfThisExe - | ElabPackage{} <- elabPkgOrComp pkg - , let pkg_descr = elabPkgDescription pkg - , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr - , let thisExeBI = PD.buildInfo thisExe = - [ binDirectoryFor (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg depExeNm - | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI - , let depExeNm = unUnqualComponentName depExe - ] - | otherwise = - [] - extraPath = - elabExeDependencyPaths pkg - ++ ( fromNubList - . projectConfigProgPathExtra - . projectConfigShared - . projectConfig - $ baseCtx - ) - ++ internalToolDepsOfThisExe - - logExtraProgramSearchPath verbosity extraPath - progPath <- programSearchPathAsPATHVar (map ProgramSearchPathDir extraPath ++ defaultProgramSearchPath) - - if dryRun - then notice verbosity "Running of executable suppressed by flag(s)" - else - runProgramInvocation - verbosity - emptyProgramInvocation - { progInvokePath = exePath - , progInvokeArgs = args - , progInvokeEnv = - ("PATH", Just $ progPath) - : dataDirsEnvironmentForPlan - (distDirLayout baseCtx) - elaboratedPlan - } + let exeName = unUnqualComponentName selectedComponent + + -- In the common case, we expect @matchingElaboratedConfiguredPackages@ + -- to consist of a single element that provides a single way of building + -- an appropriately-named executable. In that case we take that + -- package and continue. + -- + -- However, multiple packages/components could provide that + -- executable, or it's possible we don't find the executable anywhere + -- in the build plan. I suppose in principle it's also possible that + -- a single package provides an executable in two different ways, + -- though that's probably a bug if. Anyway it's a good lint to report + -- an error in all of these cases, even if some seem like they + -- shouldn't happen. + pkg <- case matchingElaboratedConfiguredPackages of + [] -> dieWithException verbosity $ UnknownExecutable exeName selectedUnitId + [elabPkg] -> do + info verbosity $ + "Selecting " + ++ prettyShow selectedUnitId + ++ " to supply " + ++ exeName + return elabPkg + elabPkgs -> + dieWithException verbosity $ + MultipleMatchingExecutables exeName (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs) + + let defaultExePath = + binDirectoryFor + (distDirLayout baseCtx) + (elaboratedShared buildCtx) + pkg + exeName + exeName + exePath = fromMaybe defaultExePath (movedExePath selectedComponent (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg) + + let dryRun = + buildSettingDryRun (buildSettings baseCtx) + || buildSettingOnlyDownload (buildSettings baseCtx) + + let + -- HACK alert: when doing a per-package build (e.g. with a Custom setup), + -- 'elabExeDependencyPaths' will not contain any internal executables + -- (they are deliberately filtered out; and even if they weren't, they have the wrong paths). + -- We add them back in here to ensure that any "build-tool-depends" of + -- the current executable is available in PATH at runtime. + internalToolDepsOfThisExe + | ElabPackage{} <- elabPkgOrComp pkg + , let pkg_descr = elabPkgDescription pkg + , thisExe : _ <- filter ((== exeName) . unUnqualComponentName . PD.exeName) $ PD.executables pkg_descr + , let thisExeBI = PD.buildInfo thisExe = + [ binDirectoryFor (distDirLayout baseCtx) (elaboratedShared buildCtx) pkg depExeNm + | depExe <- getAllInternalToolDependencies pkg_descr thisExeBI + , let depExeNm = unUnqualComponentName depExe + ] + | otherwise = + [] + extraPath = + elabExeDependencyPaths pkg + ++ ( fromNubList + . projectConfigProgPathExtra + . projectConfigShared + . projectConfig + $ baseCtx + ) + ++ internalToolDepsOfThisExe + + logExtraProgramSearchPath verbosity extraPath + progPath <- programSearchPathAsPATHVar (map ProgramSearchPathDir extraPath ++ defaultProgramSearchPath) + + if dryRun + then notice verbosity "Running of executable suppressed by flag(s)" + else + runProgramInvocation + verbosity + emptyProgramInvocation + { progInvokePath = exePath + , progInvokeArgs = args + , progInvokeEnv = + ("PATH", Just $ progPath) + : dataDirsEnvironmentForPlan + (distDirLayout baseCtx) + elaboratedPlan + } where (targetStr, args) = splitAt 1 targetAndArgs diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index 07687bbeb98..9ffb9e6f3b2 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -63,9 +63,15 @@ import Distribution.Client.Types , PackageSpecifier (..) , UnresolvedSourcePackage ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Utils.Path hiding ( (<.>) , () @@ -131,6 +137,7 @@ import Distribution.Verbosity ( normal ) +import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy.Char8 as BSL import System.Directory ( createDirectoryIfMissing @@ -143,6 +150,7 @@ import System.FilePath , (<.>) , () ) +import Text.PrettyPrint (text) ------------------------------------------------------------------------------- -- Command @@ -234,8 +242,14 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do let localPkgs = localPackages baseCtx targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing targetStrings + either (reportTargetSelectorProblems verbosity . map constraintPackage) return + =<< readTargetSelectors + localPkgs + Nothing + ( map + (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) + targetStrings + ) -- elaborate path, create target directory mOutputPath' <- case mOutputPath of @@ -268,7 +282,12 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do | otherwise -> distSdistFile distDirLayout (packageId pkg) case reifyTargetSelectors localPkgs targetSelectors of - Left errs -> dieWithException verbosity $ SdistActionException . fmap renderTargetProblem $ errs + Left errs -> + dieWithException verbosity $ + SdistActionException $ + map + (prettyShow . fmap (text . renderTargetProblem)) + errs Right pkgs | length pkgs > 1 , not listSources @@ -323,7 +342,7 @@ data OutputFormat packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () packageToSdist verbosity projectRootDir format outputFile pkg = do let death = dieWithException verbosity $ ImpossibleHappened (show pkg) - dir0 <- case srcpkgSource pkg of + dir0 <- case constraintPackage $ srcpkgSource pkg of LocalUnpackedPackage path -> pure (Right path) RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) RemoteSourceRepoPackage{} -> death @@ -367,7 +386,10 @@ packageToSdist verbosity projectRootDir format outputFile pkg = do -- -reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] +reifyTargetSelectors + :: [PackageSpecifier UnresolvedSourcePackage] + -> [WithConstraintSource TargetSelector] + -> Either [WithConstraintSource TargetProblem] [UnresolvedSourcePackage] reifyTargetSelectors pkgs sels = case partitionEithers (foldMap go sels) of ([], sels') -> Right sels' @@ -388,14 +410,24 @@ reifyTargetSelectors pkgs sels = Just pkg -> Right pkg Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." - go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] - go (TargetPackage _ pids Nothing) = fmap getPkg pids - go (TargetAllPackages Nothing) = Right <$> pkgs' - go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] - go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] - go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] - go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] - go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] + go :: WithConstraintSource TargetSelector -> [Either (WithConstraintSource TargetProblem) UnresolvedSourcePackage] + go selector = + map + ( bimap + (\problem -> selector{constraintPackage = problem}) + id + ) + inner + where + inner = + case constraintPackage selector of + (TargetPackage _ pids Nothing) -> fmap getPkg pids + (TargetAllPackages Nothing) -> Right <$> pkgs' + (TargetPackage _ _ (Just kind)) -> [Left (AllComponentsOnly kind)] + (TargetAllPackages (Just kind)) -> [Left (AllComponentsOnly kind)] + (TargetPackageNamed pname _) -> [Left (NonlocalPackageNotAllowed pname)] + (TargetComponentUnknown pname _ _) -> [Left (NonlocalPackageNotAllowed pname)] + (TargetComponent _ cname _) -> [Left (ComponentsNotAllowed cname)] data TargetProblem = AllComponentsOnly ComponentKind diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index 7c1adffdc91..7c1465da6ce 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -67,9 +67,12 @@ import qualified System.Exit (exitSuccess) import Distribution.Client.Errors import Distribution.Client.Setup (CommonSetupFlags (..)) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (ConstraintSourceCommandlineFlag)) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) import GHC.Environment ( getFullArgs ) +import qualified Text.PrettyPrint as PP testCommand :: CommandUI (NixStyleFlags ()) testCommand = @@ -124,11 +127,21 @@ testCommand = -- "Distribution.Client.ProjectOrchestration" testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () testAction flags@NixStyleFlags{..} targetStrings globalFlags = do + let targetStrings' = + map + ( \target -> + WithConstraintSource + { constraintPackage = target + , constraintConstraint = ConstraintSourceCommandlineFlag + } + ) + targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + either (reportTargetSelectorProblems verbosity . map constraintPackage) return + =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings' buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -256,17 +269,22 @@ isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ TargetProblemIsSubComponent pkgid name subcomponent -reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a +reportTargetProblems :: Verbosity -> Flag Bool -> [WithConstraintSource TestTargetProblem] -> IO a reportTargetProblems verbosity failWhenNoTestSuites problems = case (failWhenNoTestSuites, problems) of - (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) -> - dieWithException verbosity $ ReportTargetProblems problemsMessage - (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do + ( Flag True + , [ WithConstraintSource + { constraintPackage = CustomTargetProblem (TargetProblemNoTests _) + } + ] + ) -> + dieWithException verbosity $ ReportTargetProblems problemsMessage + (_, [WithConstraintSource{constraintPackage = CustomTargetProblem (TargetProblemNoTests selector)}]) -> do notice verbosity (renderAllowedNoTestsProblem selector) System.Exit.exitSuccess (_, _) -> dieWithException verbosity $ ReportTargetProblems problemsMessage where - problemsMessage = unlines . map renderTestTargetProblem $ problems + problemsMessage = unlines . map (prettyShow . fmap (PP.text . renderTestTargetProblem)) $ problems -- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't -- @die@ when the target problem is 'TargetProblemNoTests'. diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 5f82329eb52..5cfffc1695a 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} ----------------------------------------------------------------------------- @@ -72,6 +73,11 @@ import Distribution.Solver.Types.PkgConfigDb ) import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + , showWithConstraintSource + , withUnknownConstraint + ) import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags) import Distribution.Package @@ -212,13 +218,15 @@ configure let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 in case fst (InstallPlan.ready installPlan) of [ pkg@( ReadyPackage - ( ConfiguredPackage - _ - (SourcePackage _ _ (LocalUnpackedPackage _) _) - _ - _ - _ - ) + ConfiguredPackage + { confPkgSource = + SourcePackage + { srcpkgSource = + WithConstraintSource + { constraintPackage = LocalUnpackedPackage _ + } + } + } ) ] -> do configurePackage @@ -365,26 +373,26 @@ checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do for_ (safeHead unknownConstraints) $ \h -> warn verbosity $ "Constraint refers to an unknown package: " - ++ showConstraint h + ++ showWithConstraintSource prettyShow h for_ (safeHead unknownPreferences) $ \h -> warn verbosity $ "Preference refers to an unknown package: " - ++ prettyShow h + ++ showWithConstraintSource prettyShow h where unknownConstraints = - filter (unknown . userConstraintPackageName . fst) $ + filter (unknown . userConstraintPackageName . constraintPackage) $ configExConstraints flags unknownPreferences = - filter (unknown . \(PackageVersionConstraint name _) -> name) $ + filter (unknown . (\(PackageVersionConstraint name _) -> name) . constraintPackage) $ configPreferences flags unknown pkg = null (PackageIndex.lookupPackageName installedPkgIndex pkg) && not (elemByPackageName sourcePkgIndex pkg) - showConstraint (uc, src) = - prettyShow uc ++ " (" ++ showConstraintSource src ++ ")" -- | Make an 'InstallPlan' for the unpacked package in the current directory, -- and all its dependencies. +-- +-- NOTE: This is only used in the legacy v1 commands. planLocalPackage :: Verbosity -> Compiler @@ -416,7 +424,7 @@ planLocalPackage SourcePackage { srcpkgPackageId = packageId pkg , srcpkgDescription = pkg - , srcpkgSource = LocalUnpackedPackage "." + , srcpkgSource = withUnknownConstraint (LocalUnpackedPackage ".") , srcpkgDescrOverride = Nothing } @@ -435,14 +443,14 @@ planLocalPackage . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags + | PackageVersionConstraint name ver <- map constraintPackage $ configPreferences configExFlags ] . addConstraints -- version constraints from the config file or command line -- TODO: should warn or error on constraints that are not on direct -- deps or flag constraints not on the package in question. - [ LabeledPackageConstraint (userToPackageConstraint uc) src - | (uc, src) <- configExConstraints configExFlags + [ LabeledPackageConstraint (userToPackageConstraint constraintPackage) constraintConstraint + | WithConstraintSource{constraintConstraint, constraintPackage} <- configExConstraints configExFlags ] . addConstraints -- package flags from the config file or command line diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs index d59bc611c44..faeee373293 100644 --- a/cabal-install/src/Distribution/Client/Dependency.hs +++ b/cabal-install/src/Distribution/Client/Dependency.hs @@ -542,7 +542,7 @@ removeBounds relKind relDeps params = sourcePkgIndex' :: PackageIndex.PackageIndex UnresolvedSourcePackage sourcePkgIndex' = relaxDeps <$> depResolverSourcePkgIndex params - relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage + relaxDeps :: SourcePackage a -> SourcePackage a relaxDeps srcPkg = srcPkg { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg) diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs index 033d3a01e14..ccc983996df 100644 --- a/cabal-install/src/Distribution/Client/Fetch.hs +++ b/cabal-install/src/Distribution/Client/Fetch.hs @@ -38,6 +38,9 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb) import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Client.Errors import Distribution.Package @@ -146,7 +149,7 @@ fetch unlines $ "The following packages would be fetched:" : map (prettyShow . packageId) pkgs' - else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs' + else traverse_ (fetchPackage verbosity repoCtxt . constraintPackage . srcpkgSource) pkgs' where dryRun = fromFlag (fetchDryRun fetchFlags) diff --git a/cabal-install/src/Distribution/Client/FetchUtils.hs b/cabal-install/src/Distribution/Client/FetchUtils.hs index 62da386573d..01271449355 100644 --- a/cabal-install/src/Distribution/Client/FetchUtils.hs +++ b/cabal-install/src/Distribution/Client/FetchUtils.hs @@ -68,6 +68,9 @@ import Distribution.Simple.Utils , notice , warn ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Verbosity ( verboseUnmarkOutput ) @@ -99,6 +102,7 @@ import System.IO ) import Control.Monad (forM) +import Control.Monad.Trans.Maybe (MaybeT (..)) import Distribution.Client.Errors import qualified Hackage.Security.Client as Sec import qualified Hackage.Security.Util.Checked as Sec @@ -113,7 +117,7 @@ import qualified Hackage.Security.Util.Path as Sec -- | Returns @True@ if the package has already been fetched -- or does not need fetching. isFetched :: UnresolvedPkgLoc -> IO Bool -isFetched loc = case loc of +isFetched loc = case constraintPackage loc of LocalUnpackedPackage _dir -> return True LocalTarballPackage _file -> return True RemoteTarballPackage _uri local -> return (isJust local) @@ -126,23 +130,26 @@ isFetched loc = case loc of checkFetched :: UnresolvedPkgLoc -> IO (Maybe ResolvedPkgLoc) -checkFetched loc = case loc of - LocalUnpackedPackage dir -> - return (Just $ LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (Just $ LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (Just $ RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (Just $ RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just file) -> - return (Just $ RemoteSourceRepoPackage repo file) - RemoteTarballPackage _uri Nothing -> return Nothing - RemoteSourceRepoPackage _repo Nothing -> return Nothing - RepoTarballPackage repo pkgid Nothing -> - fmap - (fmap (RepoTarballPackage repo pkgid)) - (checkRepoTarballFetched repo pkgid) +checkFetched loc = runMaybeT $ do + packageLocation <- + case constraintPackage loc of + LocalUnpackedPackage dir -> + return (LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just file) -> + return (RemoteSourceRepoPackage repo file) + RemoteTarballPackage _uri Nothing -> empty + RemoteSourceRepoPackage _repo Nothing -> empty + RepoTarballPackage repo pkgid Nothing -> do + fetched <- MaybeT $ checkRepoTarballFetched repo pkgid + return (RepoTarballPackage repo pkgid fetched) + + return loc{constraintPackage = packageLocation} -- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'. checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath) @@ -220,25 +227,29 @@ fetchPackage -> RepoContext -> UnresolvedPkgLoc -> IO ResolvedPkgLoc -fetchPackage verbosity repoCtxt loc = case loc of - LocalUnpackedPackage dir -> - return (LocalUnpackedPackage dir) - LocalTarballPackage file -> - return (LocalTarballPackage file) - RemoteTarballPackage uri (Just file) -> - return (RemoteTarballPackage uri file) - RepoTarballPackage repo pkgid (Just file) -> - return (RepoTarballPackage repo pkgid file) - RemoteSourceRepoPackage repo (Just dir) -> - return (RemoteSourceRepoPackage repo dir) - RemoteTarballPackage uri Nothing -> do - path <- downloadTarballPackage uri - return (RemoteTarballPackage uri path) - RepoTarballPackage repo pkgid Nothing -> do - local <- fetchRepoTarball verbosity repoCtxt repo pkgid - return (RepoTarballPackage repo pkgid local) - RemoteSourceRepoPackage _repo Nothing -> - dieWithException verbosity FetchPackageErr +fetchPackage verbosity repoCtxt loc = do + packageLocation <- + case constraintPackage loc of + LocalUnpackedPackage dir -> + return (LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just dir) -> + return (RemoteSourceRepoPackage repo dir) + RemoteTarballPackage uri Nothing -> do + path <- downloadTarballPackage uri + return (RemoteTarballPackage uri path) + RepoTarballPackage repo pkgid Nothing -> do + local <- fetchRepoTarball verbosity repoCtxt repo pkgid + return (RepoTarballPackage repo pkgid local) + RemoteSourceRepoPackage _repo Nothing -> + dieWithException verbosity FetchPackageErr + + return loc{constraintPackage = packageLocation} where downloadTarballPackage :: URI -> IO FilePath downloadTarballPackage uri = do diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs index a03b45b6a2d..b3e52875fd3 100644 --- a/cabal-install/src/Distribution/Client/Freeze.hs +++ b/cabal-install/src/Distribution/Client/Freeze.hs @@ -52,6 +52,7 @@ import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.SolverId +import Distribution.Solver.Types.WithConstraintSource import Distribution.Client.Errors import Distribution.Package @@ -183,7 +184,7 @@ getFreezePkgs where sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO () sanityCheck pkgSpecifiers = do - when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $ + when (not . null $ [n | n@(Named _) <- pkgSpecifiers]) $ dieWithException verbosity UnexpectedNamedPkgSpecifiers when (length pkgSpecifiers /= 1) $ dieWithException verbosity UnexpectedSourcePkgSpecifiers @@ -314,9 +315,10 @@ freezePackages verbosity globalFlags pkgs = do } } constraint pkg = - ( pkgIdToConstraint $ packageId pkg - , ConstraintSourceUserConfig userPackageEnvironmentFile - ) + WithConstraintSource + { constraintPackage = pkgIdToConstraint $ packageId pkg + , constraintConstraint = ConstraintSourceUserConfig userPackageEnvironmentFile + } where pkgIdToConstraint pkgId = UserConstraint diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs index 39ace2f2652..262d8c51c61 100644 --- a/cabal-install/src/Distribution/Client/Get.hs +++ b/cabal-install/src/Distribution/Client/Get.hs @@ -25,7 +25,12 @@ module Distribution.Client.Get ) where import Distribution.Client.Compat.Prelude hiding (get) -import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..), srpToProxy) +import Distribution.Client.Types.SourceRepo + ( SourceRepoMaybe + , SourceRepoProxy + , SourceRepositoryPackage (..) + , srpToProxy + ) import Distribution.Compat.Directory ( listDirectory ) @@ -74,6 +79,9 @@ import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription ) import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Control.Monad (mapM_) import qualified Data.Map as Map @@ -176,7 +184,7 @@ get verbosity repoCtxt globalFlags getFlags userTargets = do descOverride | usePristine = Nothing | otherwise = srcpkgDescrOverride pkg - case location of + case constraintPackage location of LocalTarballPackage tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath RemoteTarballPackage _tarballURL tarballPath -> @@ -365,12 +373,12 @@ clonePackagesFromSourceRepo -- Now execute all the required commands for each repo sequence_ - [ cloneSourceRepo verbosity vcs' repo destDir + [ cloneSourceRepo verbosity vcs' (constraintPackage repo) destDir `catch` \exitcode -> throwIO ( ClonePackageFailedWithExitCode pkgid - (srpToProxy repo) + (srpToProxy $ constraintPackage repo) (programName (vcsProgram vcs)) exitcode ) @@ -380,7 +388,7 @@ clonePackagesFromSourceRepo where preCloneChecks :: (PackageId, [PD.SourceRepo]) - -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) + -> IO (PackageId, WithConstraintSource SourceRepoMaybe, VCS Program, FilePath) preCloneChecks (pkgid, repos) = do repo <- case selectPackageSourceRepo preferredRepoKind repos of Just repo -> return repo diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs index 705c62d62d1..7ac6fa993a0 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils.hs @@ -116,6 +116,7 @@ import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource (withUnknownConstraint) import qualified Codec.Compression.GZip as GZip import Control.Exception @@ -438,11 +439,12 @@ readRepoIndex verbosity repoCtxt repo idxState = dieIfRequestedIdxIsNewer isi pure ret where + mkAvailablePackage :: PackageEntry -> UnresolvedSourcePackage mkAvailablePackage pkgEntry = SourcePackage { srcpkgPackageId = pkgid , srcpkgDescription = pkgdesc - , srcpkgSource = case pkgEntry of + , srcpkgSource = withUnknownConstraint $ case pkgEntry of NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path , srcpkgDescrOverride = case pkgEntry of diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 635cd7e1689..62bbfa9f742 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -239,6 +239,12 @@ import Distribution.Simple.Utils as Utils , warn , withTempDirectory ) +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.System ( OS (Windows) , Platform @@ -618,12 +624,16 @@ planPackages . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- configPreferences configExFlags + | PackageVersionConstraint name ver <- map constraintPackage $ configPreferences configExFlags ] . addConstraints -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- configExConstraints configExFlags + | WithConstraintSource + { constraintPackage = pc + , constraintConstraint = src + } <- + configExConstraints configExFlags ] . addConstraints -- FIXME: this just applies all flags to all targets which @@ -1100,9 +1110,14 @@ reportPlanningFailure theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackagePropertyVersion version] -> - PackageIdentifier name <$> trivialRange version - NamedPackage _ _ -> Nothing + Named + ( WithConstraintSource + { constraintPackage = + NamedPackage name [PackagePropertyVersion version] + } + ) -> + PackageIdentifier name <$> trivialRange version + Named _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg where -- \| If a range includes only a single version, return Just that version. @@ -1712,7 +1727,7 @@ installLocalPackage -> (Maybe FilePath -> IO BuildOutcome) -> IO BuildOutcome installLocalPackage verbosity pkgid location distPref installPkg = - case location of + case constraintPackage location of LocalUnpackedPackage dir -> installPkg (Just dir) RemoteSourceRepoPackage _repo dir -> diff --git a/cabal-install/src/Distribution/Client/List.hs b/cabal-install/src/Distribution/Client/List.hs index 480e2c46fd7..d840df84674 100644 --- a/cabal-install/src/Distribution/Client/List.hs +++ b/cabal-install/src/Distribution/Client/List.hs @@ -65,9 +65,15 @@ import Distribution.Version import qualified Distribution.SPDX as SPDX +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + ) import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Client.FetchUtils ( isFetched @@ -317,7 +323,7 @@ info prefs installedPkgIndex sourcePkgIndex - (NamedPackage name props) + (Named (WithConstraintSource{constraintPackage = NamedPackage name props})) | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ GatherPkgInfo name (simplifyVersionRange verConstraint) | otherwise = diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index e70a89af8a3..648963bd17a 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -74,6 +74,9 @@ import Distribution.Package import Distribution.Simple.Compiler import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Compat.Graph (IsNode (..)) import Distribution.Simple.Utils @@ -186,7 +189,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = return BuildStatusInstalled dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do mloc <- checkFetched (elabPkgSourceLocation pkg) - case mloc of + case constraintPackage <$> mloc of Nothing -> return BuildStatusDownload Just (LocalUnpackedPackage srcdir) -> -- For the case of a user-managed local dir, irrespective of the @@ -449,7 +452,10 @@ rebuildTargets packagesToDownload :: [ElaboratedConfiguredPackage] packagesToDownload = - [ elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan, isRemote $ elabPkgSourceLocation elab + [ elab + | InstallPlan.Configured elab <- + InstallPlan.reverseTopologicalOrder installPlan + , isRemote $ constraintPackage $ elabPkgSourceLocation elab ] where isRemote :: PackageLocation a -> Bool @@ -637,7 +643,7 @@ asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body pkgsToDownload body where - pkgsToDownload :: [PackageLocation (Maybe FilePath)] + pkgsToDownload :: [PackageLocationProvenance (Maybe FilePath)] pkgsToDownload = ordNub $ [ elabPkgSourceLocation elab @@ -670,10 +676,10 @@ data DownloadedSourceLocation = DownloadedTarball FilePath -- TODO: [nice to have] git/darcs repos etc downloadedSourceLocation - :: PackageLocation FilePath + :: PackageLocationProvenance FilePath -> Maybe DownloadedSourceLocation downloadedSourceLocation pkgloc = - case pkgloc of + case constraintPackage pkgloc of RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) _ -> Nothing diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index eea6b958b70..f6d108bae1d 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -12,7 +12,6 @@ module Distribution.Client.ProjectConfig , ProjectConfigToParse (..) , ProjectConfigBuildOnly (..) , ProjectConfigShared (..) - , ProjectConfigProvenance (..) , PackageConfig (..) , MapLast (..) , MapMappend (..) @@ -113,9 +112,15 @@ import Distribution.Client.Types import Distribution.Client.Utils.Parsec (renderParseError) import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + ) import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Client.Errors import Distribution.Client.Setup @@ -128,6 +133,7 @@ import Distribution.Client.SrcDist import Distribution.Client.Targets import Distribution.Client.Types.SourceRepo ( SourceRepoList + , SourceRepoMaybe , SourceRepositoryPackage (..) , srpFanOut ) @@ -328,11 +334,13 @@ resolveSolverSettings cabalPkgname = mkPackageName "Cabal" profilingDynamicConstraint = - ( UserConstraint - (UserAnySetupQualifier cabalPkgname) - (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) - , ConstraintSourceProfiledDynamic - ) + WithConstraintSource + { constraintPackage = + UserConstraint + (UserAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) + , constraintConstraint = ConstraintSourceProfiledDynamic + } profDynEnabledGlobally = fromFlagOrDefault False (packageConfigProfShared projectConfigLocalPackages) @@ -597,7 +605,9 @@ findProjectRoot verbosity mprojectDir mprojectFile = do getProjectRootUsability file >>= \case ProjectRootUsabilityPresentAndUsable -> uncurry projectRoot - =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file + =<< first dropTrailingPathSeparator + . splitFileName + <$> canonicalizePath file ProjectRootUsabilityNotPresent -> left (BadProjectRootExplicitFileNotFound file) ProjectRootUsabilityPresentAndUnusable -> @@ -736,7 +746,7 @@ withProjectOrGlobalConfig' with without = do , let isGlobErr (BadLocGlobEmptyMatch _) = True isGlobErr _ = False - , any isGlobErr locs -> do + , any (isGlobErr . constraintPackage) locs -> do without err -> throwIO err @@ -781,7 +791,13 @@ defaultImplicitProjectConfig :: ProjectConfig defaultImplicitProjectConfig = mempty { -- We expect a package in the current directory. - projectPackages = ["./*.cabal"] + projectPackages = + [ WithConstraintSource + { constraintPackage = "./*.cabal" + , -- TODO: Is a relative path OK here? + constraintConstraint = ConstraintSourceMainConfig "." + } + ] , projectConfigProvenance = Set.singleton Implicit } @@ -840,7 +856,8 @@ readProjectFileSkeleton readExtensionFile = reportParseResult verbosity extensionDescription extensionFile - =<< parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity . ProjectConfigToParse + =<< parseProject extensionFile distDownloadSrcDirectory httpTransport verbosity + . ProjectConfigToParse =<< BS.readFile extensionFile -- | Render the 'ProjectConfig' format. @@ -903,7 +920,7 @@ data ProjectPackageLocation -- | Exception thrown by 'findProjectPackages'. data BadPackageLocations - = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation] + = BadPackageLocations (Set ProjectConfigProvenance) [WithConstraintSource BadPackageLocation] deriving (Show, Typeable) instance Exception BadPackageLocations where @@ -968,19 +985,41 @@ renderBadPackageLocations (BadPackageLocations provenance bpls) -- cases handled. More cases should be added with informative help text -- about the issues related specifically when having no project configuration -- is present. -renderImplicitBadPackageLocation :: BadPackageLocation -> String -renderImplicitBadPackageLocation bpl = case bpl of - BadLocGlobEmptyMatch pkglocstr -> - "No cabal.project file or cabal file matching the default glob '" - ++ pkglocstr - ++ "' was found.\n" - ++ "Please create a package description file .cabal " - ++ "or a cabal.project file referencing the packages you " - ++ "want to build." - _ -> renderBadPackageLocation bpl - -renderBadPackageLocation :: BadPackageLocation -> String -renderBadPackageLocation bpl = case bpl of +renderImplicitBadPackageLocation :: WithConstraintSource BadPackageLocation -> String +renderImplicitBadPackageLocation + ( WithConstraintSource + { constraintPackage = bpl + , constraintConstraint = constraint + } + ) = + inner + ++ "\nFrom " + ++ showConstraintSource constraint + where + inner = + case bpl of + BadLocGlobEmptyMatch pkglocstr -> + "No cabal.project file or cabal file matching the default glob '" + ++ pkglocstr + ++ "' was found.\n" + ++ "Please create a package description file .cabal " + ++ "or a cabal.project file referencing the packages you " + ++ "want to build." + _ -> renderBadPackageLocationInner bpl + +renderBadPackageLocation :: WithConstraintSource BadPackageLocation -> String +renderBadPackageLocation + ( WithConstraintSource + { constraintPackage = bpl + , constraintConstraint = constraint + } + ) = + renderBadPackageLocationInner bpl + ++ "\nFrom " + ++ showConstraintSource constraint + +renderBadPackageLocationInner :: BadPackageLocation -> String +renderBadPackageLocationInner bpl = case bpl of BadPackageLocationFile badmatch -> renderBadPackageLocationMatch badmatch BadLocGlobEmptyMatch pkglocstr -> @@ -1006,27 +1045,27 @@ renderBadPackageLocation bpl = case bpl of ++ "be a valid absolute URI." BadLocUnrecognised pkglocstr -> "The package location syntax '" ++ pkglocstr ++ "' is not recognised." - -renderBadPackageLocationMatch :: BadPackageLocationMatch -> String -renderBadPackageLocationMatch bplm = case bplm of - BadLocUnexpectedFile pkglocstr -> - "The package location '" - ++ pkglocstr - ++ "' is not recognised. The " - ++ "supported file targets are .cabal files, .tar.gz tarballs or package " - ++ "directories (i.e. directories containing a .cabal file)." - BadLocNonexistantFile pkglocstr -> - "The package location '" ++ pkglocstr ++ "' does not exist." - BadLocDirNoCabalFile pkglocstr -> - "The package directory '" - ++ pkglocstr - ++ "' does not contain any " - ++ ".cabal file." - BadLocDirManyCabalFiles pkglocstr -> - "The package directory '" - ++ pkglocstr - ++ "' contains multiple " - ++ ".cabal files (which is not currently supported)." + where + renderBadPackageLocationMatch :: BadPackageLocationMatch -> String + renderBadPackageLocationMatch bplm = case bplm of + BadLocUnexpectedFile pkglocstr -> + "The package location '" + ++ pkglocstr + ++ "' is not recognised. The " + ++ "supported file targets are .cabal files, .tar.gz tarballs or package " + ++ "directories (i.e. directories containing a .cabal file)." + BadLocNonexistantFile pkglocstr -> + "The package location '" ++ pkglocstr ++ "' does not exist." + BadLocDirNoCabalFile pkglocstr -> + "The package directory '" + ++ pkglocstr + ++ "' does not contain any " + ++ ".cabal file." + BadLocDirManyCabalFiles pkglocstr -> + "The package directory '" + ++ pkglocstr + ++ "' contains multiple " + ++ ".cabal files (which is not currently supported)." -- | Determines the location of all packages mentioned in the project configuration. -- @@ -1034,18 +1073,21 @@ renderBadPackageLocationMatch bplm = case bplm of findProjectPackages :: DistDirLayout -> ProjectConfig - -> Rebuild [ProjectPackageLocation] + -> Rebuild [WithConstraintSource ProjectPackageLocation] findProjectPackages DistDirLayout{distProjectRootDirectory} ProjectConfig{..} = do requiredPkgs <- findPackageLocations True projectPackages optionalPkgs <- findPackageLocations False projectPackagesOptional - let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo - namedPkgs = map ProjectPackageNamed projectPackagesNamed + let repoPkgs = map (fmap ProjectPackageRemoteRepo) projectPackagesRepo + namedPkgs = map (fmap ProjectPackageNamed) projectPackagesNamed return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs]) where - findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation] + findPackageLocations + :: Bool + -> [WithConstraintSource String] + -> Rebuild [WithConstraintSource ProjectPackageLocation] findPackageLocations required pkglocstr = do (problems, pkglocs) <- partitionEithers <$> traverse (findPackageLocation required) pkglocstr @@ -1057,31 +1099,43 @@ findProjectPackages findPackageLocation :: Bool - -> String - -> Rebuild (Either BadPackageLocation [ProjectPackageLocation]) - findPackageLocation _required@True pkglocstr = + -> WithConstraintSource String + -> Rebuild + ( Either + (WithConstraintSource BadPackageLocation) + [WithConstraintSource ProjectPackageLocation] + ) + findPackageLocation _required@True pkgloc = -- strategy: try first as a file:// or http(s):// URL. -- then as a file glob (usually encompassing single file) -- finally as a single file, for files that fail to parse as globs - checkIsUriPackage pkglocstr - `mplusMaybeT` checkIsFileGlobPackage pkglocstr - `mplusMaybeT` checkIsSingleFilePackage pkglocstr - >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return - findPackageLocation _required@False pkglocstr = do + checkIsUriPackage pkgloc + `mplusMaybeT` checkIsFileGlobPackage pkgloc + `mplusMaybeT` checkIsSingleFilePackage pkgloc + >>= maybe + (return (Left ((\pkglocstr -> BadLocUnrecognised pkglocstr) <$> pkgloc))) + return + findPackageLocation _required@False pkgloc = do -- just globs for optional case - res <- checkIsFileGlobPackage pkglocstr + res <- checkIsFileGlobPackage pkgloc case res of - Nothing -> return (Left (BadLocUnrecognised pkglocstr)) + Nothing -> return (Left ((\pkglocstr -> BadLocUnrecognised pkglocstr) <$> pkgloc)) Just (Left _) -> return (Right []) -- it's optional Just (Right pkglocs) -> return (Right pkglocs) checkIsUriPackage , checkIsFileGlobPackage , checkIsSingleFilePackage - :: String - -> Rebuild (Maybe (Either BadPackageLocation [ProjectPackageLocation])) - checkIsUriPackage pkglocstr = - case parseAbsoluteURI pkglocstr of + :: WithConstraintSource String + -> Rebuild + ( Maybe + ( Either + (WithConstraintSource BadPackageLocation) + [WithConstraintSource ProjectPackageLocation] + ) + ) + checkIsUriPackage pkgloc = + case parseAbsoluteURI $ constraintPackage pkgloc of Just uri@URI { uriScheme = scheme @@ -1091,22 +1145,25 @@ findProjectPackages , uriFragment = frag } | recognisedScheme && not (null host) -> - return (Just (Right [ProjectPackageRemoteTarball uri])) + return (Just (Right [const (ProjectPackageRemoteTarball uri) <$> pkgloc])) | scheme == "file:" && null host && null query && null frag -> - checkIsSingleFilePackage path + checkIsSingleFilePackage (const path <$> pkgloc) | not recognisedScheme && not (null host) -> - return (Just (Left (BadLocUnexpectedUriScheme pkglocstr))) + return (Just (Left (BadLocUnexpectedUriScheme <$> pkgloc))) | recognisedScheme && null host -> - return (Just (Left (BadLocUnrecognisedUri pkglocstr))) + return (Just (Left (BadLocUnrecognisedUri <$> pkgloc))) where recognisedScheme = - scheme == "http:" - || scheme == "https:" - || scheme == "file:" + scheme + == "http:" + || scheme + == "https:" + || scheme + == "file:" _ -> return Nothing - checkIsFileGlobPackage pkglocstr = - case simpleParsec pkglocstr of + checkIsFileGlobPackage pkgloc = + case simpleParsec $ constraintPackage pkgloc of Nothing -> return Nothing Just glob -> liftM Just $ do matches <- matchFileGlob glob @@ -1116,45 +1173,58 @@ findProjectPackages return ( Left ( BadPackageLocationFile - (BadLocNonexistantFile pkglocstr) + . BadLocNonexistantFile + <$> pkgloc ) ) - [] -> return (Left (BadLocGlobEmptyMatch pkglocstr)) + [] -> return (Left (BadLocGlobEmptyMatch <$> pkgloc)) _ -> do (failures, pkglocs) <- partitionEithers - <$> traverse checkFilePackageMatch matches + <$> traverse + ( checkFilePackageMatch + . (\match -> pkgloc{constraintPackage = match}) + ) + matches return $! case (failures, pkglocs) of ([failure], []) | isJust (isTrivialRootedGlob glob) -> - Left (BadPackageLocationFile failure) - (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures) + Left (BadPackageLocationFile <$> failure) + (_, []) -> + -- Note: The `ConstraintSources` we're dropping here are all + -- copied from `pkgloc` anyways, so we don't lose information. + Left + ( (\pkglocstr -> BadLocGlobBadMatches pkglocstr (map constraintPackage failures)) + <$> pkgloc + ) _ -> Right pkglocs - checkIsSingleFilePackage pkglocstr = do - let filename = distProjectRootDirectory pkglocstr + checkIsSingleFilePackage pkgloc = do + let pkglocstr = constraintPackage pkgloc + filename = distProjectRootDirectory pkglocstr isFile <- liftIO $ doesFileExist filename isDir <- liftIO $ doesDirectoryExist filename if isFile || isDir then - checkFilePackageMatch pkglocstr + checkFilePackageMatch pkgloc >>= either - (return . Just . Left . BadPackageLocationFile) + (return . Just . Left . fmap BadPackageLocationFile) (return . Just . Right . (\x -> [x])) else return Nothing checkFilePackageMatch - :: String + :: WithConstraintSource String -> Rebuild ( Either - BadPackageLocationMatch - ProjectPackageLocation + (WithConstraintSource BadPackageLocationMatch) + (WithConstraintSource ProjectPackageLocation) ) - checkFilePackageMatch pkglocstr = do + checkFilePackageMatch pkgloc = do -- The pkglocstr may be absolute or may be relative to the project root. -- Either way, does the right thing here. We return relative paths if -- they were relative in the first place. - let abspath = distProjectRootDirectory pkglocstr + let pkglocstr = constraintPackage pkgloc + abspath = distProjectRootDirectory pkglocstr isFile <- liftIO $ doesFileExist abspath isDir <- liftIO $ doesDirectoryExist abspath parentDirExists <- case takeDirectory abspath of @@ -1169,27 +1239,30 @@ findProjectPackages [cabalFile] -> return ( Right - ( ProjectPackageLocalDirectory - pkglocstr - cabalFile + ( pkgloc + { constraintPackage = + ProjectPackageLocalDirectory pkglocstr cabalFile + } ) ) - [] -> return (Left (BadLocDirNoCabalFile pkglocstr)) - _ -> return (Left (BadLocDirManyCabalFiles pkglocstr)) + [] -> return (Left (BadLocDirNoCabalFile <$> pkgloc)) + _ -> return (Left (BadLocDirManyCabalFiles <$> pkgloc)) | extensionIsTarGz pkglocstr -> - return (Right (ProjectPackageLocalTarball pkglocstr)) + return (Right (ProjectPackageLocalTarball <$> pkgloc)) | takeExtension pkglocstr == ".cabal" -> - return (Right (ProjectPackageLocalCabalFile pkglocstr)) + return (Right (ProjectPackageLocalCabalFile <$> pkgloc)) | isFile -> - return (Left (BadLocUnexpectedFile pkglocstr)) + return (Left (BadLocUnexpectedFile <$> pkgloc)) | parentDirExists -> - return (Left (BadLocNonexistantFile pkglocstr)) + return (Left (BadLocNonexistantFile <$> pkgloc)) | otherwise -> - return (Left (BadLocUnexpectedFile pkglocstr)) + return (Left (BadLocUnexpectedFile <$> pkgloc)) extensionIsTarGz f = - takeExtension f == ".gz" - && takeExtension (dropExtension f) == ".tar" + takeExtension f + == ".gz" + && takeExtension (dropExtension f) + == ".tar" -- | A glob to find all the cabal files in a directory. -- @@ -1230,7 +1303,7 @@ fetchAndReadSourcePackages -> Compiler -> ProjectConfigShared -> ProjectConfigBuildOnly - -> [ProjectPackageLocation] + -> [WithConstraintSource ProjectPackageLocation] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] fetchAndReadSourcePackages verbosity @@ -1241,15 +1314,23 @@ fetchAndReadSourcePackages pkgLocations = do pkgsLocalDirectory <- sequenceA - [ readSourcePackageLocalDirectory verbosity dir cabalFile - | location <- pkgLocations + [ readSourcePackageLocalDirectory verbosity constraint dir cabalFile + | WithConstraintSource + { constraintPackage = location + , constraintConstraint = constraint + } <- + pkgLocations , (dir, cabalFile) <- projectPackageLocal location ] pkgsLocalTarball <- sequenceA - [ readSourcePackageLocalTarball verbosity path - | ProjectPackageLocalTarball path <- pkgLocations + [ readSourcePackageLocalTarball verbosity constraint path + | WithConstraintSource + { constraintPackage = ProjectPackageLocalTarball path + , constraintConstraint = constraint + } <- + pkgLocations ] pkgsRemoteTarball <- do @@ -1262,10 +1343,15 @@ fetchAndReadSourcePackages sequenceA [ fetchAndReadSourcePackageRemoteTarball verbosity + constraint distDirLayout getTransport uri - | ProjectPackageRemoteTarball uri <- pkgLocations + | WithConstraintSource + { constraintPackage = ProjectPackageRemoteTarball uri + , constraintConstraint = constraint + } <- + pkgLocations ] pkgsRemoteRepo <- @@ -1276,11 +1362,20 @@ fetchAndReadSourcePackages projectConfigShared projectConfigBuildOnly (fromFlag (projectConfigOfflineMode projectConfigBuildOnly)) - [repo | ProjectPackageRemoteRepo repo <- pkgLocations] + [ withConstraint{constraintPackage = repo} + | withConstraint@WithConstraintSource + { constraintPackage = ProjectPackageRemoteRepo repo + } <- + pkgLocations + ] let pkgsNamed = - [ NamedPackage pkgname [PackagePropertyVersion verrange] - | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations + [ Named (withConstraint{constraintPackage = NamedPackage pkgname [PackagePropertyVersion verrange]}) + | withConstraint@WithConstraintSource + { constraintPackage = + ProjectPackageNamed (PackageVersionConstraint pkgname verrange) + } <- + pkgLocations ] return $ @@ -1307,15 +1402,20 @@ fetchAndReadSourcePackages -- We simply read the @.cabal@ file. readSourcePackageLocalDirectory :: Verbosity + -> ConstraintSource -> FilePath -- ^ The package directory -> FilePath -- ^ The package @.cabal@ file -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalDirectory verbosity dir cabalFile = do +readSourcePackageLocalDirectory verbosity constraintConstraint dir cabalFile = do monitorFiles [monitorFileHashed cabalFile] root <- askRoot - let location = LocalUnpackedPackage (root dir) + let location = + WithConstraintSource + { constraintPackage = LocalUnpackedPackage (root dir) + , constraintConstraint + } liftIO $ fmap (mkSpecificSourcePackage location) . readSourcePackageCabalFile verbosity cabalFile @@ -1326,12 +1426,17 @@ readSourcePackageLocalDirectory verbosity dir cabalFile = do -- the @.cabal@ file and read that. readSourcePackageLocalTarball :: Verbosity + -> ConstraintSource -> FilePath -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) -readSourcePackageLocalTarball verbosity tarballFile = do +readSourcePackageLocalTarball verbosity constraintConstraint tarballFile = do monitorFiles [monitorFile tarballFile] root <- askRoot - let location = LocalTarballPackage (root tarballFile) + let location = + WithConstraintSource + { constraintPackage = LocalTarballPackage (root tarballFile) + , constraintConstraint + } liftIO $ fmap (mkSpecificSourcePackage location) . uncurry (readSourcePackageCabalFile verbosity) @@ -1342,12 +1447,14 @@ readSourcePackageLocalTarball verbosity tarballFile = do -- and after that handle it like the local tarball case. fetchAndReadSourcePackageRemoteTarball :: Verbosity + -> ConstraintSource -> DistDirLayout -> Rebuild HttpTransport -> URI -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) fetchAndReadSourcePackageRemoteTarball verbosity + constraintConstraint DistDirLayout { distDownloadSrcDirectory } @@ -1370,7 +1477,11 @@ fetchAndReadSourcePackageRemoteTarball -- Read monitorFiles [monitorFile tarballFile] - let location = RemoteTarballPackage tarballUri tarballFile + let location = + WithConstraintSource + { constraintPackage = RemoteTarballPackage tarballUri tarballFile + , constraintConstraint + } liftIO $ fmap (mkSpecificSourcePackage location) . uncurry (readSourcePackageCabalFile verbosity) @@ -1395,7 +1506,7 @@ syncAndReadSourcePackagesRemoteRepos -> ProjectConfigShared -> ProjectConfigBuildOnly -> Bool - -> [SourceRepoList] + -> [WithConstraintSource SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncAndReadSourcePackagesRemoteRepos verbosity @@ -1419,11 +1530,13 @@ syncAndReadSourcePackagesRemoteRepos let reposByLocation :: Map (RepoType, String) - [(SourceRepoList, RepoType)] + [(WithConstraintSource SourceRepoList, RepoType)] reposByLocation = Map.fromListWith (++) - [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) + [ ( (rtype, rloc) + , [(repo, vcsRepoType vcs)] + ) | (repo, rloc, rtype, vcs) <- repos' ] @@ -1446,10 +1559,10 @@ syncAndReadSourcePackagesRemoteRepos , let repoGroup' = map fst repoGroup pathStem = distDownloadSrcDirectory - localFileNameForRemoteRepo primaryRepo + localFileNameForRemoteRepo (constraintPackage primaryRepo) monitor :: FileMonitor - [SourceRepoList] + [WithConstraintSource SourceRepoList] [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] monitor = newFileMonitor (pathStem <.> "cache") ] @@ -1458,7 +1571,7 @@ syncAndReadSourcePackagesRemoteRepos syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram -> FilePath - -> [SourceRepoList] + -> [WithConstraintSource SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do liftIO $ @@ -1497,13 +1610,23 @@ syncAndReadSourcePackagesRemoteRepos where -- So to do both things above, we pair them up here. repoGroupWithPaths - :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] + :: [ ( SourceRepositoryPackage Proxy + , NonEmpty (WithConstraintSource SourceRepoMaybe) + , FilePath + ) + ] repoGroupWithPaths = zipWith (\(x, y) z -> (x, y, z)) ( mapGroup - [ (repo{srpSubdir = Proxy}, repo) - | repo <- foldMap (NE.toList . srpFanOut) repoGroup + [ ( repoWithSubdir{srpSubdir = Proxy} + , withConstraint{constraintPackage = repoWithSubdir} + ) + | withConstraint@WithConstraintSource + { constraintPackage = repo + } <- + repoGroup + , repoWithSubdir <- NE.toList (srpFanOut repo) ] ) repoPaths @@ -1519,11 +1642,12 @@ syncAndReadSourcePackagesRemoteRepos : [pathStem ++ "-" ++ show (i :: Int) | i <- [2 ..]] readPackageFromSourceRepo - :: SourceRepositoryPackage Maybe + :: WithConstraintSource SourceRepoMaybe -> FilePath - -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) - readPackageFromSourceRepo repo repoPath = do - let packageDir :: FilePath + -> Rebuild (PackageSpecifier UnresolvedSourcePackage) + readPackageFromSourceRepo withConstraint repoPath = do + let repo = constraintPackage withConstraint + packageDir :: FilePath packageDir = maybe repoPath (repoPath ) (srpSubdir repo) entries <- liftIO $ getDirectoryContents packageDir @@ -1541,28 +1665,31 @@ syncAndReadSourcePackagesRemoteRepos let tarballPath = repoPath ++ "-" ++ prettyShow (packageId gpd) ++ ".tar.gz" liftIO $ LBS.writeFile tarballPath tarball - let location = RemoteSourceRepoPackage repo tarballPath + let location = + withConstraint + { constraintPackage = RemoteSourceRepoPackage repo tarballPath + } return $ mkSpecificSourcePackage location gpd - reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a + reportSourceRepoProblems :: [(WithConstraintSource SourceRepoList, SourceRepoProblem)] -> Rebuild a reportSourceRepoProblems = liftIO . dieWithException verbosity . ReportSourceRepoProblems . renderSourceRepoProblems - renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String + renderSourceRepoProblems :: [(WithConstraintSource SourceRepoList, SourceRepoProblem)] -> String renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" -- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an -- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package -- from a given location. mkSpecificSourcePackage - :: PackageLocation FilePath + :: PackageLocationProvenance FilePath -> GenericPackageDescription - -> PackageSpecifier (SourcePackage UnresolvedPkgLoc) + -> PackageSpecifier UnresolvedSourcePackage mkSpecificSourcePackage location pkg = SpecificSourcePackage SourcePackage { srcpkgPackageId = packageId pkg , srcpkgDescription = pkg - , srcpkgSource = fmap Just location + , srcpkgSource = fmap (fmap Just) location , srcpkgDescrOverride = Nothing } diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 49720fdd8ea..58b67d5cdbb 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -41,7 +41,10 @@ import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..)) import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..), emptyRemoteRepo) import Distribution.Client.Types.RepoName (RepoName (..), unRepoName) -import Distribution.Client.Types.SourceRepo (SourceRepoList, sourceRepositoryPackageGrammar) +import Distribution.Client.Types.SourceRepo + ( SourceRepoList + , constraintSourceRepositoryPackageGrammar + ) import Distribution.Client.Config ( SavedConfig (..) @@ -59,6 +62,9 @@ import Distribution.Compat.Lens (toListOf, view) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.ProjectConfigPath +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Client.NixStyleOptions (NixStyleFlags (..)) import Distribution.Client.ProjectFlags (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions) @@ -378,10 +384,10 @@ parseProjectSkeleton cacheDir httpTransport verbosity projectDir source (Project -- Ultimately if\/when this project-based approach becomes the default then we -- can redefine the parsers directly for the new types. data LegacyProjectConfig = LegacyProjectConfig - { legacyPackages :: [String] - , legacyPackagesOptional :: [String] - , legacyPackagesRepo :: [SourceRepoList] - , legacyPackagesNamed :: [PackageVersionConstraint] + { legacyPackages :: [WithConstraintSource String] + , legacyPackagesOptional :: [WithConstraintSource String] + , legacyPackagesRepo :: [WithConstraintSource SourceRepoList] + , legacyPackagesNamed :: [WithConstraintSource PackageVersionConstraint] , legacySharedConfig :: LegacySharedConfig , legacyAllConfig :: LegacyPackageConfig , legacyLocalConfig :: LegacyPackageConfig @@ -1252,7 +1258,7 @@ parseLegacyProjectConfigFields (ConstraintSourceProjectConfig -> constraintSrc) parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc) legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs + (legacyPackageConfigFGSectionDescrs constraintSrc) mempty parseLegacyProjectConfig :: FilePath -> BS.ByteString -> ParseResult LegacyProjectConfig @@ -1265,7 +1271,7 @@ showLegacyProjectConfig config = showConfig (legacyProjectConfigFieldDescrs constraintSrc) legacyPackageConfigSectionDescrs - legacyPackageConfigFGSectionDescrs + (legacyPackageConfigFGSectionDescrs constraintSrc) config $+$ Disp.text "" where @@ -1278,20 +1284,26 @@ legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectC legacyProjectConfigFieldDescrs constraintSrc = [ newLineListField "packages" - (Disp.text . renderPackageLocationToken) - parsePackageLocationTokenQ + (pretty . fmap (Disp.text . renderPackageLocationToken)) + ( (\pkg -> WithConstraintSource{constraintPackage = pkg, constraintConstraint = constraintSrc}) + `fmap` parsePackageLocationTokenQ + ) legacyPackages (\v flags -> flags{legacyPackages = v}) , newLineListField "optional-packages" - (Disp.text . renderPackageLocationToken) - parsePackageLocationTokenQ + (pretty . fmap (Disp.text . renderPackageLocationToken)) + ( (\pkg -> WithConstraintSource{constraintPackage = pkg, constraintConstraint = constraintSrc}) + `fmap` parsePackageLocationTokenQ + ) legacyPackagesOptional (\v flags -> flags{legacyPackagesOptional = v}) , commaNewLineListFieldParsec "extra-packages" pretty - parsec + ( (\pkg -> WithConstraintSource{constraintPackage = pkg, constraintConstraint = constraintSrc}) + `fmap` parsec + ) legacyPackagesNamed (\v flags -> flags{legacyPackagesNamed = v}) ] @@ -1410,14 +1422,18 @@ legacySharedConfigFieldDescrs constraintSrc = . addFields [ commaNewLineListFieldParsec "constraints" - (pretty . fst) - (fmap (\constraint -> (constraint, constraintSrc)) parsec) + pretty + ( (\constraint -> WithConstraintSource{constraintPackage = constraint, constraintConstraint = constraintSrc}) + `fmap` parsec + ) configExConstraints (\v conf -> conf{configExConstraints = v}) , commaNewLineListFieldParsec "preferences" pretty - parsec + ( (\preference -> WithConstraintSource{constraintPackage = preference, constraintConstraint = constraintSrc}) + `fmap` parsec + ) configPreferences (\v conf -> conf{configPreferences = v}) , monoidFieldParsec @@ -1772,14 +1788,16 @@ legacyPackageConfigFieldDescrs = legacyPackageConfigFGSectionDescrs :: ( FieldGrammar c g + , Applicative (g (WithConstraintSource SourceRepoList)) , Applicative (g SourceRepoList) , c (Identity RepoType) , c (List NoCommaFSep FilePathNT String) , c (NonEmpty' NoCommaFSep Token String) ) - => [FGSectionDescr g LegacyProjectConfig] -legacyPackageConfigFGSectionDescrs = - [ packageRepoSectionDescr + => ConstraintSource + -> [FGSectionDescr g LegacyProjectConfig] +legacyPackageConfigFGSectionDescrs constraintSource = + [ (packageRepoSectionDescr constraintSource) ] legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] @@ -1804,16 +1822,18 @@ legacyPackageConfigSectionDescrs = packageRepoSectionDescr :: ( FieldGrammar c g + , Applicative (g (WithConstraintSource SourceRepoList)) , Applicative (g SourceRepoList) , c (Identity RepoType) , c (List NoCommaFSep FilePathNT String) , c (NonEmpty' NoCommaFSep Token String) ) - => FGSectionDescr g LegacyProjectConfig -packageRepoSectionDescr = + => ConstraintSource + -> FGSectionDescr g LegacyProjectConfig +packageRepoSectionDescr constraintSource = FGSectionDescr { fgSectionName = "source-repository-package" - , fgSectionGrammar = sourceRepositoryPackageGrammar + , fgSectionGrammar = constraintSourceRepositoryPackageGrammar constraintSource , fgSectionGet = map (\x -> ("", x)) . legacyPackagesRepo , fgSectionSet = \lineno unused pkgrepo projconf -> do diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index a2826390de6..066b390239d 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -53,8 +53,8 @@ import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags (..) ) -import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.WithConstraintSource import Distribution.Package ( PackageId @@ -125,19 +125,19 @@ newtype ProjectConfigToParse = ProjectConfigToParse BS.ByteString -- features then the gap between configuration as written in the config file -- and resolved settings we actually use will become even bigger. data ProjectConfig = ProjectConfig - { projectPackages :: [String] + { projectPackages :: [WithConstraintSource String] -- ^ Packages in this project, including local dirs, local .cabal files -- local and remote tarballs. When these are file globs, they must -- match at least one package. - , projectPackagesOptional :: [String] + , projectPackagesOptional :: [WithConstraintSource String] -- ^ Like 'projectConfigPackageGlobs' but /optional/ in the sense that -- file globs are allowed to match nothing. The primary use case for -- this is to be able to say @optional-packages: */@ to automagically -- pick up deps that we unpack locally without erroring when -- there aren't any. - , projectPackagesRepo :: [SourceRepoList] + , projectPackagesRepo :: [WithConstraintSource SourceRepoList] -- ^ Packages in this project from remote source repositories. - , projectPackagesNamed :: [PackageVersionConstraint] + , projectPackagesNamed :: [WithConstraintSource PackageVersionConstraint] -- ^ Packages in this project from hackage repositories. , -- See respective types for an explanation of what these -- values are about: @@ -207,8 +207,8 @@ data ProjectConfigShared = ProjectConfigShared , projectConfigIndexState :: Flag TotalIndexState , projectConfigStoreDir :: Flag FilePath , -- solver configuration - projectConfigConstraints :: [(UserConstraint, ConstraintSource)] - , projectConfigPreferences :: [PackageVersionConstraint] + projectConfigConstraints :: [WithConstraintSource UserConstraint] + , projectConfigPreferences :: [WithConstraintSource PackageVersionConstraint] , projectConfigCabalVersion :: Flag Version -- TODO: [required eventually] unused , projectConfigSolver :: Flag PreSolver , projectConfigAllowOlder :: Maybe AllowOlder @@ -410,8 +410,8 @@ data SolverSettings = SolverSettings { solverSettingRemoteRepos :: [RemoteRepo] -- ^ Available Hackage servers. , solverSettingLocalNoIndexRepos :: [LocalRepo] - , solverSettingConstraints :: [(UserConstraint, ConstraintSource)] - , solverSettingPreferences :: [PackageVersionConstraint] + , solverSettingConstraints :: [WithConstraintSource UserConstraint] + , solverSettingPreferences :: [WithConstraintSource PackageVersionConstraint] , solverSettingFlagAssignment :: FlagAssignment -- ^ For all local packages , solverSettingFlagAssignments :: Map PackageName FlagAssignment diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index fef9f6efde4..116488ace99 100644 --- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs +++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -170,8 +171,12 @@ import Distribution.Types.UnqualComponentName ) import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Control.Exception (assert) +import Data.Bifunctor (bimap) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set @@ -564,11 +569,11 @@ runProjectPostBuildPhase -- matched this target. Typically this is exactly one, but in general it is -- possible to for different selectors to match the same target. This extra -- information is primarily to help make helpful error messages. -type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] +type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty (WithConstraintSource TargetSelector))] -- | Get all target selectors. allTargetSelectors :: TargetsMap -> [TargetSelector] -allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems +allTargetSelectors = concatMap (map constraintPackage . NE.toList . snd) . concat . Map.elems -- | Get all unique target selectors. uniqueTargetSelectors :: TargetsMap -> [TargetSelector] @@ -619,8 +624,8 @@ resolveTargets ) -> ElaboratedInstallPlan -> Maybe (SourcePackageDb) - -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap + -> [WithConstraintSource TargetSelector] + -> Either [WithConstraintSource (TargetProblem err)] TargetsMap resolveTargets selectPackageTargets selectComponentTarget @@ -632,7 +637,7 @@ resolveTargets . map (\ts -> (,) ts <$> checkTarget ts) where mkTargetsMap - :: [(TargetSelector, [(UnitId, ComponentTarget)])] + :: [(WithConstraintSource TargetSelector, [(UnitId, ComponentTarget)])] -> TargetsMap mkTargetsMap targets = Map.map nubComponentTargets $ @@ -645,76 +650,87 @@ resolveTargets AvailableTargetIndexes{..} = availableTargetIndexes installPlan - checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] + checkTarget :: WithConstraintSource TargetSelector -> Either (WithConstraintSource (TargetProblem err)) [(UnitId, ComponentTarget)] -- We can ask to build any whole package, project-local or a dependency - checkTarget bt@(TargetPackage _ (ordNub -> [pkgid]) mkfilter) - | Just ats <- - fmap (maybe id filterTargetsKind mkfilter) $ - Map.lookup pkgid availableTargetsByPackageId = - fmap (componentTargets WholeComponent) $ - selectPackageTargets bt ats - | otherwise = - Left (TargetProblemNoSuchPackage pkgid) - checkTarget (TargetPackage _ pkgids _) = - error - ( "TODO: add support for multiple packages in a directory. Got\n" - ++ unlines (map prettyShow pkgids) - ) - -- For the moment this error cannot happen here, because it gets - -- detected when the package config is being constructed. This case - -- will need handling properly when we do add support. - -- - -- TODO: how should this use case play together with the - -- '--cabal-file' option of 'configure' which allows using multiple - -- .cabal files for a single package? - - checkTarget bt@(TargetAllPackages mkfilter) = - fmap (componentTargets WholeComponent) - . selectPackageTargets bt - . maybe id filterTargetsKind mkfilter - . filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackageId) - checkTarget (TargetComponent pkgid cname subtarget) - | Just ats <- - Map.lookup - (pkgid, cname) - availableTargetsByPackageIdAndComponentName = - fmap (componentTargets subtarget) $ - selectComponentTargets subtarget ats - | Map.member pkgid availableTargetsByPackageId = - Left (TargetProblemNoSuchComponent pkgid cname) - | otherwise = - Left (TargetProblemNoSuchPackage pkgid) - checkTarget (TargetComponentUnknown pkgname ecname subtarget) - | Just ats <- case ecname of - Left ucname -> - Map.lookup - (pkgname, ucname) - availableTargetsByPackageNameAndUnqualComponentName - Right cname -> - Map.lookup - (pkgname, cname) - availableTargetsByPackageNameAndComponentName = - fmap (componentTargets subtarget) $ - selectComponentTargets subtarget ats - | Map.member pkgname availableTargetsByPackageName = - Left (TargetProblemUnknownComponent pkgname ecname) - | otherwise = - Left (TargetNotInProject pkgname) - checkTarget bt@(TargetPackageNamed pkgname mkfilter) - | Just ats <- - fmap (maybe id filterTargetsKind mkfilter) $ - Map.lookup pkgname availableTargetsByPackageName = - fmap (componentTargets WholeComponent) - . selectPackageTargets bt - $ ats - | Just SourcePackageDb{packageIndex} <- mPkgDb - , let pkg = lookupPackageName packageIndex pkgname - , not (null pkg) = - Left (TargetAvailableInIndex pkgname) - | otherwise = - Left (TargetNotInProject pkgname) + checkTarget + ( withConstraint@WithConstraintSource + { constraintPackage = targetSelector + } + ) = + bimap + (\problem -> withConstraint{constraintPackage = problem}) + id + $ case targetSelector of + bt@(TargetPackage _ (ordNub -> [pkgid]) mkfilter) -> + case fmap (maybe id filterTargetsKind mkfilter) $ + Map.lookup pkgid availableTargetsByPackageId of + Just ats -> + fmap (componentTargets WholeComponent) $ + selectPackageTargets bt ats + _ -> Left (TargetProblemNoSuchPackage pkgid) + TargetPackage _ pkgids _ -> + error + ( "TODO: add support for multiple packages in a directory. Got\n" + ++ unlines (map prettyShow pkgids) + ) + -- For the moment this error cannot happen here, because it gets + -- detected when the package config is being constructed. This case + -- will need handling properly when we do add support. + -- + -- TODO: how should this use case play together with the + -- '--cabal-file' option of 'configure' which allows using multiple + -- .cabal files for a single package? + + bt@(TargetAllPackages mkfilter) -> + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + . maybe id filterTargetsKind mkfilter + . filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackageId) + TargetComponent pkgid cname subtarget -> + if + | Just ats <- + Map.lookup + (pkgid, cname) + availableTargetsByPackageIdAndComponentName -> + fmap (componentTargets subtarget) $ + selectComponentTargets subtarget ats + | Map.member pkgid availableTargetsByPackageId -> + Left (TargetProblemNoSuchComponent pkgid cname) + | otherwise -> + Left (TargetProblemNoSuchPackage pkgid) + TargetComponentUnknown pkgname ecname subtarget -> + if + | Just ats <- case ecname of + Left ucname -> + Map.lookup + (pkgname, ucname) + availableTargetsByPackageNameAndUnqualComponentName + Right cname -> + Map.lookup + (pkgname, cname) + availableTargetsByPackageNameAndComponentName -> + fmap (componentTargets subtarget) $ + selectComponentTargets subtarget ats + | Map.member pkgname availableTargetsByPackageName -> + Left (TargetProblemUnknownComponent pkgname ecname) + | otherwise -> + Left (TargetNotInProject pkgname) + bt@(TargetPackageNamed pkgname mkfilter) -> + if + | Just ats <- + fmap (maybe id filterTargetsKind mkfilter) $ + Map.lookup pkgname availableTargetsByPackageName -> + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + $ ats + | Just SourcePackageDb{packageIndex} <- mPkgDb + , let pkg = lookupPackageName packageIndex pkgname + , not (null pkg) -> + Left (TargetAvailableInIndex pkgname) + | otherwise -> + Left (TargetNotInProject pkgname) componentTargets :: SubComponentTarget @@ -1163,7 +1179,24 @@ writeBuildReports settings buildContext plan buildOutcomes = do Right br -> case buildResultTests br of TestsNotTried -> BuildReports.NotTried TestsOk -> BuildReports.Ok - in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map (packageId . fst) $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files? + in -- TODO handle failure log files? + Just $ + ( BuildReports.BuildReport + { package = packageId pkg + , os + , arch + , compiler = compilerId comp + , client = cabalInstallID + , flagAssignment = elabFlagAssignment pkg + , dependencies = map (packageId . fst) $ elabLibDependencies pkg + , installOutcome + , docsOutcome + , testsOutcome + } + , getRepo $ + constraintPackage $ + elabPkgSourceLocation pkg + ) fromPlanPackage _ _ = Nothing buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs index 6a39694ab56..1b44bd8389b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -26,7 +26,9 @@ import Distribution.Client.HashValue (hashValue, showHashValue) import Distribution.Client.ProjectBuilding.Types import Distribution.Client.ProjectPlanning.Types import Distribution.Client.Types.ConfiguredId (confInstId) -import Distribution.Client.Types.PackageLocation (PackageLocation (..)) +import Distribution.Client.Types.PackageLocation + ( PackageLocation (..) + ) import Distribution.Client.Types.Repo (RemoteRepo (..), Repo (..)) import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) import Distribution.Client.Version (cabalInstallVersion) @@ -36,6 +38,9 @@ import qualified Distribution.Client.Utils.Json as J import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import qualified Distribution.Compat.Binary as Binary import Distribution.Compat.Graph (Graph, Node) @@ -168,7 +173,7 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig = | (fn, v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) - , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) + , "pkg-src" J..= packageLocationToJ (constraintPackage $ elabPkgSourceLocation elab) ] ++ [ "pkg-cabal-sha256" J..= J.String (showHashValue hash) | Just hash <- [fmap hashValue (elabPkgDescriptionOverride elab)] diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index ccace6f8025..19b8159537b 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} -- | -- /Elaborated: worked out with great care and nicety of detail; executed with great minuteness: elaborate preparations; elaborate care./ @@ -113,6 +114,9 @@ import Distribution.Client.JobControl import Distribution.Client.PackageHash import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.ProjectConfig.Types + ( ProjectConfigProvenance (..) + ) import Distribution.Client.ProjectPlanOutput import Distribution.Client.ProjectPlanning.SetupPolicy ( NonSetupLibDepSolverPlanPackage (..) @@ -148,12 +152,18 @@ import qualified Hackage.Security.Client as Sec import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PkgConfigDb import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.ModuleName import Distribution.Package @@ -784,7 +794,7 @@ rebuildInstallPlan -> (Compiler, Platform, ProgramDb) -> Maybe PkgConfigDb -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> [PackageSpecifier (SourcePackage (PackageLocationProvenance loc))] -> Rebuild ( ElaboratedInstallPlan , ElaboratedSharedConfig @@ -917,9 +927,14 @@ reportPlanningFailure projectConfig comp platform pkgSpecifiers = theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackagePropertyVersion version] -> - PackageIdentifier name <$> trivialRange version - NamedPackage _ _ -> Nothing + Named + ( WithConstraintSource + { constraintPackage = namedPackage + } + ) -> case namedPackage of + NamedPackage name [PackagePropertyVersion version] -> + PackageIdentifier name <$> trivialRange version + _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg -- \| If a range includes only a single version, return Just that version. trivialRange :: VersionRange -> Maybe Version @@ -1027,7 +1042,7 @@ getPkgConfigDb verbosity progdb = do -- | Select the config values to monitor for changes package source hashes. packageLocationsSignature :: SolverInstallPlan - -> [(PackageId, PackageLocation (Maybe FilePath))] + -> [(PackageId, PackageLocationProvenance (Maybe FilePath))] packageLocationsSignature solverPlan = [ (packageId pkg, srcpkgSource pkg) | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <- @@ -1046,7 +1061,7 @@ getPackageSourceHashes getPackageSourceHashes verbosity withRepoCtx solverPlan = do -- Determine if and where to get the package's source hash from. -- - let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))] + let allPkgLocations :: [(PackageId, PackageLocationProvenance (Maybe FilePath))] allPkgLocations = [ (packageId pkg, srcpkgSource pkg) | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <- @@ -1058,20 +1073,20 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do localTarballPkgs :: [(PackageId, FilePath)] localTarballPkgs = [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations + | (pkgid, constraintPackage -> LocalTarballPackage tarball) <- allPkgLocations ] -- Tarballs from remote URLs. We must have downloaded these already -- (since we extracted the .cabal file earlier) remoteTarballPkgs = [ (pkgid, tarball) - | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations + | (pkgid, constraintPackage -> RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] -- tarballs from source-repository-package stanzas sourceRepoTarballPkgs = [ (pkgid, tarball) - | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations + | (pkgid, constraintPackage -> RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] -- Tarballs from repositories, either where the repository provides @@ -1086,7 +1101,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do [ case repo of RepoSecure{} -> Left (repo, [pkgid]) _ -> Right (repo, pkgid) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations + | (pkgid, constraintPackage -> RepoTarballPackage repo _ _) <- allPkgLocations ] -- Group up the unvalidated packages by repo so we only read the remote @@ -1284,12 +1299,16 @@ planPackages . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- solverSettingPreferences + | PackageVersionConstraint name ver <- map constraintPackage solverSettingPreferences ] . addConstraints -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints + | WithConstraintSource + { constraintPackage = pc + , constraintConstraint = src + } <- + solverSettingConstraints ] . addPreferences -- enable stanza preference unilaterally, regardless if the user asked @@ -1543,7 +1562,7 @@ elaborateInstallPlan -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> [PackageSpecifier (SourcePackage (PackageLocationProvenance loc))] -> Map PackageId PackageSourceHash -> InstallDirs.InstallDirTemplates -> ProjectConfigShared @@ -2530,9 +2549,9 @@ elaborateInstallPlan -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping -shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing -shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of +shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocationProvenance loc)) -> Maybe PackageId +shouldBeLocal (Named _) = Nothing +shouldBeLocal (SpecificSourcePackage pkg) = case constraintPackage $ srcpkgSource pkg of LocalUnpackedPackage _ -> Just (packageId pkg) _ -> Nothing diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index 31a0d5df248..58e295ad4ea 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -111,6 +111,9 @@ import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.System import Distribution.Types.ComponentRequestedSpec import qualified Distribution.Types.LocalBuildConfig as LBC @@ -224,7 +227,7 @@ data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage , elabFlagDefaults :: Cabal.FlagAssignment -- ^ The original default flag assignment, used only for reporting. , elabPkgDescription :: Cabal.PackageDescription - , elabPkgSourceLocation :: PackageLocation (Maybe FilePath) + , elabPkgSourceLocation :: UnresolvedPkgLoc -- ^ Where the package comes from, e.g. tarball, local dir etc. This -- is not the same as where it may be unpacked to for the build. , elabPkgSourceHash :: Maybe PackageSourceHash @@ -461,15 +464,16 @@ dataDirEnvVarForPackage distDirLayout pkg = , Just dataDirPath ) where - srcPath (LocalUnpackedPackage path) = path - srcPath (LocalTarballPackage _path) = unpackedPath - srcPath (RemoteTarballPackage _uri _localTar) = unpackedPath - srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath - srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout - -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc - srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = - error - "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" + srcPath location = case constraintPackage location of + LocalUnpackedPackage path -> path + LocalTarballPackage _path -> unpackedPath + RemoteTarballPackage _uri _localTar -> unpackedPath + RepoTarballPackage _repo _packageId _localTar -> unpackedPath + RemoteSourceRepoPackage _sourceRepo (Just localCheckout) -> localCheckout + -- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc + RemoteSourceRepoPackage _sourceRepo Nothing -> + error + "calling dataDirEnvVarForPackage on a not-downloaded repo is an error" unpackedPath = distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg rawDataDir = getSymbolicPath $ dataDir (elabPkgDescription pkg) diff --git a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs index 57e45ddb2ba..853caccd0f9 100644 --- a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -38,7 +38,10 @@ import Distribution.Client.ParseUtils (parseFields, ppFields, ppSection) import Distribution.Client.Setup ( ConfigExFlags (..) ) -import Distribution.Client.Targets (userConstraintPackageName) +import Distribution.Client.Targets + ( UserConstraint (..) + , userConstraintPackageName + ) import Distribution.Deprecated.ParseUtils ( FieldDescr (..) , ParseResult (..) @@ -60,6 +63,9 @@ import Distribution.Simple.Setup ) import Distribution.Simple.Utils (debug, warn) import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import System.Directory (doesFileExist) import System.FilePath (()) import System.IO.Error (isDoesNotExistError) @@ -171,8 +177,10 @@ pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment] pkgEnvFieldDescrs src = [ commaNewLineListFieldParsec "constraints" - (pretty . fst) - ((\pc -> (pc, src)) `fmap` parsec) + pretty + ( (\userConstraint -> WithConstraintSource{constraintPackage = userConstraint, constraintConstraint = src}) + `fmap` parsec + ) ( sortConstraints . configExConstraints . savedConfigureExFlags @@ -186,7 +194,9 @@ pkgEnvFieldDescrs src = , commaListFieldParsec "preferences" pretty - parsec + ( (\preference -> WithConstraintSource{constraintPackage = preference, constraintConstraint = src}) + `fmap` parsec + ) (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) ( \v pkgEnv -> updateConfigureExFlags @@ -223,7 +233,8 @@ pkgEnvFieldDescrs src = } } - sortConstraints = sortBy (comparing $ userConstraintPackageName . fst) + sortConstraints :: [WithConstraintSource UserConstraint] -> [WithConstraintSource UserConstraint] + sortConstraints = sortBy (comparing $ userConstraintPackageName . constraintPackage) -- | Read the package environment file. readPackageEnvironmentFile diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 95db58bc8c1..3c923dd232a 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -141,6 +141,10 @@ import Distribution.Simple.Utils import Distribution.Solver.Types.SourcePackage as SP ( SourcePackage (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + , withUnknownConstraint + ) import Distribution.System ( Platform (..) ) @@ -196,6 +200,9 @@ import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S import Distribution.Client.Errors +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) import Distribution.Utils.Path ( unsafeMakeSymbolicPath ) @@ -287,13 +294,13 @@ withContextAndSelectors -- ^ A target filter -> NixStyleFlags a -- ^ Command line flags - -> [String] + -> [WithConstraintSource String] -- ^ Target strings or a script and args. -> GlobalFlags -- ^ Global flags. -> CurrentCommand -- ^ Current Command (usually for error reporting). - -> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b) + -> (TargetContext -> ProjectBaseContext -> [WithConstraintSource TargetSelector] -> IO b) -- ^ The body of your command action. -> IO b withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act = @@ -307,32 +314,37 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo (tc', ctx', sels) <- case targetStrings of -- Only script targets may end with ':'. -- Trying to readTargetSelectors such a target leads to a parse error. - [target] | ":" `isSuffixOf` target -> do - scriptOrError target [TargetSelectorNoScript $ TargetString1 target] + [target] | ":" `isSuffixOf` constraintPackage target -> do + scriptOrError + (constraintPackage target) + [ TargetSelectorNoScript . TargetString1 <$> target + ] _ -> do -- In the case where a selector is both a valid target and script, assume it is a target, -- because you can disambiguate the script with "./script" - readTargetSelectors (localPackages ctx) kind targetStrings >>= \case + eitherTargetSelectors <- readTargetSelectors (localPackages ctx) kind targetStrings + + case eitherTargetSelectors of -- If there are no target selectors and no targets are fine, return -- the context - Left (TargetSelectorNoTargetsInCwd{} : _) + Left (WithConstraintSource{constraintPackage = TargetSelectorNoTargetsInCwd{}} : _) | [] <- targetStrings , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - Left err@(TargetSelectorNoTargetsInProject : _) + Left err@(WithConstraintSource{constraintPackage = TargetSelectorNoTargetsInProject} : _) -- If there are no target selectors and no targets are fine, return -- the context | [] <- targetStrings , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - | (script : _) <- targetStrings -> scriptOrError script err - Left err@(TargetSelectorNoSuch t _ : _) + | (script : _) <- targetStrings -> scriptOrError (constraintPackage script) err + Left err@(WithConstraintSource{constraintPackage = TargetSelectorNoSuch t _} : _) | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _ : _) + Left err@(WithConstraintSource{constraintPackage = TargetSelectorExpected t _ _} : _) | TargetString1 script <- t -> scriptOrError script err - Left err@(MatchingInternalError _ _ _ : _) -- Handle ':' in middle of script name. - | [script] <- targetStrings -> scriptOrError script err - Left err -> reportTargetSelectorProblems verbosity err + Left err@(WithConstraintSource{constraintPackage = MatchingInternalError _ _ _} : _) -- Handle ':' in middle of script name. + | [script] <- targetStrings -> scriptOrError (constraintPackage script) err + Left err -> reportTargetSelectorProblems verbosity (map constraintPackage err) Right sels -> return (tc, ctx, sels) act tc' ctx' sels @@ -341,7 +353,12 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo ignoreProject = flagIgnoreProject projectFlags cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) - defaultTarget = [TargetPackage TargetExplicitNamed [fakePackageId] Nothing] + defaultTarget = + [ WithConstraintSource + { constraintPackage = TargetPackage TargetExplicitNamed [fakePackageId] Nothing + , constraintConstraint = ConstraintSourceImplicit + } + ] withProject = do ctx <- establishProjectBaseContext verbosity cliConfig cmd @@ -358,6 +375,10 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo distDirLayout <- establishDummyDistDirLayout verbosity cfg rootDir establishDummyProjectBaseContext verbosity cfg distDirLayout [] cmd + scriptOrError + :: FilePath + -> [WithConstraintSource TargetSelectorProblem] + -> IO (TargetContext, ProjectBaseContext, [WithConstraintSource TargetSelector]) scriptOrError script err = do exists <- doesFileExist script if exists @@ -397,7 +418,7 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo createDirectoryIfMissingVerbose verbosity True (takeDirectory exePath) return (ScriptContext script executable', ctx', defaultTarget) - else reportTargetSelectorProblems verbosity err + else reportTargetSelectorProblems verbosity (map constraintPackage err) withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act @@ -453,6 +474,10 @@ updateContextAndWriteProjectFile' ctx srcPkg = do packageFile = projectRoot fakePackageCabalFileName contents = showGenericPackageDescription (srcpkgDescription srcPkg) writePackageFile = writeUTF8File packageFile contents + srcPkg' = + srcPkg + { srcpkgSource = withUnknownConstraint $ srcpkgSource srcPkg + } -- TODO This is here to prevent reconfiguration of cached repl packages. -- It's worth investigating why it's needed in the first place. packageFileExists <- doesFileExist packageFile @@ -463,7 +488,7 @@ updateContextAndWriteProjectFile' ctx srcPkg = do (cached /= contents) writePackageFile else writePackageFile - return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg])) + return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg'])) -- | Add the executable metadata to the context and write a .cabal file. updateContextAndWriteProjectFile :: ProjectBaseContext -> FilePath -> Executable -> IO ProjectBaseContext diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 446bbbedaab..b921df640e3 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -212,6 +213,10 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils ( wrapText ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + , showWithConstraintSource + ) import Distribution.System (Platform) import Distribution.Types.GivenComponent ( GivenComponent (..) @@ -909,8 +914,8 @@ data ConfigExFlags = ConfigExFlags { configCabalVersion :: Flag Version , configAppend :: Flag Bool , configBackup :: Flag Bool - , configExConstraints :: [(UserConstraint, ConstraintSource)] - , configPreferences :: [PackageVersionConstraint] + , configExConstraints :: [WithConstraintSource UserConstraint] + , configPreferences :: [WithConstraintSource PackageVersionConstraint] , configSolver :: Flag PreSolver , configAllowNewer :: Maybe AllowNewer , configAllowOlder :: Maybe AllowOlder @@ -949,7 +954,7 @@ configureExOptions :: ShowOrParseArgs -> ConstraintSource -> [OptionField ConfigExFlags] -configureExOptions _showOrParseArgs src = +configureExOptions _showOrParseArgs constraint = [ option [] ["cabal-lib-version"] @@ -988,8 +993,10 @@ configureExOptions _showOrParseArgs src = (\v flags -> flags{configExConstraints = v}) ( reqArg "CONSTRAINT" - ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) - (map $ prettyShow . fst) + ( (\pkg -> [WithConstraintSource{constraintPackage = pkg, constraintConstraint = constraint}]) + `fmap` ReadE readUserConstraint + ) + (map $ showWithConstraintSource prettyShow) ) , option [] @@ -1001,9 +1008,11 @@ configureExOptions _showOrParseArgs src = "CONSTRAINT" ( parsecToReadE (const "dependency expected") - (fmap (\x -> [x]) parsec) + ( (\pkg -> [WithConstraintSource{constraintPackage = pkg, constraintConstraint = constraint}]) + `fmap` parsec + ) ) - (map prettyShow) + (map $ showWithConstraintSource prettyShow) ) , optionSolver configSolver (\v flags -> flags{configSolver = v}) , option diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 8dabe33f22a..b9dd938f5ed 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -49,6 +49,7 @@ import Prelude () import Distribution.Client.Types ( PackageLocation (..) + , PackageLocationProvenance , PackageSpecifier (..) ) import Distribution.Package @@ -92,15 +93,25 @@ import Distribution.Simple.LocalBuildInfo , componentName , pkgComponents ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + ) import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Types.ForeignLib import Control.Arrow ((&&&)) import Control.Monad hiding ( mfilter ) +import Data.Bifunctor (bimap) #if MIN_VERSION_base(4,20,0) import Data.Functor as UZ (unzip) #else @@ -246,24 +257,24 @@ instance Structured SubComponentTarget -- error if any are unrecognised. The possible target selectors are based on -- the available packages (and their locations). readTargetSelectors - :: [PackageSpecifier (SourcePackage (PackageLocation a))] + :: [PackageSpecifier (SourcePackage (PackageLocationProvenance a))] -> Maybe ComponentKindFilter -- ^ This parameter is used when there are ambiguous selectors. -- If it is 'Just', then we attempt to resolve ambiguity -- by applying it, since otherwise there is no way to allow -- contextually valid yet syntactically ambiguous selectors. -- (#4676, #5461) - -> [String] - -> IO (Either [TargetSelectorProblem] [TargetSelector]) + -> [WithConstraintSource String] + -> IO (Either [WithConstraintSource TargetSelectorProblem] [WithConstraintSource TargetSelector]) readTargetSelectors = readTargetSelectorsWith defaultDirActions readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> [PackageSpecifier (SourcePackage (PackageLocationProvenance a))] -> Maybe ComponentKindFilter - -> [String] - -> m (Either [TargetSelectorProblem] [TargetSelector]) + -> [WithConstraintSource String] + -> m (Either [WithConstraintSource TargetSelectorProblem] [WithConstraintSource TargetSelector]) readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = case parseTargetStrings targetStrs of ([], usertargets) -> do @@ -272,7 +283,7 @@ readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = case resolveTargetSelectors knowntargets usertargets' mfilter of ([], btargets) -> return (Right btargets) (problems, _) -> return (Left problems) - (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + (strs, _) -> return (Left (map (fmap TargetSelectorUnrecognised) strs)) data DirActions m = DirActions { doesFileExist :: FilePath -> m Bool @@ -317,14 +328,15 @@ data TargetString deriving (Show, Eq) -- | Parse a bunch of 'TargetString's (purely without throwing exceptions). -parseTargetStrings :: [String] -> ([String], [TargetString]) +parseTargetStrings :: [WithConstraintSource String] -> ([WithConstraintSource String], [WithConstraintSource TargetString]) parseTargetStrings = partitionEithers . map (\str -> maybe (Left str) Right (parseTargetString str)) -parseTargetString :: String -> Maybe TargetString -parseTargetString = - readPToMaybe parseTargetApprox +parseTargetString :: WithConstraintSource String -> Maybe (WithConstraintSource TargetString) +parseTargetString target = + (\parsed -> target{constraintPackage = parsed}) + <$> readPToMaybe parseTargetApprox (constraintPackage target) where parseTargetApprox :: Parse.ReadP r TargetString parseTargetApprox = @@ -457,22 +469,23 @@ noFileStatus = FileStatusNotExists False getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m - -> TargetString - -> m TargetStringFileStatus + -> WithConstraintSource TargetString + -> m (WithConstraintSource TargetStringFileStatus) getTargetStringFileStatus DirActions{..} t = - case t of - TargetString1 s1 -> - (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 - TargetString2 s1 s2 -> - (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 - TargetString3 s1 s2 s3 -> - (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 - TargetString4 s1 s2 s3 s4 -> - return (TargetStringFileStatus4 s1 s2 s3 s4) - TargetString5 s1 s2 s3 s4 s5 -> - return (TargetStringFileStatus5 s1 s2 s3 s4 s5) - TargetString7 s1 s2 s3 s4 s5 s6 s7 -> - return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) + (\result -> t{constraintPackage = result}) + <$> case constraintPackage t of + TargetString1 s1 -> + (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 + TargetString2 s1 s2 -> + (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 + TargetString3 s1 s2 s3 -> + (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 + TargetString4 s1 s2 s3 s4 -> + return (TargetStringFileStatus4 s1 s2 s3 s4) + TargetString5 s1 s2 s3 s4 s5 -> + return (TargetStringFileStatus5 s1 s2 s3 s4 s5) + TargetString7 s1 s2 s3 s4 s5 s6 s7 -> + return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) where fileStatus f = do fexists <- doesFileExist f @@ -533,19 +546,40 @@ copyFileStatus src dst = -- refer to. resolveTargetSelectors :: KnownTargets - -> [TargetStringFileStatus] + -> [WithConstraintSource TargetStringFileStatus] -> Maybe ComponentKindFilter - -> ( [TargetSelectorProblem] - , [TargetSelector] + -> ( [WithConstraintSource TargetSelectorProblem] + , [WithConstraintSource TargetSelector] ) -- default local dir target if there's no given target: resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = - ([TargetSelectorNoTargetsInProject], []) + ( + [ WithConstraintSource + { constraintPackage = TargetSelectorNoTargetsInProject + , constraintConstraint = ConstraintSourceImplicit + } + ] + , [] + ) -- if the component kind filter is just exes, we don't want to suggest "all" as a target. resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf = - ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind)], []) + ( + [ WithConstraintSource + { constraintPackage = TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) + , constraintConstraint = ConstraintSourceImplicit + } + ] + , [] + ) resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = - ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + ( [] + , + [ WithConstraintSource + { constraintPackage = TargetPackage TargetImplicitCwd pkgids Nothing + , constraintConstraint = ConstraintSourceImplicit + } + ] + ) where pkgids = [pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary] resolveTargetSelectors knowntargets targetStrs mfilter = @@ -556,35 +590,40 @@ resolveTargetSelectors knowntargets targetStrs mfilter = resolveTargetSelector :: KnownTargets -> Maybe ComponentKindFilter - -> TargetStringFileStatus - -> Either TargetSelectorProblem TargetSelector + -> WithConstraintSource TargetStringFileStatus + -> Either + (WithConstraintSource TargetSelectorProblem) + (WithConstraintSource TargetSelector) resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = - case findMatch (matcher targetStrStatus) of - Unambiguous _ - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - Unambiguous (TargetPackage TargetImplicitCwd [] _) -> - Left (TargetSelectorNoCurrentPackage targetStr) - Unambiguous target -> Right target - None errs - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - | otherwise -> Left (classifyMatchErrors errs) - Ambiguous _ targets - | Just kfilter <- mfilter - , [target] <- applyKindFilter kfilter targets -> - Right target - Ambiguous exactMatch targets -> - case disambiguateTargetSelectors - matcher - targetStrStatus - exactMatch - targets of - Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') - Left ((m, ms) : _) -> Left (MatchingInternalError targetStr m ms) - Left [] -> internalError "resolveTargetSelector" + bimap + (\problem -> fmap (const problem) targetStrStatus) + (\selector -> fmap (const selector) targetStrStatus) + $ case findMatch $ matcher $ constraintPackage targetStrStatus of + Unambiguous _ + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + Unambiguous (TargetPackage TargetImplicitCwd [] _) -> + Left (TargetSelectorNoCurrentPackage targetStr) + Unambiguous target -> Right target + None errs + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + | otherwise -> Left (classifyMatchErrors errs) + Ambiguous _ targets + | Just kfilter <- mfilter + , [target] <- applyKindFilter kfilter targets -> + Right target + Ambiguous exactMatch targets -> + case disambiguateTargetSelectors + matcher + targetStrStatus + exactMatch + targets of + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') + Left ((m, ms) : _) -> Left (MatchingInternalError targetStr m ms) + Left [] -> internalError "resolveTargetSelector" where matcher = matchTargetSelector knowntargets - targetStr = forgetFileStatus targetStrStatus + targetStr = forgetFileStatus $ constraintPackage targetStrStatus projectIsEmpty = null knownPackagesAll @@ -693,7 +732,7 @@ data QualLevel disambiguateTargetSelectors :: (TargetStringFileStatus -> Match TargetSelector) - -> TargetStringFileStatus + -> WithConstraintSource TargetStringFileStatus -> MatchClass -> [TargetSelector] -> Either @@ -719,7 +758,8 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = [ (matchResult, matchRenderings) | matchResult <- matchResults , let matchRenderings = - [ copyFileStatus matchInput rendering + -- TODO: Should we propagate `ConstraintSource` information here? + [ copyFileStatus (constraintPackage matchInput) rendering | ql <- [QL1 .. QLFull] , rendering <- renderTargetSelector ql matchResult ] @@ -734,7 +774,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = memoisedMatches = -- avoid recomputing the main one if it was an exact match ( if exactMatch == Exact - then Map.insert matchInput (Match Exact 0 matchResults) + then Map.insert (constraintPackage matchInput) (Match Exact 0 matchResults) else id ) $ Map.Lazy.fromList @@ -800,21 +840,27 @@ reportTargetSelectorProblems verbosity problems = do [] -> return () targets -> dieWithException verbosity $ ReportTargetSelectorProblems targets - case [(t, m, ms) | MatchingInternalError t m ms <- problems] of - [] -> return () - ((target, originalMatch, renderingsAndMatches) : _) -> - dieWithException verbosity - $ MatchingInternalErrorErr - (showTargetString target) - (showTargetSelector originalMatch) - (showTargetSelectorKind originalMatch) - $ map - ( \(rendering, matches) -> - ( showTargetString rendering - , (map (\match -> showTargetSelector match ++ " (" ++ showTargetSelectorKind match ++ ")") matches) + case [ let + renderedMatches = + map + ( \(rendering, matches) -> + ( showTargetString rendering + , (map (\match -> showTargetSelector match ++ " (" ++ showTargetSelectorKind match ++ ")") matches) + ) ) - ) - renderingsAndMatches + renderingsAndMatches + in + MatchingInternalErrorErr + (showTargetString target) + (showTargetSelector originalMatch) + (showTargetSelectorKind originalMatch) + renderedMatches + | MatchingInternalError target originalMatch renderingsAndMatches <- + problems + ] of + [] -> return () + (err : _) -> + dieWithException verbosity err case [(t, e, g) | TargetSelectorExpected t e g <- problems] of [] -> return () @@ -1839,7 +1885,7 @@ getKnownTargets :: forall m a . (Applicative m, Monad m) => DirActions m - -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> [PackageSpecifier (SourcePackage (PackageLocationProvenance a))] -> m KnownTargets getKnownTargets dirActions@DirActions{..} pkgs = do pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs @@ -1875,10 +1921,16 @@ getKnownTargets dirActions@DirActions{..} pkgs = do collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m - -> PackageSpecifier (SourcePackage (PackageLocation a)) + -> PackageSpecifier (SourcePackage (PackageLocationProvenance a)) -> m KnownPackage -collectKnownPackageInfo _ (NamedPackage pkgname _props) = - return (KnownPackageName pkgname) +collectKnownPackageInfo + _ + ( Named + ( WithConstraintSource + { constraintPackage = NamedPackage pkgname _props + } + ) + ) = return (KnownPackageName pkgname) collectKnownPackageInfo dirActions@DirActions{..} ( SpecificSourcePackage @@ -1888,7 +1940,7 @@ collectKnownPackageInfo } ) = do (pkgdir, pkgfile) <- - case loc of + case constraintPackage loc of -- TODO: local tarballs, remote tarballs etc LocalUnpackedPackage dir -> do dirabs <- canonicalizePath dir diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs index 1a37c9c73b9..9eaf8b3d68d 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -52,6 +52,7 @@ import Prelude () import Distribution.Client.Types ( PackageLocation (..) + , PackageLocationProvenance , PackageSpecifier (..) , ResolvedPkgLoc , UnresolvedSourcePackage @@ -64,12 +65,20 @@ import Distribution.Package , unPackageName ) +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + , NamedPackageConstraint + ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + , withUnknownConstraint + ) import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar.Entry as Tar @@ -290,7 +299,7 @@ resolveUserTargets verbosity repoCtxt available userTargets = do -- package references packageTargets <- traverse (readPackageTarget verbosity) - =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat + =<< traverse (fetchPackageTarget verbosity repoCtxt) =<< traverse (expandUserTarget verbosity) userTargets -- users are allowed to give package names case-insensitively, so we must @@ -318,10 +327,10 @@ resolveUserTargets verbosity repoCtxt available userTargets = do -- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. data PackageTarget pkg - = PackageTargetNamed PackageName [PackageProperty] UserTarget + = PackageTargetNamed NamedPackageConstraint UserTarget | -- | A package identified by name, but case insensitively, so it needs -- to be resolved to the right case-sensitive name. - PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget + PackageTargetNamedFuzzy NamedPackageConstraint UserTarget | PackageTargetLocation pkg deriving (Show, Functor, Foldable, Traversable) @@ -336,24 +345,25 @@ data PackageTarget pkg expandUserTarget :: Verbosity -> UserTarget - -> IO [PackageTarget (PackageLocation ())] -expandUserTarget verbosity userTarget = case userTarget of - UserTargetNamed (PackageVersionConstraint name vrange) -> - let props = - [ PackagePropertyVersion vrange - | not (isAnyVersion vrange) - ] - in return [PackageTargetNamedFuzzy name props userTarget] - UserTargetLocalDir dir -> - return [PackageTargetLocation (LocalUnpackedPackage dir)] - UserTargetLocalCabalFile file -> do - let dir = takeDirectory file - _ <- tryReadGenericPackageDesc verbosity (makeSymbolicPath dir) (localPackageError dir) -- just as a check - return [PackageTargetLocation (LocalUnpackedPackage dir)] - UserTargetLocalTarball tarballFile -> - return [PackageTargetLocation (LocalTarballPackage tarballFile)] - UserTargetRemoteTarball tarballURL -> - return [PackageTargetLocation (RemoteTarballPackage tarballURL ())] + -> IO (PackageTarget (PackageLocationProvenance ())) +expandUserTarget verbosity userTarget = + case userTarget of + UserTargetNamed (PackageVersionConstraint name vrange) -> + let props = + [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) + ] + in return $ PackageTargetNamedFuzzy (withUnknownConstraint $ NamedPackage name props) userTarget + UserTargetLocalDir dir -> + return $ PackageTargetLocation $ withUnknownConstraint $ LocalUnpackedPackage dir + UserTargetLocalCabalFile file -> do + let dir = takeDirectory file + _ <- tryReadGenericPackageDesc verbosity (makeSymbolicPath dir) (localPackageError dir) -- just as a check + return $ PackageTargetLocation $ withUnknownConstraint $ LocalUnpackedPackage dir + UserTargetLocalTarball tarballFile -> + return $ PackageTargetLocation $ withUnknownConstraint $ LocalTarballPackage tarballFile + UserTargetRemoteTarball tarballURL -> + return $ PackageTargetLocation $ withUnknownConstraint $ RemoteTarballPackage tarballURL () localPackageError :: FilePath -> String localPackageError dir = @@ -369,11 +379,11 @@ localPackageError dir = fetchPackageTarget :: Verbosity -> RepoContext - -> PackageTarget (PackageLocation ()) + -> PackageTarget (PackageLocationProvenance ()) -> IO (PackageTarget ResolvedPkgLoc) fetchPackageTarget verbosity repoCtxt = traverse $ - fetchPackage verbosity repoCtxt . fmap (const Nothing) + fetchPackage verbosity repoCtxt . fmap (fmap $ const Nothing) -- | Given a package target that has been fetched, read the .cabal file. -- @@ -385,14 +395,14 @@ readPackageTarget readPackageTarget verbosity = traverse modifyLocation where modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage - modifyLocation location = case location of + modifyLocation location = case constraintPackage location of LocalUnpackedPackage dir -> do pkg <- tryReadGenericPackageDesc verbosity (makeSymbolicPath dir) (localPackageError dir) return SourcePackage { srcpkgPackageId = packageId pkg , srcpkgDescription = pkg - , srcpkgSource = fmap Just location + , srcpkgSource = fmap Just <$> location , srcpkgDescrOverride = Nothing } LocalTarballPackage tarballFile -> @@ -425,7 +435,7 @@ readPackageTarget verbosity = traverse modifyLocation SourcePackage { srcpkgPackageId = packageId pkg , srcpkgDescription = pkg - , srcpkgSource = fmap Just location + , srcpkgSource = fmap Just <$> location , srcpkgDescrOverride = Nothing } @@ -499,11 +509,11 @@ disambiguatePackageTargets availablePkgIndex availableExtra targets = where disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - PackageTargetNamed pkgname props userTarget + PackageTargetNamed (withConstraint@WithConstraintSource{constraintPackage = (NamedPackage pkgname _)}) userTarget | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> Left (PackageNameUnknown pkgname userTarget) - | otherwise -> Right (NamedPackage pkgname props) - PackageTargetNamedFuzzy pkgname props userTarget -> + | otherwise -> Right (Named withConstraint) + PackageTargetNamedFuzzy (withConstraint@WithConstraintSource{constraintPackage = (NamedPackage pkgname _)}) userTarget -> case disambiguatePackageName packageNameEnv pkgname of None -> Left @@ -518,7 +528,7 @@ disambiguatePackageTargets availablePkgIndex availableExtra targets = pkgnames userTarget ) - Unambiguous pkgname' -> Right (NamedPackage pkgname' props) + Unambiguous _ -> Right (Named withConstraint) -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv @@ -676,7 +686,7 @@ readUserConstraint str = instance Pretty UserConstraint where pretty (UserConstraint scope prop) = - dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop + pretty $ PackageConstraint (fromUserConstraintScope scope) prop instance Parsec UserConstraint where parsec = do diff --git a/cabal-install/src/Distribution/Client/Types/PackageLocation.hs b/cabal-install/src/Distribution/Client/Types/PackageLocation.hs index 2f4993e22bd..a91bbfff5f6 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageLocation.hs +++ b/cabal-install/src/Distribution/Client/Types/PackageLocation.hs @@ -3,6 +3,7 @@ module Distribution.Client.Types.PackageLocation ( PackageLocation (..) + , PackageLocationProvenance , UnresolvedPkgLoc , ResolvedPkgLoc , UnresolvedSourcePackage @@ -18,10 +19,18 @@ import Distribution.Types.PackageId (PackageId) import Distribution.Client.Types.Repo import Distribution.Client.Types.SourceRepo (SourceRepoMaybe) import Distribution.Solver.Types.SourcePackage (SourcePackage) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) -type UnresolvedPkgLoc = PackageLocation (Maybe FilePath) +type UnresolvedPkgLoc = PackageLocationProvenance (Maybe FilePath) -type ResolvedPkgLoc = PackageLocation FilePath +type ResolvedPkgLoc = PackageLocationProvenance FilePath + +-- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. +type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc + +-- | A package location combined with provenance information indicating why +-- the package is being imported or built. +type PackageLocationProvenance local = WithConstraintSource (PackageLocation local) data PackageLocation local = -- | An unpacked package in the given dir, or current dir @@ -41,6 +50,3 @@ data PackageLocation local instance Binary local => Binary (PackageLocation local) instance Structured local => Structured (PackageLocation local) - --- | Convenience alias for 'SourcePackage UnresolvedPkgLoc'. -type UnresolvedSourcePackage = SourcePackage UnresolvedPkgLoc diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs index a803a85b429..53467f7cebc 100644 --- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs +++ b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs @@ -11,13 +11,20 @@ module Distribution.Client.Types.PackageSpecifier import Distribution.Client.Compat.Prelude import Prelude () +import Distribution.Client.Types.PackageLocation import Distribution.Package (Package (..), PackageIdentifier (..), packageName, packageVersion) import Distribution.Types.PackageName (PackageName) import Distribution.Version (nullVersion, thisVersion) import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.NamedPackage + ( NamedPackage (..) + , NamedPackageConstraint + ) import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.SourcePackage +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) -- | A fully or partially resolved reference to a package. data PackageSpecifier pkg @@ -25,7 +32,7 @@ data PackageSpecifier pkg -- installed). It is specified by package name and optionally some -- required properties. Use a dependency resolver to pick a specific -- package satisfying these properties. - NamedPackage PackageName [PackageProperty] + Named NamedPackageConstraint | -- | A fully specified source package. SpecificSourcePackage pkg deriving (Eq, Show, Functor, Generic) @@ -34,32 +41,54 @@ instance Binary pkg => Binary (PackageSpecifier pkg) instance Structured pkg => Structured (PackageSpecifier pkg) pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName -pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (Named (WithConstraintSource{constraintPackage = NamedPackage name _})) = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg +toConstraintSource :: UnresolvedSourcePackage -> ConstraintSource +toConstraintSource + SourcePackage + { srcpkgSource = + WithConstraintSource + { constraintConstraint = constraint + } + } = constraint + pkgSpecifierConstraints - :: Package pkg - => PackageSpecifier pkg + :: PackageSpecifier UnresolvedSourcePackage -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage name props) = map toLpc props - where - toLpc prop = - LabeledPackageConstraint - (PackageConstraint (scopeToplevel name) prop) - ConstraintSourceUserTarget +pkgSpecifierConstraints + ( Named + ( WithConstraintSource + { constraintPackage = NamedPackage name props + , constraintConstraint = constraint + } + ) + ) = + map toLpc props + where + toLpc prop = + LabeledPackageConstraint + (PackageConstraint (scopeToplevel name) prop) + constraint pkgSpecifierConstraints (SpecificSourcePackage pkg) = - [LabeledPackageConstraint pc ConstraintSourceUserTarget] + [LabeledPackageConstraint pc (toConstraintSource pkg)] where pc = 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))] +mkNamedPackage :: ConstraintSource -> PackageIdentifier -> PackageSpecifier pkg +mkNamedPackage constraint pkgId = + Named + ( WithConstraintSource + { constraintPackage = + NamedPackage + (pkgName pkgId) + ( if pkgVersion pkgId == nullVersion + then [] + else [PackagePropertyVersion (thisVersion (pkgVersion pkgId))] + ) + , constraintConstraint = constraint + } ) diff --git a/cabal-install/src/Distribution/Client/Types/SourceRepo.hs b/cabal-install/src/Distribution/Client/Types/SourceRepo.hs index 05449d1887b..17ae52616b3 100644 --- a/cabal-install/src/Distribution/Client/Types/SourceRepo.hs +++ b/cabal-install/src/Distribution/Client/Types/SourceRepo.hs @@ -15,7 +15,7 @@ module Distribution.Client.Types.SourceRepo , srpHoist , srpToProxy , srpFanOut - , sourceRepositoryPackageGrammar + , constraintSourceRepositoryPackageGrammar ) where import Distribution.Client.Compat.Prelude @@ -23,6 +23,12 @@ import Distribution.Compat.Lens (Lens, Lens') import Prelude () import Distribution.FieldGrammar +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource + ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Types.SourceRepo (RepoType (..)) -- | @source-repository-package@ definition @@ -59,7 +65,7 @@ srpToProxy s = s{srpSubdir = Proxy} -- | Split single @source-repository-package@ declaration with multiple subdirs, -- into multiple ones with at most single subdir. -srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe) +srpFanOut :: SourceRepoList -> NonEmpty SourceRepoMaybe srpFanOut s@SourceRepositoryPackage{srpSubdir = []} = s{srpSubdir = Nothing} :| [] srpFanOut s@SourceRepositoryPackage{srpSubdir = d : ds} = f d :| map f ds @@ -118,3 +124,21 @@ sourceRepositoryPackageGrammar = pcc = optionalFieldAla "post-checkout-command" (alaNonEmpty' NoCommaFSep Token) srpCommandLensNE {-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-} {-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-} + +constraintSourceRepositoryPackageGrammar + :: ( FieldGrammar c g + , Applicative (g SourceRepoList) + , Applicative (g (WithConstraintSource SourceRepoList)) + , c (Identity RepoType) + , c (List NoCommaFSep FilePathNT String) + , c (NonEmpty' NoCommaFSep Token String) + ) + => ConstraintSource + -> g (WithConstraintSource SourceRepoList) (WithConstraintSource SourceRepoList) +constraintSourceRepositoryPackageGrammar constraintSource = + (\pkg -> WithConstraintSource{constraintPackage = pkg, constraintConstraint = constraintSource}) + <$> blurFieldGrammar + (\f s -> fmap (\x -> s{constraintPackage = x}) (f (constraintPackage s))) + sourceRepositoryPackageGrammar +{-# SPECIALIZE constraintSourceRepositoryPackageGrammar :: ConstraintSource -> ParsecFieldGrammar' (WithConstraintSource SourceRepoList) #-} +{-# SPECIALIZE constraintSourceRepositoryPackageGrammar :: ConstraintSource -> PrettyFieldGrammar' (WithConstraintSource SourceRepoList) #-} diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 029e190a790..cb91a298cf1 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -64,6 +64,10 @@ import Distribution.Simple.Program import Distribution.Simple.Program.Db ( prependProgramSearchPath ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + , withUnknownConstraint + ) import Distribution.System ( OS (Windows) , buildOS @@ -154,31 +158,36 @@ data SourceRepoProblem -- -- | It also returns the 'VCS' driver we should use to work with it. validateSourceRepo - :: SourceRepositoryPackage f - -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) -validateSourceRepo = \repo -> do - let rtype = srpType repo - vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype - let uri = srpLocation repo - return (repo, uri, rtype, vcs) - where - a ?! e = maybe (Left e) Right a + :: WithConstraintSource (SourceRepositoryPackage f) + -> Either SourceRepoProblem (WithConstraintSource (SourceRepositoryPackage f), String, RepoType, VCS Program) +validateSourceRepo + withConstraint@WithConstraintSource + { constraintPackage = repo + } = + do + let rtype = srpType repo + vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype + let uri = srpLocation repo + return (withConstraint, uri, rtype, vcs) + where + a ?! e = maybe (Left e) Right a validatePDSourceRepo :: PD.SourceRepo - -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program) + -> Either SourceRepoProblem (WithConstraintSource SourceRepoMaybe, String, RepoType, VCS Program) validatePDSourceRepo repo = do rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified - validateSourceRepo - SourceRepositoryPackage - { srpType = rtype - , srpLocation = uri - , srpTag = PD.repoTag repo - , srpBranch = PD.repoBranch repo - , srpSubdir = PD.repoSubdir repo - , srpCommand = mempty - } + validateSourceRepo $ + withUnknownConstraint + SourceRepositoryPackage + { srpType = rtype + , srpLocation = uri + , srpTag = PD.repoTag repo + , srpBranch = PD.repoBranch repo + , srpSubdir = PD.repoSubdir repo + , srpCommand = mempty + } where a ?! e = maybe (Left e) Right a @@ -186,20 +195,20 @@ validatePDSourceRepo repo = do -- things in a convenient form to pass to 'configureVCSs', or to report -- problems. validateSourceRepos - :: [SourceRepositoryPackage f] + :: [WithConstraintSource (SourceRepositoryPackage f)] -> Either - [(SourceRepositoryPackage f, SourceRepoProblem)] - [(SourceRepositoryPackage f, String, RepoType, VCS Program)] + [(WithConstraintSource (SourceRepositoryPackage f), SourceRepoProblem)] + [(WithConstraintSource (SourceRepositoryPackage f), String, RepoType, VCS Program)] validateSourceRepos rs = case partitionEithers (map validateSourceRepo' rs) of (problems@(_ : _), _) -> Left problems ([], vcss) -> Right vcss where validateSourceRepo' - :: SourceRepositoryPackage f + :: WithConstraintSource (SourceRepositoryPackage f) -> Either - (SourceRepositoryPackage f, SourceRepoProblem) - (SourceRepositoryPackage f, String, RepoType, VCS Program) + (WithConstraintSource (SourceRepositoryPackage f), SourceRepoProblem) + (WithConstraintSource (SourceRepositoryPackage f), String, RepoType, VCS Program) validateSourceRepo' r = either (Left . (,) r)