{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.Flag (
    -- * Package flag
    PackageFlag(..),
    emptyFlag,
    -- * Flag name
    FlagName,
    mkFlagName,
    unFlagName,
    -- * Flag assignment
    FlagAssignment,
    mkFlagAssignment,
    unFlagAssignment,
    lookupFlagAssignment,
    insertFlagAssignment,
    diffFlagAssignment,
    findDuplicateFlagAssignments,
    nullFlagAssignment,
    showFlagValue,
    dispFlagAssignment,
    showFlagAssignment,
    parsecFlagAssignment,
    parsecFlagAssignmentNonEmpty,
    -- ** Legacy formats
    legacyShowFlagAssignment,
    legacyShowFlagAssignment',
    legacyParsecFlagAssignment,
    ) where

import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
import Distribution.Utils.Generic (lowercase)

import Distribution.Parsec
import Distribution.Pretty

import qualified Data.Map as Map
import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.CharParsing as P

-- -----------------------------------------------------------------------------
-- The Flag' type

-- | A flag can represent a feature to be included, or a way of linking
--   a target against its dependencies, or in fact whatever you can think of.
data PackageFlag = MkPackageFlag
    { PackageFlag -> FlagName
flagName        :: FlagName
    , PackageFlag -> String
flagDescription :: String
    , PackageFlag -> Bool
flagDefault     :: Bool
    , PackageFlag -> Bool
flagManual      :: Bool
    }
    deriving (Int -> PackageFlag -> ShowS
[PackageFlag] -> ShowS
PackageFlag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PackageFlag] -> ShowS
$cshowList :: [PackageFlag] -> ShowS
show :: PackageFlag -> String
$cshow :: PackageFlag -> String
showsPrec :: Int -> PackageFlag -> ShowS
$cshowsPrec :: Int -> PackageFlag -> ShowS
Show, PackageFlag -> PackageFlag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageFlag -> PackageFlag -> Bool
$c/= :: PackageFlag -> PackageFlag -> Bool
== :: PackageFlag -> PackageFlag -> Bool
$c== :: PackageFlag -> PackageFlag -> Bool
Eq, Typeable, Typeable PackageFlag
PackageFlag -> DataType
PackageFlag -> Constr
(forall b. Data b => b -> b) -> PackageFlag -> PackageFlag
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> PackageFlag -> u
forall u. (forall d. Data d => d -> u) -> PackageFlag -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PackageFlag -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PackageFlag -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PackageFlag
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PackageFlag -> c PackageFlag
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PackageFlag)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c PackageFlag)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> PackageFlag -> m PackageFlag
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PackageFlag -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> PackageFlag -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> PackageFlag -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> PackageFlag -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PackageFlag -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> PackageFlag -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PackageFlag -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> PackageFlag -> r
gmapT :: (forall b. Data b => b -> b) -> PackageFlag -> PackageFlag
$cgmapT :: (forall b. Data b => b -> b) -> PackageFlag -> PackageFlag
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c PackageFlag)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c PackageFlag)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PackageFlag)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c PackageFlag)
dataTypeOf :: PackageFlag -> DataType
$cdataTypeOf :: PackageFlag -> DataType
toConstr :: PackageFlag -> Constr
$ctoConstr :: PackageFlag -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PackageFlag
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c PackageFlag
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PackageFlag -> c PackageFlag
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> PackageFlag -> c PackageFlag
Data, forall x. Rep PackageFlag x -> PackageFlag
forall x. PackageFlag -> Rep PackageFlag x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PackageFlag x -> PackageFlag
$cfrom :: forall x. PackageFlag -> Rep PackageFlag x
Generic)

instance Binary PackageFlag
instance Structured PackageFlag
instance NFData PackageFlag where rnf :: PackageFlag -> ()
rnf = forall a. (Generic a, GNFData (Rep a)) => a -> ()
genericRnf

-- | A 'PackageFlag' initialized with default parameters.
emptyFlag :: FlagName -> PackageFlag
emptyFlag :: FlagName -> PackageFlag
emptyFlag FlagName
name = MkPackageFlag
    { flagName :: FlagName
flagName        = FlagName
name
    , flagDescription :: String
flagDescription = String
""
    , flagDefault :: Bool
flagDefault     = Bool
True
    , flagManual :: Bool
flagManual      = Bool
False
    }

-- | A 'FlagName' is the name of a user-defined configuration flag
--
-- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'.
--
-- This type is opaque since @Cabal-2.0@
--
-- @since 2.0.0.2
newtype FlagName = FlagName ShortText
    deriving (FlagName -> FlagName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FlagName -> FlagName -> Bool
$c/= :: FlagName -> FlagName -> Bool
== :: FlagName -> FlagName -> Bool
$c== :: FlagName -> FlagName -> Bool
Eq, forall x. Rep FlagName x -> FlagName
forall x. FlagName -> Rep FlagName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FlagName x -> FlagName
$cfrom :: forall x. FlagName -> Rep FlagName x
Generic, Eq FlagName
FlagName -> FlagName -> Bool
FlagName -> FlagName -> Ordering
FlagName -> FlagName -> FlagName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FlagName -> FlagName -> FlagName
$cmin :: FlagName -> FlagName -> FlagName
max :: FlagName -> FlagName -> FlagName
$cmax :: FlagName -> FlagName -> FlagName
>= :: FlagName -> FlagName -> Bool
$c>= :: FlagName -> FlagName -> Bool
> :: FlagName -> FlagName -> Bool
$c> :: FlagName -> FlagName -> Bool
<= :: FlagName -> FlagName -> Bool
$c<= :: FlagName -> FlagName -> Bool
< :: FlagName -> FlagName -> Bool
$c< :: FlagName -> FlagName -> Bool
compare :: FlagName -> FlagName -> Ordering
$ccompare :: FlagName -> FlagName -> Ordering
Ord, Int -> FlagName -> ShowS
[FlagName] -> ShowS
FlagName -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FlagName] -> ShowS
$cshowList :: [FlagName] -> ShowS
show :: FlagName -> String
$cshow :: FlagName -> String
showsPrec :: Int -> FlagName -> ShowS
$cshowsPrec :: Int -> FlagName -> ShowS
Show, ReadPrec [FlagName]
ReadPrec FlagName
Int -> ReadS FlagName
ReadS [FlagName]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [FlagName]
$creadListPrec :: ReadPrec [FlagName]
readPrec :: ReadPrec FlagName
$creadPrec :: ReadPrec FlagName
readList :: ReadS [FlagName]
$creadList :: ReadS [FlagName]
readsPrec :: Int -> ReadS FlagName
$creadsPrec :: Int -> ReadS FlagName
Read, Typeable, Typeable FlagName
FlagName -> DataType
FlagName -> Constr
(forall b. Data b => b -> b) -> FlagName -> FlagName
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> FlagName -> u
forall u. (forall d. Data d => d -> u) -> FlagName -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FlagName -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FlagName -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FlagName
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FlagName -> c FlagName
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FlagName)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c FlagName)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FlagName -> m FlagName
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> FlagName -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> FlagName -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> FlagName -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> FlagName -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FlagName -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> FlagName -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FlagName -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> FlagName -> r
gmapT :: (forall b. Data b => b -> b) -> FlagName -> FlagName
$cgmapT :: (forall b. Data b => b -> b) -> FlagName -> FlagName
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c FlagName)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c FlagName)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FlagName)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FlagName)
dataTypeOf :: FlagName -> DataType
$cdataTypeOf :: FlagName -> DataType
toConstr :: FlagName -> Constr
$ctoConstr :: FlagName -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FlagName
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FlagName
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FlagName -> c FlagName
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FlagName -> c FlagName
Data, FlagName -> ()
forall a. (a -> ()) -> NFData a
rnf :: FlagName -> ()
$crnf :: FlagName -> ()
NFData)

-- | Construct a 'FlagName' from a 'String'
--
-- 'mkFlagName' is the inverse to 'unFlagName'
--
-- Note: No validations are performed to ensure that the resulting
-- 'FlagName' is valid
--
-- @since 2.0.0.2
mkFlagName :: String -> FlagName
mkFlagName :: String -> FlagName
mkFlagName = ShortText -> FlagName
FlagName forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShortText
toShortText

-- | 'mkFlagName'
--
-- @since 2.0.0.2
instance IsString FlagName where
    fromString :: String -> FlagName
fromString = String -> FlagName
mkFlagName

-- | Convert 'FlagName' to 'String'
--
-- @since 2.0.0.2
unFlagName :: FlagName -> String
unFlagName :: FlagName -> String
unFlagName (FlagName ShortText
s) = ShortText -> String
fromShortText ShortText
s

instance Binary FlagName
instance Structured FlagName

instance Pretty FlagName where
    pretty :: FlagName -> Doc
pretty = String -> Doc
Disp.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> String
unFlagName

instance Parsec FlagName where
    -- Note:  we don't check that FlagName doesn't have leading dash,
    -- cabal check will do that.
    parsec :: forall (m :: * -> *). CabalParsing m => m FlagName
parsec = String -> FlagName
mkFlagName forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
lowercase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m String
parsec'
      where
        parsec' :: m String
parsec' = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Char
lead forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m String
rest
        lead :: m Char
lead = forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m Char
P.satisfy (\Char
c ->  Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_')
        rest :: m String
rest = forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
P.munch (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
||  Char
c forall a. Eq a => a -> a -> Bool
== Char
'_' Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'-')

-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
-- 'Bool' flag values. It represents the flags chosen by the user or
-- discovered during configuration. For example @--flags=foo --flags=-bar@
-- becomes @[("foo", True), ("bar", False)]@
--
-- TODO: Why we record the multiplicity of the flag?
--
newtype FlagAssignment
  = FlagAssignment { FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment :: Map.Map FlagName (Int, Bool) }
  deriving (Get FlagAssignment
[FlagAssignment] -> Put
FlagAssignment -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [FlagAssignment] -> Put
$cputList :: [FlagAssignment] -> Put
get :: Get FlagAssignment
$cget :: Get FlagAssignment
put :: FlagAssignment -> Put
$cput :: FlagAssignment -> Put
Binary, forall x. Rep FlagAssignment x -> FlagAssignment
forall x. FlagAssignment -> Rep FlagAssignment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FlagAssignment x -> FlagAssignment
$cfrom :: forall x. FlagAssignment -> Rep FlagAssignment x
Generic, FlagAssignment -> ()
forall a. (a -> ()) -> NFData a
rnf :: FlagAssignment -> ()
$crnf :: FlagAssignment -> ()
NFData, Typeable)

instance Structured FlagAssignment

instance Eq FlagAssignment where
  == :: FlagAssignment -> FlagAssignment -> Bool
(==) (FlagAssignment Map FlagName (Int, Bool)
m1) (FlagAssignment Map FlagName (Int, Bool)
m2)
    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Map FlagName (Int, Bool)
m1 forall a. Eq a => a -> a -> Bool
== forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Map FlagName (Int, Bool)
m2

instance Ord FlagAssignment where
  compare :: FlagAssignment -> FlagAssignment -> Ordering
compare (FlagAssignment Map FlagName (Int, Bool)
m1) (FlagAssignment Map FlagName (Int, Bool)
m2)
    = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Map FlagName (Int, Bool)
m1 forall a. Ord a => a -> a -> Ordering
`compare` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd Map FlagName (Int, Bool)
m2

-- | Combines pairs of values contained in the 'FlagAssignment' Map.
--
-- The last flag specified takes precedence, and we record the number
-- of times we have seen the flag.
--
combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool)
combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool)
combineFlagValues (Int
c1, Bool
_) (Int
c2, Bool
b2) = (Int
c1 forall a. Num a => a -> a -> a
+ Int
c2, Bool
b2)

-- The 'Semigroup' instance currently is right-biased.
--
-- If duplicate flags are specified, we want the last flag specified to
-- take precedence and we want to know how many times the flag has been
-- specified so that we have the option of warning the user about
-- supplying duplicate flags.
instance Semigroup FlagAssignment where
  <> :: FlagAssignment -> FlagAssignment -> FlagAssignment
(<>) (FlagAssignment Map FlagName (Int, Bool)
m1) (FlagAssignment Map FlagName (Int, Bool)
m2)
    = Map FlagName (Int, Bool) -> FlagAssignment
FlagAssignment (forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (Int, Bool) -> (Int, Bool) -> (Int, Bool)
combineFlagValues Map FlagName (Int, Bool)
m1 Map FlagName (Int, Bool)
m2)

instance Monoid FlagAssignment where
  mempty :: FlagAssignment
mempty = Map FlagName (Int, Bool) -> FlagAssignment
FlagAssignment forall k a. Map k a
Map.empty
  mappend :: FlagAssignment -> FlagAssignment -> FlagAssignment
mappend = forall a. Semigroup a => a -> a -> a
(<>)

-- | Construct a 'FlagAssignment' from a list of flag/value pairs.
--
-- If duplicate flags occur in the input list, the later entries
-- in the list will take precedence.
--
-- @since 2.2.0
mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment =
  Map FlagName (Int, Bool) -> FlagAssignment
FlagAssignment forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int, Bool) -> (Int, Bool) -> (Int, Bool)
combineFlagValues) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
b -> (Int
1, Bool
b)))

-- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs.
--
-- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @
--
-- @since 2.2.0
unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment

-- | Test whether 'FlagAssignment' is empty.
--
-- @since 2.2.0
nullFlagAssignment :: FlagAssignment -> Bool
nullFlagAssignment :: FlagAssignment -> Bool
nullFlagAssignment = forall k a. Map k a -> Bool
Map.null forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment

-- | Lookup the value for a flag
--
-- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'.
--
-- @since 2.2.0
lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool
lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool
lookupFlagAssignment FlagName
fn = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FlagName
fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment

-- | Insert or update the boolean value of a flag.
--
-- If the flag is already present in the 'FlagAssignment', the
-- value will be updated and the fact that multiple values have
-- been provided for that flag will be recorded so that a
-- warning can be generated later on.
--
-- @since 2.2.0
insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment
-- TODO: this currently just shadows prior values for an existing
-- flag; rather than enforcing uniqueness at construction, it's
-- verified later on via `D.C.Dependency.configuredPackageProblems`
insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment
insertFlagAssignment FlagName
flag Bool
val =
  Map FlagName (Int, Bool) -> FlagAssignment
FlagAssignment forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int, Bool) -> (Int, Bool) -> (Int, Bool)
combineFlagValues) FlagName
flag (Int
1, Bool
val) forall b c a. (b -> c) -> (a -> b) -> a -> c
.  FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment

-- | Remove all flag-assignments from the first 'FlagAssignment' that
-- are contained in the second 'FlagAssignment'
--
-- NB/TODO: This currently only removes flag assignments which also
-- match the value assignment! We should review the code which uses
-- this operation to figure out if this it's not enough to only
-- compare the flagnames without the values.
--
-- @since 2.2.0
diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment
diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment
diffFlagAssignment FlagAssignment
fa1 FlagAssignment
fa2 = Map FlagName (Int, Bool) -> FlagAssignment
FlagAssignment
  (forall k a b. Ord k => Map k a -> Map k b -> Map k a
Map.difference (FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment FlagAssignment
fa1) (FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment FlagAssignment
fa2))

-- | Find the 'FlagName's that have been listed more than once.
--
-- @since 2.2.0
findDuplicateFlagAssignments :: FlagAssignment -> [FlagName]
findDuplicateFlagAssignments :: FlagAssignment -> [FlagName]
findDuplicateFlagAssignments =
  forall k a. Map k a -> [k]
Map.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> Map FlagName (Int, Bool)
getFlagAssignment

-- | @since 2.2.0
instance Read FlagAssignment where
    readsPrec :: Int -> ReadS FlagAssignment
readsPrec Int
p String
s = [ (Map FlagName (Int, Bool) -> FlagAssignment
FlagAssignment Map FlagName (Int, Bool)
x, String
rest) | (Map FlagName (Int, Bool)
x,String
rest) <- forall a. Read a => Int -> ReadS a
readsPrec Int
p String
s ]

-- | @since 2.2.0
instance Show FlagAssignment where
    showsPrec :: Int -> FlagAssignment -> ShowS
showsPrec Int
p (FlagAssignment Map FlagName (Int, Bool)
xs) = forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Map FlagName (Int, Bool)
xs

-- | String representation of a flag-value pair.
showFlagValue :: (FlagName, Bool) -> String
showFlagValue :: (FlagName, Bool) -> String
showFlagValue (FlagName
f, Bool
True)   = Char
'+' forall a. a -> [a] -> [a]
: FlagName -> String
unFlagName FlagName
f
showFlagValue (FlagName
f, Bool
False)  = Char
'-' forall a. a -> [a] -> [a]
: FlagName -> String
unFlagName FlagName
f

-- | @since 3.4.0.0
instance Pretty FlagAssignment where
    pretty :: FlagAssignment -> Doc
pretty = FlagAssignment -> Doc
dispFlagAssignment

-- |
--
-- >>> simpleParsec "" :: Maybe FlagAssignment
-- Just (fromList [])
--
-- >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment
-- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))])
--
-- >>> simpleParsec "-none -any" :: Maybe FlagAssignment
-- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))])
--
-- >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment
-- Just (fromList [(FlagName "foo",(4,True))])
--
-- >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment
-- Nothing
--
-- Issue #7279 was fixed in Cabal-3.8
--
-- >>> explicitEitherParsec (parsecCommaList parsec) "+foo , -bar" :: Either String [FlagAssignment]
-- Right [fromList [(FlagName "foo",(1,True))],fromList [(FlagName "bar",(1,False))]]
--
-- >>> explicitEitherParsec (parsecCommaList parsecFlagAssignmentNonEmpty) "+foo , -bar" :: Either String [FlagAssignment]
-- Right [fromList [(FlagName "foo",(1,True))],fromList [(FlagName "bar",(1,False))]]
--
-- >>> simpleParsec "+foo+foo" :: Maybe FlagAssignment
-- Nothing
--
-- @since 3.4.0.0
--
instance Parsec FlagAssignment where
    parsec :: forall (m :: * -> *). CabalParsing m => m FlagAssignment
parsec = forall (m :: * -> *). CabalParsing m => m FlagAssignment
parsecFlagAssignment

-- | Pretty-prints a flag assignment.
dispFlagAssignment :: FlagAssignment -> Disp.Doc
dispFlagAssignment :: FlagAssignment -> Doc
dispFlagAssignment = [Doc] -> Doc
Disp.hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
Disp.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FlagName, Bool) -> String
showFlagValue) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment



-- | Parses a flag assignment.
parsecFlagAssignment :: CabalParsing m => m FlagAssignment
parsecFlagAssignment :: forall (m :: * -> *). CabalParsing m => m FlagAssignment
parsecFlagAssignment = [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b. CabalParsing m => m a -> m b -> m [a]
sepByEnding (m (FlagName, Bool)
onFlag forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (FlagName, Bool)
offFlag) forall (m :: * -> *). CharParsing m => m ()
P.skipSpaces1
  where
    onFlag :: m (FlagName, Bool)
onFlag = do
        Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'+'
        FlagName
f <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        forall (m :: * -> *) a. Monad m => a -> m a
return (FlagName
f, Bool
True)
    offFlag :: m (FlagName, Bool)
offFlag = do
        Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-'
        FlagName
f <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        forall (m :: * -> *) a. Monad m => a -> m a
return (FlagName
f, Bool
False)

    sepByEnding :: CabalParsing m => m a -> m b -> m [a]
    sepByEnding :: forall (m :: * -> *) a b. CabalParsing m => m a -> m b -> m [a]
sepByEnding m a
p m b
sep = m [a]
afterSeparator where
        element :: m [a]
element        = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [a]
afterElement
        afterElement :: m [a]
afterElement   = m b
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m [a]
afterSeparator forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        afterSeparator :: m [a]
afterSeparator = m [a]
element forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Parse a non-empty flag assignment
--
-- The flags have to explicitly start with minus or plus.
--
-- @since 3.4.0.0
parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment
parsecFlagAssignmentNonEmpty :: forall (m :: * -> *). CabalParsing m => m FlagAssignment
parsecFlagAssignmentNonEmpty = [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b. CabalParsing m => m a -> m b -> m [a]
sepByEnding1 (m (FlagName, Bool)
onFlag forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (FlagName, Bool)
offFlag) forall (m :: * -> *). CharParsing m => m ()
P.skipSpaces1
  where
    onFlag :: m (FlagName, Bool)
onFlag = do
        Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'+'
        FlagName
f <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        forall (m :: * -> *) a. Monad m => a -> m a
return (FlagName
f, Bool
True)
    offFlag :: m (FlagName, Bool)
offFlag = do
        Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-'
        FlagName
f <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        forall (m :: * -> *) a. Monad m => a -> m a
return (FlagName
f, Bool
False)

    sepByEnding1 :: CabalParsing m => m a -> m b -> m [a]
    sepByEnding1 :: forall (m :: * -> *) a b. CabalParsing m => m a -> m b -> m [a]
sepByEnding1 m a
p m b
sep = m [a]
element where
        element :: m [a]
element        = (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [a]
afterElement
        afterElement :: m [a]
afterElement   = m b
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> m [a]
afterSeparator forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
        afterSeparator :: m [a]
afterSeparator = m [a]
element forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | Show flag assignment.
--
-- @since 3.4.0.0
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment :: FlagAssignment -> String
showFlagAssignment = forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> Doc
dispFlagAssignment

-------------------------------------------------------------------------------
-- Legacy: without requiring +
-------------------------------------------------------------------------------

-- | We need this as far as we support custom setups older than 2.2.0.0
--
-- @since 3.4.0.0
legacyShowFlagAssignment :: FlagAssignment -> String
legacyShowFlagAssignment :: FlagAssignment -> String
legacyShowFlagAssignment =
    forall a. Pretty a => a -> String
prettyShow forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [Doc] -> Doc
Disp.hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
Disp.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> [String]
legacyShowFlagAssignment'

-- | @since 3.4.0.0
legacyShowFlagAssignment' :: FlagAssignment -> [String]
legacyShowFlagAssignment' :: FlagAssignment -> [String]
legacyShowFlagAssignment' = forall a b. (a -> b) -> [a] -> [b]
map (FlagName, Bool) -> String
legacyShowFlagValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagAssignment -> [(FlagName, Bool)]
unFlagAssignment

-- | @since 3.4.0.0
legacyShowFlagValue :: (FlagName, Bool) -> String
legacyShowFlagValue :: (FlagName, Bool) -> String
legacyShowFlagValue (FlagName
f, Bool
True)   =       FlagName -> String
unFlagName FlagName
f
legacyShowFlagValue (FlagName
f, Bool
False)  = Char
'-' forall a. a -> [a] -> [a]
: FlagName -> String
unFlagName FlagName
f

-- |
-- We need this as far as we support custom setups older than 2.2.0.0
--
-- @since 3.4.0.0
legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment
legacyParsecFlagAssignment :: forall (m :: * -> *). CabalParsing m => m FlagAssignment
legacyParsecFlagAssignment = [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                       forall (m :: * -> *) a sep. Alternative m => m a -> m sep -> m [a]
P.sepBy (m (FlagName, Bool)
onFlag forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> m (FlagName, Bool)
offFlag) forall (m :: * -> *). CharParsing m => m ()
P.skipSpaces1
  where
    onFlag :: m (FlagName, Bool)
onFlag = do
        Maybe Char
_ <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
P.optional (forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'+')
        FlagName
f <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        forall (m :: * -> *) a. Monad m => a -> m a
return (FlagName
f, Bool
True)
    offFlag :: m (FlagName, Bool)
offFlag = do
        Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'-'
        FlagName
f <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        forall (m :: * -> *) a. Monad m => a -> m a
return (FlagName
f, Bool
False)