module Options.Applicative.Builder (
subparser,
argument,
arguments,
flag,
flag',
switch,
nullOption,
strOption,
option,
short,
long,
help,
value,
metavar,
reader,
hidden,
internal,
command,
idm,
(&),
auto,
str,
disabled,
Mod,
HasName,
OptionFields,
FlagFields,
CommandFields,
InfoMod,
fullDesc,
header,
progDesc,
footer,
failureCode,
info,
PrefsMod,
multiSuffix,
prefs
) where
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Monoid
import Options.Applicative.Common
import Options.Applicative.Types
data OptionFields a = OptionFields
{ optNames :: [OptName]
, optReader :: String -> Maybe a }
deriving Functor
data FlagFields a = FlagFields
{ flagNames :: [OptName]
, flagActive :: a }
deriving Functor
data CommandFields a = CommandFields
{ cmdCommands :: [(String, ParserInfo a)] }
deriving Functor
data ArgumentFields a
deriving Functor
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 }
data Mod f a = Mod (f a -> f a)
(Maybe a)
(OptProperties -> OptProperties)
optionMod :: (OptProperties -> OptProperties) -> Mod f a
optionMod = Mod id Nothing
fieldMod :: (f a -> f a) -> Mod f a
fieldMod f = Mod f Nothing id
instance Monoid (Mod f a) where
mempty = Mod id Nothing id
Mod f1 d1 g1 `mappend` Mod f2 d2 g2
= Mod (f2 . f1) (d2 `mplus` d1) (g2 . g1)
auto :: Read a => String -> Maybe a
auto arg = case reads arg of
[(r, "")] -> Just r
_ -> Nothing
str :: String -> Maybe String
str = Just
disabled :: String -> Maybe a
disabled = const Nothing
short :: HasName f => Char -> Mod f a
short = fieldMod . name . OptShort
long :: HasName f => String -> Mod f a
long = fieldMod . name . OptLong
value :: a -> Mod f a
value x = Mod id (Just x) id
help :: String -> Mod f a
help s = optionMod $ \p -> p { propHelp = s }
reader :: (String -> Maybe a) -> Mod OptionFields a
reader f = fieldMod $ \p -> p { optReader = f }
metavar :: String -> Mod f a
metavar var = optionMod $ \p -> p { propMetaVar = var }
hidden :: Mod f a
hidden = optionMod $ \p ->
p { propVisibility = min Hidden (propVisibility p) }
internal :: Mod f a
internal = optionMod $ \p -> p { propVisibility = Internal }
command :: String -> ParserInfo a -> Mod CommandFields a
command cmd pinfo = fieldMod $ \p ->
p { cmdCommands = (cmd, pinfo) : cmdCommands p }
baseProps :: OptProperties
baseProps = OptProperties
{ propMetaVar = ""
, propVisibility = Visible
, propHelp = "" }
mkOption :: Maybe a -> Option a -> Parser a
mkOption def opt = liftOpt opt <|> maybe empty pure def
subparser :: Mod CommandFields a -> Parser a
subparser m = mkOption def $ Option rdr (g baseProps)
where
Mod f def g = m & metavar "COMMAND"
CommandFields cmds = f (CommandFields [])
rdr = CmdReader (map fst cmds) (`lookup` cmds)
argument :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a
argument p (Mod _ def g) = mkOption def $ Option (ArgReader p) (g baseProps)
arguments :: (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a]
arguments p m = args1 <|> pure (fromMaybe [] def)
where
Mod _ def g = m
p' ('-':_) = Nothing
p' s = p s
args1 = ((Just <$> arg') <|> (ddash *> pure Nothing)) `BindP` \x -> case x of
Nothing -> many arg
Just a -> fmap (a:) args
args = args1 <|> pure []
arg' = argument p' (optionMod g)
arg = argument p (optionMod g)
ddash = argument (guard . (== "--")) internal
flag :: a
-> a
-> Mod FlagFields a
-> Parser a
flag defv actv m = flag' actv m <|> pure defv
flag' :: a
-> Mod FlagFields a
-> Parser a
flag' actv (Mod f def g) = mkOption def $ Option rdr (g baseProps)
where
rdr = let fields = f (FlagFields [] actv)
in FlagReader (flagNames fields)
(flagActive fields)
switch :: Mod FlagFields Bool -> Parser Bool
switch = flag False True
nullOption :: Mod OptionFields a -> Parser a
nullOption (Mod f def g) = mkOption def $ Option rdr (g baseProps)
where
rdr = let fields = f (OptionFields [] disabled)
in OptReader (optNames fields) (optReader fields)
strOption :: Mod OptionFields String -> Parser String
strOption m = nullOption $ m & reader str
option :: Read a => Mod OptionFields a -> Parser a
option m = nullOption $ m & reader auto
newtype InfoMod a = InfoMod
{ applyInfoMod :: ParserInfo a -> ParserInfo a }
instance Monoid (InfoMod a) where
mempty = InfoMod id
mappend m1 m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1
fullDesc :: InfoMod a
fullDesc = InfoMod $ \i -> i { infoFullDesc = True }
header :: String -> InfoMod a
header s = InfoMod $ \i -> i { infoHeader = s }
footer :: String -> InfoMod a
footer s = InfoMod $ \i -> i { infoFooter = s }
progDesc :: String -> InfoMod a
progDesc s = InfoMod $ \i -> i { infoProgDesc = s }
failureCode :: Int -> InfoMod a
failureCode n = InfoMod $ \i -> i { infoFailureCode = n }
info :: Parser a -> InfoMod a -> ParserInfo a
info parser m = applyInfoMod m base
where
base = ParserInfo
{ infoParser = parser
, infoFullDesc = True
, infoProgDesc = ""
, infoHeader = ""
, infoFooter = ""
, infoFailureCode = 1 }
newtype PrefsMod = PrefsMod
{ applyPrefsMod :: ParserPrefs -> ParserPrefs }
instance Monoid PrefsMod where
mempty = PrefsMod id
mappend m1 m2 = PrefsMod $ applyPrefsMod m2 . applyPrefsMod m1
multiSuffix :: String -> PrefsMod
multiSuffix s = PrefsMod $ \p -> p { prefMultiSuffix = s }
prefs :: PrefsMod -> ParserPrefs
prefs m = applyPrefsMod m base
where
base = ParserPrefs
{ prefMultiSuffix = "" }
idm :: Monoid m => m
idm = mempty
(&) :: Monoid m => m -> m -> m
(&) = mappend