Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
62c31614
Commit
62c31614
authored
Apr 04, 2016
by
Mikhail Glushenkov
Browse files
Merge pull request #3220 from edsko/pr/LimitQualifierDepth
Limit qualifier depth
parents
bc0080f7
3d2ad8e0
Changes
5
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
View file @
62c31614
...
...
@@ -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
cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
View file @
62c31614
...
...
@@ -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
...
...
cabal-install/Distribution/Client/Dependency/Modular/Package.hs
View file @
62c31614
...
...
@@ -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
]
cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
View file @
62c31614
...
...
@@ -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
...
...
cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs
View file @
62c31614
...
...
@@ -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
)]
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment