diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs index e505869b918..a5345fe7083 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/DSL.hs +++ b/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 "<>" , 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 { diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs index e5162b8e60d..e7692d41b7e 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/Solver.hs +++ b/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 -------------------------------------------------------------------------------}