Commit 0c84eb36 authored by kristenk's avatar kristenk
Browse files

Add BooleanFlag type class

parent b4d86b68
......@@ -23,6 +23,7 @@ import Distribution.Client.Dependency.Modular.Package
import qualified Distribution.Client.Dependency.Modular.Preference as P
import Distribution.Client.Dependency.Modular.Validate
import Distribution.Client.Dependency.Modular.Linking
import Distribution.Client.Types (BooleanFlag(..))
-- | Various options for the modular solver.
data SolverConfig = SolverConfig {
......@@ -78,7 +79,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
buildPhase
where
explorePhase = backjumpAndExplore (enableBackjumping sc)
heuristicsPhase = (if unReorderGoals (preferEasyGoalChoices sc)
heuristicsPhase = (if asBool (preferEasyGoalChoices sc)
then P.preferEasyGoalChoices -- also leaves just one choice
else P.firstGoal) . -- after doing goal-choice heuristics, commit to the first choice (saves space)
P.deferWeakFlagChoices .
......@@ -91,7 +92,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
P.enforceSingleInstanceRestriction .
validateLinking idx .
validateTree cinfo idx pkgConfigDB
prunePhase = (if unAvoidReinstalls (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
prunePhase = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
-- packages that can never be "upgraded":
P.requireInstalled (`elem` [ PackageName "base"
, PackageName "ghc-prim"
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency.Types
......@@ -60,7 +61,8 @@ import Data.Monoid
import Distribution.Client.PkgConfigDb
( PkgConfigDb )
import Distribution.Client.Types
( OptionalStanza(..), SourcePackage(..), SolverPackage )
( BooleanFlag(..), OptionalStanza(..), SourcePackage(..)
, SolverPackage )
import qualified Distribution.Compat.ReadP as Parse
( pfail, munch1 )
......@@ -113,23 +115,23 @@ instance Text PreSolver where
"choose" -> return Choose
_ -> Parse.pfail
newtype ReorderGoals = ReorderGoals { unReorderGoals :: Bool }
deriving (Eq, Generic, Show)
newtype ReorderGoals = ReorderGoals Bool
deriving (BooleanFlag, Eq, Generic, Show)
newtype IndependentGoals = IndependentGoals { unIndependentGoals :: Bool }
deriving (Eq, Generic, Show)
newtype IndependentGoals = IndependentGoals Bool
deriving (BooleanFlag, Eq, Generic, Show)
newtype AvoidReinstalls = AvoidReinstalls { unAvoidReinstalls :: Bool }
deriving (Eq, Generic, Show)
newtype AvoidReinstalls = AvoidReinstalls Bool
deriving (BooleanFlag, Eq, Generic, Show)
newtype ShadowPkgs = ShadowPkgs { unShadowPkgs :: Bool }
deriving (Eq, Generic, Show)
newtype ShadowPkgs = ShadowPkgs Bool
deriving (BooleanFlag, Eq, Generic, Show)
newtype StrongFlags = StrongFlags { unStrongFlags :: Bool }
deriving (Eq, Generic, Show)
newtype StrongFlags = StrongFlags Bool
deriving (BooleanFlag, Eq, Generic, Show)
newtype EnableBackjumping = EnableBackjumping Bool
deriving Show
deriving (BooleanFlag, Eq, Generic, Show)
instance Binary ReorderGoals
instance Binary IndependentGoals
......
......@@ -55,7 +55,7 @@ module Distribution.Client.Setup
) where
import Distribution.Client.Types
( Username(..), Password(..), RemoteRepo(..) )
( BooleanFlag(..), Username(..), Password(..), RemoteRepo(..) )
import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
......@@ -1329,7 +1329,7 @@ installOptions showOrParseArgs =
, option [] ["avoid-reinstalls"]
"Do not select versions that would destructively overwrite installed packages."
(fmap unAvoidReinstalls . installAvoidReinstalls)
(fmap asBool . installAvoidReinstalls)
(\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v })
(yesNoOpt showOrParseArgs)
......@@ -2081,7 +2081,7 @@ optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip
(map show . flagToList))
, option [] ["reorder-goals"]
"Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."
(fmap unReorderGoals . getrg)
(fmap asBool . getrg)
(setrg . fmap ReorderGoals)
(yesNoOpt showOrParseArgs)
-- TODO: Disabled for now because it does not work as advertised (yet).
......@@ -2093,12 +2093,12 @@ 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."
(fmap unShadowPkgs . getsip)
(fmap asBool . getsip)
(setsip . fmap ShadowPkgs)
(yesNoOpt showOrParseArgs)
, option [] ["strong-flags"]
"Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."
(fmap unStrongFlags . getstrfl)
(fmap asBool . getstrfl)
(setstrfl . fmap StrongFlags)
(yesNoOpt showOrParseArgs)
]
......
......@@ -51,6 +51,13 @@ import Distribution.Compat.Binary (Binary(..))
newtype Username = Username { unUsername :: String }
newtype Password = Password { unPassword :: String }
-- | Types that represent boolean flags.
class BooleanFlag a where
asBool :: a -> Bool
instance BooleanFlag Bool where
asBool = id
-- | This is the information we get from a @00-index.tar.gz@ hackage index.
--
data SourcePackageDb = SourcePackageDb {
......
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