Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
Packages
Cabal
Commits
32cae609
Commit
32cae609
authored
Dec 04, 2016
by
Mikhail Glushenkov
Committed by
GitHub
Dec 04, 2016
Browse files
Merge pull request #4151 from haskell/fmthoma/refactor-conflict-set
Migrate ConflictSet qpn ↦ ConflictSet
parents
1b8f375a
68695045
Changes
11
Hide whitespace changes
Inline
Side-by-side
cabal-install/Distribution/Solver/Modular/Assignment.hs
View file @
32cae609
...
...
@@ -67,12 +67,12 @@ extend :: (Extension -> Bool) -- ^ is a given extension supported
->
(
Language
->
Bool
)
-- ^ is a given language supported
->
(
PkgconfigName
->
VR
->
Bool
)
-- ^ is a given pkg-config requirement satisfiable
->
Var
QPN
->
PPreAssignment
->
[
Dep
QPN
]
->
Either
(
ConflictSet
QPN
,
[
Dep
QPN
])
PPreAssignment
->
PPreAssignment
->
[
Dep
QPN
]
->
Either
(
ConflictSet
,
[
Dep
QPN
])
PPreAssignment
extend
extSupported
langSupported
pkgPresent
var
=
foldM
extendSingle
where
extendSingle
::
PPreAssignment
->
Dep
QPN
->
Either
(
ConflictSet
QPN
,
[
Dep
QPN
])
PPreAssignment
->
Either
(
ConflictSet
,
[
Dep
QPN
])
PPreAssignment
extendSingle
a
(
Ext
ext
)
=
if
extSupported
ext
then
Right
a
else
Left
(
varToConflictSet
var
,
[
Ext
ext
])
...
...
cabal-install/Distribution/Solver/Modular/ConflictSet.hs
View file @
32cae609
...
...
@@ -48,9 +48,9 @@ import Distribution.Solver.Types.PackagePath
--
-- Since these variables should be preprocessed in some way, this type is
-- kept abstract.
data
ConflictSet
qpn
=
CS
{
data
ConflictSet
=
CS
{
-- | The set of variables involved on the conflict
conflictSetToSet
::
Set
(
Var
qpn
)
conflictSetToSet
::
Set
(
Var
QPN
)
#
ifdef
DEBUG_CONFLICT_SETS
-- | The origin of the conflict set
...
...
@@ -68,16 +68,16 @@ data ConflictSet qpn = CS {
}
deriving
(
Show
)
instance
Eq
qpn
=>
Eq
(
ConflictSet
qpn
)
where
instance
Eq
ConflictSet
where
(
==
)
=
(
==
)
`
on
`
conflictSetToSet
instance
Ord
qpn
=>
Ord
(
ConflictSet
qpn
)
where
instance
Ord
ConflictSet
where
compare
=
compare
`
on
`
conflictSetToSet
showCS
::
ConflictSet
QPN
->
String
showCS
::
ConflictSet
->
String
showCS
=
intercalate
", "
.
map
showVar
.
toList
showCSWithFrequency
::
ConflictMap
->
ConflictSet
QPN
->
String
showCSWithFrequency
::
ConflictMap
->
ConflictSet
->
String
showCSWithFrequency
cm
=
intercalate
", "
.
map
showWithFrequency
.
indexByFrequency
where
indexByFrequency
=
sortBy
(
flip
compare
`
on
`
snd
)
.
map
(
\
c
->
(
c
,
M
.
lookup
c
cm
))
.
toList
...
...
@@ -89,14 +89,14 @@ showCSWithFrequency cm = intercalate ", " . map showWithFrequency . indexByFrequ
Set-like operations
-------------------------------------------------------------------------------}
toList
::
ConflictSet
qpn
->
[
Var
qpn
]
toList
::
ConflictSet
->
[
Var
QPN
]
toList
=
S
.
toList
.
conflictSetToSet
union
::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
Ord
qpn
=>
ConflictSet
qpn
->
ConflictSet
qpn
->
ConflictSet
qpn
ConflictSet
->
ConflictSet
->
ConflictSet
union
cs
cs'
=
CS
{
conflictSetToSet
=
S
.
union
(
conflictSetToSet
cs
)
(
conflictSetToSet
cs'
)
#
ifdef
DEBUG_CONFLICT_SETS
...
...
@@ -108,7 +108,7 @@ unions ::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
Ord
qpn
=>
[
ConflictSet
qpn
]
->
ConflictSet
qpn
[
ConflictSet
]
->
ConflictSet
unions
css
=
CS
{
conflictSetToSet
=
S
.
unions
(
map
conflictSetToSet
css
)
#
ifdef
DEBUG_CONFLICT_SETS
...
...
@@ -120,7 +120,7 @@ insert ::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
Ord
qpn
=>
Var
qpn
->
ConflictSet
qpn
->
ConflictSet
qpn
Var
QPN
->
ConflictSet
->
ConflictSet
insert
var
cs
=
CS
{
conflictSetToSet
=
S
.
insert
(
simplifyVar
var
)
(
conflictSetToSet
cs
)
#
ifdef
DEBUG_CONFLICT_SETS
...
...
@@ -132,7 +132,7 @@ empty ::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
ConflictSet
qpn
ConflictSet
empty
=
CS
{
conflictSetToSet
=
S
.
empty
#
ifdef
DEBUG_CONFLICT_SETS
...
...
@@ -144,7 +144,7 @@ singleton ::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
Var
qpn
->
ConflictSet
qpn
Var
QPN
->
ConflictSet
singleton
var
=
CS
{
conflictSetToSet
=
S
.
singleton
(
simplifyVar
var
)
#
ifdef
DEBUG_CONFLICT_SETS
...
...
@@ -152,17 +152,14 @@ singleton var = CS {
#
endif
}
member
::
Ord
qpn
=>
Var
qpn
->
ConflictSet
qpn
->
Bool
member
::
Var
QPN
->
ConflictSet
->
Bool
member
var
=
S
.
member
(
simplifyVar
var
)
.
conflictSetToSet
filter
::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
#
if
!
MIN_VERSION_containers
(
0
,
5
,
0
)
Ord
qpn
=>
#
endif
(
Var
qpn
->
Bool
)
->
ConflictSet
qpn
->
ConflictSet
qpn
(
Var
QPN
->
Bool
)
->
ConflictSet
->
ConflictSet
filter
p
cs
=
CS
{
conflictSetToSet
=
S
.
filter
p
(
conflictSetToSet
cs
)
#
ifdef
DEBUG_CONFLICT_SETS
...
...
@@ -174,7 +171,7 @@ fromList ::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
Ord
qpn
=>
[
Var
qpn
]
->
ConflictSet
qpn
[
Var
QPN
]
->
ConflictSet
fromList
vars
=
CS
{
conflictSetToSet
=
S
.
fromList
(
map
simplifyVar
vars
)
#
ifdef
DEBUG_CONFLICT_SETS
...
...
cabal-install/Distribution/Solver/Modular/Cycles.hs
View file @
32cae609
...
...
@@ -34,7 +34,7 @@ detectCyclesPhase = cata go
-- | Given the reverse dependency map from a 'Done' node in the tree, check
-- if the solution is cyclic. If it is, return the conflict set containing
-- all decisions that could potentially break the cycle.
findCycles
::
RevDepMap
->
Maybe
(
ConflictSet
QPN
)
findCycles
::
RevDepMap
->
Maybe
ConflictSet
findCycles
revDeps
=
case
cycles
of
[]
->
Nothing
...
...
cabal-install/Distribution/Solver/Modular/Dependency.hs
View file @
32cae609
...
...
@@ -101,7 +101,7 @@ merge ::
#
ifdef
DEBUG_CONFLICT_SETS
(
?
loc
::
CallStack
)
=>
#
endif
Ord
qpn
=>
CI
qpn
->
CI
qpn
->
Either
(
ConflictSet
qpn
,
(
CI
qpn
,
CI
qpn
))
(
CI
qpn
)
CI
QPN
->
CI
QPN
->
Either
(
ConflictSet
,
(
CI
QPN
,
CI
QPN
))
(
CI
QPN
)
merge
c
@
(
Fixed
i
g1
)
d
@
(
Fixed
j
g2
)
|
i
==
j
=
Right
c
|
otherwise
=
Left
(
CS
.
union
(
varToConflictSet
g1
)
(
varToConflictSet
g2
),
(
c
,
d
))
...
...
@@ -378,11 +378,11 @@ goalToVar (Goal v _) = v
--
-- NOTE: This is just a call to 'varToConflictSet' under the hood;
-- the 'GoalReason' is ignored.
goalVarToConflictSet
::
Goal
qpn
->
ConflictSet
qpn
goalVarToConflictSet
::
Goal
QPN
->
ConflictSet
goalVarToConflictSet
(
Goal
g
_gr
)
=
varToConflictSet
g
-- | Compute a singleton conflict set from a 'Var'
varToConflictSet
::
Var
qpn
->
ConflictSet
qpn
varToConflictSet
::
Var
QPN
->
ConflictSet
varToConflictSet
=
CS
.
singleton
-- | A goal reason is mostly just a variable paired with the
...
...
cabal-install/Distribution/Solver/Modular/Explore.hs
View file @
32cae609
...
...
@@ -45,28 +45,28 @@ import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts
-- variable. See also the comments for 'avoidSet'.
--
backjump
::
EnableBackjumping
->
Var
QPN
->
ConflictSet
QPN
->
W
.
WeightedPSQ
w
k
(
ConflictMap
->
ConflictSetLog
a
)
->
ConflictSet
->
W
.
WeightedPSQ
w
k
(
ConflictMap
->
ConflictSetLog
a
)
->
ConflictMap
->
ConflictSetLog
a
backjump
(
EnableBackjumping
enableBj
)
var
initial
xs
=
F
.
foldr
combine
logBackjump
xs
initial
where
combine
::
forall
a
.
(
ConflictMap
->
ConflictSetLog
a
)
->
(
ConflictSet
QPN
->
ConflictMap
->
ConflictSetLog
a
)
->
ConflictSet
QPN
->
ConflictMap
->
ConflictSetLog
a
->
(
ConflictSet
->
ConflictMap
->
ConflictSetLog
a
)
->
ConflictSet
->
ConflictMap
->
ConflictSetLog
a
combine
x
f
csAcc
cm
=
retry
(
x
cm
)
next
where
next
::
(
ConflictSet
QPN
,
ConflictMap
)
->
ConflictSetLog
a
next
::
(
ConflictSet
,
ConflictMap
)
->
ConflictSetLog
a
next
(
cs
,
cm'
)
|
enableBj
&&
not
(
var
`
CS
.
member
`
cs
)
=
logBackjump
cs
cm'
|
otherwise
=
f
(
csAcc
`
CS
.
union
`
cs
)
cm'
logBackjump
::
ConflictSet
QPN
->
ConflictMap
->
ConflictSetLog
a
logBackjump
::
ConflictSet
->
ConflictMap
->
ConflictSetLog
a
logBackjump
cs
!
cm
=
failWith
(
Failure
cs
Backjump
)
(
cs
,
updateCM
initial
cm
)
-- 'intial' instead of 'cs' here ---^
-- since we do not want to double-count the
-- additionally accumulated conflicts.
type
ConflictSetLog
=
RetryLog
Message
(
ConflictSet
QPN
,
ConflictMap
)
type
ConflictSetLog
=
RetryLog
Message
(
ConflictSet
,
ConflictMap
)
getBestGoal
::
ConflictMap
->
P
.
PSQ
(
Goal
QPN
)
a
->
(
Goal
QPN
,
a
)
getBestGoal
cm
=
...
...
@@ -81,7 +81,7 @@ getFirstGoal ts =
(
error
"getFirstGoal: empty goal choice"
)
-- empty goal choice is an internal error
(
\
k
v
_xs
->
(
k
,
v
))
-- commit to the first goal choice
updateCM
::
ConflictSet
QPN
->
ConflictMap
->
ConflictMap
updateCM
::
ConflictSet
->
ConflictMap
->
ConflictMap
updateCM
cs
cm
=
L
.
foldl'
(
\
cmc
k
->
M
.
alter
inc
k
cmc
)
cm
(
CS
.
toList
cs
)
where
...
...
@@ -163,7 +163,7 @@ exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty
-- current variable, the goal reason of the current node will be added to the
-- conflict set.
--
avoidSet
::
Var
QPN
->
QGoalReason
->
ConflictSet
QPN
avoidSet
::
Var
QPN
->
QGoalReason
->
ConflictSet
avoidSet
var
gr
=
CS
.
fromList
(
var
:
goalReasonToVars
gr
)
...
...
cabal-install/Distribution/Solver/Modular/Linking.hs
View file @
32cae609
...
...
@@ -125,7 +125,7 @@ validateLinking index = (`runReader` initVS) . cata go
Updating the validation state
-------------------------------------------------------------------------------}
type
Conflict
=
(
ConflictSet
QPN
,
String
)
type
Conflict
=
(
ConflictSet
,
String
)
newtype
UpdateState
a
=
UpdateState
{
unUpdateState
::
StateT
ValidateState
(
Either
Conflict
)
a
...
...
@@ -425,7 +425,7 @@ data LinkGroup = LinkGroup {
-- | 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
-- of the link group itself)
,
lgBlame
::
ConflictSet
QPN
,
lgBlame
::
ConflictSet
}
deriving
(
Show
,
Eq
)
...
...
@@ -495,7 +495,7 @@ lgMerge blame lg lg' = do
++
" and "
++
showLinkGroup
lg'
)
lgConflictSet
::
LinkGroup
->
ConflictSet
QPN
lgConflictSet
::
LinkGroup
->
ConflictSet
lgConflictSet
lg
=
CS
.
fromList
(
map
aux
(
S
.
toList
(
lgMembers
lg
)))
`
CS
.
union
`
lgBlame
lg
...
...
cabal-install/Distribution/Solver/Modular/Log.hs
View file @
32cae609
...
...
@@ -8,7 +8,6 @@ import Distribution.Client.Compat.Prelude
import
Data.List
as
L
import
Distribution.Solver.Types.PackagePath
import
Distribution.Solver.Types.Progress
import
Distribution.Solver.Modular.Dependency
...
...
@@ -21,7 +20,7 @@ import qualified Distribution.Solver.Modular.ConflictSet as CS
-- Represents the progress of a computation lazily.
--
-- Parameterized over the type of actual messages and the final result.
type
Log
m
a
=
Progress
m
(
ConflictSet
QPN
,
ConflictMap
)
a
type
Log
m
a
=
Progress
m
(
ConflictSet
,
ConflictMap
)
a
messages
::
Progress
step
fail
done
->
[
step
]
messages
=
foldProgress
(
:
)
(
const
[]
)
(
const
[]
)
...
...
@@ -43,7 +42,7 @@ logToProgress mbj l = let
-- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates
-- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the
-- original result.
proc
::
Maybe
Int
->
Log
Message
b
->
Progress
Message
(
Exhaustiveness
,
ConflictSet
QPN
,
ConflictMap
)
b
proc
::
Maybe
Int
->
Log
Message
b
->
Progress
Message
(
Exhaustiveness
,
ConflictSet
,
ConflictMap
)
b
proc
_
(
Done
x
)
=
Done
x
proc
_
(
Fail
(
cs
,
cm
))
=
Fail
(
Exhaustive
,
cs
,
cm
)
proc
mbj'
(
Step
x
@
(
Failure
cs
Backjump
)
xs
@
(
Step
Leave
(
Step
(
Failure
cs'
Backjump
)
_
)))
...
...
@@ -60,9 +59,9 @@ logToProgress mbj l = let
--
-- The third argument is the full log, ending with either the solution or the
-- exhaustiveness and final conflict set.
go
::
Progress
Message
(
Exhaustiveness
,
ConflictSet
QPN
,
ConflictMap
)
b
->
Progress
Message
(
Exhaustiveness
,
ConflictSet
QPN
,
ConflictMap
)
b
->
Progress
String
(
Exhaustiveness
,
ConflictSet
QPN
,
ConflictMap
)
b
go
::
Progress
Message
(
Exhaustiveness
,
ConflictSet
,
ConflictMap
)
b
->
Progress
Message
(
Exhaustiveness
,
ConflictSet
,
ConflictMap
)
b
->
Progress
String
(
Exhaustiveness
,
ConflictSet
,
ConflictMap
)
b
->
Progress
String
String
b
go
ms
(
Step
_
ns
)
(
Step
x
xs
)
=
Step
x
(
go
ms
ns
xs
)
go
ms
r
(
Step
x
xs
)
=
Step
x
(
go
ms
r
xs
)
...
...
cabal-install/Distribution/Solver/Modular/Message.hs
View file @
32cae609
...
...
@@ -27,7 +27,7 @@ data Message =
|
TryS
QSN
Bool
|
Next
(
Goal
QPN
)
|
Success
|
Failure
(
ConflictSet
QPN
)
FailReason
|
Failure
ConflictSet
FailReason
-- | Transforms the structured message type to actual messages (strings).
--
...
...
@@ -88,7 +88,7 @@ showMessages p sl = go [] 0
showPackageGoal
::
QPN
->
QGoalReason
->
String
showPackageGoal
qpn
gr
=
"next goal: "
++
showQPN
qpn
++
showGR
gr
showFailure
::
ConflictSet
QPN
->
FailReason
->
String
showFailure
::
ConflictSet
->
FailReason
->
String
showFailure
c
fr
=
"fail"
++
showFR
c
fr
add
::
Var
QPN
->
[
Var
QPN
]
->
[
Var
QPN
]
...
...
@@ -99,7 +99,7 @@ showMessages p sl = go [] 0
->
Int
->
QPN
->
[
POption
]
->
ConflictSet
QPN
->
ConflictSet
->
FailReason
->
Progress
Message
a
b
->
Progress
String
a
b
...
...
@@ -128,7 +128,7 @@ showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")"
showGR
(
FDependency
qfn
b
)
=
" (dependency of "
++
showQFNBool
qfn
b
++
")"
showGR
(
SDependency
qsn
)
=
" (dependency of "
++
showQSNBool
qsn
True
++
")"
showFR
::
ConflictSet
QPN
->
FailReason
->
String
showFR
::
ConflictSet
->
FailReason
->
String
showFR
_
InconsistentInitialConstraints
=
" (inconsistent initial constraints)"
showFR
_
(
Conflicting
ds
)
=
" (conflict: "
++
L
.
intercalate
", "
(
map
showDep
ds
)
++
")"
showFR
_
CannotInstall
=
" (only already installed instances can be used)"
...
...
cabal-install/Distribution/Solver/Modular/Preference.hs
View file @
32cae609
...
...
@@ -147,7 +147,7 @@ preferPackageStanzaPreferences pcs = trav go
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintP
::
PackagePath
->
ConflictSet
QPN
->
ConflictSet
->
I
->
LabeledPackageConstraint
->
Tree
d
c
...
...
@@ -175,7 +175,7 @@ processPackageConstraintP _ c i (LabeledPackageConstraint pc src) r = go i pc
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintF
::
Flag
->
ConflictSet
QPN
->
ConflictSet
->
Bool
->
LabeledPackageConstraint
->
Tree
d
c
...
...
@@ -194,7 +194,7 @@ processPackageConstraintF f c b' (LabeledPackageConstraint pc src) r = go pc
-- tree-transformer that either leaves the subtree untouched, or replaces it
-- with an appropriate failure node.
processPackageConstraintS
::
OptionalStanza
->
ConflictSet
QPN
->
ConflictSet
->
Bool
->
LabeledPackageConstraint
->
Tree
d
c
...
...
cabal-install/Distribution/Solver/Modular/Solver.hs
View file @
32cae609
...
...
@@ -211,7 +211,7 @@ instance GSimpleTree (Tree d QGoalReason) where
shortGR
(
SDependency
nm
)
=
showQSN
nm
-- Show conflict set
goCS
::
ConflictSet
QPN
->
String
goCS
::
ConflictSet
->
String
goCS
cs
=
"{"
++
(
intercalate
","
.
L
.
map
showVar
.
CS
.
toList
$
cs
)
++
"}"
#
endif
...
...
cabal-install/Distribution/Solver/Modular/Tree.hs
View file @
32cae609
...
...
@@ -72,7 +72,7 @@ data Tree d c =
|
Done
RevDepMap
d
-- | We failed to find a solution in this path through the tree
|
Fail
(
ConflictSet
QPN
)
FailReason
|
Fail
ConflictSet
FailReason
deriving
(
Eq
,
Show
)
-- | A package option is a package instance with an optional linking annotation
...
...
@@ -122,7 +122,7 @@ data TreeF d c a =
|
SChoiceF
QSN
c
WeakOrTrivial
(
WeightedPSQ
[
Weight
]
Bool
a
)
|
GoalChoiceF
(
PSQ
(
Goal
QPN
)
a
)
|
DoneF
RevDepMap
d
|
FailF
(
ConflictSet
QPN
)
FailReason
|
FailF
ConflictSet
FailReason
deriving
(
Functor
,
Foldable
,
Traversable
)
out
::
Tree
d
c
->
TreeF
d
c
(
Tree
d
c
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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