Add real tests for language extensions solving

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

See haskell#2732.

Author: jdnavarro

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

@@ -141,7 +141,7 @@ exDbPkgs = map (either exInstName exAvName)
 
 exAvSrcPkg :: ExampleAvailable -> SourcePackage
 exAvSrcPkg ex =
-    let (libraryDeps, testSuites) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
+    let (libraryDeps, testSuites, exts) = splitTopLevel (CD.libraryDeps (exAvDeps ex))
     in SourcePackage {
            packageInfoId        = exAvPkgId ex
          , packageSource        = LocalTarballPackage "<<path>>"
@@ -160,27 +160,31 @@ exAvSrcPkg ex =
                  }
              , C.genPackageFlags = concatMap extractFlags
                                    (CD.libraryDeps (exAvDeps ex))
-             , C.condLibrary     = Just $ mkCondTree libraryDeps
+             , C.condLibrary     = Just $ mkCondTree (extsLib exts) 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
-    -- and the dependencies of the test suites.
+    -- 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]
                      )
-    splitTopLevel []                = ([], [])
+    splitTopLevel []                = ([], [], [])
     splitTopLevel (ExTest t a:deps) =
-      let (other, testSuites) = splitTopLevel deps
-      in (other, (t, a):testSuites)
+      let (other, testSuites, exts) = splitTopLevel deps
+      in (other, (t, a):testSuites, exts)
+    splitTopLevel (ExExt ext:deps) =
+      let (other, testSuites, exts) = splitTopLevel deps
+      in (other, testSuites, ext:exts)
     splitTopLevel (dep:deps)        =
-      let (other, testSuites) = splitTopLevel deps
-      in (dep:other, testSuites)
+      let (other, testSuites, exts) = splitTopLevel deps
+      in (dep:other, testSuites, exts)
 
     -- Extract the total set of flags used
     extractFlags :: ExampleDependency -> [C.Flag]
@@ -197,11 +201,11 @@ exAvSrcPkg ex =
     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.condTreeData        = x -- Necessary for language extensions
            , C.condTreeConstraints = map mkDirect directDeps
            , C.condTreeComponents  = map mkFlagged flaggedDeps
            }
@@ -217,14 +221,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 the set of unconditional dependencies
-    -- and the set of dependencies guarded by a flag.
+    -- 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: Maybe Int indicates dependency on a particular package
+    -- TODO: Take care of flagged language extensions
     splitDeps :: [ExampleDependency]
               -> ( [(ExamplePkgName, Maybe Int)]
                  , [(ExampleFlagName, [ExampleDependency], [ExampleDependency])]
@@ -242,16 +249,18 @@ exAvSrcPkg ex =
       in (directDeps, (f, a, b):flaggedDeps)
     splitDeps (ExTest _ _:_) =
       error "Unexpected nested test"
-    splitDeps (ExExt _ext:deps) =
-      splitDeps deps
-    splitDeps (ExLang _lang:deps) =
-      splitDeps deps
+    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 } }
+
+
 exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
 exAvPkgId ex = C.PackageIdentifier {
       pkgName    = C.PackageName (exAvName ex)
@@ -279,15 +288,21 @@ exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex
 exInstIdx = C.PackageIndex.fromList . map exInstInfo
 
 exResolve :: ExampleDb
+          -- List of extensions supported by the compiler.
+          -> [Extension]
           -> [ExamplePkgName]
           -> Bool
           -> ([String], Either String CI.InstallPlan.InstallPlan)
-exResolve db targets indepGoals = runProgress $
+exResolve db exts targets indepGoals = runProgress $
     resolveDependencies C.buildPlatform
-                        (C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag)
+                        compiler
                         Modular
                         params
   where
+    defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
+    compiler = if null exts
+                   then defaultCompiler
+                   else defaultCompiler { C.compilerInfoExtensions = Just exts }
     (inst, avai) = partitionEithers db
     instIdx      = exInstIdx inst
     avaiIdx      = SourcePackageDb {

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

@@ -14,7 +14,7 @@ import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
 import Test.Tasty.Options
 
 -- Cabal
-import Language.Haskell.Extension -- (Extension(..), UnknownExtension, Language)
+import Language.Haskell.Extension (Extension(..), KnownExtension(..))
 
 -- cabal-install
 import UnitTests.Distribution.Client.Dependency.Modular.DSL
@@ -71,7 +71,13 @@ tests = [
         , runTest $ mkTest db12 "baseShim6" ["E"] (Just [("E", 1), ("syb", 2)])
         ]
     , testGroup "Extensions" [
-          runTest $ mkTest dbExt1 "unsupportedExtension" ["A"] Nothing
+          runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] Nothing
+        , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedTransitive" ["B"] Nothing
+        , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (Just [("A",1)])
+        , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedTransitive" ["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 "unknownExtension" ["E"] (Just [("A",1),("B",1),("C",1),("E",1)])
         ]
     ]
   where
@@ -82,30 +88,40 @@ 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]
   }
 
 mkTest :: ExampleDb
        -> String
        -> [String]
        -> Maybe [(String, Int)]
        -> SolverTest
-mkTest db label targets result = SolverTest {
-    testLabel      = label
-  , testTargets    = targets
-  , testResult     = result
-  , testIndepGoals = False
-  , testDb         = db
+mkTest = mkTestExts []
+
+mkTestExts :: [Extension]
+           -> ExampleDb
+           -> String
+           -> [String]
+           -> Maybe [(String, Int)]
+           -> SolverTest
+mkTestExts exts db label targets result = SolverTest {
+    testLabel         = label
+  , testTargets       = targets
+  , testResult        = result
+  , testIndepGoals    = False
+  , testDb            = db
+  , testSupportedExts = exts
   }
 
 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 testTargets testIndepGoals
       when showSolverLog $ mapM_ putStrLn _msgs
       case result of
         Left  err  -> assertBool ("Unexpected error:\n" ++ err) (isNothing testResult)
@@ -346,10 +362,13 @@ db12 =
     , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]
     ]
 
-
-dbExt1 :: ExampleDb
-dbExt1 = [
-    Right $ exAv "A" 1 [ExExt $ UnknownExtension "unknown"]
+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"]
   ]