{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable,
             ExistentialQuantification, GADTs,
             FlexibleInstances, UndecidableInstances,
             TypeOperators #-}
-- | Extensible options. They are used for provider-specific settings,
-- ingredient-specific settings and core settings (such as the test name pattern).
module Test.Tasty.Options
  (
    -- * IsOption class
    IsOption(..)
    -- * Option sets and operations
  , OptionSet
  , setOption
  , changeOption
  , lookupOption
  , singleOption
  , OptionDescription(..)
    -- * Utilities
  , flagCLParser
  , mkFlagCLParser
  , mkOptionCLParser
  , safeRead
  , safeReadBool
  ) where

import qualified Data.Map as Map
import Data.Map (Map)
import Data.Char (toLower)
import Data.Tagged
import Data.Proxy
import Data.Typeable
import Data.Monoid
import Data.Foldable
import Prelude hiding (mod) -- Silence FTP import warnings
import Options.Applicative
#if MIN_VERSION_base(4,9,0)
import Data.Semigroup (Semigroup)
import qualified Data.Semigroup (Semigroup((<>)))
#endif

-- | An option is a data type that inhabits the `IsOption` type class.
class Typeable v => IsOption v where
  -- | The value to use if the option was not supplied explicitly
  defaultValue :: v
  -- | Try to parse an option value from a string. Consider using
  -- 'safeReadBool' for boolean options and 'safeRead' for numeric options.
  parseValue :: String -> Maybe v
  -- | The option name. It is used to form the command line option name, for
  -- instance. Therefore, it had better not contain spaces or other fancy
  -- characters. It is recommended to use dashes instead of spaces.
  optionName :: Tagged v String
  -- | The option description or help string. This can be an arbitrary
  -- string.
  optionHelp :: Tagged v String
  -- | A command-line option parser.
  --
  -- It has a default implementation in terms of the other methods.
  -- You may want to override it in some cases (e.g. add a short flag) and
  -- 'flagCLParser', 'mkFlagCLParser' and 'mkOptionCLParser' might come in
  -- handy.
  --
  -- Even if you override this, you still should implement all the methods
  -- above, to allow alternative interfaces.
  --
  -- Do not supply a default value here for this parser!
  -- This is because if no value was provided on the command line we may
  -- lookup the option e.g. in the environment. But if the parser always
  -- succeeds, we have no way to tell whether the user really provided the
  -- option on the command line.

  -- (If we don't specify a default, the option becomes mandatory.
  -- So, when we build the complete parser for OptionSet, we turn a
  -- failing parser into an always-succeeding one that may return an empty
  -- OptionSet.)
  optionCLParser :: Parser v
  optionCLParser = Mod OptionFields v -> Parser v
forall v. IsOption v => Mod OptionFields v -> Parser v
mkOptionCLParser Mod OptionFields v
forall a. Monoid a => a
mempty


data OptionValue = forall v . IsOption v => OptionValue v

-- | A set of options. Only one option of each type can be kept.
--
-- If some option has not been explicitly set, the default value is used.
newtype OptionSet = OptionSet (Map TypeRep OptionValue)

-- | Later options override earlier ones
instance Monoid OptionSet where
  mempty :: OptionSet
mempty = Map TypeRep OptionValue -> OptionSet
OptionSet Map TypeRep OptionValue
forall a. Monoid a => a
mempty
  OptionSet a :: Map TypeRep OptionValue
a mappend :: OptionSet -> OptionSet -> OptionSet
`mappend` OptionSet b :: Map TypeRep OptionValue
b =
    Map TypeRep OptionValue -> OptionSet
OptionSet (Map TypeRep OptionValue -> OptionSet)
-> Map TypeRep OptionValue -> OptionSet
forall a b. (a -> b) -> a -> b
$ (OptionValue -> OptionValue -> OptionValue)
-> Map TypeRep OptionValue
-> Map TypeRep OptionValue
-> Map TypeRep OptionValue
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith ((OptionValue -> OptionValue -> OptionValue)
-> OptionValue -> OptionValue -> OptionValue
forall a b c. (a -> b -> c) -> b -> a -> c
flip OptionValue -> OptionValue -> OptionValue
forall a b. a -> b -> a
const) Map TypeRep OptionValue
a Map TypeRep OptionValue
b
#if MIN_VERSION_base(4,9,0)
instance Semigroup OptionSet where
  <> :: OptionSet -> OptionSet -> OptionSet
(<>) = OptionSet -> OptionSet -> OptionSet
forall a. Monoid a => a -> a -> a
mappend
#endif

-- | Set the option value
setOption :: IsOption v => v -> OptionSet -> OptionSet
setOption :: v -> OptionSet -> OptionSet
setOption v :: v
v (OptionSet s :: Map TypeRep OptionValue
s) =
  Map TypeRep OptionValue -> OptionSet
OptionSet (Map TypeRep OptionValue -> OptionSet)
-> Map TypeRep OptionValue -> OptionSet
forall a b. (a -> b) -> a -> b
$ TypeRep
-> OptionValue
-> Map TypeRep OptionValue
-> Map TypeRep OptionValue
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (v -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf v
v) (v -> OptionValue
forall v. IsOption v => v -> OptionValue
OptionValue v
v) Map TypeRep OptionValue
s

-- | Query the option value
lookupOption :: forall v . IsOption v => OptionSet -> v
lookupOption :: OptionSet -> v
lookupOption (OptionSet s :: Map TypeRep OptionValue
s) =
  case TypeRep -> Map TypeRep OptionValue -> Maybe OptionValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (v -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf (v
forall a. HasCallStack => a
undefined :: v)) Map TypeRep OptionValue
s of
    Just (OptionValue x :: v
x) | Just v :: v
v <- v -> Maybe v
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast v
x -> v
v
    Just {} -> [Char] -> v
forall a. HasCallStack => [Char] -> a
error "OptionSet: broken invariant (shouldn't happen)"
    Nothing -> v
forall v. IsOption v => v
defaultValue

-- | Change the option value
changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet
changeOption :: (v -> v) -> OptionSet -> OptionSet
changeOption f :: v -> v
f s :: OptionSet
s = v -> OptionSet -> OptionSet
forall v. IsOption v => v -> OptionSet -> OptionSet
setOption (v -> v
f (v -> v) -> v -> v
forall a b. (a -> b) -> a -> b
$ OptionSet -> v
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
s) OptionSet
s

-- | Create a singleton 'OptionSet'
singleOption :: IsOption v => v -> OptionSet
singleOption :: v -> OptionSet
singleOption v :: v
v = v -> OptionSet -> OptionSet
forall v. IsOption v => v -> OptionSet -> OptionSet
setOption v
v OptionSet
forall a. Monoid a => a
mempty

-- | The purpose of this data type is to capture the dictionary
-- corresponding to a particular option.
data OptionDescription where
  Option :: IsOption v => Proxy v -> OptionDescription

-- | Command-line parser to use with flags
flagCLParser
  :: forall v . IsOption v
  => Maybe Char -- ^ optional short flag
  -> v          -- ^ non-default value (when the flag is supplied)
  -> Parser v
flagCLParser :: Maybe Char -> v -> Parser v
flagCLParser mbShort :: Maybe Char
mbShort = Mod FlagFields v -> v -> Parser v
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser ((Char -> Mod FlagFields v) -> Maybe Char -> Mod FlagFields v
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Char -> Mod FlagFields v
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Maybe Char
mbShort)

-- | Command-line flag parser that takes additional option modifiers.
mkFlagCLParser
  :: forall v . IsOption v
  => Mod FlagFields v -- ^ option modifier
  -> v                -- ^ non-default value (when the flag is supplied)
  -> Parser v
mkFlagCLParser :: Mod FlagFields v -> v -> Parser v
mkFlagCLParser mod :: Mod FlagFields v
mod v :: v
v = v -> Mod FlagFields v -> Parser v
forall a. a -> Mod FlagFields a -> Parser a
flag' v
v
  (  [Char] -> Mod FlagFields v
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long (Tagged v [Char] -> [Char]
forall k (s :: k) b. Tagged s b -> b
untag (Tagged v [Char]
forall v. IsOption v => Tagged v [Char]
optionName :: Tagged v String))
  Mod FlagFields v -> Mod FlagFields v -> Mod FlagFields v
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod FlagFields v
forall (f :: * -> *) a. [Char] -> Mod f a
help (Tagged v [Char] -> [Char]
forall k (s :: k) b. Tagged s b -> b
untag (Tagged v [Char]
forall v. IsOption v => Tagged v [Char]
optionHelp :: Tagged v String))
  Mod FlagFields v -> Mod FlagFields v -> Mod FlagFields v
forall a. Semigroup a => a -> a -> a
<> Mod FlagFields v
mod
  )

-- | Command-line option parser that takes additional option modifiers.
mkOptionCLParser :: forall v . IsOption v => Mod OptionFields v -> Parser v
mkOptionCLParser :: Mod OptionFields v -> Parser v
mkOptionCLParser mod :: Mod OptionFields v
mod =
  ReadM v -> Mod OptionFields v -> Parser v
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM v
parse
    (  [Char] -> Mod OptionFields v
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
name
    Mod OptionFields v -> Mod OptionFields v -> Mod OptionFields v
forall a. Semigroup a => a -> a -> a
<> [Char] -> Mod OptionFields v
forall (f :: * -> *) a. [Char] -> Mod f a
help (Tagged v [Char] -> [Char]
forall k (s :: k) b. Tagged s b -> b
untag (Tagged v [Char]
forall v. IsOption v => Tagged v [Char]
optionHelp :: Tagged v String))
    Mod OptionFields v -> Mod OptionFields v -> Mod OptionFields v
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields v
mod
    )
  where
    name :: [Char]
name = Tagged v [Char] -> [Char]
forall k (s :: k) b. Tagged s b -> b
untag (Tagged v [Char]
forall v. IsOption v => Tagged v [Char]
optionName :: Tagged v String)
    parse :: ReadM v
parse = ReadM [Char]
forall s. IsString s => ReadM s
str ReadM [Char] -> ([Char] -> ReadM v) -> ReadM v
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      ReadM v -> (v -> ReadM v) -> Maybe v -> ReadM v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> ReadM v
forall a. [Char] -> ReadM a
readerError ([Char] -> ReadM v) -> [Char] -> ReadM v
forall a b. (a -> b) -> a -> b
$ "Could not parse " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
name) v -> ReadM v
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe v -> ReadM v) -> ([Char] -> Maybe v) -> [Char] -> ReadM v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe v
forall v. IsOption v => [Char] -> Maybe v
parseValue

-- | Safe read function. Defined here for convenience to use for
-- 'parseValue'.
safeRead :: Read a => String -> Maybe a
safeRead :: [Char] -> Maybe a
safeRead s :: [Char]
s
  | [(x :: a
x, "")] <- ReadS a
forall a. Read a => ReadS a
reads [Char]
s = a -> Maybe a
forall a. a -> Maybe a
Just a
x
  | Bool
otherwise = Maybe a
forall a. Maybe a
Nothing

-- | Parse a 'Bool' case-insensitively
safeReadBool :: String -> Maybe Bool
safeReadBool :: [Char] -> Maybe Bool
safeReadBool s :: [Char]
s =
  case ((Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower [Char]
s) of
    "true" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    "false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    _ -> Maybe Bool
forall a. Maybe a
Nothing