Cabal/src/Distribution/Simple/Flag.hs

   1 {-# LANGUAGE DeriveFoldable #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE DeriveTraversable #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5
   6 -----------------------------------------------------------------------------
   7
   8 -- |
   9 -- Module      :  Distribution.Simple.Flag
  10 -- Copyright   :  Isaac Jones 2003-2004
  11 --                Duncan Coutts 2007
  12 -- License     :  BSD3
  13 --
  14 -- Maintainer  :  cabal-devel@haskell.org
  15 -- Portability :  portable
  16 --
  17 -- Defines the 'Flag' type and it's 'Monoid' instance,  see
  18 -- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>
  19 -- for an explanation.
  20 --
  21 -- Split off from "Distribution.Simple.Setup" to break import cycles.
  22 module Distribution.Simple.Flag
  23   ( Flag (..)
  24   , allFlags
  25   , toFlag
  26   , fromFlag
  27   , fromFlagOrDefault
  28   , flagElim
  29   , flagToMaybe
  30   , flagToList
  31   , maybeToFlag
  32   , mergeListFlag
  33   , BooleanFlag (..)
  34   ) where
  35
  36 import Distribution.Compat.Prelude hiding (get)
  37 import Distribution.Compat.Stack
  38 import Prelude ()
  39
  40 -- ------------------------------------------------------------
  41
  42 -- * Flag type
  43
  44 -- ------------------------------------------------------------
  45
  46 -- | All flags are monoids, they come in two flavours:
  47 --
  48 -- 1. list flags eg
  49 --
  50 --   > --ghc-option=foo --ghc-option=bar
  51 --
  52 --   gives us all the values ["foo", "bar"]
  53 --
  54 -- 2. singular value flags, eg:
  55 --
  56 --   > --enable-foo --disable-foo
  57 --
  58 --   gives us Just False
  59 --
  60 -- So, this 'Flag' type is for the latter singular kind of flag.
  61 -- Its monoid instance gives us the behaviour where it starts out as
  62 -- 'NoFlag' and later flags override earlier ones.
  63 --
  64 -- Isomorphic to 'Maybe' a.
  65 data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable, Foldable, Traversable)
  66
  67 instance Binary a => Binary (Flag a)
  68 instance Structured a => Structured (Flag a)
  69
  70 instance Functor Flag where
  71   fmap f (Flag x) = Flag (f x)
  72   fmap _ NoFlag = NoFlag
  73
  74 instance Applicative Flag where
  75   (Flag x) <*> y = x <$> y
  76   NoFlag <*> _ = NoFlag
  77   pure = Flag
  78
  79 instance Monoid (Flag a) where
  80   mempty = NoFlag
  81   mappend = (<>)
  82
  83 instance Semigroup (Flag a) where
  84   _ <> f@(Flag _) = f
  85   f <> NoFlag = f
  86
  87 instance Bounded a => Bounded (Flag a) where
  88   minBound = toFlag minBound
  89   maxBound = toFlag maxBound
  90
  91 instance Enum a => Enum (Flag a) where
  92   fromEnum = fromEnum . fromFlag
  93   toEnum = toFlag . toEnum
  94   enumFrom (Flag a) = map toFlag . enumFrom $ a
  95   enumFrom _ = []
  96   enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b
  97   enumFromThen _ _ = []
  98   enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b
  99   enumFromTo _ _ = []
 100   enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c
 101   enumFromThenTo _ _ _ = []
 102
 103 -- | Wraps a value in 'Flag'.
 104 toFlag :: a -> Flag a
 105 toFlag = Flag
 106
 107 -- | Extracts a value from a 'Flag', and throws an exception on 'NoFlag'.
 108 fromFlag :: WithCallStack (Flag a -> a)
 109 fromFlag (Flag x) = x
 110 fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault"
 111
 112 -- | Extracts a value from a 'Flag', and returns the default value on 'NoFlag'.
 113 fromFlagOrDefault :: a -> Flag a -> a
 114 fromFlagOrDefault _ (Flag x) = x
 115 fromFlagOrDefault def NoFlag = def
 116
 117 -- | Converts a 'Flag' value to a 'Maybe' value.
 118 flagToMaybe :: Flag a -> Maybe a
 119 flagToMaybe (Flag x) = Just x
 120 flagToMaybe NoFlag = Nothing
 121
 122 -- | Pushes a function through a 'Flag' value, and returns a default
 123 -- if the 'Flag' value is 'NoFlag'.
 124 --
 125 -- @since 3.4.0.0
 126 flagElim :: b -> (a -> b) -> Flag a -> b
 127 flagElim n _ NoFlag = n
 128 flagElim _ f (Flag x) = f x
 129
 130 -- | Converts a 'Flag' value to a list.
 131 flagToList :: Flag a -> [a]
 132 flagToList (Flag x) = [x]
 133 flagToList NoFlag = []
 134
 135 -- | Returns 'True' only if every 'Flag' 'Bool' value is Flag True, else 'False'.
 136 allFlags :: [Flag Bool] -> Flag Bool
 137 allFlags flags =
 138   if all (\f -> fromFlagOrDefault False f) flags
 139     then Flag True
 140     else NoFlag
 141
 142 -- | Converts a 'Maybe' value to a 'Flag' value.
 143 maybeToFlag :: Maybe a -> Flag a
 144 maybeToFlag Nothing = NoFlag
 145 maybeToFlag (Just x) = Flag x
 146
 147 -- | Merge the elements of a list 'Flag' with another list 'Flag'.
 148 mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a]
 149 mergeListFlag currentFlags v =
 150   Flag $ concat (flagToList currentFlags ++ flagToList v)
 151
 152 -- | Types that represent boolean flags.
 153 class BooleanFlag a where
 154   asBool :: a -> Bool
 155
 156 instance BooleanFlag Bool where
 157   asBool = id