Cabal-syntax/src/Distribution/Types/Flag.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   4
   5 module Distribution.Types.Flag
   6   ( -- * Package flag
   7     PackageFlag (..)
   8   , emptyFlag
   9
  10     -- * Flag name
  11   , FlagName
  12   , mkFlagName
  13   , unFlagName
  14
  15     -- * Flag assignment
  16   , FlagAssignment
  17   , mkFlagAssignment
  18   , unFlagAssignment
  19   , lookupFlagAssignment
  20   , insertFlagAssignment
  21   , diffFlagAssignment
  22   , findDuplicateFlagAssignments
  23   , nullFlagAssignment
  24   , showFlagValue
  25   , dispFlagAssignment
  26   , showFlagAssignment
  27   , parsecFlagAssignment
  28   , parsecFlagAssignmentNonEmpty
  29
  30     -- ** Legacy formats
  31   , legacyShowFlagAssignment
  32   , legacyShowFlagAssignment'
  33   , legacyParsecFlagAssignment
  34   ) where
  35
  36 import Distribution.Compat.Prelude
  37 import Distribution.Utils.Generic (lowercase)
  38 import Distribution.Utils.ShortText
  39 import Prelude ()
  40
  41 import Distribution.Parsec
  42 import Distribution.Pretty
  43
  44 import qualified Data.Map as Map
  45 import qualified Distribution.Compat.CharParsing as P
  46 import qualified Text.PrettyPrint as Disp
  47
  48 -- -----------------------------------------------------------------------------
  49 -- The Flag' type
  50
  51 -- | A flag can represent a feature to be included, or a way of linking
  52 --   a target against its dependencies, or in fact whatever you can think of.
  53 data PackageFlag = MkPackageFlag
  54   { flagName :: FlagName
  55   , flagDescription :: String
  56   , flagDefault :: Bool
  57   , flagManual :: Bool
  58   }
  59   deriving (Show, Eq, Typeable, Data, Generic)
  60
  61 instance Binary PackageFlag
  62 instance Structured PackageFlag
  63 instance NFData PackageFlag where rnf = genericRnf
  64
  65 -- | A 'PackageFlag' initialized with default parameters.
  66 emptyFlag :: FlagName -> PackageFlag
  67 emptyFlag name =
  68   MkPackageFlag
  69     { flagName = name
  70     , flagDescription = ""
  71     , flagDefault = True
  72     , flagManual = False
  73     }
  74
  75 -- | A 'FlagName' is the name of a user-defined configuration flag
  76 --
  77 -- Use 'mkFlagName' and 'unFlagName' to convert from/to a 'String'.
  78 --
  79 -- This type is opaque since @Cabal-2.0@
  80 --
  81 -- @since 2.0.0.2
  82 newtype FlagName = FlagName ShortText
  83   deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData)
  84
  85 -- | Construct a 'FlagName' from a 'String'
  86 --
  87 -- 'mkFlagName' is the inverse to 'unFlagName'
  88 --
  89 -- Note: No validations are performed to ensure that the resulting
  90 -- 'FlagName' is valid
  91 --
  92 -- @since 2.0.0.2
  93 mkFlagName :: String -> FlagName
  94 mkFlagName = FlagName . toShortText
  95
  96 -- | 'mkFlagName'
  97 --
  98 -- @since 2.0.0.2
  99 instance IsString FlagName where
 100   fromString = mkFlagName
 101
 102 -- | Convert 'FlagName' to 'String'
 103 --
 104 -- @since 2.0.0.2
 105 unFlagName :: FlagName -> String
 106 unFlagName (FlagName s) = fromShortText s
 107
 108 instance Binary FlagName
 109 instance Structured FlagName
 110
 111 instance Pretty FlagName where
 112   pretty = Disp.text . unFlagName
 113
 114 instance Parsec FlagName where
 115   -- Note:  we don't check that FlagName doesn't have leading dash,
 116   -- cabal check will do that.
 117   parsec = mkFlagName . lowercase <$> parsec'
 118     where
 119       parsec' = (:) <$> lead <*> rest
 120       lead = P.satisfy (\c -> isAlphaNum c || c == '_')
 121       rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')
 122
 123 -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
 124 -- 'Bool' flag values. It represents the flags chosen by the user or
 125 -- discovered during configuration. For example @--flags=foo --flags=-bar@
 126 -- becomes @[("foo", True), ("bar", False)]@
 127 --
 128 -- TODO: Why we record the multiplicity of the flag?
 129 newtype FlagAssignment = FlagAssignment {getFlagAssignment :: Map.Map FlagName (Int, Bool)}
 130   deriving (Binary, Generic, NFData, Typeable)
 131
 132 instance Structured FlagAssignment
 133
 134 instance Eq FlagAssignment where
 135   (==) (FlagAssignment m1) (FlagAssignment m2) =
 136     fmap snd m1 == fmap snd m2
 137
 138 instance Ord FlagAssignment where
 139   compare (FlagAssignment m1) (FlagAssignment m2) =
 140     fmap snd m1 `compare` fmap snd m2
 141
 142 -- | Combines pairs of values contained in the 'FlagAssignment' Map.
 143 --
 144 -- The last flag specified takes precedence, and we record the number
 145 -- of times we have seen the flag.
 146 combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool)
 147 combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2)
 148
 149 -- The 'Semigroup' instance currently is right-biased.
 150 --
 151 -- If duplicate flags are specified, we want the last flag specified to
 152 -- take precedence and we want to know how many times the flag has been
 153 -- specified so that we have the option of warning the user about
 154 -- supplying duplicate flags.
 155 instance Semigroup FlagAssignment where
 156   (<>) (FlagAssignment m1) (FlagAssignment m2) =
 157     FlagAssignment (Map.unionWith combineFlagValues m1 m2)
 158
 159 instance Monoid FlagAssignment where
 160   mempty = FlagAssignment Map.empty
 161   mappend = (<>)
 162
 163 -- | Construct a 'FlagAssignment' from a list of flag/value pairs.
 164 --
 165 -- If duplicate flags occur in the input list, the later entries
 166 -- in the list will take precedence.
 167 --
 168 -- @since 2.2.0
 169 mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment
 170 mkFlagAssignment =
 171   FlagAssignment
 172     . Map.fromListWith (flip combineFlagValues)
 173     . fmap (fmap (\b -> (1, b)))
 174
 175 -- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs.
 176 --
 177 -- @ 'null' ('findDuplicateFlagAssignments' fa) ==> ('mkFlagAssignment' . 'unFlagAssignment') fa == fa @
 178 --
 179 -- @since 2.2.0
 180 unFlagAssignment :: FlagAssignment -> [(FlagName, Bool)]
 181 unFlagAssignment = fmap (fmap snd) . Map.toList . getFlagAssignment
 182
 183 -- | Test whether 'FlagAssignment' is empty.
 184 --
 185 -- @since 2.2.0
 186 nullFlagAssignment :: FlagAssignment -> Bool
 187 nullFlagAssignment = Map.null . getFlagAssignment
 188
 189 -- | Lookup the value for a flag
 190 --
 191 -- Returns 'Nothing' if the flag isn't contained in the 'FlagAssignment'.
 192 --
 193 -- @since 2.2.0
 194 lookupFlagAssignment :: FlagName -> FlagAssignment -> Maybe Bool
 195 lookupFlagAssignment fn = fmap snd . Map.lookup fn . getFlagAssignment
 196
 197 -- | Insert or update the boolean value of a flag.
 198 --
 199 -- If the flag is already present in the 'FlagAssignment', the
 200 -- value will be updated and the fact that multiple values have
 201 -- been provided for that flag will be recorded so that a
 202 -- warning can be generated later on.
 203 --
 204 -- @since 2.2.0
 205 insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment
 206 -- TODO: this currently just shadows prior values for an existing
 207 -- flag; rather than enforcing uniqueness at construction, it's
 208 -- verified later on via `D.C.Dependency.configuredPackageProblems`
 209 insertFlagAssignment flag val =
 210   FlagAssignment
 211     . Map.insertWith (flip combineFlagValues) flag (1, val)
 212     . getFlagAssignment
 213
 214 -- | Remove all flag-assignments from the first 'FlagAssignment' that
 215 -- are contained in the second 'FlagAssignment'
 216 --
 217 -- NB/TODO: This currently only removes flag assignments which also
 218 -- match the value assignment! We should review the code which uses
 219 -- this operation to figure out if this it's not enough to only
 220 -- compare the flagnames without the values.
 221 --
 222 -- @since 2.2.0
 223 diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment
 224 diffFlagAssignment fa1 fa2 =
 225   FlagAssignment
 226     (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2))
 227
 228 -- | Find the 'FlagName's that have been listed more than once.
 229 --
 230 -- @since 2.2.0
 231 findDuplicateFlagAssignments :: FlagAssignment -> [FlagName]
 232 findDuplicateFlagAssignments =
 233   Map.keys . Map.filter ((> 1) . fst) . getFlagAssignment
 234
 235 -- | @since 2.2.0
 236 instance Read FlagAssignment where
 237   readsPrec p s = [(FlagAssignment x, rest) | (x, rest) <- readsPrec p s]
 238
 239 -- | @since 2.2.0
 240 instance Show FlagAssignment where
 241   showsPrec p (FlagAssignment xs) = showsPrec p xs
 242
 243 -- | String representation of a flag-value pair.
 244 showFlagValue :: (FlagName, Bool) -> String
 245 showFlagValue (f, True) = '+' : unFlagName f
 246 showFlagValue (f, False) = '-' : unFlagName f
 247
 248 -- | @since 3.4.0.0
 249 instance Pretty FlagAssignment where
 250   pretty = dispFlagAssignment
 251
 252 -- |
 253 --
 254 -- >>> simpleParsec "" :: Maybe FlagAssignment
 255 -- Just (fromList [])
 256 --
 257 -- >>> simpleParsec "+foo -bar" :: Maybe FlagAssignment
 258 -- Just (fromList [(FlagName "bar",(1,False)),(FlagName "foo",(1,True))])
 259 --
 260 -- >>> simpleParsec "-none -any" :: Maybe FlagAssignment
 261 -- Just (fromList [(FlagName "any",(1,False)),(FlagName "none",(1,False))])
 262 --
 263 -- >>> simpleParsec "+foo -foo +foo +foo" :: Maybe FlagAssignment
 264 -- Just (fromList [(FlagName "foo",(4,True))])
 265 --
 266 -- >>> simpleParsec "+foo -bar baz" :: Maybe FlagAssignment
 267 -- Nothing
 268 --
 269 -- Issue #7279 was fixed in Cabal-3.8
 270 --
 271 -- >>> explicitEitherParsec (parsecCommaList parsec) "+foo , -bar" :: Either String [FlagAssignment]
 272 -- Right [fromList [(FlagName "foo",(1,True))],fromList [(FlagName "bar",(1,False))]]
 273 --
 274 -- >>> explicitEitherParsec (parsecCommaList parsecFlagAssignmentNonEmpty) "+foo , -bar" :: Either String [FlagAssignment]
 275 -- Right [fromList [(FlagName "foo",(1,True))],fromList [(FlagName "bar",(1,False))]]
 276 --
 277 -- >>> simpleParsec "+foo+foo" :: Maybe FlagAssignment
 278 -- Nothing
 279 --
 280 -- @since 3.4.0.0
 281 instance Parsec FlagAssignment where
 282   parsec = parsecFlagAssignment
 283
 284 -- | Pretty-prints a flag assignment.
 285 dispFlagAssignment :: FlagAssignment -> Disp.Doc
 286 dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment
 287
 288 -- | Parses a flag assignment.
 289 parsecFlagAssignment :: CabalParsing m => m FlagAssignment
 290 parsecFlagAssignment = mkFlagAssignment <$> sepByEnding (onFlag <|> offFlag) P.skipSpaces1
 291   where
 292     onFlag = do
 293       _ <- P.char '+'
 294       f <- parsec
 295       return (f, True)
 296     offFlag = do
 297       _ <- P.char '-'
 298       f <- parsec
 299       return (f, False)
 300
 301     sepByEnding :: CabalParsing m => m a -> m b -> m [a]
 302     sepByEnding p sep = afterSeparator
 303       where
 304         element = (:) <$> p <*> afterElement
 305         afterElement = sep *> afterSeparator <|> pure []
 306         afterSeparator = element <|> pure []
 307
 308 -- | Parse a non-empty flag assignment
 309 --
 310 -- The flags have to explicitly start with minus or plus.
 311 --
 312 -- @since 3.4.0.0
 313 parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment
 314 parsecFlagAssignmentNonEmpty = mkFlagAssignment <$> sepByEnding1 (onFlag <|> offFlag) P.skipSpaces1
 315   where
 316     onFlag = do
 317       _ <- P.char '+'
 318       f <- parsec
 319       return (f, True)
 320     offFlag = do
 321       _ <- P.char '-'
 322       f <- parsec
 323       return (f, False)
 324
 325     sepByEnding1 :: CabalParsing m => m a -> m b -> m [a]
 326     sepByEnding1 p sep = element
 327       where
 328         element = (:) <$> p <*> afterElement
 329         afterElement = sep *> afterSeparator <|> pure []
 330         afterSeparator = element <|> pure []
 331
 332 -- | Show flag assignment.
 333 --
 334 -- @since 3.4.0.0
 335 showFlagAssignment :: FlagAssignment -> String
 336 showFlagAssignment = prettyShow . dispFlagAssignment
 337
 338 -------------------------------------------------------------------------------
 339 -- Legacy: without requiring +
 340 -------------------------------------------------------------------------------
 341
 342 -- | We need this as far as we support custom setups older than 2.2.0.0
 343 --
 344 -- @since 3.4.0.0
 345 legacyShowFlagAssignment :: FlagAssignment -> String
 346 legacyShowFlagAssignment =
 347   prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment'
 348
 349 -- | @since 3.4.0.0
 350 legacyShowFlagAssignment' :: FlagAssignment -> [String]
 351 legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment
 352
 353 -- | @since 3.4.0.0
 354 legacyShowFlagValue :: (FlagName, Bool) -> String
 355 legacyShowFlagValue (f, True) = unFlagName f
 356 legacyShowFlagValue (f, False) = '-' : unFlagName f
 357
 358 -- |
 359 -- We need this as far as we support custom setups older than 2.2.0.0
 360 --
 361 -- @since 3.4.0.0
 362 legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment
 363 legacyParsecFlagAssignment =
 364   mkFlagAssignment
 365     <$> P.sepBy (onFlag <|> offFlag) P.skipSpaces1
 366   where
 367     onFlag = do
 368       _ <- P.optional (P.char '+')
 369       f <- parsec
 370       return (f, True)
 371     offFlag = do
 372       _ <- P.char '-'
 373       f <- parsec
 374       return (f, False)