mirror of
https://github.com/ilyakooo0/optparse-applicative.git
synced 2024-09-11 10:45:25 +03:00
Show alternatives in the brief help text.
This commit is contained in:
parent
9fa5d8a42a
commit
551562a4bf
@ -42,6 +42,7 @@ module Options.Applicative.Common (
|
||||
runP,
|
||||
setContext,
|
||||
mapParser,
|
||||
flatMapParser,
|
||||
optionNames
|
||||
) where
|
||||
|
||||
@ -174,11 +175,11 @@ evalParser (AltP p1 p2) = evalParser p1 <|> evalParser p2
|
||||
evalParser (BindP p k) = evalParser p >>= evalParser . k
|
||||
|
||||
-- | Map a polymorphic function over all the options of a parser, and collect
|
||||
-- the results.
|
||||
-- the results in a tree structure.
|
||||
mapParser :: (forall x . OptHelpInfo -> Option x -> b)
|
||||
-> Parser a
|
||||
-> [b]
|
||||
mapParser = go False False
|
||||
-> OptTree b
|
||||
mapParser g = simplify . go False False g
|
||||
where
|
||||
has_default :: Parser a -> Bool
|
||||
has_default p = case runP (evalParser p) of
|
||||
@ -187,10 +188,39 @@ mapParser = go False False
|
||||
|
||||
go :: Bool -> Bool
|
||||
-> (forall x . OptHelpInfo -> Option x -> b)
|
||||
-> Parser a -> [b]
|
||||
go _ _ _ (NilP _) = []
|
||||
go m d f (OptP opt) = [f (OptHelpInfo m d) opt]
|
||||
go m d f (MultP p1 p2) = go m d f p1 ++ go m d f p2
|
||||
go m d f (AltP p1 p2) = go m d' f p1 ++ go m d' f p2
|
||||
-> Parser a
|
||||
-> OptTree b
|
||||
go _ _ _ (NilP _) = MultNode []
|
||||
go m d f (OptP opt) = Leaf (f (OptHelpInfo m d) opt)
|
||||
go m d f (MultP p1 p2) = MultNode [go m d f p1, go m d f p2]
|
||||
go m d f (AltP p1 p2) = AltNode [go m d' f p1, go m d' f p2]
|
||||
where d' = d || has_default p1 || has_default p2
|
||||
go _ d f (BindP p _) = go True d f p
|
||||
|
||||
simplify :: OptTree a -> OptTree a
|
||||
simplify (Leaf x) = Leaf x
|
||||
simplify (MultNode xs) =
|
||||
case concatMap (remove_mult . simplify) xs of
|
||||
[x] -> x
|
||||
xs' -> MultNode xs'
|
||||
where
|
||||
remove_mult (MultNode ts) = ts
|
||||
remove_mult t = [t]
|
||||
simplify (AltNode xs) =
|
||||
case concatMap (remove_alt . simplify) xs of
|
||||
[] -> MultNode []
|
||||
[x] -> x
|
||||
xs' -> AltNode xs'
|
||||
where
|
||||
remove_alt (AltNode ts) = ts
|
||||
remove_alt (MultNode []) = []
|
||||
remove_alt t = [t]
|
||||
|
||||
-- | Like 'mapParser', but collect the results in a list.
|
||||
flatMapParser :: (forall x. OptHelpInfo -> Option x -> b)
|
||||
-> Parser a -> [b]
|
||||
flatMapParser f = flatten . mapParser f
|
||||
where
|
||||
flatten (Leaf x) = [x]
|
||||
flatten (MultNode xs) = xs >>= flatten
|
||||
flatten (AltNode xs) = xs >>= flatten
|
||||
|
@ -54,7 +54,7 @@ optDesc pprefs style info opt =
|
||||
|
||||
-- | Generate descriptions for commands.
|
||||
cmdDesc :: Parser a -> [String]
|
||||
cmdDesc = concat . mapParser desc
|
||||
cmdDesc = concat . flatMapParser desc
|
||||
where
|
||||
desc _ opt
|
||||
| CmdReader cmds p <- optMain opt
|
||||
@ -66,16 +66,22 @@ cmdDesc = concat . mapParser desc
|
||||
|
||||
-- | Generate a brief help text for a parser.
|
||||
briefDesc :: ParserPrefs -> Parser a -> String
|
||||
briefDesc pprefs = foldr (<+>) "" . mapParser (optDesc pprefs style)
|
||||
briefDesc pprefs = fold_tree . mapParser (optDesc pprefs style)
|
||||
where
|
||||
style = OptDescStyle
|
||||
{ descSep = "|"
|
||||
, descHidden = False
|
||||
, descSurround = True }
|
||||
|
||||
fold_tree (Leaf x) = x
|
||||
fold_tree (MultNode xs) = unwords (fold_trees xs)
|
||||
fold_tree (AltNode xs) = "(" ++ intercalate " | " (fold_trees xs) ++ ")"
|
||||
|
||||
fold_trees = filter (not . null) . map fold_tree
|
||||
|
||||
-- | Generate a full help text for a parser.
|
||||
fullDesc :: ParserPrefs -> Parser a -> [String]
|
||||
fullDesc pprefs = tabulate . catMaybes . mapParser doc
|
||||
fullDesc pprefs = tabulate . catMaybes . flatMapParser doc
|
||||
where
|
||||
doc info opt
|
||||
| null n = Nothing
|
||||
|
@ -13,6 +13,7 @@ module Options.Applicative.Types (
|
||||
Parser(..),
|
||||
ParserFailure(..),
|
||||
OptHelpInfo(..),
|
||||
OptTree(..),
|
||||
|
||||
optVisibility,
|
||||
optMetaVar,
|
||||
@ -129,6 +130,12 @@ data OptHelpInfo = OptHelpInfo
|
||||
{ hinfoMulti :: Bool
|
||||
, hinfoDefault :: Bool }
|
||||
|
||||
data OptTree a
|
||||
= Leaf a
|
||||
| MultNode [OptTree a]
|
||||
| AltNode [OptTree a]
|
||||
deriving (Functor, Show)
|
||||
|
||||
optVisibility :: Option a -> OptVisibility
|
||||
optVisibility = propVisibility . optProps
|
||||
|
||||
|
@ -107,5 +107,20 @@ case_alt_cont = do
|
||||
Left _ -> return ()
|
||||
Right r -> assertFailure $ "unexpected result: " ++ show r
|
||||
|
||||
case_alt_help :: Assertion
|
||||
case_alt_help = do
|
||||
let p = p1 <|> p2 <|> p3
|
||||
p1 = (Just . Left)
|
||||
<$> strOption ( long "virtual-machine"
|
||||
& metavar "VM"
|
||||
& help "Virtual machine name" )
|
||||
p2 = (Just . Right)
|
||||
<$> strOption ( long "cloud-service"
|
||||
& metavar "CS"
|
||||
& help "Cloud service name" )
|
||||
p3 = flag' Nothing ( long "dry-run" )
|
||||
i = info (p <**> helper) idm
|
||||
checkHelpText "alt" i ["--help"]
|
||||
|
||||
main :: IO ()
|
||||
main = $(defaultMainGenerator)
|
||||
|
6
tests/alt.err.txt
Normal file
6
tests/alt.err.txt
Normal file
@ -0,0 +1,6 @@
|
||||
Usage: alt (--virtual-machine VM | --cloud-service CS | --dry-run)
|
||||
|
||||
Available options:
|
||||
--virtual-machine VM Virtual machine name
|
||||
--cloud-service CS Cloud service name
|
||||
-h,--help Show this help text
|
Loading…
Reference in New Issue
Block a user