diff --git a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs index d0f13bef006..01082be62cd 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/ConstraintSource.hs @@ -6,7 +6,8 @@ module Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Compat.Prelude import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath) -import Text.PrettyPrint (render) +import Distribution.Pretty (Pretty(pretty), prettyShow) +import Text.PrettyPrint (text) -- | Source of a 'PackageConstraint'. data ConstraintSource = @@ -55,6 +56,9 @@ data ConstraintSource = -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion + + -- | An implicit constraint added by Cabal. + | ConstraintSourceImplicit deriving (Show, Eq, Ord, Generic, Typeable) instance Binary ConstraintSource @@ -62,24 +66,30 @@ instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String -showConstraintSource (ConstraintSourceMainConfig path) = - "main config " ++ path -showConstraintSource (ConstraintSourceProjectConfig path) = - "project config " ++ render (docProjectConfigPath path) -showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path -showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" -showConstraintSource ConstraintSourceUserTarget = "user target" -showConstraintSource ConstraintSourceNonReinstallablePackage = - "non-reinstallable package" -showConstraintSource ConstraintSourceFreeze = "cabal freeze" -showConstraintSource ConstraintSourceConfigFlagOrTarget = - "config file, command line flag, or user target" -showConstraintSource ConstraintSourceMultiRepl = - "--enable-multi-repl" -showConstraintSource ConstraintSourceProfiledDynamic = - "--enable-profiling-shared" -showConstraintSource ConstraintSourceUnknown = "unknown source" -showConstraintSource ConstraintSetupCabalMinVersion = - "minimum version of Cabal used by Setup.hs" -showConstraintSource ConstraintSetupCabalMaxVersion = - "maximum version of Cabal used by Setup.hs" +showConstraintSource = prettyShow + +instance Pretty ConstraintSource where + pretty constraintSource = case constraintSource of + (ConstraintSourceMainConfig path) -> + text "main config" <+> text path + (ConstraintSourceProjectConfig path) -> + text "project config" <+> docProjectConfigPath path + (ConstraintSourceUserConfig path)-> text "user config " <+> text path + ConstraintSourceCommandlineFlag -> text "command line flag" + ConstraintSourceUserTarget -> text "user target" + ConstraintSourceNonReinstallablePackage -> + text "non-reinstallable package" + ConstraintSourceFreeze -> text "cabal freeze" + ConstraintSourceConfigFlagOrTarget -> + text "config file, command line flag, or user target" + ConstraintSourceMultiRepl -> + text "--enable-multi-repl" + ConstraintSourceProfiledDynamic -> + text "--enable-profiling-shared" + ConstraintSourceUnknown -> text "unknown source" + ConstraintSetupCabalMinVersion -> + text "minimum version of Cabal used by Setup.hs" + ConstraintSetupCabalMaxVersion -> + text "maximum version of Cabal used by Setup.hs" + ConstraintSourceImplicit -> + text "implicit target" diff --git a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs index e51d310c7aa..026d6c2589d 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} module Distribution.Solver.Types.WithConstraintSource ( WithConstraintSource (..) diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index d496e1c09d9..73bb412d16f 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -104,7 +104,6 @@ import Distribution.Client.Setup ) import Distribution.Client.Types ( PackageLocation (..) - , PackageLocationProvenance (..) , PackageSpecifier (..) , SourcePackageDb (..) , UnresolvedSourcePackage @@ -176,6 +175,9 @@ import Distribution.Simple.Utils , withTempDirectory , wrapText ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) import Distribution.Solver.Types.PackageConstraint ( PackageProperty (..) ) @@ -186,6 +188,9 @@ import Distribution.Solver.Types.PackageIndex import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.System ( OS (Windows) , Platform @@ -360,7 +365,23 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project let installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags) - normalisedTargetStrings = if null targetStrings then ["."] else targetStrings + normalisedTargetStrings = + if null targetStrings + then + [ WithConstraintSource + { constraintPackage = "." + , constraintConstraint = ConstraintSourceImplicit + } + ] + else + map + ( \target -> + WithConstraintSource + { constraintPackage = target + , constraintConstraint = ConstraintSourceCommandlineFlag + } + ) + targetStrings -- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris. -- However, we want install to also take uri arguments. Hence, we only parse uri arguments in the case where @@ -470,7 +491,7 @@ installAction flags@NixStyleFlags{extraFlags, configFlags, installFlags, project distDirLayout (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 +584,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 @@ -598,19 +619,28 @@ withProject verbosity cliConfig targetStrings installLibs = do -- The ones who don't parse will have to be resolved in the project context. (unresolvedTargetStrings, parsedPackageIds) = partitionEithers $ - flip map targetStrings $ \s -> - case eitherParsec s of + flip map targetStrings $ \target -> + case eitherParsec $ constraintPackage target of Right pkgId@PackageIdentifier{pkgVersion} | pkgVersion /= nullVersion -> - pure pkgId - _ -> Left s + pure $ target{constraintPackage = pkgId} + _ -> Left target -- For each packageId, we output a NamedPackage specifier (i.e. a package only known by -- its name) and a target selector. (parsedPkgSpecs, parsedTargets) = unzip - [ (mkNamedPackage pkgId, TargetPackageNamed (pkgName pkgId) targetFilter) - | pkgId <- parsedPackageIds + [ ( mkNamedPackage src pkgId + , withConstraint + { constraintPackage = + TargetPackageNamed (pkgName pkgId) targetFilter + } + ) + | withConstraint@WithConstraintSource + { constraintPackage = pkgId + , constraintConstraint = src + } <- + parsedPackageIds ] targetFilter = if installLibs then Just LibKind else Just ExeKind @@ -618,9 +648,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 @@ -648,10 +678,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 @@ -776,7 +816,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector spkg { srcpkgSource = (srcpkgSource spkg) - { packageLocation = LocalTarballPackage sdistPath + { constraintPackage = LocalTarballPackage sdistPath } } sdistize named = named @@ -807,7 +847,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, diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index e381b291d7d..0877454a1c7 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -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 @@ -538,11 +541,13 @@ replAction flags@NixStyleFlags{extraFlags = r@ReplFlags{..}, ..} targetStrings g -- but that would require another solver run for marginal advantages that -- will further shrink as 3.11 is adopted. multiReplCabalConstraint = - ( UserConstraint - (UserAnySetupQualifier (mkPackageName "Cabal")) - (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11]) - , ConstraintSourceMultiRepl - ) + WithConstraintSource + { constraintPackage = + UserConstraint + (UserAnySetupQualifier (mkPackageName "Cabal")) + (PackagePropertyVersion $ orLaterVersion $ mkVersion [3, 11]) + , constraintConstraint = ConstraintSourceMultiRepl + } -- | First version of GHC which supports multiple home packages minMultipleHomeUnitsVersion :: Version @@ -866,6 +871,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/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index 9b2cd0ff366..dfa6ab71e19 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -60,13 +60,15 @@ import Distribution.Client.TargetSelector ) import Distribution.Client.Types ( PackageLocation (..) - , PackageLocationProvenance (..) , PackageSpecifier (..) , UnresolvedSourcePackage ) import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) +import Distribution.Solver.Types.WithConstraintSource + ( WithConstraintSource (..) + ) import Distribution.Utils.Path hiding ( (<.>) , () @@ -324,7 +326,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 packageLocation $ srcpkgSource pkg of + dir0 <- case constraintPackage $ srcpkgSource pkg of LocalUnpackedPackage path -> pure (Right path) RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz) RemoteSourceRepoPackage{} -> death diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index 7c1adffdc91..7c1465da6ce 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -67,9 +67,12 @@ import qualified System.Exit (exitSuccess) import Distribution.Client.Errors import Distribution.Client.Setup (CommonSetupFlags (..)) +import Distribution.Solver.Types.ConstraintSource (ConstraintSource (ConstraintSourceCommandlineFlag)) +import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource (..)) import GHC.Environment ( getFullArgs ) +import qualified Text.PrettyPrint as PP testCommand :: CommandUI (NixStyleFlags ()) testCommand = @@ -124,11 +127,21 @@ testCommand = -- "Distribution.Client.ProjectOrchestration" testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO () testAction flags@NixStyleFlags{..} targetStrings globalFlags = do + let targetStrings' = + map + ( \target -> + WithConstraintSource + { constraintPackage = target + , constraintConstraint = ConstraintSourceCommandlineFlag + } + ) + targetStrings + baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- - either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + either (reportTargetSelectorProblems verbosity . map constraintPackage) return + =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings' buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -256,17 +269,22 @@ isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $ TargetProblemIsSubComponent pkgid name subcomponent -reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a +reportTargetProblems :: Verbosity -> Flag Bool -> [WithConstraintSource TestTargetProblem] -> IO a reportTargetProblems verbosity failWhenNoTestSuites problems = case (failWhenNoTestSuites, problems) of - (Flag True, [CustomTargetProblem (TargetProblemNoTests _)]) -> - dieWithException verbosity $ ReportTargetProblems problemsMessage - (_, [CustomTargetProblem (TargetProblemNoTests selector)]) -> do + ( Flag True + , [ WithConstraintSource + { constraintPackage = CustomTargetProblem (TargetProblemNoTests _) + } + ] + ) -> + dieWithException verbosity $ ReportTargetProblems problemsMessage + (_, [WithConstraintSource{constraintPackage = CustomTargetProblem (TargetProblemNoTests selector)}]) -> do notice verbosity (renderAllowedNoTestsProblem selector) System.Exit.exitSuccess (_, _) -> dieWithException verbosity $ ReportTargetProblems problemsMessage where - problemsMessage = unlines . map renderTestTargetProblem $ problems + problemsMessage = unlines . map (prettyShow . fmap (PP.text . renderTestTargetProblem)) $ problems -- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't -- @die@ when the target problem is 'TargetProblemNoTests'. diff --git a/cabal-install/src/Distribution/Client/Errors.hs b/cabal-install/src/Distribution/Client/Errors.hs index d25c59af41e..5f2e2cc4fcc 100644 --- a/cabal-install/src/Distribution/Client/Errors.hs +++ b/cabal-install/src/Distribution/Client/Errors.hs @@ -34,6 +34,7 @@ import Distribution.Package import Distribution.Pretty import Distribution.Simple (VersionRange) import Distribution.Simple.Utils +import Distribution.Solver.Types.ConstraintSource (ConstraintSource) import Network.URI import Text.Regex.Posix.ByteString (WrapError) @@ -160,7 +161,7 @@ data CabalInstallException | TargetSelectorNoTargetsInCwdFalse | TargetSelectorNoTargetsInProjectErr | TargetSelectorNoScriptErr String - | MatchingInternalErrorErr String String String [(String, [String])] + | MatchingInternalErrorErr String String String [(String, [String])] ConstraintSource | ReportPlanningFailure String | Can'tDownloadPackagesOffline [String] | SomePackagesFailedToInstall [(String, String)] @@ -759,7 +760,7 @@ exceptionMessageCabalInstall e = case e of ++ "' does not exist, " ++ "and only script targets may contain whitespace characters or end " ++ "with ':'" - MatchingInternalErrorErr t s sKind renderingsAndMatches -> + MatchingInternalErrorErr t s sKind renderingsAndMatches constraintSource -> "Internal error in target matching: could not make an " ++ "unambiguous fully qualified target selector for '" ++ t @@ -768,6 +769,8 @@ exceptionMessageCabalInstall e = case e of ++ s ++ "' (" ++ sKind + ++ " from " + ++ prettyShow constraintSource ++ ") that was expected to " ++ "be unambiguous but matches the following targets:\n" ++ unlines diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 321b268107a..76dbc410bac 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 @@ -187,7 +190,7 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = return BuildStatusInstalled dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do mloc <- checkFetched (elabPkgSourceLocation pkg) - case packageLocation <$> mloc of + case constraintPackage <$> mloc of Nothing -> return BuildStatusDownload Just (LocalUnpackedPackage srcdir) -> -- For the case of a user-managed local dir, irrespective of the @@ -462,7 +465,7 @@ rebuildTargets [ elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan - , isRemote $ packageLocation $ elabPkgSourceLocation elab + , isRemote $ constraintPackage $ elabPkgSourceLocation elab ] where isRemote :: PackageLocation a -> Bool @@ -686,7 +689,7 @@ downloadedSourceLocation :: PackageLocationProvenance FilePath -> Maybe DownloadedSourceLocation downloadedSourceLocation pkgloc = - case packageLocation pkgloc of + case constraintPackage pkgloc of RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) _ -> Nothing diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs index 906014d10e2..ca105ec90de 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 #-} @@ -137,7 +138,6 @@ import Distribution.Client.Types ( DocsResult (..) , GenericReadyPackage (..) , PackageLocation (..) - , PackageLocationProvenance (..) , PackageSpecifier (..) , SourcePackageDb (..) , TestsResult (..) @@ -171,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 @@ -565,11 +569,11 @@ runProjectPostBuildPhase -- matched this target. Typically this is exactly one, but in general it is -- possible to for different selectors to match the same target. This extra -- information is primarily to help make helpful error messages. -type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)] +type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty (WithConstraintSource TargetSelector))] -- | Get all target selectors. allTargetSelectors :: TargetsMap -> [TargetSelector] -allTargetSelectors = concatMap (NE.toList . snd) . concat . Map.elems +allTargetSelectors = concatMap (map constraintPackage . NE.toList . snd) . concat . Map.elems -- | Get all unique target selectors. uniqueTargetSelectors :: TargetsMap -> [TargetSelector] @@ -620,8 +624,8 @@ resolveTargets ) -> ElaboratedInstallPlan -> Maybe (SourcePackageDb) - -> [TargetSelector] - -> Either [TargetProblem err] TargetsMap + -> [WithConstraintSource TargetSelector] + -> Either [WithConstraintSource (TargetProblem err)] TargetsMap resolveTargets selectPackageTargets selectComponentTarget @@ -633,7 +637,7 @@ resolveTargets . map (\ts -> (,) ts <$> checkTarget ts) where mkTargetsMap - :: [(TargetSelector, [(UnitId, ComponentTarget)])] + :: [(WithConstraintSource TargetSelector, [(UnitId, ComponentTarget)])] -> TargetsMap mkTargetsMap targets = Map.map nubComponentTargets $ @@ -646,76 +650,87 @@ resolveTargets AvailableTargetIndexes{..} = availableTargetIndexes installPlan - checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)] + checkTarget :: WithConstraintSource TargetSelector -> Either (WithConstraintSource (TargetProblem err)) [(UnitId, ComponentTarget)] -- We can ask to build any whole package, project-local or a dependency - checkTarget bt@(TargetPackage _ (ordNub -> [pkgid]) mkfilter) - | Just ats <- - fmap (maybe id filterTargetsKind mkfilter) $ - Map.lookup pkgid availableTargetsByPackageId = - fmap (componentTargets WholeComponent) $ - selectPackageTargets bt ats - | otherwise = - Left (TargetProblemNoSuchPackage pkgid) - checkTarget (TargetPackage _ pkgids _) = - error - ( "TODO: add support for multiple packages in a directory. Got\n" - ++ unlines (map prettyShow pkgids) - ) - -- For the moment this error cannot happen here, because it gets - -- detected when the package config is being constructed. This case - -- will need handling properly when we do add support. - -- - -- TODO: how should this use case play together with the - -- '--cabal-file' option of 'configure' which allows using multiple - -- .cabal files for a single package? - - checkTarget bt@(TargetAllPackages mkfilter) = - fmap (componentTargets WholeComponent) - . selectPackageTargets bt - . maybe id filterTargetsKind mkfilter - . filter availableTargetLocalToProject - $ concat (Map.elems availableTargetsByPackageId) - checkTarget (TargetComponent pkgid cname subtarget) - | Just ats <- - Map.lookup - (pkgid, cname) - availableTargetsByPackageIdAndComponentName = - fmap (componentTargets subtarget) $ - selectComponentTargets subtarget ats - | Map.member pkgid availableTargetsByPackageId = - Left (TargetProblemNoSuchComponent pkgid cname) - | otherwise = - Left (TargetProblemNoSuchPackage pkgid) - checkTarget (TargetComponentUnknown pkgname ecname subtarget) - | Just ats <- case ecname of - Left ucname -> - Map.lookup - (pkgname, ucname) - availableTargetsByPackageNameAndUnqualComponentName - Right cname -> - Map.lookup - (pkgname, cname) - availableTargetsByPackageNameAndComponentName = - fmap (componentTargets subtarget) $ - selectComponentTargets subtarget ats - | Map.member pkgname availableTargetsByPackageName = - Left (TargetProblemUnknownComponent pkgname ecname) - | otherwise = - Left (TargetNotInProject pkgname) - checkTarget bt@(TargetPackageNamed pkgname mkfilter) - | Just ats <- - fmap (maybe id filterTargetsKind mkfilter) $ - Map.lookup pkgname availableTargetsByPackageName = - fmap (componentTargets WholeComponent) - . selectPackageTargets bt - $ ats - | Just SourcePackageDb{packageIndex} <- mPkgDb - , let pkg = lookupPackageName packageIndex pkgname - , not (null pkg) = - Left (TargetAvailableInIndex pkgname) - | otherwise = - Left (TargetNotInProject pkgname) + checkTarget + ( withConstraint@WithConstraintSource + { constraintPackage = targetSelector + } + ) = + bimap + (\problem -> withConstraint{constraintPackage = problem}) + id + $ case targetSelector of + bt@(TargetPackage _ (ordNub -> [pkgid]) mkfilter) -> + case fmap (maybe id filterTargetsKind mkfilter) $ + Map.lookup pkgid availableTargetsByPackageId of + Just ats -> + fmap (componentTargets WholeComponent) $ + selectPackageTargets bt ats + _ -> Left (TargetProblemNoSuchPackage pkgid) + TargetPackage _ pkgids _ -> + error + ( "TODO: add support for multiple packages in a directory. Got\n" + ++ unlines (map prettyShow pkgids) + ) + -- For the moment this error cannot happen here, because it gets + -- detected when the package config is being constructed. This case + -- will need handling properly when we do add support. + -- + -- TODO: how should this use case play together with the + -- '--cabal-file' option of 'configure' which allows using multiple + -- .cabal files for a single package? + + bt@(TargetAllPackages mkfilter) -> + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + . maybe id filterTargetsKind mkfilter + . filter availableTargetLocalToProject + $ concat (Map.elems availableTargetsByPackageId) + TargetComponent pkgid cname subtarget -> + if + | Just ats <- + Map.lookup + (pkgid, cname) + availableTargetsByPackageIdAndComponentName -> + fmap (componentTargets subtarget) $ + selectComponentTargets subtarget ats + | Map.member pkgid availableTargetsByPackageId -> + Left (TargetProblemNoSuchComponent pkgid cname) + | otherwise -> + Left (TargetProblemNoSuchPackage pkgid) + TargetComponentUnknown pkgname ecname subtarget -> + if + | Just ats <- case ecname of + Left ucname -> + Map.lookup + (pkgname, ucname) + availableTargetsByPackageNameAndUnqualComponentName + Right cname -> + Map.lookup + (pkgname, cname) + availableTargetsByPackageNameAndComponentName -> + fmap (componentTargets subtarget) $ + selectComponentTargets subtarget ats + | Map.member pkgname availableTargetsByPackageName -> + Left (TargetProblemUnknownComponent pkgname ecname) + | otherwise -> + Left (TargetNotInProject pkgname) + bt@(TargetPackageNamed pkgname mkfilter) -> + if + | Just ats <- + fmap (maybe id filterTargetsKind mkfilter) $ + Map.lookup pkgname availableTargetsByPackageName -> + fmap (componentTargets WholeComponent) + . selectPackageTargets bt + $ ats + | Just SourcePackageDb{packageIndex} <- mPkgDb + , let pkg = lookupPackageName packageIndex pkgname + , not (null pkg) -> + Left (TargetAvailableInIndex pkgname) + | otherwise -> + Left (TargetNotInProject pkgname) componentTargets :: SubComponentTarget @@ -1178,9 +1193,8 @@ writeBuildReports settings buildContext plan buildOutcomes = do , testsOutcome } , getRepo $ - packageLocation $ - elabPkgSourceLocation $ - pkg + constraintPackage $ + elabPkgSourceLocation pkg ) fromPlanPackage _ _ = Nothing buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs index b2c0b372452..4b41d5d1e2e 100644 --- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs @@ -1296,12 +1296,16 @@ planPackages . addPreferences -- preferences from the config file or command line [ PackageVersionPreference name ver - | PackageVersionConstraint name ver <- solverSettingPreferences + | PackageVersionConstraint name ver <- map constraintPackage solverSettingPreferences ] . addConstraints -- version constraints from the config file or command line [ LabeledPackageConstraint (userToPackageConstraint pc) src - | (pc, src) <- solverSettingConstraints + | WithConstraintSource + { constraintPackage = pc + , constraintConstraint = src + } <- + solverSettingConstraints ] . addPreferences -- enable stanza preference unilaterally, regardless if the user asked @@ -2543,7 +2547,7 @@ elaborateInstallPlan -- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocationProvenance loc)) -> Maybe PackageId -shouldBeLocal NamedPackage{} = Nothing +shouldBeLocal (Named _) = Nothing shouldBeLocal (SpecificSourcePackage pkg) = case constraintPackage $ srcpkgSource pkg of LocalUnpackedPackage _ -> Just (packageId pkg) _ -> Nothing diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index a9a6bd5074c..ba8350b64b9 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -87,7 +87,6 @@ import Distribution.Client.Types ( PackageLocation (..) , PackageSpecifier (..) , UnresolvedSourcePackage - , withUnknownConstraint ) import Distribution.Compiler ( CompilerId (..) @@ -142,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 (..) ) @@ -193,6 +196,7 @@ import Control.Concurrent.MVar import Control.Exception ( bracket ) +import Data.Bifunctor (bimap) import qualified Data.ByteString.Char8 as BS import Data.ByteString.Lazy () import qualified Data.Set as S @@ -313,7 +317,10 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings glo _ -> 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 (map withUnknownConstraint targetStrings) + + -- TODO: Propagate `ConstraintSource` information here. + case bimap (map constraintPackage) (map constraintPackage) eitherTargetSelectors of -- If there are no target selectors and no targets are fine, return -- the context Left (TargetSelectorNoTargetsInCwd{} : _) diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 14a31bdc957..99df992de13 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -93,6 +93,9 @@ import Distribution.Simple.LocalBuildInfo , componentName , pkgComponents ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource (..) + ) import Distribution.Solver.Types.NamedPackage ( NamedPackage (..) ) @@ -108,6 +111,7 @@ 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 @@ -164,6 +168,7 @@ import Text.EditDistance ( defaultEditCosts , restrictedDamerauLevenshteinDistance ) +import qualified Text.PrettyPrint as PP import qualified Prelude (foldr1) -- ------------------------------------------------------------ @@ -260,8 +265,8 @@ readTargetSelectors -- 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 @@ -269,8 +274,8 @@ readTargetSelectorsWith => DirActions m -> [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 @@ -279,7 +284,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 @@ -324,14 +329,15 @@ data TargetString deriving (Show, Eq) -- | Parse a bunch of 'TargetString's (purely without throwing exceptions). -parseTargetStrings :: [String] -> ([String], [TargetString]) +parseTargetStrings :: [WithConstraintSource String] -> ([WithConstraintSource String], [WithConstraintSource TargetString]) parseTargetStrings = partitionEithers . map (\str -> maybe (Left str) Right (parseTargetString str)) -parseTargetString :: String -> Maybe TargetString -parseTargetString = - readPToMaybe parseTargetApprox +parseTargetString :: WithConstraintSource String -> Maybe (WithConstraintSource TargetString) +parseTargetString target = + (\parsed -> target{constraintPackage = parsed}) + <$> readPToMaybe parseTargetApprox (constraintPackage target) where parseTargetApprox :: Parse.ReadP r TargetString parseTargetApprox = @@ -464,22 +470,23 @@ noFileStatus = FileStatusNotExists False getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m - -> TargetString - -> m TargetStringFileStatus + -> WithConstraintSource TargetString + -> m (WithConstraintSource TargetStringFileStatus) getTargetStringFileStatus DirActions{..} t = - case t of - TargetString1 s1 -> - (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 - TargetString2 s1 s2 -> - (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 - TargetString3 s1 s2 s3 -> - (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 - TargetString4 s1 s2 s3 s4 -> - return (TargetStringFileStatus4 s1 s2 s3 s4) - TargetString5 s1 s2 s3 s4 s5 -> - return (TargetStringFileStatus5 s1 s2 s3 s4 s5) - TargetString7 s1 s2 s3 s4 s5 s6 s7 -> - return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) + (\result -> t{constraintPackage = result}) + <$> case constraintPackage t of + TargetString1 s1 -> + (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1 + TargetString2 s1 s2 -> + (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1 + TargetString3 s1 s2 s3 -> + (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1 + TargetString4 s1 s2 s3 s4 -> + return (TargetStringFileStatus4 s1 s2 s3 s4) + TargetString5 s1 s2 s3 s4 s5 -> + return (TargetStringFileStatus5 s1 s2 s3 s4 s5) + TargetString7 s1 s2 s3 s4 s5 s6 s7 -> + return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7) where fileStatus f = do fexists <- doesFileExist f @@ -540,19 +547,40 @@ copyFileStatus src dst = -- refer to. resolveTargetSelectors :: KnownTargets - -> [TargetStringFileStatus] + -> [WithConstraintSource TargetStringFileStatus] -> Maybe ComponentKindFilter - -> ( [TargetSelectorProblem] - , [TargetSelector] + -> ( [WithConstraintSource TargetSelectorProblem] + , [WithConstraintSource TargetSelector] ) -- default local dir target if there's no given target: resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = - ([TargetSelectorNoTargetsInProject], []) + ( + [ WithConstraintSource + { constraintPackage = TargetSelectorNoTargetsInProject + , constraintConstraint = ConstraintSourceImplicit + } + ] + , [] + ) -- if the component kind filter is just exes, we don't want to suggest "all" as a target. resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf = - ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind)], []) + ( + [ WithConstraintSource + { constraintPackage = TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) + , constraintConstraint = ConstraintSourceImplicit + } + ] + , [] + ) resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = - ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) + ( [] + , + [ WithConstraintSource + { constraintPackage = TargetPackage TargetImplicitCwd pkgids Nothing + , constraintConstraint = ConstraintSourceImplicit + } + ] + ) where pkgids = [pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary] resolveTargetSelectors knowntargets targetStrs mfilter = @@ -563,35 +591,40 @@ resolveTargetSelectors knowntargets targetStrs mfilter = resolveTargetSelector :: KnownTargets -> Maybe ComponentKindFilter - -> TargetStringFileStatus - -> Either TargetSelectorProblem TargetSelector + -> WithConstraintSource TargetStringFileStatus + -> Either + (WithConstraintSource TargetSelectorProblem) + (WithConstraintSource TargetSelector) resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = - case findMatch (matcher targetStrStatus) of - Unambiguous _ - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - Unambiguous (TargetPackage TargetImplicitCwd [] _) -> - Left (TargetSelectorNoCurrentPackage targetStr) - Unambiguous target -> Right target - None errs - | projectIsEmpty -> Left TargetSelectorNoTargetsInProject - | otherwise -> Left (classifyMatchErrors errs) - Ambiguous _ targets - | Just kfilter <- mfilter - , [target] <- applyKindFilter kfilter targets -> - Right target - Ambiguous exactMatch targets -> - case disambiguateTargetSelectors - matcher - targetStrStatus - exactMatch - targets of - Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') - Left ((m, ms) : _) -> Left (MatchingInternalError targetStr m ms) - Left [] -> internalError "resolveTargetSelector" + bimap + (\problem -> fmap (const problem) targetStrStatus) + (\selector -> fmap (const selector) targetStrStatus) + $ case findMatch $ matcher $ constraintPackage targetStrStatus of + Unambiguous _ + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + Unambiguous (TargetPackage TargetImplicitCwd [] _) -> + Left (TargetSelectorNoCurrentPackage targetStr) + Unambiguous target -> Right target + None errs + | projectIsEmpty -> Left TargetSelectorNoTargetsInProject + | otherwise -> Left (classifyMatchErrors errs) + Ambiguous _ targets + | Just kfilter <- mfilter + , [target] <- applyKindFilter kfilter targets -> + Right target + Ambiguous exactMatch targets -> + case disambiguateTargetSelectors + matcher + targetStrStatus + exactMatch + targets of + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') + Left ((m, ms) : _) -> Left (MatchingInternalError targetStr m ms) + Left [] -> internalError "resolveTargetSelector" where matcher = matchTargetSelector knowntargets - targetStr = forgetFileStatus targetStrStatus + targetStr = forgetFileStatus $ constraintPackage targetStrStatus projectIsEmpty = null knownPackagesAll @@ -700,7 +733,7 @@ data QualLevel disambiguateTargetSelectors :: (TargetStringFileStatus -> Match TargetSelector) - -> TargetStringFileStatus + -> WithConstraintSource TargetStringFileStatus -> MatchClass -> [TargetSelector] -> Either @@ -726,7 +759,8 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = [ (matchResult, matchRenderings) | matchResult <- matchResults , let matchRenderings = - [ copyFileStatus matchInput rendering + -- TODO: Should we propagate `ConstraintSource` information here? + [ copyFileStatus (constraintPackage matchInput) rendering | ql <- [QL1 .. QLFull] , rendering <- renderTargetSelector ql matchResult ] @@ -741,7 +775,7 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults = memoisedMatches = -- avoid recomputing the main one if it was an exact match ( if exactMatch == Exact - then Map.insert matchInput (Match Exact 0 matchResults) + then Map.insert (constraintPackage matchInput) (Match Exact 0 matchResults) else id ) $ Map.Lazy.fromList @@ -801,27 +835,43 @@ internalError msg = error $ "TargetSelector: internal error: " ++ msg -- | Throw an exception with a formatted message if there are any problems. -reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a +reportTargetSelectorProblems :: Verbosity -> [WithConstraintSource TargetSelectorProblem] -> IO a reportTargetSelectorProblems verbosity problems = do - case [str | TargetSelectorUnrecognised str <- problems] of - [] -> return () - targets -> dieWithException verbosity $ ReportTargetSelectorProblems targets - - case [(t, m, ms) | MatchingInternalError t m ms <- problems] of + case [ withConstraint{constraintPackage = str} + | withConstraint@WithConstraintSource + { constraintPackage = + TargetSelectorUnrecognised str + } <- + 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) + targets -> dieWithException verbosity $ ReportTargetSelectorProblems $ map (prettyShow . fmap PP.text) targets + + 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 + src + | WithConstraintSource + { constraintPackage = MatchingInternalError target originalMatch renderingsAndMatches + , constraintConstraint = src + } <- + problems + ] of + [] -> return () + (err : _) -> + dieWithException verbosity err case [(t, e, g) | TargetSelectorExpected t e g <- problems] of [] -> return ()