cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs

   1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   2 {-# LANGUAGE MultiParamTypeClasses #-}
   3
   4 -- TODO: remove this
   5 {-# OPTIONS -fno-warn-incomplete-uni-patterns #-}
   6 module Distribution.Solver.Modular.Linking (
   7     validateLinking
   8   ) where
   9
  10 import Prelude ()
  11 import Distribution.Solver.Compat.Prelude hiding (get,put)
  12
  13 import Control.Exception (assert)
  14 import Control.Monad (forM_, zipWithM_)
  15 import Control.Monad.Reader (Reader, runReader, local, ask)
  16 import Control.Monad.State (MonadState, StateT, get, put, modify, execStateT)
  17 import Control.Monad.Trans (lift)
  18 import Data.Map ((!))
  19 import qualified Data.Map         as M
  20 import qualified Data.Set         as S
  21 import qualified Data.Traversable as T
  22
  23 import Distribution.Client.Utils.Assertion
  24 import Distribution.Solver.Modular.Assignment
  25 import Distribution.Solver.Modular.Dependency
  26 import Distribution.Solver.Modular.Flag
  27 import Distribution.Solver.Modular.Index
  28 import Distribution.Solver.Modular.Package
  29 import Distribution.Solver.Modular.Tree
  30 import qualified Distribution.Solver.Modular.ConflictSet as CS
  31 import qualified Distribution.Solver.Modular.WeightedPSQ as W
  32
  33 import Distribution.Solver.Types.OptionalStanza
  34 import Distribution.Solver.Types.PackagePath
  35 import Distribution.Types.Flag (unFlagName)
  36
  37 {-------------------------------------------------------------------------------
  38   Validation
  39
  40   Validation of links is a separate pass that's performed after normal
  41   validation. Validation of links checks that if the tree indicates that a
  42   package is linked, then everything underneath that choice really matches the
  43   package we have linked to.
  44
  45   This is interesting because it isn't unidirectional. Consider that we've
  46   chosen a.foo to be version 1 and later decide that b.foo should link to a.foo.
  47   Now foo depends on bar. Because a.foo and b.foo are linked, it's required that
  48   a.bar and b.bar are also linked. However, it's not required that we actually
  49   choose a.bar before b.bar. Goal choice order is relatively free. It's possible
  50   that we choose a.bar first, but also possible that we choose b.bar first. In
  51   both cases, we have to recognize that we have freedom of choice for the first
  52   of the two, but no freedom of choice for the second.
  53
  54   This is what LinkGroups are all about. Using LinkGroup, we can record (in the
  55   situation above) that a.bar and b.bar need to be linked even if we haven't
  56   chosen either of them yet.
  57 -------------------------------------------------------------------------------}
  58
  59 data ValidateState = VS {
  60       vsIndex    :: Index
  61     , vsLinks    :: Map QPN LinkGroup
  62     , vsFlags    :: FAssignment
  63     , vsStanzas  :: SAssignment
  64     , vsQualifyOptions :: QualifyOptions
  65
  66     -- Saved qualified dependencies. Every time 'validateLinking' makes a
  67     -- package choice, it qualifies the package's dependencies and saves them in
  68     -- this map. Then the qualified dependencies are available for subsequent
  69     -- flag and stanza choices for the same package.
  70     , vsSaved    :: Map QPN (FlaggedDeps QPN)
  71     }
  72
  73 type Validate = Reader ValidateState
  74
  75 -- | Validate linked packages
  76 --
  77 -- Verify that linked packages have
  78 --
  79 -- * Linked dependencies,
  80 -- * Equal flag assignments
  81 -- * Equal stanza assignments
  82 validateLinking :: Index -> Tree d c -> Tree d c
  83 validateLinking index = (`runReader` initVS) . go
  84   where
  85     go :: Tree d c -> Validate (Tree d c)
  86
  87     go (PChoice qpn rdm gr       cs) =
  88       PChoice qpn rdm gr       <$> W.traverseWithKey (goP qpn) (fmap go cs)
  89     go (FChoice qfn rdm gr t m d cs) =
  90       FChoice qfn rdm gr t m d <$> W.traverseWithKey (goF qfn) (fmap go cs)
  91     go (SChoice qsn rdm gr t     cs) =
  92       SChoice qsn rdm gr t     <$> W.traverseWithKey (goS qsn) (fmap go cs)
  93
  94     -- For the other nodes we just recurse
  95     go (GoalChoice rdm           cs) = GoalChoice rdm <$> T.traverse go cs
  96     go (Done revDepMap s)            = return $ Done revDepMap s
  97     go (Fail conflictSet failReason) = return $ Fail conflictSet failReason
  98
  99     -- Package choices
 100     goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c)
 101     goP qpn@(Q _pp pn) opt@(POption i _) r = do
 102       vs <- ask
 103       let PInfo deps _ _ _ = vsIndex vs ! pn ! i
 104           qdeps            = qualifyDeps (vsQualifyOptions vs) qpn deps
 105           newSaved         = M.insert qpn qdeps (vsSaved vs)
 106       case execUpdateState (pickPOption qpn opt qdeps) vs of
 107         Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
 108         Right vs'       -> local (const vs' { vsSaved = newSaved }) r
 109
 110     -- Flag choices
 111     goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
 112     goF qfn b r = do
 113       vs <- ask
 114       case execUpdateState (pickFlag qfn b) vs of
 115         Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
 116         Right vs'       -> local (const vs') r
 117
 118     -- Stanza choices (much the same as flag choices)
 119     goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
 120     goS qsn b r = do
 121       vs <- ask
 122       case execUpdateState (pickStanza qsn b) vs of
 123         Left  (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
 124         Right vs'       -> local (const vs') r
 125
 126     initVS :: ValidateState
 127     initVS = VS {
 128         vsIndex   = index
 129       , vsLinks   = M.empty
 130       , vsFlags   = M.empty
 131       , vsStanzas = M.empty
 132       , vsQualifyOptions = defaultQualifyOptions index
 133       , vsSaved   = M.empty
 134       }
 135
 136 {-------------------------------------------------------------------------------
 137   Updating the validation state
 138 -------------------------------------------------------------------------------}
 139
 140 type Conflict = (ConflictSet, String)
 141
 142 newtype UpdateState a = UpdateState {
 143     unUpdateState :: StateT ValidateState (Either Conflict) a
 144   }
 145   deriving (Functor, Applicative, Monad)
 146
 147 instance MonadState ValidateState UpdateState where
 148   get    = UpdateState $ get
 149   put st = UpdateState $ do
 150              expensiveAssert (lgInvariant $ vsLinks st) $ return ()
 151              put st
 152
 153 lift' :: Either Conflict a -> UpdateState a
 154 lift' = UpdateState . lift
 155
 156 conflict :: Conflict -> UpdateState a
 157 conflict = lift' . Left
 158
 159 execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
 160 execUpdateState = execStateT . unUpdateState
 161
 162 pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
 163 pickPOption qpn (POption i Nothing)    _deps = pickConcrete qpn i
 164 pickPOption qpn (POption i (Just pp'))  deps = pickLink     qpn i pp' deps
 165
 166 pickConcrete :: QPN -> I -> UpdateState ()
 167 pickConcrete qpn@(Q pp _) i = do
 168     vs <- get
 169     case M.lookup qpn (vsLinks vs) of
 170       -- Package is not yet in a LinkGroup. Create a new singleton link group.
 171       Nothing -> do
 172         let lg = lgSingleton qpn (Just $ PI pp i)
 173         updateLinkGroup lg
 174
 175       -- Package is already in a link group. Since we are picking a concrete
 176       -- instance here, it must by definition be the canonical package.
 177       Just lg ->
 178         makeCanonical lg qpn i
 179
 180 pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState ()
 181 pickLink qpn@(Q _pp pn) i pp' deps = do
 182     vs <- get
 183
 184     -- The package might already be in a link group
 185     -- (because one of its reverse dependencies is)
 186     let lgSource = case M.lookup qpn (vsLinks vs) of
 187                      Nothing -> lgSingleton qpn Nothing
 188                      Just lg -> lg
 189
 190     -- Find the link group for the package we are linking to
 191     --
 192     -- Since the builder never links to a package without having first picked a
 193     -- concrete instance for that package, and since we create singleton link
 194     -- groups for concrete instances, this link group must exist (and must
 195     -- in fact already have a canonical member).
 196     let target   = Q pp' pn
 197         lgTarget = vsLinks vs ! target
 198
 199     -- Verify here that the member we add is in fact for the same package and
 200     -- matches the version of the canonical instance. However, violations of
 201     -- these checks would indicate a bug in the linker, not a true conflict.
 202     let sanityCheck :: Maybe (PI PackagePath) -> Bool
 203         sanityCheck Nothing              = False
 204         sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI
 205     assert (sanityCheck (lgCanon lgTarget)) $ return ()
 206
 207     -- Merge the two link groups (updateLinkGroup will propagate the change)
 208     lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget
 209     updateLinkGroup lgTarget'
 210
 211     -- Make sure all dependencies are linked as well
 212     linkDeps target deps
 213
 214 makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()
 215 makeCanonical lg qpn@(Q pp _) i =
 216     case lgCanon lg of
 217       -- There is already a canonical member. Fail.
 218       Just _ ->
 219         conflict ( CS.insert (P qpn) (lgConflictSet lg)
 220                  ,    "cannot make " ++ showQPN qpn
 221                    ++ " canonical member of " ++ showLinkGroup lg
 222                  )
 223       Nothing -> do
 224         let lg' = lg { lgCanon = Just (PI pp i) }
 225         updateLinkGroup lg'
 226
 227 -- | Link the dependencies of linked parents.
 228 --
 229 -- When we decide to link one package against another we walk through the
 230 -- package's direct dependencies and make sure that they're all linked to each
 231 -- other by merging their link groups (or creating new singleton link groups if
 232 -- they don't have link groups yet). We do not need to do this recursively,
 233 -- because having the direct dependencies in a link group means that we must
 234 -- have already made or will make sooner or later a link choice for one of these
 235 -- as well, and cover their dependencies at that point.
 236 linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState ()
 237 linkDeps target = \deps -> do
 238     -- linkDeps is called in two places: when we first link one package to
 239     -- another, and when we discover more dependencies of an already linked
 240     -- package after doing some flag assignment. It is therefore important that
 241     -- flag assignments cannot influence _how_ dependencies are qualified;
 242     -- fortunately this is a documented property of 'qualifyDeps'.
 243     rdeps <- requalify deps
 244     go deps rdeps
 245   where
 246     go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState ()
 247     go = zipWithM_ go1
 248
 249     go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState ()
 250     go1 dep rdep = case (dep, rdep) of
 251       (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do
 252         vs <- get
 253         let lg   = M.findWithDefault (lgSingleton qpn  Nothing) qpn  $ vsLinks vs
 254             lg'  = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
 255         lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg'
 256         updateLinkGroup lg''
 257       (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do
 258         vs <- get
 259         case M.lookup fn (vsFlags vs) of
 260           Nothing    -> return () -- flag assignment not yet known
 261           Just True  -> go t t'
 262           Just False -> go f f'
 263       (Stanza sn t, ~(Stanza _ t')) -> do
 264         vs <- get
 265         case M.lookup sn (vsStanzas vs) of
 266           Nothing    -> return () -- stanza assignment not yet known
 267           Just True  -> go t t'
 268           Just False -> return () -- stanza not enabled; no new deps
 269     -- For extensions and language dependencies, there is nothing to do.
 270     -- No choice is involved, just checking, so there is nothing to link.
 271     -- The same goes for pkg-config constraints.
 272       (Simple (LDep _ (Ext  _))   _, _) -> return ()
 273       (Simple (LDep _ (Lang _))   _, _) -> return ()
 274       (Simple (LDep _ (Pkg  _ _)) _, _) -> return ()
 275
 276     requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN)
 277     requalify deps = do
 278       vs <- get
 279       return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps)
 280
 281 pickFlag :: QFN -> Bool -> UpdateState ()
 282 pickFlag qfn b = do
 283     modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) }
 284     verifyFlag qfn
 285     linkNewDeps (F qfn) b
 286
 287 pickStanza :: QSN -> Bool -> UpdateState ()
 288 pickStanza qsn b = do
 289     modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) }
 290     verifyStanza qsn
 291     linkNewDeps (S qsn) b
 292
 293 -- | Link dependencies that we discover after making a flag or stanza choice.
 294 --
 295 -- When we make a flag choice for a package, then new dependencies for that
 296 -- package might become available. If the package under consideration is in a
 297 -- non-trivial link group, then these new dependencies have to be linked as
 298 -- well. In linkNewDeps, we compute such new dependencies and make sure they are
 299 -- linked.
 300 linkNewDeps :: Var QPN -> Bool -> UpdateState ()
 301 linkNewDeps var b = do
 302     vs <- get
 303     let qpn@(Q pp pn)           = varPN var
 304         qdeps                   = vsSaved vs ! qpn
 305         lg                      = vsLinks vs ! qpn
 306         newDeps                 = findNewDeps vs qdeps
 307         linkedTo                = S.delete pp (lgMembers lg)
 308     forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps
 309   where
 310     findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN
 311     findNewDeps vs = concatMap (findNewDeps' vs)
 312
 313     findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN
 314     findNewDeps' _  (Simple _ _)        = []
 315     findNewDeps' vs (Flagged qfn _ t f) =
 316       case (F qfn == var, M.lookup qfn (vsFlags vs)) of
 317         (True, _)    -> if b then t else f
 318         (_, Nothing) -> [] -- not yet known
 319         (_, Just b') -> findNewDeps vs (if b' then t else f)
 320     findNewDeps' vs (Stanza qsn t) =
 321       case (S qsn == var, M.lookup qsn (vsStanzas vs)) of
 322         (True, _)    -> if b then t else []
 323         (_, Nothing) -> [] -- not yet known
 324         (_, Just b') -> findNewDeps vs (if b' then t else [])
 325
 326 updateLinkGroup :: LinkGroup -> UpdateState ()
 327 updateLinkGroup lg = do
 328     verifyLinkGroup lg
 329     modify $ \vs -> vs {
 330         vsLinks =           M.fromList (map aux (S.toList (lgMembers lg)))
 331                   `M.union` vsLinks vs
 332       }
 333   where
 334     aux pp = (Q pp (lgPackage lg), lg)
 335
 336 {-------------------------------------------------------------------------------
 337   Verification
 338 -------------------------------------------------------------------------------}
 339
 340 verifyLinkGroup :: LinkGroup -> UpdateState ()
 341 verifyLinkGroup lg =
 342     case lgInstance lg of
 343       -- No instance picked yet. Nothing to verify
 344       Nothing ->
 345         return ()
 346
 347       -- We picked an instance. Verify flags and stanzas
 348       -- TODO: The enumeration of OptionalStanza names is very brittle;
 349       -- if a constructor is added to the datatype we won't notice it here
 350       Just i -> do
 351         vs <- get
 352         let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i
 353             flags   = M.keys finfo
 354             stanzas = [TestStanzas, BenchStanzas]
 355         forM_ flags $ \fn -> do
 356           let flag = FN (lgPackage lg) fn
 357           verifyFlag' flag lg
 358         forM_ stanzas $ \sn -> do
 359           let stanza = SN (lgPackage lg) sn
 360           verifyStanza' stanza lg
 361
 362 verifyFlag :: QFN -> UpdateState ()
 363 verifyFlag (FN qpn@(Q _pp pn) fn) = do
 364     vs <- get
 365     -- We can only pick a flag after picking an instance; link group must exist
 366     verifyFlag' (FN pn fn) (vsLinks vs ! qpn)
 367
 368 verifyStanza :: QSN -> UpdateState ()
 369 verifyStanza (SN qpn@(Q _pp pn) sn) = do
 370     vs <- get
 371     -- We can only pick a stanza after picking an instance; link group must exist
 372     verifyStanza' (SN pn sn) (vsLinks vs ! qpn)
 373
 374 -- | Verify that all packages in the link group agree on flag assignments
 375 --
 376 -- For the given flag and the link group, obtain all assignments for the flag
 377 -- that have already been made for link group members, and check that they are
 378 -- equal.
 379 verifyFlag' :: FN PN -> LinkGroup -> UpdateState ()
 380 verifyFlag' (FN pn fn) lg = do
 381     vs <- get
 382     let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg))
 383         vals  = map (`M.lookup` vsFlags vs) flags
 384     if allEqual (catMaybes vals) -- We ignore not-yet assigned flags
 385       then return ()
 386       else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg
 387                     , "flag \"" ++ unFlagName fn ++ "\" incompatible"
 388                     )
 389
 390 -- | Verify that all packages in the link group agree on stanza assignments
 391 --
 392 -- For the given stanza and the link group, obtain all assignments for the
 393 -- stanza that have already been made for link group members, and check that
 394 -- they are equal.
 395 --
 396 -- This function closely mirrors 'verifyFlag''.
 397 verifyStanza' :: SN PN -> LinkGroup -> UpdateState ()
 398 verifyStanza' (SN pn sn) lg = do
 399     vs <- get
 400     let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg))
 401         vals    = map (`M.lookup` vsStanzas vs) stanzas
 402     if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas
 403       then return ()
 404       else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg
 405                     , "stanza \"" ++ showStanza sn ++ "\" incompatible"
 406                     )
 407
 408 {-------------------------------------------------------------------------------
 409   Link groups
 410 -------------------------------------------------------------------------------}
 411
 412 -- | Set of packages that must be linked together
 413 --
 414 -- A LinkGroup is between several qualified package names. In the validation
 415 -- state, we maintain a map vsLinks from qualified package names to link groups.
 416 -- There is an invariant that for all members of a link group, vsLinks must map
 417 -- to the same link group. The function updateLinkGroup can be used to
 418 -- re-establish this invariant after creating or expanding a LinkGroup.
 419 data LinkGroup = LinkGroup {
 420       -- | The name of the package of this link group
 421       lgPackage :: PN
 422
 423       -- | The canonical member of this link group (the one where we picked
 424       -- a concrete instance). Once we have picked a canonical member, all
 425       -- other packages must link to this one.
 426       --
 427       -- We may not know this yet (if we are constructing link groups
 428       -- for dependencies)
 429     , lgCanon :: Maybe (PI PackagePath)
 430
 431       -- | The members of the link group
 432     , lgMembers :: Set PackagePath
 433
 434       -- | The set of variables that should be added to the conflict set if
 435       -- something goes wrong with this link set (in addition to the members
 436       -- of the link group itself)
 437     , lgBlame :: ConflictSet
 438     }
 439     deriving (Show, Eq)
 440
 441 -- | Invariant for the set of link groups: every element in the link group
 442 -- must be pointing to the /same/ link group
 443 lgInvariant :: Map QPN LinkGroup -> Bool
 444 lgInvariant links = all invGroup (M.elems links)
 445   where
 446     invGroup :: LinkGroup -> Bool
 447     invGroup lg = allEqual $ map (`M.lookup` links) members
 448       where
 449         members :: [QPN]
 450         members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg)
 451
 452 -- | Package version of this group
 453 --
 454 -- This is only known once we have picked a canonical element.
 455 lgInstance :: LinkGroup -> Maybe I
 456 lgInstance = fmap (\(PI _ i) -> i) . lgCanon
 457
 458 showLinkGroup :: LinkGroup -> String
 459 showLinkGroup lg =
 460     "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"
 461   where
 462     showMember :: PackagePath -> String
 463     showMember pp = case lgCanon lg of
 464                       Just (PI pp' _i) | pp == pp' -> "*"
 465                       _otherwise                   -> ""
 466                  ++ case lgInstance lg of
 467                       Nothing -> showQPN (qpn pp)
 468                       Just i  -> showPI (PI (qpn pp) i)
 469
 470     qpn :: PackagePath -> QPN
 471     qpn pp = Q pp (lgPackage lg)
 472
 473 -- | Creates a link group that contains a single member.
 474 lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup
 475 lgSingleton (Q pp pn) canon = LinkGroup {
 476       lgPackage = pn
 477     , lgCanon   = canon
 478     , lgMembers = S.singleton pp
 479     , lgBlame   = CS.empty
 480     }
 481
 482 lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
 483 lgMerge blame lg lg' = do
 484     canon <- pick (lgCanon lg) (lgCanon lg')
 485     return LinkGroup {
 486         lgPackage = lgPackage lg
 487       , lgCanon   = canon
 488       , lgMembers = lgMembers lg `S.union` lgMembers lg'
 489       , lgBlame   = CS.unions [blame, lgBlame lg, lgBlame lg']
 490       }
 491   where
 492     pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a)
 493     pick Nothing  Nothing  = Right Nothing
 494     pick (Just x) Nothing  = Right $ Just x
 495     pick Nothing  (Just y) = Right $ Just y
 496     pick (Just x) (Just y) =
 497       if x == y then Right $ Just x
 498                 else Left ( CS.unions [
 499                                blame
 500                              , lgConflictSet lg
 501                              , lgConflictSet lg'
 502                              ]
 503                           ,    "cannot merge " ++ showLinkGroup lg
 504                             ++ " and " ++ showLinkGroup lg'
 505                           )
 506
 507 lgConflictSet :: LinkGroup -> ConflictSet
 508 lgConflictSet lg =
 509                CS.fromList (map aux (S.toList (lgMembers lg)))
 510     `CS.union` lgBlame lg
 511   where
 512     aux pp = P (Q pp (lgPackage lg))
 513
 514 {-------------------------------------------------------------------------------
 515   Auxiliary
 516 -------------------------------------------------------------------------------}
 517
 518 allEqual :: Eq a => [a] -> Bool
 519 allEqual []       = True
 520 allEqual [_]      = True
 521 allEqual (x:y:ys) = x == y && allEqual (y:ys)