Linking.hs 22.8 KB
Newer Older
Edsko de Vries's avatar
Edsko de Vries committed
1
{-# LANGUAGE CPP #-}
Edsko de Vries's avatar
Edsko de Vries committed
2
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
Edsko de Vries's avatar
Edsko de Vries committed
3
{-# LANGUAGE MultiParamTypeClasses #-}
Edsko de Vries's avatar
Edsko de Vries committed
4
5
module Distribution.Client.Dependency.Modular.Linking (
    addLinking
Edsko de Vries's avatar
Edsko de Vries committed
6
  , validateLinking
Edsko de Vries's avatar
Edsko de Vries committed
7
8
  ) where

Edsko de Vries's avatar
Edsko de Vries committed
9
10
import Prelude hiding (pi)
import Control.Exception (assert)
Edsko de Vries's avatar
Edsko de Vries committed
11
import Control.Monad.Reader
Edsko de Vries's avatar
Edsko de Vries committed
12
13
14
15
16
import Control.Monad.State
import Data.Maybe (catMaybes)
import Data.Map (Map, (!))
import Data.List (intercalate)
import Data.Set (Set)
Edsko de Vries's avatar
Edsko de Vries committed
17
import qualified Data.Map         as M
Edsko de Vries's avatar
Edsko de Vries committed
18
import qualified Data.Set         as S
Edsko de Vries's avatar
Edsko de Vries committed
19
20
21
22
23
24
import qualified Data.Traversable as T

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif

Edsko de Vries's avatar
Edsko de Vries committed
25
import Distribution.Client.Dependency.Modular.Assignment
Edsko de Vries's avatar
Edsko de Vries committed
26
import Distribution.Client.Dependency.Modular.Dependency
Edsko de Vries's avatar
Edsko de Vries committed
27
28
import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Index
Edsko de Vries's avatar
Edsko de Vries committed
29
30
31
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
import qualified Distribution.Client.Dependency.Modular.PSQ as P
Edsko de Vries's avatar
Edsko de Vries committed
32
import qualified Distribution.Client.Dependency.Modular.ConflictSet as CS
Edsko de Vries's avatar
Edsko de Vries committed
33

Edsko de Vries's avatar
Edsko de Vries committed
34
import Distribution.Client.Types (OptionalStanza(..))
35
import Distribution.Client.ComponentDeps (Component)
Edsko de Vries's avatar
Edsko de Vries committed
36

Edsko de Vries's avatar
Edsko de Vries committed
37
38
39
40
41
42
43
{-------------------------------------------------------------------------------
  Add linking
-------------------------------------------------------------------------------}

type RelatedGoals = Map (PN, I) [PP]
type Linker       = Reader RelatedGoals

Edsko de Vries's avatar
Edsko de Vries committed
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
-- | Introduce link nodes into tree tree
--
-- Linking is a traversal of the solver tree that adapts package choice nodes
-- and adds the option to link wherever appropriate: Package goals are called
-- "related" if they are for the same version of the same package (but have
-- different prefixes). A link option is available in a package choice node
-- whenever we can choose an instance that has already been chosen for a related
-- goal at a higher position in the tree.
--
-- The code here proceeds by maintaining a finite map recording choices that
-- have been made at higher positions in the tree. For each pair of package name
-- and instance, it stores the prefixes at which we have made a choice for this
-- package instance. Whenever we make a choice, we extend the map. Whenever we
-- find a choice, we look into the map in order to find out what link options we
-- have to add.
Andres Löh's avatar
Andres Löh committed
59
addLinking :: Tree QGoalReason -> Tree QGoalReason
Edsko de Vries's avatar
Edsko de Vries committed
60
61
addLinking = (`runReader` M.empty) .  cata go
  where
Andres Löh's avatar
Andres Löh committed
62
    go :: TreeF QGoalReason (Linker (Tree QGoalReason)) -> Linker (Tree QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
63
64
65
66
67
68
69

    -- The only nodes of interest are package nodes
    go (PChoiceF qpn gr cs) = do
      env <- ask
      cs' <- T.sequence $ P.mapWithKey (goP qpn) cs
      let newCs = concatMap (linkChoices env qpn) (P.toList cs')
      return $ PChoice qpn gr (cs' `P.union` P.fromList newCs)
Edsko de Vries's avatar
Edsko de Vries committed
70
71
    go _otherwise =
      innM _otherwise
Edsko de Vries's avatar
Edsko de Vries committed
72
73
74

    -- Recurse underneath package choices. Here we just need to make sure
    -- that we record the package choice so that it is available below
Andres Löh's avatar
Andres Löh committed
75
    goP :: QPN -> POption -> Linker (Tree QGoalReason) -> Linker (Tree QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
76
77
78
    goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
    goP _ _ = alreadyLinked

Andres Löh's avatar
Andres Löh committed
79
linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReason) -> [(POption, Tree QGoalReason)]
Edsko de Vries's avatar
Edsko de Vries committed
80
81
82
linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
    map aux (M.findWithDefault [] (pn, i) related)
  where
Andres Löh's avatar
Andres Löh committed
83
    aux :: PP -> (POption, Tree QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
84
85
86
87
88
89
    aux pp = (POption i (Just pp), subtree)
linkChoices _ _ (POption _ (Just _), _) =
    alreadyLinked

alreadyLinked :: a
alreadyLinked = error "addLinking called on tree that already contains linked nodes"
Edsko de Vries's avatar
Edsko de Vries committed
90
91
92

{-------------------------------------------------------------------------------
  Validation
Edsko de Vries's avatar
Edsko de Vries committed
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110

  Validation of links is a separate pass that's performed after normal
  validation. Validation of links checks that if the tree indicates that a
  package is linked, then everything underneath that choice really matches the
  package we have linked to.

  This is interesting because it isn't unidirectional. Consider that we've
  chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.
  Now foo depends on bar. Because a.foo and b.foo are linked, it's required that
  a.bar and b.bar are also linked. However, it's not required that we actually
  choose a.bar before b.bar. Goal choice order is relatively free. It's possible
  that we choose a.bar first, but also possible that we choose b.bar first. In
  both cases, we have to recognize that we have freedom of choice for the first
  of the two, but no freedom of choice for the second.

  This is what LinkGroups are all about. Using LinkGroup, we can record (in the
  situation above) that a.bar and b.bar need to be linked even if we haven't
  chosen either of them yet.
Edsko de Vries's avatar
Edsko de Vries committed
111
112
113
114
115
116
117
-------------------------------------------------------------------------------}

data ValidateState = VS {
      vsIndex    :: Index
    , vsLinks    :: Map QPN LinkGroup
    , vsFlags    :: FAssignment
    , vsStanzas  :: SAssignment
118
    , vsQualifyOptions :: QualifyOptions
Edsko de Vries's avatar
Edsko de Vries committed
119
120
121
122
123
124
125
126
127
128
129
    }
    deriving Show

type Validate = Reader ValidateState

-- | Validate linked packages
--
-- Verify that linked packages have
--
-- * Linked dependencies,
-- * Equal flag assignments
Edsko de Vries's avatar
Edsko de Vries committed
130
-- * Equal stanza assignments
Andres Löh's avatar
Andres Löh committed
131
validateLinking :: Index -> Tree QGoalReason -> Tree QGoalReason
Edsko de Vries's avatar
Edsko de Vries committed
132
133
validateLinking index = (`runReader` initVS) . cata go
  where
Andres Löh's avatar
Andres Löh committed
134
    go :: TreeF QGoalReason (Validate (Tree QGoalReason)) -> Validate (Tree QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
135
136
137
138
139
140
141
142
143
144
145
146
147
148

    go (PChoiceF qpn gr cs) =
      PChoice qpn gr     <$> T.sequence (P.mapWithKey (goP qpn) cs)
    go (FChoiceF qfn gr t m cs) =
      FChoice qfn gr t m <$> T.sequence (P.mapWithKey (goF qfn) cs)
    go (SChoiceF qsn gr t cs) =
      SChoice qsn gr t   <$> T.sequence (P.mapWithKey (goS qsn) cs)

    -- For the other nodes we just recurse
    go (GoalChoiceF         cs)       = GoalChoice          <$> T.sequence cs
    go (DoneF revDepMap)              = return $ Done revDepMap
    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason

    -- Package choices
Andres Löh's avatar
Andres Löh committed
149
    goP :: QPN -> POption -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
150
    goP qpn@(Q _pp pn) opt@(POption i _) r = do
Edsko de Vries's avatar
Edsko de Vries committed
151
152
      vs <- ask
      let PInfo deps _ _ = vsIndex vs ! pn ! i
153
          qdeps          = qualifyDeps (vsQualifyOptions vs) qpn deps
Edsko de Vries's avatar
Edsko de Vries committed
154
155
156
157
158
      case execUpdateState (pickPOption qpn opt qdeps) vs of
        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
        Right vs'       -> local (const vs') r

    -- Flag choices
Andres Löh's avatar
Andres Löh committed
159
    goF :: QFN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
160
161
162
163
164
165
166
    goF qfn b r = do
      vs <- ask
      case execUpdateState (pickFlag qfn b) vs of
        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
        Right vs'       -> local (const vs') r

    -- Stanza choices (much the same as flag choices)
Andres Löh's avatar
Andres Löh committed
167
    goS :: QSN -> Bool -> Validate (Tree QGoalReason) -> Validate (Tree QGoalReason)
Edsko de Vries's avatar
Edsko de Vries committed
168
169
170
171
172
173
174
175
176
177
178
179
    goS qsn b r = do
      vs <- ask
      case execUpdateState (pickStanza qsn b) vs of
        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
        Right vs'       -> local (const vs') r

    initVS :: ValidateState
    initVS = VS {
        vsIndex   = index
      , vsLinks   = M.empty
      , vsFlags   = M.empty
      , vsStanzas = M.empty
180
      , vsQualifyOptions = defaultQualifyOptions index
Edsko de Vries's avatar
Edsko de Vries committed
181
182
183
184
185
186
187
188
189
190
191
      }

{-------------------------------------------------------------------------------
  Updating the validation state
-------------------------------------------------------------------------------}

type Conflict = (ConflictSet QPN, String)

newtype UpdateState a = UpdateState {
    unUpdateState :: StateT ValidateState (Either Conflict) a
  }
Edsko de Vries's avatar
Edsko de Vries committed
192
193
194
195
196
197
198
  deriving (Functor, Applicative, Monad)

instance MonadState ValidateState UpdateState where
  get    = UpdateState $ get
  put st = UpdateState $ do
             assert (lgInvariant $ vsLinks st) $ return ()
             put st
Edsko de Vries's avatar
Edsko de Vries committed
199
200
201
202
203
204
205
206
207
208

lift' :: Either Conflict a -> UpdateState a
lift' = UpdateState . lift

conflict :: Conflict -> UpdateState a
conflict = lift' . Left

execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState = execStateT . unUpdateState

Edsko de Vries's avatar
Edsko de Vries committed
209
pickPOption :: QPN -> POption -> FlaggedDeps Component QPN -> UpdateState ()
Edsko de Vries's avatar
Edsko de Vries committed
210
211
212
213
214
215
216
217
218
pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i
pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps

pickConcrete :: QPN -> I -> UpdateState ()
pickConcrete qpn@(Q pp _) i = do
    vs <- get
    case M.lookup qpn (vsLinks vs) of
      -- Package is not yet in a LinkGroup. Create a new singleton link group.
      Nothing -> do
Edsko de Vries's avatar
Edsko de Vries committed
219
        let lg = lgSingleton qpn (Just $ PI pp i)
Edsko de Vries's avatar
Edsko de Vries committed
220
221
222
        updateLinkGroup lg

      -- Package is already in a link group. Since we are picking a concrete
Edsko de Vries's avatar
Edsko de Vries committed
223
      -- instance here, it must by definition be the canonical package.
Edsko de Vries's avatar
Edsko de Vries committed
224
      Just lg ->
Edsko de Vries's avatar
Edsko de Vries committed
225
        makeCanonical lg qpn i
Edsko de Vries's avatar
Edsko de Vries committed
226

Edsko de Vries's avatar
Edsko de Vries committed
227
pickLink :: QPN -> I -> PP -> FlaggedDeps Component QPN -> UpdateState ()
Edsko de Vries's avatar
Edsko de Vries committed
228
pickLink qpn@(Q _pp pn) i pp' deps = do
Edsko de Vries's avatar
Edsko de Vries committed
229
    vs <- get
Edsko de Vries's avatar
Edsko de Vries committed
230
231
232
233
234
235
236
237

    -- The package might already be in a link group
    -- (because one of its reverse dependencies is)
    let lgSource = case M.lookup qpn (vsLinks vs) of
                     Nothing -> lgSingleton qpn Nothing
                     Just lg -> lg

    -- Find the link group for the package we are linking to
Edsko de Vries's avatar
Edsko de Vries committed
238
239
240
    --
    -- Since the builder never links to a package without having first picked a
    -- concrete instance for that package, and since we create singleton link
Edsko de Vries's avatar
Edsko de Vries committed
241
242
    -- groups for concrete instances, this link group must exist (and must
    -- in fact already have a canonical member).
Edsko de Vries's avatar
Edsko de Vries committed
243
    let target   = Q pp' pn
244
        lgTarget = vsLinks vs ! target
Edsko de Vries's avatar
Edsko de Vries committed
245
246
247
248
249
250

    -- Verify here that the member we add is in fact for the same package and
    -- matches the version of the canonical instance. However, violations of
    -- these checks would indicate a bug in the linker, not a true conflict.
    let sanityCheck :: Maybe (PI PP) -> Bool
        sanityCheck Nothing              = False
Edsko de Vries's avatar
Edsko de Vries committed
251
252
253
254
255
256
257
258
        sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI
    assert (sanityCheck (lgCanon lgTarget)) $ return ()

    -- Merge the two link groups (updateLinkGroup will propagate the change)
    lgTarget' <- lift' $ lgMerge [] lgSource lgTarget
    updateLinkGroup lgTarget'

    -- Make sure all dependencies are linked as well
Edsko de Vries's avatar
Edsko de Vries committed
259
    linkDeps target [P qpn] deps
Edsko de Vries's avatar
Edsko de Vries committed
260

Edsko de Vries's avatar
Edsko de Vries committed
261
262
makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()
makeCanonical lg qpn@(Q pp _) i =
Edsko de Vries's avatar
Edsko de Vries committed
263
264
265
    case lgCanon lg of
      -- There is already a canonical member. Fail.
      Just _ ->
266
        conflict ( CS.insert (P qpn) (lgConflictSet lg)
Edsko de Vries's avatar
Edsko de Vries committed
267
268
269
270
                 ,    "cannot make " ++ showQPN qpn
                   ++ " canonical member of " ++ showLinkGroup lg
                 )
      Nothing -> do
Edsko de Vries's avatar
Edsko de Vries committed
271
        let lg' = lg { lgCanon = Just (PI pp i) }
Edsko de Vries's avatar
Edsko de Vries committed
272
273
        updateLinkGroup lg'

Edsko de Vries's avatar
Edsko de Vries committed
274
275
276
277
278
279
280
281
282
-- | Link the dependencies of linked parents.
--
-- When we decide to link one package against another we walk through the
-- package's direct depedencies and make sure that they're all linked to each
-- other by merging their link groups (or creating new singleton link groups if
-- they don't have link groups yet). We do not need to do this recursively,
-- because having the direct dependencies in a link group means that we must
-- have already made or will make sooner or later a link choice for one of these
-- as well, and cover their dependencies at that point.
Edsko de Vries's avatar
Edsko de Vries committed
283
284
285
286
linkDeps :: QPN -> [Var QPN] -> FlaggedDeps Component QPN -> UpdateState ()
linkDeps parent = \parents deps -> do
    rdeps <- requalify deps
    go parents deps rdeps
Edsko de Vries's avatar
Edsko de Vries committed
287
  where
Edsko de Vries's avatar
Edsko de Vries committed
288
    go :: [Var QPN] -> FlaggedDeps Component QPN -> FlaggedDeps Component QPN -> UpdateState ()
Edsko de Vries's avatar
Edsko de Vries committed
289
    go = zipWithM_ . go1
Edsko de Vries's avatar
Edsko de Vries committed
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310

    go1 :: [Var QPN] -> FlaggedDep Component QPN -> FlaggedDep Component QPN -> UpdateState ()
    go1 parents dep rdep = case (dep, rdep) of
      (Simple (Dep qpn _) _, ~(Simple (Dep qpn' _) _)) -> do
        vs <- get
        let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs
            lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
        lg'' <- lift' $ lgMerge parents lg lg'
        updateLinkGroup lg''
      (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do
        vs <- get
        case M.lookup fn (vsFlags vs) of
          Nothing    -> return () -- flag assignment not yet known
          Just True  -> go (F fn:parents) t t'
          Just False -> go (F fn:parents) f f'
      (Stanza sn t, ~(Stanza _ t')) -> do
        vs <- get
        case M.lookup sn (vsStanzas vs) of
          Nothing    -> return () -- stanza assignment not yet known
          Just True  -> go (S sn:parents) t t'
          Just False -> return () -- stanza not enabled; no new deps
311
312
    -- For extensions and language dependencies, there is nothing to do.
    -- No choice is involved, just checking, so there is nothing to link.
Edsko de Vries's avatar
Edsko de Vries committed
313
314
315
316
317
318
319
    -- The same goes for for pkg-config constraints.
      (Simple (Ext  _)   _, _) -> return ()
      (Simple (Lang _)   _, _) -> return ()
      (Simple (Pkg  _ _) _, _) -> return ()

    requalify :: FlaggedDeps Component QPN -> UpdateState (FlaggedDeps Component QPN)
    requalify deps = do
Edsko de Vries's avatar
Edsko de Vries committed
320
      vs <- get
Edsko de Vries's avatar
Edsko de Vries committed
321
      return $ qualifyDeps (vsQualifyOptions vs) parent (unqualifyDeps deps)
Edsko de Vries's avatar
Edsko de Vries committed
322
323
324
325
326
327
328
329
330
331
332
333
334

pickFlag :: QFN -> Bool -> UpdateState ()
pickFlag qfn b = do
    modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }
    verifyFlag qfn
    linkNewDeps (F qfn) b

pickStanza :: QSN -> Bool -> UpdateState ()
pickStanza qsn b = do
    modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }
    verifyStanza qsn
    linkNewDeps (S qsn) b

Edsko de Vries's avatar
Edsko de Vries committed
335
336
337
338
339
340
341
-- | Link dependencies that we discover after making a flag choice.
--
-- When we make a flag choice for a package, then new dependencies for that
-- package might become available. If the package under consideration is in a
-- non-trivial link group, then these new dependencies have to be linked as
-- well. In linkNewDeps, we compute such new dependencies and make sure they are
-- linked.
Edsko de Vries's avatar
Edsko de Vries committed
342
343
344
345
346
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps var b = do
    vs <- get
    let (qpn@(Q pp pn), Just i) = varPI var
        PInfo deps _ _          = vsIndex vs ! pn ! i
347
        qdeps                   = qualifyDeps (vsQualifyOptions vs) qpn deps
Edsko de Vries's avatar
Edsko de Vries committed
348
349
350
        lg                      = vsLinks vs ! qpn
        (parents, newDeps)      = findNewDeps vs qdeps
        linkedTo                = S.delete pp (lgMembers lg)
Edsko de Vries's avatar
Edsko de Vries committed
351
    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) (P qpn : parents) newDeps
Edsko de Vries's avatar
Edsko de Vries committed
352
  where
353
    findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
Edsko de Vries's avatar
Edsko de Vries committed
354
355
    findNewDeps vs = concatMapUnzip (findNewDeps' vs)

356
357
    findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
    findNewDeps' _  (Simple _ _)        = ([], [])
Edsko de Vries's avatar
Edsko de Vries committed
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
    findNewDeps' vs (Flagged qfn _ t f) =
      case (F qfn == var, M.lookup qfn (vsFlags vs)) of
        (True, _)    -> ([F qfn], if b then t else f)
        (_, Nothing) -> ([], []) -- not yet known
        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else f)
                        in (F qfn:parents, deps)
    findNewDeps' vs (Stanza qsn t) =
      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of
        (True, _)    -> ([S qsn], if b then t else [])
        (_, Nothing) -> ([], []) -- not yet known
        (_, Just b') -> let (parents, deps) = findNewDeps vs (if b' then t else [])
                        in (S qsn:parents, deps)

updateLinkGroup :: LinkGroup -> UpdateState ()
updateLinkGroup lg = do
    verifyLinkGroup lg
    modify $ \vs -> vs {
        vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))
                  `M.union` vsLinks vs
      }
  where
    aux pp = (Q pp (lgPackage lg), lg)

{-------------------------------------------------------------------------------
  Verification
-------------------------------------------------------------------------------}

verifyLinkGroup :: LinkGroup -> UpdateState ()
verifyLinkGroup lg =
    case lgInstance lg of
      -- No instance picked yet. Nothing to verify
      Nothing ->
        return ()

      -- We picked an instance. Verify flags and stanzas
      -- TODO: The enumeration of OptionalStanza names is very brittle;
      -- if a constructor is added to the datatype we won't notice it here
      Just i -> do
        vs <- get
        let PInfo _deps finfo _ = vsIndex vs ! lgPackage lg ! i
            flags   = M.keys finfo
            stanzas = [TestStanzas, BenchStanzas]
        forM_ flags $ \fn -> do
          let flag = FN (PI (lgPackage lg) i) fn
          verifyFlag' flag lg
        forM_ stanzas $ \sn -> do
          let stanza = SN (PI (lgPackage lg) i) sn
          verifyStanza' stanza lg

verifyFlag :: QFN -> UpdateState ()
verifyFlag (FN (PI qpn@(Q _pp pn) i) fn) = do
    vs <- get
    -- We can only pick a flag after picking an instance; link group must exist
    verifyFlag' (FN (PI pn i) fn) (vsLinks vs ! qpn)

verifyStanza :: QSN -> UpdateState ()
verifyStanza (SN (PI qpn@(Q _pp pn) i) sn) = do
    vs <- get
    -- We can only pick a stanza after picking an instance; link group must exist
    verifyStanza' (SN (PI pn i) sn) (vsLinks vs ! qpn)

Edsko de Vries's avatar
Edsko de Vries committed
419
420
421
422
423
-- | Verify that all packages in the link group agree on flag assignments
--
-- For the given flag and the link group, obtain all assignments for the flag
-- that have already been made for link group members, and check that they are
-- equal.
Edsko de Vries's avatar
Edsko de Vries committed
424
425
426
427
428
429
430
verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
verifyFlag' (FN (PI pn i) fn) lg = do
    vs <- get
    let flags = map (\pp' -> FN (PI (Q pp' pn) i) fn) (S.toList (lgMembers lg))
        vals  = map (`M.lookup` vsFlags vs) flags
    if allEqual (catMaybes vals) -- We ignore not-yet assigned flags
      then return ()
Edsko de Vries's avatar
Edsko de Vries committed
431
      else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg
Edsko de Vries's avatar
Edsko de Vries committed
432
433
434
                    , "flag " ++ show fn ++ " incompatible"
                    )

Edsko de Vries's avatar
Edsko de Vries committed
435
436
437
438
439
440
441
-- | Verify that all packages in the link group agree on stanza assignments
--
-- For the given stanza and the link group, obtain all assignments for the
-- stanza that have already been made for link group members, and check that
-- they are equal.
--
-- This function closely mirrors 'verifyFlag''.
Edsko de Vries's avatar
Edsko de Vries committed
442
443
444
445
446
447
448
verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
verifyStanza' (SN (PI pn i) sn) lg = do
    vs <- get
    let stanzas = map (\pp' -> SN (PI (Q pp' pn) i) sn) (S.toList (lgMembers lg))
        vals    = map (`M.lookup` vsStanzas vs) stanzas
    if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas
      then return ()
Edsko de Vries's avatar
Edsko de Vries committed
449
      else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg
Edsko de Vries's avatar
Edsko de Vries committed
450
451
452
453
454
455
456
457
                    , "stanza " ++ show sn ++ " incompatible"
                    )

{-------------------------------------------------------------------------------
  Link groups
-------------------------------------------------------------------------------}

-- | Set of packages that must be linked together
Edsko de Vries's avatar
Edsko de Vries committed
458
459
460
461
462
463
--
-- A LinkGroup is between several qualified package names. In the validation
-- state, we maintain a map vsLinks from qualified package names to link groups.
-- There is an invariant that for all members of a link group, vsLinks must map
-- to the same link group. The function updateLinkGroup can be used to
-- re-establish this invariant after creating or expanding a LinkGroup.
Edsko de Vries's avatar
Edsko de Vries committed
464
465
466
467
468
469
470
data LinkGroup = LinkGroup {
      -- | The name of the package of this link group
      lgPackage :: PN

      -- | The canonical member of this link group (the one where we picked
      -- a concrete instance). Once we have picked a canonical member, all
      -- other packages must link to this one.
Edsko de Vries's avatar
Edsko de Vries committed
471
472
473
474
      --
      -- We may not know this yet (if we are constructing link groups
      -- for dependencies)
    , lgCanon :: Maybe (PI PP)
Edsko de Vries's avatar
Edsko de Vries committed
475
476
477
478
479
480
481

      -- | The members of the link group
    , lgMembers :: Set PP

      -- | 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)
Edsko de Vries's avatar
Edsko de Vries committed
482
    , lgBlame :: ConflictSet QPN
Edsko de Vries's avatar
Edsko de Vries committed
483
    }
Edsko de Vries's avatar
Edsko de Vries committed
484
485
486
487
488
489
490
491
492
493
494
495
    deriving (Show, Eq)

-- | Invariant for the set of link groups: every element in the link group
-- must be pointing to the /same/ link group
lgInvariant :: Map QPN LinkGroup -> Bool
lgInvariant links = all invGroup (M.elems links)
  where
    invGroup :: LinkGroup -> Bool
    invGroup lg = allEqual $ map (`M.lookup` links) members
      where
        members :: [QPN]
        members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg)
Edsko de Vries's avatar
Edsko de Vries committed
496

Edsko de Vries's avatar
Edsko de Vries committed
497
498
499
500
501
502
-- | Package version of this group
--
-- This is only known once we have picked a canonical element.
lgInstance :: LinkGroup -> Maybe I
lgInstance = fmap (\(PI _ i) -> i) . lgCanon

Edsko de Vries's avatar
Edsko de Vries committed
503
504
505
506
507
showLinkGroup :: LinkGroup -> String
showLinkGroup lg =
    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"
  where
    showMember :: PP -> String
Edsko de Vries's avatar
Edsko de Vries committed
508
509
510
    showMember pp = case lgCanon lg of
                      Just (PI pp' _i) | pp == pp' -> "*"
                      _otherwise                   -> ""
Edsko de Vries's avatar
Edsko de Vries committed
511
512
513
514
515
516
517
                 ++ case lgInstance lg of
                      Nothing -> showQPN (qpn pp)
                      Just i  -> showPI (PI (qpn pp) i)

    qpn :: PP -> QPN
    qpn pp = Q pp (lgPackage lg)

Edsko de Vries's avatar
Edsko de Vries committed
518
519
520
521
522
523
-- | Creates a link group that contains a single member.
lgSingleton :: QPN -> Maybe (PI PP) -> LinkGroup
lgSingleton (Q pp pn) canon = LinkGroup {
      lgPackage = pn
    , lgCanon   = canon
    , lgMembers = S.singleton pp
Edsko de Vries's avatar
Edsko de Vries committed
524
    , lgBlame   = CS.empty
Edsko de Vries's avatar
Edsko de Vries committed
525
526
527
528
    }

lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge blame lg lg' = do
Edsko de Vries's avatar
Edsko de Vries committed
529
    canon <- pick (lgCanon lg) (lgCanon lg')
Edsko de Vries's avatar
Edsko de Vries committed
530
    return LinkGroup {
Edsko de Vries's avatar
Edsko de Vries committed
531
532
533
        lgPackage = lgPackage lg
      , lgCanon   = canon
      , lgMembers = lgMembers lg `S.union` lgMembers lg'
Edsko de Vries's avatar
Edsko de Vries committed
534
      , lgBlame   = CS.unions [CS.fromList blame, lgBlame lg, lgBlame lg']
Edsko de Vries's avatar
Edsko de Vries committed
535
536
537
538
539
540
541
542
      }
  where
    pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
    pick Nothing  Nothing  = Right Nothing
    pick (Just x) Nothing  = Right $ Just x
    pick Nothing  (Just y) = Right $ Just y
    pick (Just x) (Just y) =
      if x == y then Right $ Just x
Edsko de Vries's avatar
Edsko de Vries committed
543
544
                else Left ( CS.unions [
                               CS.fromList blame
Edsko de Vries's avatar
Edsko de Vries committed
545
546
547
                             , lgConflictSet lg
                             , lgConflictSet lg'
                             ]
Edsko de Vries's avatar
Edsko de Vries committed
548
                          ,    "cannot merge " ++ showLinkGroup lg
Edsko de Vries's avatar
Edsko de Vries committed
549
550
551
552
                            ++ " and " ++ showLinkGroup lg'
                          )

lgConflictSet :: LinkGroup -> ConflictSet QPN
Edsko de Vries's avatar
Edsko de Vries committed
553
554
555
lgConflictSet lg =
               CS.fromList (map aux (S.toList (lgMembers lg)))
    `CS.union` lgBlame lg
Edsko de Vries's avatar
Edsko de Vries committed
556
557
558
559
560
561
562
563
564
565
566
567
568
569
  where
    aux pp = P (Q pp (lgPackage lg))

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

allEqual :: Eq a => [a] -> Bool
allEqual []       = True
allEqual [_]      = True
allEqual (x:y:ys) = x == y && allEqual (y:ys)

concatMapUnzip :: (a -> ([b], [c])) -> [a] -> ([b], [c])
concatMapUnzip f = (\(xs, ys) -> (concat xs, concat ys)) . unzip . map f