{-# 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).
--
-- @since 0.1
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.
--
-- @since 0.1
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.
  --
  -- @since 1.3
  showDefaultValue :: v -> Maybe String
  showDefaultValue v
_ = 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.)
  optionCLParser :: Parser v
  optionCLParser = forall v. IsOption v => Mod OptionFields v -> Parser v
mkOptionCLParser 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.
--
-- @since 0.1
newtype OptionSet = OptionSet (Map TypeRep OptionValue)

-- | Later options override earlier ones.
--
-- @since 0.12.0.1
instance Sem.Semigroup OptionSet where
  OptionSet Map TypeRep OptionValue
a <> :: OptionSet -> OptionSet -> OptionSet
<> OptionSet Map TypeRep OptionValue
b =
    Map TypeRep OptionValue -> OptionSet
OptionSet forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 forall a. Monoid a => a
mempty
#if !MIN_VERSION_base(4,11,0)
  mappend = (Sem.<>)
#endif

-- | Set the option value.
--
-- @since 0.1
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 forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (forall a. Typeable a => a -> TypeRep
typeOf v
v) (forall v. IsOption v => v -> OptionValue
OptionValue v
v) Map TypeRep OptionValue
s

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

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

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

-- | The purpose of this data type is to capture the dictionary
-- corresponding to a particular option.
--
-- @since 0.1
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 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)
      | forall a. Typeable a => a -> TypeRep
typeOf Proxy v
o 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 = forall v. IsOption v => Proxy v -> OptionDescription
Option Proxy v
o forall a. a -> [a] -> [a]
: Set TypeRep -> [OptionDescription] -> [OptionDescription]
go (forall a. Ord a => a -> Set a -> Set a
S.insert (forall a. Typeable a => a -> TypeRep
typeOf Proxy v
o) Set TypeRep
acc) [OptionDescription]
os

-- | Command-line parser to use with flags.
--
-- @since 0.8
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 = forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Maybe Char
mbShort)

-- | Command-line flag parser that takes additional option modifiers.
--
-- @since 0.11.1
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 = forall a. a -> Mod FlagFields a -> Parser a
flag' v
v
  (  forall (f :: * -> *) a. HasName f => String -> Mod f a
long (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionName :: Tagged v String))
  forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionHelp :: Tagged v String))
  forall a. Semigroup a => a -> a -> a
<> Mod FlagFields v
mod
  )

-- | Command-line option parser that takes additional option modifiers.
--
-- @since 0.11.1
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 =
  forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM v
parse
    (  forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
name
    forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a. String -> Mod f a
help (forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionHelp :: Tagged v String))
    forall a. Semigroup a => a -> a -> a
<> Mod OptionFields v
mod
    )
  where
    name :: String
    name :: String
name = forall {k} (s :: k) b. Tagged s b -> b
untag (forall v. IsOption v => Tagged v String
optionName :: Tagged v String)

    parse :: ReadM v
    parse :: ReadM v
parse = do
      String
s <- forall s. IsString s => ReadM s
str
      let err :: String
err = String
"Could not parse: " forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ String
" is not a valid " forall a. [a] -> [a] -> [a]
++ String
name
      forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> ReadM a
readerError String
err) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall v. IsOption v => String -> Maybe v
parseValue String
s)

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

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