Add biOption for two-argument options

src/Options/Applicative.hs

@@ -65,6 +65,8 @@ module Options.Applicative (
   strOption,
   option,
 
+  biOption,
+
   strArgument,
   argument,
 
@@ -93,6 +95,7 @@ module Options.Applicative (
   showDefaultWith,
   showDefault,
   metavar,
+  metavar2,
   noArgError,
   hidden,
   internal,
@@ -102,6 +105,7 @@ module Options.Applicative (
   completeWith,
   action,
   completer,
+  completer2,
   idm,
   mappend,
 
@@ -112,8 +116,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
@@ -91,12 +93,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
@@ -370,10 +391,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.

src/Options/Applicative/Extra.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GADTs #-}
 module Options.Applicative.Extra (
   -- * Extra parser utilities
   --
@@ -167,6 +168,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
@@ -193,6 +195,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
@@ -222,6 +225,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
@@ -282,8 +288,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

@@ -51,11 +51,14 @@ optDesc pprefs style _reachability opt =
         sort . optionNames . optMain $ opt
       meta =
         stringChunk $ optMetaVar opt
+      meta2 =
+        stringChunk $ optMetaVar2 opt
       descs =
         map (string . 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 =

src/Options/Applicative/Types.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification #-}
+{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification, GADTs #-}
 module Options.Applicative.Types (
   ParseError(..),
   ParserInfo(..),
@@ -44,6 +44,7 @@ module Options.Applicative.Types (
   filterOptional,
   optVisibility,
   optMetaVar,
+  optMetaVar2,
   optHelp,
   optShowDefault,
   optDescMod
@@ -72,6 +73,7 @@ data ParseError
   | UnknownError
   | MissingError IsCmdStart SomeParser
   | ExpectsArgError String
+  | ExpectsArgError2 String
   | UnexpectedError String SomeParser
 
 data IsCmdStart = CmdStart | CmdCont
@@ -152,17 +154,19 @@ data OptProperties = OptProperties
   { propVisibility :: OptVisibility       -- ^ whether this flag is shown in the brief description
   , propHelp :: Chunk Doc                 -- ^ help text for this option
   , propMetaVar :: String                 -- ^ metavariable for this option
+  , propMetaVar2 :: String                -- ^ second metavariable for this 'biOption'
   , propShowDefault :: Maybe String       -- ^ what to show in the help text as the default
   , propShowGlobal :: Bool                -- ^ whether the option is presented in global options text
   , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description
   }
 
 instance Show OptProperties where
-  showsPrec p (OptProperties pV pH pMV pSD pSG _)
+  showsPrec p (OptProperties pV pH pMV pMV2 pSD pSG _)
     = showParen (p >= 11)
     $ showString "OptProperties { propVisibility = " . shows pV
     . showString ", propHelp = " . shows pH
     . showString ", propMetaVar = " . shows pMV
+    . showString ", propMetaVar2 = " . shows pMV2
     . showString ", propShowDefault = " . shows pSD
     . showString ", propShowGlobal = " . shows pSG
     . showString ", propDescMod = _ }"
@@ -235,18 +239,24 @@ instance Functor CReader where
   fmap f (CReader c r) = CReader c (fmap f r)
 
 -- | An 'OptReader' defines whether an option matches an command line argument.
-data OptReader a
-  = OptReader [OptName] (CReader a) (String -> ParseError)
-  -- ^ option reader
-  | FlagReader [OptName] !a
-  -- ^ flag reader
-  | ArgReader (CReader a)
-  -- ^ argument reader
-  | CmdReader (Maybe String) [String] (String -> Maybe (ParserInfo a))
-  -- ^ command reader
+data OptReader a where
+  -- | option reader
+  OptReader :: [OptName] -> CReader a -> (String -> ParseError) -> OptReader a
+  -- | two-arg option reader
+  BiOptReader :: [OptName] -> CReader a -> CReader b -> (String -> ParseError) -> OptReader (a, b)
+  -- | fmap option reader
+  MapReader :: (a -> b) -> OptReader a -> OptReader b
+  -- | flag reader
+  FlagReader :: [OptName] -> !a -> OptReader a
+  -- | argument reader
+  ArgReader :: CReader a -> OptReader a
+  -- | command reader
+  CmdReader :: Maybe String -> [String] -> (String -> Maybe (ParserInfo a)) -> OptReader a
 
 instance Functor OptReader where
   fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e
+  fmap f r@BiOptReader {} = MapReader f r
+  fmap f (MapReader g r) = MapReader (f . g) r
   fmap f (FlagReader ns x) = FlagReader ns (f x)
   fmap f (ArgReader cr) = ArgReader (fmap f cr)
   fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)
@@ -437,6 +447,9 @@ optHelp  = propHelp . optProps
 optMetaVar :: Option a -> String
 optMetaVar = propMetaVar . optProps
 
+optMetaVar2 :: Option a -> String
+optMetaVar2 = propMetaVar2 . optProps
+
 optShowDefault :: Option a -> Maybe String
 optShowDefault = propShowDefault . optProps