Allow the solver to toggle manual flags to match constraints that have any qualifier.

cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs

@@ -14,16 +14,18 @@ module UnitTests.Distribution.Solver.Modular.DSL (
   , ExamplePkgVersion
   , ExamplePkgName
   , ExampleFlagName
+  , ExFlag(..)
   , ExampleAvailable(..)
   , ExampleInstalled(..)
   , ExampleQualifier(..)
   , ExampleVar(..)
   , 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

cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs

@@ -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

cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs

@@ -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

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

@@ -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 []