module Options.Applicative.Builder (
subparser,
argument,
arguments,
arguments1,
flag,
flag',
switch,
nullOption,
abortOption,
infoOption,
strOption,
option,
short,
long,
help,
value,
showDefaultWith,
showDefault,
metavar,
reader,
eitherReader,
noArgError,
ParseError(..),
hidden,
internal,
command,
completeWith,
action,
completer,
idm,
(&),
#if __GLASGOW_HASKELL__ > 702
(<>),
#endif
mappend,
auto,
str,
disabled,
readerAbort,
readerError,
InfoMod,
fullDesc,
briefDesc,
header,
progDesc,
footer,
failureCode,
info,
PrefsMod,
multiSuffix,
disambiguate,
showHelpOnError,
noBacktrack,
noIntersperse,
prefs,
Mod,
ReadM,
OptionFields,
FlagFields,
ArgumentFields,
CommandFields
) where
import Control.Applicative (pure, (<|>), many, some)
import Data.Monoid (Monoid (..)
#if __GLASGOW_HASKELL__ > 702
, (<>)
#endif
)
import Options.Applicative.Builder.Completer
import Options.Applicative.Builder.Internal
import Options.Applicative.Common
import Options.Applicative.Types
auto :: Monad m => Read a => String -> m a
auto arg = case reads arg of
[(r, "")] -> return r
_ -> fail $ "cannot parse value `" ++ arg ++ "'"
str :: Monad m => String -> m String
str = return
disabled :: Monad m => String -> m a
disabled = const . fail $ "disabled option"
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 (DefaultProp (Just x) Nothing) id
showDefaultWith :: (a -> String) -> Mod f a
showDefaultWith s = Mod id (DefaultProp Nothing (Just s)) id
showDefault :: Show a => Mod f a
showDefault = showDefaultWith show
help :: String -> Mod f a
help s = optionMod $ \p -> p { propHelp = s }
reader :: (String -> ReadM a) -> Mod OptionFields a
reader f = fieldMod $ \p -> p { optReader = f }
eitherReader :: (String -> Either String a) -> Mod OptionFields a
eitherReader f = reader (either readerError return . f)
noArgError :: ParseError -> Mod OptionFields a
noArgError e = fieldMod $ \p -> p { optNoArgError = e }
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) }
command :: String -> ParserInfo a -> Mod CommandFields a
command cmd pinfo = fieldMod $ \p ->
p { cmdCommands = (cmd, pinfo) : cmdCommands p }
completeWith :: HasCompleter f => [String] -> Mod f a
completeWith xs = completer (listCompleter xs)
action :: HasCompleter f => String -> Mod f a
action act = completer (bashCompleter act)
completer :: HasCompleter f => Completer -> Mod f a
completer f = fieldMod $ modCompleter (`mappend` f)
subparser :: Mod CommandFields a -> Parser a
subparser m = mkParser d g rdr
where
Mod _ d g = m `mappend` metavar "COMMAND"
rdr = uncurry CmdReader (mkCommand m)
argument :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a
argument p (Mod f d g) = mkParser d g (ArgReader rdr)
where
ArgumentFields compl = f (ArgumentFields mempty)
rdr = CReader compl p
arguments :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a]
arguments r m = many (argument r m)
arguments1 :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a]
arguments1 r m = some (argument r m)
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 d g) = mkParser d g rdr
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 m = mkParser d g rdr
where
Mod f d g = metavar "ARG" `mappend` m
fields = f (OptionFields [] mempty disabled (ErrorMsg ""))
crdr = CReader (optCompleter fields) (optReader fields)
rdr = OptReader (optNames fields) crdr (optNoArgError fields)
abortOption :: ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)
abortOption err m = nullOption . (<> m) $ mconcat
[ reader (const (ReadM (Left err)))
, noArgError err
, value id
, metavar ""
, hidden ]
infoOption :: String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption = abortOption . InfoMsg
strOption :: Mod OptionFields String -> Parser String
strOption m = nullOption $ reader str `mappend` m
option :: Read a => Mod OptionFields a -> Parser a
option m = nullOption $ reader auto `mappend` m
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 }
briefDesc :: InfoMod a
briefDesc = InfoMod $ \i -> i { infoFullDesc = False }
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 }
disambiguate :: PrefsMod
disambiguate = PrefsMod $ \p -> p { prefDisambiguate = True }
showHelpOnError :: PrefsMod
showHelpOnError = PrefsMod $ \p -> p { prefShowHelpOnError = True }
noBacktrack :: PrefsMod
noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False }
noIntersperse :: PrefsMod
noIntersperse = PrefsMod $ \p -> p { prefIntersperse = False }
prefs :: PrefsMod -> ParserPrefs
prefs m = applyPrefsMod m base
where
base = ParserPrefs
{ prefMultiSuffix = ""
, prefDisambiguate = False
, prefShowHelpOnError = False
, prefBacktrack = True
, prefIntersperse = True }
idm :: Monoid m => m
idm = mempty
(&) :: Monoid m => m -> m -> m
(&) = mappend