Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Qualified constraints (issue #3502) #4219

Merged
7 commits merged into from Jan 9, 2017
Merged

Qualified constraints (issue #3502) #4219

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
39c3cb6
Added pretty-printing functions and 'unqualified' constructor.
Jan 6, 2017
79d562b
Added qualifier to 'PackageConstraint' data type.
Jan 7, 2017
ee86697
Code cleanup: refactored 'PackageSpecifier' and 'PackageTarget'.
Jan 7, 2017
d2bf16e
Code cleanup: added Traversable instance for PackageTarget.
Jan 7, 2017
702a39d
Added qualifer to 'UserConstraint' data type.
Jan 7, 2017
b992fae
Corrected minor error (forgot to delete old instance).
Jan 8, 2017
14b5e9d
Corrected missing parentheses and added comment.
Jan 8, 2017
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
8 changes: 5 additions & 3 deletions cabal-install/Distribution/Client/Configure.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
15 changes: 10 additions & 5 deletions cabal-install/Distribution/Client/Dependency.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,9 @@ module Distribution.Client.Dependency (
resolveWithoutDependencies,

-- * Constructing resolver policies
PackageProperty(..),
PackageConstraint(..),
unqualified,
PackagesPreferenceDefault(..),
PackagePreference(..),

Expand Down Expand Up @@ -346,7 +348,7 @@ dontUpgradeNonUpgradeablePackages params =
where
extraConstraints =
[ LabeledPackageConstraint
(PackageConstraintInstalled pkgname)
(PackageConstraint (unqualified pkgname) PackagePropertyInstalled)
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

These constraints should still apply to dependencies with any qualifier. I would expand PackageConstraint so that it can take either a qualified or unqualified PackageName, because there will probably be other situations where it is useful to constrain a package everywhere it appears as a dependency.

It would also be nice to allow users to specify unqualified constraints, but I don't think that's necessary for this set of PRs. I think that --constraint pkg==2 should always apply to the top-level pkg dependency, as implemented in this PR. Once the solver part is done, it will fix an issue with bootstrapping packages such as time: #4154. (See the comment at #4154 (comment).)

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes I see your point. This may require a little thought, so I'll make a new PR after this one. Would it make sense instead of expanding PackageConstraint to expand Qualifier by adding a new constructor? I see two obvious choices:

  1. Let 'Unqualified' mean top-level dependency and add a new constructor called e.g. Any.
  2. Let 'Unqualified' mean applies everywhere and add a new constructor Toplevel.

Option 1 seems somewhat confusing semantically, so maybe option 2 is better - what do you think?

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

On second thoughts, having looked at how Qualifier is used in the solver, I think my last suggestion was incorrect. So, if I understand you, I should modify PackageConstraint to support a wildcard or 'any' qualifier as an extra alternative, but leave the Qualifier and QPN datatypes as they are?

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

So, if I understand you, I should modify PackageConstraint to support a wildcard or 'any' qualifier as an extra alternative, but leave the Qualifier and QPN datatypes as they are?

Yes, the solver still needs QPN to refer to a single instance of a package in many places. It might be worth adding a new type for the scope of the constraint, since we'll probably need other scopes later, such as "all setup dependencies". For example:

data PackageConstraint = PackageConstraint ConstraintScope PackageProperty

data ConstraintScope =
  Qualified QPN
  | AnyQualifier PackageName
  | AnySetupQualifier PackageName

Let 'Unqualified' mean applies everywhere and add a new constructor Toplevel.

I think Toplevel is a lot clearer than the current use of Unqualified. (I'm not suggesting a change for these PRs, though.)

ConstraintSourceNonUpgradeablePackage
| Set.notMember (mkPackageName "base") (depResolverTargets params)
-- If you change this enumeration, make sure to update the list in
Expand Down Expand Up @@ -477,7 +479,8 @@ addSetupCabalMinVersionConstraint :: Version
addSetupCabalMinVersionConstraint minVersion =
addConstraints
[ LabeledPackageConstraint
(PackageConstraintVersion cabalPkgname (orLaterVersion minVersion))
(PackageConstraint (unqualified cabalPkgname)
(PackagePropertyVersion $ orLaterVersion minVersion))
ConstraintSetupCabalMinVersion
]
where
Expand Down Expand Up @@ -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 ]

Expand Down Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion cabal-install/Distribution/Client/Freeze.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 ]

Expand Down
14 changes: 8 additions & 6 deletions cabal-install/Distribution/Client/Install.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 ]

Expand Down Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/List.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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) =
Expand Down
9 changes: 6 additions & 3 deletions cabal-install/Distribution/Client/ProjectPlanning.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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 ]

Expand All @@ -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)
Expand Down
34 changes: 17 additions & 17 deletions cabal-install/Distribution/Client/Targets.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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]

Expand All @@ -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 ->
Expand Down Expand Up @@ -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 =
Expand Down
7 changes: 2 additions & 5 deletions cabal-install/Distribution/Solver/Modular.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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(..) )
Expand Down Expand Up @@ -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
10 changes: 5 additions & 5 deletions cabal-install/Distribution/Solver/Modular/Preference.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down
89 changes: 59 additions & 30 deletions cabal-install/Distribution/Solver/Types/PackageConstraint.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think that your changes to PackageSpecifier removed the need for this instance and most of the new Binary instances.

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, I think you're right - I'll look into that.


-- | 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
Loading