From cb58b97971778358c65bb4bd56a1c008bb48836b Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Tue, 29 Oct 2024 12:59:51 -0700 Subject: [PATCH 1/8] Add `ConstraintSource` to local packages Before: [__0] rejecting: memory-0.18.0 (constraint from user target requires ==0.17.0) After: [__0] rejecting: memory-0.18.0 (constraint from cabal.project requires ==0.17.0) --- .../cabal-install-solver.cabal | 2 + .../Solver/Types/ConstraintSource.hs | 7 +- .../Distribution/Solver/Types/NamedPackage.hs | 30 + .../Solver/Types/PackageConstraint.hs | 2 +- .../Solver/Types/SourcePackage.hs | 4 +- .../Solver/Types/WithConstraintSource.hs | 50 ++ cabal-install/cabal-install.cabal | 1 + .../Client/BuildReports/Storage.hs | 15 +- .../src/Distribution/Client/CmdBench.hs | 15 +- .../src/Distribution/Client/CmdBuild.hs | 19 +- .../src/Distribution/Client/CmdFreeze.hs | 31 +- .../src/Distribution/Client/CmdHaddock.hs | 15 +- .../Distribution/Client/CmdHaddockProject.hs | 8 +- .../src/Distribution/Client/CmdInstall.hs | 167 +++-- .../CmdInstall/ClientInstallTargetSelector.hs | 5 +- .../src/Distribution/Client/CmdListBin.hs | 12 +- .../src/Distribution/Client/CmdOutdated.hs | 7 +- .../src/Distribution/Client/CmdRepl.hs | 453 +++++++------- .../src/Distribution/Client/CmdRun.hs | 314 +++++----- .../src/Distribution/Client/CmdSdist.hs | 57 +- .../src/Distribution/Client/CmdTest.hs | 32 +- .../src/Distribution/Client/Configure.hs | 42 +- .../src/Distribution/Client/Dependency.hs | 2 +- .../src/Distribution/Client/Fetch.hs | 5 +- .../src/Distribution/Client/FetchUtils.hs | 85 +-- .../src/Distribution/Client/Freeze.hs | 10 +- cabal-install/src/Distribution/Client/Get.hs | 18 +- .../src/Distribution/Client/IndexUtils.hs | 4 +- .../src/Distribution/Client/Install.hs | 27 +- cabal-install/src/Distribution/Client/List.hs | 8 +- .../Distribution/Client/ProjectBuilding.hs | 16 +- .../src/Distribution/Client/ProjectConfig.hs | 389 ++++++++---- .../Client/ProjectConfig/Legacy.hs | 66 +- .../Client/ProjectConfig/Types.hs | 18 +- .../Client/ProjectOrchestration.hs | 181 +++--- .../Distribution/Client/ProjectPlanOutput.hs | 9 +- .../Distribution/Client/ProjectPlanning.hs | 51 +- .../Client/ProjectPlanning/Types.hs | 24 +- .../Client/Sandbox/PackageEnvironment.hs | 21 +- .../src/Distribution/Client/ScriptUtils.hs | 57 +- .../src/Distribution/Client/Setup.hs | 23 +- .../src/Distribution/Client/TargetSelector.hs | 210 ++++--- .../src/Distribution/Client/Targets.hs | 70 ++- .../Client/Types/PackageLocation.hs | 16 +- .../Client/Types/PackageSpecifier.hs | 65 +- .../Distribution/Client/Types/SourceRepo.hs | 28 +- cabal-install/src/Distribution/Client/VCS.hs | 59 +- cabal-install/tests/IntegrationTests2.hs | 573 ++++++++++++------ .../Distribution/Client/ArbitraryInstances.hs | 38 ++ .../Distribution/Client/FetchUtils.hs | 46 +- .../Distribution/Client/ProjectConfig.hs | 55 +- .../Distribution/Client/TreeDiffInstances.hs | 4 + .../Distribution/Solver/Modular/DSL.hs | 21 +- .../use-local-version-of-package.out | 3 +- .../use-local-package-as-setup-dep.out | 3 +- .../ConditionalAndImport/cabal.out | 24 +- .../SourceRepositoryPackage/A.hs | 3 + .../SourceRepositoryPackage/cabal.out | 16 + .../SourceRepositoryPackage/cabal.project | 7 + .../SourceRepositoryPackage/cabal.test.hs | 5 + .../SourceRepositoryPackage/plain.cabal | 11 + .../repo/my-lib-1.0/my-lib.cabal | 11 + .../repo/my-lib-1.0/src/MyLib.hs | 4 + .../repo/my-lib-2.0/my-lib.cabal | 11 + .../repo/my-lib-2.0/src/MyLib.hs | 4 + .../NewSdist/MultiTarget/all-test-suite.out | 5 + ...st-sute.test.hs => all-test-suite.test.hs} | 0 changelog.d/pr-10524 | 21 + 68 files changed, 2406 insertions(+), 1209 deletions(-) create mode 100644 cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs create mode 100644 cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/A.hs create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.out create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.project create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.test.hs create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/plain.cabal create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/my-lib.cabal create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/src/MyLib.hs create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/my-lib.cabal create mode 100644 cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/src/MyLib.hs create mode 100644 cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-suite.out rename cabal-testsuite/PackageTests/NewSdist/MultiTarget/{all-test-sute.test.hs => all-test-suite.test.hs} (100%) create mode 100644 changelog.d/pr-10524 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 3f171b3c6d7..01082be62cd 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -56,7 +56,10 @@ 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 (Show, Eq, Generic) + + -- | An implicit constraint added by Cabal. + | ConstraintSourceImplicit + deriving (Show, Eq, Ord, Generic, Typeable) instance Binary ConstraintSource instance Structured ConstraintSource @@ -88,3 +91,5 @@ instance Pretty ConstraintSource where 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 06c5ae169fa..2c00d9592fa 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/PackageConstraint.hs @@ -93,7 +93,7 @@ data PackageProperty | PackagePropertySource | PackagePropertyFlags FlagAssignment | PackagePropertyStanzas [OptionalStanza] - deriving (Eq, Show, Generic) + deriving (Eq, Ord, Show, Generic) instance Binary PackageProperty instance Structured PackageProperty diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs index 35cba9b6e4a..1c4d5b4686f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveDataTypeable #-} + module Distribution.Solver.Types.SourcePackage ( PackageDescriptionOverride , SourcePackage(..) @@ -25,7 +27,7 @@ data SourcePackage loc = SourcePackage , srcpkgSource :: loc , srcpkgDescrOverride :: PackageDescriptionOverride } - deriving (Eq, Show, Generic, Typeable) + deriving (Eq, Show, Functor, Generic, Typeable) instance Binary loc => Binary (SourcePackage loc) instance Structured loc => Structured (SourcePackage loc) 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..ba0052a68cc --- /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 + { constraintInner :: pkg + -- ^ The package. + , constraintSource :: 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 constraintInner = + WithConstraintSource + { constraintInner + , constraintSource = ConstraintSourceUnknown + } + +showWithConstraintSource :: (pkg -> String) -> WithConstraintSource pkg -> String +showWithConstraintSource + showPackage + (WithConstraintSource { constraintInner, constraintSource }) = + showPackage constraintInner ++ " (" ++ showConstraintSource constraintSource ++ ")" + +instance Pretty pkg => Pretty (WithConstraintSource pkg) where + pretty (WithConstraintSource { constraintInner, constraintSource = ConstraintSourceUnknown }) + = pretty constraintInner + pretty (WithConstraintSource { constraintInner, constraintSource }) + = pretty constraintInner + <+> parens (text "from" <+> pretty constraintSource) 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..989d5747d1c 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 + { constraintInner = + 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..79e8e146774 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 constraintInner) return + =<< readTargetSelectors + (localPackages baseCtx) + (Just BenchKind) + (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = 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 constraintInner) return $ resolveTargets selectPackageTargets selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 44f1c4e0f27..7790c53a999 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 constraintTargets 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 constraintInner) return $ resolveTargets selectPackageTargets selectComponentTarget @@ -186,6 +192,15 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globa runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags) + constraintTargets = + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + targetStrings -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs index 29718b5d441..2e1b418dc31 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 + { constraintInner = UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v) + , constraintSource = 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 + { constraintInner = UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f) + , constraintSource = 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 . constraintInner) 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 677589e3e35..7acd9df7443 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 ) @@ -164,8 +170,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 constraintInner) return + =<< readTargetSelectors + (localPackages baseCtx) + Nothing + (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceCommandlineFlag}) targetStrings) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -175,7 +184,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 constraintInner) 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..fc9fc1b4ec5 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{constraintInner = "all", constraintSource = 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 75e673e895f..b60a4ba7350 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 + { constraintInner = "." + , constraintSource = ConstraintSourceImplicit + } + ] + else + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = 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) . constraintInner) 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 $ constraintInner target of Right pkgId@PackageIdentifier{pkgVersion} | pkgVersion /= nullVersion -> - pure pkgId - _ -> Left s + pure $ target{constraintInner = 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 + { constraintInner = + TargetPackageNamed (pkgName pkgId) targetFilter + } + ) + | withConstraint@WithConstraintSource + { constraintInner = pkgId + , constraintSource = 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 constraintInner 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 . constraintInner) 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{constraintInner = either'}) = + case either' of + Left inner -> Left (withConstraint{constraintInner = inner}) + Right inner -> Right (withConstraint{constraintInner = 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 . constraintInner) tss) + return (map constraintInner 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) + { constraintInner = 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{constraintInner = NamedPackage packageName []}) + | withConstraint@WithConstraintSource{constraintInner = packageName} <- hackageNames + ] - hackageTargets :: [TargetSelector] - hackageTargets = [TargetPackageNamed pn targetFilter | pn <- hackageNames] + hackageTargets :: [WithConstraintSource TargetSelector] + hackageTargets = + [ withConstraint{constraintInner = TargetPackageNamed packageName targetFilter} + | withConstraint@WithConstraintSource{constraintInner = 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 constraintInner problem of + TargetAvailableInIndex name -> Right problem{constraintInner = 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 constraintInner target of TargetComponentUnknown name _ _ - | name `elem` hackageNames -> False + | name `elem` (map constraintInner hackageNames) -> False TargetPackageNamed name _ - | name `elem` hackageNames -> False + | name `elem` (map constraintInner 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 constraintInner) 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 constraintInner) 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 . constraintInner) 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 . constraintInner) 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 + { constraintInner = + pkgSpec + , constraintSource = 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 df16b98e1a2..e86fbc293c3 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -61,6 +61,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 @@ -93,8 +95,14 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do [x] -> return x _ -> dieWithException verbosity OneTargetRequired + let targetProvenance = + WithConstraintSource + { constraintInner = target + , constraintSource = 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 @@ -105,7 +113,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 constraintInner) return $ resolveTargets selectPackageTargets selectComponentTarget diff --git a/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal-install/src/Distribution/Client/CmdOutdated.hs index 7674e67286f..6c64d763bef 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 constraintInner . 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 constraintInner . 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 a75524bbca6..05401df30eb 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{constraintInner = target, constraintSource = 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 implementation 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 overridden 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 implementation 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 constraintInner) 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 + { constraintInner = + UserConstraint + (UserAnySetupQualifier (mkPackageName "Cabal")) + (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11]) + , constraintSource = 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 0000a2927a1..ed6d6ca2385 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -112,6 +112,8 @@ import Distribution.Simple.Utils , wrapText ) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) import Distribution.Types.ComponentName ( componentNameRaw ) @@ -206,159 +208,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{constraintInner = target, constraintSource = 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 constraintInner) 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 ab9e7712bc3..1d0fd90a676 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -60,9 +60,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 ( (<.>) , () @@ -128,6 +134,7 @@ import Distribution.Verbosity ( normal ) +import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy.Char8 as BSL import System.Directory ( createDirectoryIfMissing @@ -231,8 +238,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 constraintInner) return + =<< readTargetSelectors + localPkgs + Nothing + ( map + (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceCommandlineFlag}) + targetStrings + ) -- elaborate path, create target directory mOutputPath' <- case mOutputPath of @@ -265,7 +278,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 + (renderTargetProblem . constraintInner) + errs Right pkgs | length pkgs > 1 , not listSources @@ -320,7 +338,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 constraintInner $ srcpkgSource pkg of LocalUnpackedPackage path -> pure (Right path) RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) RemoteSourceRepoPackage{} -> death @@ -364,7 +382,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' @@ -385,14 +406,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{constraintInner = problem}) + id + ) + inner + where + inner = + case constraintInner 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..d59f78168f3 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 + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + either (reportTargetSelectorProblems verbosity . map constraintInner) 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 + { constraintInner = CustomTargetProblem (TargetProblemNoTests _) + } + ] + ) -> + dieWithException verbosity $ ReportTargetProblems problemsMessage + (_, [WithConstraintSource{constraintInner = 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..326ea5e802b 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 + { constraintInner = 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 . constraintInner) $ configExConstraints flags unknownPreferences = - filter (unknown . \(PackageVersionConstraint name _) -> name) $ + filter (unknown . (\(PackageVersionConstraint name _) -> name) . constraintInner) $ 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 constraintInner $ 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 constraintInner) constraintSource + | WithConstraintSource{constraintSource, constraintInner} <- 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..17dfef9d351 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 . constraintInner . 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..06d8951e557 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 constraintInner 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 constraintInner 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{constraintInner = 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 constraintInner 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{constraintInner = 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..cf7b457fdb8 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 + { constraintInner = pkgIdToConstraint $ packageId pkg + , constraintSource = 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..a18782f806e 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 constraintInner 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' (constraintInner repo) destDir `catch` \exitcode -> throwIO ( ClonePackageFailedWithExitCode pkgid - (srpToProxy repo) + (srpToProxy $ constraintInner 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..7fd751d6014 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 constraintInner $ configPreferences configExFlags ] . addConstraints -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- configExConstraints configExFlags + | WithConstraintSource + { constraintInner = pc + , constraintSource = 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 + { constraintInner = + 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 constraintInner 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..e9f0a66ed7b 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{constraintInner = 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..6b03af513b6 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 constraintInner <$> 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 $ constraintInner $ 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 constraintInner 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 5f31dc0fab5..a7d9c081aec 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 + { constraintInner = + UserConstraint + (UserAnySetupQualifier cabalPkgname) + (PackagePropertyVersion $ orLaterVersion (mkVersion [3, 13, 0])) + , constraintSource = 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 . constraintInner) 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 + { constraintInner = "./*.cabal" + , -- TODO: Is a relative path OK here? + constraintSource = 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 + { constraintInner = bpl + , constraintSource = 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 + { constraintInner = bpl + , constraintSource = 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 $ constraintInner 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 $ constraintInner 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{constraintInner = 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 constraintInner failures)) + <$> pkgloc + ) _ -> Right pkglocs - checkIsSingleFilePackage pkglocstr = do - let filename = distProjectRootDirectory pkglocstr + checkIsSingleFilePackage pkgloc = do + let pkglocstr = constraintInner 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 = constraintInner 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 + { constraintInner = + 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 + { constraintInner = location + , constraintSource = constraint + } <- + pkgLocations , (dir, cabalFile) <- projectPackageLocal location ] pkgsLocalTarball <- sequenceA - [ readSourcePackageLocalTarball verbosity path - | ProjectPackageLocalTarball path <- pkgLocations + [ readSourcePackageLocalTarball verbosity constraint path + | WithConstraintSource + { constraintInner = ProjectPackageLocalTarball path + , constraintSource = constraint + } <- + pkgLocations ] pkgsRemoteTarball <- do @@ -1262,10 +1343,15 @@ fetchAndReadSourcePackages sequenceA [ fetchAndReadSourcePackageRemoteTarball verbosity + constraint distDirLayout getTransport uri - | ProjectPackageRemoteTarball uri <- pkgLocations + | WithConstraintSource + { constraintInner = ProjectPackageRemoteTarball uri + , constraintSource = constraint + } <- + pkgLocations ] pkgsRemoteRepo <- @@ -1276,11 +1362,20 @@ fetchAndReadSourcePackages projectConfigShared projectConfigBuildOnly (fromFlag (projectConfigOfflineMode projectConfigBuildOnly)) - [repo | ProjectPackageRemoteRepo repo <- pkgLocations] + [ withConstraint{constraintInner = repo} + | withConstraint@WithConstraintSource + { constraintInner = ProjectPackageRemoteRepo repo + } <- + pkgLocations + ] let pkgsNamed = - [ NamedPackage pkgname [PackagePropertyVersion verrange] - | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations + [ Named (withConstraint{constraintInner = NamedPackage pkgname [PackagePropertyVersion verrange]}) + | withConstraint@WithConstraintSource + { constraintInner = + 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 constraintSource dir cabalFile = do monitorFiles [monitorFileHashed cabalFile] root <- askRoot - let location = LocalUnpackedPackage (root dir) + let location = + WithConstraintSource + { constraintInner = LocalUnpackedPackage (root dir) + , constraintSource + } 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 constraintSource tarballFile = do monitorFiles [monitorFile tarballFile] root <- askRoot - let location = LocalTarballPackage (root tarballFile) + let location = + WithConstraintSource + { constraintInner = LocalTarballPackage (root tarballFile) + , constraintSource + } 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 + constraintSource DistDirLayout { distDownloadSrcDirectory } @@ -1370,7 +1477,11 @@ fetchAndReadSourcePackageRemoteTarball -- Read monitorFiles [monitorFile tarballFile] - let location = RemoteTarballPackage tarballUri tarballFile + let location = + WithConstraintSource + { constraintInner = RemoteTarballPackage tarballUri tarballFile + , constraintSource + } 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 (constraintInner 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{constraintInner = repoWithSubdir} + ) + | withConstraint@WithConstraintSource + { constraintInner = 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 = constraintInner 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 + { constraintInner = 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..5a75f9f9931 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 + (Disp.text . renderPackageLocationToken . constraintInner) + ( (\pkg -> WithConstraintSource{constraintInner = pkg, constraintSource = constraintSrc}) + `fmap` parsePackageLocationTokenQ + ) legacyPackages (\v flags -> flags{legacyPackages = v}) , newLineListField "optional-packages" - (Disp.text . renderPackageLocationToken) - parsePackageLocationTokenQ + (Disp.text . renderPackageLocationToken . constraintInner) + ( (\pkg -> WithConstraintSource{constraintInner = pkg, constraintSource = constraintSrc}) + `fmap` parsePackageLocationTokenQ + ) legacyPackagesOptional (\v flags -> flags{legacyPackagesOptional = v}) , commaNewLineListFieldParsec "extra-packages" - pretty - parsec + (pretty . constraintInner) + ( (\pkg -> WithConstraintSource{constraintInner = pkg, constraintSource = 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 . constraintInner) + ( (\constraint -> WithConstraintSource{constraintInner = constraint, constraintSource = constraintSrc}) + `fmap` parsec + ) configExConstraints (\v conf -> conf{configExConstraints = v}) , commaNewLineListFieldParsec "preferences" - pretty - parsec + (pretty . constraintInner) + ( (\preference -> WithConstraintSource{constraintInner = preference, constraintSource = 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..5f52909b2a5 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 constraintInner . 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 + { constraintInner = targetSelector + } + ) = + bimap + (\problem -> withConstraint{constraintInner = 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 $ + constraintInner $ + 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 b6b5dc8dd79..e2fc4efb188 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs @@ -22,7 +22,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) @@ -32,6 +34,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) @@ -164,7 +169,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 (constraintInner $ 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 582e526af53..edf1416b781 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -6,6 +6,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./ @@ -112,6 +113,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 (..) @@ -147,12 +151,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 @@ -783,7 +793,7 @@ rebuildInstallPlan -> (Compiler, Platform, ProgramDb) -> Maybe PkgConfigDb -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> [PackageSpecifier (SourcePackage (PackageLocationProvenance loc))] -> Rebuild ( ElaboratedInstallPlan , ElaboratedSharedConfig @@ -916,9 +926,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 + { constraintInner = 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 @@ -1026,7 +1041,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}) <- @@ -1045,7 +1060,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}) <- @@ -1057,20 +1072,20 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do localTarballPkgs :: [(PackageId, FilePath)] localTarballPkgs = [ (pkgid, tarball) - | (pkgid, LocalTarballPackage tarball) <- allPkgLocations + | (pkgid, constraintInner -> 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, constraintInner -> RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ] -- tarballs from source-repository-package stanzas sourceRepoTarballPkgs = [ (pkgid, tarball) - | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations + | (pkgid, constraintInner -> RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ] -- Tarballs from repositories, either where the repository provides @@ -1085,7 +1100,7 @@ getPackageSourceHashes verbosity withRepoCtx solverPlan = do [ case repo of RepoSecure{} -> Left (repo, [pkgid]) _ -> Right (repo, pkgid) - | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations + | (pkgid, constraintInner -> RepoTarballPackage repo _ _) <- allPkgLocations ] -- Group up the unvalidated packages by repo so we only read the remote @@ -1283,12 +1298,16 @@ planPackages . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- solverSettingPreferences + | PackageVersionConstraint name ver <- map constraintInner solverSettingPreferences ] . addConstraints -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints + | WithConstraintSource + { constraintInner = pc + , constraintSource = src + } <- + solverSettingConstraints ] . addPreferences -- enable stanza preference unilaterally, regardless if the user asked @@ -1542,7 +1561,7 @@ elaborateInstallPlan -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage (PackageLocation loc))] + -> [PackageSpecifier (SourcePackage (PackageLocationProvenance loc))] -> Map PackageId PackageSourceHash -> InstallDirs.InstallDirTemplates -> ProjectConfigShared @@ -2529,9 +2548,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 constraintInner $ 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 0ac54fce8ce..fd4f7451b6c 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -110,6 +110,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 @@ -223,7 +226,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 @@ -460,15 +463,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 constraintInner 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..b3bdde5704a 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{constraintInner = userConstraint, constraintSource = src}) + `fmap` parsec + ) ( sortConstraints . configExConstraints . savedConfigureExFlags @@ -186,7 +194,9 @@ pkgEnvFieldDescrs src = , commaListFieldParsec "preferences" pretty - parsec + ( (\preference -> WithConstraintSource{constraintInner = preference, constraintSource = 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 . constraintInner) -- | 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 f397f4342c5..e767c1cab64 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` constraintInner target -> do + scriptOrError + (constraintInner 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{constraintInner = TargetSelectorNoTargetsInCwd{}} : _) | [] <- targetStrings , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget) - Left err@(TargetSelectorNoTargetsInProject : _) + Left err@(WithConstraintSource{constraintInner = 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 (constraintInner script) err + Left err@(WithConstraintSource{constraintInner = TargetSelectorNoSuch t _} : _) | TargetString1 script <- t -> scriptOrError script err - Left err@(TargetSelectorExpected t _ _ : _) + Left err@(WithConstraintSource{constraintInner = 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{constraintInner = MatchingInternalError _ _ _} : _) -- Handle ':' in middle of script name. + | [script] <- targetStrings -> scriptOrError (constraintInner script) err + Left err -> reportTargetSelectorProblems verbosity (map constraintInner 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 + { constraintInner = TargetPackage TargetExplicitNamed [fakePackageId] Nothing + , constraintSource = 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 constraintInner 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 ce1436ff9a7..5008c49a372 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 ScopedTypeVariables #-} @@ -211,6 +212,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 (..) @@ -908,8 +913,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 @@ -948,7 +953,7 @@ configureExOptions :: ShowOrParseArgs -> ConstraintSource -> [OptionField ConfigExFlags] -configureExOptions _showOrParseArgs src = +configureExOptions _showOrParseArgs constraint = [ option [] ["cabal-lib-version"] @@ -987,8 +992,10 @@ configureExOptions _showOrParseArgs src = (\v flags -> flags{configExConstraints = v}) ( reqArg "CONSTRAINT" - ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint) - (map $ prettyShow . fst) + ( (\pkg -> [WithConstraintSource{constraintInner = pkg, constraintSource = constraint}]) + `fmap` ReadE readUserConstraint + ) + (map $ showWithConstraintSource prettyShow) ) , option [] @@ -1000,9 +1007,11 @@ configureExOptions _showOrParseArgs src = "CONSTRAINT" ( parsecToReadE (const "dependency expected") - (fmap (\x -> [x]) parsec) + ( (\pkg -> [WithConstraintSource{constraintInner = pkg, constraintSource = 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 6e0ad2488f3..2b0e63412f4 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -48,6 +48,7 @@ import Prelude () import Distribution.Client.Types ( PackageLocation (..) + , PackageLocationProvenance , PackageSpecifier (..) ) import Distribution.Package @@ -91,15 +92,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 @@ -245,24 +256,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 @@ -271,7 +282,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 @@ -316,14 +327,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{constraintInner = parsed}) + <$> readPToMaybe parseTargetApprox (constraintInner target) where parseTargetApprox :: Parse.ReadP r TargetString parseTargetApprox = @@ -456,22 +468,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{constraintInner = result}) + <$> case constraintInner 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 @@ -532,19 +545,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 + { constraintInner = TargetSelectorNoTargetsInProject + , constraintSource = 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 + { constraintInner = TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) + , constraintSource = ConstraintSourceImplicit + } + ] + , [] + ) resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = - ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + ( [] + , + [ WithConstraintSource + { constraintInner = TargetPackage TargetImplicitCwd pkgids Nothing + , constraintSource = ConstraintSourceImplicit + } + ] + ) where pkgids = [pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary] resolveTargetSelectors knowntargets targetStrs mfilter = @@ -555,35 +589,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 $ constraintInner 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 $ constraintInner targetStrStatus projectIsEmpty = null knownPackagesAll @@ -692,7 +731,7 @@ data QualLevel disambiguateTargetSelectors :: (TargetStringFileStatus -> Match TargetSelector) - -> TargetStringFileStatus + -> WithConstraintSource TargetStringFileStatus -> MatchClass -> [TargetSelector] -> Either @@ -718,7 +757,8 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = [ (matchResult, matchRenderings) | matchResult <- matchResults , let matchRenderings = - [ copyFileStatus matchInput rendering + -- TODO: Should we propagate `ConstraintSource` information here? + [ copyFileStatus (constraintInner matchInput) rendering | ql <- [QL1 .. QLFull] , rendering <- renderTargetSelector ql matchResult ] @@ -733,7 +773,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 (constraintInner matchInput) (Match Exact 0 matchResults) else id ) $ Map.Lazy.fromList @@ -799,21 +839,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 () @@ -1838,7 +1884,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 @@ -1874,10 +1920,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 + { constraintInner = NamedPackage pkgname _props + } + ) + ) = return (KnownPackageName pkgname) collectKnownPackageInfo dirActions@DirActions{..} ( SpecificSourcePackage @@ -1887,7 +1939,7 @@ collectKnownPackageInfo } ) = do (pkgdir, pkgfile) <- - case loc of + case constraintInner 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 a973433ccb8..e7ddaf74fff 100644 --- a/cabal-install/src/Distribution/Client/Targets.hs +++ b/cabal-install/src/Distribution/Client/Targets.hs @@ -50,6 +50,7 @@ import Prelude () import Distribution.Client.Types ( PackageLocation (..) + , PackageLocationProvenance , PackageSpecifier (..) , ResolvedPkgLoc , UnresolvedSourcePackage @@ -62,12 +63,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 @@ -288,7 +297,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 @@ -316,10 +325,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) @@ -334,24 +343,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 = @@ -367,11 +377,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. -- @@ -383,14 +393,14 @@ readPackageTarget readPackageTarget verbosity = traverse modifyLocation where modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage - modifyLocation location = case location of + modifyLocation location = case constraintInner 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 -> @@ -423,7 +433,7 @@ readPackageTarget verbosity = traverse modifyLocation SourcePackage { srcpkgPackageId = packageId pkg , srcpkgDescription = pkg - , srcpkgSource = fmap Just location + , srcpkgSource = fmap Just <$> location , srcpkgDescrOverride = Nothing } @@ -497,11 +507,11 @@ disambiguatePackageTargets availablePkgIndex availableExtra targets = where disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - PackageTargetNamed pkgname props userTarget + PackageTargetNamed (withConstraint@WithConstraintSource{constraintInner = (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{constraintInner = (NamedPackage pkgname _)}) userTarget -> case disambiguatePackageName packageNameEnv pkgname of None -> Left @@ -516,7 +526,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 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..1081450c438 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{constraintInner = NamedPackage name _})) = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg +toConstraintSource :: UnresolvedSourcePackage -> ConstraintSource +toConstraintSource + SourcePackage + { srcpkgSource = + WithConstraintSource + { constraintSource = 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 + { constraintInner = NamedPackage name props + , constraintSource = 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 + { constraintInner = + NamedPackage + (pkgName pkgId) + ( if pkgVersion pkgId == nullVersion + then [] + else [PackagePropertyVersion (thisVersion (pkgVersion pkgId))] + ) + , constraintSource = constraint + } ) diff --git a/cabal-install/src/Distribution/Client/Types/SourceRepo.hs b/cabal-install/src/Distribution/Client/Types/SourceRepo.hs index 05449d1887b..9d82af1ed27 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 source = + (\pkg -> WithConstraintSource{constraintInner = pkg, constraintSource = source}) + <$> blurFieldGrammar + (\f s -> fmap (\x -> s{constraintInner = x}) (f (constraintInner 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 98b8251d9c1..270466b7d5d 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 @@ -155,31 +159,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 + { constraintInner = 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 @@ -187,20 +196,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) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index a74d235c6e5..d9faf49bb2f 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -38,12 +38,18 @@ import Distribution.Client.Types , UnresolvedSourcePackage ) import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource (ConstraintSourceUnknown) + ( ConstraintSource (..) ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty (PackagePropertySource) ) +import Distribution.Solver.Types.ProjectConfigPath + ( ProjectConfigPath (..) + ) import Distribution.Solver.Types.SourcePackage as SP +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import qualified Distribution.Client.CmdBench as CmdBench import qualified Distribution.Client.CmdBuild as CmdBuild @@ -191,194 +197,305 @@ testTargetSelectors reportSubCase = do reportSubCase "cwd" do Right ts <- readTargetSelectors' [] - ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] + ts + @?= [ WithConstraintSource + { constraintInner = TargetPackage TargetImplicitCwd ["p-0.1"] Nothing + , constraintSource = ConstraintSourceImplicit + } + ] reportSubCase "all" do Right ts <- readTargetSelectors' - ["all", ":all"] - ts @?= replicate 2 (TargetAllPackages Nothing) + [ WithConstraintSource + { constraintInner = "all" + , constraintSource = ConstraintSourceCommandlineFlag + } + , WithConstraintSource + { constraintInner = ":all" + , constraintSource = ConstraintSourceCommandlineFlag + } + ] + ts + @?= replicate + 2 + ( WithConstraintSource + { constraintInner = TargetAllPackages Nothing + , constraintSource = ConstraintSourceCommandlineFlag + } + ) reportSubCase "filter" do Right ts <- - readTargetSelectors' - [ "libs" - , ":cwd:libs" - , "flibs" - , ":cwd:flibs" - , "exes" - , ":cwd:exes" - , "tests" - , ":cwd:tests" - , "benchmarks" - , ":cwd:benchmarks" - ] + readTargetSelectors' $ + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "libs" + , ":cwd:libs" + , "flibs" + , ":cwd:flibs" + , "exes" + , ":cwd:exes" + , "tests" + , ":cwd:tests" + , "benchmarks" + , ":cwd:benchmarks" + ] zipWithM_ (@?=) ts - [ TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind) + [ WithConstraintSource + { constraintInner = TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind) + , constraintSource = ConstraintSourceCommandlineFlag + } | kind <- concatMap (replicate 2) [LibKind ..] ] reportSubCase "all:filter" do Right ts <- - readTargetSelectors' - [ "all:libs" - , ":all:libs" - , "all:flibs" - , ":all:flibs" - , "all:exes" - , ":all:exes" - , "all:tests" - , ":all:tests" - , "all:benchmarks" - , ":all:benchmarks" - ] + readTargetSelectors' $ + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "all:libs" + , ":all:libs" + , "all:flibs" + , ":all:flibs" + , "all:exes" + , ":all:exes" + , "all:tests" + , ":all:tests" + , "all:benchmarks" + , ":all:benchmarks" + ] zipWithM_ (@?=) ts - [ TargetAllPackages (Just kind) + [ WithConstraintSource + { constraintInner = TargetAllPackages (Just kind) + , constraintSource = ConstraintSourceCommandlineFlag + } | kind <- concatMap (replicate 2) [LibKind ..] ] reportSubCase "pkg" do Right ts <- - readTargetSelectors' - [ ":pkg:p" - , "." - , "./" - , "p.cabal" - , "q" - , ":pkg:q" - , "q/" - , "./q/" - , "q/q.cabal" - ] + readTargetSelectors' $ + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ ":pkg:p" + , "." + , "./" + , "p.cabal" + , "q" + , ":pkg:q" + , "q/" + , "./q/" + , "q/q.cabal" + ] ts - @?= replicate 4 (mkTargetPackage "p-0.1") - ++ replicate 5 (mkTargetPackage "q-0.1") + @?= replicate + 4 + ( WithConstraintSource + { constraintInner = mkTargetPackage "p-0.1" + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + ++ replicate + 5 + ( WithConstraintSource + { constraintInner = mkTargetPackage "q-0.1" + , constraintSource = ConstraintSourceCommandlineFlag + } + ) reportSubCase "pkg:filter" do Right ts <- - readTargetSelectors' - [ "p:libs" - , ".:libs" - , ":pkg:p:libs" - , "p:flibs" - , ".:flibs" - , ":pkg:p:flibs" - , "p:exes" - , ".:exes" - , ":pkg:p:exes" - , "p:tests" - , ".:tests" - , ":pkg:p:tests" - , "p:benchmarks" - , ".:benchmarks" - , ":pkg:p:benchmarks" - , "q:libs" - , "q/:libs" - , ":pkg:q:libs" - , "q:flibs" - , "q/:flibs" - , ":pkg:q:flibs" - , "q:exes" - , "q/:exes" - , ":pkg:q:exes" - , "q:tests" - , "q/:tests" - , ":pkg:q:tests" - , "q:benchmarks" - , "q/:benchmarks" - , ":pkg:q:benchmarks" - ] + readTargetSelectors' $ + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "p:libs" + , ".:libs" + , ":pkg:p:libs" + , "p:flibs" + , ".:flibs" + , ":pkg:p:flibs" + , "p:exes" + , ".:exes" + , ":pkg:p:exes" + , "p:tests" + , ".:tests" + , ":pkg:p:tests" + , "p:benchmarks" + , ".:benchmarks" + , ":pkg:p:benchmarks" + , "q:libs" + , "q/:libs" + , ":pkg:q:libs" + , "q:flibs" + , "q/:flibs" + , ":pkg:q:flibs" + , "q:exes" + , "q/:exes" + , ":pkg:q:exes" + , "q:tests" + , "q/:tests" + , ":pkg:q:tests" + , "q:benchmarks" + , "q/:benchmarks" + , ":pkg:q:benchmarks" + ] zipWithM_ (@?=) ts $ - [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind) + [ WithConstraintSource + { constraintInner = TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind) + , constraintSource = ConstraintSourceCommandlineFlag + } | kind <- concatMap (replicate 3) [LibKind ..] ] - ++ [ TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind) + ++ [ WithConstraintSource + { constraintInner = TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind) + , constraintSource = ConstraintSourceCommandlineFlag + } | kind <- concatMap (replicate 3) [LibKind ..] ] reportSubCase "component" do Right ts <- - readTargetSelectors' - [ "p" - , "lib:p" - , "p:lib:p" - , ":pkg:p:lib:p" - , "lib:q" - , "q:lib:q" - , ":pkg:q:lib:q" - ] + readTargetSelectors' $ + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "p" + , "lib:p" + , "p:lib:p" + , ":pkg:p:lib:p" + , "lib:q" + , "q:lib:q" + , ":pkg:q:lib:q" + ] ts - @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) WholeComponent) - ++ replicate 3 (TargetComponent "q-0.1" (CLibName LMainLibName) WholeComponent) + @?= replicate + 4 + ( WithConstraintSource + { constraintInner = TargetComponent "p-0.1" (CLibName LMainLibName) WholeComponent + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + ++ replicate + 3 + ( WithConstraintSource + { constraintInner = TargetComponent "q-0.1" (CLibName LMainLibName) WholeComponent + , constraintSource = ConstraintSourceCommandlineFlag + } + ) reportSubCase "module" do Right ts <- - readTargetSelectors' - [ "P" - , "lib:p:P" - , "p:p:P" - , ":pkg:p:lib:p:module:P" - , "QQ" - , "lib:q:QQ" - , "q:q:QQ" - , ":pkg:q:lib:q:module:QQ" - , "pexe:PMain" -- p:P or q:QQ would be ambiguous here - , "qexe:QMain" -- package p vs component p - ] + readTargetSelectors' $ + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "P" + , "lib:p:P" + , "p:p:P" + , ":pkg:p:lib:p:module:P" + , "QQ" + , "lib:q:QQ" + , "q:q:QQ" + , ":pkg:q:lib:q:module:QQ" + , "pexe:PMain" -- p:P or q:QQ would be ambiguous here + , "qexe:QMain" -- package p vs component p + ] ts - @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) (ModuleTarget "P")) - ++ replicate 4 (TargetComponent "q-0.1" (CLibName LMainLibName) (ModuleTarget "QQ")) - ++ [ TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain") - , TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain") + @?= replicate 4 (WithConstraintSource{constraintInner = TargetComponent "p-0.1" (CLibName LMainLibName) (ModuleTarget "P"), constraintSource = ConstraintSourceCommandlineFlag}) + ++ replicate 4 (WithConstraintSource{constraintInner = TargetComponent "q-0.1" (CLibName LMainLibName) (ModuleTarget "QQ"), constraintSource = ConstraintSourceCommandlineFlag}) + ++ [ WithConstraintSource + { constraintInner = TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain") + , constraintSource = ConstraintSourceCommandlineFlag + } + , WithConstraintSource + { constraintInner = TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain") + , constraintSource = ConstraintSourceCommandlineFlag + } ] reportSubCase "file" do Right ts <- - readTargetSelectors' - [ "./P.hs" - , "p:P.lhs" - , "lib:p:P.hsc" - , "p:p:P.hsc" - , ":pkg:p:lib:p:file:P.y" - , "q/QQ.hs" - , "q:QQ.lhs" - , "lib:q:QQ.hsc" - , "q:q:QQ.hsc" - , ":pkg:q:lib:q:file:QQ.y" - , "q/Q.hs" - , "q:Q.lhs" - , "lib:q:Q.hsc" - , "q:q:Q.hsc" - , ":pkg:q:lib:q:file:Q.y" - , "app/Main.hs" - , "p:app/Main.hs" - , "exe:ppexe:app/Main.hs" - , "p:ppexe:app/Main.hs" - , ":pkg:p:exe:ppexe:file:app/Main.hs" - , "a p p/Main.hs" - , "p:a p p/Main.hs" - , "exe:pppexe:a p p/Main.hs" - , "p:pppexe:a p p/Main.hs" - , ":pkg:p:exe:pppexe:file:a p p/Main.hs" - ] + readTargetSelectors' $ + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "./P.hs" + , "p:P.lhs" + , "lib:p:P.hsc" + , "p:p:P.hsc" + , ":pkg:p:lib:p:file:P.y" + , "q/QQ.hs" + , "q:QQ.lhs" + , "lib:q:QQ.hsc" + , "q:q:QQ.hsc" + , ":pkg:q:lib:q:file:QQ.y" + , "q/Q.hs" + , "q:Q.lhs" + , "lib:q:Q.hsc" + , "q:q:Q.hsc" + , ":pkg:q:lib:q:file:Q.y" + , "app/Main.hs" + , "p:app/Main.hs" + , "exe:ppexe:app/Main.hs" + , "p:ppexe:app/Main.hs" + , ":pkg:p:exe:ppexe:file:app/Main.hs" + , "a p p/Main.hs" + , "p:a p p/Main.hs" + , "exe:pppexe:a p p/Main.hs" + , "p:pppexe:a p p/Main.hs" + , ":pkg:p:exe:pppexe:file:a p p/Main.hs" + ] ts - @?= replicate 5 (TargetComponent "p-0.1" (CLibName LMainLibName) (FileTarget "P")) - ++ replicate 5 (TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "QQ")) - ++ replicate 5 (TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "Q")) - ++ replicate 5 (TargetComponent "p-0.1" (CExeName "ppexe") (FileTarget ("app" "Main.hs"))) - ++ replicate 5 (TargetComponent "p-0.1" (CExeName "pppexe") (FileTarget ("a p p" "Main.hs"))) + @?= replicate 5 (WithConstraintSource{constraintInner = TargetComponent "p-0.1" (CLibName LMainLibName) (FileTarget "P"), constraintSource = ConstraintSourceCommandlineFlag}) + ++ replicate 5 (WithConstraintSource{constraintInner = TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "QQ"), constraintSource = ConstraintSourceCommandlineFlag}) + ++ replicate 5 (WithConstraintSource{constraintInner = TargetComponent "q-0.1" (CLibName LMainLibName) (FileTarget "Q"), constraintSource = ConstraintSourceCommandlineFlag}) + ++ replicate 5 (WithConstraintSource{constraintInner = TargetComponent "p-0.1" (CExeName "ppexe") (FileTarget ("app" "Main.hs")), constraintSource = ConstraintSourceCommandlineFlag}) + ++ replicate 5 (WithConstraintSource{constraintInner = TargetComponent "p-0.1" (CExeName "pppexe") (FileTarget ("a p p" "Main.hs")), constraintSource = ConstraintSourceCommandlineFlag}) -- Note there's a bit of an inconsistency here: for the single-part -- syntax the target has to point to a file that exists, whereas for -- all the other forms we don't require that. @@ -392,15 +509,25 @@ testTargetSelectorBadSyntax :: Assertion testTargetSelectorBadSyntax = do (_, _, _, localPackages, _) <- configureProject testdir config let targets = - [ "foo:" - , "foo::bar" - , " :foo" - , "foo: :bar" - , "a:b:c:d:e:f" - , "a:b:c:d:e:f:g:h" - ] + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "foo:" + , "foo::bar" + , " :foo" + , "foo: :bar" + , "a:b:c:d:e:f" + , "a:b:c:d:e:f:g:h" + ] Left errs <- readTargetSelectors localPackages Nothing targets - zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets) + zipWithM_ + (@?=) + errs + (map (fmap TargetSelectorUnrecognised) targets) cleanProject testdir where testdir = "targets/empty" @@ -575,12 +702,32 @@ testTargetSelectorAmbiguous reportSubCase = do res <- readTargetSelectorsWith fakeDirActions - (map SpecificSourcePackage pkgs) + ( map + ( SpecificSourcePackage + . fmap + ( \loc -> + WithConstraintSource + { constraintInner = loc + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + ) + pkgs + ) Nothing - [str] + [ WithConstraintSource + { constraintInner = str + , constraintSource = ConstraintSourceCommandlineFlag + } + ] case res of - Left [TargetSelectorAmbiguous _ tss'] -> - sort (map snd tss') @?= sort tss + Left + [ WithConstraintSource + { constraintInner = TargetSelectorAmbiguous _ tss' + , constraintSource = ConstraintSourceCommandlineFlag + } + ] -> + sort (map snd tss') @?= sort tss _ -> assertFailure $ "expected Left [TargetSelectorAmbiguous _ _], " @@ -596,11 +743,32 @@ testTargetSelectorAmbiguous reportSubCase = do res <- readTargetSelectorsWith fakeDirActions - (map SpecificSourcePackage pkgs) + ( map + ( SpecificSourcePackage + . fmap + ( \loc -> + WithConstraintSource + { constraintInner = loc + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + ) + pkgs + ) Nothing - [str] + [ WithConstraintSource + { constraintInner = str + , constraintSource = ConstraintSourceCommandlineFlag + } + ] case res of - Right [ts'] -> ts' @?= ts + Right [ts'] -> + ts' + @?= ( WithConstraintSource + { constraintInner = ts + , constraintSource = ConstraintSourceCommandlineFlag + } + ) _ -> assertFailure $ "expected Right [Target...], " @@ -695,24 +863,31 @@ testTargetSelectorNoCurrentPackage = do localPackages Nothing targets = - [ "libs" - , ":cwd:libs" - , "flibs" - , ":cwd:flibs" - , "exes" - , ":cwd:exes" - , "tests" - , ":cwd:tests" - , "benchmarks" - , ":cwd:benchmarks" - ] + map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceCommandlineFlag + } + ) + [ "libs" + , ":cwd:libs" + , "flibs" + , ":cwd:flibs" + , "exes" + , ":cwd:exes" + , "tests" + , ":cwd:tests" + , "benchmarks" + , ":cwd:benchmarks" + ] Left errs <- readTargetSelectors' targets zipWithM_ (@?=) errs - [ TargetSelectorNoCurrentPackage ts + [ fmap TargetSelectorNoCurrentPackage ts | target <- targets - , let ts = fromMaybe (error $ "failed to parse target string " ++ target) $ parseTargetString target + , let ts = fromMaybe (error $ "failed to parse target string " ++ constraintInner target) $ parseTargetString target ] cleanProject testdir where @@ -723,7 +898,12 @@ testTargetSelectorNoTargets :: Assertion testTargetSelectorNoTargets = do (_, _, _, localPackages, _) <- configureProject testdir config Left errs <- readTargetSelectors localPackages Nothing [] - errs @?= [TargetSelectorNoTargetsInCwd True] + errs + @?= [ WithConstraintSource + { constraintInner = TargetSelectorNoTargetsInCwd True + , constraintSource = ConstraintSourceImplicit + } + ] cleanProject testdir where testdir = "targets/complex" @@ -733,7 +913,12 @@ testTargetSelectorProjectEmpty :: Assertion testTargetSelectorProjectEmpty = do (_, _, _, localPackages, _) <- configureProject testdir config Left errs <- readTargetSelectors localPackages Nothing [] - errs @?= [TargetSelectorNoTargetsInProject] + errs + @?= [ WithConstraintSource + { constraintInner = TargetSelectorNoTargetsInProject + , constraintSource = ConstraintSourceImplicit + } + ] cleanProject testdir where testdir = "targets/empty" @@ -755,7 +940,12 @@ testTargetSelectorCanonicalizedPath = do ( do let dirActions' = (dirActions symlink){TS.getCurrentDirectory = return virtcwd} Right ts <- readTargetSelectorsWith dirActions' localPackages Nothing [] - ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] + ts + @?= [ WithConstraintSource + { constraintInner = TargetPackage TargetImplicitCwd ["p-0.1"] Nothing + , constraintSource = ConstraintSourceImplicit + } + ] ) cleanProject testdir where @@ -849,10 +1039,10 @@ testTargetProblemsCommon config0 = do , projectConfigShared = (projectConfigShared config0) { projectConfigConstraints = - [ - ( UserConstraint (UserAnyQualifier "filepath") PackagePropertySource - , ConstraintSourceUnknown - ) + [ WithConstraintSource + { constraintInner = UserConstraint (UserAnyQualifier "filepath") PackagePropertySource + , constraintSource = ConstraintSourceUnknown + } ] } } @@ -1754,7 +1944,15 @@ assertProjectDistinctTargets selectComponentTarget elaboratedPlan Nothing - targetSelectors + ( map + ( \target -> + WithConstraintSource + { constraintInner = target + , constraintSource = ConstraintSourceUnknown + } + ) + targetSelectors + ) assertProjectTargetProblems :: forall err @@ -1804,10 +2002,23 @@ assertTargetProblems elaboratedPlan selectPackageTargets selectComponentTarget = selectComponentTarget elaboratedPlan Nothing - [targetSelector] + [ WithConstraintSource + { constraintInner = targetSelector + , constraintSource = ConstraintSourceUnknown + } + ] in case res of Left [problem] -> - problem @?= expected targetSelector + problem + @?= ( ( \problem' -> + WithConstraintSource + { constraintInner = problem' + , constraintSource = ConstraintSourceUnknown + } + ) + . expected + ) + targetSelector unexpected -> assertFailure $ "expected resolveTargets result: (Left [problem]) " @@ -1821,8 +2032,12 @@ testExceptionInFindingPackage config = do void $ planProject testdir config case locs of - [BadLocGlobEmptyMatch "./*.cabal"] -> return () - _ -> assertFailure "expected BadLocGlobEmptyMatch" + [ WithConstraintSource + { constraintInner = BadLocGlobEmptyMatch "./*.cabal" + , constraintSource = ConstraintSourceMainConfig "." + } + ] -> return () + _ -> assertFailure $ "expected BadLocGlobEmptyMatch, found " <> show locs cleanProject testdir where testdir = "exception/no-pkg" @@ -1834,7 +2049,11 @@ testExceptionInFindingPackage2 config = do void $ planProject testdir config case locs of - [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return () + [ WithConstraintSource + { constraintInner = BadPackageLocationFile (BadLocDirNoCabalFile ".") + , constraintSource = ConstraintSourceProjectConfig (ProjectConfigPath ("cabal.project" :| [])) + } + ] -> return () _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs cleanProject testdir where diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 4246617a6e0..534cb295b0b 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -1,5 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnitTests.Distribution.Client.ArbitraryInstances @@ -39,8 +41,11 @@ import Distribution.Client.Targets import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy) import Distribution.Client.Types.AllowNewer import Distribution.Client.Types.OverwritePolicy (OverwritePolicy) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..)) import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate) import Distribution.Solver.Types.PackageConstraint (PackageProperty (..)) +import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..)) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) import Data.Coerce (Coercible, coerce) import Network.URI (URI (..), URIAuth (..), isUnreserved) @@ -445,3 +450,36 @@ instance Arbitrary GlobPiece where globLiteralChars :: [Char] globLiteralChars = ['\0' .. '\128'] \\ "*{},/\\" + +------------------------------------------------------------------------------- +-- ConstraintSource +------------------------------------------------------------------------------- + +instance Arbitrary a => Arbitrary (NonEmpty a) where + arbitrary = do + xs' <- arbitrary @(NonEmptyList _) + case getNonEmpty xs' of + x : xs -> pure (x :| xs) + _ -> error "unreachable" + + -- No way to shrink a 1-element list. + shrink (_ :| []) = [] + shrink (x :| xs) = + let possibilities = shrink (NonEmpty (x : xs)) + in [ case getNonEmpty possibility of + x' : xs' -> x' :| xs' + _ -> error "unreachable" + | possibility <- possibilities + ] + +instance Arbitrary ProjectConfigPath where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary ConstraintSource where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary a => Arbitrary (WithConstraintSource a) where + arbitrary = genericArbitrary + shrink = genericShrink diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs index c14682c2bcb..c1e473d1357 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs @@ -14,6 +14,12 @@ import Distribution.Client.HttpUtils (HttpCode, HttpTransport (..)) import Distribution.Client.Types.PackageLocation (PackageLocation (..), ResolvedPkgLoc) import Distribution.Client.Types.Repo (Repo (..), emptyRemoteRepo) import Distribution.Client.Types.RepoName (RepoName (..)) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Types.PackageId (PackageIdentifier (..)) import Distribution.Types.PackageName (mkPackageName) import qualified Distribution.Verbosity as Verbosity @@ -61,18 +67,30 @@ testEmpty = do testPassLocalPackage :: Assertion testPassLocalPackage = do let repoCtxt = error "repoCtxt undefined" - loc = LocalUnpackedPackage "a" + loc = + WithConstraintSource + { constraintInner = LocalUnpackedPackage "a" + , constraintSource = ConstraintSourceUnknown + } res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap -> waitAsyncFetchPackage verbosity downloadMap loc - res @?= LocalUnpackedPackage "a" + res + @?= WithConstraintSource + { constraintInner = LocalUnpackedPackage "a" + , constraintSource = ConstraintSourceUnknown + } testHttp :: Assertion testHttp = withFakeRepoCtxt get200 $ \repoCtxt repo -> do let pkgId = mkPkgId "foo" - loc = RepoTarballPackage repo pkgId Nothing + loc = + WithConstraintSource + { constraintInner = RepoTarballPackage repo pkgId Nothing + , constraintSource = ConstraintSourceUnknown + } res <- asyncFetchPackages verbosity repoCtxt [loc] $ \downloadMap -> waitAsyncFetchPackage verbosity downloadMap loc - case res of + case constraintInner res of RepoTarballPackage repo' pkgId' _ -> do repo' @?= repo pkgId' @?= pkgId @@ -94,7 +112,11 @@ testGetException = testGetAny $ userError "some error" -- 3. third download keeps running testGetAny :: Exception e => e -> Assertion testGetAny exc = withFakeRepoCtxt get $ \repoCtxt repo -> do - let loc pkgId = RepoTarballPackage repo pkgId Nothing + let loc pkgId = + WithConstraintSource + { constraintInner = RepoTarballPackage repo pkgId Nothing + , constraintSource = ConstraintSourceUnknown + } pkgLocs = [loc throws, loc slowA, loc slowB] start <- getCurrentTime @@ -120,7 +142,11 @@ testGetAny exc = withFakeRepoCtxt get $ \repoCtxt repo -> do -- we still abort directly. testUncollectedInterrupt :: Assertion testUncollectedInterrupt = withFakeRepoCtxt get $ \repoCtxt repo -> do - let loc pkgId = RepoTarballPackage repo pkgId Nothing + let loc pkgId = + WithConstraintSource + { constraintInner = RepoTarballPackage repo pkgId Nothing + , constraintSource = ConstraintSourceUnknown + } pkgLocs = [loc throws, loc slowA, loc slowB] start <- getCurrentTime @@ -147,14 +173,18 @@ testUncollectedInterrupt = withFakeRepoCtxt get $ \repoCtxt repo -> do -- the download and handle its exception.) testUncollectedException :: Assertion testUncollectedException = withFakeRepoCtxt get $ \repoCtxt repo -> do - let loc pkgId = RepoTarballPackage repo pkgId Nothing + let loc pkgId = + WithConstraintSource + { constraintInner = RepoTarballPackage repo pkgId Nothing + , constraintSource = ConstraintSourceUnknown + } pkgLocs = [loc throws, loc foo] start <- getCurrentTime res <- asyncFetchPackages verbosity repoCtxt pkgLocs $ \downloadMap -> do waitAsyncFetchPackage verbosity downloadMap (loc foo) assertFaster start shortDelta - case res of + case constraintInner res of RepoTarballPackage repo' pkgId' _ -> do repo' @?= repo pkgId' @?= foo diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 1996dab1a1d..5da69680ea1 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -52,9 +52,11 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ProjectConfigPath import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.WithConstraintSource import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Legacy +import Distribution.Client.ProjectConfig.Types import UnitTests.Distribution.Client.ArbitraryInstances import UnitTests.Distribution.Client.TreeDiffInstances () @@ -305,10 +307,10 @@ prop_roundtrip_printparse_packages prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named = roundtrip_printparse mempty - { projectPackages = map getPackageLocationString pkglocstrs1 - , projectPackagesOptional = map getPackageLocationString pkglocstrs2 - , projectPackagesRepo = repos - , projectPackagesNamed = named + { projectPackages = map (withProjectConfigConstraintSource . getPackageLocationString) pkglocstrs1 + , projectPackagesOptional = map (withProjectConfigConstraintSource . getPackageLocationString) pkglocstrs2 + , projectPackagesRepo = map withProjectConfigConstraintSource repos + , projectPackagesNamed = map withProjectConfigConstraintSource named } prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Property @@ -344,7 +346,7 @@ hackProjectConfigShared config = , projectConfigConstraints = -- TODO: [required eventually] parse ambiguity in constraint -- "pkgname -any" as either any version or disabled flag "any". - let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) = + let ambiguous (WithConstraintSource{constraintInner = UserConstraint _ (PackagePropertyFlags flags)}) = (not . null) [ () | (name, False) <- unFlagAssignment flags, "any" `isPrefixOf` unFlagName name ] @@ -418,10 +420,10 @@ prop_roundtrip_printparse_RelaxDeps' rdep = instance Arbitrary ProjectConfig where arbitrary = ProjectConfig - <$> (map getPackageLocationString <$> arbitrary) - <*> (map getPackageLocationString <$> arbitrary) - <*> shortListOf 3 arbitrary - <*> arbitrary + <$> (map (fmap getPackageLocationString) <$> arbitraryWithConstraintSources) + <*> (map (fmap getPackageLocationString) <$> arbitraryWithConstraintSources) + <*> shortListOf 3 arbitraryWithConstraintSource + <*> arbitraryWithConstraintSources <*> arbitrary <*> arbitrary <*> arbitrary @@ -617,8 +619,8 @@ instance Arbitrary ProjectConfigShared where projectConfigActiveRepos <- arbitrary projectConfigIndexState <- arbitrary projectConfigStoreDir <- arbitraryFlag arbitraryShortToken - projectConfigConstraints <- arbitraryConstraints - projectConfigPreferences <- shortListOf 2 arbitrary + projectConfigConstraints <- arbitraryWithConstraintSources + projectConfigPreferences <- shortListOf 2 arbitraryWithConstraintSource projectConfigCabalVersion <- arbitrary projectConfigSolver <- arbitrary projectConfigAllowOlder <- arbitrary @@ -639,9 +641,6 @@ instance Arbitrary ProjectConfigShared where projectConfigMultiRepl <- arbitrary return ProjectConfigShared{..} where - arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] - arbitraryConstraints = - fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary fixInstallDirs x = x{InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty} shrink ProjectConfigShared{..} = @@ -684,12 +683,36 @@ instance Arbitrary ProjectConfigShared where <*> shrinker projectConfigProgPathExtra <*> shrinker projectConfigMultiRepl where - preShrink_Constraints = map fst - postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) + preShrink_Constraints = map constraintInner + postShrink_Constraints = + map + ( \uc -> + WithConstraintSource + { constraintInner = uc + , constraintSource = projectConfigConstraintSource + } + ) projectConfigConstraintSource :: ConstraintSource projectConfigConstraintSource = ConstraintSourceProjectConfig nullProjectConfigPath +withProjectConfigConstraintSource :: a -> WithConstraintSource a +withProjectConfigConstraintSource inner = + WithConstraintSource + { constraintInner = inner + , constraintSource = projectConfigConstraintSource + } + +-- | The constraint sources are not and cannot be displayed in the textual representation +-- of the project configuration, so we need to make sure they're replaced with a constant +-- for our round trip tests. +arbitraryWithConstraintSource :: Arbitrary a => Gen (WithConstraintSource a) +arbitraryWithConstraintSource = + withProjectConfigConstraintSource <$> arbitrary + +arbitraryWithConstraintSources :: Arbitrary a => Gen [WithConstraintSource a] +arbitraryWithConstraintSources = listOf arbitraryWithConstraintSource + instance Arbitrary ProjectConfigProvenance where arbitrary = elements [Implicit, Explicit (ProjectConfigPath $ "cabal.project" :| [])] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs index da9bd8ad90d..3d23b11dd0c 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs @@ -5,10 +5,12 @@ module UnitTests.Distribution.Client.TreeDiffInstances () where import Distribution.Solver.Types.ConstraintSource +import Distribution.Solver.Types.NamedPackage import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ProjectConfigPath import Distribution.Solver.Types.Settings +import Distribution.Solver.Types.WithConstraintSource import Distribution.Client.BuildReports.Types import Distribution.Client.CmdInstall.ClientInstallFlags @@ -30,6 +32,7 @@ import Network.URI instance (ToExpr k, ToExpr v) => ToExpr (MapMappend k v) instance (ToExpr k, ToExpr v) => ToExpr (MapLast k v) +instance ToExpr a => ToExpr (WithConstraintSource a) instance ToExpr (f FilePath) => ToExpr (SourceRepositoryPackage f) @@ -43,6 +46,7 @@ instance ToExpr ClientInstallFlags instance ToExpr CombineStrategy instance ToExpr ProjectConfigPath instance ToExpr ConstraintSource +instance ToExpr NamedPackage instance ToExpr CountConflicts instance ToExpr FineGrainedConflicts instance ToExpr IndependentGoals diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index d1d70f59348..ab77e5c1259 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -87,6 +87,7 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag import Distribution.Solver.Types.LabeledPackageConstraint +import Distribution.Solver.Types.NamedPackage import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex @@ -96,6 +97,7 @@ import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Variable +import Distribution.Solver.Types.WithConstraintSource {------------------------------------------------------------------------------- Example package database DSL @@ -432,7 +434,11 @@ exAvSrcPkg ex = package = SourcePackage { srcpkgPackageId = pkgId - , srcpkgSource = LocalTarballPackage "<>" + , srcpkgSource = + WithConstraintSource + { constraintInner = LocalTarballPackage "<>" + , constraintSource = ConstraintSourceUnknown + } , srcpkgDescrOverride = Nothing , srcpkgDescription = C.GenericPackageDescription @@ -849,7 +855,18 @@ exResolve ) (exDbPkgs db) | otherwise = [] - targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets + targets' = + fmap + ( \p -> + Named + ( WithConstraintSource + { constraintInner = + NamedPackage (C.mkPackageName p) [] + , constraintSource = ConstraintSourceUnknown + } + ) + ) + targets params = addConstraints (fmap toConstraint constraints) $ addConstraints (fmap toLpc enableTests) $ diff --git a/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out b/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out index 92f3698edc6..b67e162a62e 100644 --- a/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out +++ b/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackage/use-local-version-of-package.out @@ -19,7 +19,8 @@ Resolving dependencies... Error: [Cabal-7107] Could not resolve dependencies: [__0] next goal: pkg (user goal) -[__0] rejecting: pkg-2.0 (constraint from user target requires ==1.0) +[__0] rejecting: pkg-2.0 + (constraint from cabal.project requires ==1.0) [__0] rejecting: pkg-1.0 (constraint from command line flag requires ==2.0) [__0] fail (backjumping, conflict set: pkg) After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: pkg (3) diff --git a/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out b/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out index de46b91c396..29ed238fd53 100644 --- a/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out +++ b/cabal-testsuite/PackageTests/BuildTargets/UseLocalPackageForSetup/use-local-package-as-setup-dep.out @@ -9,7 +9,8 @@ Could not resolve dependencies: [__0] trying: pkg-1.0 (user goal) [__1] next goal: setup-dep (user goal) [__1] rejecting: setup-dep-2.0 (conflict: pkg => setup-dep>=1 && <2) -[__1] rejecting: setup-dep-1.0 (constraint from user target requires ==2.0) +[__1] rejecting: setup-dep-1.0 + (constraint from cabal.project requires ==2.0) [__1] fail (backjumping, conflict set: pkg, setup-dep) After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: setup-dep (3), pkg (2) # pkg my-exe diff --git a/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out b/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out index fd408a95505..abd524aa4c3 100644 --- a/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out +++ b/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out @@ -89,7 +89,13 @@ Configuration is affected by the following files: imported by: noncyclical-same-filename-b.project - same-filename/noncyclical-same-filename-b.config imported by: noncyclical-same-filename-b.project -Up to date +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - my-0.1 (lib:my) (configuration changed) +Configuring my-0.1... +Preprocessing library for my-0.1... +Building library for my-0.1... # checking that cyclical check catches a same file name that imports itself # cabal v2-build Error: [Cabal-7090] @@ -175,7 +181,13 @@ Configuration is affected by the following files: imported by: hops-2.config imported by: hops/hops-1.config imported by: hops-0.project -Up to date +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - my-0.1 (lib:my) (configuration changed) +Configuring my-0.1... +Preprocessing library for my-0.1... +Building library for my-0.1... # checking conflicting constraints skipping into a subfolder and then back out again and again # cabal v2-build Configuration is affected by the following files: @@ -378,7 +390,13 @@ Configuration is affected by the following files: imported by: yops-2.config imported by: yops/yops-1.config imported by: yops-0.project -Up to date +Resolving dependencies... +Build profile: -w ghc- -O1 +In order, the following will be built: + - my-0.1 (lib:my) (configuration changed) +Configuring my-0.1... +Preprocessing library for my-0.1... +Building library for my-0.1... # checking bad conditional # cabal v2-build Error: [Cabal-7090] diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/A.hs b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/A.hs new file mode 100644 index 00000000000..e0ba50b355f --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/A.hs @@ -0,0 +1,3 @@ +module A where + +str = "A" diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.out b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.out new file mode 100644 index 00000000000..10a874344bd --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.out @@ -0,0 +1,16 @@ +# cabal v2-update +Downloading the latest package list from test-local-repo +# cabal v2-build +Configuration is affected by the following files: +- cabal.project +Resolving dependencies... +Error: [Cabal-7107] +Could not resolve dependencies: +[__0] next goal: my-lib (user goal) +[__0] rejecting: my-lib; 2.0, 1.0 + (constraint from cabal.project requires ==0.9) +[__0] trying: my-lib-0.9 +[__1] next goal: plain (user goal) +[__1] rejecting: plain-0.1.0.0 (conflict: my-lib==0.9, plain => my-lib>1) +[__1] fail (backjumping, conflict set: my-lib, plain) +After searching the rest of the dependency tree exhaustively, these were the goals I've had most trouble fulfilling: my-lib (4), plain (2) diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.project b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.project new file mode 100644 index 00000000000..3e0a13dee7f --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.project @@ -0,0 +1,7 @@ +packages: . + +-- This is `my-lib` 0.9. +source-repository-package + type: git + location: https://github.com/9999years/cabal-testsuite-my-lib.git + tag: 9a0af0aa81325c71e744def11db06265840ffb5f diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.test.hs b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.test.hs new file mode 100644 index 00000000000..447f63f3977 --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/cabal.test.hs @@ -0,0 +1,5 @@ +import Test.Cabal.Prelude + +main = cabalTest $ withRepo "repo" $ do + output <- fails $ cabal' "v2-build" ["plain"] + assertOutputContains "(constraint from cabal.project requires ==0.9)" output diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/plain.cabal b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/plain.cabal new file mode 100644 index 00000000000..1290a8f04da --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/plain.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: plain +version: 0.1.0.0 +license: BSD-3-Clause +author: Rebecca Turner +build-type: Simple + +library + exposed-modules: A + build-depends: base, my-lib >1 + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/my-lib.cabal b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/my-lib.cabal new file mode 100644 index 00000000000..24dd0a44e65 --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/my-lib.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: my-lib +version: 1.0 +license: BSD-3-Clause +author: Rebecca Turner + +library + exposed-modules: MyLib + hs-source-dirs: src + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/src/MyLib.hs b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/src/MyLib.hs new file mode 100644 index 00000000000..1eca7fb8e6c --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-1.0/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib where + +myValue :: Int +myValue = 1 diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/my-lib.cabal b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/my-lib.cabal new file mode 100644 index 00000000000..586b90befa9 --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/my-lib.cabal @@ -0,0 +1,11 @@ +cabal-version: 3.0 +name: my-lib +version: 2.0 +license: BSD-3-Clause +author: Rebecca Turner + +library + exposed-modules: MyLib + hs-source-dirs: src + build-depends: base + default-language: Haskell2010 diff --git a/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/src/MyLib.hs b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/src/MyLib.hs new file mode 100644 index 00000000000..1eca7fb8e6c --- /dev/null +++ b/cabal-testsuite/PackageTests/ConstraintSource/SourceRepositoryPackage/repo/my-lib-2.0/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib where + +myValue :: Int +myValue = 1 diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-suite.out b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-suite.out new file mode 100644 index 00000000000..cf7d268fa44 --- /dev/null +++ b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-suite.out @@ -0,0 +1,5 @@ +# cabal v2-sdist +Configuration is affected by the following files: +- cabal.project +Error: [Cabal-7151] +It is not possible to package only the test suites from a package for distribution. Only entire packages may be packaged for distribution. diff --git a/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.test.hs b/cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-suite.test.hs similarity index 100% rename from cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-sute.test.hs rename to cabal-testsuite/PackageTests/NewSdist/MultiTarget/all-test-suite.test.hs diff --git a/changelog.d/pr-10524 b/changelog.d/pr-10524 new file mode 100644 index 00000000000..9ef34ec65ec --- /dev/null +++ b/changelog.d/pr-10524 @@ -0,0 +1,21 @@ +--- +synopsis: "Show constraint sources in dependency solver errors" +packages: [cabal-install, cabal-install-solver] +prs: 10524 +--- + +When solving dependencies fails, constraints will be labeled with their source. +For example, in this error message, a `source-repository-package` in +`cabal.project` has fixed the version of `memory` to `0.17.0`: + +``` +[__0] rejecting: memory-0.18.0 + (constraint from cabal.project requires ==0.17.0) +``` + +Previously, these error messages would just specify that the constraint came +from a "user target", which was unclear and misleading: + +``` +[__0] rejecting: memory-0.18.0 (constraint from user target requires ==0.17.0) +``` From 3f9b654a5acf8336813c219f24db10c8b48157a8 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 6 Dec 2024 13:24:25 -0800 Subject: [PATCH 2/8] ConstraintSourceImplicit -> ConstraintSourceImplicitTarget --- .../src/Distribution/Solver/Types/ConstraintSource.hs | 7 ++++--- .../src/Distribution/Client/CmdHaddockProject.hs | 2 +- cabal-install/src/Distribution/Client/CmdInstall.hs | 2 +- cabal-install/src/Distribution/Client/ScriptUtils.hs | 2 +- cabal-install/src/Distribution/Client/TargetSelector.hs | 6 +++--- cabal-install/tests/IntegrationTests2.hs | 8 ++++---- 6 files changed, 14 insertions(+), 13 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index 01082be62cd..ae2a5bb2a5f 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -57,8 +57,9 @@ data ConstraintSource = -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion - -- | An implicit constraint added by Cabal. - | ConstraintSourceImplicit + -- | An implicit constraint added by Cabal, for example if no targets are + -- listed on the command line. + | ConstraintSourceImplicitTarget deriving (Show, Eq, Ord, Generic, Typeable) instance Binary ConstraintSource @@ -91,5 +92,5 @@ instance Pretty ConstraintSource where text "minimum version of Cabal used by Setup.hs" ConstraintSetupCabalMaxVersion -> text "maximum version of Cabal used by Setup.hs" - ConstraintSourceImplicit -> + ConstraintSourceImplicitTarget -> text "implicit target" diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs index fc9fc1b4ec5..88aceed0457 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs @@ -133,7 +133,7 @@ haddockProjectAction flags _extraArgs globalFlags = do RejectNoTargets Nothing (commandDefaultFlags CmdBuild.buildCommand) - [WithConstraintSource{constraintInner = "all", constraintSource = ConstraintSourceImplicit}] + [WithConstraintSource{constraintInner = "all", constraintSource = ConstraintSourceImplicitTarget}] 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 b60a4ba7350..ca288c76bbd 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -374,7 +374,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project then [ WithConstraintSource { constraintInner = "." - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] else diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index e767c1cab64..756d4e58a37 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -356,7 +356,7 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo defaultTarget = [ WithConstraintSource { constraintInner = TargetPackage TargetExplicitNamed [fakePackageId] Nothing - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 2b0e63412f4..9d92b45d658 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -555,7 +555,7 @@ resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = ( [ WithConstraintSource { constraintInner = TargetSelectorNoTargetsInProject - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] , [] @@ -565,7 +565,7 @@ resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf = ( [ WithConstraintSource { constraintInner = TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] , [] @@ -575,7 +575,7 @@ resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = , [ WithConstraintSource { constraintInner = TargetPackage TargetImplicitCwd pkgids Nothing - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] ) diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index d9faf49bb2f..d2d31fc3dc6 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -200,7 +200,7 @@ testTargetSelectors reportSubCase = do ts @?= [ WithConstraintSource { constraintInner = TargetPackage TargetImplicitCwd ["p-0.1"] Nothing - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] @@ -901,7 +901,7 @@ testTargetSelectorNoTargets = do errs @?= [ WithConstraintSource { constraintInner = TargetSelectorNoTargetsInCwd True - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] cleanProject testdir @@ -916,7 +916,7 @@ testTargetSelectorProjectEmpty = do errs @?= [ WithConstraintSource { constraintInner = TargetSelectorNoTargetsInProject - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] cleanProject testdir @@ -943,7 +943,7 @@ testTargetSelectorCanonicalizedPath = do ts @?= [ WithConstraintSource { constraintInner = TargetPackage TargetImplicitCwd ["p-0.1"] Nothing - , constraintSource = ConstraintSourceImplicit + , constraintSource = ConstraintSourceImplicitTarget } ] ) From 3b626691770dea18ec9e43aaa119908d537558c6 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 6 Dec 2024 13:27:22 -0800 Subject: [PATCH 3/8] Remove Typeable instances --- .../src/Distribution/Solver/Types/ConstraintSource.hs | 2 +- .../src/Distribution/Solver/Types/NamedPackage.hs | 2 +- .../src/Distribution/Solver/Types/WithConstraintSource.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index ae2a5bb2a5f..43236f8563b 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -60,7 +60,7 @@ data ConstraintSource = -- | An implicit constraint added by Cabal, for example if no targets are -- listed on the command line. | ConstraintSourceImplicitTarget - deriving (Show, Eq, Ord, Generic, Typeable) + deriving (Show, Eq, Ord, Generic) instance Binary ConstraintSource instance Structured ConstraintSource diff --git a/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs index e76cee7c4b0..a213b9052a5 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs @@ -18,7 +18,7 @@ import Text.PrettyPrint -- | A package, identified by a name and properties. data NamedPackage = NamedPackage PackageName [PackageProperty] - deriving (Show, Eq, Ord, Generic, Typeable) + deriving (Show, Eq, Ord, Generic) instance Binary NamedPackage instance Structured NamedPackage diff --git a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs index ba0052a68cc..365bb40e492 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs @@ -24,7 +24,7 @@ data WithConstraintSource pkg = , constraintSource :: ConstraintSource -- ^ The constraint source for the package. } - deriving (Show, Functor, Eq, Ord, Traversable, Foldable, Generic, Typeable) + deriving (Show, Functor, Eq, Ord, Traversable, Foldable, Generic) instance Binary pkg => Binary (WithConstraintSource pkg) instance Structured pkg => Structured (WithConstraintSource pkg) From dff36076f5f0b19ad5a1119cc47186333a62c4c9 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 6 Dec 2024 13:35:56 -0800 Subject: [PATCH 4/8] ConstraintSourceCommandlineFlag -> ConstraintSourceUserTarget --- cabal-install/src/Distribution/Client/CmdBench.hs | 2 +- cabal-install/src/Distribution/Client/CmdBuild.hs | 2 +- cabal-install/src/Distribution/Client/CmdHaddock.hs | 2 +- cabal-install/src/Distribution/Client/CmdInstall.hs | 2 +- cabal-install/src/Distribution/Client/CmdListBin.hs | 2 +- cabal-install/src/Distribution/Client/CmdRepl.hs | 2 +- cabal-install/src/Distribution/Client/CmdRun.hs | 2 +- cabal-install/src/Distribution/Client/CmdSdist.hs | 2 +- cabal-install/src/Distribution/Client/CmdTest.hs | 4 ++-- 9 files changed, 10 insertions(+), 10 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs index 79e8e146774..3126e17da17 100644 --- a/cabal-install/src/Distribution/Client/CmdBench.hs +++ b/cabal-install/src/Distribution/Client/CmdBench.hs @@ -125,7 +125,7 @@ benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) - (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceCommandlineFlag}) targetStrings) + (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceUserTarget}) targetStrings) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index 7790c53a999..1e79514d6eb 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -197,7 +197,7 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globa ( \target -> WithConstraintSource { constraintInner = target - , constraintSource = ConstraintSourceCommandlineFlag + , constraintSource = ConstraintSourceUserTarget } ) targetStrings diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index 7acd9df7443..cdb5e59b3ff 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -174,7 +174,7 @@ haddockAction relFlags targetStrings globalFlags = do =<< readTargetSelectors (localPackages baseCtx) Nothing - (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceCommandlineFlag}) targetStrings) + (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceUserTarget}) targetStrings) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index ca288c76bbd..13d156b752f 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -382,7 +382,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project ( \target -> WithConstraintSource { constraintInner = target - , constraintSource = ConstraintSourceCommandlineFlag + , constraintSource = ConstraintSourceUserTarget } ) targetStrings diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index e86fbc293c3..67b1714e917 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -98,7 +98,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do let targetProvenance = WithConstraintSource { constraintInner = target - , constraintSource = ConstraintSourceCommandlineFlag + , constraintSource = ConstraintSourceUserTarget } -- configure and elaborate target selectors diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 05401df30eb..372468c2453 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -293,7 +293,7 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g (Just LibKind) flags ( map - (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceCommandlineFlag}) + (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceUserTarget}) targetStrings ) globalFlags diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index ed6d6ca2385..f49a3e12ac7 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -213,7 +213,7 @@ runAction flags@NixStyleFlags{..} targetAndArgs globalFlags = (Just ExeKind) flags ( map - (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceCommandlineFlag}) + (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceUserTarget}) targetStr ) globalFlags diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index 1d0fd90a676..c097132bed3 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -243,7 +243,7 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do localPkgs Nothing ( map - (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceCommandlineFlag}) + (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceUserTarget}) targetStrings ) diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index d59f78168f3..1948de8a7a6 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -67,7 +67,7 @@ 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.ConstraintSource (ConstraintSource (ConstraintSourceUserTarget)) import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) import GHC.Environment ( getFullArgs @@ -132,7 +132,7 @@ testAction flags@NixStyleFlags{..} targetStrings globalFlags = do ( \target -> WithConstraintSource { constraintInner = target - , constraintSource = ConstraintSourceCommandlineFlag + , constraintSource = ConstraintSourceUserTarget } ) targetStrings From b1c7f1bd723b34af02071fc8f8064d1835b5dd61 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 6 Dec 2024 13:59:17 -0800 Subject: [PATCH 5/8] Remove `ConstraintSource`s from preferences From @grayjay: > The dependency solver currently doesn't describe preferences in error > messages, so I think that it would take a lot more work to make this > useful. --- cabal-install/src/Distribution/Client/Configure.hs | 6 +++--- cabal-install/src/Distribution/Client/Install.hs | 2 +- .../src/Distribution/Client/ProjectConfig/Legacy.hs | 6 ++---- .../src/Distribution/Client/ProjectConfig/Types.hs | 4 ++-- cabal-install/src/Distribution/Client/ProjectPlanning.hs | 2 +- .../src/Distribution/Client/Sandbox/PackageEnvironment.hs | 4 +--- cabal-install/src/Distribution/Client/Setup.hs | 8 +++----- .../tests/UnitTests/Distribution/Client/ProjectConfig.hs | 2 +- 8 files changed, 14 insertions(+), 20 deletions(-) diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs index 326ea5e802b..1538457b7f2 100644 --- a/cabal-install/src/Distribution/Client/Configure.hs +++ b/cabal-install/src/Distribution/Client/Configure.hs @@ -377,13 +377,13 @@ checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do for_ (safeHead unknownPreferences) $ \h -> warn verbosity $ "Preference refers to an unknown package: " - ++ showWithConstraintSource prettyShow h + ++ prettyShow h where unknownConstraints = filter (unknown . userConstraintPackageName . constraintInner) $ configExConstraints flags unknownPreferences = - filter (unknown . (\(PackageVersionConstraint name _) -> name) . constraintInner) $ + filter (unknown . (\(PackageVersionConstraint name _) -> name)) $ configPreferences flags unknown pkg = null (PackageIndex.lookupPackageName installedPkgIndex pkg) @@ -443,7 +443,7 @@ planLocalPackage . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- map constraintInner $ configPreferences configExFlags + | PackageVersionConstraint name ver <- configPreferences configExFlags ] . addConstraints -- version constraints from the config file or command line diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index 7fd751d6014..206a15320fc 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -624,7 +624,7 @@ planPackages . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- map constraintInner $ configPreferences configExFlags + | PackageVersionConstraint name ver <- configPreferences configExFlags ] . addConstraints -- version constraints from the config file or command line diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 5a75f9f9931..60166ca9c32 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -1430,10 +1430,8 @@ legacySharedConfigFieldDescrs constraintSrc = (\v conf -> conf{configExConstraints = v}) , commaNewLineListFieldParsec "preferences" - (pretty . constraintInner) - ( (\preference -> WithConstraintSource{constraintInner = preference, constraintSource = constraintSrc}) - `fmap` parsec - ) + pretty + parsec configPreferences (\v conf -> conf{configPreferences = v}) , monoidFieldParsec diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs index 066b390239d..847659ddc33 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs @@ -208,7 +208,7 @@ data ProjectConfigShared = ProjectConfigShared , projectConfigStoreDir :: Flag FilePath , -- solver configuration projectConfigConstraints :: [WithConstraintSource UserConstraint] - , projectConfigPreferences :: [WithConstraintSource PackageVersionConstraint] + , projectConfigPreferences :: [PackageVersionConstraint] , projectConfigCabalVersion :: Flag Version -- TODO: [required eventually] unused , projectConfigSolver :: Flag PreSolver , projectConfigAllowOlder :: Maybe AllowOlder @@ -411,7 +411,7 @@ data SolverSettings = SolverSettings -- ^ Available Hackage servers. , solverSettingLocalNoIndexRepos :: [LocalRepo] , solverSettingConstraints :: [WithConstraintSource UserConstraint] - , solverSettingPreferences :: [WithConstraintSource PackageVersionConstraint] + , solverSettingPreferences :: [PackageVersionConstraint] , solverSettingFlagAssignment :: FlagAssignment -- ^ For all local packages , solverSettingFlagAssignments :: Map PackageName FlagAssignment diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index edf1416b781..ac17eadf090 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1298,7 +1298,7 @@ planPackages . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- map constraintInner solverSettingPreferences + | PackageVersionConstraint name ver <- solverSettingPreferences ] . addConstraints -- version constraints from the config file or command line diff --git a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs index b3bdde5704a..b33da2142f9 100644 --- a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs +++ b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs @@ -194,9 +194,7 @@ pkgEnvFieldDescrs src = , commaListFieldParsec "preferences" pretty - ( (\preference -> WithConstraintSource{constraintInner = preference, constraintSource = src}) - `fmap` parsec - ) + parsec (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig) ( \v pkgEnv -> updateConfigureExFlags diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index 5008c49a372..d208bf9b571 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -914,7 +914,7 @@ data ConfigExFlags = ConfigExFlags , configAppend :: Flag Bool , configBackup :: Flag Bool , configExConstraints :: [WithConstraintSource UserConstraint] - , configPreferences :: [WithConstraintSource PackageVersionConstraint] + , configPreferences :: [PackageVersionConstraint] , configSolver :: Flag PreSolver , configAllowNewer :: Maybe AllowNewer , configAllowOlder :: Maybe AllowOlder @@ -1007,11 +1007,9 @@ configureExOptions _showOrParseArgs constraint = "CONSTRAINT" ( parsecToReadE (const "dependency expected") - ( (\pkg -> [WithConstraintSource{constraintInner = pkg, constraintSource = constraint}]) - `fmap` parsec - ) + (fmap (\x -> [x]) parsec) ) - (map $ showWithConstraintSource prettyShow) + (map prettyShow) ) , optionSolver configSolver (\v flags -> flags{configSolver = v}) , option diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 5da69680ea1..95ed974fbdc 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -620,7 +620,7 @@ instance Arbitrary ProjectConfigShared where projectConfigIndexState <- arbitrary projectConfigStoreDir <- arbitraryFlag arbitraryShortToken projectConfigConstraints <- arbitraryWithConstraintSources - projectConfigPreferences <- shortListOf 2 arbitraryWithConstraintSource + projectConfigPreferences <- shortListOf 2 arbitrary projectConfigCabalVersion <- arbitrary projectConfigSolver <- arbitrary projectConfigAllowOlder <- arbitrary From 524ba6da1425d620f2cda1f834a5d264961ff68b Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 6 Dec 2024 14:53:37 -0800 Subject: [PATCH 6/8] Prevent rebuilds when the project file changes ...provided that nothing else changes. --- .../Client/ProjectPlanning/Types.hs | 13 +++++++++++- .../ConditionalAndImport/cabal.out | 21 +++---------------- 2 files changed, 15 insertions(+), 19 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs index fd4f7451b6c..1faaa3f1e50 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs @@ -109,6 +109,9 @@ import Distribution.Simple.Setup import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.ComponentDeps as CD +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.WithConstraintSource ( WithConstraintSource (..) @@ -347,7 +350,15 @@ normaliseConfiguredPackage -> ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = - pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)} + pkg + { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) + , -- Wipe the constraint source so that if (e.g.) a project file changes we + -- don't necessarily force a rebuild if nothing else changes. + elabPkgSourceLocation = + (elabPkgSourceLocation pkg) + { constraintSource = ConstraintSourceUnknown + } + } where knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs diff --git a/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out b/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out index abd524aa4c3..cfb91b4afdc 100644 --- a/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out +++ b/cabal-testsuite/PackageTests/ConditionalAndImport/cabal.out @@ -90,12 +90,7 @@ Configuration is affected by the following files: - same-filename/noncyclical-same-filename-b.config imported by: noncyclical-same-filename-b.project Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - my-0.1 (lib:my) (configuration changed) -Configuring my-0.1... -Preprocessing library for my-0.1... -Building library for my-0.1... +Up to date # checking that cyclical check catches a same file name that imports itself # cabal v2-build Error: [Cabal-7090] @@ -182,12 +177,7 @@ Configuration is affected by the following files: imported by: hops/hops-1.config imported by: hops-0.project Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - my-0.1 (lib:my) (configuration changed) -Configuring my-0.1... -Preprocessing library for my-0.1... -Building library for my-0.1... +Up to date # checking conflicting constraints skipping into a subfolder and then back out again and again # cabal v2-build Configuration is affected by the following files: @@ -391,12 +381,7 @@ Configuration is affected by the following files: imported by: yops/yops-1.config imported by: yops-0.project Resolving dependencies... -Build profile: -w ghc- -O1 -In order, the following will be built: - - my-0.1 (lib:my) (configuration changed) -Configuring my-0.1... -Preprocessing library for my-0.1... -Building library for my-0.1... +Up to date # checking bad conditional # cabal v2-build Error: [Cabal-7090] From 35025e56cf5b1d86517ad22b44f9001e56234e3c Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 20 Dec 2024 14:48:09 -0800 Subject: [PATCH 7/8] Fix DedupUsingConfigFromComplex test --- .../src/Distribution/Client/ProjectConfig.hs | 97 ++++++++++--------- .../DedupUsingConfigFromComplex/cabal.out | 2 - .../DedupUsingConfigFromComplex/cabal.test.hs | 11 ++- 3 files changed, 58 insertions(+), 52 deletions(-) diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs index a7d9c081aec..1c259e1e566 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs @@ -65,7 +65,6 @@ module Distribution.Client.ProjectConfig ) where import Distribution.Client.Compat.Prelude -import Text.PrettyPrint (nest, render, text, vcat) import Prelude () import Distribution.Client.Glob @@ -223,6 +222,7 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set +import Text.PrettyPrint (Doc, hang, nest, text, vcat, ($$)) import Network.URI ( URI (..) @@ -924,10 +924,41 @@ data BadPackageLocations deriving (Show, Typeable) instance Exception BadPackageLocations where - displayException = renderBadPackageLocations + displayException = prettyShow -- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc +instance Pretty BadPackageLocations where + pretty (BadPackageLocations provenance bpls) + -- There is no provenance information, + -- render standard bad package error information. + | Set.null provenance = renderErrors renderBadPackageLocation + -- The configuration is implicit, render bad package locations + -- using possibly specialized error messages. + | Set.singleton Implicit == provenance = + renderErrors renderImplicitBadPackageLocation + -- The configuration contains both implicit and explicit provenance. + -- This should not occur, and a message is output to assist debugging. + | Implicit `Set.member` provenance = + text "Warning: both implicit and explicit configuration is present." + $$ renderExplicit + -- The configuration was read from one or more explicit path(s), + -- list the locations and render the bad package error information. + -- The intent is to supersede this with the relevant location information + -- per package error. + | otherwise = renderExplicit + where + renderErrors f = vcat (map f bpls) + + renderExplicit = + text "When using configuration from:" + $$ nest 2 (docProjectConfigFiles $ mapMaybe getExplicit $ Set.toList provenance) + $$ text "The following errors occurred:" + $$ nest 2 (vcat $ map (hang (text "-") 2 . renderBadPackageLocation) bpls) + + getExplicit (Explicit path) = Just path + getExplicit Implicit = Nothing + data BadPackageLocation = BadPackageLocationFile BadPackageLocationMatch | BadLocGlobEmptyMatch String @@ -944,37 +975,6 @@ data BadPackageLocationMatch | BadLocDirManyCabalFiles String deriving (Show) -renderBadPackageLocations :: BadPackageLocations -> String -renderBadPackageLocations (BadPackageLocations provenance bpls) - -- There is no provenance information, - -- render standard bad package error information. - | Set.null provenance = renderErrors renderBadPackageLocation - -- The configuration is implicit, render bad package locations - -- using possibly specialized error messages. - | Set.singleton Implicit == provenance = - renderErrors renderImplicitBadPackageLocation - -- The configuration contains both implicit and explicit provenance. - -- This should not occur, and a message is output to assist debugging. - | Implicit `Set.member` provenance = - "Warning: both implicit and explicit configuration is present." - ++ renderExplicit - -- The configuration was read from one or more explicit path(s), - -- list the locations and render the bad package error information. - -- The intent is to supersede this with the relevant location information - -- per package error. - | otherwise = renderExplicit - where - renderErrors f = unlines (map f bpls) - - renderExplicit = - "When using configuration from:\n" - ++ render (nest 2 . docProjectConfigFiles $ mapMaybe getExplicit (Set.toList provenance)) - ++ "\nThe following errors occurred:\n" - ++ render (nest 2 $ vcat ((text "-" <+>) . text <$> map renderBadPackageLocation bpls)) - - getExplicit (Explicit path) = Just path - getExplicit Implicit = Nothing - -- TODO: [nice to have] keep track of the config file (and src loc) packages -- were listed, to use in error messages @@ -985,7 +985,7 @@ 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 :: WithConstraintSource BadPackageLocation -> String +renderImplicitBadPackageLocation :: WithConstraintSource BadPackageLocation -> Doc renderImplicitBadPackageLocation ( WithConstraintSource { constraintInner = bpl @@ -993,30 +993,31 @@ renderImplicitBadPackageLocation } ) = inner - ++ "\nFrom " - ++ showConstraintSource constraint + $$ text "From" + <+> pretty 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 + text $ + "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." + _ -> text $ renderBadPackageLocationInner bpl + +renderBadPackageLocation :: WithConstraintSource BadPackageLocation -> Doc renderBadPackageLocation ( WithConstraintSource { constraintInner = bpl , constraintSource = constraint } ) = - renderBadPackageLocationInner bpl - ++ "\nFrom " - ++ showConstraintSource constraint + text (renderBadPackageLocationInner bpl) + $$ text "From" + <+> pretty constraint renderBadPackageLocationInner :: BadPackageLocation -> String renderBadPackageLocationInner bpl = case bpl of diff --git a/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.out b/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.out index 437612a2eca..92fd8204a40 100644 --- a/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.out +++ b/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.out @@ -1,3 +1 @@ -# checking "using config from message" with URI imports # cabal v2-build -# checking that package directories and locations are reported in order diff --git a/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.test.hs b/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.test.hs index e354b356d7f..f74878371fb 100644 --- a/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.test.hs +++ b/cabal-testsuite/PackageTests/ProjectImport/DedupUsingConfigFromComplex/cabal.test.hs @@ -1,11 +1,14 @@ import Test.Cabal.Prelude -main = cabalTest . recordMode RecordMarked $ do +main = cabalTest $ do let log = recordHeader . pure log "checking \"using config from message\" with URI imports" out <- fails $ cabal' "v2-build" [ "all", "--dry-run", "--project-file=no-pkgs.project" ] + -- TODO: Make `BadPackageLocations` a `CabalInstallException` so that we can + -- use the normal output recording here. + -- Use assertRegex when the output is tainted by the temp directory, like -- this: -- @@ -34,9 +37,13 @@ main = cabalTest . recordMode RecordMarked $ do assertOutputContains "The following errors occurred: \ \ - The package directory 'no-pkg-1' does not contain any .cabal file. \ + \ From project config no-pkgs.project \ \ - The package location 'no-pkg-2-dir' does not exist. \ + \ From project config no-pkgs.project \ \ - The package directory 'no-pkg-3' does not contain any .cabal file. \ - \ - The package location 'no-pkg-4-dir' does not exist." + \ From project config no-pkgs.project \ + \ - The package location 'no-pkg-4-dir' does not exist. \ + \ From project config no-pkgs.project" out return () From 611d65c4732d0d85a8c8abc36e5b11fb7dc750f4 Mon Sep 17 00:00:00 2001 From: Rebecca Turner Date: Fri, 20 Dec 2024 16:19:35 -0800 Subject: [PATCH 8/8] Fix HLint nits --- .../src/Distribution/Solver/Types/NamedPackage.hs | 2 -- .../src/Distribution/Solver/Types/WithConstraintSource.hs | 2 -- cabal-install/src/Distribution/Client/ScriptUtils.hs | 1 - cabal-install/src/Distribution/Client/Setup.hs | 1 - .../tests/UnitTests/Distribution/Client/ArbitraryInstances.hs | 1 - 5 files changed, 7 deletions(-) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs index a213b9052a5..440e61c9038 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/NamedPackage.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Types.NamedPackage ( NamedPackage (..) diff --git a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs index 365bb40e492..5da8f2110d9 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE NamedFieldPuns #-} diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index 756d4e58a37..68e9292d4e6 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index d208bf9b571..0bf981e7550 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs index 534cb295b0b..8dcdb5c8cdf 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module UnitTests.Distribution.Client.ArbitraryInstances