Permalink
Fetching contributors…
Cannot retrieve contributors at this time
184 lines (151 sloc) 4.85 KB
module Options.Applicative.Builder.Internal (
-- * Internals
Mod(..),
HasName(..),
HasCompleter(..),
HasValue(..),
HasMetavar(..),
OptionFields(..),
FlagFields(..),
CommandFields(..),
ArgumentFields(..),
DefaultProp(..),
optionMod,
fieldMod,
baseProps,
mkCommand,
mkParser,
mkOption,
mkProps,
internal
) where
import Control.Applicative
import Control.Monad (mplus)
import Data.Semigroup hiding (Option)
import Prelude
import Options.Applicative.Common
import Options.Applicative.Types
data OptionFields a = OptionFields
{ optNames :: [OptName]
, optCompleter :: Completer
, optNoArgError :: String -> ParseError }
data FlagFields a = FlagFields
{ flagNames :: [OptName]
, flagActive :: a }
data CommandFields a = CommandFields
{ cmdCommands :: [(String, ParserInfo a)]
, cmdGroup :: Maybe String }
data ArgumentFields a = ArgumentFields
{ argCompleter :: Completer }
class HasName f where
name :: OptName -> f a -> f a
instance HasName OptionFields where
name n fields = fields { optNames = n : optNames fields }
instance HasName FlagFields where
name n fields = fields { flagNames = n : flagNames fields }
class HasCompleter f where
modCompleter :: (Completer -> Completer) -> f a -> f a
instance HasCompleter OptionFields where
modCompleter f p = p { optCompleter = f (optCompleter p) }
instance HasCompleter ArgumentFields where
modCompleter f p = p { argCompleter = f (argCompleter p) }
class HasValue f where
-- this is just so that it is not necessary to specify the kind of f
hasValueDummy :: f a -> ()
instance HasValue OptionFields where
hasValueDummy _ = ()
instance HasValue ArgumentFields where
hasValueDummy _ = ()
class HasMetavar f where
hasMetavarDummy :: f a -> ()
instance HasMetavar OptionFields where
hasMetavarDummy _ = ()
instance HasMetavar ArgumentFields where
hasMetavarDummy _ = ()
instance HasMetavar CommandFields where
hasMetavarDummy _ = ()
-- mod --
data DefaultProp a = DefaultProp
(Maybe a)
(Maybe (a -> String))
instance Monoid (DefaultProp a) where
mempty = DefaultProp Nothing Nothing
mappend = (<>)
instance Semigroup (DefaultProp a) where
(DefaultProp d1 s1) <> (DefaultProp d2 s2) =
DefaultProp (d1 `mplus` d2) (s1 `mplus` s2)
-- | An option modifier.
--
-- Option modifiers are values that represent a modification of the properties
-- of an option.
--
-- The type parameter @a@ is the return type of the option, while @f@ is a
-- record containing its properties (e.g. 'OptionFields' for regular options,
-- 'FlagFields' for flags, etc...).
--
-- An option modifier consists of 3 elements:
--
-- - A field modifier, of the form @f a -> f a@. These are essentially
-- (compositions of) setters for some of the properties supported by @f@.
--
-- - An optional default value and function to display it.
--
-- - A property modifier, of the form @OptProperties -> OptProperties@. This
-- is just like the field modifier, but for properties applicable to any
-- option.
--
-- Modifiers are instances of 'Monoid', and can be composed as such.
--
-- One rarely needs to deal with modifiers directly, as most of the times it is
-- sufficient to pass them to builders (such as 'strOption' or 'flag') to
-- create options (see 'Options.Applicative.Builder').
data Mod f a = Mod (f a -> f a)
(DefaultProp a)
(OptProperties -> OptProperties)
optionMod :: (OptProperties -> OptProperties) -> Mod f a
optionMod = Mod id mempty
fieldMod :: (f a -> f a) -> Mod f a
fieldMod f = Mod f mempty id
instance Monoid (Mod f a) where
mempty = Mod id mempty id
mappend = (<>)
-- | @since 0.13.0.0
instance Semigroup (Mod f a) where
Mod f1 d1 g1 <> Mod f2 d2 g2
= Mod (f2 . f1) (d2 <> d1) (g2 . g1)
-- | Base default properties.
baseProps :: OptProperties
baseProps = OptProperties
{ propMetaVar = ""
, propVisibility = Visible
, propHelp = mempty
, propShowDefault = Nothing
, propDescMod = Nothing
}
mkCommand :: Mod CommandFields a -> (Maybe String, [String], String -> Maybe (ParserInfo a))
mkCommand m = (group, map fst cmds, (`lookup` cmds))
where
Mod f _ _ = m
CommandFields cmds group = f (CommandFields [] Nothing)
mkParser :: DefaultProp a
-> (OptProperties -> OptProperties)
-> OptReader a
-> Parser a
mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def
where
opt = mkOption d g rdr
mkOption :: DefaultProp a
-> (OptProperties -> OptProperties)
-> OptReader a
-> Option a
mkOption d g rdr = Option rdr (mkProps d g)
mkProps :: DefaultProp a
-> (OptProperties -> OptProperties)
-> OptProperties
mkProps (DefaultProp def sdef) g = props
where
props = (g baseProps)
{ propShowDefault = sdef <*> def }
-- | Hide this option from the help text
internal :: Mod f a
internal = optionMod $ \p -> p { propVisibility = Internal }