module Options.Applicative.Builder (
subparser,
argument,
arguments,
flag,
switch,
nullOption,
strOption,
option,
short,
long,
help,
value,
metavar,
reader,
hide,
multi,
transform,
command,
idm,
(&),
auto,
str,
disabled,
Mod,
HasName,
OptionFields,
FlagFields,
CommandFields,
InfoMod,
fullDesc,
header,
progDesc,
footer,
failureCode,
info
) where
import Control.Applicative
import Control.Category
import Control.Monad
import Data.Lens.Common
import Data.Lens.Template
import Options.Applicative.Common
import Options.Applicative.Types
import Prelude hiding (id, (.))
data OptionFields a = OptionFields
{ _optNames :: [OptName]
, _optReader :: String -> Maybe a }
data FlagFields a = FlagFields
{ _flagNames :: [OptName] }
data CommandFields a = CommandFields
{ _cmdCommands :: [(String, ParserInfo a)] }
$( makeLenses [ ''OptionFields
, ''FlagFields
, ''CommandFields ] )
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 r a b = Mod (f r -> f r) (Option r a -> Option r b)
optionMod :: (Option r a -> Option r b) -> Mod f r a b
optionMod = Mod id
fieldMod :: (f r -> f r) -> Mod f r a a
fieldMod f = Mod f id
instance Category (Mod f r) 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 r a a
short = fieldMod . name . OptShort
long :: HasName f => String -> Mod f r a a
long = fieldMod . name . OptLong
value :: a -> Mod f r a a
value = optionMod . setL optDefault . Just
help :: String -> Mod f r a a
help = optionMod . setL optHelp
reader :: (String -> Maybe r) -> Mod OptionFields r a a
reader = fieldMod . setL optReader
metavar :: String -> Mod f r a a
metavar = optionMod . setL optMetaVar
hide :: Mod f r a a
hide = optionMod $ optShow^=False
multi :: Mod f r a [a]
multi = optionMod f
where
f opt = mkOptGroup []
where
mkOptGroup xs = opt
{ _optDefault = Just xs
, _optCont = mkCont xs }
mkCont xs r = do
p' <- getL optCont opt r
x <- evalParser p'
return $ liftOpt (mkOptGroup (x:xs))
transform :: (a -> b) -> Mod f r a b
transform f = optionMod $ fmap f
command :: String -> ParserInfo r -> Mod CommandFields r a a
command cmd pinfo = fieldMod $ cmdCommands^%=((cmd, pinfo):)
baseOpts :: OptReader a -> Option a a
baseOpts opt = Option
{ _optMain = opt
, _optMetaVar = ""
, _optShow = True
, _optCont = Just . pure
, _optHelp = ""
, _optDefault = Nothing }
subparser :: Mod CommandFields a a b -> Parser b
subparser m = liftOpt . g . baseOpts $ opt
where
Mod f g = m . metavar "COMMAND"
CommandFields cmds = f (CommandFields [])
opt = CmdReader (map fst cmds) (`lookup` cmds)
argument :: (String -> Maybe a) -> Mod f a a b -> Parser b
argument p (Mod _ g) = liftOpt . g . baseOpts $ ArgReader p
arguments :: (String -> Maybe a) -> Mod f a [a] b -> Parser b
arguments p m = argument p (m . multi)
flag :: a
-> a
-> Mod FlagFields a a b
-> Parser b
flag defv actv (Mod f g) = liftOpt . g . set_default . baseOpts $ rdr
where
rdr = let fields = f (FlagFields [])
in FlagReader (fields^.flagNames) actv
set_default = optDefault ^= Just defv
switch :: Mod FlagFields Bool Bool a -> Parser a
switch = flag False True
nullOption :: Mod OptionFields a a b -> Parser b
nullOption (Mod f g) = liftOpt . g . baseOpts $ rdr
where
rdr = let fields = f (OptionFields [] disabled)
in OptReader (fields^.optNames) (fields^.optReader)
strOption :: Mod OptionFields String String a -> Parser a
strOption m = nullOption $ m . reader str
option :: Read a => Mod OptionFields a 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
, _infoFullDesc = True
, _infoHeader = ""
, _infoProgDesc = ""
, _infoFooter = ""
, _infoFailureCode = 1 }
idm :: Category hom => hom a a
idm = id
(&) :: Category hom => hom a b -> hom b c -> hom a c
(&) = flip (.)