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
8f32ab44
Commit
8f32ab44
authored
Jul 01, 2016
by
Mikhail Glushenkov
Committed by
GitHub
Jul 01, 2016
Browse files
Merge pull request #3510 from grayjay/issue-3489
Add a goal order parameter to the dependency solver
parents
efe23a9a
bfdcd7ee
Changes
9
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Client/Dependency.hs
View file @
8f32ab44
...
...
@@ -54,6 +54,7 @@ module Distribution.Client.Dependency (
setStrongFlags
,
setMaxBackjumps
,
setEnableBackjumping
,
setGoalOrder
,
addSourcePackages
,
hideInstalledPackagesSpecificByUnitId
,
hideInstalledPackagesSpecificBySourcePackageId
,
...
...
@@ -119,6 +120,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
qualified
Distribution.Solver.Types.PackageIndex
as
PackageIndex
import
Distribution.Solver.Types.PkgConfigDb
(
PkgConfigDb
)
...
...
@@ -128,6 +130,7 @@ import Distribution.Solver.Types.Settings
import
Distribution.Solver.Types.SolverId
import
Distribution.Solver.Types.SolverPackage
import
Distribution.Solver.Types.SourcePackage
import
Distribution.Solver.Types.Variable
import
Data.List
(
foldl'
,
sort
,
sortBy
,
nubBy
,
maximumBy
,
intercalate
,
nub
)
...
...
@@ -161,7 +164,10 @@ data DepResolverParams = DepResolverParams {
depResolverShadowPkgs
::
ShadowPkgs
,
depResolverStrongFlags
::
StrongFlags
,
depResolverMaxBackjumps
::
Maybe
Int
,
depResolverEnableBackjumping
::
EnableBackjumping
depResolverEnableBackjumping
::
EnableBackjumping
,
-- | Function to override the solver's goal-ordering heuristics.
depResolverGoalOrder
::
Maybe
(
Variable
QPN
->
Variable
QPN
->
Ordering
)
}
showDepResolverParams
::
DepResolverParams
->
String
...
...
@@ -233,7 +239,8 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
depResolverShadowPkgs
=
ShadowPkgs
False
,
depResolverStrongFlags
=
StrongFlags
False
,
depResolverMaxBackjumps
=
Nothing
,
depResolverEnableBackjumping
=
EnableBackjumping
True
depResolverEnableBackjumping
=
EnableBackjumping
True
,
depResolverGoalOrder
=
Nothing
}
addTargets
::
[
PackageName
]
...
...
@@ -308,6 +315,14 @@ setEnableBackjumping b params =
depResolverEnableBackjumping
=
b
}
setGoalOrder
::
Maybe
(
Variable
QPN
->
Variable
QPN
->
Ordering
)
->
DepResolverParams
->
DepResolverParams
setGoalOrder
order
params
=
params
{
depResolverGoalOrder
=
order
}
-- | Some packages are specific to a given compiler version and should never be
-- upgraded.
dontUpgradeNonUpgradeablePackages
::
DepResolverParams
->
DepResolverParams
...
...
@@ -607,7 +622,7 @@ resolveDependencies platform comp pkgConfigDB solver params =
Step
(
showDepResolverParams
finalparams
)
$
fmap
(
validateSolverResult
platform
comp
indGoals
)
$
runSolver
solver
(
SolverConfig
reorderGoals
indGoals
noReinstalls
shadowing
strFlags
maxBkjumps
enableBj
)
shadowing
strFlags
maxBkjumps
enableBj
order
)
platform
comp
installedPkgIndex
sourcePkgIndex
pkgConfigDB
preferences
constraints
targets
where
...
...
@@ -623,7 +638,8 @@ resolveDependencies platform comp pkgConfigDB solver params =
shadowing
strFlags
maxBkjumps
enableBj
)
=
dontUpgradeNonUpgradeablePackages
enableBj
order
)
=
dontUpgradeNonUpgradeablePackages
-- TODO:
-- The modular solver can properly deal with broken
-- packages and won't select them. So the
...
...
@@ -858,7 +874,7 @@ resolveWithoutDependencies :: DepResolverParams
resolveWithoutDependencies
(
DepResolverParams
targets
constraints
prefs
defpref
installedPkgIndex
sourcePkgIndex
_reorderGoals
_indGoals
_avoidReinstalls
_shadowing
_strFlags
_maxBjumps
_enableBj
)
=
_shadowing
_strFlags
_maxBjumps
_enableBj
_order
)
=
collectEithers
(
map
selectPackage
targets
)
where
selectPackage
::
PackageName
->
Either
ResolveNoDepsError
UnresolvedSourcePackage
...
...
cabal-install/Distribution/Solver/Modular/Dependency.hs
View file @
8f32ab44
...
...
@@ -35,6 +35,7 @@ module Distribution.Solver.Modular.Dependency (
,
GoalReason
(
..
)
,
QGoalReason
,
ResetVar
(
..
)
,
goalToVar
,
goalVarToConflictSet
,
varToConflictSet
,
goalReasonToVars
...
...
@@ -361,6 +362,9 @@ instance ResetVar Dep where
instance
ResetVar
Var
where
resetVar
=
const
goalToVar
::
Goal
a
->
Var
a
goalToVar
(
Goal
v
_
)
=
v
-- | Compute a singleton conflict set from a goal, containing just
-- the goal variable.
--
...
...
cabal-install/Distribution/Solver/Modular/Preference.hs
View file @
8f32ab44
...
...
@@ -13,10 +13,12 @@ module Distribution.Solver.Modular.Preference
,
preferPackagePreferences
,
preferReallyEasyGoalChoices
,
requireInstalled
,
sortGoals
)
where
-- Reordering or pruning the tree in order to prefer or make certain choices.
import
Data.Function
(
on
)
import
qualified
Data.List
as
L
import
qualified
Data.Map
as
M
#
if
!
MIN_VERSION_base
(
4
,
8
,
0
)
...
...
@@ -35,6 +37,7 @@ import Distribution.Solver.Types.OptionalStanza
import
Distribution.Solver.Types.PackageConstraint
import
Distribution.Solver.Types.PackagePath
import
Distribution.Solver.Types.PackagePreferences
import
Distribution.Solver.Types.Variable
import
Distribution.Solver.Modular.Dependency
import
Distribution.Solver.Modular.Flag
...
...
@@ -191,8 +194,8 @@ processPackageConstraintS s c b' (LabeledPackageConstraint pc src) r = go pc
-- by selectively disabling choices that have been ruled out by global user
-- constraints.
enforcePackageConstraints
::
M
.
Map
PN
[
LabeledPackageConstraint
]
->
Tree
QGoalReason
->
Tree
QGoalReason
->
Tree
a
->
Tree
a
enforcePackageConstraints
pcs
=
trav
go
where
go
(
PChoiceF
qpn
@
(
Q
pp
pn
)
gr
ts
)
=
...
...
@@ -220,7 +223,7 @@ enforcePackageConstraints pcs = trav go
-- be run after user preferences have been enforced. For manual flags,
-- it checks if a user choice has been made. If not, it disables all but
-- the first choice.
enforceManualFlags
::
Tree
QGoalReason
->
Tree
QGoalReason
enforceManualFlags
::
Tree
a
->
Tree
a
enforceManualFlags
=
trav
go
where
go
(
FChoiceF
qfn
gr
tr
True
ts
)
=
FChoiceF
qfn
gr
tr
True
$
...
...
@@ -234,7 +237,7 @@ enforceManualFlags = trav go
go
x
=
x
-- | Require installed packages.
requireInstalled
::
(
PN
->
Bool
)
->
Tree
QGoalReason
->
Tree
QGoalReason
requireInstalled
::
(
PN
->
Bool
)
->
Tree
a
->
Tree
a
requireInstalled
p
=
trav
go
where
go
(
PChoiceF
v
@
(
Q
_
pn
)
gr
cs
)
...
...
@@ -258,7 +261,7 @@ requireInstalled p = trav go
-- they are, perhaps this should just result in trying to reinstall those other
-- packages as well. However, doing this all neatly in one pass would require to
-- change the builder, or at least to change the goal set after building.
avoidReinstalls
::
(
PN
->
Bool
)
->
Tree
QGoalReason
->
Tree
QGoalReason
avoidReinstalls
::
(
PN
->
Bool
)
->
Tree
a
->
Tree
a
avoidReinstalls
p
=
trav
go
where
go
(
PChoiceF
qpn
@
(
Q
_
pn
)
gr
cs
)
...
...
@@ -275,6 +278,21 @@ avoidReinstalls p = trav go
x
go
x
=
x
-- | Sort all goals using the provided function.
sortGoals
::
(
Variable
QPN
->
Variable
QPN
->
Ordering
)
->
Tree
a
->
Tree
a
sortGoals
variableOrder
=
trav
go
where
go
(
GoalChoiceF
xs
)
=
GoalChoiceF
(
P
.
sortByKeys
goalOrder
xs
)
go
x
=
x
goalOrder
::
Goal
QPN
->
Goal
QPN
->
Ordering
goalOrder
=
variableOrder
`
on
`
(
varToVariable
.
goalToVar
)
varToVariable
::
Var
QPN
->
Variable
QPN
varToVariable
(
P
qpn
)
=
PackageVar
qpn
varToVariable
(
F
(
FN
(
PI
qpn
_
)
fn
))
=
FlagVar
qpn
fn
varToVariable
(
S
(
SN
(
PI
qpn
_
)
stanza
))
=
StanzaVar
qpn
stanza
-- | Always choose the first goal in the list next, abandoning all
-- other choices.
--
...
...
@@ -371,10 +389,10 @@ type EnforceSIR = Reader (Map (PI PN) QPN)
-- (that is, package name + package version) there can be at most one qualified
-- goal resolving to that instance (there may be other goals _linking_ to that
-- instance however).
enforceSingleInstanceRestriction
::
Tree
QGoalReason
->
Tree
QGoalReason
enforceSingleInstanceRestriction
::
Tree
a
->
Tree
a
enforceSingleInstanceRestriction
=
(`
runReader
`
M
.
empty
)
.
cata
go
where
go
::
TreeF
QGoalReason
(
EnforceSIR
(
Tree
QGoalReason
))
->
EnforceSIR
(
Tree
QGoalReason
)
go
::
TreeF
a
(
EnforceSIR
(
Tree
a
))
->
EnforceSIR
(
Tree
a
)
-- We just verify package choices.
go
(
PChoiceF
qpn
gr
cs
)
=
...
...
@@ -383,7 +401,7 @@ enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go
innM
_otherwise
-- The check proper
goP
::
QPN
->
POption
->
EnforceSIR
(
Tree
QGoalReason
)
->
EnforceSIR
(
Tree
QGoalReason
)
goP
::
QPN
->
POption
->
EnforceSIR
(
Tree
a
)
->
EnforceSIR
(
Tree
a
)
goP
qpn
@
(
Q
_
pn
)
(
POption
i
linkedTo
)
r
=
do
let
inst
=
PI
pn
i
env
<-
ask
...
...
cabal-install/Distribution/Solver/Modular/Solver.hs
View file @
8f32ab44
...
...
@@ -19,6 +19,7 @@ import Distribution.Solver.Types.PackagePreferences
import
Distribution.Solver.Types.PkgConfigDb
(
PkgConfigDb
)
import
Distribution.Solver.Types.LabeledPackageConstraint
import
Distribution.Solver.Types.Settings
import
Distribution.Solver.Types.Variable
import
Distribution.Solver.Modular.Assignment
import
Distribution.Solver.Modular.Builder
...
...
@@ -56,7 +57,8 @@ data SolverConfig = SolverConfig {
shadowPkgs
::
ShadowPkgs
,
strongFlags
::
StrongFlags
,
maxBackjumps
::
Maybe
Int
,
enableBackjumping
::
EnableBackjumping
enableBackjumping
::
EnableBackjumping
,
goalOrder
::
Maybe
(
Variable
QPN
->
Variable
QPN
->
Ordering
)
}
-- | Run all solver phases.
...
...
@@ -103,15 +105,22 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
where
explorePhase
=
backjumpAndExplore
(
enableBackjumping
sc
)
detectCycles
=
traceTree
"cycles.json"
id
.
detectCyclesPhase
heuristicsPhase
=
(
if
asBool
(
preferEasyGoalChoices
sc
)
then
P
.
preferEasyGoalChoices
-- also leaves just one choice
else
P
.
firstGoal
)
.
-- after doing goal-choice heuristics, commit to the first choice (saves space)
traceTree
"heuristics.json"
id
.
P
.
deferWeakFlagChoices
.
P
.
deferSetupChoices
.
P
.
preferBaseGoalChoice
.
P
.
preferLinked
preferencesPhase
=
P
.
preferPackagePreferences
userPrefs
heuristicsPhase
=
let
heuristicsTree
=
traceTree
"heuristics.json"
id
in
case
goalOrder
sc
of
Nothing
->
(
if
asBool
(
preferEasyGoalChoices
sc
)
then
P
.
preferEasyGoalChoices
-- also leaves just one choice
else
P
.
firstGoal
)
.
-- after doing goal-choice heuristics,
-- commit to the first choice (saves space)
heuristicsTree
.
P
.
deferWeakFlagChoices
.
P
.
deferSetupChoices
.
P
.
preferBaseGoalChoice
Just
order
->
P
.
firstGoal
.
heuristicsTree
.
P
.
sortGoals
order
preferencesPhase
=
P
.
preferLinked
.
P
.
preferPackagePreferences
userPrefs
validationPhase
=
traceTree
"validated.json"
id
.
P
.
enforceManualFlags
.
-- can only be done after user constraints
P
.
enforcePackageConstraints
userConstraints
.
...
...
cabal-install/Distribution/Solver/Types/Variable.hs
0 → 100644
View file @
8f32ab44
module
Distribution.Solver.Types.Variable
where
import
Distribution.Solver.Types.OptionalStanza
import
Distribution.PackageDescription
(
FlagName
)
-- | Variables used by the dependency solver. This type is similar to the
-- internal 'Var' type, except that flags and stanzas are associated with
-- package names instead of package instances.
data
Variable
qpn
=
PackageVar
qpn
|
FlagVar
qpn
FlagName
|
StanzaVar
qpn
OptionalStanza
deriving
Eq
cabal-install/cabal-install.cabal
View file @
8f32ab44
...
...
@@ -281,6 +281,7 @@ executable cabal
Distribution.Solver.Types.SolverId
Distribution.Solver.Types.SolverPackage
Distribution.Solver.Types.SourcePackage
Distribution.Solver.Types.Variable
Distribution.Solver.Modular
Distribution.Solver.Modular.Assignment
Distribution.Solver.Modular.Builder
...
...
cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
View file @
8f32ab44
...
...
@@ -11,6 +11,8 @@ module UnitTests.Distribution.Solver.Modular.DSL (
,
ExamplePkgName
,
ExampleAvailable
(
..
)
,
ExampleInstalled
(
..
)
,
ExampleQualifier
(
..
)
,
ExampleVar
(
..
)
,
exAv
,
exInst
,
exFlag
...
...
@@ -23,9 +25,10 @@ module UnitTests.Distribution.Solver.Modular.DSL (
-- base
import
Data.Either
(
partitionEithers
)
import
Data.Maybe
(
catMaybes
)
import
Data.List
(
nub
)
import
Data.Maybe
(
catMaybes
,
isNothing
)
import
Data.List
(
elemIndex
,
nub
)
import
Data.Monoid
import
Data.Ord
(
comparing
)
import
Data.Version
import
qualified
Data.Map
as
Map
...
...
@@ -52,10 +55,12 @@ import Distribution.Solver.Types.ConstraintSource
import
Distribution.Solver.Types.LabeledPackageConstraint
import
Distribution.Solver.Types.OptionalStanza
import
qualified
Distribution.Solver.Types.PackageIndex
as
CI.PackageIndex
import
qualified
Distribution.Solver.Types.PackagePath
as
P
import
qualified
Distribution.Solver.Types.PkgConfigDb
as
PC
import
Distribution.Solver.Types.Settings
import
Distribution.Solver.Types.SolverPackage
import
Distribution.Solver.Types.SourcePackage
import
Distribution.Solver.Types.Variable
{-------------------------------------------------------------------------------
Example package database DSL
...
...
@@ -143,6 +148,17 @@ data ExampleAvailable = ExAv {
,
exAvDeps
::
ComponentDeps
[
ExampleDependency
]
}
deriving
Show
data
ExampleVar
=
P
ExampleQualifier
ExamplePkgName
|
F
ExampleQualifier
ExamplePkgName
ExampleFlagName
|
S
ExampleQualifier
ExamplePkgName
OptionalStanza
data
ExampleQualifier
=
None
|
Indep
Int
|
Setup
ExamplePkgName
|
IndepSetup
Int
ExamplePkgName
-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',
-- given:
--
...
...
@@ -398,10 +414,11 @@ exResolve :: ExampleDb
->
IndependentGoals
->
ReorderGoals
->
EnableBackjumping
->
Maybe
[
ExampleVar
]
->
[
ExPreference
]
->
([
String
],
Either
String
CI
.
InstallPlan
.
SolverInstallPlan
)
exResolve
db
exts
langs
pkgConfigDb
targets
solver
mbj
indepGoals
reorder
enableBj
prefs
enableBj
vars
prefs
=
runProgress
$
resolveDependencies
C
.
buildPlatform
compiler
pkgConfigDb
solver
...
...
@@ -427,10 +444,34 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
$
setReorderGoals
reorder
$
setMaxBackjumps
mbj
$
setEnableBackjumping
enableBj
$
setGoalOrder
goalOrder
$
standardInstallPolicy
instIdx
avaiIdx
targets'
toLpc
pc
=
LabeledPackageConstraint
pc
ConstraintSourceUnknown
toPref
(
ExPref
n
v
)
=
PackageVersionPreference
(
C
.
PackageName
n
)
v
goalOrder
::
Maybe
(
Variable
P
.
QPN
->
Variable
P
.
QPN
->
Ordering
)
goalOrder
=
(
orderFromList
.
map
toVariable
)
`
fmap
`
vars
-- Sort elements in the list ahead of elements not in the list. Otherwise,
-- follow the order in the list.
orderFromList
::
Eq
a
=>
[
a
]
->
a
->
a
->
Ordering
orderFromList
xs
=
comparing
$
\
x
->
let
i
=
elemIndex
x
xs
in
(
isNothing
i
,
i
)
toVariable
::
ExampleVar
->
Variable
P
.
QPN
toVariable
(
P
q
pn
)
=
PackageVar
(
toQPN
q
pn
)
toVariable
(
F
q
pn
fn
)
=
FlagVar
(
toQPN
q
pn
)
(
C
.
FlagName
fn
)
toVariable
(
S
q
pn
stanza
)
=
StanzaVar
(
toQPN
q
pn
)
stanza
toQPN
::
ExampleQualifier
->
ExamplePkgName
->
P
.
QPN
toQPN
q
pn
=
P
.
Q
pp
(
C
.
PackageName
pn
)
where
pp
=
case
q
of
None
->
P
.
PackagePath
P
.
DefaultNamespace
P
.
Unqualified
Indep
x
->
P
.
PackagePath
(
P
.
Independent
x
)
P
.
Unqualified
Setup
p
->
P
.
PackagePath
P
.
DefaultNamespace
(
P
.
Setup
(
C
.
PackageName
p
))
IndepSetup
x
p
->
P
.
PackagePath
(
P
.
Independent
x
)
(
P
.
Setup
(
C
.
PackageName
p
))
extractInstallPlan
::
CI
.
InstallPlan
.
SolverInstallPlan
->
[(
ExamplePkgName
,
ExamplePkgVersion
)]
extractInstallPlan
=
catMaybes
.
map
confPkg
.
CI
.
InstallPlan
.
toList
...
...
cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs
View file @
8f32ab44
...
...
@@ -102,7 +102,7 @@ solve enableBj reorder indep solver targets (TestDb db) =
-- The backjump limit prevents individual tests from using
-- too much time and memory.
(
Just
defaultMaxBackjumps
)
indep
reorder
enableBj
[]
indep
reorder
enableBj
Nothing
[]
failure
::
String
->
Failure
failure
msg
...
...
@@ -223,12 +223,12 @@ arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency])
arbitraryComponentDep
db
=
do
comp
<-
arbitrary
deps
<-
case
comp
of
ComponentSetup
->
smallListOf
(
arbitraryExDep
db
Setup
)
_
->
boundedListOf
5
(
arbitraryExDep
db
NonSetup
)
ComponentSetup
->
smallListOf
(
arbitraryExDep
db
Setup
Dep
)
_
->
boundedListOf
5
(
arbitraryExDep
db
NonSetup
Dep
)
return
(
comp
,
deps
)
-- | Location of an 'ExampleDependency'. It determines which values are valid.
data
ExDepLocation
=
Setup
|
NonSetup
data
ExDepLocation
=
Setup
Dep
|
NonSetup
Dep
arbitraryExDep
::
TestDb
->
ExDepLocation
->
Gen
ExampleDependency
arbitraryExDep
db
@
(
TestDb
pkgs
)
level
=
...
...
@@ -247,13 +247,13 @@ arbitraryExDep db@(TestDb pkgs) level =
]
in
oneof
$
case
level
of
NonSetup
->
flag
:
other
Setup
->
other
NonSetup
Dep
->
flag
:
other
Setup
Dep
->
other
arbitraryDeps
::
TestDb
->
Gen
Dependencies
arbitraryDeps
db
=
frequency
[
(
1
,
return
NotBuildable
)
,
(
20
,
Buildable
<$>
smallListOf
(
arbitraryExDep
db
NonSetup
))
,
(
20
,
Buildable
<$>
smallListOf
(
arbitraryExDep
db
NonSetup
Dep
))
]
arbitraryFlagName
::
Gen
String
...
...
cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
View file @
8f32ab44
...
...
@@ -18,6 +18,7 @@ import Language.Haskell.Extension ( Extension(..)
,
KnownExtension
(
..
),
Language
(
..
))
-- cabal-install
import
Distribution.Solver.Types.OptionalStanza
import
Distribution.Solver.Types.PkgConfigDb
(
PkgConfigDb
,
pkgConfigDbFromList
)
import
Distribution.Solver.Types.Settings
import
Distribution.Client.Dependency.Types
...
...
@@ -133,9 +134,9 @@ tests = [
]
,
testGroup
"Independent goals"
[
runTest
$
indep
$
mkTest
db16
"indepGoals1"
[
"A"
,
"B"
]
(
SolverSuccess
[(
"A"
,
1
),
(
"B"
,
1
),
(
"C"
,
1
),
(
"D"
,
1
),
(
"D"
,
2
),
(
"E"
,
1
)])
,
runTest
$
indep
$
mkTest
db17
"indepGoals2"
[
"A"
,
"B"
]
(
SolverSuccess
[(
"A"
,
1
),
(
"B"
,
1
),
(
"C"
,
1
),
(
"D"
,
1
)])
,
runTest
$
indep
$
mkTest
db19
"indepGoals3"
[
"D"
,
"E"
,
"F"
]
anySolverFailure
-- The target order is important.
,
runTest
$
indep
$
mkTest
db20
"indepGoals4"
[
"C"
,
"A"
,
"B"
]
(
SolverSuccess
[(
"A"
,
1
),
(
"B"
,
1
),
(
"C"
,
1
),
(
"D"
,
1
),
(
"D"
,
2
)])
,
runTest
$
testIndepGoals2
"indepGoals2"
,
runTest
$
testIndepGoals3
"indepGoals3"
,
runTest
$
testIndepGoals4
"indepGoals4"
,
runTest
$
indep
$
mkTest
db23
"indepGoals5"
[
"X"
,
"Y"
]
(
SolverSuccess
[(
"A"
,
1
),
(
"A"
,
2
),
(
"B"
,
1
),
(
"C"
,
1
),
(
"C"
,
2
),
(
"X"
,
1
),
(
"Y"
,
1
)])
,
runTest
$
indep
$
mkTest
db24
"indepGoals6"
[
"X"
,
"Y"
]
(
SolverSuccess
[(
"A"
,
1
),
(
"A"
,
2
),
(
"B"
,
1
),
(
"B"
,
2
),
(
"X"
,
1
),
(
"Y"
,
1
)])
]
...
...
@@ -154,15 +155,20 @@ tests = [
]
]
where
-- | Combinator to turn on --independent-goals behavior, i.e. solve
-- for the goals as if we were solving for each goal independently.
-- (This doesn't really work well at the moment, see #2842)
indep
test
=
test
{
testIndepGoals
=
IndependentGoals
True
}
soft
prefs
test
=
test
{
testSoftConstraints
=
prefs
}
mkvrThis
=
V
.
thisVersion
.
makeV
mkvrOrEarlier
=
V
.
orEarlierVersion
.
makeV
makeV
v
=
V
.
Version
[
v
,
0
,
0
]
[]
-- | Combinator to turn on --independent-goals behavior, i.e. solve
-- for the goals as if we were solving for each goal independently.
-- (This doesn't really work well at the moment, see #2842)
indep
::
SolverTest
->
SolverTest
indep
test
=
test
{
testIndepGoals
=
IndependentGoals
True
}
goalOrder
::
[
ExampleVar
]
->
SolverTest
->
SolverTest
goalOrder
order
test
=
test
{
testGoalOrder
=
Just
order
}
{-------------------------------------------------------------------------------
Solver tests
-------------------------------------------------------------------------------}
...
...
@@ -172,6 +178,7 @@ data SolverTest = SolverTest {
,
testTargets
::
[
String
]
,
testResult
::
SolverResult
,
testIndepGoals
::
IndependentGoals
,
testGoalOrder
::
Maybe
[
ExampleVar
]
,
testSoftConstraints
::
[
ExPreference
]
,
testDb
::
ExampleDb
,
testSupportedExts
::
Maybe
[
Extension
]
...
...
@@ -246,6 +253,7 @@ mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest {
,
testTargets
=
targets
,
testResult
=
result
,
testIndepGoals
=
IndependentGoals
False
,
testGoalOrder
=
Nothing
,
testSoftConstraints
=
[]
,
testDb
=
db
,
testSupportedExts
=
exts
...
...
@@ -259,7 +267,7 @@ runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
let
(
_msgs
,
result
)
=
exResolve
testDb
testSupportedExts
testSupportedLangs
testPkgConfigDb
testTargets
Modular
Nothing
testIndepGoals
(
ReorderGoals
False
)
(
EnableBackjumping
True
)
testSoftConstraints
(
EnableBackjumping
True
)
testGoalOrder
testSoftConstraints
when
showSolverLog
$
mapM_
putStrLn
_msgs
case
result
of
Left
err
->
assertBool
(
"Unexpected error:
\n
"
++
err
)
(
check
testResult
err
)
...
...
@@ -602,23 +610,41 @@ db16 = [
,
Right
$
exAv
"E"
1
[]
]
-- | This
database
checks that when the solver discovers a constraint on a
-- | This
test
checks that when the solver discovers a constraint on a
-- package's version after choosing to link that package, it can backtrack to
-- try alternative versions for the linked-to package. See pull request #3327.
--
-- When A and B are installed as independent goals, their dependencies on C
-- must be linked. Since C depends on D, A and B's dependencies on D must also
-- be linked. This test relies on the fact that the solver chooses D-2 for both
-- 0.D and 1.D before it encounters the test suites' constraints. The solver
-- must backtrack to try D-1 for both 0.D and 1.D.
db17
::
ExampleDb
db17
=
[
Right
$
exAv
"A"
1
[
ExAny
"C"
]
`
withTest
`
ExTest
"test"
[
ExFix
"D"
1
]
,
Right
$
exAv
"B"
1
[
ExAny
"C"
]
`
withTest
`
ExTest
"test"
[
ExFix
"D"
1
]
,
Right
$
exAv
"C"
1
[
ExAny
"D"
]
,
Right
$
exAv
"D"
1
[]
,
Right
$
exAv
"D"
2
[]
]
-- be linked. This test fixes the goal order so that the solver chooses D-2 for
-- both 0.D and 1.D before it encounters the test suites' constraints. The
-- solver must backtrack to try D-1 for both 0.D and 1.D.
testIndepGoals2
::
String
->
SolverTest
testIndepGoals2
name
=
goalOrder
goals
$
indep
$
mkTest
db
name
[
"A"
,
"B"
]
$
SolverSuccess
[(
"A"
,
1
),
(
"B"
,
1
),
(
"C"
,
1
),
(
"D"
,
1
)]
where
db
::
ExampleDb
db
=
[
Right
$
exAv
"A"
1
[
ExAny
"C"
]
`
withTest
`
ExTest
"test"
[
ExFix
"D"
1
]
,
Right
$
exAv
"B"
1
[
ExAny
"C"
]
`
withTest
`
ExTest
"test"
[
ExFix
"D"
1
]
,
Right
$
exAv
"C"
1
[
ExAny
"D"
]
,
Right
$
exAv
"D"
1
[]
,
Right
$
exAv
"D"
2
[]
]
goals
::
[
ExampleVar
]
goals
=
[
P
(
Indep
0
)
"A"
,
P
(
Indep
0
)
"C"
,
P
(
Indep
0
)
"D"
,
P
(
Indep
1
)
"B"
,
P
(
Indep
1
)
"C"
,
P
(
Indep
1
)
"D"
,
S
(
Indep
1
)
"B"
TestStanzas
,
S
(
Indep
0
)
"A"
TestStanzas
]
-- | Issue #2834
-- When both A and B are installed as independent goals, their dependencies on
...
...
@@ -676,34 +702,76 @@ db18 = [
-- > \ | \ / | /
-- > \| V |/
-- > D F E
db19
::
ExampleDb
db19
=
[
Right
$
exAv
"A"
1
[
ExAny
"C"
]
,
Right
$
exAv
"B"
1
[
ExAny
"C"
]
,
Right
$
exAv
"C"
1
[]
,
Right
$
exAv
"C"
2
[]
,
Right
$
exAv
"D"
1
[
ExAny
"A"
,
ExFix
"C"
1
]
,
Right
$
exAv
"E"
1
[
ExAny
"B"
,
ExFix
"C"
2
]
,
Right
$
exAv
"F"
1
[
ExAny
"A"
,
ExAny
"B"
]
]
testIndepGoals3
::
String
->
SolverTest
testIndepGoals3
name
=
goalOrder
goals
$
indep
$
mkTest
db
name
[
"D"
,
"E"
,
"F"
]
anySolverFailure
where
db
::
ExampleDb
db
=
[
Right
$
exAv
"A"
1
[
ExAny
"C"
]
,
Right
$
exAv
"B"
1
[
ExAny
"C"
]
,
Right
$
exAv
"C"
1
[]
,
Right
$
exAv
"C"
2
[]
,
Right
$
exAv
"D"
1
[
ExAny
"A"
,
ExFix
"C"
1
]
,
Right
$
exAv
"E"
1
[
ExAny
"B"
,
ExFix
"C"
2
]
,
Right
$
exAv
"F"
1
[
ExAny
"A"
,
ExAny
"B"
]
]
goals
::
[
ExampleVar
]
goals
=
[
P
(
Indep
0
)
"D"
,
P
(
Indep
0
)
"C"
,
P
(
Indep
0
)
"A"
,
P
(
Indep
1
)
"E"
,
P
(
Indep
1
)
"C"
,
P
(
Indep
1
)
"B"
,
P
(
Indep
2
)
"F"
,
P
(
Indep
2
)
"B"
,
P
(
Indep
2
)
"C"
,
P
(
Indep
2
)
"A"
]
-- | This
database test
s that the solver correctly backjumps when dependencies
-- | This
test check
s that the solver correctly backjumps when dependencies
-- of linked packages are not linked. It is an example where the conflict set