From fd5e0c65b2346f0fc7f7f35cee18596ca8674109 Mon Sep 17 00:00:00 2001
From: Andres Loeh <andres@well-typed.com>
Date: Thu, 23 Jul 2015 23:46:34 +0200
Subject: [PATCH] Track language extensions and language flavours in the
solver.
Every package now "depends" on all language extensions
(default-extensions and other-extensions) and language flavours
(default-language and other-languages) it declares in its cabal file.
During solving, we verify that the compiler we use actually
supports selected extensions and languages. This has to be done
during solving, because flag choices can influence the declared
extensions and languages being used.
There currently is no equivalent check performed on the generated
install plans. In general, cabal-install performs a sanity check
on the solver output, checking that the solver e.g. indeed includes
all the declared dependencies of a package. There is no such
double-checking for language extensions. This is not really
problematic, as all that this change does is to make the solver
more conservative rather than less. However, having a sanity check
available might ultimately be nice to have.
---
.../Distribution/Client/Dependency/Modular.hs | 2 +-
.../Client/Dependency/Modular/Assignment.hs | 29 +++++++++++----
.../Client/Dependency/Modular/Builder.hs | 6 ++++
.../Client/Dependency/Modular/Dependency.hs | 18 +++++++++-
.../Dependency/Modular/IndexConversion.hs | 26 ++++++++------
.../Client/Dependency/Modular/Linking.hs | 4 +++
.../Client/Dependency/Modular/Solver.hs | 11 +++---
.../Client/Dependency/Modular/Validate.hs | 35 ++++++++++++++-----
8 files changed, 100 insertions(+), 31 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular.hs b/cabal-install/Distribution/Client/Dependency/Modular.hs
index 60fde9aed7..4f356dcf17 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular.hs
@@ -37,7 +37,7 @@ modularResolver :: SolverConfig -> DependencyResolver
modularResolver sc (Platform arch os) cinfo iidx sidx pprefs pcs pns =
fmap (uncurry postprocess) $ -- convert install plan
logToProgress (maxBackjumps sc) $ -- convert log format into progress format
- solve sc idx pprefs gcs pns
+ solve sc cinfo idx pprefs gcs pns
where
-- Indices have to be converted into solver-specific uniform index.
idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) iidx sidx
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
index e5a5080a37..54529d3c01 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs
@@ -8,6 +8,8 @@ import Data.Map as M
import Data.Maybe
import Prelude hiding (pi)
+import Language.Haskell.Extension (Extension, Language)
+
import Distribution.PackageDescription (FlagAssignment) -- from Cabal
import Distribution.Client.Types (OptionalStanza)
import Distribution.Client.Utils.LabeledGraph
@@ -53,14 +55,27 @@ data PreAssignment = PA PPreAssignment FAssignment SAssignment
--
-- Either returns a witness of the conflict that would arise during the merge,
-- or the successfully extended assignment.
-extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
-extend var pa qa = foldM (\ a (Dep qpn ci) ->
- let ci' = M.findWithDefault (Constrained []) qpn a
- in case (\ x -> M.insert qpn x a) <$> merge ci' ci of
- Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d'))
- Right x -> Right x)
- pa qa
+extend :: (Extension -> Bool) -- ^ is a given extension supported
+ -> (Language -> Bool) -- ^ is a given language supported
+ -> Goal QPN
+ -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
+extend extSupported langSupported goal@(Goal var _) = foldM extendSingle
where
+
+ extendSingle :: PPreAssignment -> Dep QPN
+ -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment
+ extendSingle a (Ext ext ) =
+ if extSupported ext then Right a
+ else Left (toConflictSet goal, [Ext ext])
+ extendSingle a (Lang lang) =
+ if langSupported lang then Right a
+ else Left (toConflictSet goal, [Lang lang])
+ extendSingle a (Dep qpn ci) =
+ let ci' = M.findWithDefault (Constrained []) qpn a
+ in case (\ x -> M.insert qpn x a) <$> merge ci' ci of
+ Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d'))
+ Right x -> Right x
+
-- We're trying to remove trivial elements of the conflict. If we're just
-- making a choice pkg == instance, and pkg => pkg == instance is a part
-- of the conflict, then this info is clear from the context and does not
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
index 543a006961..de070a6297 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs
@@ -58,6 +58,8 @@ extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs
| qpn `M.member` g = go (M.adjust ((c, qpn'):) qpn g) o ngs
| otherwise = go (M.insert qpn [(c, qpn')] g) (cons' ng () o) ngs
-- code above is correct; insert/adjust have different arg order
+ go g o ( (OpenGoal (Simple (Ext _ext ) _) _gr) : ngs) = go g o ngs
+ go g o ( (OpenGoal (Simple (Lang _lang)_) _gr) : ngs) = go g o ngs
cons' = cons . forgetCompOpenGoal
@@ -114,6 +116,10 @@ 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 { index = _ , next = OneGoal (OpenGoal (Simple (Ext _ ) _) _ ) }) =
+ error "Distribution.Client.Dependency.Modular.Builder: build.go called with Ext goal"
+ go (BS { index = _ , next = OneGoal (OpenGoal (Simple (Lang _ ) _) _ ) }) =
+ error "Distribution.Client.Dependency.Modular.Builder: build.go called with Lang goal"
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)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
index 4403f5b8c1..b62ee98ee7 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs
@@ -59,6 +59,10 @@ import Data.Set (Set)
import qualified Data.List as L
import qualified Data.Set as S
+import Language.Haskell.Extension (Extension(..), Language(..))
+
+import Distribution.Text
+
import Distribution.Client.Dependency.Modular.Flag
import Distribution.Client.Dependency.Modular.Package
import Distribution.Client.Dependency.Modular.Version
@@ -201,7 +205,9 @@ type FalseFlaggedDeps qpn = FlaggedDeps Component qpn
-- | A dependency (constraint) associates a package name with a
-- constrained instance.
-data Dep qpn = Dep qpn (CI qpn)
+data Dep qpn = Dep qpn (CI qpn) -- dependency on a package
+ | Ext Extension -- dependency on a language extension
+ | Lang Language -- dependency on a language version
deriving (Eq, Show, Functor)
showDep :: Dep QPN -> String
@@ -212,6 +218,8 @@ showDep (Dep qpn (Constrained [(vr, Goal v _)])) =
showVar v ++ " => " ++ showQPN qpn ++ showVR vr
showDep (Dep qpn ci ) =
showQPN qpn ++ showCI ci
+showDep (Ext ext) = "requires " ++ display ext
+showDep (Lang lang) = "requires " ++ display lang
-- | Options for goal qualification (used in 'qualifyDeps')
--
@@ -253,6 +261,8 @@ qualifyDeps QO{..} (Q pp' pn) = go
-- Should we qualify this goal with the 'Base' package path?
qBase :: Dep PN -> Bool
qBase (Dep dep _ci) = qoBaseShim && unPackageName dep == "base"
+ qBase (Ext _) = False
+ qBase (Lang _) = False
-- Should we qualify this goal with the 'Setup' packaeg path?
qSetup :: Component -> Bool
@@ -381,6 +391,8 @@ instance ResetGoal CI where
instance ResetGoal Dep where
resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci)
+ resetGoal _ (Ext ext) = Ext ext
+ resetGoal _ (Lang lang) = Lang lang
instance ResetGoal Goal where
resetGoal = const
@@ -415,6 +427,10 @@ data OpenGoal comp = OpenGoal (FlaggedDep comp QPN) QGoalReasonChain
-- need only during the build phase.
close :: OpenGoal comp -> Goal QPN
close (OpenGoal (Simple (Dep qpn _) _) gr) = Goal (P qpn) gr
+close (OpenGoal (Simple (Ext _) _) _ ) =
+ error "Distribution.Client.Dependency.Modular.Dependency.close: called on Ext goal"
+close (OpenGoal (Simple (Lang _) _) _ ) =
+ error "Distribution.Client.Dependency.Modular.Dependency.close: called on Lang goal"
close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr
close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
index fcb06896d9..5e39c99623 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs
@@ -120,13 +120,13 @@ convGPD os arch comp strfl pi
conv = convCondTree os arch comp pi fds (const True)
in
PInfo
- (maybe [] (conv ComponentLib ) libs ++
+ (maybe [] (conv ComponentLib libBuildInfo ) libs ++
maybe [] (convSetupBuildInfo pi) (setupBuildInfo pkg) ++
- concatMap (\(nm, ds) -> conv (ComponentExe nm) ds) exes ++
+ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo ds) exes ++
prefix (Stanza (SN pi TestStanzas))
- (L.map (\(nm, ds) -> conv (ComponentTest nm) ds) tests) ++
+ (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo ds) tests) ++
prefix (Stanza (SN pi BenchStanzas))
- (L.map (\(nm, ds) -> conv (ComponentBench nm) ds) benchs))
+ (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo ds) benchs))
fds
Nothing
@@ -143,11 +143,16 @@ flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not
convCondTree :: OS -> Arch -> CompilerInfo -> PI PN -> FlagInfo ->
(a -> Bool) -> -- how to detect if a branch is active
Component ->
+ (a -> BuildInfo) ->
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
+convCondTree os arch cinfo pi@(PI pn _) fds p comp getInfo (CondNode info ds branches)
+ | p info = L.map (\d -> D.Simple (convDep pn d) comp) ds -- unconditional package dependencies
+ ++ L.map (\e -> D.Simple (Ext e) comp) (PD.allExtensions bi) -- unconditional extension dependencies
+ ++ L.map (\l -> D.Simple (Lang l) comp) (PD.allLanguages bi) -- unconditional language dependencies
+ ++ concatMap (convBranch os arch cinfo pi fds p comp getInfo) branches
| otherwise = []
+ where
+ bi = getInfo info
-- | Branch interpreter.
--
@@ -161,12 +166,13 @@ convBranch :: OS -> Arch -> CompilerInfo ->
PI PN -> FlagInfo ->
(a -> Bool) -> -- how to detect if a branch is active
Component ->
+ (a -> BuildInfo) ->
(Condition ConfVar,
CondTree ConfVar [Dependency] a,
Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps Component PN
-convBranch os arch cinfo pi@(PI pn _) 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')
+convBranch os arch cinfo pi@(PI pn _) fds p comp getInfo (c', t', mf') =
+ go c' ( convCondTree os arch cinfo pi fds p comp getInfo t')
+ (maybe [] (convCondTree os arch cinfo pi fds p comp getInfo) mf')
where
go :: Condition ConfVar ->
FlaggedDeps Component PN -> FlaggedDeps Component PN -> FlaggedDeps Component PN
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
index 26bf12235d..0b0a5ef603 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Linking.hs
@@ -274,6 +274,10 @@ linkDeps parents pp' = mapM_ go
lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs
lg'' <- lift' $ lgMerge parents lg lg'
updateLinkGroup lg''
+ -- For extensions and language dependencies, there is nothing to do.
+ -- No choice is involved, just checking, so there is nothing to link.
+ go (Simple (Ext _) _) = return ()
+ go (Simple (Lang _) _) = return ()
go (Flagged fn _ t f) = do
vs <- get
case M.lookup fn (vsFlags vs) of
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index af5901f628..bf7feeaacb 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -2,6 +2,8 @@ module Distribution.Client.Dependency.Modular.Solver where
import Data.Map as M
+import Distribution.Compiler (CompilerInfo)
+
import Distribution.Client.Dependency.Types
import Distribution.Client.Dependency.Modular.Assignment
@@ -26,13 +28,14 @@ data SolverConfig = SolverConfig {
maxBackjumps :: Maybe Int
}
-solve :: SolverConfig -> -- solver parameters
- Index -> -- all available packages as an index
+solve :: SolverConfig -> -- solver parameters
+ CompilerInfo ->
+ Index -> -- all available packages as an index
(PN -> PackagePreferences) -> -- preferences
Map PN [LabeledPackageConstraint] -> -- global constraints
[PN] -> -- global goals
Log Message (Assignment, RevDepMap)
-solve sc idx userPrefs userConstraints userGoals =
+solve sc cinfo idx userPrefs userConstraints userGoals =
explorePhase $
heuristicsPhase $
preferencesPhase $
@@ -54,7 +57,7 @@ solve sc idx userPrefs userConstraints userGoals =
P.enforcePackageConstraints userConstraints .
P.enforceSingleInstanceRestriction .
validateLinking idx .
- validateTree idx
+ validateTree cinfo idx
prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) .
-- packages that can never be "upgraded":
P.requireInstalled (`elem` [ PackageName "base"
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
index dfd1d29be2..5b6d3c2b2a 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs
@@ -10,9 +10,14 @@ import Control.Applicative
import Control.Monad.Reader hiding (sequence)
import Data.List as L
import Data.Map as M
+import Data.Set as S
import Data.Traversable
import Prelude hiding (sequence)
+import Language.Haskell.Extension (Extension, Language)
+
+import Distribution.Compiler (CompilerInfo(..))
+
import Distribution.Client.Dependency.Modular.Assignment
import Distribution.Client.Dependency.Modular.Dependency
import Distribution.Client.Dependency.Modular.Flag
@@ -75,6 +80,8 @@ import Distribution.Client.ComponentDeps (Component)
-- | The state needed during validation.
data ValidateState = VS {
+ supportedExt :: Extension -> Bool,
+ supportedLang :: Language -> Bool,
index :: Index,
saved :: Map QPN (FlaggedDeps Component QPN), -- saved, scoped, dependencies
pa :: PreAssignment,
@@ -123,6 +130,8 @@ validate = cata go
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
+ extSupported <- asks supportedExt -- obtain the supported extensions
+ langSupported <- asks supportedLang -- obtain the supported languages
idx <- asks index -- obtain the index
svd <- asks saved -- obtain saved dependencies
qo <- asks qualifyOptions
@@ -135,7 +144,7 @@ validate = cata go
let goal = Goal (P qpn) gr
let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps)
-- We now try to extend the partial assignment with the new active constraints.
- let mnppa = extend (P qpn) ppa newactives
+ let mnppa = extend extSupported langSupported goal ppa newactives
-- In case we continue, we save the scoped dependencies
let nsvd = M.insert qpn qdeps svd
case mfr of
@@ -151,6 +160,8 @@ validate = cata go
goF :: QFN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
goF qfn@(FN (PI qpn _i) _f) gr b r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
+ extSupported <- asks supportedExt -- obtain the supported extensions
+ langSupported <- asks supportedLang -- obtain the supported languages
svd <- asks saved -- obtain saved dependencies
-- Note that there should be saved dependencies for the package in question,
-- because while building, we do not choose flags before we see the packages
@@ -165,7 +176,7 @@ validate = cata go
-- we have chosen a new flag.
let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps
-- As in the package case, we try to extend the partial assignment.
- case extend (F qfn) ppa newactives of
+ case extend extSupported langSupported (Goal (F qfn) gr) ppa newactives of
Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found
Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r
@@ -173,6 +184,8 @@ validate = cata go
goS :: QSN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)
goS qsn@(SN (PI qpn _i) _f) gr b r = do
PA ppa pfa psa <- asks pa -- obtain current preassignment
+ extSupported <- asks supportedExt -- obtain the supported extensions
+ langSupported <- asks supportedLang -- obtain the supported languages
svd <- asks saved -- obtain saved dependencies
-- Note that there should be saved dependencies for the package in question,
-- because while building, we do not choose flags before we see the packages
@@ -187,7 +200,7 @@ validate = cata go
-- we have chosen a new flag.
let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps
-- As in the package case, we try to extend the partial assignment.
- case extend (S qsn) ppa newactives of
+ case extend extSupported langSupported (Goal (S qsn) gr) ppa newactives of
Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found
Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r
@@ -235,10 +248,16 @@ extractNewDeps v gr b fa sa = go
Just False -> []
-- | Interface.
-validateTree :: Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain
-validateTree idx t = runReader (validate t) VS {
- index = idx
- , saved = M.empty
- , pa = PA M.empty M.empty M.empty
+validateTree :: CompilerInfo -> Index -> Tree QGoalReasonChain -> Tree QGoalReasonChain
+validateTree cinfo idx t = runReader (validate t) VS {
+ supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported
+ (\ es -> let s = S.fromList es in \ x -> S.member x s)
+ (compilerInfoExtensions cinfo)
+ , supportedLang = maybe (const True)
+ (flip L.elem) -- use list lookup because language list is small and no Ord instance
+ (compilerInfoLanguages cinfo)
+ , index = idx
+ , saved = M.empty
+ , pa = PA M.empty M.empty M.empty
, qualifyOptions = defaultQualifyOptions idx
}
--
GitLab