diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs index ad518f2af12..0560ff0f89e 100644 --- a/cabal-install/Distribution/Client/Dependency.hs +++ b/cabal-install/Distribution/Client/Dependency.hs @@ -513,12 +513,12 @@ resolveDependencies :: Platform --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages resolveDependencies platform comp _solver params | null (depResolverTargets params) - = return (mkInstallPlan platform comp []) + = return (mkInstallPlan platform comp (depResolverIndependentGoals params) []) resolveDependencies platform comp solver params = Step (debugDepResolverParams finalparams) - $ fmap (mkInstallPlan platform comp) + $ fmap (mkInstallPlan platform comp indGoals) $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing strFlags maxBkjumps) platform comp installedPkgIndex sourcePkgIndex @@ -553,10 +553,11 @@ resolveDependencies platform comp solver params = -- mkInstallPlan :: Platform -> CompilerInfo + -> Bool -> [InstallPlan.PlanPackage] -> InstallPlan -mkInstallPlan platform comp pkgIndex = +mkInstallPlan platform comp indepGoals pkgIndex = let index = InstalledPackageIndex.fromList pkgIndex in - case InstallPlan.new platform comp index of + case InstallPlan.new platform comp indepGoals index of Right plan -> plan Left problems -> error $ unlines $ "internal error: could not construct a valid install plan." diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs index 38fbf71858f..1a9bb2cd342 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs @@ -1,4 +1,4 @@ -module Distribution.Client.Dependency.Modular.Builder where +module Distribution.Client.Dependency.Modular.Builder (buildTree) where -- Building the search tree. -- @@ -30,7 +30,6 @@ import Distribution.Client.Dependency.Modular.Tree -- | The state needed during the build phase of the search tree. data BuildState = BS { index :: Index, -- ^ information about packages and their dependencies - scope :: Scope, -- ^ information about encapsulations rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies open :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals) next :: BuildType -- ^ kind of node to generate next @@ -57,23 +56,14 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs | otherwise = go (M.insert qpn [qpn'] g) (cons ng () o) ngs -- code above is correct; insert/adjust have different arg order --- | Update the current scope by taking into account the encapsulations that --- are defined for the current package. -establishScope :: QPN -> Encaps -> BuildState -> BuildState -establishScope (Q pp pn) ecs s = - s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs } - where - pp' = pn : pp -- new path - -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo -> BuildState -> BuildState -scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s +scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s where - sc = scope s -- Qualify all package names - qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names + qfdeps = L.map (fmap (Q pp)) fdeps -- qualify all the package names -- Introduce all package flags qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals @@ -101,10 +91,10 @@ data BuildType = | Instance QPN I PInfo QGoalReasonChain -- ^ build a tree for a concrete instance deriving Show -build :: BuildState -> Tree (QGoalReasonChain, Scope) +build :: BuildState -> Tree QGoalReasonChain build = ana go where - go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState + go :: BuildState -> TreeF QGoalReasonChain BuildState -- If we have a choice between many goals, we just record the choice in -- the tree. We select each open goal in turn, and before we descend, remove @@ -119,11 +109,11 @@ build = ana go -- -- For a package, we look up the instances available in the global info, -- and then handle each instance in turn. - go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) = + go bs@(BS { index = idx, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) = case M.lookup pn idx of Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn) - Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) -> - (i, bs { next = Instance qpn i info gr })) + Just pis -> PChoiceF qpn gr (P.fromList (L.map (\ (i, info) -> + (POption i Nothing, bs { next = Instance qpn i info gr })) (M.toList pis))) -- TODO: data structure conversion is rather ugly here @@ -131,8 +121,8 @@ build = ana go -- that is indicated by the flag default. -- -- TODO: Should we include the flag default in the tree? - go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) = - FChoiceF qfn (gr, sc) (w || trivial) m (P.fromList (reorder b + go bs@(BS { next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) = + FChoiceF qfn gr (w || trivial) m (P.fromList (reorder b [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }), (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])) where @@ -140,8 +130,8 @@ build = ana go reorder False = reverse trivial = L.null t && L.null f - go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = - SChoiceF qsn (gr, sc) trivial (P.fromList + go bs@(BS { next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = + SChoiceF qsn gr trivial (P.fromList [(False, bs { next = Goals }), (True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })]) where @@ -151,20 +141,17 @@ build = ana go -- and furthermore we update the set of goals. -- -- TODO: We could inline this above. - go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) = - go ((establishScope qpn ecs - (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)) + go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs _) gr }) = + go ((scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs) { next = Goals }) -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there. -buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasonChain, Scope) +buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain buildTree idx ind igs = - build (BS idx sc - (M.fromList (L.map (\ qpn -> (qpn, [])) qpns)) + build (BS idx (M.fromList (L.map (\ qpn -> (qpn, [])) qpns)) (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns)) Goals) where - sc | ind = makeIndependent igs - | otherwise = emptyScope - qpns = L.map (qualify sc) igs + qpns | ind = makeIndependent igs + | otherwise = L.map (Q None) igs diff --git a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs index 97d22a52d99..405c69bcdce 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs @@ -13,11 +13,11 @@ import Distribution.System import Distribution.Client.Dependency.Modular.Configured import Distribution.Client.Dependency.Modular.Package -mkPlan :: Platform -> CompilerInfo -> +mkPlan :: Platform -> CompilerInfo -> Bool -> SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> [CP QPN] -> Either [PlanProblem] InstallPlan -mkPlan plat comp iidx sidx cps = - new plat comp (SI.fromList (map (convCP iidx sidx) cps)) +mkPlan plat comp indepGoals iidx sidx cps = + new plat comp indepGoals (SI.fromList (map (convCP iidx sidx) cps)) convCP :: SI.InstalledPackageIndex -> CI.PackageIndex SourcePackage -> CP QPN -> PlanPackage diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs b/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs index 2cf0d575f8f..82dbec8eebe 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs @@ -80,7 +80,7 @@ explore = cata go go (PChoiceF qpn _ ts) (A pa fa sa) = asum $ -- try children in order, P.mapWithKey -- when descending ... - (\ k r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice + (\ (POption k _) r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice ts go (FChoiceF qfn _ _ _ ts) (A pa fa sa) = asum $ -- try children in order, @@ -107,7 +107,7 @@ exploreLog = cata go backjumpInfo c $ asum $ -- try children in order, P.mapWithKey -- when descending ... - (\ k r -> tryWith (TryP (PI qpn k)) $ -- log and ... + (\ i@(POption k _) r -> tryWith (TryP qpn i) $ -- log and ... r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice ts go (FChoiceF qfn c _ _ ts) (A pa fa sa) = diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs index d01cdb61fa1..ac3450379a7 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs @@ -15,17 +15,14 @@ import Distribution.Client.Dependency.Modular.Tree type Index = Map PN (Map I PInfo) -- | Info associated with a package instance. --- Currently, dependencies, flags, encapsulations and failure reasons. +-- Currently, dependencies, flags and failure reasons. -- Packages that have a failure reason recorded for them are disabled -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) FlagInfo Encaps (Maybe FailReason) +data PInfo = PInfo (FlaggedDeps PN) FlagInfo (Maybe FailReason) deriving (Show) --- | Encapsulations. A list of package names. -type Encaps = [PN] - mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs index cd31868fdfe..53b5a46a4db 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -49,8 +49,8 @@ convIPI' sip idx = where -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed)) - shadow x = x + shadow (pn, i, PInfo fdeps fds _) | sip = (pn, i, PInfo fdeps fds (Just Shadowed)) + shadow x = x convIPI :: Bool -> SI.InstalledPackageIndex -> Index convIPI sip = mkIndex . convIPI' sip @@ -62,8 +62,8 @@ convIP idx ipi = i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) pn = pkgName (sourcePackageId ipi) in case mapM (convIPId pn idx) (IPI.depends ipi) of - Nothing -> (pn, i, PInfo [] M.empty [] (Just Broken)) - Just fds -> (pn, i, PInfo fds M.empty [] Nothing) + Nothing -> (pn, i, PInfo [] M.empty (Just Broken)) + Just fds -> (pn, i, PInfo fds M.empty Nothing) -- TODO: Installed packages should also store their encapsulations! -- | Convert dependencies specified by an installed package id into @@ -119,7 +119,6 @@ convGPD os arch comp strfl pi prefix (Stanza (SN pi BenchStanzas)) (L.map (convCondTree os arch comp pi fds (const True) . snd) benchs)) fds - [] -- TODO: add encaps Nothing prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs new file mode 100644 index 00000000000..b9b5aea078c --- /dev/null +++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs @@ -0,0 +1,461 @@ +{-# 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(..)) + +{------------------------------------------------------------------------------- + Add linking +-------------------------------------------------------------------------------} + +type RelatedGoals = Map (PN, I) [PP] +type Linker = Reader RelatedGoals + +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) + + -- For all other nodes we just recurse + go (FChoiceF qfn gr t m cs) = FChoice qfn gr t m <$> T.sequence cs + go (SChoiceF qsn gr t cs) = SChoice qsn gr t <$> T.sequence cs + go (GoalChoiceF cs) = GoalChoice <$> T.sequence cs + go (DoneF revDepMap) = return $ Done revDepMap + go (FailF conflictSet failReason) = return $ Fail conflictSet failReason + + -- 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 +-------------------------------------------------------------------------------} + +data ValidateState = VS { + vsIndex :: Index + , vsLinks :: Map QPN LinkGroup + , vsFlags :: FAssignment + , vsStanzas :: SAssignment + } + deriving Show + +type Validate = Reader ValidateState + +-- | Validate linked packages +-- +-- Verify that linked packages have +-- +-- * Linked dependencies, +-- * Equal flag assignments +-- * And something to do with stanzas (TODO) +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 = map (fmap (Q pp)) 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 + } + +{------------------------------------------------------------------------------- + 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 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 i)) { lgCanon = Just pp } + updateLinkGroup lg + + -- Package is already in a link group. Since we are picking a concrete + -- instance here, it must by definition by the canonical package. + Just lg -> + makeCanonical lg qpn + +pickLink :: QPN -> I -> PP -> FlaggedDeps QPN -> UpdateState () +pickLink qpn@(Q _ 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. + let lg = vsLinks vs ! Q pp' pn + lg' <- lift' $ lgAddMember qpn i lg + updateLinkGroup lg' + linkDeps [P qpn] pp' deps + +makeCanonical :: LinkGroup -> QPN -> UpdateState () +makeCanonical lg qpn@(Q pp _) = + 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 pp } + updateLinkGroup lg' + +linkDeps :: [Var QPN] -> PP -> FlaggedDeps QPN -> UpdateState () +linkDeps parents pp' = mapM_ go + where + go :: FlaggedDep 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'' + 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 + +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 = map (fmap (Q pp)) 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 QPN -> ([Var QPN], FlaggedDeps QPN) + findNewDeps vs = concatMapUnzip (findNewDeps' vs) + + findNewDeps' :: ValidateState -> FlaggedDep QPN -> ([Var QPN], FlaggedDeps 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) + +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" + ) + +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 +data LinkGroup = LinkGroup { + -- | The name of the package of this link group + lgPackage :: PN + + -- | The version of the package of this link group + -- + -- We may not know this version yet (if we are constructing link groups + -- for dependencies) + , lgInstance :: Maybe I + + -- | 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. + , lgCanon :: Maybe 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 + +showLinkGroup :: LinkGroup -> String +showLinkGroup lg = + "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" + where + showMember :: PP -> String + showMember pp = (if lgCanon lg == Just pp then "*" else "") + ++ case lgInstance lg of + Nothing -> showQPN (qpn pp) + Just i -> showPI (PI (qpn pp) i) + + qpn :: PP -> QPN + qpn pp = Q pp (lgPackage lg) + +lgSingleton :: QPN -> Maybe I -> LinkGroup +lgSingleton (Q pp pn) inst = LinkGroup { + lgPackage = pn + , lgInstance = inst + , lgCanon = Nothing + , lgMembers = S.singleton pp + , lgBlame = [] + } + +lgMerge :: [Var QPN] -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup +lgMerge blame lg lg' = do + canon <- pick (lgCanon lg) (lgCanon lg') + inst <- pick (lgInstance lg) (lgInstance lg') + return LinkGroup { + lgPackage = lgPackage lg + , lgInstance = inst + , 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)) + +lgAddMember :: QPN -> I -> LinkGroup -> Either Conflict LinkGroup +lgAddMember qpn@(Q pp pn) i lg = do + assert (pn == lgPackage lg) $ Right () + let lg' = lg { lgMembers = S.insert pp (lgMembers lg) } + case lgInstance lg of + Nothing -> Right $ lg' { lgInstance = Just i } + Just i' | i == i' -> Right lg' + | otherwise -> Left ( lgConflictSet lg' + , "cannot add " ++ showQPN qpn + ++ " to " ++ showLinkGroup lg + ) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Extract the package instance from a Var +varPI :: Var QPN -> (QPN, Maybe I) +varPI (P qpn) = (qpn, Nothing) +varPI (F (FN (PI qpn i) _)) = (qpn, Just i) +varPI (S (SN (PI qpn i) _)) = (qpn, Just i) + +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 diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs index 9042d4ea4de..cf5dcd7a3d4 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Message.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Message.hs @@ -13,7 +13,7 @@ import Distribution.Client.Dependency.Modular.Tree data Message = Enter -- ^ increase indentation level | Leave -- ^ decrease indentation level - | TryP (PI QPN) + | TryP QPN POption | TryF QFN Bool | TryS QSN Bool | Next (Goal QPN) @@ -38,15 +38,15 @@ showMessages p sl = go [] 0 go :: [Var QPN] -> Int -> [Message] -> [String] go _ _ [] = [] -- complex patterns - go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms + go v l (TryP qpn i : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (F qfn) v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (add (S qsn) v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) - go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (add (P qpn) v) l ms) + go v l (Next (Goal (P qpn) gr) : TryP qpn' i : ms@(Enter : Next _ : _)) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn' i ++ showGRs gr) (go (add (P qpn) v) l ms) go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms -- standard display go v l (Enter : ms) = go v (l+1) ms go v l (Leave : ms) = go (drop 1 v) (l-1) ms - go v l (TryP pi@(PI qpn _) : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showPI pi) (go (add (P qpn) v) l ms) + go v l (TryP qpn i : ms) = (atLevel (add (P qpn) v) l $ "trying: " ++ showQPNPOpt qpn i) (go (add (P qpn) v) l ms) go v l (TryF qfn b : ms) = (atLevel (add (F qfn) v) l $ "trying: " ++ showQFNBool qfn b) (go (add (F qfn) v) l ms) go v l (TryS qsn b : ms) = (atLevel (add (S qsn) v) l $ "trying: " ++ showQSNBool qsn b) (go (add (S qsn) v) l ms) go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (add (P qpn) v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms) @@ -58,9 +58,9 @@ showMessages p sl = go [] 0 add v vs = simplifyVar v : vs -- special handler for many subsequent package rejections - goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String] - goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms - goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms) + goPReject :: [Var QPN] -> Int -> QPN -> [POption] -> ConflictSet QPN -> FailReason -> [Message] -> [String] + goPReject v l qpn is c fr (TryP qpn' i : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms + goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go v l ms) -- write a message, but only if it's relevant; we can also enable or disable the display of the current level atLevel v l x xs @@ -69,6 +69,12 @@ showMessages p sl = go [] 0 | p v = x : xs | otherwise = xs +showQPNPOpt :: QPN -> POption -> String +showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) = + case linkedTo of + Nothing -> showPI (PI qpn i) -- Consistent with prior to POption + Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) + showGRs :: QGoalReasonChain -> String showGRs (gr : _) = showGR gr showGRs [] = "" @@ -93,6 +99,8 @@ showFR _ GlobalConstraintFlag = " (global constraint requires opposite showFR _ ManualFlag = " (manual flag can only be changed explicitly)" showFR _ (BuildFailureNotInIndex pn) = " (unknown package: " ++ display pn ++ ")" showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")" +showFR _ MultipleInstances = " (multiple instances)" +showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showCS c ++ ")" -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though. diff --git a/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs b/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs index 7197cd3f84d..db2e320cd37 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs @@ -57,7 +57,7 @@ casePSQ (PSQ xs) n c = (k, v) : ys -> c k v (PSQ ys) splits :: PSQ k a -> PSQ k (a, PSQ k a) -splits = go id +splits = go id where go f xs = casePSQ xs (PSQ []) @@ -92,3 +92,6 @@ null (PSQ xs) = S.null xs toList :: PSQ k a -> [(k, a)] toList (PSQ xs) = xs + +union :: PSQ k a -> PSQ k a -> PSQ k a +union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs index 5f81c6868cb..4cd9fe8bf0d 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs @@ -4,7 +4,6 @@ module Distribution.Client.Dependency.Modular.Package module Distribution.Package) where import Data.List as L -import Data.Map as M import Distribution.Package -- from Cabal import Distribution.Text -- from Cabal @@ -67,13 +66,17 @@ instI :: I -> Bool instI (I _ (Inst _)) = True instI _ = False --- | Package path. (Stored in "reverse" order.) -type PP = [PN] +-- | Package path. +data PP = Independent Int PP | Setup PN PP | None + deriving (Eq, Ord, Show) -- | String representation of a package path. +-- +-- NOTE: This always ends in a period showPP :: PP -> String -showPP = intercalate "." . L.map display . reverse - +showPP (Independent i pp) = show i ++ "." ++ showPP pp +showPP (Setup pn pp) = display pn ++ ".setup." ++ showPP pp +showPP None = "" -- | A qualified entity. Pairs a package path with the entity. data Q a = Q PP a @@ -81,8 +84,8 @@ data Q a = Q PP a -- | Standard string representation of a qualified entity. showQ :: (a -> String) -> (Q a -> String) -showQ showa (Q [] x) = showa x -showQ showa (Q pp x) = showPP pp ++ "." ++ showa x +showQ showa (Q None x) = showa x +showQ showa (Q pp x) = showPP pp ++ showa x -- | Qualified package name. type QPN = Q PN @@ -91,21 +94,13 @@ type QPN = Q PN showQPN :: QPN -> String showQPN = showQ display --- | The scope associates every package with a path. The convention is that packages --- not in the data structure have an empty path associated with them. -type Scope = Map PN PP - --- | An empty scope structure, for initialization. -emptyScope :: Scope -emptyScope = M.empty - -- | Create artificial parents for each of the package names, making -- them all independent. -makeIndependent :: [PN] -> Scope -makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps) +makeIndependent :: [PN] -> [QPN] +makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..] + , let pp = Independent i None + ] -qualify :: Scope -> PN -> QPN -qualify sc pn = Q (findWithDefault [] pn sc) pn unQualify :: Q a -> a unQualify (Q _ x) = x diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs index 005eeb1eccb..8e8b98dba65 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs @@ -7,8 +7,14 @@ import qualified Data.List as L import qualified Data.Map as M #if !MIN_VERSION_base(4,8,0) import Data.Monoid +import Control.Applicative #endif +import qualified Data.Set as S +import Prelude hiding (sequence) +import Control.Monad.Reader hiding (sequence) import Data.Ord +import Data.Map (Map) +import Data.Traversable (sequence) import Distribution.Client.Dependency.Types ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) ) @@ -25,13 +31,31 @@ import Distribution.Client.Dependency.Modular.Version -- | Generic abstraction for strategies that just rearrange the package order. -- Only packages that match the given predicate are reordered. packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a -packageOrderFor p cmp = trav go +packageOrderFor p cmp' = trav go where go (PChoiceF v@(Q _ pn) r cs) | p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs) | otherwise = PChoiceF v r cs go x = x + cmp :: PN -> POption -> POption -> Ordering + cmp pn (POption i _) (POption i' _) = cmp' pn i i' + +-- | Prefer to link packages whenever possible +preferLinked :: Tree a -> Tree a +preferLinked = trav go + where + go (PChoiceF qn a cs) = PChoiceF qn a (P.sortByKeys cmp cs) + go x = x + + cmp (POption _ linkedTo) (POption _ linkedTo') = cmpL linkedTo linkedTo' + + cmpL Nothing Nothing = EQ + cmpL Nothing (Just _) = GT + cmpL (Just _) Nothing = LT + cmpL (Just _) (Just _) = EQ + + -- | Ordering that treats preferred versions as greater than non-preferred -- versions. preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering @@ -114,7 +138,7 @@ enforcePackageConstraints pcs = trav go go (PChoiceF qpn@(Q _ pn) gr ts) = let c = toConflictSet (Goal (P qpn) gr) -- compose the transformation functions for each of the relevant constraint - g = \ i -> foldl (\ h pc -> h . processPackageConstraintP c i pc) id + g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP c i pc) id (M.findWithDefault [] pn pcs) in PChoiceF qpn gr (P.mapWithKey g ts) go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr m ts) = @@ -166,15 +190,15 @@ preferLatest :: Tree a -> Tree a preferLatest = preferLatestFor (const True) -- | Require installed packages. -requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) +requireInstalled :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain requireInstalled p = trav go where - go (PChoiceF v@(Q _ pn) i@(gr, _) cs) - | p pn = PChoiceF v i (P.mapWithKey installed cs) - | otherwise = PChoiceF v i cs + go (PChoiceF v@(Q _ pn) gr cs) + | p pn = PChoiceF v gr (P.mapWithKey installed cs) + | otherwise = PChoiceF v gr cs where - installed (I _ (Inst _)) x = x - installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall + installed (POption (I _ (Inst _)) _) x = x + installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall go x = x -- | Avoid reinstalls. @@ -190,20 +214,21 @@ requireInstalled p = trav go -- they are, perhaps this should just result in trying to reinstall those other -- packages as well. However, doing this all neatly in one pass would require to -- change the builder, or at least to change the goal set after building. -avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) +avoidReinstalls :: (PN -> Bool) -> Tree QGoalReasonChain -> Tree QGoalReasonChain avoidReinstalls p = trav go where - go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs) - | p pn = PChoiceF qpn i disableReinstalls - | otherwise = PChoiceF qpn i cs + go (PChoiceF qpn@(Q _ pn) gr cs) + | p pn = PChoiceF qpn gr disableReinstalls + | otherwise = PChoiceF qpn gr cs where disableReinstalls = - let installed = [ v | (I v (Inst _), _) <- toList cs ] + let installed = [ v | (POption (I v (Inst _)) _, _) <- toList cs ] in P.mapWithKey (notReinstall installed) cs - notReinstall vs (I v InRepo) _ - | v `elem` vs = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall - notReinstall _ _ x = x + notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = + Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall + notReinstall _ _ x = + x go x = x -- | Always choose the first goal in the list next, abandoning all @@ -230,9 +255,9 @@ preferBaseGoalChoice = trav go go x = x preferBase :: OpenGoal -> OpenGoal -> Ordering - preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT - preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT - preferBase _ _ = EQ + preferBase (OpenGoal (Simple (Dep (Q _pp pn) _)) _) _ | unPN pn == "base" = LT + preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _)) _) | unPN pn == "base" = GT + preferBase _ _ = EQ -- | Transformation that sorts choice nodes so that -- child nodes with a small branching degree are preferred. As a @@ -279,3 +304,43 @@ preferEasyGoalChoices' = para (inn . go) go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs)) go x = fmap fst x +-- | Monad used internally in enforceSingleInstanceRestriction +type EnforceSIR = Reader (Map (PI PN) QPN) + +-- | Enforce ghc's single instance restriction +-- +-- From the solver's perspective, this means that for any package instance +-- (that is, package name + package version) there can be at most one qualified +-- goal resolving to that instance (there may be other goals _linking_ to that +-- instance however). +enforceSingleInstanceRestriction :: Tree QGoalReasonChain -> Tree QGoalReasonChain +enforceSingleInstanceRestriction = (`runReader` M.empty) . cata go + where + go :: TreeF QGoalReasonChain (EnforceSIR (Tree QGoalReasonChain)) -> EnforceSIR (Tree QGoalReasonChain) + + -- We just verify package choices + go (PChoiceF qpn gr cs) = + PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn) cs) + + -- For all other nodes we don't check anything + go (FChoiceF qfn gr t m cs) = FChoice qfn gr t m <$> sequence cs + go (SChoiceF qsn gr t cs) = SChoice qsn gr t <$> sequence cs + go (GoalChoiceF cs) = GoalChoice <$> sequence cs + go (DoneF revDepMap) = return $ Done revDepMap + go (FailF conflictSet failReason) = return $ Fail conflictSet failReason + + -- The check proper + goP :: QPN -> POption -> EnforceSIR (Tree QGoalReasonChain) -> EnforceSIR (Tree QGoalReasonChain) + goP qpn@(Q _ pn) (POption i linkedTo) r = do + let inst = PI pn i + env <- ask + case (linkedTo, M.lookup inst env) of + (Just _, _) -> + -- For linked nodes we don't check anything + r + (Nothing, Nothing) -> + -- Not linked, not already used + local (M.insert inst qpn) r + (Nothing, Just qpn') -> do + -- Not linked, already used. This is an error + return $ Fail (S.fromList [P qpn, P qpn']) MultipleInstances diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs index 13ec67bc03b..dd93f289449 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs @@ -14,6 +14,7 @@ import Distribution.Client.Dependency.Modular.Message import Distribution.Client.Dependency.Modular.Package import qualified Distribution.Client.Dependency.Modular.Preference as P import Distribution.Client.Dependency.Modular.Validate +import Distribution.Client.Dependency.Modular.Linking -- | Various options for the modular solver. data SolverConfig = SolverConfig { @@ -43,12 +44,15 @@ solve sc idx userPrefs userConstraints userGoals = heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space) P.deferWeakFlagChoices . P.preferBaseGoalChoice . + P.preferLinked . if preferEasyGoalChoices sc then P.lpreferEasyGoalChoices else id preferencesPhase = P.preferPackagePreferences userPrefs validationPhase = P.enforceManualFlags . -- can only be done after user constraints P.enforcePackageConstraints userConstraints . + P.enforceSingleInstanceRestriction . + validateLinking idx . validateTree idx prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) . -- packages that can never be "upgraded": @@ -57,4 +61,4 @@ solve sc idx userPrefs userConstraints userGoals = , PackageName "integer-gmp" , PackageName "integer-simple" ]) - buildPhase = buildTree idx (independentGoals sc) userGoals + buildPhase = addLinking $ buildTree idx (independentGoals sc) userGoals diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs index d7ccc17aaec..cdcd5760e79 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs @@ -14,7 +14,7 @@ import Distribution.Client.Dependency.Modular.Version -- | Type of the search tree. Inlining the choice nodes for now. data Tree a = - PChoice QPN a (PSQ I (Tree a)) + PChoice QPN a (PSQ POption (Tree a)) | FChoice QFN a Bool Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty @@ -30,6 +30,11 @@ data Tree a = -- the system, as opposed to flags that are used to explicitly enable or -- disable some functionality. +-- | A package option is an instance, together with an optional annotation that +-- this package is linked to the same package with another prefix +data POption = POption I (Maybe PP) + deriving (Eq, Show) + data FailReason = InconsistentInitialConstraints | Conflicting [Dep QPN] | CannotInstall @@ -46,11 +51,13 @@ data FailReason = InconsistentInitialConstraints | MalformedStanzaChoice QSN | EmptyGoalChoice | Backjump + | MultipleInstances + | DependenciesNotLinked String deriving (Eq, Show) -- | Functor for the tree type. data TreeF a b = - PChoiceF QPN a (PSQ I b) + PChoiceF QPN a (PSQ POption b) | FChoiceF QFN a Bool Bool (PSQ Bool b) | SChoiceF QSN a Bool (PSQ Bool b) | GoalChoiceF (PSQ OpenGoal b) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs index 16c8cf55370..c28700e142b 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs @@ -1,4 +1,4 @@ -module Distribution.Client.Dependency.Modular.Validate where +module Distribution.Client.Dependency.Modular.Validate (validateTree) where -- Validation of the tree. -- @@ -80,13 +80,13 @@ data ValidateState = VS { type Validate = Reader ValidateState -validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain) +validate :: Tree QGoalReasonChain -> Validate (Tree QGoalReasonChain) validate = cata go where - go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain) + go :: TreeF QGoalReasonChain (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain) - go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts) - go (FChoiceF qfn (gr, _sc) b m ts) = + go (PChoiceF qpn gr ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr) ts) + go (FChoiceF qfn gr b m ts) = do -- Flag choices may occur repeatedly (because they can introduce new constraints -- in various places). However, subsequent choices must be consistent. We thereby @@ -99,7 +99,7 @@ validate = cata go Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn) Nothing -> -- flag choice is new, follow both branches FChoice qfn gr b m <$> sequence (P.mapWithKey (goF qfn gr) ts) - go (SChoiceF qsn (gr, _sc) b ts) = + go (SChoiceF qsn gr b ts) = do -- Optional stanza choices are very similar to flag choices. PA _ _ psa <- asks pa -- obtain current stanza-preassignment @@ -117,13 +117,13 @@ validate = cata go go (FailF c fr ) = pure (Fail c fr) -- What to do for package nodes ... - goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain) - goP qpn@(Q _pp pn) gr sc i r = do + goP :: QPN -> QGoalReasonChain -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain) + goP qpn@(Q pp pn) gr (POption i _) r = do PA ppa pfa psa <- asks pa -- obtain current preassignment idx <- asks index -- obtain the index svd <- asks saved -- obtain saved dependencies - let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice - let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope + let (PInfo deps _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice + let qdeps = L.map (fmap (Q pp)) deps -- qualify the deps in the current scope -- the new active constraints are given by the instance we have chosen, -- plus the dependency information we have for that instance let goal = Goal (P qpn) gr @@ -228,5 +228,5 @@ extractNewDeps v gr b fa sa = go Just False -> [] -- | Interface. -validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain +validateTree :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty)) diff --git a/cabal-install/Distribution/Client/InstallPlan.hs b/cabal-install/Distribution/Client/InstallPlan.hs index 741d3124702..431f8263507 100644 --- a/cabal-install/Distribution/Client/InstallPlan.hs +++ b/cabal-install/Distribution/Client/InstallPlan.hs @@ -188,19 +188,24 @@ instance HasInstalledPackageId PlanPackage where installedPackageId (Failed pkg _) = installedPackageId pkg data InstallPlan = InstallPlan { - planIndex :: PlanIndex, - planFakeMap :: FakeMap, - planGraph :: Graph, - planGraphRev :: Graph, - planPkgOf :: Graph.Vertex -> PlanPackage, - planVertexOf :: InstalledPackageId -> Graph.Vertex, - planPlatform :: Platform, - planCompiler :: CompilerInfo + planIndex :: PlanIndex, + planFakeMap :: FakeMap, + planGraph :: Graph, + planGraphRev :: Graph, + planPkgOf :: Graph.Vertex -> PlanPackage, + planVertexOf :: InstalledPackageId -> Graph.Vertex, + planPlatform :: Platform, + planCompiler :: CompilerInfo, + planIndepGoals :: Bool } invariant :: InstallPlan -> Bool invariant plan = - valid (planPlatform plan) (planCompiler plan) (planFakeMap plan) (planIndex plan) + valid (planPlatform plan) + (planCompiler plan) + (planFakeMap plan) + (planIndepGoals plan) + (planIndex plan) internalError :: String -> a internalError msg = error $ "InstallPlan: internal error: " ++ msg @@ -228,9 +233,9 @@ showPlanPackageTag (Failed _ _) = "Failed" -- | Build an installation plan from a valid set of resolved packages. -- -new :: Platform -> CompilerInfo -> PlanIndex +new :: Platform -> CompilerInfo -> Bool -> PlanIndex -> Either [PlanProblem] InstallPlan -new platform cinfo index = +new platform cinfo indepGoals index = -- NB: Need to pre-initialize the fake-map with pre-existing -- packages let isPreExisting (PreExisting _) = True @@ -239,16 +244,17 @@ new platform cinfo index = . map (\p -> (fakeInstalledPackageId (packageId p), installedPackageId p)) . filter isPreExisting $ PackageIndex.allPackages index in - case problems platform cinfo fakeMap index of + case problems platform cinfo fakeMap indepGoals index of [] -> Right InstallPlan { - planIndex = index, - planFakeMap = fakeMap, - planGraph = graph, - planGraphRev = Graph.transposeG graph, - planPkgOf = vertexToPkgId, - planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, - planPlatform = platform, - planCompiler = cinfo + planIndex = index, + planFakeMap = fakeMap, + planGraph = graph, + planGraphRev = Graph.transposeG graph, + planPkgOf = vertexToPkgId, + planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, + planPlatform = platform, + planCompiler = cinfo, + planIndepGoals = indepGoals } where (graph, vertexToPkgId, pkgIdToVertex) = PlanIndex.dependencyGraph fakeMap index @@ -268,7 +274,7 @@ remove :: (PlanPackage -> Bool) -> InstallPlan -> Either [PlanProblem] InstallPlan remove shouldRemove plan = - new (planPlatform plan) (planCompiler plan) newIndex + new (planPlatform plan) (planCompiler plan) (planIndepGoals plan) newIndex where newIndex = PackageIndex.fromList $ filter (not . shouldRemove) (toList plan) @@ -414,8 +420,9 @@ checkConfiguredPackage pkg = -- -- * if the result is @False@ use 'problems' to get a detailed list. -- -valid :: Platform -> CompilerInfo -> FakeMap -> PlanIndex -> Bool -valid platform cinfo fakeMap index = null (problems platform cinfo fakeMap index) +valid :: Platform -> CompilerInfo -> FakeMap -> Bool -> PlanIndex -> Bool +valid platform cinfo fakeMap indepGoals index = + null $ problems platform cinfo fakeMap indepGoals index data PlanProblem = PackageInvalid ConfiguredPackage [PackageProblem] @@ -465,9 +472,9 @@ showPlanProblem (PackageStateInvalid pkg pkg') = -- error messages. This is mainly intended for debugging purposes. -- Use 'showPlanProblem' for a human readable explanation. -- -problems :: Platform -> CompilerInfo -> FakeMap +problems :: Platform -> CompilerInfo -> FakeMap -> Bool -> PlanIndex -> [PlanProblem] -problems platform cinfo fakeMap index = +problems platform cinfo fakeMap indepGoals index = [ PackageInvalid pkg packageProblems | Configured pkg <- PackageIndex.allPackages index , let packageProblems = configuredPackageProblems platform cinfo pkg @@ -480,7 +487,7 @@ problems platform cinfo fakeMap index = | cycleGroup <- PlanIndex.dependencyCycles fakeMap index ] ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- PlanIndex.dependencyInconsistencies fakeMap index ] + | (name, inconsistencies) <- PlanIndex.dependencyInconsistencies fakeMap indepGoals index ] ++ [ PackageStateInvalid pkg pkg' | pkg <- PackageIndex.allPackages index @@ -522,7 +529,7 @@ closed fakeMap = null . PlanIndex.brokenPackages fakeMap -- find out which packages are. -- consistent :: FakeMap -> PlanIndex -> Bool -consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap +consistent fakeMap = null . PlanIndex.dependencyInconsistencies fakeMap False -- | The states of packages have that depend on each other must respect -- this relation. That is for very case where package @a@ depends on diff --git a/cabal-install/Distribution/Client/PlanIndex.hs b/cabal-install/Distribution/Client/PlanIndex.hs index b4f96e30507..ae489600c4e 100644 --- a/cabal-install/Distribution/Client/PlanIndex.hs +++ b/cabal-install/Distribution/Client/PlanIndex.hs @@ -24,11 +24,10 @@ import Prelude hiding (lookup) import qualified Data.Map as Map import qualified Data.Tree as Tree import qualified Data.Graph as Graph -import qualified Data.Array as Array import Data.Array ((!)) -import Data.List (sortBy) import Data.Map (Map) -import Data.Maybe (isNothing, fromMaybe) +import Data.Maybe (isNothing, fromMaybe, fromJust) +import Data.Either (lefts) #if !MIN_VERSION_base(4,8,0) import Data.Monoid (Monoid(..)) @@ -40,8 +39,6 @@ import Distribution.Package ) import Distribution.Version ( Version ) -import Distribution.Simple.Utils - ( comparing ) import Distribution.Client.PackageIndex ( PackageFixedDeps(..) ) @@ -116,6 +113,47 @@ brokenPackages fakeMap index = , isNothing (fakeLookupInstalledPackageId fakeMap index pkg') ] , not (null missing) ] + +dependencyInconsistencies :: forall pkg. (PackageFixedDeps pkg, HasInstalledPackageId pkg) + => FakeMap + -> Bool + -> PackageIndex pkg + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies fakeMap indepGoals index = + concatMap (dependencyInconsistencies' fakeMap) subplans + where + subplans :: [PackageIndex pkg] + subplans = lefts $ + map (dependencyClosure fakeMap index) + (rootSets fakeMap indepGoals index) + +-- | Compute the root sets of a plan +-- +-- A root set is a set of packages whose dependency closure must be consistent. +-- This is the set of all top-level library roots (taken together normally, or +-- as singletons sets if we are considering them as independent goals), along +-- with all setup dependencies of all packages. +rootSets :: (PackageFixedDeps pkg, HasInstalledPackageId pkg) + => FakeMap -> Bool -> PackageIndex pkg -> [[InstalledPackageId]] +rootSets fakeMap indepGoals index = + if indepGoals then map (:[]) libRoots else [libRoots] + where + libRoots = libraryRoots fakeMap index + +-- | Compute the library roots of a plan +-- +-- The library roots are the set of packages with no reverse dependencies +-- (no reverse library dependencies but also no reverse setup dependencies). +libraryRoots :: (PackageFixedDeps pkg, HasInstalledPackageId pkg) + => FakeMap -> PackageIndex pkg -> [InstalledPackageId] +libraryRoots fakeMap index = + map (installedPackageId . toPkgId) roots + where + (graph, toPkgId, _) = dependencyGraph fakeMap index + indegree = Graph.indegree graph + roots = filter isRoot (Graph.vertices graph) + isRoot v = indegree ! v == 0 + -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out -- if the dependencies within it use consistent versions of each package. @@ -126,12 +164,12 @@ brokenPackages fakeMap index = -- depend on it and the versions they require. These are guaranteed to be -- distinct. -- -dependencyInconsistencies :: forall pkg. - (PackageFixedDeps pkg, HasInstalledPackageId pkg) - => FakeMap - -> PackageIndex pkg - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies fakeMap index = +dependencyInconsistencies' :: forall pkg. + (PackageFixedDeps pkg, HasInstalledPackageId pkg) + => FakeMap + -> PackageIndex pkg + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies' fakeMap index = [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) | (name, ipid_map) <- Map.toList inverseIndex , let uses = Map.elems ipid_map @@ -196,7 +234,6 @@ dependencyCycles fakeMap index = -- -- * Note that if the result is @Right []@ it is because at least one of -- the original given 'PackageIdentifier's do not occur in the index. --- dependencyClosure :: (PackageFixedDeps pkg, HasInstalledPackageId pkg) => FakeMap -> PackageIndex pkg @@ -272,19 +309,16 @@ dependencyGraph :: (PackageFixedDeps pkg, HasInstalledPackageId pkg) InstalledPackageId -> Maybe Graph.Vertex) dependencyGraph fakeMap index = (graph, vertexToPkg, idToVertex) where - graph = Array.listArray bounds - [ [ v | Just v <- map idToVertex (depends pkg) ] - | pkg <- pkgs ] - - pkgs = sortBy (comparing packageId) (allPackages index) - pkgTable = Array.listArray bounds pkgs - bounds = (0, topBound) - topBound = length pkgs - 1 - vertexToPkg vertex = pkgTable ! vertex - - -- Old implementation used to use an array for vertices as well, with a - -- binary search algorithm. Not sure why this changed, but sticking with - -- this linear search for now. - vertices = zip (map installedPackageId pkgs) [0..] - vertexMap = Map.fromList vertices - idToVertex pid = Map.lookup (Map.findWithDefault pid pid fakeMap) vertexMap + (graph, vertexToPkg', idToVertex) = Graph.graphFromEdges edges + vertexToPkg = fromJust + . (\((), key, _targets) -> lookupInstalledPackageId index key) + . vertexToPkg' + + pkgs = allPackages index + edges = map edgesFrom pkgs + + resolve pid = Map.findWithDefault pid pid fakeMap + edgesFrom pkg = ( () + , resolve (installedPackageId pkg) + , fakeDepends fakeMap pkg + ) diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 321b025c913..954644b8a03 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -68,6 +68,7 @@ executable cabal Distribution.Client.Dependency.Modular.Flag Distribution.Client.Dependency.Modular.Index Distribution.Client.Dependency.Modular.IndexConversion + Distribution.Client.Dependency.Modular.Linking Distribution.Client.Dependency.Modular.Log Distribution.Client.Dependency.Modular.Message Distribution.Client.Dependency.Modular.Package @@ -180,6 +181,7 @@ Test-Suite unit-tests other-modules: UnitTests.Distribution.Client.Targets UnitTests.Distribution.Client.Dependency.Modular.PSQ + UnitTests.Distribution.Client.Dependency.Modular.Solver UnitTests.Distribution.Client.Sandbox UnitTests.Distribution.Client.UserConfig build-depends: @@ -201,6 +203,7 @@ Test-Suite unit-tests tasty, tasty-hunit, tasty-quickcheck, + tagged, QuickCheck >= 2.5 if flag(old-directory) diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs index f457d266d4f..28ee60fe553 100644 --- a/cabal-install/tests/UnitTests.hs +++ b/cabal-install/tests/UnitTests.hs @@ -2,11 +2,13 @@ module Main where import Test.Tasty +import Test.Tasty.Options import qualified UnitTests.Distribution.Client.Sandbox import qualified UnitTests.Distribution.Client.UserConfig import qualified UnitTests.Distribution.Client.Targets import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ +import qualified UnitTests.Distribution.Client.Dependency.Modular.Solver tests :: TestTree tests = testGroup "Unit Tests" [ @@ -18,7 +20,17 @@ tests = testGroup "Unit Tests" [ UnitTests.Distribution.Client.Targets.tests ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ" UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests + ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.Solver" + UnitTests.Distribution.Client.Dependency.Modular.Solver.tests + ] + +-- Extra options for running the test suite +extraOptions :: [OptionDescription] +extraOptions = concat [ + UnitTests.Distribution.Client.Dependency.Modular.Solver.options ] main :: IO () -main = defaultMain tests +main = defaultMainWithIngredients + (includingOptions extraOptions : defaultIngredients) + tests diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs new file mode 100644 index 00000000000..9619f897fd4 --- /dev/null +++ b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs @@ -0,0 +1,507 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +module UnitTests.Distribution.Client.Dependency.Modular.Solver (tests, options) where + +-- base +import Control.Monad +import Data.Maybe (catMaybes, isNothing) +import Data.Either (partitionEithers) +import Data.Proxy +import Data.Typeable +import Data.Version +import qualified Data.Map as Map + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +#endif + +-- test-framework +import Test.Tasty as TF +import Test.Tasty.HUnit (testCase, assertEqual, assertBool) +import Test.Tasty.Options + +-- Cabal +import qualified Distribution.Compiler as C +import qualified Distribution.InstalledPackageInfo as C +import qualified Distribution.Package as C hiding (HasInstalledPackageId(..)) +import qualified Distribution.PackageDescription as C +import qualified Distribution.Simple.PackageIndex as C.PackageIndex +import qualified Distribution.System as C +import qualified Distribution.Version as C + +-- cabal-install +import Distribution.Client.Dependency +import Distribution.Client.Dependency.Types +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as CI.InstallPlan +import qualified Distribution.Client.PackageIndex as CI.PackageIndex + +tests :: [TF.TestTree] +tests = [ + testGroup "Simple dependencies" [ + runTest $ mkTest db1 "alreadyInstalled" ["A"] (Just []) + , runTest $ mkTest db1 "installLatest" ["B"] (Just [("B", 2)]) + , runTest $ mkTest db1 "simpleDep1" ["C"] (Just [("B", 1), ("C", 1)]) + , runTest $ mkTest db1 "simpleDep2" ["D"] (Just [("B", 2), ("D", 1)]) + , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] Nothing + , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (Just [("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (Just [("B", 1), ("C", 1), ("E", 1)]) + , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (Just [("B", 2), ("D", 1), ("E", 1)]) + , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (Just [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) + , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (Just [("B", 1), ("E", 1), ("F", 1)]) + , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (Just [("B", 2), ("E", 1), ("G", 1)]) + , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] Nothing + ] + , testGroup "Flagged dependencies" [ + runTest $ mkTest db3 "forceFlagOn" ["C"] (Just [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ mkTest db3 "forceFlagOff" ["D"] (Just [("A", 2), ("B", 1), ("D", 1)]) + , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] Nothing + , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] Nothing + ] + , testGroup "Stanzas" [ + runTest $ mkTest db5 "simpleTest1" ["C"] (Just [("A", 2), ("C", 1)]) + , runTest $ mkTest db5 "simpleTest2" ["D"] Nothing + , runTest $ mkTest db5 "simpleTest3" ["E"] (Just [("A", 1), ("E", 1)]) + , runTest $ mkTest db5 "simpleTest4" ["F"] Nothing -- TODO + , runTest $ mkTest db5 "simpleTest5" ["G"] (Just [("A", 2), ("G", 1)]) + , runTest $ mkTest db5 "simpleTest6" ["E", "G"] Nothing + , runTest $ indep $ mkTest db5 "simpleTest7" ["E", "G"] (Just [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) + , runTest $ mkTest db6 "depsWithTests1" ["C"] (Just [("A", 1), ("B", 1), ("C", 1)]) + , runTest $ indep $ mkTest db6 "depsWithTests2" ["C", "D"] (Just [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) + ] + ] + where + indep test = test { testIndepGoals = True } + +{------------------------------------------------------------------------------- + Solver tests +-------------------------------------------------------------------------------} + +data SolverTest = SolverTest { + testLabel :: String + , testTargets :: [String] + , testResult :: Maybe [(String, Int)] + , testIndepGoals :: Bool + , testDb :: ExampleDb + } + +mkTest :: ExampleDb + -> String + -> [String] + -> Maybe [(String, Int)] + -> SolverTest +mkTest db label targets result = SolverTest { + testLabel = label + , testTargets = targets + , testResult = result + , testIndepGoals = False + , testDb = db + } + +runTest :: SolverTest -> TF.TestTree +runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> + testCase testLabel $ do + let (_msgs, result) = exResolve testDb testTargets testIndepGoals + when showSolverLog $ mapM_ putStrLn _msgs + case result of + Left err -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult) + Right plan -> assertEqual "" testResult (Just (extractInstallPlan plan)) + +{------------------------------------------------------------------------------- + Specific example database for the tests +-------------------------------------------------------------------------------} + +db1 :: ExampleDb +db1 = + let a = ExInst "A" 1 "A-1" [] + in [ Left a + , Right $ ExAv "B" 1 [ExAny "A"] + , Right $ ExAv "B" 2 [ExAny "A"] + , Right $ ExAv "C" 1 [ExFix "B" 1] + , Right $ ExAv "D" 1 [ExFix "B" 2] + , Right $ ExAv "E" 1 [ExAny "B"] + , Right $ ExAv "F" 1 [ExFix "B" 1, ExAny "E"] + , Right $ ExAv "G" 1 [ExFix "B" 2, ExAny "E"] + , Right $ ExAv "Z" 1 [] + ] + +-- In this example, we _can_ install C and D as independent goals, but we have +-- to pick two diferent versions for B (arbitrarily) +db2 :: ExampleDb +db2 = [ + Right $ ExAv "A" 1 [] + , Right $ ExAv "A" 2 [] + , Right $ ExAv "B" 1 [ExAny "A"] + , Right $ ExAv "B" 2 [ExAny "A"] + , Right $ ExAv "C" 1 [ExAny "B", ExFix "A" 1] + , Right $ ExAv "D" 1 [ExAny "B", ExFix "A" 2] + ] + +db3 :: ExampleDb +db3 = [ + Right $ ExAv "A" 1 [] + , Right $ ExAv "A" 2 [] + , Right $ ExAv "B" 1 [ExFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]] + , Right $ ExAv "C" 1 [ExFix "A" 1, ExAny "B"] + , Right $ ExAv "D" 1 [ExFix "A" 2, ExAny "B"] + ] + +-- | Like exampleDb2, but the flag picks a different package rather than a +-- different package version +-- +-- In exampleDb2 we cannot install C and D as independent goals because: +-- +-- * The multiple instance restriction says C and D _must_ share B +-- * Since C relies on A.1, C needs B to be compiled with flagB on +-- * Since D relies on A.2, D needs B to be compiled with flagsB off +-- * Hence C and D have incompatible requirements on B's flags. +-- +-- However, _even_ if we don't check explicitly that we pick the same flag +-- assignment for 0.B and 1.B, we will still detect the problem because +-- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to +-- 1.B and therefore we cannot link 0.B to 1.B. +-- +-- In exampleDb3 the situation however is trickier. We again cannot install +-- packages C and D as independent goals because: +-- +-- * As above, the multiple instance restriction says that C and D _must_ share B +-- * Since C relies on Ax-2, it requires B to be compiled with flagB off +-- * Since D relies on Ay-2, it requires B to be compiled with flagB on +-- * Hence C and D have incompatible requirements on B's flags. +-- +-- But now this requirement is more indirect. If we only check dependencies +-- we don't see the problem: +-- +-- * We link 0.B to 1.B +-- * 0.B relies on Ay.1 +-- * 1.B relies on Ax.1 +-- +-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.A, but since +-- we only ever assign to one of these, these constraints are never broken. +db4 :: ExampleDb +db4 = [ + Right $ ExAv "Ax" 1 [] + , Right $ ExAv "Ax" 2 [] + , Right $ ExAv "Ay" 1 [] + , Right $ ExAv "Ay" 2 [] + , Right $ ExAv "B" 1 [ExFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] + , Right $ ExAv "C" 1 [ExFix "Ax" 2, ExAny "B"] + , Right $ ExAv "D" 1 [ExFix "Ay" 2, ExAny "B"] + ] + +-- | Some tests involving testsuites +-- +-- Note that in this test framework test suites are always enabled; if you +-- want to test without test suites just set up a test database without +-- test suites. +-- +-- * C depends on A (through its test suite) +-- * D depends on B-2 (through its test suite), but B-2 is unavailable +-- * E depends on A-1 directly and on A through its test suite. We prefer +-- to use A-1 for the test suite in this case. +-- * F depends on A-1 directly and on A-2 through its test suite. In this +-- case we currently fail to install F, although strictly speaking +-- test suites should be considered independent goals. +-- * G is like E, but for version A-2. This means that if we cannot install +-- E and G together, unless we regard them as independent goals. +db5 :: ExampleDb +db5 = [ + Right $ ExAv "A" 1 [] + , Right $ ExAv "A" 2 [] + , Right $ ExAv "B" 1 [] + , Right $ ExAv "C" 1 [ExTest "testC" [ExAny "A"]] + , Right $ ExAv "D" 1 [ExTest "testD" [ExFix "B" 2]] + , Right $ ExAv "E" 1 [ExFix "A" 1, ExTest "testE" [ExAny "A"]] + , Right $ ExAv "F" 1 [ExFix "A" 1, ExTest "testF" [ExFix "A" 2]] + , Right $ ExAv "G" 1 [ExFix "A" 2, ExTest "testG" [ExAny "A"]] + ] + +-- Now the _dependencies_ have test suites +-- +-- * Installing C is a simple example. C wants version 1 of A, but depends on +-- B, and B's testsuite depends on an any version of A. In this case we prefer +-- to link (if we don't regard test suites as independent goals then of course +-- linking here doesn't even come into it). +-- * Installing [C, D] means that we prefer to link B -- depending on how we +-- set things up, this means that we should also link their test suites. +db6 :: ExampleDb +db6 = [ + Right $ ExAv "A" 1 [] + , Right $ ExAv "A" 2 [] + , Right $ ExAv "B" 1 [ExTest "testA" [ExAny "A"]] + , Right $ ExAv "C" 1 [ExFix "A" 1, ExAny "B"] + , Right $ ExAv "D" 1 [ExAny "B"] + ] + +{------------------------------------------------------------------------------- + Example package database DSL + + In order to be able to set simple examples up quickly, we define a very + simple version of the package database here explicitly designed for use in + tests. + + The design of `ExampleDb` takes the perspective of the solver, not the + perspective of the package DB. This makes it easier to set up tests for + various parts of the solver, but makes the mapping somewhat awkward, because + it means we first map from "solver perspective" `ExampleDb` to the package + database format, and then the modular solver internally in `IndexConversion` + maps this back to the solver specific data structures. + + IMPLEMENTATION NOTES + -------------------- + + TODO: Perhaps these should be made comments of the corresponding data type + definitions. For now these are just my own conclusions and may be wrong. + + * The difference between `GenericPackageDescription` and `PackageDescription` + is that `PackageDescription` describes a particular _configuration_ of a + package (for instance, see documentation for `checkPackage`). A + `GenericPackageDescription` can be returned into a `PackageDescription` in + two ways: + + a. `finalizePackageDescription` does the proper translation, by taking + into account the platform, available dependencies, etc. and picks a + flag assignment (or gives an error if no flag assignment can be found) + b. `flattenPackageDescription` ignores flag assignment and just joins all + components together. + + The slightly odd thing is that a `GenericPackageDescription` contains a + `PackageDescription` as a field; both of the above functions do the same + thing: they take the embedded `PackageDescription` as a basis for the result + value, but override `library`, `executables`, `testSuites`, `benchmarks` + and `buildDepends`. + * The `condTreeComponents` fields of a `CondTree` is a list of triples + `(condition, then-branch, else-branch)`, where the `else-branch` is + optional. +-------------------------------------------------------------------------------} + +type ExamplePkgName = String +type ExamplePkgVersion = Int +type ExamplePkgHash = String -- for example "installed" packages +type ExampleFlagName = String +type ExampleTestName = String + +data ExampleDependency = + -- | Simple dependency on any version + ExAny ExamplePkgName + + -- | Simple dependency on a fixed version + | ExFix ExamplePkgName ExamplePkgVersion + + -- | Dependencies indexed by a flag + | ExFlag ExampleFlagName [ExampleDependency] [ExampleDependency] + + -- | Dependency if tests are enabled + | ExTest ExampleTestName [ExampleDependency] + +data ExampleAvailable = ExAv { + exAvName :: ExamplePkgName + , exAvVersion :: ExamplePkgVersion + , exAvDeps :: [ExampleDependency] + } + +data ExampleInstalled = ExInst { + exInstName :: ExamplePkgName + , exInstVersion :: ExamplePkgVersion + , exInstHash :: ExamplePkgHash + , exInstBuildAgainst :: [ExampleInstalled] + } + +type ExampleDb = [Either ExampleInstalled ExampleAvailable] + +type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a + +exDbPkgs :: ExampleDb -> [ExamplePkgName] +exDbPkgs = map (either exInstName exAvName) + +exAvSrcPkg :: ExampleAvailable -> SourcePackage +exAvSrcPkg ex = + let (libraryDeps, testSuites) = splitTopLevel (exAvDeps ex) + in SourcePackage { + packageInfoId = exAvPkgId ex + , packageSource = LocalTarballPackage "<>" + , packageDescrOverride = Nothing + , packageDescription = C.GenericPackageDescription{ + C.packageDescription = C.emptyPackageDescription { + C.package = exAvPkgId ex + , C.library = error "not yet configured: library" + , C.executables = error "not yet configured: executables" + , C.testSuites = error "not yet configured: testSuites" + , C.benchmarks = error "not yet configured: benchmarks" + , C.buildDepends = error "not yet configured: buildDepends" + } + , C.genPackageFlags = concatMap extractFlags (exAvDeps ex) + , C.condLibrary = Just $ mkCondTree libraryDeps + , C.condExecutables = [] + , C.condTestSuites = map (\(t, deps) -> (t, mkCondTree deps)) testSuites + , C.condBenchmarks = [] + } + } + where + splitTopLevel :: [ExampleDependency] + -> ( [ExampleDependency] + , [(ExampleTestName, [ExampleDependency])] + ) + splitTopLevel [] = ([], []) + splitTopLevel (ExTest t a:deps) = let (other, testSuites) = splitTopLevel deps + in (other, (t, a):testSuites) + splitTopLevel (dep:deps) = let (other, testSuites) = splitTopLevel deps + in (dep:other, testSuites) + + extractFlags :: ExampleDependency -> [C.Flag] + extractFlags (ExAny _) = [] + extractFlags (ExFix _ _) = [] + extractFlags (ExFlag f a b) = C.MkFlag { + C.flagName = C.FlagName f + , C.flagDescription = "" + , C.flagDefault = False + , C.flagManual = False + } + : concatMap extractFlags (a ++ b) + extractFlags (ExTest _ a) = concatMap extractFlags a + + mkCondTree :: Monoid a => [ExampleDependency] -> DependencyTree a + mkCondTree deps = + let (directDeps, flaggedDeps) = splitDeps deps + in C.CondNode { + C.condTreeData = mempty -- irrelevant to the solver + , C.condTreeConstraints = map mkDirect directDeps + , C.condTreeComponents = map mkFlagged flaggedDeps + } + + mkDirect :: (ExamplePkgName, Maybe ExamplePkgVersion) -> C.Dependency + mkDirect (dep, Nothing) = C.Dependency (C.PackageName dep) C.anyVersion + mkDirect (dep, Just n) = C.Dependency (C.PackageName dep) (C.thisVersion v) + where + v = Version [n, 0, 0] [] + + mkFlagged :: Monoid a + => (ExampleFlagName, [ExampleDependency], [ExampleDependency]) + -> (C.Condition C.ConfVar, DependencyTree a, Maybe (DependencyTree a)) + mkFlagged (f, a, b) = ( C.Var (C.Flag (C.FlagName f)) + , mkCondTree a + , Just (mkCondTree b) + ) + + splitDeps :: [ExampleDependency] + -> ( [(ExamplePkgName, Maybe Int)] + , [(ExampleFlagName, [ExampleDependency], [ExampleDependency])] + ) + splitDeps [] = + ([], []) + splitDeps (ExAny p:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, Nothing):directDeps, flaggedDeps) + splitDeps (ExFix p v:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in ((p, Just v):directDeps, flaggedDeps) + splitDeps (ExFlag f a b:deps) = + let (directDeps, flaggedDeps) = splitDeps deps + in (directDeps, (f, a, b):flaggedDeps) + splitDeps (ExTest _ _:_) = + error "Unexpected nested test" + +exAvPkgId :: ExampleAvailable -> C.PackageIdentifier +exAvPkgId ex = C.PackageIdentifier { + pkgName = C.PackageName (exAvName ex) + , pkgVersion = Version [exAvVersion ex, 0, 0] [] + } + +exInstInfo :: ExampleInstalled -> C.InstalledPackageInfo +exInstInfo ex = C.emptyInstalledPackageInfo { + C.installedPackageId = C.InstalledPackageId (exInstHash ex) + , C.sourcePackageId = exInstPkgId ex + , C.packageKey = exInstKey ex + , C.depends = map (C.InstalledPackageId . exInstHash) + (exInstBuildAgainst ex) + } + +exInstPkgId :: ExampleInstalled -> C.PackageIdentifier +exInstPkgId ex = C.PackageIdentifier { + pkgName = C.PackageName (exInstName ex) + , pkgVersion = Version [exInstVersion ex, 0, 0] [] + } + +exInstKey :: ExampleInstalled -> C.PackageKey +exInstKey ex = + C.mkPackageKey True + (exInstPkgId ex) + (map exInstKey (exInstBuildAgainst ex)) + [] + +exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex SourcePackage +exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg + +exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex +exInstIdx = C.PackageIndex.fromList . map exInstInfo + +exResolve :: ExampleDb + -> [ExamplePkgName] + -> Bool + -> ([String], Either String CI.InstallPlan.InstallPlan) +exResolve db targets indepGoals = runProgress $ + resolveDependencies C.buildPlatform + (C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag) + Modular + params + where + (inst, avai) = partitionEithers db + instIdx = exInstIdx inst + avaiIdx = SourcePackageDb { + packageIndex = exAvIdx avai + , packagePreferences = Map.empty + } + enableTests = map (\p -> PackageConstraintStanzas (C.PackageName p) [TestStanzas]) + (exDbPkgs db) + targets' = map (\p -> NamedPackage (C.PackageName p) []) targets + params = addConstraints enableTests + $ (standardInstallPolicy instIdx avaiIdx targets') { + depResolverIndependentGoals = indepGoals + } + +extractInstallPlan :: CI.InstallPlan.InstallPlan + -> [(ExamplePkgName, ExamplePkgVersion)] +extractInstallPlan = catMaybes . map confPkg . CI.InstallPlan.toList + where + confPkg :: CI.InstallPlan.PlanPackage -> Maybe (String, Int) + confPkg (CI.InstallPlan.Configured pkg) = Just $ srcPkg pkg + confPkg _ = Nothing + + srcPkg :: ConfiguredPackage -> (String, Int) + srcPkg (ConfiguredPackage pkg _flags _stanzas _deps) = + let C.PackageIdentifier (C.PackageName p) (Version (n:_) _) = packageInfoId pkg + in (p, n) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Run Progress computation +-- +-- Like `runLog`, but for the more general `Progress` type. +runProgress :: Progress step e a -> ([step], Either e a) +runProgress = go + where + go (Step s p) = let (ss, result) = go p in (s:ss, result) + go (Fail e) = ([], Left e) + go (Done a) = ([], Right a) + +{------------------------------------------------------------------------------- + Test options +-------------------------------------------------------------------------------} + +options :: [OptionDescription] +options = [ + Option (Proxy :: Proxy OptionShowSolverLog) + ] + +newtype OptionShowSolverLog = OptionShowSolverLog Bool + deriving Typeable + +instance IsOption OptionShowSolverLog where + defaultValue = OptionShowSolverLog False + parseValue = fmap OptionShowSolverLog . safeRead + optionName = return "show-solver-log" + optionHelp = return "Show full log from the solver" + optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)