diff --git a/src/Options/Applicative.hs b/src/Options/Applicative.hs index 662134bb..56a99a0e 100644 --- a/src/Options/Applicative.hs +++ b/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 diff --git a/src/Options/Applicative/BashCompletion.hs b/src/Options/Applicative/BashCompletion.hs index b010c7df..2aefc901 100644 --- a/src/Options/Applicative/BashCompletion.hs +++ b/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 diff --git a/src/Options/Applicative/Builder.hs b/src/Options/Applicative/Builder.hs index 3d919be2..1fdf0095 100644 --- a/src/Options/Applicative/Builder.hs +++ b/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 } diff --git a/src/Options/Applicative/Builder/Internal.hs b/src/Options/Applicative/Builder/Internal.hs index e5bc4b63..c43b581c 100644 --- a/src/Options/Applicative/Builder/Internal.hs +++ b/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 diff --git a/src/Options/Applicative/Common.hs b/src/Options/Applicative/Common.hs index 46d2b730..8d39678d 100644 --- a/src/Options/Applicative/Common.hs +++ b/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. diff --git a/src/Options/Applicative/Extra.hs b/src/Options/Applicative/Extra.hs index 36ac963a..06248f39 100644 --- a/src/Options/Applicative/Extra.hs +++ b/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 diff --git a/src/Options/Applicative/Help/Core.hs b/src/Options/Applicative/Help/Core.hs index 9560fcec..a27cbae9 100644 --- a/src/Options/Applicative/Help/Core.hs +++ b/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 = diff --git a/src/Options/Applicative/Types.hs b/src/Options/Applicative/Types.hs index ee0636b6..6db2b4de 100644 --- a/src/Options/Applicative/Types.hs +++ b/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 diff --git a/tests/test.hs b/tests/test.hs index 3c8bf6a4..9ed8059c 100644 --- a/tests/test.hs +++ b/tests/test.hs @@ -891,6 +891,110 @@ prop_help_unknown_context = once $ post = run i ["--help", "not-a-command"] in grabHelpMessage pre === grabHelpMessage post +prop_biOption_example :: Property +prop_biOption_example = once $ + let p = biOption str str ( short 'p' <> metavar "KEY" <> metavar2 "VALUE" ) + i = info (p <**> helper) idm + result = run i ["-p", "foo", "bar"] + in assertResult result (("foo", "bar") ===) + +prop_biOption_example_many :: Property +prop_biOption_example_many = once $ + let p = many (biOption str auto ( long "option" )) + i = info (p <**> helper) idm + result = run i ["--option", "one", "1", "--option", "two", "2"] + in assertResult result ([("one", 1), ("two", 2 :: Int)] ===) + +prop_biOption_fail_zero :: Property +prop_biOption_fail_zero = once $ + let p :: Parser (String, String) + p = biOption str str (long "option") + i = info (p <**> helper) briefDesc + result = run i ["--help"] + in assertError result $ \failure -> + let text = head . lines . fst $ renderFailure failure "test" + in "Usage: test --option ARG ARG" === text + +prop_kvOption_fail_zero :: Property +prop_kvOption_fail_zero = once $ + let p :: Parser (String, String) + p = biOption str str (long "option" <> metavar "KEY" <> metavar2 "VALUE") + i = info (p <**> helper) briefDesc + result = run i ["--help"] + in assertError result $ \failure -> + let text = head . lines . fst $ renderFailure failure "test" + in "Usage: test --option KEY VALUE" === text + +prop_many_kvOption_fail_zero :: Property +prop_many_kvOption_fail_zero = once $ + let p :: Parser [(String, String)] + p = many $ biOption str str (long "option" <> metavar "KEY" <> metavar2 "VALUE") + i = info (p <**> helper) briefDesc + result = run i ["--help"] + in assertError result $ \failure -> + let text = head . lines . fst $ renderFailure failure "test" + in "Usage: test [--option KEY VALUE]" === text + +prop_strOption_fail_zero :: Property +prop_strOption_fail_zero = once $ + let p :: Parser String + p = strOption (long "option") + i = info (p <**> helper) briefDesc + result = run i ["--help"] + in assertError result $ \failure -> + let text = head . lines . fst $ renderFailure failure "test" + in "Usage: test --option ARG" === text + +prop_completion_biOption_option :: Property +prop_completion_biOption_option = once . ioProperty $ + let p :: Parser (String,String) + p = biOption str str (long "option" <> completeWith ["key"] <> completer2 (listCompleter ["value"])) + i = info p idm + result = run i + [ "--bash-completion-index", "1" + ] + in case result of + CompletionInvoked (CompletionResult err) -> do + completions <- lines <$> err "test" + return $ ["--option"] === completions + Failure _ -> return $ counterexample "unexpected failure" failed + Success val -> return $ counterexample ("unexpected result " ++ show val) failed + +prop_completion_biOption_first_value :: Property +prop_completion_biOption_first_value = once . ioProperty $ + let p :: Parser (String,String) + p = biOption str str (long "option" <> completeWith ["key"] <> completer2 (listCompleter ["value"])) <* many (strArgument mempty :: Parser String) + i = info p idm + result = run i + [ "--bash-completion-word", "test" + , "--bash-completion-word", "--option" + , "--bash-completion-index", "2" + ] + in case result of + CompletionInvoked (CompletionResult err) -> do + completions <- lines <$> err "test" + return $ ["key"] === completions + Failure _ -> return $ counterexample "unexpected failure" failed + Success val -> return $ counterexample ("unexpected result " ++ show val) failed + +prop_completion_biOption_second_value :: Property +prop_completion_biOption_second_value = once . ioProperty $ + let p :: Parser (String,String) + p = biOption str str (short 'o' <> completeWith ["key"] <> completer2 (listCompleter ["value"])) + i = info p idm + result = run i + [ "--bash-completion-word", "test" + , "--bash-completion-word", "-o" + , "--bash-completion-word", "key" + , "--bash-completion-index", "3" + ] + in case result of + CompletionInvoked (CompletionResult err) -> do + completions <- lines <$> err "test" + return $ ["value"] === completions + Failure _ -> return $ counterexample "unexpected failure" failed + Success val -> return $ counterexample ("unexpected result " ++ show val) failed + --- deriving instance Arbitrary a => Arbitrary (Chunk a)