Merge bash-completion feature (#10).

CHANGELOG

@@ -1,3 +1,9 @@
+## Version 0.3.2 (31 Jul 2012)
+
+- Fixed bug where both branches of an alternative could be matched.
+
+- Improved brief help text for alternatives.
+
 ## Version 0.3.1 (30 Jul 2012)
 
 - Added new `showDefault` and `showDefaultWith` modifiers, which will result in

Options/Applicative/Builder.hs

@@ -287,7 +287,7 @@ argument p (Mod f d g) = mkParser d g (ArgReader rdr)
 -- command line, all following arguments are included in the result, even if
 -- they start with @'-'@.
 arguments :: (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a]
-arguments p m = args1 <|> pure (fromMaybe [] def)
+arguments p m = set_default <$> fromM args
   where
     Mod f (DefaultProp def sdef) g = m
     show_def = sdef <*> def
@@ -298,10 +298,15 @@ arguments p m = args1 <|> pure (fromMaybe [] def)
     props = mkProps mempty g
     props' = (mkProps mempty g) { propShowDefault = show_def }
 
-    args1 = ((Just <$> arg') <|> (ddash *> pure Nothing)) `BindP` \x -> case x of
-      Nothing -> many arg
-      Just a -> fmap (a:) args
-    args = args1 <|> pure []
+    args = do
+      mx <- oneM $ optional arg_or_ddash
+      case mx of
+        Nothing       -> return []
+        Just Nothing  -> manyM arg
+        Just (Just x) -> (x:) <$> args
+    arg_or_ddash = (Just <$> arg') <|> (ddash *> pure Nothing)
+    set_default [] = fromMaybe [] def
+    set_default xs = xs
 
     arg = liftOpt (Option (ArgReader (CReader compl p)) props)
     arg' = liftOpt (Option (ArgReader (CReader compl p')) props')
@@ -348,8 +353,9 @@ switch = flag False True
 -- | Builder for an option with a null reader. A non-trivial reader can be
 -- added using the 'reader' modifier.
 nullOption :: Mod OptionFields a -> Parser a
-nullOption (Mod f d g) = mkParser d g rdr
+nullOption m = mkParser d g rdr
   where
+    Mod f d g = metavar "ARG" <> m
     fields = f (OptionFields [] mempty disabled)
     crdr = CReader (optCompleter fields) (optReader fields)
     rdr = OptReader (optNames fields) crdr

Options/Applicative/Common.hs

@@ -42,6 +42,7 @@ module Options.Applicative.Common (
   runP,
   setContext,
   mapParser,
+  treeMapParser,
   optionNames
   ) where
 
@@ -123,10 +124,8 @@ stepParser (MultP p1 p2) arg args = msum
   , do (p2', args') <- stepParser p2 arg args
        return (p1 <*> p2', args') ]
 stepParser (AltP p1 p2) arg args = msum
-  [ do (p1', args') <- stepParser p1 arg args
-       return (p1' <|> p2, args')
-  , do (p2', args') <- stepParser p2 arg args
-       return (p1 <|> p2', args') ]
+  [ stepParser p1 arg args
+  , stepParser p2 arg args ]
 stepParser (BindP p k) arg args = do
   (p', args') <- stepParser p arg args
   x <- liftMaybe $ evalParser p'
@@ -162,21 +161,50 @@ 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.
-mapParser :: (forall x . OptHelpInfo -> Option x -> b)
+-- the results in a list.
+mapParser :: (forall x. OptHelpInfo -> Option x -> b)
+              -> Parser a -> [b]
+mapParser f = flatten . treeMapParser f
+  where
+    flatten (Leaf x) = [x]
+    flatten (MultNode xs) = xs >>= flatten
+    flatten (AltNode xs) = xs >>= flatten
+
+-- | Like 'mapParser', but collect the results in a tree structure.
+treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)
           -> Parser a
-          -> [b]
-mapParser = go False False
+          -> OptTree b
+treeMapParser g = simplify . go False False g
   where
     has_default :: Parser a -> Bool
     has_default p = isJust (evalParser p)
 
     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]

Options/Applicative/Extra.hs

@@ -68,28 +68,28 @@ execParserPure pprefs pinfo args =
       Extra failure -> Left failure
     (Left msg, ctx) -> Left ParserFailure
       { errMessage = \progn
-          -> with_context ctx pinfo $ \name ->
+          -> with_context ctx pinfo $ \names ->
                  return
                . parserHelpText pprefs
                . add_error msg
-               . add_usage name progn
+               . add_usage names progn
       , errExitCode = ExitFailure (infoFailureCode pinfo) }
   where
     parser = infoParser pinfo
-    add_usage name progn i = i
+    add_usage names progn i = i
       { infoHeader = vcat
           [ infoHeader i
           , usage pprefs (infoParser i) ename ] }
       where
-        ename = maybe progn (\n -> progn ++ " " ++ n) name
+        ename = unwords (progn : names)
     add_error msg i = i
       { infoHeader = vcat [msg, infoHeader i] }
 
     with_context :: Context
                  -> ParserInfo a
-                 -> (forall b . Maybe String -> ParserInfo b -> c)
+                 -> (forall b . [String] -> ParserInfo b -> c)
                  -> c
-    with_context NullContext i f = f Nothing i
+    with_context NullContext i f = f [] i
     with_context (Context n i) _ f = f n i
 
     parser' = (Extra <$> bashCompletionParser parser) <|> (Result <$> parser)

Options/Applicative/Help.hs

@@ -66,13 +66,19 @@ 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 . treeMapParser (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

Options/Applicative/Internal.hs

@@ -40,18 +40,22 @@ class (Alternative m, MonadPlus m) => MonadP m where
 type P = ErrorT String (Writer Context)
 
 data Context where
-  Context :: Maybe String -> ParserInfo a -> Context
+  Context :: [String] -> ParserInfo a -> Context
   NullContext :: Context
 
+contextNames :: Context -> [String]
+contextNames (Context ns _) = ns
+contextNames NullContext = []
+
 instance Monoid Context where
   mempty = NullContext
-  mappend _ c@(Context _ _) = c
+  mappend c (Context ns i) = Context (contextNames c ++ ns) i
   mappend c _ = c
 
 instance MonadP P where
   type PError P = String
 
-  setContext name = lift . tell . Context name
+  setContext name = lift . tell . Context (maybeToList name)
   setParser _ _ = return ()
 
   missingArgP _ = empty

Options/Applicative/Types.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE GADTs, DeriveFunctor #-}
+{-# LANGUAGE GADTs, DeriveFunctor, Rank2Types #-}
 module Options.Applicative.Types (
   ParserInfo(..),
   ParserPrefs(..),
@@ -10,9 +10,15 @@ module Options.Applicative.Types (
   OptVisibility(..),
   CReader(..),
   Parser(..),
+  ParserM(..),
   Completer(..),
   ParserFailure(..),
   OptHelpInfo(..),
+  OptTree(..),
+
+  fromM,
+  oneM,
+  manyM,
 
   optVisibility,
   optMetaVar,
@@ -21,6 +27,7 @@ module Options.Applicative.Types (
   ) where
 
 import Control.Applicative
+import Control.Monad
 import Control.Monad.Trans.Error
 import Data.Monoid
 import System.Exit
@@ -97,11 +104,38 @@ instance Applicative Parser where
   pure = NilP . Just
   (<*>) = MultP
 
+newtype ParserM r = ParserM
+  { runParserM :: forall x . (r -> Parser x) -> Parser x }
+
+instance Monad ParserM where
+  return x = ParserM $ \k -> k x
+  ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)
+
+instance Functor ParserM where
+  fmap = liftM
+
+instance Applicative ParserM where
+  pure = return
+  (<*>) = ap
+
+fromM :: ParserM a -> Parser a
+fromM (ParserM f) = f pure
+
+oneM :: Parser a -> ParserM a
+oneM p = ParserM (BindP p)
+
+manyM :: Parser a -> ParserM [a]
+manyM p = do
+  mx <- oneM (optional p)
+  case mx of
+    Nothing -> return []
+    Just x -> (x:) <$> manyM p
+
 instance Alternative Parser where
   empty = NilP Nothing
   (<|>) = AltP
-  many p = some p <|> pure []
-  some p = p `BindP` (\r -> (r:) <$> many p)
+  many p = fromM $ manyM p
+  some p = fromM $ (:) <$> oneM p <*> manyM p
 
 newtype Completer = Completer
   { runCompleter :: String -> IO [String] }
@@ -127,6 +161,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

@@ -100,5 +100,47 @@ case_show_default = do
         msg
     Right r  -> assertFailure $ "unexpected result: " ++ show r
 
+case_alt_cont :: Assertion
+case_alt_cont = do
+  let p = Alternatives.a <|> Alternatives.b
+      i = info p idm
+      result = run i ["-a", "-b"]
+  case result of
+    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"]
+
+case_nested_commands :: Assertion
+case_nested_commands = do
+  let p3 = strOption (short 'a' & metavar "A")
+      p2 = subparser (command "b" (info p3 idm))
+      p1 = subparser (command "c" (info p2 idm))
+      i = info (p1 <**> helper) idm
+  checkHelpText "nested" i ["c", "b"]
+
+case_many_args :: Assertion
+case_many_args = do
+  let p = arguments str idm
+      i = info p idm
+      nargs = 20000
+      result = run i (replicate nargs "foo")
+  case result of
+    Left _ -> assertFailure "unexpected parse error"
+    Right xs -> nargs @=? length xs
+
 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

tests/nested.err.txt

@@ -0,0 +1 @@
+Usage: nested c b -a A