From 21b6b2b62239b1fa316c6f1e64722fa06ded2a20 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Mon, 6 Apr 2015 17:14:20 +0100
Subject: [PATCH] Abstract out qualification of goals
This happened independently in a number of places, which was bad; and was about
to get worse with the base 3/4 thing.
---
.../Client/Dependency/Modular/Builder.hs | 14 ++------------
.../Client/Dependency/Modular/Dependency.hs | 16 ++++++++++++++++
.../Client/Dependency/Modular/Linking.hs | 8 +++-----
.../Client/Dependency/Modular/Package.hs | 1 -
.../Client/Dependency/Modular/Validate.hs | 5 ++---
5 files changed, 23 insertions(+), 21 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index e614c3c6d3..226cbbc9e7 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -16,7 +16,6 @@ module Distribution.Client.Dependency.Modular.Builder (buildTree) where
-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we
-- store the entire dependency.
-import Control.Monad.Reader hiding (sequence, mapM)
import Data.List as L
import Data.Map as M
import Prelude hiding (sequence, mapM)
@@ -65,19 +64,10 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
-- dependencies and then extend the set of open goals accordingly.
scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps Component PN -> FlagInfo ->
BuildState -> BuildState
-scopedExtendOpen qpn@(Q pp pn) i gr fdeps fdefs s = extendOpen qpn gs s
+scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s
where
-- Qualify all package names
- --
- -- NOTE: We `fmap` over the setup dependencies to qualify the package name,
- -- BUT this is _only_ correct because the setup dependencies cannot have
- -- conditional sections (setup dependencies cannot depend on flags). IF
- -- setup dependencies _could_ depend on flags, then these flag names should
- -- NOT be qualified with @Q (Setup pn pp)@ but rather with @pp@: flag
- -- assignments are package wide, irrespective of whether or not we treat
- -- certain dependencies as independent or not.
- qfdeps = L.map (fmap (Q pp)) (nonSetupDeps fdeps)
- ++ L.map (fmap (Q (Setup pn pp))) (setupDeps fdeps)
+ qfdeps = qualifyDeps qpn fdeps
-- 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
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 0525f56f98..c1c9d0ede9 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -18,6 +18,7 @@ module Distribution.Client.Dependency.Modular.Dependency (
, FalseFlaggedDeps
, Dep(..)
, showDep
+ , qualifyDeps
-- ** Setting/forgetting components
, forgetCompOpenGoal
, setCompFlaggedDeps
@@ -191,6 +192,21 @@ showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
showDep (Dep qpn ci ) =
showQPN qpn ++ showCI ci
+-- | Apply built-in rules for package qualifiers
+--
+-- NOTE: We `fmap` over the setup dependencies to qualify the package name, BUT
+-- this is _only_ correct because the setup dependencies cannot have conditional
+-- sections (setup dependencies cannot depend on flags). IF setup dependencies
+-- _could_ depend on flags, then these flag names should NOT be qualified with
+-- @Q (Setup pn pp)@ but rather with @pp@: flag assignments are package wide,
+-- irrespective of whether or not we treat certain dependencies as independent
+-- or not.
+qualifyDeps :: QPN -> FlaggedDeps Component PN -> FlaggedDeps Component QPN
+qualifyDeps (Q pp pn) deps = concat [
+ map (fmap (Q pp)) (nonSetupDeps deps)
+ , map (fmap (Q (Setup pn pp))) (setupDeps deps)
+ ]
+
{-------------------------------------------------------------------------------
Setting/forgetting the Component
-------------------------------------------------------------------------------}
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
index d645877351..ba0b97c561 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
@@ -116,11 +116,10 @@ validateLinking index = (`runReader` initVS) . cata go
-- Package choices
goP :: QPN -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
- goP qpn@(Q pp pn) opt@(POption i _) r = do
+ goP qpn@(Q _pp pn) opt@(POption i _) r = do
vs <- ask
let PInfo deps _ _ = vsIndex vs ! pn ! i
- qdeps = map (fmap (Q pp)) (nonSetupDeps deps)
- ++ map (fmap (Q (Setup pn pp))) (setupDeps deps)
+ qdeps = qualifyDeps qpn deps
case execUpdateState (pickPOption qpn opt qdeps) vs of
Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err)
Right vs' -> local (const vs') r
@@ -254,8 +253,7 @@ 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)) (nonSetupDeps deps)
- ++ map (fmap (Q (Setup pn pp))) (setupDeps deps)
+ qdeps = qualifyDeps qpn deps
lg = vsLinks vs ! qpn
(parents, newDeps) = findNewDeps vs qdeps
linkedTo = S.delete pp (lgMembers lg)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
index 22ba01e7e8..1f5fe57952 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Package.hs
@@ -103,6 +103,5 @@ makeIndependent ps = [ Q pp pn | (pn, i) <- zip ps [0::Int ..]
, let pp = Independent i None
]
-
unQualify :: Q a -> a
unQualify (Q _ x) = x
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index cfc048ebd0..ac748e3d9c 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -120,15 +120,14 @@ validate = cata go
-- What to do for package nodes ...
goP :: QPN -> QGoalReasonChain -> POption -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
- goP qpn@(Q pp pn) gr (POption i _) r = do
+ 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
-- obtain dependencies and index-dictated exclusions introduced by the choice
let (PInfo deps _ mfr) = idx ! pn ! i
-- qualify the deps in the current scope
- let qdeps = L.map (fmap (Q pp)) (nonSetupDeps deps)
- ++ L.map (fmap (Q (Setup pn pp))) (setupDeps deps)
+ let qdeps = qualifyDeps qpn deps
-- 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
--
GitLab