diff --git a/cabal-install/Distribution/Client/CmdFreeze.hs b/cabal-install/Distribution/Client/CmdFreeze.hs index c84fc70cb99..9c3332fd757 100644 --- a/cabal-install/Distribution/Client/CmdFreeze.hs +++ b/cabal-install/Distribution/Client/CmdFreeze.hs @@ -13,7 +13,9 @@ import Distribution.Client.ProjectConfig , commandLineFlagsToProjectConfig, writeProjectLocalFreezeConfig , findProjectRoot, getProjectFileName ) import Distribution.Client.Targets - ( UserConstraint(..) ) + ( UserQualifier(..), UserConstraint(..) ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.DistDirLayout @@ -148,7 +150,8 @@ projectFreezeConstraints plan = versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] versionConstraints = Map.mapWithKey - (\p v -> [(UserConstraintVersion p v, ConstraintSourceFreeze)]) + (\p v -> [(UserConstraint UserUnqualified p (PackagePropertyVersion v), + ConstraintSourceFreeze)]) versionRanges versionRanges :: Map PackageName VersionRange @@ -165,7 +168,8 @@ projectFreezeConstraints plan = flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)] flagConstraints = Map.mapWithKey - (\p f -> [(UserConstraintFlags p f, ConstraintSourceFreeze)]) + (\p f -> [(UserConstraint UserUnqualified p (PackagePropertyFlags f), + ConstraintSourceFreeze)]) flagAssignments flagAssignments :: Map PackageName FlagAssignment @@ -201,7 +205,7 @@ projectFreezeConstraints plan = else Just constraints) #endif - isVersionConstraint UserConstraintVersion{} = True + isVersionConstraint (UserConstraint _ _ (PackagePropertyVersion _)) = True isVersionConstraint _ = False localPackages :: Map PackageName () diff --git a/cabal-install/Distribution/Client/Configure.hs b/cabal-install/Distribution/Client/Configure.hs index 4d4ece7bef8..006682e9c87 100644 --- a/cabal-install/Distribution/Client/Configure.hs +++ b/cabal-install/Distribution/Client/Configure.hs @@ -335,15 +335,17 @@ planLocalPackage verbosity comp platform configFlags configExFlags . addConstraints -- package flags from the config file or command line - [ let pc = PackageConstraintFlags (packageName pkg) - (configConfigurationsFlags configFlags) + [ let pc = PackageConstraint + (unqualified $ packageName pkg) + (PackagePropertyFlags $ configConfigurationsFlags configFlags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget ] . addConstraints -- '--enable-tests' and '--enable-benchmarks' constraints from -- the config file or command line - [ let pc = PackageConstraintStanzas (packageName pkg) $ + [ let pc = PackageConstraint (unqualified $ packageName pkg) . + PackagePropertyStanzas $ [ TestStanzas | testsEnabled ] ++ [ BenchStanzas | benchmarksEnabled ] in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index 6cfee98c804..92d9fbe3ee1 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -23,7 +23,9 @@ module Distribution.Client.Dependency ( resolveWithoutDependencies, -- * Constructing resolver policies + PackageProperty(..), PackageConstraint(..), + unqualified, PackagesPreferenceDefault(..), PackagePreference(..), @@ -346,7 +348,7 @@ dontUpgradeNonUpgradeablePackages params = where extraConstraints = [ LabeledPackageConstraint - (PackageConstraintInstalled pkgname) + (PackageConstraint (unqualified pkgname) PackagePropertyInstalled) ConstraintSourceNonUpgradeablePackage | Set.notMember (mkPackageName "base") (depResolverTargets params) -- If you change this enumeration, make sure to update the list in @@ -477,7 +479,8 @@ addSetupCabalMinVersionConstraint :: Version addSetupCabalMinVersionConstraint minVersion = addConstraints [ LabeledPackageConstraint - (PackageConstraintVersion cabalPkgname (orLaterVersion minVersion)) + (PackageConstraint (unqualified cabalPkgname) + (PackagePropertyVersion $ orLaterVersion minVersion)) ConstraintSetupCabalMinVersion ] where @@ -583,8 +586,9 @@ applySandboxInstallPolicy (thisVersion (packageVersion pkg)) | pkg <- otherDeps ] . addConstraints - [ let pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) + [ let pc = PackageConstraint + (unqualified $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep | pkg <- modifiedDeps ] @@ -925,7 +929,8 @@ resolveWithoutDependencies (DepResolverParams targets constraints packageVersionConstraintMap = let pcs = map unlabelPackageConstraint constraints in Map.fromList [ (name, range) - | PackageConstraintVersion name range <- pcs ] + | PackageConstraint + (Q _ name) (PackagePropertyVersion range) <- pcs ] packagePreferences :: PackageName -> PackagePreferences packagePreferences = interpretPackagesPreference targets defpref prefs diff --git a/cabal-install/Distribution/Client/Freeze.hs b/cabal-install/Distribution/Client/Freeze.hs index 5ef886c59f8..0dc3afdec85 100644 --- a/cabal-install/Distribution/Client/Freeze.hs +++ b/cabal-install/Distribution/Client/Freeze.hs @@ -181,7 +181,8 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags . addConstraints [ let pkg = pkgSpecifierTarget pkgSpecifier - pc = PackageConstraintStanzas pkg stanzas + pc = PackageConstraint (unqualified pkg) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceFreeze | pkgSpecifier <- pkgSpecifiers ] @@ -247,8 +248,8 @@ freezePackages verbosity globalFlags pkgs = do (pkgIdToConstraint $ packageId pkg, ConstraintSourceUserConfig userPackageEnvironmentFile) where pkgIdToConstraint pkgId = - UserConstraintVersion (packageName pkgId) - (thisVersion $ packageVersion pkgId) + UserConstraint UserUnqualified (packageName pkgId) + (PackagePropertyVersion $ thisVersion (packageVersion pkgId)) createPkgEnv config = mempty { pkgEnvSavedConfig = config } showPkgEnv = BS.Char8.pack . showPackageEnvironment diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index f263d84cc8c..66d42a5a2cb 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -407,16 +407,18 @@ planPackages comp platform mSandboxPkgInfo solver . addConstraints --FIXME: this just applies all flags to all targets which -- is silly. We should check if the flags are appropriate - [ let pc = PackageConstraintFlags - (pkgSpecifierTarget pkgSpecifier) flags + [ let pc = PackageConstraint + (unqualified $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyFlags flags) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | let flags = configConfigurationsFlags configFlags , not (null flags) , pkgSpecifier <- pkgSpecifiers ] . addConstraints - [ let pc = PackageConstraintStanzas - (pkgSpecifierTarget pkgSpecifier) stanzas + [ let pc = PackageConstraint + (unqualified $ pkgSpecifierTarget pkgSpecifier) + (PackagePropertyStanzas stanzas) in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget | pkgSpecifier <- pkgSpecifiers ] @@ -775,8 +777,8 @@ reportPlanningFailure verbosity theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId theSpecifiedPackage pkgSpec = case pkgSpec of - NamedPackage name [PackageConstraintVersion name' version] - | name == name' -> PackageIdentifier name <$> trivialRange version + NamedPackage name [PackagePropertyVersion version] + -> PackageIdentifier name <$> trivialRange version NamedPackage _ _ -> Nothing SpecificSourcePackage pkg -> Just $ packageId pkg where diff --git a/cabal-install/Distribution/Client/List.hs b/cabal-install/Distribution/Client/List.hs index 20d032fcd5e..751d28ef277 100644 --- a/cabal-install/Distribution/Client/List.hs +++ b/cabal-install/Distribution/Client/List.hs @@ -213,7 +213,7 @@ info verbosity packageDBs repoCtxt comp progdb PackageSpecifier UnresolvedSourcePackage -> Either String PackageDisplayInfo gatherPkgInfo prefs installedPkgIndex sourcePkgIndex - (NamedPackage name constraints) + (NamedPackage name props) | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ "There is no available version of " ++ display name ++ " that satisfies " @@ -238,7 +238,7 @@ info verbosity packageDBs repoCtxt comp progdb -- supplied a non-trivial version constraint showPkgVersion = not (null verConstraints) verConstraint = foldr intersectVersionRanges anyVersion verConstraints - verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] + verConstraints = [ vr | PackagePropertyVersion vr <- props ] gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) = diff --git a/cabal-install/Distribution/Client/ProjectPlanning.hs b/cabal-install/Distribution/Client/ProjectPlanning.hs index 33ebe979c66..5235ac27d31 100644 --- a/cabal-install/Distribution/Client/ProjectPlanning.hs +++ b/cabal-install/Distribution/Client/ProjectPlanning.hs @@ -983,7 +983,8 @@ planPackages comp platform solver SolverSettings{..} . addConstraints -- enable stanza constraints where the user asked to enable [ LabeledPackageConstraint - (PackageConstraintStanzas pkgname stanzas) + (PackageConstraint (unqualified pkgname) + (PackagePropertyStanzas stanzas)) ConstraintSourceConfigFlagOrTarget | pkg <- localPackages , let pkgname = packageName pkg @@ -997,7 +998,8 @@ planPackages comp platform solver SolverSettings{..} --TODO: [nice to have] should have checked at some point that the -- package in question actually has these flags. [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) + (PackageConstraint (unqualified pkgname) + (PackagePropertyFlags flags)) ConstraintSourceConfigFlagOrTarget | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] @@ -1007,7 +1009,8 @@ planPackages comp platform solver SolverSettings{..} -- former we just apply all these flags to all local targets which -- is silly. We should check if the flags are appropriate. [ LabeledPackageConstraint - (PackageConstraintFlags pkgname flags) + (PackageConstraint (unqualified pkgname) + (PackagePropertyFlags flags)) ConstraintSourceConfigFlagOrTarget | let flags = solverSettingFlagAssignment , not (null flags) diff --git a/cabal-install/Distribution/Client/Targets.hs b/cabal-install/Distribution/Client/Targets.hs index aedd5b08cc2..06ea29662b5 100644 --- a/cabal-install/Distribution/Client/Targets.hs +++ b/cabal-install/Distribution/Client/Targets.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} ----------------------------------------------------------------------------- -- | @@ -41,6 +42,7 @@ module Distribution.Client.Targets ( disambiguatePackageName, -- * User constraints + UserQualifier(..), UserConstraint(..), userConstraintPackageName, readUserConstraint, @@ -63,6 +65,7 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackageIndex (PackageIndex) import qualified Distribution.Solver.Types.PackageIndex as PackageIndex import Distribution.Solver.Types.SourcePackage @@ -77,13 +80,11 @@ import Distribution.Client.GlobalFlags ( RepoContext(..) ) import Distribution.PackageDescription - ( GenericPackageDescription, FlagAssignment - , dispFlagAssignment, parseFlagAssignment ) + ( GenericPackageDescription, parseFlagAssignment ) import Distribution.PackageDescription.Parse ( readPackageDescription, parsePackageDescription, ParseResult(..) ) import Distribution.Version - ( nullVersion, thisVersion, anyVersion, isAnyVersion - , VersionRange ) + ( nullVersion, thisVersion, anyVersion, isAnyVersion ) import Distribution.Text ( Text(..), display ) import Distribution.Verbosity (Verbosity) @@ -103,7 +104,6 @@ import Distribution.Compat.ReadP ( (+++), (<++) ) import Distribution.ParseUtils ( readPToMaybe ) -import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ( (<+>) ) import System.FilePath @@ -180,10 +180,10 @@ data PackageSpecifier pkg = -- | A partially specified reference to a package (either source or -- installed). It is specified by package name and optionally some - -- additional constraints. Use a dependency resolver to pick a specific - -- package satisfying these constraints. + -- required properties. Use a dependency resolver to pick a specific + -- package satisfying these properties. -- - NamedPackage PackageName [PackageConstraint] + NamedPackage PackageName [PackageProperty] -- | A fully specified source package. -- @@ -198,14 +198,17 @@ pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg pkgSpecifierConstraints :: Package pkg => PackageSpecifier pkg -> [LabeledPackageConstraint] -pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints +pkgSpecifierConstraints (NamedPackage name props) = map toLpc props where - toLpc pc = LabeledPackageConstraint pc ConstraintSourceUserTarget + toLpc prop = LabeledPackageConstraint + (PackageConstraint (unqualified name) prop) + ConstraintSourceUserTarget pkgSpecifierConstraints (SpecificSourcePackage pkg) = [LabeledPackageConstraint pc ConstraintSourceUserTarget] where - pc = PackageConstraintVersion (packageName pkg) - (thisVersion (packageVersion pkg)) + pc = PackageConstraint + (unqualified $ packageName pkg) + (PackagePropertyVersion $ thisVersion (packageVersion pkg)) -- ------------------------------------------------------------ -- * Parsing and checking user targets @@ -398,13 +401,13 @@ resolveUserTargets verbosity repoCtxt worldFile available userTargets = do -- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. -- data PackageTarget pkg = - PackageTargetNamed PackageName [PackageConstraint] UserTarget + PackageTargetNamed PackageName [PackageProperty] UserTarget -- | A package identified by name, but case insensitively, so it needs -- to be resolved to the right case-sensitive name. - | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget + | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget | PackageTargetLocation pkg - deriving Show + deriving (Show, Functor, Foldable, Traversable) -- ------------------------------------------------------------ @@ -420,19 +423,19 @@ expandUserTarget :: FilePath expandUserTarget worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) -> - let constraints = [ PackageConstraintVersion name vrange - | not (isAnyVersion vrange) ] - in return [PackageTargetNamedFuzzy name constraints userTarget] + let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name props userTarget] UserTargetWorld -> do worldPkgs <- World.getContents worldFile --TODO: should we warn if there are no world targets? - return [ PackageTargetNamed name constraints userTarget + return [ PackageTargetNamed name props userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs - , let constraints = [ PackageConstraintVersion name vrange - | not (isAnyVersion vrange) ] - ++ [ PackageConstraintFlags name flags - | not (null flags) ] ] + , let props = [ PackagePropertyVersion vrange + | not (isAnyVersion vrange) ] + ++ [ PackagePropertyFlags flags + | not (null flags) ] ] UserTargetLocalDir dir -> return [ PackageTargetLocation (LocalUnpackedPackage dir) ] @@ -463,12 +466,8 @@ fetchPackageTarget :: Verbosity -> RepoContext -> PackageTarget (PackageLocation ()) -> IO (PackageTarget ResolvedPkgLoc) -fetchPackageTarget verbosity repoCtxt target = case target of - PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut) - PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut) - PackageTargetLocation location -> do - location' <- fetchPackage verbosity repoCtxt (fmap (const Nothing) location) - return (PackageTargetLocation location') +fetchPackageTarget verbosity repoCtxt = traverse $ + fetchPackage verbosity repoCtxt . fmap (const Nothing) -- | Given a package target that has been fetched, read the .cabal file. @@ -478,26 +477,19 @@ fetchPackageTarget verbosity repoCtxt target = case target of readPackageTarget :: Verbosity -> PackageTarget ResolvedPkgLoc -> IO (PackageTarget UnresolvedSourcePackage) -readPackageTarget verbosity target = case target of - - PackageTargetNamed pkgname constraints userTarget -> - return (PackageTargetNamed pkgname constraints userTarget) - - PackageTargetNamedFuzzy pkgname constraints userTarget -> - return (PackageTargetNamedFuzzy pkgname constraints userTarget) - - PackageTargetLocation location -> case location of +readPackageTarget verbosity = traverse modifyLocation + where + modifyLocation location = case location of LocalUnpackedPackage dir -> do pkg <- tryFindPackageDesc dir (localPackageError dir) >>= readPackageDescription verbosity - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } LocalTarballPackage tarballFile -> readTarballPackageTarget location tarballFile tarballFile @@ -509,7 +501,6 @@ readPackageTarget verbosity target = case target of error "TODO: readPackageTarget RepoTarballPackage" -- For repo tarballs this info should be obtained from the index. - where readTarballPackageTarget location tarballFile tarballOriginalLoc = do (filename, content) <- extractTarballPackageCabalFile tarballFile tarballOriginalLoc @@ -517,13 +508,12 @@ readPackageTarget verbosity target = case target of Nothing -> die $ "Could not parse the cabal file " ++ filename ++ " in " ++ tarballFile Just pkg -> - return $ PackageTargetLocation $ - SourcePackage { - packageInfoId = packageId pkg, - packageDescription = pkg, - packageSource = fmap Just location, - packageDescrOverride = Nothing - } + return $ SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location, + packageDescrOverride = Nothing + } extractTarballPackageCabalFile :: FilePath -> String -> IO (FilePath, BS.ByteString) @@ -590,20 +580,18 @@ disambiguatePackageTargets availablePkgIndex availableExtra targets = disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) - PackageTargetNamed pkgname constraints userTarget + PackageTargetNamed pkgname props userTarget | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> Left (PackageNameUnknown pkgname userTarget) - | otherwise -> Right (NamedPackage pkgname constraints) + | otherwise -> Right (NamedPackage pkgname props) - PackageTargetNamedFuzzy pkgname constraints userTarget -> + PackageTargetNamedFuzzy pkgname props userTarget -> case disambiguatePackageName packageNameEnv pkgname of None -> Left (PackageNameUnknown pkgname userTarget) Ambiguous pkgnames -> Left (PackageNameAmbiguous pkgname pkgnames userTarget) - Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints') - where - constraints' = map (renamePackageConstraint pkgname') constraints + Unambiguous pkgname' -> Right (NamedPackage pkgname' props) -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv @@ -698,40 +686,41 @@ extraPackageNameEnv names = PackageNameEnv pkgNameLookup -- * Package constraints -- ------------------------------------------------------------ -data UserConstraint = - UserConstraintVersion PackageName VersionRange - | UserConstraintInstalled PackageName - | UserConstraintSource PackageName - | UserConstraintFlags PackageName FlagAssignment - | UserConstraintStanzas PackageName [OptionalStanza] +-- | Version of 'Qualifier' that a user may specify on the +-- command line. +data UserQualifier = + -- | Top-level dependency. + UserUnqualified + + -- | Setup dependency. + | UserSetup PackageName + + -- | Executable dependency. + | UserExe PackageName PackageName deriving (Eq, Show, Generic) + +instance Binary UserQualifier + +fromUserQualifier :: UserQualifier -> Qualifier +fromUserQualifier UserUnqualified = Unqualified +fromUserQualifier (UserSetup name) = Setup name +fromUserQualifier (UserExe name1 name2) = Exe name1 name2 +-- | Version of 'PackageConstraint' that the user can specify on +-- the command line. +data UserConstraint = UserConstraint UserQualifier PackageName PackageProperty + deriving (Eq, Show, Generic) + instance Binary UserConstraint userConstraintPackageName :: UserConstraint -> PackageName -userConstraintPackageName uc = case uc of - UserConstraintVersion name _ -> name - UserConstraintInstalled name -> name - UserConstraintSource name -> name - UserConstraintFlags name _ -> name - UserConstraintStanzas name _ -> name +userConstraintPackageName (UserConstraint _ name _) = name userToPackageConstraint :: UserConstraint -> PackageConstraint --- At the moment, the types happen to be directly equivalent -userToPackageConstraint uc = case uc of - UserConstraintVersion name ver -> PackageConstraintVersion name ver - UserConstraintInstalled name -> PackageConstraintInstalled name - UserConstraintSource name -> PackageConstraintSource name - UserConstraintFlags name flags -> PackageConstraintFlags name flags - UserConstraintStanzas name stanzas -> PackageConstraintStanzas name stanzas - -renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint -renamePackageConstraint name pc = case pc of - PackageConstraintVersion _ ver -> PackageConstraintVersion name ver - PackageConstraintInstalled _ -> PackageConstraintInstalled name - PackageConstraintSource _ -> PackageConstraintSource name - PackageConstraintFlags _ flags -> PackageConstraintFlags name flags - PackageConstraintStanzas _ stanzas -> PackageConstraintStanzas name stanzas +userToPackageConstraint (UserConstraint qual name prop) = + PackageConstraint (Q path name) prop + where + path = PackagePath DefaultNamespace (fromUserQualifier qual) readUserConstraint :: String -> Either String UserConstraint readUserConstraint str = @@ -744,35 +733,42 @@ readUserConstraint str = ++ "either a version range, 'installed', 'source' or flags" instance Text UserConstraint where - disp (UserConstraintVersion pkgname verrange) = disp pkgname - <+> disp verrange - disp (UserConstraintInstalled pkgname) = disp pkgname - <+> Disp.text "installed" - disp (UserConstraintSource pkgname) = disp pkgname - <+> Disp.text "source" - disp (UserConstraintFlags pkgname flags) = disp pkgname - <+> dispFlagAssignment flags - disp (UserConstraintStanzas pkgname stanzas) = disp pkgname - <+> dispStanzas stanzas - where - dispStanzas = Disp.hsep . map (Disp.text . showStanza) - - parse = parse >>= parseConstraint - where - parseConstraint pkgname = - ((parse >>= return . UserConstraintVersion pkgname) - +++ (do Parse.skipSpaces1 - _ <- Parse.string "installed" - return (UserConstraintInstalled pkgname)) - +++ (do Parse.skipSpaces1 - _ <- Parse.string "source" - return (UserConstraintSource pkgname)) - +++ (do Parse.skipSpaces1 - _ <- Parse.string "test" - return (UserConstraintStanzas pkgname [TestStanzas])) - +++ (do Parse.skipSpaces1 - _ <- Parse.string "bench" - return (UserConstraintStanzas pkgname [BenchStanzas]))) - <++ (do Parse.skipSpaces1 - flags <- parseFlagAssignment - return (UserConstraintFlags pkgname flags)) + disp (UserConstraint qual name prop) = + dispQualifier (fromUserQualifier qual) <<>> disp name + <+> dispPackageProperty prop + + parse = do + -- Qualified name + pn <- parse + (qual, name) <- return (UserUnqualified, pn) + +++ + do _ <- Parse.string ":setup." + pn2 <- parse + return (UserSetup pn, pn2) + +++ + do _ <- Parse.string ":" + pn2 <- parse + _ <- Parse.string ":exe." + pn3 <- parse + return (UserExe pn pn2, pn3) + + -- Package property + let keyword str x = Parse.skipSpaces1 >> Parse.string str >> return x + prop <- ((parse >>= return . PackagePropertyVersion) + +++ + keyword "installed" PackagePropertyInstalled + +++ + keyword "source" PackagePropertySource + +++ + keyword "test" (PackagePropertyStanzas [TestStanzas]) + +++ + keyword "bench" (PackagePropertyStanzas [BenchStanzas])) + -- Note: the parser is left-biased here so that we + -- don't get an ambiguous parse from 'installed', + -- 'source', etc. being regarded as flags. + <++ + (Parse.skipSpaces1 >> parseFlagAssignment + >>= return . PackagePropertyFlags) + + -- Result + return (UserConstraint qual name prop) diff --git a/cabal-install/Distribution/Solver/Modular.hs b/cabal-install/Distribution/Solver/Modular.hs index 8f71629bd5a..9061ceda192 100644 --- a/cabal-install/Distribution/Solver/Modular.hs +++ b/cabal-install/Distribution/Solver/Modular.hs @@ -31,6 +31,7 @@ import Distribution.Solver.Modular.Solver ( SolverConfig(..), solve ) import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackageConstraint +import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.DependencyResolver import Distribution.System ( Platform(..) ) @@ -59,8 +60,4 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN - pcName (PackageConstraintVersion pn _) = pn - pcName (PackageConstraintInstalled pn ) = pn - pcName (PackageConstraintSource pn ) = pn - pcName (PackageConstraintFlags pn _) = pn - pcName (PackageConstraintStanzas pn _) = pn + pcName (PackageConstraint (Q _ pn) _) = pn diff --git a/cabal-install/Distribution/Solver/Modular/Preference.hs b/cabal-install/Distribution/Solver/Modular/Preference.hs index 04bfc40956e..7295279060e 100644 --- a/cabal-install/Distribution/Solver/Modular/Preference.hs +++ b/cabal-install/Distribution/Solver/Modular/Preference.hs @@ -162,13 +162,13 @@ processPackageConstraintP pp _ _ (LabeledPackageConstraint _ src) r processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc where - go (I v _) (PackageConstraintVersion _ vr) + go (I v _) (PackageConstraint _ (PackagePropertyVersion vr)) | checkVR vr v = r | otherwise = Fail c (GlobalConstraintVersion vr src) - go _ (PackageConstraintInstalled _) + go _ (PackageConstraint _ PackagePropertyInstalled) | instI i = r | otherwise = Fail c (GlobalConstraintInstalled src) - go _ (PackageConstraintSource _) + go _ (PackageConstraint _ PackagePropertySource) | not (instI i) = r | otherwise = Fail c (GlobalConstraintSource src) go _ _ = r @@ -185,7 +185,7 @@ processPackageConstraintF :: Flag -> Tree d c processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc where - go (PackageConstraintFlags _ fa) = + go (PackageConstraint _ (PackagePropertyFlags fa)) = case L.lookup f fa of Nothing -> r Just b | b == b' -> r @@ -204,7 +204,7 @@ processPackageConstraintS :: OptionalStanza -> Tree d c processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc where - go (PackageConstraintStanzas _ ss) = + go (PackageConstraint _ (PackagePropertyStanzas ss)) = if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) else r go _ = r diff --git a/cabal-install/Distribution/Solver/Types/PackageConstraint.hs b/cabal-install/Distribution/Solver/Types/PackageConstraint.hs index 4482215ad2a..7e4911326f9 100644 --- a/cabal-install/Distribution/Solver/Types/PackageConstraint.hs +++ b/cabal-install/Distribution/Solver/Types/PackageConstraint.hs @@ -1,46 +1,75 @@ {-# LANGUAGE DeriveGeneric #-} + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- module Distribution.Solver.Types.PackageConstraint ( + PackageProperty(..), + dispPackageProperty, PackageConstraint(..), + dispPackageConstraint, showPackageConstraint, ) where -import Distribution.Compat.Binary (Binary(..)) -import Distribution.PackageDescription (FlagAssignment, unFlagName) -import Distribution.Package (PackageName) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Text (display) import Distribution.Version (VersionRange, simplifyVersionRange) +import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) +import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackagePath (QPN, dispQPN) + import GHC.Generics (Generic) +import Distribution.Compat.Binary (Binary) --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -data PackageConstraint - = PackageConstraintVersion PackageName VersionRange - | PackageConstraintInstalled PackageName - | PackageConstraintSource PackageName - | PackageConstraintFlags PackageName FlagAssignment - | PackageConstraintStanzas PackageName [OptionalStanza] +import Distribution.Text (disp, flatStyle) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<+>)) + +-- | A package property is a logical predicate on packages. +data PackageProperty + = PackagePropertyVersion VersionRange + | PackagePropertyInstalled + | PackagePropertySource + | PackagePropertyFlags FlagAssignment + | PackagePropertyStanzas [OptionalStanza] + deriving (Eq, Show, Generic) + +instance Binary PackageProperty + +-- | Pretty-prints a package property. +dispPackageProperty :: PackageProperty -> Disp.Doc +dispPackageProperty (PackagePropertyVersion verrange) = disp verrange +dispPackageProperty PackagePropertyInstalled = Disp.text "installed" +dispPackageProperty PackagePropertySource = Disp.text "source" +dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags +dispPackageProperty (PackagePropertyStanzas stanzas) = + Disp.hsep $ map (Disp.text . showStanza) stanzas + +-- | A package constraint consists of a package plus a property +-- that must hold for that package. +data PackageConstraint = PackageConstraint QPN PackageProperty deriving (Eq, Show, Generic) instance Binary PackageConstraint --- | Provide a textual representation of a package constraint --- for debugging purposes. +-- | Pretty-prints a package constraint. +dispPackageConstraint :: PackageConstraint -> Disp.Doc +dispPackageConstraint (PackageConstraint qpn prop) = + dispQPN qpn <+> dispPackageProperty prop + +-- | Alternative textual representation of a package constraint +-- for debugging purposes (slightly more verbose than that +-- produced by 'dispPackageConstraint'). -- showPackageConstraint :: PackageConstraint -> String -showPackageConstraint (PackageConstraintVersion pn vr) = - display pn ++ " " ++ display (simplifyVersionRange vr) -showPackageConstraint (PackageConstraintInstalled pn) = - display pn ++ " installed" -showPackageConstraint (PackageConstraintSource pn) = - display pn ++ " source" -showPackageConstraint (PackageConstraintFlags pn fs) = - "flags " ++ display pn ++ " " ++ unwords (map (uncurry showFlag) fs) +showPackageConstraint pc@(PackageConstraint qpn prop) = + Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 where - showFlag f True = "+" ++ unFlagName f - showFlag f False = "-" ++ unFlagName f -showPackageConstraint (PackageConstraintStanzas pn ss) = - "stanzas " ++ display pn ++ " " ++ unwords (map showStanza ss) + pc2 = case prop of + PackagePropertyVersion vr -> + PackageConstraint qpn $ PackagePropertyVersion (simplifyVersionRange vr) + _ -> pc + postprocess = case prop of + PackagePropertyFlags _ -> (Disp.text "flags" <+>) + PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) + _ -> id diff --git a/cabal-install/Distribution/Solver/Types/PackagePath.hs b/cabal-install/Distribution/Solver/Types/PackagePath.hs index 5ba2ecac4e5..ba098cc92ee 100644 --- a/cabal-install/Distribution/Solver/Types/PackagePath.hs +++ b/cabal-install/Distribution/Solver/Types/PackagePath.hs @@ -1,19 +1,29 @@ +{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Namespace(..) , Qualifier(..) - , QPN + , dispQualifier , Qualified(..) + , unqualified + , QPN + , dispQPN , showQPN ) where import Distribution.Package import Distribution.Text +import qualified Text.PrettyPrint as Disp +import Distribution.Client.Compat.Prelude ((<<>>)) +import GHC.Generics (Generic) +import Distribution.Compat.Binary (Binary) -- | A package path consists of a namespace and a package path inside that -- namespace. data PackagePath = PackagePath Namespace Qualifier - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary PackagePath -- | Top-level namespace -- @@ -27,7 +37,15 @@ data Namespace = -- -- For now we just number these (rather than giving them more structure). | Independent Int - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary Namespace + +-- | Pretty-prints a namespace. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. +dispNamespace :: Namespace -> Disp.Doc +dispNamespace DefaultNamespace = Disp.empty +dispNamespace (Independent i) = Disp.int i <<>> Disp.text "." -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = @@ -59,41 +77,43 @@ data Qualifier = -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) | Exe PackageName PackageName - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary Qualifier --- | String representation of a package path. +-- | Pretty-prints a qualifier. The result is either empty or +-- ends in a period, so it can be prepended onto a package name. -- --- NOTE: The result of 'showPP' is either empty or results in a period, so that --- it can be prepended to a package name. -showPP :: PackagePath -> String -showPP (PackagePath ns q) = - case ns of - DefaultNamespace -> go q - Independent i -> show i ++ "." ++ go q - where - -- Print the qualifier - -- - -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is - -- there to make sure different dependencies on base are all independent. - -- So we want to print something like @"A.base"@, where the @"A."@ part - -- is the qualifier and @"base"@ is the actual dependency (which, for the - -- 'Base' qualifier, will always be @base@). - go Unqualified = "" - go (Setup pn) = display pn ++ "-setup." - go (Exe pn pn2) = display pn ++ "-" ++ display pn2 ++ "-exe." - go (Base pn) = display pn ++ "." +-- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is +-- there to make sure different dependencies on base are all independent. +-- So we want to print something like @"A.base"@, where the @"A."@ part +-- is the qualifier and @"base"@ is the actual dependency (which, for the +-- 'Base' qualifier, will always be @base@). +dispQualifier :: Qualifier -> Disp.Doc +dispQualifier Unqualified = Disp.empty +dispQualifier (Setup pn) = disp pn <<>> Disp.text ":setup." +dispQualifier (Exe pn pn2) = disp pn <<>> Disp.text ":" <<>> + disp pn2 <<>> Disp.text ":exe." +dispQualifier (Base pn) = disp pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) + +instance Binary a => Binary (Qualified a) --- | Standard string representation of a qualified entity. -showQ :: (a -> String) -> (Qualified a -> String) -showQ showa (Q pp x) = showPP pp ++ showa x +-- | Marks the entity as a top-level dependency in the default namespace. +unqualified :: a -> Qualified a +unqualified = Q (PackagePath DefaultNamespace Unqualified) -- | Qualified package name. type QPN = Qualified PackageName --- | String representation of a qualified package path. +-- | Pretty-prints a qualified package name. +dispQPN :: QPN -> Disp.Doc +dispQPN (Q (PackagePath ns qual) pn) = + dispNamespace ns <<>> dispQualifier qual <<>> disp pn + +-- | String representation of a qualified package name. showQPN :: QPN -> String -showQPN = showQ display +showQPN = Disp.renderStyle flatStyle . dispQPN diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs index 09de1a1d5be..3b5699124a0 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs @@ -32,6 +32,7 @@ import Distribution.Client.Targets import Distribution.Utils.NubList import Network.URI +import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.Settings @@ -202,7 +203,7 @@ hackProjectConfigShared config = projectConfigConstraints = --TODO: [required eventually] parse ambiguity in constraint -- "pkgname -any" as either any version or disabled flag "any". - let ambiguous ((UserConstraintFlags _pkg flags), _) = + let ambiguous (UserConstraint _ _ (PackagePropertyFlags flags), _) = (not . null) [ () | (name, False) <- flags , "any" `isPrefixOf` unFlagName name ] ambiguous _ = False @@ -565,13 +566,13 @@ instance Arbitrary RemoteRepo where instance Arbitrary UserConstraint where arbitrary = - oneof - [ UserConstraintVersion <$> arbitrary <*> arbitrary - , UserConstraintInstalled <$> arbitrary - , UserConstraintSource <$> arbitrary - , UserConstraintFlags <$> arbitrary <*> shortListOf1 3 arbitrary - , UserConstraintStanzas <$> arbitrary <*> ((\x->[x]) <$> arbitrary) - ] + oneof [ UserConstraint UserUnqualified <$> arbitrary <*> prop + | prop <- [ PackagePropertyVersion <$> arbitrary + , pure PackagePropertyInstalled + , pure PackagePropertySource + , PackagePropertyFlags <$> shortListOf1 3 arbitrary + , PackagePropertyStanzas . (\x->[x]) <$> arbitrary + ] ] instance Arbitrary OptionalStanza where arbitrary = elements [minBound..maxBound] diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs index 9956d284b8b..6c343c6caab 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs +++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs @@ -2,12 +2,15 @@ module UnitTests.Distribution.Client.Targets ( tests ) where -import Distribution.Client.Targets (UserConstraint (..), readUserConstraint) +import Distribution.Client.Targets (UserQualifier(..), UserConstraint(..) + ,readUserConstraint) import Distribution.Compat.ReadP (ReadP, readP_to_S) import Distribution.Package (mkPackageName) import Distribution.ParseUtils (parseCommaList) import Distribution.Text (parse) +import Distribution.Solver.Types.PackageConstraint (PackageProperty(..)) + import Test.Tasty import Test.Tasty.HUnit @@ -26,7 +29,8 @@ readUserConstraintTest = pkgName = "template-haskell" constr = pkgName ++ " installed" - expected = UserConstraintInstalled (mkPackageName pkgName) + expected = UserConstraint UserUnqualified (mkPackageName pkgName) + PackagePropertyInstalled actual = let (Right r) = readUserConstraint constr in r parseUserConstraintTest :: Assertion @@ -36,7 +40,8 @@ parseUserConstraintTest = pkgName = "template-haskell" constr = pkgName ++ " installed" - expected = [UserConstraintInstalled (mkPackageName pkgName)] + expected = [UserConstraint UserUnqualified (mkPackageName pkgName) + PackagePropertyInstalled] actual = [ x | (x, ys) <- readP_to_S parseUserConstraint constr , all isSpace ys] @@ -50,7 +55,8 @@ readUserConstraintsTest = pkgName = "template-haskell" constr = pkgName ++ " installed" - expected = [[UserConstraintInstalled (mkPackageName pkgName)]] + expected = [[UserConstraint UserUnqualified (mkPackageName pkgName) + PackagePropertyInstalled]] actual = [ x | (x, ys) <- readP_to_S parseUserConstraints constr , all isSpace ys] diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 0c45943c619..3c6ac256090 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -546,8 +546,9 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder , packagePreferences = Map.empty } enableTests - | asBool enableAllTests = fmap (\p -> PackageConstraintStanzas - (C.mkPackageName p) [TestStanzas]) + | asBool enableAllTests = fmap (\p -> PackageConstraint + (unqualified (C.mkPackageName p)) + (PackagePropertyStanzas [TestStanzas])) (exDbPkgs db) | otherwise = [] targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets