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
. addConstraints
-- package flags from the config file or command line
[ let pc = PackageConstraint
(unqualified $ packageName pkg)
(scopeToplevel $ packageName pkg)
(PackagePropertyFlags $ configConfigurationsFlags configFlags)
in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
]
......@@ -344,7 +344,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags
. addConstraints
-- '--enable-tests' and '--enable-benchmarks' constraints from
-- the config file or command line
[ let pc = PackageConstraint (unqualified $ packageName pkg) .
[ let pc = PackageConstraint (scopeToplevel $ packageName pkg) .
PackagePropertyStanzas $
[ TestStanzas | testsEnabled ] ++
[ BenchStanzas | benchmarksEnabled ]
......
......@@ -25,7 +25,7 @@ module Distribution.Client.Dependency (
-- * Constructing resolver policies
PackageProperty(..),
PackageConstraint(..),
unqualified,
scopeToplevel,
PackagesPreferenceDefault(..),
PackagePreference(..),
......@@ -361,7 +361,7 @@ dontUpgradeNonUpgradeablePackages params =
where
extraConstraints =
[ LabeledPackageConstraint
(PackageConstraint (unqualified pkgname) PackagePropertyInstalled)
(PackageConstraint (scopeToplevel pkgname) PackagePropertyInstalled)
ConstraintSourceNonUpgradeablePackage
| Set.notMember (mkPackageName "base") (depResolverTargets params)
-- If you change this enumeration, make sure to update the list in
......@@ -492,7 +492,7 @@ addSetupCabalMinVersionConstraint :: Version
addSetupCabalMinVersionConstraint minVersion =
addConstraints
[ LabeledPackageConstraint
(PackageConstraint (unqualified cabalPkgname)
(PackageConstraint (scopeToplevel cabalPkgname)
(PackagePropertyVersion $ orLaterVersion minVersion))
ConstraintSetupCabalMinVersion
]
......@@ -600,7 +600,7 @@ applySandboxInstallPolicy
. addConstraints
[ let pc = PackageConstraint
(unqualified $ packageName pkg)
(scopeToplevel $ packageName pkg)
(PackagePropertyVersion $ thisVersion (packageVersion pkg))
in LabeledPackageConstraint pc ConstraintSourceModifiedAddSourceDep
| pkg <- modifiedDeps ]
......@@ -946,9 +946,9 @@ resolveWithoutDependencies (DepResolverParams targets constraints
Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
packageVersionConstraintMap =
let pcs = map unlabelPackageConstraint constraints
in Map.fromList [ (name, range)
in Map.fromList [ (scopeToPackageName scope, range)
| PackageConstraint
(Q _ name) (PackagePropertyVersion range) <- pcs ]
scope (PackagePropertyVersion range) <- pcs ]
packagePreferences :: PackageName -> PackagePreferences
packagePreferences = interpretPackagesPreference targets defpref prefs
......
......@@ -183,7 +183,7 @@ planPackages verbosity comp platform mSandboxPkgInfo freezeFlags
. addConstraints
[ let pkg = pkgSpecifierTarget pkgSpecifier
pc = PackageConstraint (unqualified pkg)
pc = PackageConstraint (scopeToplevel pkg)
(PackagePropertyStanzas stanzas)
in LabeledPackageConstraint pc ConstraintSourceFreeze
| pkgSpecifier <- pkgSpecifiers ]
......
......@@ -410,7 +410,7 @@ planPackages comp platform mSandboxPkgInfo solver
--FIXME: this just applies all flags to all targets which
-- is silly. We should check if the flags are appropriate
[ let pc = PackageConstraint
(unqualified $ pkgSpecifierTarget pkgSpecifier)
(scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
(PackagePropertyFlags flags)
in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
| let flags = configConfigurationsFlags configFlags
......@@ -419,7 +419,7 @@ planPackages comp platform mSandboxPkgInfo solver
. addConstraints
[ let pc = PackageConstraint
(unqualified $ pkgSpecifierTarget pkgSpecifier)
(scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
(PackagePropertyStanzas stanzas)
in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
| pkgSpecifier <- pkgSpecifiers ]
......
......@@ -985,7 +985,7 @@ planPackages comp platform solver SolverSettings{..}
. addConstraints
-- enable stanza constraints where the user asked to enable
[ LabeledPackageConstraint
(PackageConstraint (unqualified pkgname)
(PackageConstraint (scopeToplevel pkgname)
(PackagePropertyStanzas stanzas))
ConstraintSourceConfigFlagOrTarget
| pkg <- localPackages
......@@ -1000,7 +1000,7 @@ 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
(PackageConstraint (unqualified pkgname)
(PackageConstraint (scopeToplevel pkgname)
(PackagePropertyFlags flags))
ConstraintSourceConfigFlagOrTarget
| (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]
......@@ -1011,7 +1011,7 @@ 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
(PackageConstraint (unqualified pkgname)
(PackageConstraint (scopeToplevel pkgname)
(PackagePropertyFlags flags))
ConstraintSourceConfigFlagOrTarget
| let flags = solverSettingFlagAssignment
......
......@@ -201,13 +201,13 @@ pkgSpecifierConstraints :: Package pkg
pkgSpecifierConstraints (NamedPackage name props) = map toLpc props
where
toLpc prop = LabeledPackageConstraint
(PackageConstraint (unqualified name) prop)
(PackageConstraint (scopeToplevel name) prop)
ConstraintSourceUserTarget
pkgSpecifierConstraints (SpecificSourcePackage pkg) =
[LabeledPackageConstraint pc ConstraintSourceUserTarget]
where
pc = PackageConstraint
(unqualified $ packageName pkg)
(scopeToplevel $ packageName pkg)
(PackagePropertyVersion $ thisVersion (packageVersion pkg))
-- ------------------------------------------------------------
......@@ -718,7 +718,7 @@ userConstraintPackageName (UserConstraint _ name _) = name
userToPackageConstraint :: UserConstraint -> PackageConstraint
userToPackageConstraint (UserConstraint qual name prop) =
PackageConstraint (Q path name) prop
PackageConstraint (ScopeQualified $ Q path name) prop
where
path = PackagePath DefaultNamespace (fromUserQualifier qual)
......
......@@ -31,7 +31,6 @@ 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(..) )
......@@ -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.
pcName :: PackageConstraint -> PN
pcName (PackageConstraint (Q _ pn) _) = pn
pcName (PackageConstraint scope _) = scopeToPackageName scope
......@@ -6,6 +6,9 @@
-- range or inconsistent flag assignment).
--
module Distribution.Solver.Types.PackageConstraint (
ConstraintScope(..),
scopeToplevel,
scopeToPackageName,
PackageProperty(..),
dispPackageProperty,
PackageConstraint(..),
......@@ -13,11 +16,13 @@ module Distribution.Solver.Types.PackageConstraint (
showPackageConstraint,
) where
import Distribution.Package (PackageName)
import Distribution.Version (VersionRange, simplifyVersionRange)
import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment)
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 Distribution.Compat.Binary (Binary)
......@@ -25,6 +30,34 @@ import Distribution.Text (disp, flatStyle)
import qualified Text.PrettyPrint as Disp
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.
data PackageProperty
= PackagePropertyVersion VersionRange
......@@ -45,29 +78,29 @@ 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
-- | A package constraint consists of a scope plus a property
-- that must hold for all packages within that scope.
data PackageConstraint = PackageConstraint ConstraintScope PackageProperty
deriving (Eq, Show, Generic)
instance Binary PackageConstraint
-- | Pretty-prints a package constraint.
dispPackageConstraint :: PackageConstraint -> Disp.Doc
dispPackageConstraint (PackageConstraint qpn prop) =
dispQPN qpn <+> dispPackageProperty prop
dispPackageConstraint (PackageConstraint scope prop) =
dispConstraintScope scope <+> dispPackageProperty prop
-- | Alternative textual representation of a package constraint
-- for debugging purposes (slightly more verbose than that
-- produced by 'dispPackageConstraint').
--
showPackageConstraint :: PackageConstraint -> String
showPackageConstraint pc@(PackageConstraint qpn prop) =
showPackageConstraint pc@(PackageConstraint scope prop) =
Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2
where
pc2 = case prop of
PackagePropertyVersion vr ->
PackageConstraint qpn $ PackagePropertyVersion (simplifyVersionRange vr)
PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr)
_ -> pc
postprocess = case prop of
PackagePropertyFlags _ -> (Disp.text "flags" <+>)
......
......@@ -5,7 +5,6 @@ module Distribution.Solver.Types.PackagePath
, Qualifier(..)
, dispQualifier
, Qualified(..)
, unqualified
, QPN
, dispQPN
, showQPN
......@@ -102,10 +101,6 @@ data Qualified a = Q PackagePath 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.
type QPN = Qualified PackageName
......
......@@ -545,7 +545,7 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
}
enableTests
| asBool enableAllTests = fmap (\p -> PackageConstraint
(unqualified (C.mkPackageName p))
(scopeToplevel (C.mkPackageName p))
(PackagePropertyStanzas [TestStanzas]))
(exDbPkgs db)
| 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