Linking.hs 20.5 KB
Newer Older
Edsko de Vries's avatar
Edsko de Vries committed
1
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
Edsko de Vries's avatar
Edsko de Vries committed
2
{-# LANGUAGE MultiParamTypeClasses #-}
3
module Distribution.Solver.Modular.Linking (
kristenk's avatar
kristenk committed
4
    validateLinking
Edsko de Vries's avatar
Edsko de Vries committed
5 6
  ) where

7
import Prelude ()
8
import Distribution.Solver.Compat.Prelude hiding (get,put)
9

Edsko de Vries's avatar
Edsko de Vries committed
10
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
import Control.Monad.State
13
import Data.Function (on)
14
import Data.Map ((!))
Edsko de Vries's avatar
Edsko de Vries committed
15
import Data.Set (Set)
Edsko de Vries's avatar
Edsko de Vries committed
16
import qualified Data.Map         as M
Edsko de Vries's avatar
Edsko de Vries committed
17
import qualified Data.Set         as S
Edsko de Vries's avatar
Edsko de Vries committed
18 19
import qualified Data.Traversable as T

20
import Distribution.Client.Utils.Assertion
21 22 23 24 25 26 27
import Distribution.Solver.Modular.Assignment
import Distribution.Solver.Modular.Dependency
import Distribution.Solver.Modular.Flag
import Distribution.Solver.Modular.Index
import Distribution.Solver.Modular.Package
import Distribution.Solver.Modular.Tree
import qualified Distribution.Solver.Modular.ConflictSet as CS
28
import qualified Distribution.Solver.Modular.WeightedPSQ as W
Edsko de Vries's avatar
Edsko de Vries committed
29

30
import Distribution.Solver.Types.OptionalStanza
31
import Distribution.Solver.Types.PackagePath
32
import Distribution.Types.GenericPackageDescription (unFlagName)
Edsko de Vries's avatar
Edsko de Vries committed
33 34 35

{-------------------------------------------------------------------------------
  Validation
Edsko de Vries's avatar
Edsko de Vries committed
36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53

  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
54 55 56 57 58 59 60
-------------------------------------------------------------------------------}

data ValidateState = VS {
      vsIndex    :: Index
    , vsLinks    :: Map QPN LinkGroup
    , vsFlags    :: FAssignment
    , vsStanzas  :: SAssignment
61
    , vsQualifyOptions :: QualifyOptions
kristenk's avatar
kristenk committed
62 63 64 65 66 67

    -- Saved qualified dependencies. Every time 'validateLinking' makes a
    -- package choice, it qualifies the package's dependencies and saves them in
    -- this map. Then the qualified dependencies are available for subsequent
    -- flag and stanza choices for the same package.
    , vsSaved    :: Map QPN (FlaggedDeps QPN)
Edsko de Vries's avatar
Edsko de Vries committed
68 69 70 71 72 73 74 75 76 77
    }

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
78
-- * Equal stanza assignments
79
validateLinking :: Index -> Tree d c -> Tree d c
Edsko de Vries's avatar
Edsko de Vries committed
80 81
validateLinking index = (`runReader` initVS) . cata go
  where
82
    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)
Edsko de Vries's avatar
Edsko de Vries committed
83

84 85 86 87 88 89
    go (PChoiceF qpn rdm gr       cs) =
      PChoice qpn rdm gr       <$> T.sequence (W.mapWithKey (goP qpn) cs)
    go (FChoiceF qfn rdm gr t m d cs) =
      FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs)
    go (SChoiceF qsn rdm gr t     cs) =
      SChoice qsn rdm gr t     <$> T.sequence (W.mapWithKey (goS qsn) cs)
Edsko de Vries's avatar
Edsko de Vries committed
90 91

    -- For the other nodes we just recurse
92
    go (GoalChoiceF rdm           cs) = GoalChoice rdm <$> T.sequence cs
93
    go (DoneF revDepMap s)            = return $ Done revDepMap s
Edsko de Vries's avatar
Edsko de Vries committed
94 95 96
    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason

    -- Package choices
97
    goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
98
    goP qpn@(Q _pp pn) opt@(POption i _) r = do
Edsko de Vries's avatar
Edsko de Vries committed
99
      vs <- ask
100 101 102
      let PInfo deps _ _ _ = vsIndex vs ! pn ! i
          qdeps            = qualifyDeps (vsQualifyOptions vs) qpn deps
          newSaved         = M.insert qpn qdeps (vsSaved vs)
Edsko de Vries's avatar
Edsko de Vries committed
103 104
      case execUpdateState (pickPOption qpn opt qdeps) vs of
        Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
kristenk's avatar
kristenk committed
105
        Right vs'       -> local (const vs' { vsSaved = newSaved }) r
Edsko de Vries's avatar
Edsko de Vries committed
106 107

    -- Flag choices
108
    goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
Edsko de Vries's avatar
Edsko de Vries committed
109 110 111 112 113 114 115
    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)
116
    goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
Edsko de Vries's avatar
Edsko de Vries committed
117 118 119 120 121 122 123 124 125 126 127 128
    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
129
      , vsQualifyOptions = defaultQualifyOptions index
kristenk's avatar
kristenk committed
130
      , vsSaved   = M.empty
Edsko de Vries's avatar
Edsko de Vries committed
131 132 133 134 135 136
      }

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

137
type Conflict = (ConflictSet, String)
Edsko de Vries's avatar
Edsko de Vries committed
138 139 140 141

newtype UpdateState a = UpdateState {
    unUpdateState :: StateT ValidateState (Either Conflict) a
  }
Edsko de Vries's avatar
Edsko de Vries committed
142 143 144 145 146
  deriving (Functor, Applicative, Monad)

instance MonadState ValidateState UpdateState where
  get    = UpdateState $ get
  put st = UpdateState $ do
147
             expensiveAssert (lgInvariant $ vsLinks st) $ return ()
Edsko de Vries's avatar
Edsko de Vries committed
148
             put st
Edsko de Vries's avatar
Edsko de Vries committed
149 150 151 152 153 154 155 156 157 158

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

kristenk's avatar
kristenk committed
159
pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
Edsko de Vries's avatar
Edsko de Vries committed
160 161 162 163 164 165 166 167 168
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
169
        let lg = lgSingleton qpn (Just $ PI pp i)
Edsko de Vries's avatar
Edsko de Vries committed
170 171 172
        updateLinkGroup lg

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

kristenk's avatar
kristenk committed
177
pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
Edsko de Vries's avatar
Edsko de Vries committed
178
pickLink qpn@(Q _pp pn) i pp' deps = do
Edsko de Vries's avatar
Edsko de Vries committed
179
    vs <- get
Edsko de Vries's avatar
Edsko de Vries committed
180 181 182 183 184 185 186 187

    -- 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
188 189 190
    --
    -- 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
191 192
    -- 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
193
    let target   = Q pp' pn
194
        lgTarget = vsLinks vs ! target
Edsko de Vries's avatar
Edsko de Vries committed
195 196 197 198

    -- 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.
199
    let sanityCheck :: Maybe (PI PackagePath) -> Bool
Edsko de Vries's avatar
Edsko de Vries committed
200
        sanityCheck Nothing              = False
Edsko de Vries's avatar
Edsko de Vries committed
201 202 203 204
        sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI
    assert (sanityCheck (lgCanon lgTarget)) $ return ()

    -- Merge the two link groups (updateLinkGroup will propagate the change)
205
    lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget
Edsko de Vries's avatar
Edsko de Vries committed
206 207 208
    updateLinkGroup lgTarget'

    -- Make sure all dependencies are linked as well
209
    linkDeps target deps
Edsko de Vries's avatar
Edsko de Vries committed
210

Edsko de Vries's avatar
Edsko de Vries committed
211 212
makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()
makeCanonical lg qpn@(Q pp _) i =
Edsko de Vries's avatar
Edsko de Vries committed
213 214 215
    case lgCanon lg of
      -- There is already a canonical member. Fail.
      Just _ ->
216
        conflict ( CS.insert (P qpn) (lgConflictSet lg)
Edsko de Vries's avatar
Edsko de Vries committed
217 218 219 220
                 ,    "cannot make " ++ showQPN qpn
                   ++ " canonical member of " ++ showLinkGroup lg
                 )
      Nothing -> do
Edsko de Vries's avatar
Edsko de Vries committed
221
        let lg' = lg { lgCanon = Just (PI pp i) }
Edsko de Vries's avatar
Edsko de Vries committed
222 223
        updateLinkGroup lg'

Edsko de Vries's avatar
Edsko de Vries committed
224 225 226 227 228 229 230 231 232
-- | 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.
233 234
linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()
linkDeps target = \deps -> do
235 236 237 238 239
    -- linkDeps is called in two places: when we first link one package to
    -- another, and when we discover more dependencies of an already linked
    -- package after doing some flag assignment. It is therefore important that
    -- flag assignments cannot influence _how_ dependencies are qualified;
    -- fortunately this is a documented property of 'qualifyDeps'.
Edsko de Vries's avatar
Edsko de Vries committed
240
    rdeps <- requalify deps
241
    go deps rdeps
Edsko de Vries's avatar
Edsko de Vries committed
242
  where
243 244
    go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
    go = zipWithM_ go1
Edsko de Vries's avatar
Edsko de Vries committed
245

246 247
    go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
    go1 dep rdep = case (dep, rdep) of
248
      (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do
Edsko de Vries's avatar
Edsko de Vries committed
249 250 251
        vs <- get
        let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs
            lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
252
        lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToCS) dr1 dr2) lg lg'
Edsko de Vries's avatar
Edsko de Vries committed
253 254 255 256 257
        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
258 259
          Just True  -> go t t'
          Just False -> go f f'
Edsko de Vries's avatar
Edsko de Vries committed
260 261 262 263
      (Stanza sn t, ~(Stanza _ t')) -> do
        vs <- get
        case M.lookup sn (vsStanzas vs) of
          Nothing    -> return () -- stanza assignment not yet known
264
          Just True  -> go t t'
Edsko de Vries's avatar
Edsko de Vries committed
265
          Just False -> return () -- stanza not enabled; no new deps
266 267
    -- 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
268
    -- The same goes for for pkg-config constraints.
269 270 271
      (Simple (LDep _ (Ext  _))   _, _) -> return ()
      (Simple (LDep _ (Lang _))   _, _) -> return ()
      (Simple (LDep _ (Pkg  _ _)) _, _) -> return ()
Edsko de Vries's avatar
Edsko de Vries committed
272

kristenk's avatar
kristenk committed
273
    requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
Edsko de Vries's avatar
Edsko de Vries committed
274
    requalify deps = do
Edsko de Vries's avatar
Edsko de Vries committed
275
      vs <- get
Edsko de Vries's avatar
Edsko de Vries committed
276
      return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)
Edsko de Vries's avatar
Edsko de Vries committed
277 278 279 280 281 282 283 284 285 286 287 288 289

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

290
-- | Link dependencies that we discover after making a flag or stanza choice.
Edsko de Vries's avatar
Edsko de Vries committed
291 292 293 294 295 296
--
-- 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
297 298 299
linkNewDeps :: Var QPN -> Bool -> UpdateState ()
linkNewDeps var b = do
    vs <- get
kristenk's avatar
kristenk committed
300 301
    let qpn@(Q pp pn)           = varPN var
        qdeps                   = vsSaved vs ! qpn
Edsko de Vries's avatar
Edsko de Vries committed
302
        lg                      = vsLinks vs ! qpn
303
        newDeps                 = findNewDeps vs qdeps
Edsko de Vries's avatar
Edsko de Vries committed
304
        linkedTo                = S.delete pp (lgMembers lg)
305
    forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps
Edsko de Vries's avatar
Edsko de Vries committed
306
  where
307 308
    findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
    findNewDeps vs = concatMap (findNewDeps' vs)
Edsko de Vries's avatar
Edsko de Vries committed
309

310 311
    findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
    findNewDeps' _  (Simple _ _)        = []
Edsko de Vries's avatar
Edsko de Vries committed
312 313
    findNewDeps' vs (Flagged qfn _ t f) =
      case (F qfn == var, M.lookup qfn (vsFlags vs)) of
314 315 316
        (True, _)    -> if b then t else f
        (_, Nothing) -> [] -- not yet known
        (_, Just b') -> findNewDeps vs (if b' then t else f)
Edsko de Vries's avatar
Edsko de Vries committed
317 318
    findNewDeps' vs (Stanza qsn t) =
      case (S qsn == var, M.lookup qsn (vsStanzas vs)) of
319 320 321
        (True, _)    -> if b then t else []
        (_, Nothing) -> [] -- not yet known
        (_, Just b') -> findNewDeps vs (if b' then t else [])
Edsko de Vries's avatar
Edsko de Vries committed
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348

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
349
        let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i
Edsko de Vries's avatar
Edsko de Vries committed
350 351 352
            flags   = M.keys finfo
            stanzas = [TestStanzas, BenchStanzas]
        forM_ flags $ \fn -> do
353
          let flag = FN (lgPackage lg) fn
Edsko de Vries's avatar
Edsko de Vries committed
354 355
          verifyFlag' flag lg
        forM_ stanzas $ \sn -> do
356
          let stanza = SN (lgPackage lg) sn
Edsko de Vries's avatar
Edsko de Vries committed
357 358 359
          verifyStanza' stanza lg

verifyFlag :: QFN -> UpdateState ()
360
verifyFlag (FN qpn@(Q _pp pn) fn) = do
Edsko de Vries's avatar
Edsko de Vries committed
361 362
    vs <- get
    -- We can only pick a flag after picking an instance; link group must exist
363
    verifyFlag' (FN pn fn) (vsLinks vs ! qpn)
Edsko de Vries's avatar
Edsko de Vries committed
364 365

verifyStanza :: QSN -> UpdateState ()
366
verifyStanza (SN qpn@(Q _pp pn) sn) = do
Edsko de Vries's avatar
Edsko de Vries committed
367 368
    vs <- get
    -- We can only pick a stanza after picking an instance; link group must exist
369
    verifyStanza' (SN pn sn) (vsLinks vs ! qpn)
Edsko de Vries's avatar
Edsko de Vries committed
370

Edsko de Vries's avatar
Edsko de Vries committed
371 372 373 374 375
-- | 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
376
verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
377
verifyFlag' (FN pn fn) lg = do
Edsko de Vries's avatar
Edsko de Vries committed
378
    vs <- get
379
    let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg))
Edsko de Vries's avatar
Edsko de Vries committed
380 381 382
        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
383
      else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg
384
                    , "flag \"" ++ unFlagName fn ++ "\" incompatible"
Edsko de Vries's avatar
Edsko de Vries committed
385 386
                    )

Edsko de Vries's avatar
Edsko de Vries committed
387 388 389 390 391 392 393
-- | 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
394
verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
395
verifyStanza' (SN pn sn) lg = do
Edsko de Vries's avatar
Edsko de Vries committed
396
    vs <- get
397
    let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg))
Edsko de Vries's avatar
Edsko de Vries committed
398 399 400
        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
401
      else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg
402
                    , "stanza \"" ++ showStanza sn ++ "\" incompatible"
Edsko de Vries's avatar
Edsko de Vries committed
403 404 405 406 407 408 409
                    )

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

-- | Set of packages that must be linked together
Edsko de Vries's avatar
Edsko de Vries committed
410 411 412 413 414 415
--
-- 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
416 417 418 419 420 421 422
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
423 424 425
      --
      -- We may not know this yet (if we are constructing link groups
      -- for dependencies)
426
    , lgCanon :: Maybe (PI PackagePath)
Edsko de Vries's avatar
Edsko de Vries committed
427 428

      -- | The members of the link group
429
    , lgMembers :: Set PackagePath
Edsko de Vries's avatar
Edsko de Vries committed
430 431 432 433

      -- | 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)
434
    , lgBlame :: ConflictSet
Edsko de Vries's avatar
Edsko de Vries committed
435
    }
Edsko de Vries's avatar
Edsko de Vries committed
436 437 438 439 440 441 442 443 444 445 446 447
    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
448

Edsko de Vries's avatar
Edsko de Vries committed
449 450 451 452 453 454
-- | 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
455 456 457 458
showLinkGroup :: LinkGroup -> String
showLinkGroup lg =
    "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"
  where
459
    showMember :: PackagePath -> String
Edsko de Vries's avatar
Edsko de Vries committed
460 461 462
    showMember pp = case lgCanon lg of
                      Just (PI pp' _i) | pp == pp' -> "*"
                      _otherwise                   -> ""
Edsko de Vries's avatar
Edsko de Vries committed
463 464 465 466
                 ++ case lgInstance lg of
                      Nothing -> showQPN (qpn pp)
                      Just i  -> showPI (PI (qpn pp) i)

467
    qpn :: PackagePath -> QPN
Edsko de Vries's avatar
Edsko de Vries committed
468 469
    qpn pp = Q pp (lgPackage lg)

Edsko de Vries's avatar
Edsko de Vries committed
470
-- | Creates a link group that contains a single member.
471
lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
Edsko de Vries's avatar
Edsko de Vries committed
472 473 474 475
lgSingleton (Q pp pn) canon = LinkGroup {
      lgPackage = pn
    , lgCanon   = canon
    , lgMembers = S.singleton pp
Edsko de Vries's avatar
Edsko de Vries committed
476
    , lgBlame   = CS.empty
Edsko de Vries's avatar
Edsko de Vries committed
477 478
    }

479
lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
Edsko de Vries's avatar
Edsko de Vries committed
480
lgMerge blame lg lg' = do
Edsko de Vries's avatar
Edsko de Vries committed
481
    canon <- pick (lgCanon lg) (lgCanon lg')
Edsko de Vries's avatar
Edsko de Vries committed
482
    return LinkGroup {
Edsko de Vries's avatar
Edsko de Vries committed
483 484 485
        lgPackage = lgPackage lg
      , lgCanon   = canon
      , lgMembers = lgMembers lg `S.union` lgMembers lg'
486
      , lgBlame   = CS.unions [blame, lgBlame lg, lgBlame lg']
Edsko de Vries's avatar
Edsko de Vries committed
487 488 489 490 491 492 493 494
      }
  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
495
                else Left ( CS.unions [
496
                               blame
Edsko de Vries's avatar
Edsko de Vries committed
497 498 499
                             , lgConflictSet lg
                             , lgConflictSet lg'
                             ]
Edsko de Vries's avatar
Edsko de Vries committed
500
                          ,    "cannot merge " ++ showLinkGroup lg
Edsko de Vries's avatar
Edsko de Vries committed
501 502 503
                            ++ " and " ++ showLinkGroup lg'
                          )

504
lgConflictSet :: LinkGroup -> ConflictSet
Edsko de Vries's avatar
Edsko de Vries committed
505 506 507
lgConflictSet lg =
               CS.fromList (map aux (S.toList (lgMembers lg)))
    `CS.union` lgBlame lg
Edsko de Vries's avatar
Edsko de Vries committed
508 509 510 511 512 513 514 515 516 517 518
  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)