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