Commit 79d562bf authored by Robert Henderson's avatar Robert Henderson

Added qualifier to 'PackageConstraint' data type.

Refactored PackageConstraint in two ways:
 1) split it into a package name and a 'PackageProperty' to make
    the code a bit cleaner;
 2) changed PackageName to 'Qualified PackageName'.

Added a Binary instance for Qualifier in PackagePath.hs (needed
for PackageConstraint).

Added pretty-printing code for PackageConstraint.

For now, all the code that creates a PackageConstraint just sets
the qualifier to 'unqualified', so this commit will not change
the external behaviour of cabal-install.
parent 39c3cb6d
......@@ -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
......
......@@ -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
......
......@@ -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 ]
......
......@@ -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 [PackageConstraint name' (PackagePropertyVersion version)]
| name' == unqualified name -> PackageIdentifier name <$> trivialRange version
NamedPackage _ _ -> Nothing
SpecificSourcePackage pkg -> Just $ packageId pkg
where
......
......@@ -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 | PackageConstraint _ (PackagePropertyVersion vr) <- constraints ]
gatherPkgInfo prefs installedPkgIndex sourcePkgIndex
(SpecificSourcePackage pkg) =
......
......@@ -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)
......
......@@ -63,6 +63,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
......@@ -204,8 +205,9 @@ pkgSpecifierConstraints (NamedPackage _ constraints) = map toLpc constraints
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
......@@ -420,7 +422,8 @@ expandUserTarget :: FilePath
expandUserTarget worldFile userTarget = case userTarget of
UserTargetNamed (Dependency name vrange) ->
let constraints = [ PackageConstraintVersion name vrange
let constraints = [ PackageConstraint (unqualified name)
(PackagePropertyVersion vrange)
| not (isAnyVersion vrange) ]
in return [PackageTargetNamedFuzzy name constraints userTarget]
......@@ -429,9 +432,11 @@ expandUserTarget worldFile userTarget = case userTarget of
--TODO: should we warn if there are no world targets?
return [ PackageTargetNamed name constraints userTarget
| World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs
, let constraints = [ PackageConstraintVersion name vrange
, let constraints = [ PackageConstraint (unqualified name)
(PackagePropertyVersion vrange)
| not (isAnyVersion vrange) ]
++ [ PackageConstraintFlags name flags
++ [ PackageConstraint (unqualified name)
(PackagePropertyFlags flags)
| not (null flags) ] ]
UserTargetLocalDir dir ->
......@@ -717,21 +722,16 @@ userConstraintPackageName uc = case uc of
UserConstraintStanzas 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
UserConstraintVersion name ver -> PackageConstraint (unqualified name) (PackagePropertyVersion ver)
UserConstraintInstalled name -> PackageConstraint (unqualified name) PackagePropertyInstalled
UserConstraintSource name -> PackageConstraint (unqualified name) PackagePropertySource
UserConstraintFlags name flags -> PackageConstraint (unqualified name) (PackagePropertyFlags flags)
UserConstraintStanzas name stanzas -> PackageConstraint (unqualified name) (PackagePropertyStanzas 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
renamePackageConstraint name (PackageConstraint _ prop) =
PackageConstraint (unqualified name) prop
readUserConstraint :: String -> Either String UserConstraint
readUserConstraint str =
......
......@@ -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
......@@ -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
......
{-# 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
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Solver.Types.PackagePath
( PackagePath(..)
, Namespace(..)
......@@ -14,11 +15,15 @@ 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
--
......@@ -32,7 +37,9 @@ 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.
......@@ -70,7 +77,9 @@ 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
-- | Pretty-prints a qualifier. The result is either empty or
-- ends in a period, so it can be prepended onto a package name.
......@@ -89,7 +98,9 @@ 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)
-- | Marks the entity as a top-level dependency in the default namespace.
unqualified :: a -> Qualified a
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment