module Options.Applicative.Builder (
subparser,
argument,
arguments,
flag,
flag',
switch,
nullOption,
strOption,
option,
short,
long,
help,
value,
metavar,
reader,
hidden,
internal,
transform,
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.Category
import Control.Monad
import Data.Functor.Identity
import Data.Lens.Common
import Options.Applicative.Common
import Options.Applicative.Types
import Prelude hiding (id, (.))
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
optNames :: Lens (OptionFields a) [OptName]
optNames = lens _optNames $ \x o -> o { _optNames = x }
optReader :: Lens (OptionFields a) (String -> Maybe a)
optReader = lens _optReader $ \x o -> o { _optReader = x }
flagNames :: Lens (FlagFields a) [OptName]
flagNames = lens _flagNames $ \x o -> o { _flagNames = x }
cmdCommands :: Lens (CommandFields a) [(String, ParserInfo a)]
cmdCommands = lens _cmdCommands $ \x o -> o { _cmdCommands = x }
class HasName f where
name :: OptName -> f a -> f a
instance HasName OptionFields where
name n = modL optNames (n:)
instance HasName FlagFields where
name n = modL flagNames (n:)
data Mod f a b = Mod (f a -> f b) (OptProperties a -> OptProperties b)
optionMod :: (OptProperties a -> OptProperties a) -> Mod f a a
optionMod = Mod id
fieldMod :: (f a -> f a) -> Mod f a a
fieldMod f = Mod f id
instance Category (Mod f) where
id = Mod id id
Mod f1 g1 . Mod f2 g2 = Mod (f1 . f2) (g1 . g2)
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 a
short = fieldMod . name . OptShort
long :: HasName f => String -> Mod f a a
long = fieldMod . name . OptLong
value :: a -> Mod f a a
value = optionMod . setL propDefault . Just
help :: String -> Mod f a a
help = optionMod . setL propHelp
reader :: (String -> Maybe a) -> Mod OptionFields a a
reader = fieldMod . setL optReader
metavar :: String -> Mod f a a
metavar = optionMod . setL propMetaVar
hidden :: Mod f a a
hidden = optionMod $ propVisibility ^%= min Hidden
internal :: Mod f a a
internal = optionMod $ propVisibility ^= Internal
transform :: Functor f => (a -> b) -> Mod f a b
transform f = Mod (fmap f) (fmap f)
command :: String -> ParserInfo a -> Mod CommandFields a a
command cmd pinfo = fieldMod $ cmdCommands^%=((cmd, pinfo):)
baseProps :: OptProperties a
baseProps = OptProperties
{ _propMetaVar = ""
, _propVisibility = Visible
, _propHelp = ""
, _propDefault = Nothing }
subparser :: Mod CommandFields a b -> Parser b
subparser m = liftOpt $ Option rdr (g baseProps)
where
Mod f g = m . metavar "COMMAND"
CommandFields cmds = f (CommandFields [])
rdr = CmdReader (map fst cmds) (`lookup` cmds)
argument :: (String -> Maybe a) -> Mod Identity a b -> Parser b
argument p (Mod f g) = liftOpt $ Option (ArgReader p') (g baseProps)
where p' s = fmap (runIdentity . f . Identity) (p s)
arguments :: (String -> Maybe a) -> Mod Identity a b -> Parser [b]
arguments p m = args
where
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' m
arg = argument p m
ddash = argument (guard . (== "--")) internal
flag :: a
-> a
-> Mod FlagFields a b
-> Parser b
flag defv actv m = flag' actv (m . value defv)
flag' :: a
-> Mod FlagFields a b
-> Parser b
flag' actv (Mod f g) = liftOpt $ Option rdr (g baseProps)
where
rdr = let FlagFields ns actv' = f (FlagFields [] actv)
in FlagReader ns actv'
switch :: Mod FlagFields Bool a -> Parser a
switch = flag False True
nullOption :: Mod OptionFields a b -> Parser b
nullOption (Mod f g) = liftOpt $ Option rdr (g baseProps)
where
rdr = let fields = f (OptionFields [] disabled)
in OptReader (fields^.optNames) (fields^.optReader)
strOption :: Mod OptionFields String a -> Parser a
strOption m = nullOption $ m . reader str
option :: Read a => Mod OptionFields a b -> Parser b
option m = nullOption $ m . reader auto
newtype InfoMod a b = InfoMod
{ applyInfoMod :: ParserInfo a -> ParserInfo b }
instance Category InfoMod where
id = InfoMod id
m1 . m2 = InfoMod $ applyInfoMod m1 . applyInfoMod m2
fullDesc :: InfoMod a a
fullDesc = InfoMod $ infoFullDesc^=True
header :: String -> InfoMod a a
header s = InfoMod $ infoHeader^=s
footer :: String -> InfoMod a a
footer s = InfoMod $ infoFooter^=s
progDesc :: String -> InfoMod a a
progDesc s = InfoMod $ infoProgDesc^=s
failureCode :: Int -> InfoMod a a
failureCode n = InfoMod $ infoFailureCode^=n
info :: Parser a -> InfoMod a a -> ParserInfo a
info parser m = applyInfoMod m base
where
base = ParserInfo
{ _infoParser = parser
, _infoDesc = ParserDesc
{ _descFull = True
, _descProg = ""
, _descHeader = ""
, _descFooter = ""
, _descFailureCode = 1
}
}
newtype PrefsModC a b = PrefsMod
{ applyPrefsMod :: a -> b }
type PrefsMod = PrefsModC ParserPrefs ParserPrefs
instance Category PrefsModC where
id = PrefsMod id
m1 . m2 = PrefsMod $ applyPrefsMod m1 . applyPrefsMod m2
multiSuffix :: String -> PrefsMod
multiSuffix s = PrefsMod $ prefMultiSuffix ^= s
prefs :: PrefsMod -> ParserPrefs
prefs m = applyPrefsMod m base
where
base = ParserPrefs
{ _prefMultiSuffix = "" }
idm :: Category hom => hom a a
idm = id
(&) :: Category hom => hom a b -> hom b c -> hom a c
(&) = flip (.)