From a5a823d47b44802e535dbdf3d225da706b78f3bf Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Fri, 27 Mar 2015 14:33:02 +0000
Subject: [PATCH] Fine-grained dependencies in solver input
The modular solver has its own representation for a package (PInfo). In this
commit we modify PInfo to keep track of the different kinds of dependencies.
This is a bit intricate because the solver also regards top-level goals as
dependencies, but of course those dependencies are not part of any 'component'
as such, unlike "real" dependencies. We model this by adding a type parameter
to FlaggedDeps and go which indicates whether or not we have component
information; crucially, underneath flag choices we _always_ have component
information available.
Consequently, the modular solver itself will not make use of the ComponentDeps
datatype (but only using the Component type, classifying components); we will
use ComponentDeps when we translate out of the results from the modular solver
into cabal-install's main datatypes.
We don't yet _return_ fine-grained dependencies from the solver; this will be
the subject of the next commit.
---
.../Client/Dependency/Modular/Builder.hs | 51 +++++++------
.../Client/Dependency/Modular/Dependency.hs | 73 ++++++++++++++++---
.../Client/Dependency/Modular/Index.hs | 4 +-
.../Dependency/Modular/IndexConversion.hs | 57 +++++++++------
.../Client/Dependency/Modular/Linking.hs | 17 +++--
.../Client/Dependency/Modular/Preference.hs | 8 +-
.../Client/Dependency/Modular/Tree.hs | 16 ++--
.../Client/Dependency/Modular/Validate.hs | 13 ++--
8 files changed, 158 insertions(+), 81 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 1a9bb2cd34..3c6e4b082e 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -27,38 +27,42 @@ import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.PSQ as P
import Distribution.Client.Dependency.Modular.Tree
+import Distribution.Client.ComponentDeps (Component)
+
-- | The state needed during the build phase of the search tree.
data BuildState = BS {
- index :: Index, -- ^ information about packages and their dependencies
- 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
+ index :: Index, -- ^ information about packages and their dependencies
+ 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
}
-- | Extend the set of open goals with the new goals listed.
--
-- We also adjust the map of overall goals, and keep track of the
-- reverse dependencies of each of the goals.
-extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState
+extendOpen :: QPN -> [OpenGoal Component] -> BuildState -> BuildState
extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
where
- go :: RevDepMap -> PSQ OpenGoal () -> [OpenGoal] -> BuildState
- go g o [] = s { rdeps = g, open = o }
- go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons ng () o) ngs
+ go :: RevDepMap -> PSQ (OpenGoal ()) () -> [OpenGoal Component] -> BuildState
+ go g o [] = s { rdeps = g, open = o }
+ go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons' ng () o) ngs
-- Note: for 'Flagged' goals, we always insert, so later additions win.
-- This is important, because in general, if a goal is inserted twice,
-- the later addition will have better dependency information.
- go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons ng () o) ngs
- go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs)
- | qpn == qpn' = go g o ngs
- -- we ignore self-dependencies at this point; TODO: more care may be needed
- | qpn `M.member` g = go (M.adjust (qpn':) qpn g) o ngs
- | otherwise = go (M.insert qpn [qpn'] g) (cons ng () o) ngs
- -- code above is correct; insert/adjust have different arg order
+ go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons' ng () o) ngs
+ go g o (ng@(OpenGoal (Simple (Dep qpn _) _) _gr) : ngs)
+ | qpn == qpn' = go g o ngs
+ -- we ignore self-dependencies at this point; TODO: more care may be needed
+ | qpn `M.member` g = go (M.adjust (qpn':) qpn g) o ngs
+ | otherwise = go (M.insert qpn [qpn'] g) (cons' ng () o) ngs
+ -- code above is correct; insert/adjust have different arg order
+
+ cons' = cons . forgetCompOpenGoal
-- | 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 ->
+scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->
BuildState -> BuildState
scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
where
@@ -87,7 +91,7 @@ scopedExtendOpen qpn@(Q pp _pn) i gr fdeps fdefs s = extendOpen qpn gs s
-- | Datatype that encodes what to build next
data BuildType =
Goals -- ^ build a goal choice node
- | OneGoal OpenGoal -- ^ build a node for this goal
+ | OneGoal (OpenGoal ()) -- ^ build a node for this goal
| Instance QPN I PInfo QGoalReasonChain -- ^ build a tree for a concrete instance
deriving Show
@@ -109,7 +113,7 @@ 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, 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 (P.fromList (L.map (\ (i, info) ->
@@ -149,9 +153,14 @@ build = ana go
-- and computes the initial state and then the tree from there.
buildTree :: Index -> Bool -> [PN] -> Tree QGoalReasonChain
buildTree idx ind igs =
- build (BS idx (M.fromList (L.map (\ qpn -> (qpn, [])) qpns))
- (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns))
- Goals)
+ build BS {
+ index = idx
+ , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns)
+ , open = P.fromList (L.map (\ qpn -> (topLevelGoal qpn, ())) qpns)
+ , next = Goals
+ }
where
+ topLevelGoal qpn = OpenGoal (Simple (Dep qpn (Constrained [])) ()) [UserGoal]
+
qpns | ind = makeIndependent igs
| otherwise = L.map (Q None) igs
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 5282de4d71..95d59f5ed0 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -18,6 +18,9 @@ module Distribution.Client.Dependency.Modular.Dependency (
, FalseFlaggedDeps
, Dep(..)
, showDep
+ -- ** Setting/forgetting components
+ , forgetCompOpenGoal
+ , setCompFlaggedDeps
-- * Reverse dependency map
, RevDepMap
-- * Goals
@@ -48,6 +51,8 @@ import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Version
+import Distribution.Client.ComponentDeps (Component)
+
{-------------------------------------------------------------------------------
Variables
-------------------------------------------------------------------------------}
@@ -133,18 +138,37 @@ merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss))
Flagged dependencies
-------------------------------------------------------------------------------}
-type FlaggedDeps qpn = [FlaggedDep qpn]
+-- | Flagged dependencies
+--
+-- 'FlaggedDeps' is the modular solver's view of a packages dependencies:
+-- rather than having the dependencies indexed by component, each dependency
+-- defines what component it is in.
+--
+-- However, top-level goals are also modelled as dependencies, but of course
+-- these don't actually belong in any component of any package. Therefore, we
+-- parameterize 'FlaggedDeps' and derived datatypes with a type argument that
+-- specifies whether or not we have a component: we only ever instantiate this
+-- type argument with @()@ for top-level goals, or 'Component' for everything
+-- else (we could express this as a kind at the type-level, but that would
+-- require a very recent GHC).
+--
+-- Note however, crucially, that independent of the type parameters, the list
+-- of dependencies underneath a flag choice or stanza choices _always_ uses
+-- Component as the type argument. This is important: when we pick a value for
+-- a flag, we _must_ know what component the new dependencies belong to, or
+-- else we don't be able to construct fine-grained reverse dependencies.
+type FlaggedDeps comp qpn = [FlaggedDep comp qpn]
-- | Flagged dependencies can either be plain dependency constraints,
-- or flag-dependent dependency trees.
-data FlaggedDep qpn =
+data FlaggedDep comp qpn =
Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn)
| Stanza (SN qpn) (TrueFlaggedDeps qpn)
- | Simple (Dep qpn)
+ | Simple (Dep qpn) comp
deriving (Eq, Show, Functor)
-type TrueFlaggedDeps qpn = FlaggedDeps qpn
-type FalseFlaggedDeps qpn = FlaggedDeps qpn
+type TrueFlaggedDeps qpn = FlaggedDeps Component qpn
+type FalseFlaggedDeps qpn = FlaggedDeps Component qpn
-- | A dependency (constraint) associates a package name with a
-- constrained instance.
@@ -160,6 +184,35 @@ showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
showDep (Dep qpn ci ) =
showQPN qpn ++ showCI ci
+{-------------------------------------------------------------------------------
+ Setting/forgetting the Component
+-------------------------------------------------------------------------------}
+
+forgetCompOpenGoal :: OpenGoal Component -> OpenGoal ()
+forgetCompOpenGoal = mapCompOpenGoal $ const ()
+
+setCompFlaggedDeps :: Component -> FlaggedDeps () qpn -> FlaggedDeps Component qpn
+setCompFlaggedDeps = mapCompFlaggedDeps . const
+
+{-------------------------------------------------------------------------------
+ Auxiliary: Mapping over the Component goal
+
+ We don't export these, because the only type instantiations for 'a' and 'b'
+ here should be () or Component. (We could express this at the type level
+ if we relied on newer versions of GHC.)
+-------------------------------------------------------------------------------}
+
+mapCompOpenGoal :: (a -> b) -> OpenGoal a -> OpenGoal b
+mapCompOpenGoal g (OpenGoal d gr) = OpenGoal (mapCompFlaggedDep g d) gr
+
+mapCompFlaggedDeps :: (a -> b) -> FlaggedDeps a qpn -> FlaggedDeps b qpn
+mapCompFlaggedDeps = L.map . mapCompFlaggedDep
+
+mapCompFlaggedDep :: (a -> b) -> FlaggedDep a qpn -> FlaggedDep b qpn
+mapCompFlaggedDep _ (Flagged fn nfo t f) = Flagged fn nfo t f
+mapCompFlaggedDep _ (Stanza sn t ) = Stanza sn t
+mapCompFlaggedDep g (Simple pn a ) = Simple pn (g a)
+
{-------------------------------------------------------------------------------
Reverse dependency map
-------------------------------------------------------------------------------}
@@ -227,15 +280,15 @@ goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars
-- | For open goals as they occur during the build phase, we need to store
-- additional information about flags.
-data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain
+data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReasonChain
deriving (Eq, Show)
-- | Closes a goal, i.e., removes all the extraneous information that we
-- need only during the build phase.
-close :: OpenGoal -> Goal QPN
-close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr
-close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr
-close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr
+close :: OpenGoal comp -> Goal QPN
+close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr
+close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr
+close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr
{-------------------------------------------------------------------------------
Version ranges paired with origins
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
index ac3450379a..9af767aa97 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Index.hs
@@ -9,6 +9,8 @@ import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
+import Distribution.Client.ComponentDeps (Component)
+
-- | An index contains information about package instances. This is a nested
-- dictionary. Package names are mapped to instances, which in turn is mapped
-- to info.
@@ -20,7 +22,7 @@ type Index = Map PN (Map I PInfo)
-- 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 (Maybe FailReason)
+data PInfo = PInfo (FlaggedDeps Component PN) FlagInfo (Maybe FailReason)
deriving (Show)
mkIndex :: [(PN, I, PInfo)] -> Index
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index 53b5a46a4d..681a6d3014 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -21,6 +21,8 @@ import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Tree
import Distribution.Client.Dependency.Modular.Version
+import Distribution.Client.ComponentDeps (Component(..))
+
-- | Convert both the installed package index and the source package
-- index into one uniform solver index.
--
@@ -62,8 +64,11 @@ 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 (setComp fds) M.empty Nothing)
+ where
+ -- We assume that all dependencies of installed packages are _library_ deps
+ setComp = setCompFlaggedDeps ComponentLib
-- TODO: Installed packages should also store their encapsulations!
-- | Convert dependencies specified by an installed package id into
@@ -72,13 +77,13 @@ convIP idx ipi =
-- May return Nothing if the package can't be found in the index. That
-- indicates that the original package having this dependency is broken
-- and should be ignored.
-convIPId :: PN -> SI.InstalledPackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN)
+convIPId :: PN -> SI.InstalledPackageIndex -> InstalledPackageId -> Maybe (FlaggedDep () PN)
convIPId pn' idx ipid =
case SI.lookupInstalledPackageId idx ipid of
Nothing -> Nothing
Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid)
pn = pkgName (sourcePackageId ipi)
- in Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))))
+ in Just (D.Simple (Dep pn (Fixed i (Goal (P pn') []))) ())
-- | Convert a cabal-install source package index to the simpler,
-- more uniform index format of the solver.
@@ -101,27 +106,25 @@ convSP os arch cinfo strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
-- want to keep the condition tree, but simplify much of the test.
-- | Convert a generic package description to a solver-specific 'PInfo'.
---
--- TODO: We currently just take all dependencies from all specified library,
--- executable and test components. This does not quite seem fair.
convGPD :: OS -> Arch -> CompilerInfo -> Bool ->
PI PN -> GenericPackageDescription -> PInfo
convGPD os arch comp strfl pi
(GenericPackageDescription _ flags libs exes tests benchs) =
let
- fds = flagInfo strfl flags
+ fds = flagInfo strfl flags
+ conv = convCondTree os arch comp pi fds (const True)
in
PInfo
- (maybe [] (convCondTree os arch comp pi fds (const True) ) libs ++
- concatMap (convCondTree os arch comp pi fds (const True) . snd) exes ++
+ (maybe [] (conv ComponentLib ) libs ++
+ concatMap (\(nm, ds) -> conv (ComponentExe nm) ds) exes ++
prefix (Stanza (SN pi TestStanzas))
- (L.map (convCondTree os arch comp pi fds (const True) . snd) tests) ++
+ (L.map (\(nm, ds) -> conv (ComponentTest nm) ds) tests) ++
prefix (Stanza (SN pi BenchStanzas))
- (L.map (convCondTree os arch comp pi fds (const True) . snd) benchs))
+ (L.map (\(nm, ds) -> conv (ComponentBench nm) ds) benchs))
fds
Nothing
-prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn
+prefix :: (FlaggedDeps comp qpn -> FlaggedDep comp' qpn) -> [FlaggedDeps comp qpn] -> FlaggedDeps comp' qpn
prefix _ [] = []
prefix f fds = [f (concat fds)]
@@ -133,10 +136,11 @@ flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not
-- | Convert condition trees to flagged dependencies.
convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->
(a -> Bool) -> -- how to detect if a branch is active
- CondTree ConfVar [Dependency] a -> FlaggedDeps PN
-convCondTree os arch comp pi@(PI pn _) fds p (CondNode info ds branches)
- | p info = L.map (D.Simple . convDep pn) ds -- unconditional dependencies
- ++ concatMap (convBranch os arch comp pi fds p) branches
+ Component ->
+ CondTree ConfVar [Dependency] a -> FlaggedDeps Component PN
+convCondTree os arch cinfo pi@(PI pn _) fds p comp (CondNode info ds branches)
+ | p info = L.map (\d -> D.Simple (convDep pn d) comp) ds -- unconditional dependencies
+ ++ concatMap (convBranch os arch cinfo pi fds p comp) branches
| otherwise = []
-- | Branch interpreter.
@@ -150,15 +154,16 @@ convCondTree os arch comp pi@(PI pn _) fds p (CondNode info ds branches)
convBranch :: OS -> Arch -> CompilerInfo ->
PI PN -> FlagInfo ->
(a -> Bool) -> -- how to detect if a branch is active
+ Component ->
(Condition ConfVar,
CondTree ConfVar [Dependency] a,
- Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN
-convBranch os arch cinfo pi fds p (c', t', mf') =
- go c' ( convCondTree os arch cinfo pi fds p t')
- (maybe [] (convCondTree os arch cinfo pi fds p) mf')
+ Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN
+convBranch os arch cinfo pi fds p comp (c', t', mf') =
+ go c' ( convCondTree os arch cinfo pi fds p comp t')
+ (maybe [] (convCondTree os arch cinfo pi fds p comp) mf')
where
go :: Condition ConfVar ->
- FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN
+ FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN
go (Lit True) t _ = t
go (Lit False) _ f = f
go (CNot c) t f = go c f t
@@ -187,8 +192,12 @@ convBranch os arch cinfo pi fds p (c', t', mf') =
-- with deferring flag choices will then usually first resolve this package,
-- and try an already installed version before imposing a default flag choice
-- that might not be what we want.
- extractCommon :: FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN
- extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) | D.Simple (Dep pn _) <- ps, D.Simple (Dep pn' _) <- ps', pn == pn' ]
+ extractCommon :: FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN
+ extractCommon ps ps' = [ D.Simple (Dep pn (Constrained [])) comp
+ | D.Simple (Dep pn _) _ <- ps
+ , D.Simple (Dep pn' _) _ <- ps'
+ , pn == pn'
+ ]
-- | Convert a Cabal dependency to a solver-specific dependency.
convDep :: PN -> Dependency -> Dep PN
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
index b9b5aea078..9a394ac5bf 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
@@ -30,6 +30,7 @@ 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
@@ -167,7 +168,7 @@ conflict = lift' . Left
execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState
execUpdateState = execStateT . unUpdateState
-pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState ()
+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
@@ -185,7 +186,7 @@ pickConcrete qpn@(Q pp _) i = do
Just lg ->
makeCanonical lg qpn
-pickLink :: QPN -> I -> PP -> FlaggedDeps QPN -> UpdateState ()
+pickLink :: QPN -> I -> PP -> FlaggedDeps comp 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
@@ -211,11 +212,11 @@ makeCanonical lg qpn@(Q pp _) =
let lg' = lg { lgCanon = Just pp }
updateLinkGroup lg'
-linkDeps :: [Var QPN] -> PP -> FlaggedDeps QPN -> UpdateState ()
+linkDeps :: [Var QPN] -> PP -> FlaggedDeps comp QPN -> UpdateState ()
linkDeps parents pp' = mapM_ go
where
- go :: FlaggedDep QPN -> UpdateState ()
- go (Simple (Dep qpn@(Q _ pn) _)) = do
+ 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
@@ -258,11 +259,11 @@ linkNewDeps var b = do
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 :: ValidateState -> FlaggedDeps comp QPN -> ([Var QPN], FlaggedDeps Component QPN)
findNewDeps vs = concatMapUnzip (findNewDeps' vs)
- findNewDeps' :: ValidateState -> FlaggedDep QPN -> ([Var QPN], FlaggedDeps QPN)
- findNewDeps' _ (Simple _) = ([], [])
+ 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)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index 8e8b98dba6..eb45b1b043 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -254,10 +254,10 @@ preferBaseGoalChoice = trav go
go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs)
go x = x
- preferBase :: OpenGoal -> OpenGoal -> Ordering
- preferBase (OpenGoal (Simple (Dep (Q _pp pn) _)) _) _ | unPN pn == "base" = LT
- preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _)) _) | unPN pn == "base" = GT
- preferBase _ _ = EQ
+ preferBase :: OpenGoal comp -> OpenGoal comp -> Ordering
+ 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
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
index cdcd5760e7..307af38fc3 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs
@@ -14,10 +14,10 @@ import Distribution.Client.Dependency.Modular.Version
-- | Type of the search tree. Inlining the choice nodes for now.
data 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
+ 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
| Done RevDepMap
| Fail (ConflictSet QPN) FailReason
deriving (Eq, Show, Functor)
@@ -57,10 +57,10 @@ data FailReason = InconsistentInitialConstraints
-- | Functor for the tree type.
data TreeF a 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)
+ 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)
| DoneF RevDepMap
| FailF (ConflictSet QPN) FailReason
deriving (Functor, Foldable, Traversable)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index c28700e142..4d96bf280f 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -21,6 +21,8 @@ import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.PSQ as P
import Distribution.Client.Dependency.Modular.Tree
+import Distribution.Client.ComponentDeps (Component)
+
-- In practice, most constraints are implication constraints (IF we have made
-- a number of choices, THEN we also have to ensure that). We call constraints
-- that for which the preconditions are fulfilled ACTIVE. We maintain a set
@@ -74,7 +76,7 @@ import Distribution.Client.Dependency.Modular.Tree
-- | The state needed during validation.
data ValidateState = VS {
index :: Index,
- saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies
+ saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies
pa :: PreAssignment
}
@@ -188,11 +190,11 @@ validate = cata go
-- | We try to extract as many concrete dependencies from the given flagged
-- dependencies as possible. We make use of all the flag knowledge we have
-- already acquired.
-extractDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]
+extractDeps :: FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]
extractDeps fa sa deps = do
d <- deps
case d of
- Simple sd -> return sd
+ Simple sd _ -> return sd
Flagged qfn _ td fd -> case M.lookup qfn fa of
Nothing -> mzero
Just True -> extractDeps fa sa td
@@ -205,13 +207,14 @@ extractDeps fa sa deps = do
-- | We try to find new dependencies that become available due to the given
-- flag or stanza choice. We therefore look for the choice in question, and then call
-- 'extractDeps' for everything underneath.
-extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]
+extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps comp QPN -> [Dep QPN]
extractNewDeps v gr b fa sa = go
where
+ go :: FlaggedDeps comp QPN -> [Dep QPN] -- Type annotation necessary (polymorphic recursion)
go deps = do
d <- deps
case d of
- Simple _ -> mzero
+ Simple _ _ -> mzero
Flagged qfn' _ td fd
| v == F qfn' -> L.map (resetGoal (Goal v gr)) $
if b then extractDeps fa sa td else extractDeps fa sa fd
--
GitLab