Configurable strong/weak flags.

This adds a mechanism in the modular solver to store whether a flag
is "strong" or "weak". A weak flag is deferred during solving, a strong
flag is not.

By default, flags are now weak unless they're manual. This is a change
in behaviour, but I think it's probably the better default, because many
automatic flags are used to figure out what's on the system rather than
to impose hard constraints.

There's a new flag --strong-flags that restores the old behaviour. I do
not think such a global flag is particularly useful, but it may be
of interest to compare build plans between the new and old behaviour.

With these preparations, it's easy to make the distinction between
strong and weak flags more sophisticated. We can either add more
heuristics as to when flags should be treated as strong or weak, or we
can add syntax to .cabal files that allows package authors to specify
explicitly how they intend a flag to behave.

This is related to various cabal-install issues, e.g. #1831, #1864,
and #1877.

(cherry picked from commit 3dcddea)

Conflicts:
	cabal-install/Distribution/Client/Dependency.hs
	cabal-install/Distribution/Client/Freeze.hs
	cabal-install/Distribution/Client/Setup.hs

cabal-install/Distribution/Client/Dependency.hs

@@ -50,6 +50,7 @@ module Distribution.Client.Dependency (
     setIndependentGoals,
     setAvoidReinstalls,
     setShadowPkgs,
+    setStrongFlags,
     setMaxBackjumps,
     addSourcePackages,
     hideInstalledPackagesSpecificByInstalledPackageId,
@@ -119,6 +120,7 @@ data DepResolverParams = DepResolverParams {
        depResolverIndependentGoals  :: Bool,
        depResolverAvoidReinstalls   :: Bool,
        depResolverShadowPkgs        :: Bool,
+       depResolverStrongFlags       :: Bool,
        depResolverMaxBackjumps      :: Maybe Int
      }
 
@@ -152,6 +154,7 @@ basicDepResolverParams installedPkgIndex sourcePkgIndex =
        depResolverIndependentGoals  = False,
        depResolverAvoidReinstalls   = False,
        depResolverShadowPkgs        = False,
+       depResolverStrongFlags       = False,
        depResolverMaxBackjumps      = Nothing
      }
 
@@ -209,6 +212,12 @@ setShadowPkgs b params =
       depResolverShadowPkgs = b
     }
 
+setStrongFlags :: Bool -> DepResolverParams -> DepResolverParams
+setStrongFlags b params =
+    params {
+      depResolverStrongFlags = b
+    }
+
 setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
 setMaxBackjumps n params =
     params {
@@ -399,7 +408,7 @@ resolveDependencies platform comp  solver params =
 
     fmap (mkInstallPlan platform comp)
   $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls
-                      shadowing maxBkjumps)
+                      shadowing strFlags maxBkjumps)
                      platform comp installedPkgIndex sourcePkgIndex
                      preferences constraints targets
   where
@@ -412,7 +421,8 @@ resolveDependencies platform comp  solver params =
       indGoals
       noReinstalls
       shadowing
-      maxBkjumps      = dontUpgradeBasePackage
+      strFlags
+      maxBkjumps      = dontUpgradeNonUpgradeablePackages
                       -- TODO:
                       -- The modular solver can properly deal with broken
                       -- packages and won't select them. So the
@@ -495,7 +505,7 @@ resolveWithoutDependencies :: DepResolverParams
 resolveWithoutDependencies (DepResolverParams targets constraints
                               prefs defpref installedPkgIndex sourcePkgIndex
                               _reorderGoals _indGoals _avoidReinstalls
-                              _shadowing _maxBjumps) =
+                              _shadowing _strFlags _maxBjumps) =
     collectEithers (map selectPackage targets)
   where
     selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage

cabal-install/Distribution/Client/Dependency/Modular.hs

@@ -41,7 +41,7 @@ modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns =
   solve sc idx pprefs gcs pns
     where
       -- Indices have to be converted into solver-specific uniform index.
-      idx    = convPIs os arch cid (shadowPkgs sc) iidx sidx
+      idx    = convPIs os arch cid (shadowPkgs sc) (strongFlags sc) iidx sidx
       -- Constraints have to be converted into a finite map indexed by PN.
       gcs    = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs)
 

cabal-install/Distribution/Client/Dependency/Modular/Builder.hs

@@ -127,8 +127,8 @@ build = ana go
     -- that is indicated by the flag default.
     --
     -- TODO: Should we include the flag default in the tree?
-    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m) t f) gr) }) =
-      FChoiceF qfn (gr, sc) trivial m (P.fromList (reorder b
+    go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) (FInfo b m w) t f) gr) }) =
+      FChoiceF qfn (gr, sc) (w || trivial) m (P.fromList (reorder b
         [(True,  (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True  : gr)) t) bs) { next = Goals }),
          (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })]))
       where

cabal-install/Distribution/Client/Dependency/Modular/Flag.hs

@@ -25,9 +25,10 @@ type Flag = FlagName
 unFlag :: Flag -> String
 unFlag (FlagName fn) = fn
 
--- | Flag info. Default value, and whether the flag is manual.
--- Manual flags can only be set explicitly.
-data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool }
+-- | Flag info. Default value, whether the flag is manual, and
+-- whether the flag is weak. Manual flags can only be set explicitly.
+-- Weak flags are typically deferred by the solver.
+data FInfo = FInfo { fdefault :: Bool, fmanual :: Bool, fweak :: Bool }
   deriving (Eq, Ord, Show)
 
 -- | Flag defaults.

cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs

@@ -32,10 +32,10 @@ import Distribution.Client.Dependency.Modular.Version
 -- resolving these situations. However, the right thing to do is to
 -- fix the problem there, so for now, shadowing is only activated if
 -- explicitly requested.
-convPIs :: OS -> Arch -> CompilerId -> Bool ->
+convPIs :: OS -> Arch -> CompilerId -> Bool -> Bool ->
            SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index
-convPIs os arch cid sip iidx sidx =
-  mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx)
+convPIs os arch cid sip strfl iidx sidx =
+  mkIndex (convIPI' sip iidx ++ convSPI' os arch cid strfl sidx)
 
 -- | Convert a Cabal installed package index to the simpler,
 -- more uniform index format of the solver.
@@ -82,19 +82,19 @@ convIPId pn' idx ipid =
 
 -- | Convert a cabal-install source package index to the simpler,
 -- more uniform index format of the solver.
-convSPI' :: OS -> Arch -> CompilerId ->
+convSPI' :: OS -> Arch -> CompilerId -> Bool ->
             CI.PackageIndex SourcePackage -> [(PN, I, PInfo)]
-convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages
+convSPI' os arch cid strfl = L.map (convSP os arch cid strfl) . CI.allPackages
 
-convSPI :: OS -> Arch -> CompilerId ->
+convSPI :: OS -> Arch -> CompilerId -> Bool ->
            CI.PackageIndex SourcePackage -> Index
-convSPI os arch cid = mkIndex . convSPI' os arch cid
+convSPI os arch cid strfl = mkIndex . convSPI' os arch cid strfl
 
 -- | Convert a single source package into the solver-specific format.
-convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo)
-convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
+convSP :: OS -> Arch -> CompilerId -> Bool -> SourcePackage -> (PN, I, PInfo)
+convSP os arch cid strfl (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
   let i = I pv InRepo
-  in  (pn, i, convGPD os arch cid (PI pn i) gpd)
+  in  (pn, i, convGPD os arch cid strfl (PI pn i) gpd)
 
 -- We do not use 'flattenPackageDescription' or 'finalizePackageDescription'
 -- from 'Distribution.PackageDescription.Configuration' here, because we
@@ -104,12 +104,12 @@ convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
 --
 -- TODO: We currently just take all dependencies from all specified library,
 -- executable and test components. This does not quite seem fair.
-convGPD :: OS -> Arch -> CompilerId ->
+convGPD :: OS -> Arch -> CompilerId -> Bool ->
            PI PN -> GenericPackageDescription -> PInfo
-convGPD os arch cid pi
+convGPD os arch cid strfl pi
         (GenericPackageDescription _ flags libs exes tests benchs) =
   let
-    fds = flagInfo flags
+    fds = flagInfo strfl flags
   in
     PInfo
       (maybe []    (convCondTree os arch cid pi fds (const True)          ) libs    ++
@@ -126,9 +126,10 @@ prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDep
 prefix _ []  = []
 prefix f fds = [f (concat fds)]
 
--- | Convert flag information.
-flagInfo :: [PD.Flag] -> FlagInfo
-flagInfo = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m))
+-- | Convert flag information. Automatic flags are now considered weak
+-- unless strong flags have been selected explicitly.
+flagInfo :: Bool -> [PD.Flag] -> FlagInfo
+flagInfo strfl = M.fromList . L.map (\ (MkFlag fn _ b m) -> (fn, FInfo b m (not (strfl || m))))
 
 -- | Convert condition trees to flagged dependencies.
 convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagInfo ->

cabal-install/Distribution/Client/Dependency/Modular/Preference.hs

@@ -241,25 +241,19 @@ preferEasyGoalChoices = trav go
     go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs)
     go x                = x
 
--- | Transformation that tries to avoid making flag choices early.
-deferFlagChoices :: (Bool -> Bool) -> Tree a -> Tree a
-deferFlagChoices f = trav go
+-- | Transformation that tries to avoid making weak flag choices early.
+-- Weak flags are trivial flags (not influencing dependencies) or such
+-- flags that are explicitly declared to be weak in the index.
+deferWeakFlagChoices :: Tree a -> Tree a
+deferWeakFlagChoices = trav go
   where
     go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs)
     go x                = x
 
     defer :: Tree a -> Tree a -> Ordering
-    defer (FChoice _ _ b _ _) _ | f b = GT
-    defer _ (FChoice _ _ b _ _) | f b = LT
-    defer _ _                         = EQ
-
--- | Avoid trivial flag choices early in the process.
-deferTrivialFlagChoices :: Tree a -> Tree a
-deferTrivialFlagChoices = deferFlagChoices id
-
--- | Avoid all flag choices as long as possible.
-deferAllFlagChoices :: Tree a -> Tree a
-deferAllFlagChoices = deferFlagChoices (const True)
+    defer (FChoice _ _ True _ _) _ = GT
+    defer _ (FChoice _ _ True _ _) = LT
+    defer _ _                      = EQ
 
 -- | Variant of 'preferEasyGoalChoices'.
 --

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

@@ -21,6 +21,7 @@ data SolverConfig = SolverConfig {
   independentGoals      :: Bool,
   avoidReinstalls       :: Bool,
   shadowPkgs            :: Bool,
+  strongFlags           :: Bool,
   maxBackjumps          :: Maybe Int
 }
 
@@ -40,10 +41,11 @@ solve sc idx userPrefs userConstraints userGoals =
   where
     explorePhase     = exploreTreeLog . backjump
     heuristicsPhase  = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)
-                       P.deferAllFlagChoices .
+                       P.deferWeakFlagChoices .
+                       P.preferBaseGoalChoice .
                        if preferEasyGoalChoices sc
-                         then P.preferBaseGoalChoice . P.lpreferEasyGoalChoices
-                         else P.preferBaseGoalChoice
+                         then P.lpreferEasyGoalChoices
+                         else id
     preferencesPhase = P.preferPackagePreferences userPrefs
     validationPhase  = P.enforceManualFlags . -- can only be done after user constraints
                        P.enforcePackageConstraints userConstraints .

cabal-install/Distribution/Client/Dependency/Modular/Tree.hs

@@ -15,7 +15,7 @@ import Distribution.Client.Dependency.Modular.Version
 -- | Type of the search tree. Inlining the choice nodes for now.
 data Tree a =
     PChoice     QPN a           (PSQ I        (Tree a))
-  | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial, second Bool whether it's manual
+  | FChoice     QFN a Bool Bool (PSQ Bool     (Tree a)) -- Bool indicates whether it's weak/trivial, second Bool whether it's manual
   | SChoice     QSN a Bool      (PSQ Bool     (Tree a)) -- Bool indicates whether it's trivial
   | GoalChoice                  (PSQ OpenGoal (Tree a)) -- PSQ should never be empty
   | Done        RevDepMap
@@ -24,6 +24,11 @@ data Tree a =
   -- Above, a choice is called trivial if it clearly does not matter. The
   -- special case of triviality we actually consider is if there are no new
   -- dependencies introduced by this node.
+  --
+  -- A (flag) choice is called weak if we do want to defer it. This is the
+  -- case for flags that should be implied by what's currently installed on
+  -- the system, as opposed to flags that are used to explicitly enable or
+  -- disable some functionality.
 
 instance Functor Tree where
   fmap  f (PChoice qpn i     xs) = PChoice qpn (f i)     (fmap (fmap f) xs)

cabal-install/Distribution/Client/Fetch.hs

@@ -154,6 +154,8 @@ planPackages verbosity comp platform fetchFlags
 
       . setShadowPkgs shadowPkgs
 
+      . setStrongFlags strongFlags
+
         -- Reinstall the targets given on the command line so that the dep
         -- resolver will decide that they need fetching, even if they're
         -- already installed. Since we want to get the source packages of
@@ -168,6 +170,7 @@ planPackages verbosity comp platform fetchFlags
     reorderGoals     = fromFlag (fetchReorderGoals     fetchFlags)
     independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
     shadowPkgs       = fromFlag (fetchShadowPkgs       fetchFlags)
+    strongFlags      = fromFlag (fetchStrongFlags      fetchFlags)
     maxBackjumps     = fromFlag (fetchMaxBackjumps     fetchFlags)
 
 

cabal-install/Distribution/Client/Install.hs

@@ -319,6 +319,8 @@ planPackages comp platform mSandboxPkgInfo solver
 
       . setShadowPkgs shadowPkgs
 
+      . setStrongFlags strongFlags
+
       . setPreferenceDefault (if upgradeDeps then PreferAllLatest
                                              else PreferLatestForSelected)
 
@@ -362,6 +364,7 @@ planPackages comp platform mSandboxPkgInfo solver
     independentGoals = fromFlag (installIndependentGoals installFlags)
     avoidReinstalls  = fromFlag (installAvoidReinstalls  installFlags)
     shadowPkgs       = fromFlag (installShadowPkgs       installFlags)
+    strongFlags      = fromFlag (installStrongFlags      installFlags)
     maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)
     upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)
     onlyDeps         = fromFlag (installOnlyDeps         installFlags)

cabal-install/Distribution/Client/Setup.hs

@@ -437,6 +437,7 @@ data FetchFlags = FetchFlags {
       fetchReorderGoals     :: Flag Bool,
       fetchIndependentGoals :: Flag Bool,
       fetchShadowPkgs       :: Flag Bool,
+      fetchStrongFlags      :: Flag Bool,
       fetchVerbosity :: Flag Verbosity
     }
 
@@ -450,6 +451,7 @@ defaultFetchFlags = FetchFlags {
     fetchReorderGoals     = Flag False,
     fetchIndependentGoals = Flag False,
     fetchShadowPkgs       = Flag False,
+    fetchStrongFlags      = Flag False,
     fetchVerbosity = toFlag normal
    }
 
@@ -491,6 +493,7 @@ fetchCommand = CommandUI {
                          fetchReorderGoals     (\v flags -> flags { fetchReorderGoals     = v })
                          fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
                          fetchShadowPkgs       (\v flags -> flags { fetchShadowPkgs       = v })
+                         fetchStrongFlags      (\v flags -> flags { fetchStrongFlags      = v })
 
   }
 
@@ -784,6 +787,7 @@ data InstallFlags = InstallFlags {
     installReorderGoals     :: Flag Bool,
     installIndependentGoals :: Flag Bool,
     installShadowPkgs       :: Flag Bool,
+    installStrongFlags      :: Flag Bool,
     installReinstall        :: Flag Bool,
     installAvoidReinstalls  :: Flag Bool,
     installOverrideReinstall :: Flag Bool,
@@ -808,6 +812,7 @@ defaultInstallFlags = InstallFlags {
     installReorderGoals    = Flag False,
     installIndependentGoals= Flag False,
     installShadowPkgs      = Flag False,
+    installStrongFlags     = Flag False,
     installReinstall       = Flag False,
     installAvoidReinstalls = Flag False,
     installOverrideReinstall = Flag False,
@@ -909,7 +914,8 @@ installOptions showOrParseArgs =
                         installMaxBackjumps     (\v flags -> flags { installMaxBackjumps     = v })
                         installReorderGoals     (\v flags -> flags { installReorderGoals     = v })
                         installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
-                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v }) ++
+                        installShadowPkgs       (\v flags -> flags { installShadowPkgs       = v })
+                        installStrongFlags      (\v flags -> flags { installStrongFlags      = v }) ++
 
       [ option [] ["reinstall"]
           "Install even if it means installing the same version again."
@@ -1004,6 +1010,7 @@ instance Monoid InstallFlags where
     installReorderGoals    = mempty,
     installIndependentGoals= mempty,
     installShadowPkgs      = mempty,
+    installStrongFlags     = mempty,
     installOnly            = mempty,
     installOnlyDeps        = mempty,
     installRootCmd         = mempty,
@@ -1026,6 +1033,7 @@ instance Monoid InstallFlags where
     installReorderGoals    = combine installReorderGoals,
     installIndependentGoals= combine installIndependentGoals,
     installShadowPkgs      = combine installShadowPkgs,
+    installStrongFlags     = combine installStrongFlags,
     installOnly            = combine installOnly,
     installOnlyDeps        = combine installOnlyDeps,
     installRootCmd         = combine installRootCmd,
@@ -1479,8 +1487,9 @@ optionSolverFlags :: ShowOrParseArgs
                   -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)
                   -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)
                   -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)
+                  -> (flags -> Flag Bool  ) -> (Flag Bool   -> flags -> flags)
                   -> [OptionField flags]
-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip =
+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip getstrfl setstrfl =
   [ option [] ["max-backjumps"]
       ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")
       getmbj setmbj
@@ -1501,7 +1510,11 @@ optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip
   , option [] ["shadow-installed-packages"]
       "If multiple package instances of the same version are installed, treat all but one as shadowed."
       getsip setsip
-      trueArg
+      (yesNoOpt showOrParseArgs)
+  , option [] ["strong-flags"]
+      "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."
+      getstrfl setstrfl
+      (yesNoOpt showOrParseArgs)
   ]