Commit 0cc27c1f authored by kristenk's avatar kristenk Committed by Mikhail Glushenkov
Browse files

Add manual flags to the solver DSL.

Tests can now declare flags before using them, in order to specify non-default
values for the fields in 'D.Types.GenericPackageDescription.Flag'.
parent f7f63ab4
......@@ -14,6 +14,7 @@ module UnitTests.Distribution.Solver.Modular.DSL (
, ExamplePkgVersion
, ExamplePkgName
, ExampleFlagName
, ExFlag(..)
, ExampleAvailable(..)
, ExampleInstalled(..)
, ExampleQualifier(..)
......@@ -21,9 +22,10 @@ module UnitTests.Distribution.Solver.Modular.DSL (
, EnableAllTests(..)
, exAv
, exInst
, exFlag
, exFlagged
, exResolve
, extractInstallPlan
, declareFlags
, withSetupDeps
, withTest
, withTests
......@@ -72,6 +74,7 @@ import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan
import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Flag
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex
......@@ -154,7 +157,7 @@ data ExampleDependency =
| ExBuildToolFix ExamplePkgName ExamplePkgVersion
-- | Dependencies indexed by a flag
| ExFlag ExampleFlagName Dependencies Dependencies
| ExFlagged ExampleFlagName Dependencies Dependencies
-- | Dependency on a language extension
| ExExt Extension
......@@ -166,16 +169,23 @@ data ExampleDependency =
| ExPkg (ExamplePkgName, ExamplePkgVersion)
deriving Show
data ExFlag = ExFlag {
exFlagName :: ExampleFlagName
, exFlagDefault :: Bool
, exFlagType :: FlagType
} deriving Show
data ExTest = ExTest ExampleTestName [ExampleDependency]
data ExExe = ExExe ExampleExeName [ExampleDependency]
exFlag :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
-> ExampleDependency
exFlag n t e = ExFlag n (Buildable t) (Buildable e)
exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
-> ExampleDependency
exFlagged n t e = ExFlagged n (Buildable t) (Buildable e)
data ExConstraint =
ExConstraint ConstraintScope ExampleVersionRange
ExVersionConstraint ConstraintScope ExampleVersionRange
| ExFlagConstraint ConstraintScope ExampleFlagName Bool
data ExPreference =
ExPkgPref ExamplePkgName ExampleVersionRange
......@@ -185,6 +195,10 @@ data ExampleAvailable = ExAv {
exAvName :: ExamplePkgName
, exAvVersion :: ExamplePkgVersion
, exAvDeps :: ComponentDeps [ExampleDependency]
-- Setting flags here is only necessary to override the default values of
-- the fields in C.Flag.
, exAvFlags :: [ExFlag]
} deriving Show
data ExampleVar =
......@@ -214,7 +228,14 @@ newtype EnableAllTests = EnableAllTests Bool
exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]
-> ExampleAvailable
exAv n v ds = ExAv { exAvName = n, exAvVersion = v
, exAvDeps = CD.fromLibraryDeps ds }
, exAvDeps = CD.fromLibraryDeps ds, exAvFlags = [] }
-- | Override the default settings (e.g., manual vs. automatic) for a subset of
-- a package's flags.
declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable
declareFlags flags ex = ex {
exAvFlags = flags
}
withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable
withSetupDeps ex setupDeps = ex {
......@@ -276,6 +297,25 @@ exDbPkgs = map (either exInstName exAvName)
exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage
exAvSrcPkg ex =
let pkgId = exAvPkgId ex
flags :: [C.Flag]
flags =
let declaredFlags :: Map ExampleFlagName C.Flag
declaredFlags =
Map.fromListWith
(\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2])
[(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex]
usedFlags :: Map ExampleFlagName C.Flag
usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]
where
names = concatMap extractFlags $
CD.libraryDeps (exAvDeps ex)
++ concatMap snd testSuites
++ concatMap snd executables
in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:
Map.elems $ declaredFlags `Map.union` usedFlags
testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]
setup = case CD.setupDeps (exAvDeps ex) of
......@@ -303,10 +343,7 @@ exAvSrcPkg ex =
, C.licenseFiles = ["LICENSE"]
, C.specVersionRaw = Left $ C.mkVersion [1,12]
}
, C.genPackageFlags = nub $ concatMap extractFlags $
CD.libraryDeps (exAvDeps ex)
++ concatMap snd testSuites
++ concatMap snd executables
, C.genPackageFlags = flags
, C.condLibrary =
let mkLib bi = mempty { C.libBuildInfo = bi }
in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $
......@@ -382,19 +419,14 @@ exAvSrcPkg ex =
in (dep:other, exts, lang, pcpkgs, exes)
-- Extract the total set of flags used
extractFlags :: ExampleDependency -> [C.Flag]
extractFlags :: ExampleDependency -> [ExampleFlagName]
extractFlags (ExAny _) = []
extractFlags (ExFix _ _) = []
extractFlags (ExRange _ _ _) = []
extractFlags (ExBuildToolAny _) = []
extractFlags (ExBuildToolFix _ _) = []
extractFlags (ExFlag f a b) = C.MkFlag {
C.flagName = C.mkFlagName f
, C.flagDescription = ""
, C.flagDefault = True
, C.flagManual = False
}
: concatMap extractFlags (deps a ++ deps b)
extractFlags (ExFlagged f a b) =
f : concatMap extractFlags (deps a ++ deps b)
where
deps :: Dependencies -> [ExampleDependency]
deps NotBuildable = []
......@@ -485,7 +517,7 @@ exAvSrcPkg ex =
splitDeps (ExRange p v1 v2:deps) =
let (directDeps, flaggedDeps) = splitDeps deps
in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps)
splitDeps (ExFlag f a b:deps) =
splitDeps (ExFlagged f a b:deps) =
let (directDeps, flaggedDeps) = splitDeps deps
in (directDeps, (f, a, b):flaggedDeps)
splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep
......@@ -503,6 +535,25 @@ mkVersionRange v1 v2 =
C.intersectVersionRanges (C.orLaterVersion $ mkVersion v1)
(C.earlierVersion $ mkVersion v2)
mkFlag :: ExFlag -> C.Flag
mkFlag flag = C.MkFlag {
C.flagName = C.mkFlagName $ exFlagName flag
, C.flagDescription = ""
, C.flagDefault = exFlagDefault flag
, C.flagManual =
case exFlagType flag of
Manual -> True
Automatic -> False
}
mkDefaultFlag :: ExampleFlagName -> C.Flag
mkDefaultFlag flag = C.MkFlag {
C.flagName = C.mkFlagName flag
, C.flagDescription = ""
, C.flagDefault = True
, C.flagManual = False
}
exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
exAvPkgId ex = C.PackageIdentifier {
pkgName = C.mkPackageName (exAvName ex)
......@@ -579,8 +630,10 @@ exResolve db exts langs pkgConfigDb targets solver mbj indepGoals reorder
$ standardInstallPolicy instIdx avaiIdx targets'
toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
toConstraint (ExConstraint scope v) =
toConstraint (ExVersionConstraint scope v) =
toLpc $ PackageConstraint scope (PackagePropertyVersion v)
toConstraint (ExFlagConstraint scope fn b) =
toLpc $ PackageConstraint scope (PackagePropertyFlags [(C.mkFlagName fn, b)])
toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v
toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas
......
......@@ -46,10 +46,10 @@ flagsTest name =
pkgs :: ExampleDb
pkgs = [Right $ exAv "pkg" 1 $
[exFlag (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]]
[exFlagged (flagName n) [ExAny "unknown1"] [ExAny "unknown2"]]
-- The remaining flags have no effect:
++ [exFlag (flagName i) [] [] | i <- [1..n - 1]]
++ [exFlagged (flagName i) [] [] | i <- [1..n - 1]]
]
flagName :: Int -> ExampleFlagName
......
......@@ -216,7 +216,7 @@ instance Arbitrary TestDb where
arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable
arbitraryExAv pn v db =
ExAv (unPN pn) (unPV v) <$> arbitraryComponentDeps db
(\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps db
arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled
arbitraryExInst pn v pkgs = do
......@@ -259,9 +259,9 @@ data ExDepLocation = SetupDep | NonSetupDep
arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
arbitraryExDep db@(TestDb pkgs) level =
let flag = ExFlag <$> arbitraryFlagName
<*> arbitraryDeps db
<*> arbitraryDeps db
let flag = ExFlagged <$> arbitraryFlagName
<*> arbitraryDeps db
<*> arbitraryDeps db
other =
-- Package checks require dependencies on "base" to have bounds.
let notBase = filter ((/= PN "base") . getName) pkgs
......@@ -341,10 +341,10 @@ instance Arbitrary ExampleDependency where
shrink (ExAny _) = []
shrink (ExFix "base" _) = [] -- preserve bounds on base
shrink (ExFix pn _) = [ExAny pn]
shrink (ExFlag flag th el) =
shrink (ExFlagged flag th el) =
deps th ++ deps el
++ [ExFlag flag th' el | th' <- shrink th]
++ [ExFlag flag th el' | el' <- shrink el]
++ [ExFlagged flag th' el | th' <- shrink th]
++ [ExFlagged flag th el' | el' <- shrink el]
where
deps NotBuildable = []
deps (Buildable ds) = ds
......
......@@ -116,19 +116,19 @@ tests = [
runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $
solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)]
, let cs = [ ExConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ]
, let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ]
in runTest $ constraints cs $
mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $
solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)]
, let cs = [ ExConstraint (ScopeQualified QualToplevel "D") $ mkVersionRange 1 4
, ExConstraint (ScopeQualified (QualSetup "B") "D") $ mkVersionRange 4 7
, let cs = [ ExVersionConstraint (ScopeQualified QualToplevel "D") $ mkVersionRange 1 4
, ExVersionConstraint (ScopeQualified (QualSetup "B") "D") $ mkVersionRange 4 7
]
in runTest $ constraints cs $
mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $
solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)]
, let cs = [ ExConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ]
, let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ]
in runTest $ constraints cs $
mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $
solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)]
......@@ -264,7 +264,7 @@ db3 :: ExampleDb
db3 = [
Right $ exAv "A" 1 []
, Right $ exAv "A" 2 []
, Right $ exAv "B" 1 [exFlag "flagB" [ExFix "A" 1] [ExFix "A" 2]]
, Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]]
, Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]
, Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]
]
......@@ -307,7 +307,7 @@ db4 = [
, Right $ exAv "Ax" 2 []
, Right $ exAv "Ay" 1 []
, Right $ exAv "Ay" 2 []
, Right $ exAv "B" 1 [exFlag "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]
, Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]
, Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"]
, Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"]
]
......@@ -533,7 +533,7 @@ db14 :: ExampleDb
db14 = [
Right $ exAv "A" 1 [ExAny "B"]
, Right $ exAv "B" 1 [ExAny "A"]
, Right $ exAv "C" 1 [exFlag "flagC" [ExAny "D"] [ExAny "E"]]
, Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]]
, Right $ exAv "D" 1 [ExAny "C"]
, Right $ exAv "E" 1 []
]
......@@ -615,9 +615,9 @@ db16 :: ExampleDb
db16 = [
Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
, Right $ exAv "B" 1 [ ExFix "D" 2
, exFlag "flagA"
, exFlagged "flagA"
[ExAny "C"]
[exFlag "flagB"
[exFlagged "flagB"
[ExAny "E"]
[ExAny "C"]]]
, Right $ exAv "C" 1 [ExAny "D"]
......@@ -682,9 +682,9 @@ db18 :: ExampleDb
db18 = [
Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
, Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2]
, Right $ exAv "C" 1 [exFlag "flagA"
, Right $ exAv "C" 1 [exFlagged "flagA"
[ExFix "D" 1, ExAny "E"]
[exFlag "flagB"
[exFlagged "flagB"
[ExAny "F"]
[ExFix "D" 2, ExAny "G"]]]
, Right $ exAv "D" 1 []
......@@ -923,12 +923,12 @@ testBuildable testName unavailableDep =
where
expected = solverSuccess [("false-dep", 1), ("pkg", 1)]
db = [
Right $ exAv "pkg" 1 [exFlag "enable-exe"
Right $ exAv "pkg" 1 [exFlagged "enable-exe"
[ExAny "true-dep"]
[ExAny "false-dep"]]
`withExe`
ExExe "exe" [ unavailableDep
, ExFlag "enable-exe" (Buildable []) NotBuildable ]
, ExFlagged "enable-exe" (Buildable []) NotBuildable ]
, Right $ exAv "true-dep" 1 []
, Right $ exAv "false-dep" 1 []
]
......@@ -938,18 +938,18 @@ testBuildable testName unavailableDep =
dbBuildable1 :: ExampleDb
dbBuildable1 = [
Right $ exAv "pkg" 1
[ exFlag "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]
, exFlag "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]
[ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]
, exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]
`withExes`
[ ExExe "exe1"
[ ExAny "unknown"
, ExFlag "flag1" (Buildable []) NotBuildable
, ExFlag "flag2" (Buildable []) NotBuildable]
, ExFlagged "flag1" (Buildable []) NotBuildable
, ExFlagged "flag2" (Buildable []) NotBuildable]
, ExExe "exe2"
[ ExAny "unknown"
, ExFlag "flag1"
, ExFlagged "flag1"
(Buildable [])
(Buildable [ExFlag "flag2" NotBuildable (Buildable [])])]
(Buildable [ExFlagged "flag2" NotBuildable (Buildable [])])]
]
, Right $ exAv "flag1-true" 1 []
, Right $ exAv "flag1-false" 1 []
......@@ -966,7 +966,7 @@ dbBuildable2 = [
`withExe`
ExExe "exe"
[ ExAny "unknown"
, ExFlag "disable-exe" NotBuildable (Buildable [])
, ExFlagged "disable-exe" NotBuildable (Buildable [])
]
, Right $ exAv "B" 3 [ExAny "unknown"]
]
......@@ -1044,7 +1044,7 @@ dbBJ4 = [
-- bug report (#3409)
dbBJ5 :: ExampleDb
dbBJ5 = [
Right $ exAv "A" 1 [exFlag "flagA" [ExFix "B" 1] [ExFix "C" 1]]
Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]]
, Right $ exAv "B" 1 [ExFix "D" 1]
, Right $ exAv "C" 1 [ExFix "D" 2]
, Right $ exAv "D" 1 []
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment