hackport-0.5: cabal/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Client.Dependency.Modular.Linking (
addLinking
, validateLinking
) where
import Prelude hiding (pi)
import Control.Exception (assert)
import Control.Monad.Reader
import Control.Monad.State
import Data.Maybe (catMaybes)
import Data.Map (Map, (!))
import Data.List (intercalate)
import Data.Set (Set)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Traversable as T
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Distribution.Client.Dependency.Modular.Assignment
import Distribution.Client.Dependency.Modular.Dependency
import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Index
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
import qualified Distribution.Client.Dependency.Modular.PSQ as P
import Distribution.Client.Types (OptionalStanza(..))
import Distribution.Client.ComponentDeps (Component)
{-------------------------------------------------------------------------------
Add linking
-------------------------------------------------------------------------------}
type RelatedGoals = Map (PN, I) [PP]
type Linker = Reader RelatedGoals
-- | 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.
addLinking :: Tree QGoalReasonChain -> Tree QGoalReasonChain
addLinking = (`runReader` M.empty) . cata go
where
go :: TreeF QGoalReasonChain (Linker (Tree QGoalReasonChain)) -> Linker (Tree QGoalReasonChain)
-- 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)
go _otherwise =
innM _otherwise
-- Recurse underneath package choices. Here we just need to make sure
-- that we record the package choice so that it is available below
goP :: QPN -> POption -> Linker (Tree QGoalReasonChain) -> Linker (Tree QGoalReasonChain)
goP (Q pp pn) (POption i Nothing) = local (M.insertWith (++) (pn, i) [pp])
goP _ _ = alreadyLinked
linkChoices :: RelatedGoals -> QPN -> (POption, Tree QGoalReasonChain) -> [(POption, Tree QGoalReasonChain)]
linkChoices related (Q _pp pn) (POption i Nothing, subtree) =
map aux (M.findWithDefault [] (pn, i) related)
where
aux :: PP -> (POption, Tree QGoalReasonChain)
aux pp = (POption i (Just pp), subtree)
linkChoices _ _ (POption _ (Just _), _) =
alreadyLinked
alreadyLinked :: a
alreadyLinked = error "addLinking called on tree that already contains linked nodes"
{-------------------------------------------------------------------------------
Validation
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.
-------------------------------------------------------------------------------}
data ValidateState = VS {
vsIndex :: Index
, vsLinks :: Map QPN LinkGroup
, vsFlags :: FAssignment
, vsStanzas :: SAssignment
, vsQualifyOptions :: QualifyOptions
}
deriving Show
type Validate = Reader ValidateState
-- | Validate linked packages
--
-- Verify that linked packages have
--
-- * Linked dependencies,
-- * Equal flag assignments
-- * Equal stanza assignments
validateLinking :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain
validateLinking index = (`runReader` initVS) . cata go
where
go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)
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
goP :: QPN -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
goP qpn@(Q _pp pn) opt@(POption i _) r = do
vs <- ask
let PInfo deps _ _ = vsIndex vs ! pn ! i
qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
case execUpdateState (pickPOption qpn opt qdeps) vs of
Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
Right vs' -> local (const vs') r
-- Flag choices
goF :: QFN -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
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)
goS :: QSN -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
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
, vsQualifyOptions = defaultQualifyOptions index
}
{-------------------------------------------------------------------------------
Updating the validation state
-------------------------------------------------------------------------------}
type Conflict = (ConflictSet QPN, String)
newtype UpdateState a = UpdateState {
unUpdateState :: StateT ValidateState (Either Conflict) a
}
deriving (Functor, Applicative, Monad, MonadState ValidateState)
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
pickPOption :: QPN -> POption -> FlaggedDeps comp QPN -> UpdateState ()
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
let lg = lgSingleton qpn (Just $ PI pp i)
updateLinkGroup lg
-- Package is already in a link group. Since we are picking a concrete
-- instance here, it must by definition be the canonical package.
Just lg ->
makeCanonical lg qpn i
pickLink :: QPN -> I -> PP -> FlaggedDeps comp QPN -> UpdateState ()
pickLink qpn@(Q pp pn) i pp' deps = do
vs <- get
-- Find the link group for the package we are linking to, and add this package
--
-- Since the builder never links to a package without having first picked a
-- concrete instance for that package, and since we create singleton link
-- groups for concrete instances, this link group must exist (and must
-- in fact already have a canonical member).
let lg = vsLinks vs ! Q pp' pn
-- 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
sanityCheck (Just (PI _ canonI)) = pn == lgPackage lg && i == canonI
assert (sanityCheck (lgCanon lg)) $ return ()
-- Since we already have a canonical member, we just need to add the new
-- member into the group
let lg' = lg { lgMembers = S.insert pp (lgMembers lg) }
updateLinkGroup lg'
linkDeps [P qpn] pp' deps
makeCanonical :: LinkGroup -> QPN -> I -> UpdateState ()
makeCanonical lg qpn@(Q pp _) i =
case lgCanon lg of
-- There is already a canonical member. Fail.
Just _ ->
conflict ( S.fromList (P qpn : lgBlame lg)
, "cannot make " ++ showQPN qpn
++ " canonical member of " ++ showLinkGroup lg
)
Nothing -> do
let lg' = lg { lgCanon = Just (PI pp i) }
updateLinkGroup lg'
-- | 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.
linkDeps :: [Var QPN] -> PP -> FlaggedDeps comp QPN -> UpdateState ()
linkDeps parents pp' = mapM_ go
where
go :: FlaggedDep comp QPN -> UpdateState ()
go (Simple (Dep qpn@(Q _ pn) _) _) = do
vs <- get
let qpn' = Q pp' pn
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''
-- For extensions and language dependencies, there is nothing to do.
-- No choice is involved, just checking, so there is nothing to link.
go (Simple (Ext _) _) = return ()
go (Simple (Lang _) _) = return ()
-- Similarly for pkg-config constraints
go (Simple (Pkg _ _) _) = return ()
go (Flagged fn _ t f) = do
vs <- get
case M.lookup fn (vsFlags vs) of
Nothing -> return () -- flag assignment not yet known
Just True -> linkDeps (F fn:parents) pp' t
Just False -> linkDeps (F fn:parents) pp' f
go (Stanza sn t) = do
vs <- get
case M.lookup sn (vsStanzas vs) of
Nothing -> return () -- stanza assignment not yet known
Just True -> linkDeps (S sn:parents) pp' t
Just False -> return () -- stanza not enabled; no new deps
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
-- | 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.
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
qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps
lg = vsLinks vs ! qpn
(parents, newDeps) = findNewDeps vs qdeps
linkedTo = S.delete pp (lgMembers lg)
forM_ (S.toList linkedTo) $ \pp' -> linkDeps (P qpn : parents) pp' newDeps
where
findNewDeps :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
findNewDeps vs = concatMapUnzip (findNewDeps' vs)
findNewDeps' :: ValidateState -> FlaggedDep comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
findNewDeps' _ (Simple _ _) = ([], [])
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)
-- | 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.
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 ()
else conflict ( S.fromList (map F flags) `S.union` lgConflictSet lg
, "flag " ++ show fn ++ " incompatible"
)
-- | 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''.
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 ()
else conflict ( S.fromList (map S stanzas) `S.union` lgConflictSet lg
, "stanza " ++ show sn ++ " incompatible"
)
{-------------------------------------------------------------------------------
Link groups
-------------------------------------------------------------------------------}
-- | Set of packages that must be linked together
--
-- 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.
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.
--
-- We may not know this yet (if we are constructing link groups
-- for dependencies)
, lgCanon :: Maybe (PI PP)
-- | 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)
, lgBlame :: [Var QPN]
}
deriving Show
-- | 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
showLinkGroup :: LinkGroup -> String
showLinkGroup lg =
"{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}"
where
showMember :: PP -> String
showMember pp = case lgCanon lg of
Just (PI pp' _i) | pp == pp' -> "*"
_otherwise -> ""
++ case lgInstance lg of
Nothing -> showQPN (qpn pp)
Just i -> showPI (PI (qpn pp) i)
qpn :: PP -> QPN
qpn pp = Q pp (lgPackage lg)
-- | 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
, lgBlame = []
}
lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup
lgMerge blame lg lg' = do
canon <- pick (lgCanon lg) (lgCanon lg')
return LinkGroup {
lgPackage = lgPackage lg
, lgCanon = canon
, lgMembers = lgMembers lg `S.union` lgMembers lg'
, lgBlame = blame ++ lgBlame lg ++ lgBlame lg'
}
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
else Left ( S.unions [
S.fromList blame
, lgConflictSet lg
, lgConflictSet lg'
]
, "cannot merge " ++ showLinkGroup lg
++ " and " ++ showLinkGroup lg'
)
lgConflictSet :: LinkGroup -> ConflictSet QPN
lgConflictSet lg = S.fromList (map aux (S.toList (lgMembers lg)) ++ lgBlame lg)
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