Show alternatives in the brief help text.

Options/Applicative/Common.hs

@@ -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

Options/Applicative/Help.hs

@@ -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

Options/Applicative/Types.hs

@@ -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
 

tests/Tests.hs

@@ -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)

tests/alt.err.txt

@@ -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