1{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable,
2             ExistentialQuantification, GADTs,
3             FlexibleInstances, UndecidableInstances,
4             TypeOperators #-}
5-- | Extensible options. They are used for provider-specific settings,
6-- ingredient-specific settings and core settings (such as the test name pattern).
7module Test.Tasty.Options
8  (
9    -- * IsOption class
10    IsOption(..)
11    -- * Option sets and operations
12  , OptionSet
13  , setOption
14  , changeOption
15  , lookupOption
16  , singleOption
17  , OptionDescription(..)
18  , uniqueOptionDescriptions
19    -- * Utilities
20  , flagCLParser
21  , mkFlagCLParser
22  , mkOptionCLParser
23  , safeRead
24  , safeReadBool
25  ) where
26
27import qualified Data.Map as Map
28import Data.Map (Map)
29import Data.Maybe
30import Data.Char (toLower)
31import Data.Tagged
32import Data.Proxy
33import Data.Typeable
34import Data.Monoid
35import Data.Foldable
36import qualified Data.Set as S
37import Prelude hiding (mod) -- Silence FTP import warnings
38import Options.Applicative
39#if !MIN_VERSION_base(4,11,0)
40import Data.Semigroup (Semigroup)
41import qualified Data.Semigroup (Semigroup((<>)))
42#endif
43
44-- | An option is a data type that inhabits the `IsOption` type class.
45class Typeable v => IsOption v where
46  -- | The value to use if the option was not supplied explicitly
47  defaultValue :: v
48  -- | Try to parse an option value from a string. Consider using
49  -- 'safeReadBool' for boolean options and 'safeRead' for numeric options.
50  parseValue :: String -> Maybe v
51  -- | The option name. It is used to form the command line option name, for
52  -- instance. Therefore, it had better not contain spaces or other fancy
53  -- characters. It is recommended to use dashes instead of spaces.
54  optionName :: Tagged v String
55  -- | The option description or help string. This can be an arbitrary
56  -- string.
57  optionHelp :: Tagged v String
58  -- | How a 'defaultValue' should be displayed in the help string. 'Nothing'
59  -- (the default implementation) will result in nothing being displayed, while
60  -- @'Just' def@ will result in @def@ being advertised as the default in the
61  -- help string.
62  showDefaultValue :: v -> Maybe String
63  showDefaultValue _ = Nothing
64  -- | A command-line option parser.
65  --
66  -- It has a default implementation in terms of the other methods.
67  -- You may want to override it in some cases (e.g. add a short flag) and
68  -- 'flagCLParser', 'mkFlagCLParser' and 'mkOptionCLParser' might come in
69  -- handy.
70  --
71  -- Even if you override this, you still should implement all the methods
72  -- above, to allow alternative interfaces.
73  --
74  -- Do not supply a default value (e.g., with the 'value' function) here
75  -- for this parser! This is because if no value was provided on the command
76  -- line we may lookup the option e.g. in the environment. But if the parser
77  -- always succeeds, we have no way to tell whether the user really provided
78  -- the option on the command line.
79  --
80  -- Similarly, do not use 'showDefaultWith' here, as it will be ignored. Use
81  -- the 'showDefaultValue' method of 'IsOption' instead.
82
83  -- (If we don't specify a default, the option becomes mandatory.
84  -- So, when we build the complete parser for OptionSet, we turn a
85  -- failing parser into an always-succeeding one that may return an empty
86  -- OptionSet.)
87  --
88  -- @since 1.3
89  optionCLParser :: Parser v
90  optionCLParser = mkOptionCLParser mempty
91
92
93data OptionValue = forall v . IsOption v => OptionValue v
94
95-- | A set of options. Only one option of each type can be kept.
96--
97-- If some option has not been explicitly set, the default value is used.
98newtype OptionSet = OptionSet (Map TypeRep OptionValue)
99
100-- | Later options override earlier ones
101instance Monoid OptionSet where
102  mempty = OptionSet mempty
103  OptionSet a `mappend` OptionSet b =
104    OptionSet $ Map.unionWith (flip const) a b
105instance Semigroup OptionSet where
106  (<>) = mappend
107
108-- | Set the option value
109setOption :: IsOption v => v -> OptionSet -> OptionSet
110setOption v (OptionSet s) =
111  OptionSet $ Map.insert (typeOf v) (OptionValue v) s
112
113-- | Query the option value
114lookupOption :: forall v . IsOption v => OptionSet -> v
115lookupOption (OptionSet s) =
116  case Map.lookup (typeOf (undefined :: v)) s of
117    Just (OptionValue x) | Just v <- cast x -> v
118    Just {} -> error "OptionSet: broken invariant (shouldn't happen)"
119    Nothing -> defaultValue
120
121-- | Change the option value
122changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet
123changeOption f s = setOption (f $ lookupOption s) s
124
125-- | Create a singleton 'OptionSet'
126singleOption :: IsOption v => v -> OptionSet
127singleOption v = setOption v mempty
128
129-- | The purpose of this data type is to capture the dictionary
130-- corresponding to a particular option.
131data OptionDescription where
132  Option :: IsOption v => Proxy v -> OptionDescription
133
134-- | Remove duplicated 'OptionDescription', preserving existing order otherwise
135--
136-- @since 1.4.1
137uniqueOptionDescriptions :: [OptionDescription] -> [OptionDescription]
138uniqueOptionDescriptions = go S.empty
139  where
140    go _ [] = []
141    go acc (Option o : os)
142      | typeOf o `S.member` acc = go acc os
143      | otherwise = Option o : go (S.insert (typeOf o) acc) os
144
145-- | Command-line parser to use with flags
146flagCLParser
147  :: forall v . IsOption v
148  => Maybe Char -- ^ optional short flag
149  -> v          -- ^ non-default value (when the flag is supplied)
150  -> Parser v
151flagCLParser mbShort = mkFlagCLParser (foldMap short mbShort)
152
153-- | Command-line flag parser that takes additional option modifiers.
154mkFlagCLParser
155  :: forall v . IsOption v
156  => Mod FlagFields v -- ^ option modifier
157  -> v                -- ^ non-default value (when the flag is supplied)
158  -> Parser v
159mkFlagCLParser mod v = flag' v
160  (  long (untag (optionName :: Tagged v String))
161  <> help (untag (optionHelp :: Tagged v String))
162  <> mod
163  )
164
165-- | Command-line option parser that takes additional option modifiers.
166mkOptionCLParser :: forall v . IsOption v => Mod OptionFields v -> Parser v
167mkOptionCLParser mod =
168  option parse
169    (  long name
170    <> help (untag (optionHelp :: Tagged v String))
171    <> mod
172    )
173  where
174    name = untag (optionName :: Tagged v String)
175    parse = str >>=
176      maybe (readerError $ "Could not parse " ++ name) pure <$> parseValue
177
178-- | Safe read function. Defined here for convenience to use for
179-- 'parseValue'.
180safeRead :: Read a => String -> Maybe a
181safeRead s
182  | [(x, "")] <- reads s = Just x
183  | otherwise = Nothing
184
185-- | Parse a 'Bool' case-insensitively
186safeReadBool :: String -> Maybe Bool
187safeReadBool s =
188  case (map toLower s) of
189    "true" -> Just True
190    "false" -> Just False
191    _ -> Nothing
192