diff --git a/Options/Applicative/Builder.hs b/Options/Applicative/Builder.hs --- a/Options/Applicative/Builder.hs +++ b/Options/Applicative/Builder.hs @@ -19,13 +19,14 @@ -- creates a parser for an option called \"output\". subparser, argument, - argument', arguments, arguments1, flag, flag', switch, nullOption, + abortOption, + infoOption, strOption, option, @@ -38,6 +39,7 @@ showDefault, metavar, reader, + eitherReader, noArgError, ParseError(..), hidden, @@ -59,6 +61,8 @@ auto, str, disabled, + readerAbort, + readerError, -- * Builder for 'ParserInfo' InfoMod, @@ -76,17 +80,19 @@ disambiguate, showHelpOnError, noBacktrack, + noIntersperse, prefs, -- * Types Mod, + ReadM, OptionFields, FlagFields, ArgumentFields, CommandFields ) where -import Control.Applicative (pure, (<|>)) +import Control.Applicative (pure, (<|>), many, some) import Data.Monoid (Monoid (..) #if __GLASGOW_HASKELL__ > 702 , (<>) @@ -94,7 +100,6 @@ ) import Options.Applicative.Builder.Completer -import Options.Applicative.Builder.Arguments import Options.Applicative.Builder.Internal import Options.Applicative.Common import Options.Applicative.Types @@ -145,6 +150,10 @@ reader :: (String -> ReadM a) -> Mod OptionFields a reader f = fieldMod $ \p -> p { optReader = f } +-- | Specify the 'Option' reader as a function in the 'Either' monad. +eitherReader :: (String -> Either String a) -> Mod OptionFields a +eitherReader f = reader (either readerError return . f) + -- | Specify the error to display when no argument is provided to this option. noArgError :: ParseError -> Mod OptionFields a noArgError e = fieldMod $ \p -> p { optNoArgError = e } @@ -191,6 +200,22 @@ Mod _ d g = m `mappend` metavar "COMMAND" rdr = uncurry CmdReader (mkCommand m) +-- | Builder for an argument parser. +argument :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a +argument p (Mod f d g) = mkParser d g (ArgReader rdr) + where + ArgumentFields compl = f (ArgumentFields mempty) + rdr = CReader compl p + +-- | Builder for an argument list parser. All arguments are collected and +-- returned as a list. +arguments :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a] +arguments r m = many (argument r m) + +-- | Like `arguments`, but require at least one argument. +arguments1 :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser [a] +arguments1 r m = some (argument r m) + -- | Builder for a flag parser. -- -- A flag that switches from a \"default value\" to an \"active value\" when @@ -236,6 +261,23 @@ crdr = CReader (optCompleter fields) (optReader fields) rdr = OptReader (optNames fields) crdr (optNoArgError fields) +-- | An option that always fails. +-- +-- When this option is encountered, the option parser immediately aborts with +-- the given parse error. If you simply want to output a message, use +-- 'infoOption' instead. +abortOption :: ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a) +abortOption err m = nullOption . (<> m) $ mconcat + [ reader (const (ReadM (Left err))) + , noArgError err + , value id + , metavar "" + , hidden ] + +-- | An option that always fails and displays a message. +infoOption :: String -> Mod OptionFields (a -> a) -> Parser (a -> a) +infoOption = abortOption . InfoMsg + -- | Builder for an option taking a 'String' argument. strOption :: Mod OptionFields String -> Parser String strOption m = nullOption $ reader str `mappend` m @@ -307,6 +349,9 @@ noBacktrack :: PrefsMod noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False } +noIntersperse :: PrefsMod +noIntersperse = PrefsMod $ \p -> p { prefIntersperse = False } + prefs :: PrefsMod -> ParserPrefs prefs m = applyPrefsMod m base where @@ -314,7 +359,8 @@ { prefMultiSuffix = "" , prefDisambiguate = False , prefShowHelpOnError = False - , prefBacktrack = True } + , prefBacktrack = True + , prefIntersperse = True } -- convenience shortcuts diff --git a/Options/Applicative/Builder/Arguments.hs b/Options/Applicative/Builder/Arguments.hs deleted file mode 100644 --- a/Options/Applicative/Builder/Arguments.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Options.Applicative.Builder.Arguments - ( argument - , argument' - , arguments - , arguments1 - ) where - -import Control.Applicative ((<$>), pure, (<*>), optional, (<|>), (*>)) -import Control.Monad (guard) -import Data.Maybe (fromMaybe) -import Data.Monoid (mempty) - -import Options.Applicative.Builder.Internal -import Options.Applicative.Common -import Options.Applicative.Types - -skipOpts :: (String -> Maybe a) -> String -> Maybe a -skipOpts _ ('-':_) = Nothing -skipOpts rdr s = rdr s - --- | Builder for an argument parser. -argument' :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a -argument' p (Mod f d g) = mkParser d g (ArgReader rdr) - where - ArgumentFields compl = f (ArgumentFields mempty) - rdr = CReader compl p - --- | Builder for an argument parser ignoring arguments starting with '-'. -argument :: (String -> Maybe a) -> Mod ArgumentFields a -> Parser a -argument p = argument' (skipOpts p) - --- | Builder for an argument list parser. All arguments are collected and --- returned as a list. --- --- Note that arguments starting with @'-'@ are ignored. --- --- This parser accepts a special argument: @--@. When a @--@ is found on the --- 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 = arguments_ True - --- | Like `arguments`, but require at least one argument. -arguments1 :: (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a] -arguments1 = arguments_ False - --- | Builder for an argument list parser. All arguments are collected and --- returned as a list. --- --- Note that arguments starting with @'-'@ are ignored. --- --- This parser accepts a special argument: @--@. When a @--@ is found on the --- command line, all following arguments are included in the result, even if --- they start with @'-'@. -arguments_ :: Bool -> (String -> Maybe a) -> Mod ArgumentFields [a] -> Parser [a] -arguments_ allow_empty p m = set_default <$> fromM args1 - where - Mod f (DefaultProp def sdef) g = m - show_def = sdef <*> def - - props = mkProps mempty g - props' = (mkProps mempty g) { propShowDefault = show_def } - - args1 | allow_empty = args - | otherwise = do - mx <- oneM arg_or_ddash - case mx of - Nothing -> someM arg - Just x -> (x:) <$> args - 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 (skipOpts p))) props') - - ddash = argument' (guard . (== "--")) internal - - ArgumentFields compl = f (ArgumentFields mempty) diff --git a/Options/Applicative/Builder/Completer.hs b/Options/Applicative/Builder/Completer.hs --- a/Options/Applicative/Builder/Completer.hs +++ b/Options/Applicative/Builder/Completer.hs @@ -22,8 +22,7 @@ bashCompleter :: String -> Completer bashCompleter action = Completer $ \word -> do - let cmd = unwords ["compgen", "-A", action, word] - + let cmd = unwords ["compgen", "-A", action, "--", word] result <- tryIO $ readProcess "bash" ["-c", cmd] "" return . lines . either (const []) id $ result diff --git a/Options/Applicative/Common.hs b/Options/Applicative/Common.hs --- a/Options/Applicative/Common.hs +++ b/Options/Applicative/Common.hs @@ -45,12 +45,12 @@ optionNames ) where -import Control.Applicative (pure, (<*>), (<$>), (<|>)) -import Control.Monad (guard, mzero, msum, when) +import Control.Applicative (pure, (<*>), (<$>), (<|>), (<$)) +import Control.Monad (guard, mzero, msum, when, liftM, MonadPlus) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT(..), get, put, runStateT) import Data.List (isPrefixOf) -import Data.Maybe (maybeToList, isJust) +import Data.Maybe (maybeToList, isJust, isNothing) import Data.Monoid (Monoid(..)) import Options.Applicative.Internal @@ -85,10 +85,28 @@ type Args = [String] -optMatches :: MonadP m => Bool -> OptReader a -> String -> Maybe (StateT Args m a) -optMatches disambiguate opt arg = case opt of +argMatches :: MonadP m => OptReader a -> String + -> Maybe (StateT Args m a) +argMatches opt arg = case opt of + ArgReader rdr -> do + result <- crReader rdr arg + Just $ return result + CmdReader _ f -> + flip fmap (f arg) $ \subp -> StateT $ \args -> do + setContext (Just arg) subp + prefs <- getPrefs + let runSubparser + | prefBacktrack prefs = \p a -> do + policy <- getPolicy + runParser policy p a + | otherwise = \p a + -> (,) <$> runParserFully p a <*> pure [] + runSubparser (infoParser subp) args + _ -> Nothing + +optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a) +optMatches disambiguate opt (OptWord arg1 val) = case opt of OptReader names rdr no_arg_err -> do - (arg1, val) <- parsed guard $ has_name arg1 names Just $ do args <- get @@ -100,38 +118,15 @@ Left e -> lift $ errorFor arg1 e Right r -> return r FlagReader names x -> do - (arg1, Nothing) <- parsed guard $ has_name arg1 names + guard $ isNothing val Just $ return x - ArgReader rdr -> do - result <- crReader rdr arg - Just $ return result - CmdReader _ f -> - flip fmap (f arg) $ \subp -> StateT $ \args -> do - setContext (Just arg) subp - prefs <- getPrefs - let runSubparser - | prefBacktrack prefs = runParser - | otherwise = \p a - -> (,) <$> runParserFully p a <*> pure [] - runSubparser (infoParser subp) args + _ -> Nothing where errorFor name (ErrorMsg msg) = errorP (ErrorMsg ("option " ++ showOption name ++ ": " ++ msg)) errorFor _ e = errorP e - parsed = - case arg of - '-' : '-' : arg1 -> - Just $ - case span (/= '=') arg1 of - (_, "") -> (OptLong arg1, Nothing) - (arg1', _ : rest) -> (OptLong arg1', Just rest) - '-' : arg1 -> - case arg1 of - [] -> Nothing - (a : rest) -> Just (OptShort a, if null rest then Nothing else Just rest) - _ -> Nothing has_name a | disambiguate = any (isOptionPrefix a) | otherwise = elem a @@ -140,51 +135,89 @@ isArg (ArgReader _) = True isArg _ = False -stepParser :: MonadP m => ParserPrefs -> String -> Parser a - -> NondetT (StateT Args m) (Parser a) -stepParser _ _ (NilP _) = mzero -stepParser prefs arg (OptP opt) = do - when (isArg (optMain opt)) cut - case optMatches disambiguate (optMain opt) arg of - Just matcher -> pure <$> lift matcher - Nothing -> mzero - where - disambiguate = prefDisambiguate prefs - && optVisibility opt > Internal -stepParser prefs arg (MultP p1 p2) = foldr1 () - [ do p1' <- stepParser prefs arg p1 +data OptWord = OptWord OptName (Maybe String) + +parseWord :: String -> Maybe OptWord +parseWord ('-' : '-' : w) = Just $ let + (opt, arg) = case span (/= '=') w of + (_, "") -> (w, Nothing) + (w', _ : rest) -> (w', Just rest) + in OptWord (OptLong opt) arg +parseWord ('-' : w) = case w of + [] -> Nothing + (a : rest) -> Just $ let + arg = rest <$ guard (not (null rest)) + in OptWord (OptShort a) arg +parseWord _ = Nothing + +searchParser :: Monad m + => (forall r . Option r -> NondetT m r) + -> Parser a -> NondetT m (Parser a) +searchParser _ (NilP _) = mzero +searchParser f (OptP opt) = liftM pure (f opt) +searchParser f (MultP p1 p2) = foldr1 () + [ do p1' <- searchParser f p1 return (p1' <*> p2) - , do p2' <- stepParser prefs arg p2 + , do p2' <- searchParser f p2 return (p1 <*> p2') ] -stepParser prefs arg (AltP p1 p2) = msum - [ stepParser prefs arg p1 - , stepParser prefs arg p2 ] -stepParser prefs arg (BindP p k) = do - p' <- stepParser prefs arg p - x <- hoistMaybe $ evalParser p' +searchParser f (AltP p1 p2) = msum + [ searchParser f p1 + , searchParser f p2 ] +searchParser f (BindP p k) = do + p' <- searchParser f p + x <- hoistMaybe (evalParser p') return (k x) +searchOpt :: MonadP m => ParserPrefs -> OptWord -> Parser a + -> NondetT (StateT Args m) (Parser a) +searchOpt pprefs w = searchParser $ \opt -> do + let disambiguate = prefDisambiguate pprefs + && optVisibility opt > Internal + case optMatches disambiguate (optMain opt) w of + Just matcher -> lift matcher + Nothing -> mzero + +searchArg :: MonadP m => String -> Parser a + -> NondetT (StateT Args m) (Parser a) +searchArg arg = searchParser $ \opt -> do + when (isArg (optMain opt)) cut + case argMatches (optMain opt) arg of + Just matcher -> lift matcher + Nothing -> mzero + +data ArgPolicy + = SkipOpts + | AllowOpts + deriving Eq + +stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String + -> Parser a -> NondetT (StateT Args m) (Parser a) +stepParser pprefs SkipOpts arg p = case parseWord arg of + Just w -> searchOpt pprefs w p + Nothing -> searchArg arg p +stepParser pprefs AllowOpts arg p = msum + [ searchArg arg p + , do w <- hoistMaybe (parseWord arg) + searchOpt pprefs w p ] + -- | Apply a 'Parser' to a command line, and return a result and leftover -- arguments. This function returns an error if any parsing error occurs, or -- if any options are missing and don't have a default value. -runParser :: MonadP m => Parser a -> Args -> m (a, Args) -runParser p args = case args of +runParser :: MonadP m => ArgPolicy -> Parser a -> Args -> m (a, Args) +runParser policy p args = case args of [] -> exitP p result + ("--" : argt) -> runParser AllowOpts p argt (arg : argt) -> do prefs <- getPrefs - x <- do_step prefs arg argt - case x of - Left e -> case (result, e) of - (Just r, ErrorMsg _) -> return r - _ -> errorP e - Right (p', args') -> runParser p' args' + (mp', args') <- do_step prefs arg argt + case mp' of + Nothing -> hoistMaybe result <|> parseError arg + Just p' -> runParser policy p' args' where result = (,) <$> evalParser p <*> pure args - do_step prefs arg argt = tryP - . (`runStateT` argt) - . (>>= maybe ((lift . parseError) arg) return) + do_step prefs arg argt = (`runStateT` argt) . disamb (not (prefDisambiguate prefs)) - $ stepParser prefs arg p + $ stepParser prefs policy arg p parseError :: MonadP m => String -> m a parseError arg = errorP . ErrorMsg $ msg @@ -193,9 +226,17 @@ ('-':_) -> "Invalid option `" ++ arg ++ "'" _ -> "Invalid argument `" ++ arg ++ "'" +getPolicy :: MonadP m => m ArgPolicy +getPolicy = do + prefs <- getPrefs + return $ if prefIntersperse prefs + then SkipOpts + else AllowOpts + runParserFully :: MonadP m => Parser a -> Args -> m a runParserFully p args = do - (r, args') <- runParser p args + policy <- getPolicy + (r, args') <- runParser policy p args guard $ null args' return r diff --git a/Options/Applicative/Extra.hs b/Options/Applicative/Extra.hs --- a/Options/Applicative/Extra.hs +++ b/Options/Applicative/Extra.hs @@ -6,8 +6,10 @@ helper, hsubparser, execParser, - execParserPure, + execParserMaybe, customExecParser, + customExecParserMaybe, + execParserPure, usage, ParserFailure(..), ) where @@ -29,15 +31,10 @@ -- | A hidden \"helper\" option which always fails. helper :: Parser (a -> a) -helper = nullOption $ mconcat - [ long "help" - , reader (const (ReadM (Left ShowHelpText))) - , noArgError ShowHelpText - , short 'h' - , help "Show this help text" - , value id - , metavar "" - , hidden ] +helper = abortOption ShowHelpText $ mconcat + [ long "help" + , short 'h' + , help "Show this help text" ] hsubparser :: Mod CommandFields a -> Parser a hsubparser m = mkParser d g rdr @@ -70,10 +67,28 @@ _ -> hPutStr stderr msg exitWith c +-- | Run a program description in pure code. +-- +-- This function behaves like 'execParser', but can be called from pure code. +-- Note that, in case of errors, no message is displayed, and this function +-- simply returns 'Nothing'. +-- +-- If you need to keep track of error messages, use 'execParserPure' instead. +execParserMaybe :: ParserInfo a -> [String] -> Maybe a +execParserMaybe = customExecParserMaybe (prefs idm) + +-- | Run a program description with custom preferences in pure code. +-- +-- See 'execParserMaybe' for details. +customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a +customExecParserMaybe pprefs pinfo + = either (const Nothing) Just + . execParserPure pprefs pinfo + data Result a = Result a | Extra ParserFailure --- | A pure version 'execParser'. +-- | The most general way to run a program description in pure code. execParserPure :: ParserPrefs -- ^ Global preferences for this parser -> ParserInfo a -- ^ Description of the program to run -> [String] -- ^ Program arguments @@ -101,12 +116,14 @@ . show_help . add_error . add_usage names progn - , errExitCode = ExitFailure (infoFailureCode pinfo) } + , errExitCode = exit_code } where - add_usage names progn i = i - { infoHeader = vcat - ( header_line i ++ - [ usage pprefs (infoParser i) ename ] ) } + add_usage names progn i = case msg of + InfoMsg _ -> i + _ -> i + { infoHeader = vcat + ( header_line i ++ + [ usage pprefs (infoParser i) ename ] ) } where ename = unwords (progn : names) add_error i = i @@ -114,6 +131,10 @@ error_msg = case msg of ShowHelpText -> [] ErrorMsg m -> [m] + InfoMsg m -> [m] + exit_code = case msg of + InfoMsg _ -> ExitSuccess + _ -> ExitFailure (infoFailureCode pinfo) show_full_help = case msg of ShowHelpText -> True _ -> prefShowHelpOnError pprefs diff --git a/Options/Applicative/Types.hs b/Options/Applicative/Types.hs --- a/Options/Applicative/Types.hs +++ b/Options/Applicative/Types.hs @@ -10,6 +10,8 @@ OptProperties(..), OptVisibility(..), ReadM(..), + readerAbort, + readerError, CReader(..), Parser(..), ParserM(..), @@ -39,6 +41,7 @@ data ParseError = ErrorMsg String + | InfoMsg String | ShowHelpText deriving Show @@ -61,9 +64,14 @@ -- | Global preferences for a top-level 'Parser'. data ParserPrefs = ParserPrefs { prefMultiSuffix :: String -- ^ metavar suffix for multiple options - , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations (default: False) - , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors (default: False) - , prefBacktrack :: Bool -- ^ backtrack to parent parser when a subcommand fails (default: True) + , prefDisambiguate :: Bool -- ^ automatically disambiguate abbreviations + -- (default: False) + , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors + -- (default: False) + , prefBacktrack :: Bool -- ^ backtrack to parent parser when a + -- subcommand fails (default: True) + , prefIntersperse :: Bool -- ^ allow regular options and flags to occur + -- after arguments (default: True) } data OptName = OptShort !Char @@ -101,6 +109,7 @@ instance Functor m => Functor (CReader m) where fmap f (CReader c r) = CReader c (fmap f . r) +-- | A newtype over the 'Either' monad used by option readers. newtype ReadM a = ReadM { runReadM :: Either ParseError a } @@ -121,6 +130,14 @@ mplus m1 m2 = case runReadM m1 of Left _ -> m2 Right r -> return r + +-- | Abort option reader by exiting with a 'ParseError'. +readerAbort :: ParseError -> ReadM a +readerAbort = ReadM . Left + +-- | Abort option reader by exiting with an error message. +readerError :: String -> ReadM a +readerError = readerAbort . ErrorMsg type OptCReader = CReader ReadM type ArgCReader = CReader Maybe diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -131,7 +131,7 @@ ``` creates a regular option with a string argument (which can be referred to as -`FILE` in the help text and documentation), a long name "option" and a short +`FILE` in the help text and documentation), a long name "output" and a short name "o". See below for more information on the builder syntax and modifiers. A regular option can return an object of any type, provided you specify a @@ -163,7 +163,7 @@ parseFluxCapacitor :: Monad m => String -> m FluxCapacitor -option +nullOption ( long "flux-capacitor" <> reader parseFluxCapacitor ) ``` @@ -221,6 +221,13 @@ attach a description to them. They should be manually documented in the program description. +Note that arguments starting with `-` are considered options by default, and +will not be considered by an `argument` parser. + +However, parsers always accept a special argument: `--`. When a `--` is found on +the command line, all the following words are considered by `argument` parsers, +regardless of whether they start with `-` or not. + ### Commands A **command** can be used to specify a sub-parser to be used when a certain @@ -280,7 +287,7 @@ main = join $ execParser (info opts idm) ``` -# Option builders +## Option builders Builders allow you to define parsers using a convenient combinator-based syntax. Each builder takes a **modifier** as parameter, and returns a parser. @@ -296,7 +303,7 @@ See the haddock documentation for `Options.Applicative.Builder` for a full list of builders and modifiers. -# Arrow interface +## Arrow interface It is also possible to use the [Arrow syntax][arrows] to combine basic parsers. diff --git a/optparse-applicative.cabal b/optparse-applicative.cabal --- a/optparse-applicative.cabal +++ b/optparse-applicative.cabal @@ -1,5 +1,5 @@ name: optparse-applicative -version: 0.6.0 +version: 0.7.0 synopsis: Utilities and combinators for parsing command line options description: Here is a simple example of an applicative option parser: @@ -91,7 +91,6 @@ Options.Applicative.Arrows, Options.Applicative.BashCompletion, Options.Applicative.Builder, - Options.Applicative.Builder.Arguments, Options.Applicative.Builder.Completer, Options.Applicative.Builder.Internal, Options.Applicative.Common, diff --git a/tests/Examples/Cabal.hs b/tests/Examples/Cabal.hs --- a/tests/Examples/Cabal.hs +++ b/tests/Examples/Cabal.hs @@ -38,6 +38,11 @@ { buildDir :: FilePath } deriving Show +version :: Parser (a -> a) +version = infoOption "0.0.0" + ( long "version" + <> help "Print version information" ) + parser :: Parser Args parser = runA $ proc () -> do opts <- asA commonOpts -< () @@ -54,7 +59,7 @@ <> command "build" (info buildParser (progDesc "Make this package ready for installation")) ) -< () - A helper -< Args opts cmds + A version >>> A helper -< Args opts cmds commonOpts :: Parser CommonOpts commonOpts = CommonOpts diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -28,6 +28,13 @@ where err b = assertFailure $ "expected Left, got " ++ show b +assertRight :: Either ParserFailure b -> (b -> Assertion) -> Assertion +assertRight x f = either err f x + where + err (ParserFailure e _) = do + msg <- e "test" + assertFailure $ "unexpected parse error\n" ++ msg + assertHasLine :: String -> String -> Assertion assertHasLine l s | l `elem` lines s = return () @@ -48,8 +55,8 @@ case_modes :: Assertion case_modes = checkHelpText "commands" Commands.opts ["--help"] -case_cabal :: Assertion -case_cabal = checkHelpText "cabal" Cabal.pinfo ["configure", "--help"] +case_cabal_conf :: Assertion +case_cabal_conf = checkHelpText "cabal" Cabal.pinfo ["configure", "--help"] case_args :: Assertion case_args = do @@ -227,6 +234,14 @@ Left _ -> assertFailure "unexpected parse error" Right r -> ["foo", "bar", "baz"] @=? r +case_arguments_switch :: Assertion +case_arguments_switch = do + let p = switch (short 'x') + *> arguments str idm + i = info p idm + result = run i ["--", "-x"] + assertRight result $ \args -> ["-x"] @=? args + case_issue_35 :: Assertion case_issue_35 = do let p = flag' True (short 't' <> hidden) @@ -309,6 +324,32 @@ Left _ -> assertFailure "unexpected parse error" Right res -> (3, 5) @=? res + +case_issue_47 :: Assertion +case_issue_47 = do + let p = nullOption (long "test" <> reader r <> value 9) :: Parser Int + r _ = readerError "error message" + result = run (info p idm) ["--test", "x"] + assertLeft result $ \(ParserFailure err _) -> do + text <- head . lines <$> err "test" + assertBool "no error message" + ("error message" `isInfixOf` text) + +case_issue_50 :: Assertion +case_issue_50 = do + let p = argument str (metavar "INPUT") + <* switch (long "version") + result = run (info p idm) ["--version", "test"] + assertRight result $ \r -> "test" @=? r + +case_intersperse_1 :: Assertion +case_intersperse_1 = do + let p = arguments str (metavar "ARGS") + <* switch (short 'x') + result = execParserPure (prefs noIntersperse) + (info p idm) + ["a", "-x", "b"] + assertRight result $ \args -> ["a", "-x", "b"] @=? args main :: IO () main = $(defaultMainGenerator)