Distribution/Simple/Flag.hs

    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE DeriveGeneric #-}
    {-# LANGUAGE FlexibleContexts #-}
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Distribution.Simple.Flag
    -- Copyright   :  Isaac Jones 2003-2004
    --                Duncan Coutts 2007
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- Defines the 'Flag' type and it's 'Monoid' instance,  see
    -- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>
    -- for an explanation.
    --
    -- Split off from "Distribution.Simple.Setup" to break import cycles.
    module Distribution.Simple.Flag (
      Flag(..),
      allFlags,
      toFlag,
      fromFlag,
      fromFlagOrDefault,
      flagElim,
      flagToMaybe,
      flagToList,
      maybeToFlag,
      BooleanFlag(..) ) where

    import Prelude ()
    import Distribution.Compat.Prelude hiding (get)
    import Distribution.Compat.Stack

    -- ------------------------------------------------------------
    -- * Flag type
    -- ------------------------------------------------------------

    -- | All flags are monoids, they come in two flavours:
    --
    -- 1. list flags eg
    --
    -- > --ghc-option=foo --ghc-option=bar
    --
    -- gives us all the values ["foo", "bar"]
    --
    -- 2. singular value flags, eg:
    --
    -- > --enable-foo --disable-foo
    --
    -- gives us Just False
    -- So this Flag type is for the latter singular kind of flag.
    -- Its monoid instance gives us the behaviour where it starts out as
    -- 'NoFlag' and later flags override earlier ones.
    --
    data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable)

    instance Binary a => Binary (Flag a)
    instance Structured a => Structured (Flag a)

    instance Functor Flag where
      fmap f (Flag x) = Flag (f x)
      fmap _ NoFlag  = NoFlag

    instance Applicative Flag where
      (Flag x) <*> y = x <$> y
      NoFlag   <*> _ = NoFlag
      pure = Flag

    instance Monoid (Flag a) where
      mempty = NoFlag
      mappend = (<>)

    instance Semigroup (Flag a) where
      _ <> f@(Flag _) = f
      f <> NoFlag     = f

    instance Bounded a => Bounded (Flag a) where
      minBound = toFlag minBound
      maxBound = toFlag maxBound

    instance Enum a => Enum (Flag a) where
      fromEnum = fromEnum . fromFlag
      toEnum   = toFlag   . toEnum
      enumFrom (Flag a) = map toFlag . enumFrom $ a
      enumFrom _        = []
      enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b
      enumFromThen _        _        = []
      enumFromTo   (Flag a) (Flag b) = toFlag `map` enumFromTo a b
      enumFromTo   _        _        = []
      enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c
      enumFromThenTo _        _        _        = []

    toFlag :: a -> Flag a
    toFlag = Flag

    fromFlag :: WithCallStack (Flag a -> a)
    fromFlag (Flag x) = x
    fromFlag NoFlag   = error "fromFlag NoFlag. Use fromFlagOrDefault"

    fromFlagOrDefault :: a -> Flag a -> a
    fromFlagOrDefault _   (Flag x) = x
    fromFlagOrDefault def NoFlag   = def

    flagToMaybe :: Flag a -> Maybe a
    flagToMaybe (Flag x) = Just x
    flagToMaybe NoFlag   = Nothing

    -- | @since 3.4.0.0
    flagElim :: b -> (a -> b) -> Flag a -> b
    flagElim n _ NoFlag   = n
    flagElim _ f (Flag x) = f x

    flagToList :: Flag a -> [a]
    flagToList (Flag x) = [x]
    flagToList NoFlag   = []

    allFlags :: [Flag Bool] -> Flag Bool
    allFlags flags = if all (\f -> fromFlagOrDefault False f) flags
                     then Flag True
                     else NoFlag

    maybeToFlag :: Maybe a -> Flag a
    maybeToFlag Nothing  = NoFlag
    maybeToFlag (Just x) = Flag x

    -- | Types that represent boolean flags.
    class BooleanFlag a where
        asBool :: a -> Bool

    instance BooleanFlag Bool where
      asBool = id