Add biOption for two-argument options

src/Options/Applicative.hs

@@ -65,6 +65,8 @@ module Options.Applicative (
   strOption,
   option,
 
+  biOption,
+
   strArgument,
   argument,
 
@@ -94,6 +96,7 @@ module Options.Applicative (
   showDefaultWith,
   showDefault,
   metavar,
+  metavar2,
   noArgError,
   hidden,
   internal,
@@ -103,6 +106,7 @@ module Options.Applicative (
   completeWith,
   action,
   completer,
+  completer2,
   idm,
   mappend,
 
@@ -113,8 +117,10 @@ module Options.Applicative (
 
   HasName,
   HasCompleter,
+  HasCompleter2,
   HasValue,
   HasMetavar,
+  HasMetavar2,
   -- ** Readers
   --
   -- | A reader is used by the 'option' and 'argument' builders to parse

src/Options/Applicative/BashCompletion.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
 -- | You don't need to import this module to enable bash completion.
 --
 -- See
@@ -97,12 +99,19 @@ bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl ppre
     --
     -- For options and flags, ensure that the user
     -- hasn't disabled them with `--`.
+    opt_completions :: forall a. ArgPolicy -> ArgumentReachability -> Option a -> IO [String]
     opt_completions argPolicy reachability opt = case optMain opt of
       OptReader ns _ _
          | argPolicy /= AllPositionals
         -> return . add_opt_help opt $ show_names ns
          | otherwise
         -> return []
+      BiOptReader ns _ _ _
+         | argPolicy /= AllPositionals
+        -> return . add_opt_help opt $ show_names ns
+         | otherwise
+        -> return []
+      MapReader _f optr -> opt_completions argPolicy reachability (opt { optMain = optr })
       FlagReader ns _
          | argPolicy /= AllPositionals
         -> return . add_opt_help opt $ show_names ns

src/Options/Applicative/Builder.hs

@@ -28,6 +28,8 @@ module Options.Applicative.Builder (
   strOption,
   option,
 
+  biOption,
+
   -- * Modifiers
   short,
   long,
@@ -37,6 +39,7 @@ module Options.Applicative.Builder (
   showDefaultWith,
   showDefault,
   metavar,
+  metavar2,
   noArgError,
   ParseError(..),
   hidden,
@@ -47,6 +50,7 @@ module Options.Applicative.Builder (
   completeWith,
   action,
   completer,
+  completer2,
   idm,
   mappend,
 
@@ -102,8 +106,10 @@ module Options.Applicative.Builder (
 
   HasName,
   HasCompleter,
+  HasCompleter2,
   HasValue,
-  HasMetavar
+  HasMetavar,
+  HasMetavar2
   ) where
 
 import Control.Applicative
@@ -205,6 +211,13 @@ noArgError e = fieldMod $ \p -> p { optNoArgError = const e }
 metavar :: HasMetavar f => String -> Mod f a
 metavar var = optionMod $ \p -> p { propMetaVar = var }
 
+-- | Specify a metavariable for the second argument of a 'biOption'.
+--
+-- Metavariables have no effect on the actual parser, and only serve to specify
+-- the symbolic name for an argument to be displayed in the help text.
+metavar2 :: HasMetavar2 f => String -> Mod f a
+metavar2 var = optionMod $ \p -> p { propMetaVar2 = var }
+
 -- | Hide this option from the brief description.
 --
 -- Use 'internal' to hide the option from the help text too.
@@ -269,6 +282,14 @@ action = completer . bashCompleter
 completer :: HasCompleter f => Completer -> Mod f a
 completer f = fieldMod $ modCompleter (`mappend` f)
 
+-- | Add a completer to the second argument of a 'biOption'.
+--
+-- A completer is a function String -> IO String which, given a partial
+-- argument, returns all possible completions for that argument.
+completer2 :: HasCompleter2 f => Completer -> Mod f a
+completer2 f = fieldMod $ modCompleter2 (`mappend` f)
+
+
 -- parsers --
 
 -- | Builder for a command parser. The 'command' modifier can be used to
@@ -375,10 +396,26 @@ option :: ReadM a -> Mod OptionFields a -> Parser a
 option r m = mkParser d g rdr
   where
     Mod f d g = metavar "ARG" `mappend` m
-    fields = f (OptionFields [] mempty ExpectsArgError)
+    fields = f (OptionFields [] mempty mempty ExpectsArgError)
     crdr = CReader (optCompleter fields) r
     rdr = OptReader (optNames fields) crdr (optNoArgError fields)
 
+-- | Builder for a two-argument option using the given two readers.
+--
+-- It should always have either a @long@ or
+-- @short@ name specified in the modifiers (or both).
+--
+-- > nameParser = option str ( long "name" <> short 'n' )
+--
+biOption :: ReadM a -> ReadM b -> Mod OptionFields (a, b) -> Parser (a, b)
+biOption r r2 m = mkParser d g rdr
+  where
+    Mod f d g = metavar "ARG" `mappend` metavar2 "ARG" `mappend` m
+    fields = f (OptionFields [] mempty mempty ExpectsArgError2)
+    crdr = CReader (optCompleter fields) r
+    crdr2 = CReader (optCompleter2 fields) r2
+    rdr = BiOptReader (optNames fields) crdr crdr2 (optNoArgError fields)
+
 -- | Modifier for 'ParserInfo'.
 newtype InfoMod a = InfoMod
   { applyInfoMod :: ParserInfo a -> ParserInfo a }

src/Options/Applicative/Builder/Internal.hs

@@ -3,8 +3,10 @@ module Options.Applicative.Builder.Internal (
   Mod(..),
   HasName(..),
   HasCompleter(..),
+  HasCompleter2(..),
   HasValue(..),
   HasMetavar(..),
+  HasMetavar2(..),
   OptionFields(..),
   FlagFields(..),
   CommandFields(..),
@@ -35,6 +37,7 @@ import Options.Applicative.Types
 data OptionFields a = OptionFields
   { optNames :: [OptName]
   , optCompleter :: Completer
+  , optCompleter2 :: Completer
   , optNoArgError :: String -> ParseError }
 
 data FlagFields a = FlagFields
@@ -66,6 +69,12 @@ instance HasCompleter OptionFields where
 instance HasCompleter ArgumentFields where
   modCompleter f p = p { argCompleter = f (argCompleter p) }
 
+class HasCompleter2 f where
+  modCompleter2 :: (Completer -> Completer) -> f a -> f a
+
+instance HasCompleter2 OptionFields where
+  modCompleter2 f p = p { optCompleter2 = f (optCompleter2 p) }
+
 class HasValue f where
   -- this is just so that it is not necessary to specify the kind of f
   hasValueDummy :: f a -> ()
@@ -83,6 +92,11 @@ instance HasMetavar ArgumentFields where
 instance HasMetavar CommandFields where
   hasMetavarDummy _ = ()
 
+class HasMetavar2 f where
+  hasMetavar2Dummy :: f a -> ()
+instance HasMetavar2 OptionFields where
+  hasMetavar2Dummy _ = ()
+
 -- mod --
 
 data DefaultProp a = DefaultProp
@@ -145,6 +159,7 @@ instance Semigroup (Mod f a) where
 baseProps :: OptProperties
 baseProps = OptProperties
   { propMetaVar = ""
+  , propMetaVar2 = ""
   , propVisibility = Visible
   , propHelp = mempty
   , propShowDefault = Nothing

src/Options/Applicative/Common.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE Rank2Types #-}
 module Options.Applicative.Common (
   -- * Option parsers
@@ -68,6 +69,8 @@ showOption (OptShort n) = '-' : [n]
 
 optionNames :: OptReader a -> [OptName]
 optionNames (OptReader names _ _) = names
+optionNames (BiOptReader names _ _ _) = names
+optionNames (MapReader _f r) = optionNames r
 optionNames (FlagReader names _) = names
 optionNames _ = []
 
@@ -92,6 +95,23 @@ optMatches disambiguate opt (OptWord arg1 val) = case opt of
       put args'
       lift $ runReadM (withReadM (errorFor arg1) (crReader rdr)) arg'
 
+  BiOptReader names rdr rdr2 no_arg_err -> do
+    guard $ has_name arg1 names
+    Just $ do
+      args <- get
+      let mb_args = uncons $ maybeToList val ++ args
+      let missing_arg = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr)
+      (arg', args') <- maybe (lift missing_arg) return mb_args
+      let missing_arg2 = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr2)
+      (arg'', args'') <- maybe (lift missing_arg2) return (uncons args')
+      put args''
+      lift $ do
+        a <- runReadM (withReadM (errorFor arg1) (crReader rdr)) arg'
+        b <- runReadM (withReadM (errorFor arg1) (crReader rdr2)) arg''
+        pure (a, b)
+
+  MapReader f r -> fmap f <$> optMatches disambiguate r (OptWord arg1 val)
+
   FlagReader names x -> do
     guard $ has_name arg1 names
     -- #242 Flags/switches succeed incorrectly when given an argument.
@@ -167,6 +187,10 @@ searchArg prefs arg =
     when (isArg (optMain opt)) cut
     case optMain opt of
       CmdReader _ cs -> do
+        let
+          cmdMatches _
+            | prefDisambiguate prefs = snd <$> filter (isPrefixOf arg . fst) cs
+            | otherwise = maybeToList (lookup arg cs)
         subp <- hoistList (cmdMatches cs)
         case prefBacktrack prefs of
           NoBacktrack -> lift $ do
@@ -184,11 +208,6 @@ searchArg prefs arg =
         fmap pure . lift . lift $ runReadM (crReader rdr) arg
       _ -> mzero
 
-  where
-    cmdMatches cs
-      | prefDisambiguate prefs = snd <$> filter (isPrefixOf arg . fst) cs
-      | otherwise = maybeToList (lookup arg cs)
-
 stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String
            -> Parser a -> NondetT (StateT Args m) (Parser a)
 stepParser pprefs AllPositionals arg p =

src/Options/Applicative/Extra.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GADTs #-}
 module Options.Applicative.Extra (
   -- * Extra parser utilities
   --
@@ -198,6 +199,7 @@ parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn ->
       UnknownError       -> ExitFailure (infoFailureCode pinfo)
       MissingError {}    -> ExitFailure (infoFailureCode pinfo)
       ExpectsArgError {} -> ExitFailure (infoFailureCode pinfo)
+      ExpectsArgError2 {}-> ExitFailure (infoFailureCode pinfo)
       UnexpectedError {} -> ExitFailure (infoFailureCode pinfo)
       ShowHelpText {}    -> ExitSuccess
       InfoMsg {}         -> ExitSuccess
@@ -224,6 +226,7 @@ parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn ->
         else
           mempty
 
+    usage_help :: String -> [String] -> ParserInfo a -> ParserHelp
     usage_help progn names i = case msg of
       InfoMsg _
         -> mempty
@@ -253,6 +256,9 @@ parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn ->
       ExpectsArgError x
         -> stringChunk $ "The option `" ++ x ++ "` expects an argument."
 
+      ExpectsArgError2 x
+        -> stringChunk $ "The option `" ++ x ++ "` expects two arguments."
+
       UnexpectedError arg _
         -> stringChunk msg'
           where
@@ -313,8 +319,12 @@ parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn ->
             -- things the user could type. If it's a command
             -- reader also ensure that it can be immediately
             -- reachable from where the error was given.
+            opt_completions :: ArgumentReachability -> Option a -> [String]
             opt_completions reachability opt = case optMain opt of
               OptReader ns _ _ -> fmap showOption ns
+              BiOptReader ns _ _ _ ->
+                                  fmap showOption ns
+              MapReader _f r   -> opt_completions reachability (opt { optMain = r })
               FlagReader ns _  -> fmap showOption ns
               ArgReader _      -> []
               CmdReader _ ns    | argumentIsUnreachable reachability

src/Options/Applicative/Help/Core.hs

@@ -56,11 +56,14 @@ optDesc pprefs style _reachability opt =
         sort . optionNames . optMain $ opt
       meta =
         stringChunk $ optMetaVar opt
+      meta2 =
+        stringChunk $ optMetaVar2 opt
       descs =
         map (pretty . showOption) names
       descriptions =
         listToChunk (intersperse (descSep style) descs)
       desc
+        | not (isEmpty meta) && not (isEmpty meta2) = descriptions <<+>> meta <<+>> meta2
         | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names) =
           descriptions <> stringChunk "=" <> meta
         | otherwise =