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.

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

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

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)

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
 

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

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

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"

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,14 +176,16 @@ 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
 
     -- What to do for stanza nodes (similar to flag nodes) ...
     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
   }