{-# 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(..)
  , uniqueOptionDescriptions
    -- * Utilities
  , flagCLParser
  , mkFlagCLParser
  , mkOptionCLParser
  , safeRead
  , safeReadBool
  ) where

import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe
import Data.Char (toLower)
import Data.Tagged
import Data.Proxy
import Data.Typeable
import Data.Monoid
import Data.Foldable
import qualified Data.Semigroup as Sem
import qualified Data.Set as S
import Prelude hiding (mod) -- Silence FTP import warnings
import Options.Applicative

-- | 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
  -- | How a 'defaultValue' should be displayed in the help string. 'Nothing'
  -- (the default implementation) will result in nothing being displayed, while
  -- @'Just' def@ will result in @def@ being advertised as the default in the
  -- help string.
  showDefaultValue :: v -> Maybe String
  showDefaultValue v
_ = Maybe String
forall a. Maybe a
Nothing
  -- | 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 (e.g., with the 'value' function) 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.
  --
  -- Similarly, do not use 'showDefaultWith' here, as it will be ignored. Use
  -- the 'showDefaultValue' method of 'IsOption' instead.

  -- (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.)
  --
  -- @since 1.3
  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 Sem.Semigroup OptionSet where
  OptionSet Map TypeRep OptionValue
a <> :: OptionSet -> OptionSet -> OptionSet
<> OptionSet 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
instance Monoid OptionSet where
  mempty :: OptionSet
mempty = Map TypeRep OptionValue -> OptionSet
OptionSet Map TypeRep OptionValue
forall a. Monoid a => a
mempty
#if !MIN_VERSION_base(4,11,0)
  mappend = (Sem.<>)
#endif

-- | Set the option value
setOption :: IsOption v => v -> OptionSet -> OptionSet
setOption :: forall v. IsOption v => v -> OptionSet -> OptionSet
setOption v
v (OptionSet 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 :: forall v. IsOption v => OptionSet -> v
lookupOption (OptionSet 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 v
x) | Just v
v <- v -> Maybe v
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast v
x -> v
v
    Just {} -> String -> v
forall a. HasCallStack => String -> a
error String
"OptionSet: broken invariant (shouldn't happen)"
    Maybe OptionValue
Nothing -> v
forall v. IsOption v => v
defaultValue

-- | Change the option value
changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet
changeOption :: forall v. IsOption v => (v -> v) -> OptionSet -> OptionSet
changeOption v -> v
f 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 :: forall v. IsOption v => v -> OptionSet
singleOption 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

-- | Remove duplicated 'OptionDescription', preserving existing order otherwise
--
-- @since 1.4.1
uniqueOptionDescriptions :: [OptionDescription] -> [OptionDescription]
uniqueOptionDescriptions :: [OptionDescription] -> [OptionDescription]
uniqueOptionDescriptions = Set TypeRep -> [OptionDescription] -> [OptionDescription]
go Set TypeRep
forall a. Set a
S.empty
  where
    go :: Set TypeRep -> [OptionDescription] -> [OptionDescription]
go Set TypeRep
_ [] = []
    go Set TypeRep
acc (Option Proxy v
o : [OptionDescription]
os)
      | Proxy v -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy v
o TypeRep -> Set TypeRep -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set TypeRep
acc = Set TypeRep -> [OptionDescription] -> [OptionDescription]
go Set TypeRep
acc [OptionDescription]
os
      | Bool
otherwise = Proxy v -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option Proxy v
o OptionDescription -> [OptionDescription] -> [OptionDescription]
forall a. a -> [a] -> [a]
: Set TypeRep -> [OptionDescription] -> [OptionDescription]
go (TypeRep -> Set TypeRep -> Set TypeRep
forall a. Ord a => a -> Set a -> Set a
S.insert (Proxy v -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Proxy v
o) Set TypeRep
acc) [OptionDescription]
os

-- | 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 :: forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser 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 :: forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields v
mod v
v = v -> Mod FlagFields v -> Parser v
forall a. a -> Mod FlagFields a -> Parser a
flag' v
v
  (  String -> Mod FlagFields v
forall (f :: * -> *) a. HasName f => String -> Mod f a
long (Tagged v String -> String
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged v String
forall v. IsOption v => Tagged v String
optionName :: Tagged v String))
  Mod FlagFields v -> Mod FlagFields v -> Mod FlagFields v
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields v
forall (f :: * -> *) a. String -> Mod f a
help (Tagged v String -> String
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged v String
forall v. IsOption v => Tagged v String
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 :: forall v. IsOption v => Mod OptionFields v -> Parser v
mkOptionCLParser Mod OptionFields v
mod =
  ReadM v -> Mod OptionFields v -> Parser v
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM v
parse
    (  String -> Mod OptionFields v
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name
    Mod OptionFields v -> Mod OptionFields v -> Mod OptionFields v
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields v
forall (f :: * -> *) a. String -> Mod f a
help (Tagged v String -> String
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged v String
forall v. IsOption v => Tagged v String
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 :: String
name = Tagged v String -> String
forall {k} (s :: k) b. Tagged s b -> b
untag (Tagged v String
forall v. IsOption v => Tagged v String
optionName :: Tagged v String)
    parse :: ReadM v
parse = ReadM String
forall s. IsString s => ReadM s
str ReadM String -> (String -> 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 (String -> ReadM v
forall a. String -> ReadM a
readerError (String -> ReadM v) -> String -> ReadM v
forall a b. (a -> b) -> a -> b
$ String
"Could not parse " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) v -> ReadM v
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe v -> ReadM v) -> (String -> Maybe v) -> String -> ReadM v
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Maybe v
forall v. IsOption v => String -> Maybe v
parseValue

-- | Safe read function. Defined here for convenience to use for
-- 'parseValue'.
safeRead :: Read a => String -> Maybe a
safeRead :: forall a. Read a => String -> Maybe a
safeRead String
s
  | [(a
x, String
"")] <- ReadS a
forall a. Read a => ReadS a
reads String
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 :: String -> Maybe Bool
safeReadBool String
s =
  case ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower String
s) of
    String
"true" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
    String
"false" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    String
_ -> Maybe Bool
forall a. Maybe a
Nothing