Dependency.hs 7.81 KB
Newer Older
1
2
module Distribution.Client.Dependency.Modular.Dependency where

Andres Löh's avatar
Andres Löh committed
3
4
import Prelude hiding (pi)

5
import Data.List as L
6
import Data.Map as M
7
import Data.Set as S
8
9
10

import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
11
12
13
14
import Distribution.Client.Dependency.Modular.Version

-- | The type of variables that play a role in the solver.
-- Note that the tree currently does not use this type directly,
Andres Löh's avatar
Andres Löh committed
15
-- and rather has separate tree nodes for the different types of
16
17
18
19
20
-- variables. This fits better with the fact that in most cases,
-- these have to be treated differently.
--
-- TODO: This isn't the ideal location to declare the type,
-- but we need them for constrained instances.
Andres Löh's avatar
Andres Löh committed
21
data Var qpn = P qpn | F (FN qpn) | S (SN qpn)
22
  deriving (Eq, Ord, Show)
23

24
25
26
27
28
29
30
31
32
33
-- | For computing conflict sets, we map flag choice vars to a
-- single flag choice. This means that all flag choices are treated
-- as interdependent. So if one flag of a package ends up in a
-- conflict set, then all flags are being treated as being part of
-- the conflict set.
simplifyVar :: Var qpn -> Var qpn
simplifyVar (P qpn)       = P qpn
simplifyVar (F (FN pi _)) = F (FN pi (mkFlag "flag"))
simplifyVar (S qsn)       = S qsn

34
35
36
showVar :: Var QPN -> String
showVar (P qpn) = showQPN qpn
showVar (F qfn) = showQFN qfn
Andres Löh's avatar
Andres Löh committed
37
showVar (S qsn) = showQSN qsn
38

39
40
41
instance Functor Var where
  fmap f (P n)  = P (f n)
  fmap f (F fn) = F (fmap f fn)
Andres Löh's avatar
Andres Löh committed
42
  fmap f (S sn) = S (fmap f sn)
43

44
45
type ConflictSet qpn = Set (Var qpn)

Andres Löh's avatar
Andres Löh committed
46
47
48
showCS :: ConflictSet QPN -> String
showCS = intercalate ", " . L.map showVar . S.toList

49
50
51
52
-- | Constrained instance. If the choice has already been made, this is
-- a fixed instance, and we record the package name for which the choice
-- is for convenience. Otherwise, it is a list of version ranges paired with
-- the goals / variables that introduced them.
53
data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn]
54
55
56
  deriving (Eq, Show)

instance Functor CI where
57
  fmap f (Fixed i g)       = Fixed i (fmap f g)
58
59
  fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs)

60
61
62
instance ResetGoal CI where
  resetGoal g (Fixed i _)       = Fixed i g
  resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs)
63

64
type VROrigin qpn = (VR, Goal qpn)
65
66
67
68

-- | Helper function to collapse a list of version ranges with origins into
-- a single, simplified, version range.
collapse :: [VROrigin qpn] -> VR
Andres Löh's avatar
Andres Löh committed
69
collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst
70

71
showCI :: CI QPN -> String
72
73
74
75
76
showCI (Fixed i _)      = "==" ++ showI i
showCI (Constrained vr) = showVR (collapse vr)

-- | Merge constrained instances. We currently adopt a lazy strategy for
-- merging, i.e., we only perform actual checking if one of the two choices
77
78
79
80
81
82
-- is fixed. If the merge fails, we return a conflict set indicating the
-- variables responsible for the failure, as well as the two conflicting
-- fragments.
--
-- Note that while there may be more than one conflicting pair of version
-- ranges, we only return the first we find.
83
--
84
85
86
87
88
-- TODO: Different pairs might have different conflict sets. We're
-- obviously interested to return a conflict that has a "better" conflict
-- set in the sense the it contains variables that allow us to backjump
-- further. We might apply some heuristics here, such as to change the
-- order in which we check the constraints.
89
merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn)
90
merge c@(Fixed i g1)       d@(Fixed j g2)
91
92
93
  | i == j                                    = Right c
  | otherwise                                 = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d))
merge c@(Fixed (I v _) g1)   (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ...
94
95
  where
    go []              = Right c
96
    go (d@(vr, g2) : vrs)
97
      | checkVR vr v   = go vrs
98
99
100
      | otherwise      = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d]))
merge c@(Constrained _)    d@(Fixed _ _)      = merge d c
merge   (Constrained rs)     (Constrained ss) = Right (Constrained (rs ++ ss))
101

102
103
104
105
106
107

type FlaggedDeps qpn = [FlaggedDep qpn]

-- | Flagged dependencies can either be plain dependency constraints,
-- or flag-dependent dependency trees.
data FlaggedDep qpn =
108
109
    Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
  | Stanza  (SN qpn)       (TrueFlaggedDeps qpn)
110
111
112
113
114
115
  | Simple (Dep qpn)
  deriving (Eq, Show)

instance Functor FlaggedDep where
  fmap f (Flagged x y tt ff) = Flagged (fmap f x) y
                                       (fmap (fmap f) tt) (fmap (fmap f) ff)
Andres Löh's avatar
Andres Löh committed
116
  fmap f (Stanza x tt)       = Stanza (fmap f x) (fmap (fmap f) tt)
117
118
119
120
121
122
123
  fmap f (Simple d)          = Simple (fmap f d)

type TrueFlaggedDeps  qpn = FlaggedDeps qpn
type FalseFlaggedDeps qpn = FlaggedDeps qpn

-- | A dependency (constraint) associates a package name with a
-- constrained instance.
124
data Dep qpn = Dep qpn (CI qpn)
125
126
127
  deriving (Eq, Show)

showDep :: Dep QPN -> String
Andres Löh's avatar
Andres Löh committed
128
129
130
131
132
133
134
showDep (Dep qpn (Fixed i (Goal v _))          ) =
  (if P qpn /= v then showVar v ++ " => " else "") ++
  showQPN qpn ++ "==" ++ showI i
showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
  showVar v ++ " => " ++ showQPN qpn ++ showVR vr
showDep (Dep qpn ci                            ) =
  showQPN qpn ++ showCI ci
135
136

instance Functor Dep where
137
  fmap f (Dep x y) = Dep (f x) (fmap f y)
138

139
140
instance ResetGoal Dep where
  resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)
141

142
143
144
-- | A map containing reverse dependencies between qualified
-- package names.
type RevDepMap = Map QPN [QPN]
145

146
147
-- | Goals are solver variables paired with information about
-- why they have been introduced.
148
data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn)
149
150
151
  deriving (Eq, Show)

instance Functor Goal where
152
  fmap f (Goal v grs) = Goal (fmap f v) (fmap (fmap f) grs)
153
154
155
156
157
158
159
160
161

class ResetGoal f where
  resetGoal :: Goal qpn -> f qpn -> f qpn

instance ResetGoal Goal where
  resetGoal = const

-- | For open goals as they occur during the build phase, we need to store
-- additional information about flags.
162
data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain
163
164
165
  deriving (Eq, Show)

-- | Reasons why a goal can be added to a goal set.
Andres Löh's avatar
Andres Löh committed
166
167
168
169
170
data GoalReason qpn =
    UserGoal
  | PDependency (PI qpn)
  | FDependency (FN qpn) Bool
  | SDependency (SN qpn)
171
172
  deriving (Eq, Show)

173
instance Functor GoalReason where
Andres Löh's avatar
Andres Löh committed
174
  fmap _ UserGoal           = UserGoal
175
176
  fmap f (PDependency pi)   = PDependency (fmap f pi)
  fmap f (FDependency fn b) = FDependency (fmap f fn) b
Andres Löh's avatar
Andres Löh committed
177
  fmap f (SDependency sn)   = SDependency (fmap f sn)
178

179
180
-- | The first element is the immediate reason. The rest are the reasons
-- for the reasons ...
181
type GoalReasonChain qpn = [GoalReason qpn]
182

183
type QGoalReasonChain = GoalReasonChain QPN
184

185
goalReasonToVars :: GoalReason qpn -> ConflictSet qpn
186
187
goalReasonToVars UserGoal                 = S.empty
goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn)
188
goalReasonToVars (FDependency qfn _)      = S.singleton (simplifyVar (F qfn))
Andres Löh's avatar
Andres Löh committed
189
goalReasonToVars (SDependency qsn)        = S.singleton (S qsn)
190

191
192
193
194
195
goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn
goalReasonChainToVars = S.unions . L.map goalReasonToVars

goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn
goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars
196

197
198
199
200
201
-- | Closes a goal, i.e., removes all the extraneous information that we
-- need only during the build phase.
close :: OpenGoal -> Goal QPN
close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr
close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr
Andres Löh's avatar
Andres Löh committed
202
close (OpenGoal (Stanza  qsn _)      gr) = Goal (S qsn) gr
203

204
205
206
-- | Compute a conflic set from a goal. The conflict set contains the
-- closure of goal reasons as well as the variable of the goal itself.
toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn
207
toConflictSet (Goal g grs) = S.insert (simplifyVar g) (goalReasonChainToVars grs)