Commit 62c31614 authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Merge pull request #3220 from edsko/pr/LimitQualifierDepth

Limit qualifier depth
parents bc0080f7 3d2ad8e0
......@@ -180,4 +180,4 @@ buildTree idx ind igs =
topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]
qpns | ind = makeIndependent igs
| otherwise = L.map (Q None) igs
| otherwise = L.map (Q (PP DefaultNamespace Unqualified)) igs
......@@ -237,12 +237,8 @@ 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' pn) = go
qualifyDeps QO{..} (Q pp@(PP ns q) pn) = go
where
-- The Base qualifier does not get inherited
pp :: PP
pp = (if qoBaseShim then stripBase else id) pp'
go :: FlaggedDeps Component PN -> FlaggedDeps Component QPN
go = map go1
......@@ -264,9 +260,22 @@ qualifyDeps QO{..} (Q pp' pn) = go
goD (Lang lang) _ = Lang lang
goD (Pkg pkn vr) _ = Pkg pkn vr
goD (Dep dep ci) comp
| qBase dep = Dep (Q (Base pn pp) dep) (fmap (Q pp) ci)
| qSetup comp = Dep (Q (Setup pn pp) dep) (fmap (Q pp) ci)
| otherwise = Dep (Q pp dep) (fmap (Q pp) ci)
| 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)
-- 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
-- dependency on R. We do not do this for the base qualifier however.
--
-- The inherited qualifier is only used for regular dependencies; for setup
-- and base deppendencies we override the existing qualifier. See #3160 for
-- a detailed discussion.
inheritedQ :: Qualifier
inheritedQ = case q of
Setup _ -> q
Unqualified -> q
Base _ -> Unqualified
-- Should we qualify this goal with the 'Base' package path?
qBase :: PN -> Bool
......
......@@ -8,6 +8,8 @@ module Distribution.Client.Dependency.Modular.Package
, PI(..)
, PN
, PP(..)
, Namespace(..)
, Qualifier(..)
, QPN
, QPV
, Q(..)
......@@ -17,7 +19,6 @@ module Distribution.Client.Dependency.Modular.Package
, showI
, showPI
, showQPN
, stripBase
, unPN
) where
......@@ -81,46 +82,75 @@ instI :: I -> Bool
instI (I _ (Inst _)) = True
instI _ = False
-- | Package path.
--
-- Stored in reverse order
data PP =
-- User-specified independent goal
Independent Int PP
-- Setup dependencies are always considered independent from their package
| Setup PN PP
-- Any dependency on base is considered independent (allows for base shims)
| Base PN PP
-- Unqualified
| None
-- | A package path consists of a namespace and a package path inside that
-- namespace.
data PP = PP Namespace Qualifier
deriving (Eq, Ord, Show)
-- | Strip any 'Base' qualifiers from a PP
-- | Top-level namespace
--
-- (the Base qualifier does not get inherited)
stripBase :: PP -> PP
stripBase (Independent i pp) = Independent i (stripBase pp)
stripBase (Setup pn pp) = Setup pn (stripBase pp)
stripBase (Base _pn pp) = stripBase pp
stripBase None = None
-- 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 (Independent _ pp) = primaryPP pp
primaryPP (Setup _ _ ) = False
primaryPP (Base _ pp) = primaryPP pp
primaryPP None = True
primaryPP (PP _ns q) = go q
where
go Unqualified = True
go (Base _) = True
go (Setup _) = False
-- | String representation of a package path.
--
-- NOTE: This always ends in a period
-- 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 (Independent i pp) = show i ++ "." ++ showPP pp
showPP (Setup pn pp) = display pn ++ "-setup" ++ "." ++ showPP pp
showPP (Base pn pp) = display pn ++ "." ++ showPP pp
showPP None = ""
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
......@@ -128,8 +158,7 @@ data Q a = Q PP a
-- | Standard string representation of a qualified entity.
showQ :: (a -> String) -> (Q a -> String)
showQ showa (Q None x) = showa x
showQ showa (Q pp x) = showPP pp ++ showa x
showQ showa (Q pp x) = showPP pp ++ showa x
-- | Qualified package name.
type QPN = Q PN
......@@ -142,5 +171,5 @@ showQPN = showQ display
-- them all independent.
makeIndependent :: [PN] -> [QPN]
makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
, let pp = Independent i None
, let pp = PP (Independent i) Unqualified
]
......@@ -308,8 +308,8 @@ deferSetupChoices = trav go
go x = x
noSetup :: OpenGoal comp -> Bool
noSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = False
noSetup _ = True
noSetup (OpenGoal (Simple (Dep (Q (PP _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
......
......@@ -75,9 +75,14 @@ tests = [
, runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])
]
, testGroup "Cycles" [
runTest $ mkTest db14 "simpleCycle1" ["A"] Nothing
, runTest $ mkTest db14 "simpleCycle2" ["A", "B"] Nothing
, runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (Just [("C", 1), ("E", 1)])
runTest $ mkTest db14 "simpleCycle1" ["A"] Nothing
, runTest $ mkTest db14 "simpleCycle2" ["A", "B"] Nothing
, runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (Just [("C", 1), ("E", 1)])
, runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] Nothing
, runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] Nothing
, runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (Just [("C", 2), ("D", 1)])
, runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (Just [("D", 1)])
, runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (Just [("C", 2), ("D", 1), ("E", 1)])
]
, testGroup "Extensions" [
runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing
......@@ -479,6 +484,29 @@ db14 = [
, Right $ exAv "E" 1 []
]
-- | Cycles through setup dependencies
--
-- The first cycle is unsolvable: package A has a setup dependency on B,
-- B has a regular dependency on A, and we only have a single version available
-- for both.
--
-- The second cycle can be broken by picking different versions: package C-2.0
-- has a setup dependency on D, and D has a regular dependency on C-*. However,
-- version C-1.0 is already available (perhaps it didn't have this setup dep).
-- Thus, we should be able to break this cycle even if we are installing package
-- E, which explictly depends on C-2.0.
db15 :: ExampleDb
db15 = [
-- First example (real cycle, no solution)
Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"]
, Right $ exAv "B" 1 [ExAny "A"]
-- Second example (cycle can be broken by picking versions carefully)
, Left $ exInst "C" 1 "C-1-inst" []
, Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"]
, Right $ exAv "D" 1 [ExAny "C" ]
, Right $ exAv "E" 1 [ExFix "C" 2]
]
dbExts1 :: ExampleDb
dbExts1 = [
Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]
......
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