Commit c170de48 authored by bardur.arantsson's avatar bardur.arantsson
Browse files

Merge pull request #2873 from jdnavarro/lang-extensions

Tests for solver support language extensions and language flavours
parents f217c479 1f40772a
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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
}
......@@ -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 {
......
......@@ -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