Commit 8f6477d0 authored by kristenk's avatar kristenk Committed by GitHub
Browse files

Move goal qualification types into D.Solver.Types.PackagePath (#3511)

parent 5520bea7
......@@ -22,6 +22,7 @@ import Distribution.PackageDescription (FlagAssignment) -- from Cabal
import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Modular.Configured
import Distribution.Solver.Modular.Dependency
......
......@@ -29,6 +29,7 @@ import qualified Distribution.Solver.Modular.PSQ as P
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Types.ComponentDeps (Component)
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings
-- | The state needed during the build phase of the search tree.
......@@ -187,4 +188,4 @@ buildTree idx (IndependentGoals ind) igs =
topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) UserGoal
qpns | ind = makeIndependent igs
| otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs
| otherwise = L.map (Q (PackagePath DefaultNamespace Unqualified)) igs
......@@ -14,6 +14,7 @@ import Distribution.Solver.Modular.Package
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.PackageIndex as CI
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.ResolverPackage
import Distribution.Solver.Types.SolverId
import Distribution.Solver.Types.SolverPackage
......
......@@ -37,8 +37,8 @@ import Data.Tree
import GHC.Stack
#endif
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Var
import Distribution.Solver.Types.PackagePath
-- | The set of variables involved in a solver conflict
--
......
......@@ -9,9 +9,9 @@ import qualified Data.Graph as Gr
import qualified Data.Map as Map
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Types.PackagePath
-- | Find and reject any solutions that are cyclic
detectCyclesPhase :: Tree QGoalReason -> Tree QGoalReason
......
......@@ -60,6 +60,7 @@ import Distribution.Solver.Modular.Version
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Types.ComponentDeps (Component(..))
import Distribution.Solver.Types.PackagePath
#ifdef DEBUG_CONFLICT_SETS
import GHC.Stack (CallStack)
......@@ -213,7 +214,7 @@ data QualifyOptions = QO {
-- NOTE: It's the _dependencies_ of a package that may or may not be independent
-- from the package itself. Package flag choices must of course be consistent.
qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN
qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go
qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go
where
go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN
go = map go1
......@@ -236,9 +237,9 @@ qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go
goD (Lang lang) _ = Lang lang
goD (Pkg pkn vr) _ = Pkg pkn vr
goD (Dep dep ci) comp
| qBase dep = Dep (Q (PP ns (Base pn)) dep) (fmap (Q pp) ci)
| qSetup comp = Dep (Q (PP ns (Setup pn)) dep) (fmap (Q pp) ci)
| otherwise = Dep (Q (PP ns inheritedQ) dep) (fmap (Q pp) ci)
| qBase dep = Dep (Q (PackagePath ns (Base pn)) dep) (fmap (Q pp) ci)
| qSetup comp = Dep (Q (PackagePath ns (Setup pn)) dep) (fmap (Q pp) ci)
| otherwise = Dep (Q (PackagePath ns inheritedQ) dep) (fmap (Q pp) ci)
-- If P has a setup dependency on Q, and Q has a regular dependency on R, then
-- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup
......
......@@ -10,10 +10,10 @@ import Distribution.Solver.Modular.Assignment
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Log
import Distribution.Solver.Modular.Message
import Distribution.Solver.Modular.Package
import qualified Distribution.Solver.Modular.PSQ as P
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Modular.Tree
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Settings (EnableBackjumping(..))
import qualified Distribution.Solver.Types.Progress as P
......
......@@ -22,6 +22,7 @@ import Distribution.PackageDescription hiding (Flag) -- from Cabal
import Distribution.Solver.Modular.Package
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
-- | Flag name. Consists of a package instance and the flag identifier itself.
data FN qpn = FN (PI qpn) Flag
......
......@@ -32,13 +32,14 @@ import qualified Distribution.Solver.Modular.PSQ as P
import qualified Distribution.Solver.Modular.ConflictSet as CS
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.ComponentDeps (Component)
{-------------------------------------------------------------------------------
Add linking
-------------------------------------------------------------------------------}
type RelatedGoals = Map (PN, I) [PP]
type RelatedGoals = Map (PN, I) [PackagePath]
type Linker = Reader RelatedGoals
-- | Introduce link nodes into tree tree
......@@ -80,7 +81,7 @@ linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReason) -> [(POption,
linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
map aux (M.findWithDefault [] (pn, i) related)
where
aux :: PP -> (POption, Tree QGoalReason)
aux :: PackagePath -> (POption, Tree QGoalReason)
aux pp = (POption i (Just pp), subtree)
linkChoices _ _ (POption _ (Just _), _) =
alreadyLinked
......@@ -224,7 +225,7 @@ pickConcrete qpn@(Q pp _) i = do
Just lg ->
makeCanonical lg qpn i
pickLink :: QPN -> I -> PP -> FlaggedDeps Component QPN -> UpdateState ()
pickLink :: QPN -> I -> PackagePath -> FlaggedDeps Component QPN -> UpdateState ()
pickLink qpn@(Q _pp pn) i pp' deps = do
vs <- get
......@@ -246,7 +247,7 @@ pickLink qpn@(Q _pp pn) i pp' deps = do
-- Verify here that the member we add is in fact for the same package and
-- matches the version of the canonical instance. However, violations of
-- these checks would indicate a bug in the linker, not a true conflict.
let sanityCheck :: Maybe (PI PP) -> Bool
let sanityCheck :: Maybe (PI PackagePath) -> Bool
sanityCheck Nothing = False
sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI
assert (sanityCheck (lgCanon lgTarget)) $ return ()
......@@ -476,10 +477,10 @@ data LinkGroup = LinkGroup {
--
-- We may not know this yet (if we are constructing link groups
-- for dependencies)
, lgCanon :: Maybe (PI PP)
, lgCanon :: Maybe (PI PackagePath)
-- | The members of the link group
, lgMembers :: Set PP
, lgMembers :: Set PackagePath
-- | The set of variables that should be added to the conflict set if
-- something goes wrong with this link set (in addition to the members
......@@ -509,7 +510,7 @@ showLinkGroup :: LinkGroup -> String
showLinkGroup lg =
"{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"
where
showMember :: PP -> String
showMember :: PackagePath -> String
showMember pp = case lgCanon lg of
Just (PI pp' _i) | pp == pp' -> "*"
_otherwise -> ""
......@@ -517,11 +518,11 @@ showLinkGroup lg =
Nothing -> showQPN (qpn pp)
Just i -> showPI (PI (qpn pp) i)
qpn :: PP -> QPN
qpn :: PackagePath -> QPN
qpn pp = Q pp (lgPackage lg)
-- | Creates a link group that contains a single member.
lgSingleton :: QPN -> Maybe (PI PP) -> LinkGroup
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
lgSingleton (Q pp pn) canon = LinkGroup {
lgPackage = pn
, lgCanon = canon
......
......@@ -11,11 +11,11 @@ import Control.Applicative
import Data.List as L
import Data.Maybe (isNothing)
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Progress
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Message
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree (FailReason(..))
import qualified Distribution.Solver.Modular.ConflictSet as CS
......
......@@ -16,6 +16,7 @@ import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
( FailReason(..), POption(..) )
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.Progress
data Message =
......
......@@ -7,28 +7,21 @@ module Distribution.Solver.Modular.Package
, PackageName(..)
, PI(..)
, PN
, PP(..)
, Namespace(..)
, Qualifier(..)
, QPN
, QPV
, Q(..)
, instI
, makeIndependent
, primaryPP
, showI
, showPI
, showQPN
, showPP
, unPN
) where
import Data.List as L
import Distribution.Package -- from Cabal
import Distribution.Text -- from Cabal
import Distribution.Solver.Modular.Version
import Distribution.Solver.Types.PackagePath
-- | A package name.
type PN = PackageName
......@@ -41,7 +34,7 @@ unPN (PackageName pn) = pn
type PV = PackageId
-- | Qualified package version.
type QPV = Q PV
type QPV = Qualified PV
-- | Package id. Currently just a black-box string.
type PId = UnitId
......@@ -83,94 +76,19 @@ instI :: I -> Bool
instI (I _ (Inst _)) = True
instI _ = False
-- | A package path consists of a namespace and a package path inside that
-- namespace.
data PP = PP Namespace Qualifier
deriving (Eq, Ord, Show)
-- | Top-level namespace
--
-- Package choices in different namespaces are considered completely independent
-- by the solver.
data Namespace =
-- | The default namespace
DefaultNamespace
-- | Independent namespace
--
-- For now we just number these (rather than giving them more structure).
| Independent Int
deriving (Eq, Ord, Show)
-- | Qualifier of a package within a namespace (see 'PP')
data Qualifier =
-- | Top-level dependency in this namespace
Unqualified
-- | Any dependency on base is considered independent
--
-- This makes it possible to have base shims.
| Base PN
-- | Setup dependency
--
-- By rights setup dependencies ought to be nestable; after all, the setup
-- dependencies of a package might themselves have setup dependencies, which
-- are independent from everything else. However, this very quickly leads to
-- infinite search trees in the solver. Therefore we limit ourselves to
-- a single qualifier (within a given namespace).
| Setup PN
deriving (Eq, Ord, Show)
-- | Is the package in the primary group of packages. In particular this
-- does not include packages pulled in as setup deps.
--
primaryPP :: PP -> Bool
primaryPP (PP _ns q) = go q
primaryPP :: PackagePath -> Bool
primaryPP (PackagePath _ns q) = go q
where
go Unqualified = True
go (Base _) = True
go (Setup _) = False
-- | String representation of a package path.
--
-- NOTE: The result of 'showPP' is either empty or results in a period, so that
-- it can be prepended to a package name.
showPP :: PP -> String
showPP (PP 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 (Base pn) = display pn ++ "."
-- | A qualified entity. Pairs a package path with the entity.
data Q a = Q PP a
deriving (Eq, Ord, Show)
-- | Standard string representation of a qualified entity.
showQ :: (a -> String) -> (Q a -> String)
showQ showa (Q pp x) = showPP pp ++ showa x
-- | Qualified package name.
type QPN = Q PN
-- | String representation of a qualified package path.
showQPN :: QPN -> String
showQPN = showQ display
-- | Create artificial parents for each of the package names, making
-- them all independent.
makeIndependent :: [PN] -> [QPN]
makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
, let pp = PP (Independent i) Unqualified
, let pp = PackagePath (Independent i) Unqualified
]
......@@ -33,6 +33,7 @@ import Distribution.Solver.Types.InstalledPreference
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Modular.Dependency
......@@ -126,7 +127,7 @@ preferPackageStanzaPreferences pcs = trav go
-- given instance for a P-node. Translates the constraint into a
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintP :: PP
processPackageConstraintP :: PackagePath
-> ConflictSet QPN
-> I
-> LabeledPackageConstraint
......@@ -309,8 +310,8 @@ deferSetupChoices = trav go
go x = x
noSetup :: Goal QPN -> Bool
noSetup (Goal (P (Q (PP _ns (Setup _)) _)) _) = False
noSetup _ = True
noSetup (Goal (P (Q (PackagePath _ns (Setup _)) _)) _) = False
noSetup _ = True
-- | Transformation that tries to avoid making weak flag choices early.
-- Weak flags are trivial flags (not influencing dependencies) or such
......
......@@ -14,6 +14,7 @@ import Data.Version
import Distribution.Compiler (CompilerInfo)
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PackagePreferences
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
import Distribution.Solver.Types.LabeledPackageConstraint
......@@ -206,5 +207,5 @@ _removeGR = trav go
dummy :: QGoalReason
dummy = PDependency
$ PI (Q (PP DefaultNamespace Unqualified) (PackageName "$"))
$ PI (Q (PackagePath DefaultNamespace Unqualified) (PackageName "$"))
(I (Version [1] []) InRepo)
......@@ -27,6 +27,7 @@ import Distribution.Solver.Modular.PSQ (PSQ)
import qualified Distribution.Solver.Modular.PSQ as P
import Distribution.Solver.Modular.Version
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.PackagePath
-- | Type of the search tree. Inlining the choice nodes for now.
data Tree a =
......@@ -90,7 +91,7 @@ data Tree a =
-- dependencies must also be the exact same).
--
-- See <http://www.well-typed.com/blog/2015/03/qualified-goals/> for details.
data POption = POption I (Maybe PP)
data POption = POption I (Maybe PackagePath)
deriving (Eq, Show)
data FailReason = InconsistentInitialConstraints
......
......@@ -31,6 +31,7 @@ import Distribution.Solver.Modular.Version (VR)
import Distribution.Solver.Types.ComponentDeps (Component)
import Distribution.Solver.Types.PackagePath
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent)
-- In practice, most constraints are implication constraints (IF we have made
......
......@@ -10,6 +10,7 @@ import Prelude hiding (pi)
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Package
import Distribution.Solver.Types.PackagePath
{-------------------------------------------------------------------------------
Variables
......
module Distribution.Solver.Types.PackagePath
( PackagePath(..)
, Namespace(..)
, Qualifier(..)
, QPN
, Qualified(..)
, showQPN
) where
import Distribution.Package
import Distribution.Text
-- | A package path consists of a namespace and a package path inside that
-- namespace.
data PackagePath = PackagePath Namespace Qualifier
deriving (Eq, Ord, Show)
-- | Top-level namespace
--
-- Package choices in different namespaces are considered completely independent
-- by the solver.
data Namespace =
-- | The default namespace
DefaultNamespace
-- | Independent namespace
--
-- For now we just number these (rather than giving them more structure).
| Independent Int
deriving (Eq, Ord, Show)
-- | Qualifier of a package within a namespace (see 'PackagePath')
data Qualifier =
-- | Top-level dependency in this namespace
Unqualified
-- | Any dependency on base is considered independent
--
-- This makes it possible to have base shims.
| Base PackageName
-- | Setup dependency
--
-- By rights setup dependencies ought to be nestable; after all, the setup
-- dependencies of a package might themselves have setup dependencies, which
-- are independent from everything else. However, this very quickly leads to
-- infinite search trees in the solver. Therefore we limit ourselves to
-- a single qualifier (within a given namespace).
| Setup PackageName
deriving (Eq, Ord, Show)
-- | String representation of a package path.
--
-- 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 (Base pn) = display pn ++ "."
-- | A qualified entity. Pairs a package path with the entity.
data Qualified a = Q PackagePath a
deriving (Eq, Ord, Show)
-- | Standard string representation of a qualified entity.
showQ :: (a -> String) -> (Qualified a -> String)
showQ showa (Q pp x) = showPP pp ++ showa x
-- | Qualified package name.
type QPN = Qualified PackageName
-- | String representation of a qualified package path.
showQPN :: QPN -> String
showQPN = showQ display
......@@ -272,6 +272,7 @@ executable cabal
Distribution.Solver.Types.PackageConstraint
Distribution.Solver.Types.PackageFixedDeps
Distribution.Solver.Types.PackageIndex
Distribution.Solver.Types.PackagePath
Distribution.Solver.Types.PackagePreferences
Distribution.Solver.Types.PkgConfigDb
Distribution.Solver.Types.Progress
......
Supports Markdown
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