Commit ff38c921 authored by Robert Henderson's avatar Robert Henderson

Added 'ConstraintScope' to PackageConstraint.

I also removed 'unqualified' from PackagePath.hs and replaced all
uses of it with 'scopeToplevel'. The meaning is identical,
however 'scopeToplevel' is a less confusing name.
parent 4094ca50
...@@ -336,7 +336,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags ...@@ -336,7 +336,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags
. addConstraints . addConstraints
-- package flags from the config file or command line -- package flags from the config file or command line
[ let pc = PackageConstraint [ let pc = PackageConstraint
(unqualified $ packageName pkg) (scopeToplevel $ packageName pkg)
(PackagePropertyFlags $ configConfigurationsFlags configFlags) (PackagePropertyFlags $ configConfigurationsFlags configFlags)
in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
] ]
...@@ -344,7 +344,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags ...@@ -344,7 +344,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags
. addConstraints . addConstraints
-- '--enable-tests' and '--enable-benchmarks' constraints from -- '--enable-tests' and '--enable-benchmarks' constraints from
-- the config file or command line -- the config file or command line
[ let pc = PackageConstraint (unqualified $ packageName pkg) . [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) .
PackagePropertyStanzas $ PackagePropertyStanzas $
[ TestStanzas | testsEnabled ] ++ [ TestStanzas | testsEnabled ] ++
[ BenchStanzas | benchmarksEnabled ] [ BenchStanzas | benchmarksEnabled ]
......
...@@ -25,7 +25,7 @@ module Distribution.Client.Dependency ( ...@@ -25,7 +25,7 @@ module Distribution.Client.Dependency (
-- * Constructing resolver policies -- * Constructing resolver policies
PackageProperty(..), PackageProperty(..),
PackageConstraint(..), PackageConstraint(..),
unqualified, scopeToplevel,
PackagesPreferenceDefault(..), PackagesPreferenceDefault(..),
PackagePreference(..), PackagePreference(..),
...@@ -361,7 +361,7 @@ dontUpgradeNonUpgradeablePackages params = ...@@ -361,7 +361,7 @@ dontUpgradeNonUpgradeablePackages params =
where where
extraConstraints = extraConstraints =
[ LabeledPackageConstraint [ LabeledPackageConstraint
(PackageConstraint (unqualified pkgname) PackagePropertyInstalled) (PackageConstraint (scopeToplevel pkgname) PackagePropertyInstalled)
ConstraintSourceNonUpgradeablePackage ConstraintSourceNonUpgradeablePackage
| Set.notMember (mkPackageName "base") (depResolverTargets params) | Set.notMember (mkPackageName "base") (depResolverTargets params)
-- If you change this enumeration, make sure to update the list in -- If you change this enumeration, make sure to update the list in
...@@ -492,7 +492,7 @@ addSetupCabalMinVersionConstraint :: Version ...@@ -492,7 +492,7 @@ addSetupCabalMinVersionConstraint :: Version
addSetupCabalMinVersionConstraint minVersion = addSetupCabalMinVersionConstraint minVersion =
addConstraints addConstraints
[ LabeledPackageConstraint [ LabeledPackageConstraint
(PackageConstraint (unqualified cabalPkgname) (PackageConstraint (scopeToplevel cabalPkgname)
(PackagePropertyVersion $ orLaterVersion minVersion)) (PackagePropertyVersion $ orLaterVersion minVersion))
ConstraintSetupCabalMinVersion ConstraintSetupCabalMinVersion
] ]
...@@ -600,7 +600,7 @@ applySandboxInstallPolicy ...@@ -600,7 +600,7 @@ applySandboxInstallPolicy
. addConstraints . addConstraints
[ let pc = PackageConstraint [ let pc = PackageConstraint
(unqualified $ packageName pkg) (scopeToplevel $ packageName pkg)
(PackagePropertyVersion $ thisVersion (packageVersion pkg)) (PackagePropertyVersion $ thisVersion (packageVersion pkg))
in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep
| pkg <- modifiedDeps ] | pkg <- modifiedDeps ]
...@@ -946,9 +946,9 @@ resolveWithoutDependencies (DepResolverParams targets constraints ...@@ -946,9 +946,9 @@ resolveWithoutDependencies (DepResolverParams targets constraints
Map.findWithDefault anyVersion pkgname packageVersionConstraintMap Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
packageVersionConstraintMap = packageVersionConstraintMap =
let pcs = map unlabelPackageConstraint constraints let pcs = map unlabelPackageConstraint constraints
in Map.fromList [ (name, range) in Map.fromList [ (scopeToPackageName scope, range)
| PackageConstraint | PackageConstraint
(Q _ name) (PackagePropertyVersion range) <- pcs ] scope (PackagePropertyVersion range) <- pcs ]
packagePreferences :: PackageName -> PackagePreferences packagePreferences :: PackageName -> PackagePreferences
packagePreferences = interpretPackagesPreference targets defpref prefs packagePreferences = interpretPackagesPreference targets defpref prefs
......
...@@ -183,7 +183,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags ...@@ -183,7 +183,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
. addConstraints . addConstraints
[ let pkg = pkgSpecifierTarget pkgSpecifier [ let pkg = pkgSpecifierTarget pkgSpecifier
pc = PackageConstraint (unqualified pkg) pc = PackageConstraint (scopeToplevel pkg)
(PackagePropertyStanzas stanzas) (PackagePropertyStanzas stanzas)
in LabeledPackageConstraint pc ConstraintSourceFreeze in LabeledPackageConstraint pc ConstraintSourceFreeze
| pkgSpecifier <- pkgSpecifiers ] | pkgSpecifier <- pkgSpecifiers ]
......
...@@ -410,7 +410,7 @@ planPackages comp platform mSandboxPkgInfo solver ...@@ -410,7 +410,7 @@ planPackages comp platform mSandboxPkgInfo solver
--FIXME: this just applies all flags to all targets which --FIXME: this just applies all flags to all targets which
-- is silly. We should check if the flags are appropriate -- is silly. We should check if the flags are appropriate
[ let pc = PackageConstraint [ let pc = PackageConstraint
(unqualified $ pkgSpecifierTarget pkgSpecifier) (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
(PackagePropertyFlags flags) (PackagePropertyFlags flags)
in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
| let flags = configConfigurationsFlags configFlags | let flags = configConfigurationsFlags configFlags
...@@ -419,7 +419,7 @@ planPackages comp platform mSandboxPkgInfo solver ...@@ -419,7 +419,7 @@ planPackages comp platform mSandboxPkgInfo solver
. addConstraints . addConstraints
[ let pc = PackageConstraint [ let pc = PackageConstraint
(unqualified $ pkgSpecifierTarget pkgSpecifier) (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
(PackagePropertyStanzas stanzas) (PackagePropertyStanzas stanzas)
in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
| pkgSpecifier <- pkgSpecifiers ] | pkgSpecifier <- pkgSpecifiers ]
......
...@@ -985,7 +985,7 @@ planPackages comp platform solver SolverSettings{..} ...@@ -985,7 +985,7 @@ planPackages comp platform solver SolverSettings{..}
. addConstraints . addConstraints
-- enable stanza constraints where the user asked to enable -- enable stanza constraints where the user asked to enable
[ LabeledPackageConstraint [ LabeledPackageConstraint
(PackageConstraint (unqualified pkgname) (PackageConstraint (scopeToplevel pkgname)
(PackagePropertyStanzas stanzas)) (PackagePropertyStanzas stanzas))
ConstraintSourceConfigFlagOrTarget ConstraintSourceConfigFlagOrTarget
| pkg <- localPackages | pkg <- localPackages
...@@ -1000,7 +1000,7 @@ planPackages comp platform solver SolverSettings{..} ...@@ -1000,7 +1000,7 @@ planPackages comp platform solver SolverSettings{..}
--TODO: [nice to have] should have checked at some point that the --TODO: [nice to have] should have checked at some point that the
-- package in question actually has these flags. -- package in question actually has these flags.
[ LabeledPackageConstraint [ LabeledPackageConstraint
(PackageConstraint (unqualified pkgname) (PackageConstraint (scopeToplevel pkgname)
(PackagePropertyFlags flags)) (PackagePropertyFlags flags))
ConstraintSourceConfigFlagOrTarget ConstraintSourceConfigFlagOrTarget
| (pkgname, flags) <- Map.toList solverSettingFlagAssignments ] | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]
...@@ -1011,7 +1011,7 @@ planPackages comp platform solver SolverSettings{..} ...@@ -1011,7 +1011,7 @@ planPackages comp platform solver SolverSettings{..}
-- former we just apply all these flags to all local targets which -- former we just apply all these flags to all local targets which
-- is silly. We should check if the flags are appropriate. -- is silly. We should check if the flags are appropriate.
[ LabeledPackageConstraint [ LabeledPackageConstraint
(PackageConstraint (unqualified pkgname) (PackageConstraint (scopeToplevel pkgname)
(PackagePropertyFlags flags)) (PackagePropertyFlags flags))
ConstraintSourceConfigFlagOrTarget ConstraintSourceConfigFlagOrTarget
| let flags = solverSettingFlagAssignment | let flags = solverSettingFlagAssignment
......
...@@ -201,13 +201,13 @@ pkgSpecifierConstraints :: Package pkg ...@@ -201,13 +201,13 @@ pkgSpecifierConstraints :: Package pkg
pkgSpecifierConstraints (NamedPackage name props) = map toLpc props pkgSpecifierConstraints (NamedPackage name props) = map toLpc props
where where
toLpc prop = LabeledPackageConstraint toLpc prop = LabeledPackageConstraint
(PackageConstraint (unqualified name) prop) (PackageConstraint (scopeToplevel name) prop)
ConstraintSourceUserTarget ConstraintSourceUserTarget
pkgSpecifierConstraints (SpecificSourcePackage pkg) = pkgSpecifierConstraints (SpecificSourcePackage pkg) =
[LabeledPackageConstraint pc ConstraintSourceUserTarget] [LabeledPackageConstraint pc ConstraintSourceUserTarget]
where where
pc = PackageConstraint pc = PackageConstraint
(unqualified $ packageName pkg) (scopeToplevel $ packageName pkg)
(PackagePropertyVersion $ thisVersion (packageVersion pkg)) (PackagePropertyVersion $ thisVersion (packageVersion pkg))
-- ------------------------------------------------------------ -- ------------------------------------------------------------
...@@ -718,7 +718,7 @@ userConstraintPackageName (UserConstraint _ name _) = name ...@@ -718,7 +718,7 @@ userConstraintPackageName (UserConstraint _ name _) = name
userToPackageConstraint :: UserConstraint -> PackageConstraint userToPackageConstraint :: UserConstraint -> PackageConstraint
userToPackageConstraint (UserConstraint qual name prop) = userToPackageConstraint (UserConstraint qual name prop) =
PackageConstraint (Q path name) prop PackageConstraint (ScopeQualified $ Q path name) prop
where where
path = PackagePath DefaultNamespace (fromUserQualifier qual) path = PackagePath DefaultNamespace (fromUserQualifier qual)
......
...@@ -31,7 +31,6 @@ import Distribution.Solver.Modular.Solver ...@@ -31,7 +31,6 @@ import Distribution.Solver.Modular.Solver
( SolverConfig(..), solve ) ( SolverConfig(..), solve )
import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.DependencyResolver
import Distribution.System import Distribution.System
( Platform(..) ) ( Platform(..) )
...@@ -60,4 +59,4 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns ...@@ -60,4 +59,4 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
-- Helper function to extract the PN from a constraint. -- Helper function to extract the PN from a constraint.
pcName :: PackageConstraint -> PN pcName :: PackageConstraint -> PN
pcName (PackageConstraint (Q _ pn) _) = pn pcName (PackageConstraint scope _) = scopeToPackageName scope
...@@ -6,6 +6,9 @@ ...@@ -6,6 +6,9 @@
-- range or inconsistent flag assignment). -- range or inconsistent flag assignment).
-- --
module Distribution.Solver.Types.PackageConstraint ( module Distribution.Solver.Types.PackageConstraint (
ConstraintScope(..),
scopeToplevel,
scopeToPackageName,
PackageProperty(..), PackageProperty(..),
dispPackageProperty, dispPackageProperty,
PackageConstraint(..), PackageConstraint(..),
...@@ -13,11 +16,13 @@ module Distribution.Solver.Types.PackageConstraint ( ...@@ -13,11 +16,13 @@ module Distribution.Solver.Types.PackageConstraint (
showPackageConstraint, showPackageConstraint,
) where ) where
import Distribution.Package (PackageName)
import Distribution.Version (VersionRange, simplifyVersionRange) import Distribution.Version (VersionRange, simplifyVersionRange)
import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment)
import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath (QPN, dispQPN) import Distribution.Solver.Types.PackagePath
import Distribution.Client.Compat.Prelude ((<<>>))
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary) import Distribution.Compat.Binary (Binary)
...@@ -25,6 +30,34 @@ import Distribution.Text (disp, flatStyle) ...@@ -25,6 +30,34 @@ import Distribution.Text (disp, flatStyle)
import qualified Text.PrettyPrint as Disp import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<+>)) import Text.PrettyPrint ((<+>))
-- | Determines to what packages and in what contexts a
-- constraint applies.
data ConstraintScope
-- | The package with the specified qualified name.
= ScopeQualified QPN
-- | The package with the specified name regardless of
-- qualifier.
| ScopeAnyQualifier PackageName
deriving (Eq, Show, Generic)
instance Binary ConstraintScope
-- | Constructor for a common use case: the constraint applies to
-- the package with the specified name when that package is a
-- top-level dependency in the default namespace.
scopeToplevel :: PackageName -> ConstraintScope
scopeToplevel = ScopeQualified . Q (PackagePath DefaultNamespace Unqualified)
-- | Returns the package name associated with a constraint scope.
scopeToPackageName :: ConstraintScope -> PackageName
scopeToPackageName (ScopeQualified (Q _ pn)) = pn
scopeToPackageName (ScopeAnyQualifier pn) = pn
-- | Pretty-prints a constraint scope.
dispConstraintScope :: ConstraintScope -> Disp.Doc
dispConstraintScope (ScopeQualified qpn) = dispQPN qpn
dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> disp pn
-- | A package property is a logical predicate on packages. -- | A package property is a logical predicate on packages.
data PackageProperty data PackageProperty
= PackagePropertyVersion VersionRange = PackagePropertyVersion VersionRange
...@@ -45,29 +78,29 @@ dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags ...@@ -45,29 +78,29 @@ dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags
dispPackageProperty (PackagePropertyStanzas stanzas) = dispPackageProperty (PackagePropertyStanzas stanzas) =
Disp.hsep $ map (Disp.text . showStanza) stanzas Disp.hsep $ map (Disp.text . showStanza) stanzas
-- | A package constraint consists of a package plus a property -- | A package constraint consists of a scope plus a property
-- that must hold for that package. -- that must hold for all packages within that scope.
data PackageConstraint = PackageConstraint QPN PackageProperty data PackageConstraint = PackageConstraint ConstraintScope PackageProperty
deriving (Eq, Show, Generic) deriving (Eq, Show, Generic)
instance Binary PackageConstraint instance Binary PackageConstraint
-- | Pretty-prints a package constraint. -- | Pretty-prints a package constraint.
dispPackageConstraint :: PackageConstraint -> Disp.Doc dispPackageConstraint :: PackageConstraint -> Disp.Doc
dispPackageConstraint (PackageConstraint qpn prop) = dispPackageConstraint (PackageConstraint scope prop) =
dispQPN qpn <+> dispPackageProperty prop dispConstraintScope scope <+> dispPackageProperty prop
-- | Alternative textual representation of a package constraint -- | Alternative textual representation of a package constraint
-- for debugging purposes (slightly more verbose than that -- for debugging purposes (slightly more verbose than that
-- produced by 'dispPackageConstraint'). -- produced by 'dispPackageConstraint').
-- --
showPackageConstraint :: PackageConstraint -> String showPackageConstraint :: PackageConstraint -> String
showPackageConstraint pc@(PackageConstraint qpn prop) = showPackageConstraint pc@(PackageConstraint scope prop) =
Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2
where where
pc2 = case prop of pc2 = case prop of
PackagePropertyVersion vr -> PackagePropertyVersion vr ->
PackageConstraint qpn $ PackagePropertyVersion (simplifyVersionRange vr) PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr)
_ -> pc _ -> pc
postprocess = case prop of postprocess = case prop of
PackagePropertyFlags _ -> (Disp.text "flags" <+>) PackagePropertyFlags _ -> (Disp.text "flags" <+>)
......
...@@ -5,7 +5,6 @@ module Distribution.Solver.Types.PackagePath ...@@ -5,7 +5,6 @@ module Distribution.Solver.Types.PackagePath
, Qualifier(..) , Qualifier(..)
, dispQualifier , dispQualifier
, Qualified(..) , Qualified(..)
, unqualified
, QPN , QPN
, dispQPN , dispQPN
, showQPN , showQPN
...@@ -102,10 +101,6 @@ data Qualified a = Q PackagePath a ...@@ -102,10 +101,6 @@ data Qualified a = Q PackagePath a
instance Binary a => Binary (Qualified a) instance Binary a => Binary (Qualified a)
-- | Marks the entity as a top-level dependency in the default namespace.
unqualified :: a -> Qualified a
unqualified = Q (PackagePath DefaultNamespace Unqualified)
-- | Qualified package name. -- | Qualified package name.
type QPN = Qualified PackageName type QPN = Qualified PackageName
......
...@@ -545,7 +545,7 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder ...@@ -545,7 +545,7 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
} }
enableTests enableTests
| asBool enableAllTests = fmap (\p -> PackageConstraint | asBool enableAllTests = fmap (\p -> PackageConstraint
(unqualified (C.mkPackageName p)) (scopeToplevel (C.mkPackageName p))
(PackagePropertyStanzas [TestStanzas])) (PackagePropertyStanzas [TestStanzas]))
(exDbPkgs db) (exDbPkgs db)
| otherwise = [] | otherwise = []
......
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