Add solver tests for language extensions and flavours

This also includes modifications to the solver testing DSL and the
testing functions.

This is necessary for merging PR #2732.

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs

@@ -26,6 +26,7 @@ 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
+import Language.Haskell.Extension (Extension(..), Language)
 
 -- cabal-install
 import Distribution.Client.ComponentDeps (ComponentDeps)
@@ -97,6 +98,13 @@ data ExampleDependency =
     -- | Dependency if tests are enabled
   | ExTest ExampleTestName [ExampleDependency]
 
+    -- | Dependency on a language extension
+  | ExExt Extension
+
+    -- | Dependency on a language version
+  | ExLang Language
+
+
 data ExampleAvailable = ExAv {
     exAvName    :: ExamplePkgName
   , exAvVersion :: ExamplePkgVersion
@@ -133,12 +141,12 @@ exDbPkgs = map (either exInstName exAvName)
 
 exAvSrcPkg :: ExampleAvailable -> SourcePackage
 exAvSrcPkg ex =
-    let (libraryDeps, testSuites) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
+    let (libraryDeps, testSuites, exts, mlang) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
     in SourcePackage {
            packageInfoId        = exAvPkgId ex
          , packageSource        = LocalTarballPackage "<<path>>"
          , packageDescrOverride = Nothing
-         , packageDescription   = C.GenericPackageDescription{
+         , packageDescription   = C.GenericPackageDescription {
                C.packageDescription = C.emptyPackageDescription {
                    C.package        = exAvPkgId ex
                  , C.library        = error "not yet configured: library"
@@ -152,26 +160,39 @@ exAvSrcPkg ex =
                  }
              , C.genPackageFlags = concatMap extractFlags
                                    (CD.libraryDeps (exAvDeps ex))
-             , C.condLibrary     = Just $ mkCondTree libraryDeps
+             , C.condLibrary     = Just $ mkCondTree (extsLib exts <> langLib mlang) libraryDeps
              , C.condExecutables = []
-             , C.condTestSuites  = map (\(t, deps) -> (t, mkCondTree deps))
+             , C.condTestSuites  = map (\(t, deps) -> (t, mkCondTree mempty deps))
                                    testSuites
              , C.condBenchmarks  = []
              }
          }
   where
+    -- Split the set of dependencies into the set of dependencies of the library,
+    -- the dependencies of the test suites and extensions.
     splitTopLevel :: [ExampleDependency]
                   -> ( [ExampleDependency]
                      , [(ExampleTestName, [ExampleDependency])]
+                     , [Extension]
+                     , Maybe Language
                      )
-    splitTopLevel []                = ([], [])
+    splitTopLevel [] =
+        ([], [], [], Nothing)
     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)
-
+      let (other, testSuites, exts, lang) = splitTopLevel deps
+      in (other, (t, a):testSuites, exts, lang)
+    splitTopLevel (ExExt ext:deps) =
+      let (other, testSuites, exts, lang) = splitTopLevel deps
+      in (other, testSuites, ext:exts, lang)
+    splitTopLevel (ExLang lang:deps) =
+        case splitTopLevel deps of
+            (other, testSuites, exts, Nothing) -> (other, testSuites, exts, Just lang)
+            _ -> error "Only 1 Language dependency is supported"
+    splitTopLevel (dep:deps) =
+      let (other, testSuites, exts, lang) = splitTopLevel deps
+      in (dep:other, testSuites, exts, lang)
+
+    -- Extract the total set of flags used
     extractFlags :: ExampleDependency -> [C.Flag]
     extractFlags (ExAny _)      = []
     extractFlags (ExFix _ _)    = []
@@ -183,13 +204,15 @@ exAvSrcPkg ex =
                                     }
                                 : concatMap extractFlags (a ++ b)
     extractFlags (ExTest _ a)   = concatMap extractFlags a
+    extractFlags (ExExt _)      = []
+    extractFlags (ExLang _)     = []
 
-    mkCondTree :: Monoid a => [ExampleDependency] -> DependencyTree a
-    mkCondTree deps =
+    mkCondTree :: Monoid a => a -> [ExampleDependency] -> DependencyTree a
+    mkCondTree x deps =
       let (directDeps, flaggedDeps) = splitDeps deps
       in C.CondNode {
-             C.condTreeData        = mempty -- irrelevant to the solver
-           , C.condTreeConstraints = map mkDirect  directDeps
+             C.condTreeData        = x -- Necessary for language extensions
+           , C.condTreeConstraints = map mkDirect directDeps
            , C.condTreeComponents  = map mkFlagged flaggedDeps
            }
 
@@ -204,10 +227,17 @@ exAvSrcPkg ex =
               -> (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)
+                          , mkCondTree mempty a
+                          , Just (mkCondTree mempty b)
                           )
 
+    -- Split a set of dependencies into direct dependencies and flagged
+    -- dependencies. A direct dependency is a tuple of the name of package and
+    -- maybe its version (no version means any version) meant to be converted
+    -- to a 'C.Dependency' with 'mkDirect' for example. A flagged dependency is
+    -- the set of dependencies guarded by a flag.
+    --
+    -- TODO: Take care of flagged language extensions and language flavours.
     splitDeps :: [ExampleDependency]
               -> ( [(ExamplePkgName, Maybe Int)]
                  , [(ExampleFlagName, [ExampleDependency], [ExampleDependency])]
@@ -225,12 +255,22 @@ exAvSrcPkg ex =
       in (directDeps, (f, a, b):flaggedDeps)
     splitDeps (ExTest _ _:_) =
       error "Unexpected nested test"
+    splitDeps (_:deps) = splitDeps deps
 
     -- Currently we only support simple setup dependencies
     mkSetupDeps :: [ExampleDependency] -> [C.Dependency]
     mkSetupDeps deps =
       let (directDeps, []) = splitDeps deps in map mkDirect directDeps
 
+    -- A 'C.Library' with just the given extensions in its 'BuildInfo'
+    extsLib :: [Extension] -> C.Library
+    extsLib es = mempty { C.libBuildInfo = mempty { C.otherExtensions = es } }
+
+    -- A 'C.Library' with just the given extensions in its 'BuildInfo'
+    langLib :: Maybe Language -> C.Library
+    langLib (Just lang) = mempty { C.libBuildInfo = mempty { C.defaultLanguage = Just lang } }
+    langLib _ = mempty
+
 exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
 exAvPkgId ex = C.PackageIdentifier {
       pkgName    = C.PackageName (exAvName ex)
@@ -258,15 +298,27 @@ exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex
 exInstIdx = C.PackageIndex.fromList . map exInstInfo
 
 exResolve :: ExampleDb
+          -- List of extensions supported by the compiler.
+          -> [Extension]
+          -- A compiler can support multiple languages.
+          -> [Language]
           -> [ExamplePkgName]
           -> Bool
           -> ([String], Either String CI.InstallPlan.InstallPlan)
-exResolve db targets indepGoals = runProgress $
+exResolve db exts langs targets indepGoals = runProgress $
     resolveDependencies C.buildPlatform
-                        (C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag)
+                        compiler
                         Modular
                         params
   where
+    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
+    compiler = defaultCompiler { C.compilerInfoExtensions = if null exts
+                                                               then Nothing
+                                                               else Just exts
+                               , C.compilerInfoLanguages  = if null langs
+                                                                then Nothing
+                                                                else Just langs
+                               }
     (inst, avai) = partitionEithers db
     instIdx      = exInstIdx inst
     avaiIdx      = SourcePackageDb {

cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs

@@ -13,6 +13,9 @@ import Test.Tasty as TF
 import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
 import Test.Tasty.Options
 
+-- Cabal
+import Language.Haskell.Extension (Extension(..), KnownExtension(..), Language(..))
+
 -- cabal-install
 import UnitTests.Distribution.Client.Dependency.Modular.DSL
 
@@ -67,6 +70,21 @@ tests = [
         , runTest $ mkTest db12 "baseShim5" ["D"] Nothing
         , runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])
         ]
+    , testGroup "Extensions" [
+          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing
+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] Nothing
+        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (Just [("A",1)])
+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (Just [("A",1),("B",1), ("C",1)])
+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] Nothing
+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] Nothing
+        , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (Just [("A",1),("B",1),("C",1),("E",1)])
+        ]
+    , testGroup "Languages" [
+          runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] Nothing
+        , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (Just [("A",1)])
+        , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] Nothing
+        , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (Just [("A",1),("B",1),("C",1)])
+        ]
     ]
   where
     indep test = test { testIndepGoals = True }
@@ -76,11 +94,13 @@ tests = [
 -------------------------------------------------------------------------------}
 
 data SolverTest = SolverTest {
-    testLabel      :: String
-  , testTargets    :: [String]
-  , testResult     :: Maybe [(String, Int)]
-  , testIndepGoals :: Bool
-  , testDb         :: ExampleDb
+    testLabel          :: String
+  , testTargets        :: [String]
+  , testResult         :: Maybe [(String, Int)]
+  , testIndepGoals     :: Bool
+  , testDb             :: ExampleDb
+  , testSupportedExts  :: [Extension]
+  , testSupportedLangs :: [Language]
   }
 
 mkTest :: ExampleDb
@@ -88,18 +108,45 @@ mkTest :: ExampleDb
        -> [String]
        -> Maybe [(String, Int)]
        -> SolverTest
-mkTest db label targets result = SolverTest {
-    testLabel      = label
-  , testTargets    = targets
-  , testResult     = result
-  , testIndepGoals = False
-  , testDb         = db
+mkTest = mkTestExtLang [] []
+
+mkTestExts :: [Extension]
+           -> ExampleDb
+           -> String
+           -> [String]
+           -> Maybe [(String, Int)]
+           -> SolverTest
+mkTestExts exts = mkTestExtLang exts []
+
+mkTestLangs :: [Language]
+            -> ExampleDb
+            -> String
+            -> [String]
+            -> Maybe [(String, Int)]
+            -> SolverTest
+mkTestLangs = mkTestExtLang []
+
+mkTestExtLang :: [Extension]
+              -> [Language]
+              -> ExampleDb
+              -> String
+              -> [String]
+              -> Maybe [(String, Int)]
+              -> SolverTest
+mkTestExtLang exts langs db label targets result = SolverTest {
+    testLabel          = label
+  , testTargets        = targets
+  , testResult         = result
+  , testIndepGoals     = False
+  , testDb             = db
+  , testSupportedExts  = exts
+  , testSupportedLangs = langs
   }
 
 runTest :: SolverTest -> TF.TestTree
 runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
     testCase testLabel $ do
-      let (_msgs, result) = exResolve testDb testTargets testIndepGoals
+      let (_msgs, result) = exResolve testDb testSupportedExts testSupportedLangs testTargets testIndepGoals
       when showSolverLog $ mapM_ putStrLn _msgs
       case result of
         Left  err  -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)
@@ -340,6 +387,23 @@ db12 =
     , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]
     ]
 
+dbExts1 :: ExampleDb
+dbExts1 = [
+    Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]
+  , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]
+  , Right $ exAv "C" 1 [ExAny "B"]
+  , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]
+  , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"]
+  ]
+
+dbLangs1 :: ExampleDb
+dbLangs1 = [
+    Right $ exAv "A" 1 [ExLang Haskell2010]
+  , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]
+  , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]
+  ]
+
+
 {-------------------------------------------------------------------------------
   Test options
 -------------------------------------------------------------------------------}