optparse-applicative 0.12.1.0 → 0.13.0.0
raw patch · 21 files changed
+891/−221 lines, 21 filesdep +QuickCheckdep +optparse-applicativedep +semigroupsdep ~base
Dependencies added: QuickCheck, optparse-applicative, semigroups
Dependency ranges changed: base
Files
- CHANGELOG.md +31/−0
- Options/Applicative/BashCompletion.hs +3/−2
- Options/Applicative/Builder.hs +34/−18
- Options/Applicative/Builder/Completer.hs +2/−1
- Options/Applicative/Builder/Internal.hs +19/−11
- Options/Applicative/Common.hs +49/−115
- Options/Applicative/Extra.hs +22/−17
- Options/Applicative/Help/Chunk.hs +1/−1
- Options/Applicative/Help/Core.hs +73/−8
- Options/Applicative/Help/Types.hs +6/−2
- Options/Applicative/Internal.hs +5/−17
- Options/Applicative/Types.hs +32/−9
- README.md +10/−7
- optparse-applicative.cabal +34/−7
- tests/Examples/Cabal.hs +2/−1
- tests/Examples/Commands.hs +12/−2
- tests/Examples/Formatting.hs +3/−2
- tests/Examples/Hello.hs +1/−1
- tests/commands.err.txt +4/−0
- tests/commands_header_full.err.txt +4/−0
- tests/test.hs +544/−0
CHANGELOG.md view
@@ -1,3 +1,34 @@+## Version 0.13.0.0 (15 Aug 2016)++- Implement command groups, which allow subcommands to have their own+ usage description.++- Implement showHelpOnEmpty, which is similar to showHelpOnError, but only+ fires when a command or subcommand is begun, and suppresses the "Missing:"+ error text.++- Fix ghc 8.0 warnings++- Fix ghc 7.10 warnings++- Bump dependency bounds++- Add maybeReader function for convenient ReadM creation++- Move eitherReader to Readers section (for better discoverability)++- Fix hsubparser metavar override++- Remove ComplError, which was dead code.++- Reimplement Missing error generation, which overly complicated evalParser.++- Export Semigroup instances for types which are also Monoids. Removes+ mempty synonym `(<>)` export, as it clashes with Semigroup exports.+ One may need to import Data.Monoid or Data.Semigroup when upgrading.++- Use a Cabal test suite for tests, simplify test dependencies.+ ## Version 0.12.1.0 (18 Jan 2016) - Updated dependency bounds.
Options/Applicative/BashCompletion.hs view
@@ -7,7 +7,8 @@ ( bashCompletionParser ) where -import Control.Applicative ((<$>), (<*>), many)+import Control.Applicative+import Prelude import Data.Foldable (asum) import Data.List (isPrefixOf) import Data.Maybe (fromMaybe, listToMaybe)@@ -48,7 +49,7 @@ OptReader ns _ _ -> return $ show_names ns FlagReader ns _ -> return $ show_names ns ArgReader rdr -> run_completer (crCompleter rdr)- CmdReader ns _ -> return $ filter_names ns+ CmdReader _ ns _ -> return $ filter_names ns show_name :: OptName -> String show_name (OptShort c) = '-':[c]
Options/Applicative/Builder.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Options.Applicative.Builder ( -- * Parser builders --@@ -38,19 +37,16 @@ showDefaultWith, showDefault, metavar,- eitherReader, noArgError, ParseError(..), hidden, internal, command,+ commandGroup, completeWith, action, completer, idm,-#if __GLASGOW_HASKELL__ > 702- (<>),-#endif mappend, -- * Readers@@ -58,6 +54,8 @@ -- | A collection of basic 'Option' readers. auto, str,+ maybeReader,+ eitherReader, disabled, readerAbort, readerError,@@ -81,6 +79,7 @@ multiSuffix, disambiguate, showHelpOnError,+ showHelpOnEmpty, noBacktrack, columns, prefs,@@ -95,12 +94,8 @@ CommandFields ) where -import Control.Applicative (pure, (<|>))-import Data.Monoid (Monoid (..)-#if __GLASGOW_HASKELL__ > 702- , (<>)-#endif- )+import Control.Applicative+import Data.Semigroup hiding (option) import Options.Applicative.Builder.Completer import Options.Applicative.Builder.Internal@@ -121,6 +116,15 @@ str :: ReadM String str = readerAsk +-- | Convert a function in the 'Either' monad to a reader.+eitherReader :: (String -> Either String a) -> ReadM a+eitherReader f = readerAsk >>= either readerError return . f++-- | Convert a function in the 'Maybe' monad to a reader.+maybeReader :: (String -> Maybe a) -> ReadM a+maybeReader f = eitherReader $ \arg ->+ maybe (Left $ "cannot parse value `" ++ arg ++ "'") pure . f $ arg+ -- | Null 'Option' reader. All arguments will fail validation. disabled :: ReadM a disabled = readerError "disabled option"@@ -161,10 +165,6 @@ helpDoc :: Maybe Doc -> Mod f a helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc } --- | Convert a function in the 'Either' monad to a reader.-eitherReader :: (String -> Either String a) -> ReadM a-eitherReader f = readerAsk >>= 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 }@@ -186,6 +186,11 @@ command cmd pinfo = fieldMod $ \p -> p { cmdCommands = (cmd, pinfo) : cmdCommands p } +-- | Add a description to a group of commands.+commandGroup :: String -> Mod CommandFields a+commandGroup g = fieldMod $ \p ->+ p { cmdGroup = Just g }+ -- | Add a list of possible completion values. completeWith :: HasCompleter f => [String] -> Mod f a completeWith xs = completer (listCompleter xs)@@ -212,7 +217,8 @@ subparser m = mkParser d g rdr where Mod _ d g = metavar "COMMAND" `mappend` m- rdr = uncurry CmdReader (mkCommand m)+ (groupName, cmds, subs) = mkCommand m+ rdr = CmdReader groupName cmds subs -- | Builder for an argument parser. argument :: ReadM a -> Mod ArgumentFields a -> Parser a@@ -299,8 +305,11 @@ instance Monoid (InfoMod a) where mempty = InfoMod id- mappend m1 m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1+ mappend = (<>) +instance Semigroup (InfoMod a) where+ m1 <> m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1+ -- | Show a full description in the help text of this parser. fullDesc :: InfoMod a fullDesc = InfoMod $ \i -> i { infoFullDesc = True }@@ -362,8 +371,11 @@ instance Monoid PrefsMod where mempty = PrefsMod id- mappend m1 m2 = PrefsMod $ applyPrefsMod m2 . applyPrefsMod m1+ mappend = (<>) +instance Semigroup PrefsMod where+ m1 <> m2 = PrefsMod $ applyPrefsMod m2 . applyPrefsMod m1+ multiSuffix :: String -> PrefsMod multiSuffix s = PrefsMod $ \p -> p { prefMultiSuffix = s } @@ -373,6 +385,9 @@ showHelpOnError :: PrefsMod showHelpOnError = PrefsMod $ \p -> p { prefShowHelpOnError = True } +showHelpOnEmpty :: PrefsMod+showHelpOnEmpty = PrefsMod $ \p -> p { prefShowHelpOnEmpty = True }+ noBacktrack :: PrefsMod noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False } @@ -386,6 +401,7 @@ { prefMultiSuffix = "" , prefDisambiguate = False , prefShowHelpOnError = False+ , prefShowHelpOnEmpty = False , prefBacktrack = True , prefColumns = 80 }
Options/Applicative/Builder/Completer.hs view
@@ -6,7 +6,8 @@ , bashCompleter ) where -import Control.Applicative ((<$>), pure)+import Control.Applicative+import Prelude import Control.Exception (IOException, try) import Data.List (isPrefixOf) import System.Process (readProcess)
Options/Applicative/Builder/Internal.hs view
@@ -3,8 +3,8 @@ Mod(..), HasName(..), HasCompleter(..),- HasValue,- HasMetavar,+ HasValue(..),+ HasMetavar(..), OptionFields(..), FlagFields(..), CommandFields(..),@@ -23,9 +23,10 @@ internal ) where -import Control.Applicative (pure, (<*>), empty, (<|>))+import Control.Applicative import Control.Monad (mplus)-import Data.Monoid (Monoid(..))+import Data.Semigroup hiding (Option)+import Prelude import Options.Applicative.Common import Options.Applicative.Types@@ -40,7 +41,8 @@ , flagActive :: a } data CommandFields a = CommandFields- { cmdCommands :: [(String, ParserInfo a)] }+ { cmdCommands :: [(String, ParserInfo a)]+ , cmdGroup :: Maybe String } data ArgumentFields a = ArgumentFields { argCompleter :: Completer }@@ -88,7 +90,10 @@ instance Monoid (DefaultProp a) where mempty = DefaultProp Nothing Nothing- mappend (DefaultProp d1 s1) (DefaultProp d2 s2) =+ mappend = (<>)++instance Semigroup (DefaultProp a) where+ (DefaultProp d1 s1) <> (DefaultProp d2 s2) = DefaultProp (d1 `mplus` d2) (s1 `mplus` s2) -- | An option modifier.@@ -128,9 +133,12 @@ instance Monoid (Mod f a) where mempty = Mod id mempty id- Mod f1 d1 g1 `mappend` Mod f2 d2 g2- = Mod (f2 . f1) (d2 `mappend` d1) (g2 . g1)+ mappend = (<>) +instance Semigroup (Mod f a) where+ Mod f1 d1 g1 <> Mod f2 d2 g2+ = Mod (f2 . f1) (d2 <> d1) (g2 . g1)+ -- | Base default properties. baseProps :: OptProperties baseProps = OptProperties@@ -139,11 +147,11 @@ , propHelp = mempty , propShowDefault = Nothing } -mkCommand :: Mod CommandFields a -> ([String], String -> Maybe (ParserInfo a))-mkCommand m = (map fst cmds, (`lookup` cmds))+mkCommand :: Mod CommandFields a -> (Maybe String, [String], String -> Maybe (ParserInfo a))+mkCommand m = (group, map fst cmds, (`lookup` cmds)) where Mod f _ _ = m- CommandFields cmds = f (CommandFields [])+ CommandFields cmds group = f (CommandFields [] Nothing) mkParser :: DefaultProp a -> (OptProperties -> OptProperties)
Options/Applicative/Common.hs view
@@ -47,26 +47,21 @@ -- * Low-level utilities mapParser, treeMapParser,- optionNames,- optDesc,- OptDescStyle (..)+ optionNames ) where -import Control.Applicative (pure, (<*>), (<*), (*>), (<$>), (<|>), (<$))-import Control.Arrow (left)+import Control.Applicative import Control.Monad (guard, mzero, msum, when, liftM) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State (StateT(..), get, put, runStateT)-import Data.List (isPrefixOf, sort, intersperse)-import Data.Maybe (maybeToList)-import Data.Monoid (Monoid(..))+import Data.List (isPrefixOf)+import Data.Maybe (maybeToList, isJust)+import Data.Semigroup hiding (Option)+import Prelude import Options.Applicative.Internal import Options.Applicative.Types -import Options.Applicative.Help.Pretty-import Options.Applicative.Help.Chunk- showOption :: OptName -> String showOption (OptLong n) = "--" ++ n showOption (OptShort n) = '-' : [n]@@ -91,21 +86,24 @@ instance Monoid MatchResult where mempty = NoMatch- mappend m@(Match _) _ = m- mappend _ m = m+ mappend = (<>) +instance Semigroup MatchResult where+ m@(Match _) <> _ = m+ _ <> m = m+ argMatches :: MonadP m => OptReader a -> String -> Maybe (StateT Args m a) argMatches opt arg = case opt of ArgReader rdr -> Just $ do result <- lift $ runReadM (crReader rdr) arg return result- CmdReader _ f ->+ CmdReader _ _ f -> flip fmap (f arg) $ \subp -> StateT $ \args -> do prefs <- getPrefs let runSubparser | prefBacktrack prefs = \i a ->- runParser (getPolicy i) (infoParser i) a+ runParser (getPolicy i) CmdStart (infoParser i) a | otherwise = \i a -> (,) <$> runParserInfo i a <*> pure [] enterContext arg subp *> runSubparser subp args <* exitContext@@ -157,37 +155,37 @@ parseWord _ = Nothing searchParser :: Monad m- => ParserPrefs- -> (forall r . Option r -> NondetT m r)+ => (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 pprefs f (MultP p1 p2) = foldr1 (<!>)- [ do p1' <- searchParser pprefs f p1+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' <- searchParser pprefs f p2+ , do p2' <- searchParser f p2 return (p1 <*> p2') ]-searchParser pprefs f (AltP p1 p2) = msum- [ searchParser pprefs f p1- , searchParser pprefs f p2 ]-searchParser pprefs f (BindP p k) = do- p' <- searchParser pprefs f p- case (evalParser False False (optDesc pprefs missingStyle) p') of- Left _ -> mzero- Right aa -> pure $ k aa+searchParser f (AltP p1 p2) = msum+ [ searchParser f p1+ , searchParser f p2 ]+searchParser f (BindP p k) = msum+ [ do p' <- searchParser f p+ return $ BindP p' k+ , case evalParser p of+ Nothing -> mzero+ Just aa -> searchParser f (k aa) ] searchOpt :: MonadP m => ParserPrefs -> OptWord -> Parser a -> NondetT (StateT Args m) (Parser a)-searchOpt pprefs w = searchParser pprefs $ \opt -> do+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 => ParserPrefs -> String -> Parser a+searchArg :: MonadP m => String -> Parser a -> NondetT (StateT Args m) (Parser a)-searchArg pprefs arg = searchParser pprefs $ \opt -> do+searchArg arg = searchParser $ \opt -> do when (isArg (optMain opt)) cut case argMatches (optMain opt) arg of Just matcher -> lift matcher@@ -197,29 +195,25 @@ -> 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 pprefs arg p-stepParser pprefs AllowOpts arg p = msum- [ searchArg pprefs arg p- , do w <- hoistMaybe (parseWord arg)- searchOpt pprefs w p ]+ Nothing -> searchArg arg p+stepParser _ AllowOpts arg p =+ searchArg arg 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 => ArgPolicy -> Parser a -> Args -> m (a, Args)-runParser SkipOpts p ("--" : argt) = runParser AllowOpts p argt-runParser policy p args = case args of- [] -> do- prefs <- getPrefs- exitP p $ MissingError `left` result prefs+runParser :: MonadP m => ArgPolicy -> IsCmdStart -> Parser a -> Args -> m (a, Args)+runParser SkipOpts _ p ("--" : argt) = runParser AllowOpts CmdCont p argt+runParser policy isCmdStart p args = case args of+ [] -> exitP isCmdStart p result (arg : argt) -> do prefs <- getPrefs (mp', args') <- do_step prefs arg argt case mp' of- Nothing -> hoistEither (MissingError `left` (result prefs)) <|> parseError arg- Just p' -> runParser policy p' args'+ Nothing -> hoistMaybe result <|> parseError arg+ Just p' -> runParser policy CmdCont p' args' where- result (prefs') = (,) <$> evalParser False False (optDesc prefs' missingStyle) p <*> pure args+ result = (,) <$> evalParser p <*> pure args do_step prefs arg argt = (`runStateT` argt) . disamb (not (prefDisambiguate prefs)) $ stepParser prefs policy arg p@@ -241,33 +235,19 @@ runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a runParserFully policy p args = do- (r, args') <- runParser policy p args+ (r, args') <- runParser policy CmdStart p args case args' of [] -> return r a:_ -> parseError a -- | The default value of a 'Parser'. This function returns an error if any of -- the options don't have a default value.-evalParser :: Bool -> Bool- -> (forall x . OptHelpInfo -> Option x -> b)- -> Parser a- -> Either (OptTree b) a-evalParser _ _ _ (NilP r) = maybeToEither (MultNode []) r-evalParser m d f (OptP opt)- | optVisibility opt > Internal- = Left $ Leaf (f (OptHelpInfo m d) opt)- | otherwise- = Left $ MultNode []-evalParser m d f (MultP p1 p2) = case (evalParser m d f p1, evalParser m d f p2) of- (Right a', Right b') -> Right $ a' b'- (Left a', Left b') -> Left $ MultNode [a', b']- (Left a', _) -> Left $ MultNode [a']- (_, Left b') -> Left $ MultNode [b']-evalParser m d f (AltP p1 p2) = case (evalParser m d f p1, evalParser m d f p2) of- (Right a', _) -> Right a'- (_, Right b') -> Right b'- (Left a', Left b') -> Left $ AltNode [a', b']-evalParser _ d f (BindP p k) = evalParser True d f p >>= (evalParser True d f) . k+evalParser :: Parser a -> Maybe a+evalParser (NilP r) = r+evalParser (OptP _) = Nothing+evalParser (MultP p1 p2) = evalParser p1 <*> evalParser p2+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 in a list.@@ -286,7 +266,7 @@ treeMapParser g = simplify . go False False g where has_default :: Parser a -> Bool- has_default p = either (const False) (const True) (evalParser False False g p)+ has_default p = isJust (evalParser p) go :: Bool -> Bool -> (forall x . OptHelpInfo -> Option x -> b)@@ -321,49 +301,3 @@ remove_alt (AltNode ts) = ts remove_alt (MultNode []) = [] remove_alt t = [t]----- | Style for rendering an option.-data OptDescStyle = OptDescStyle- { descSep :: Doc- , descHidden :: Bool- , descSurround :: Bool }---- | Generate description for a single option.-optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> Chunk Doc-optDesc pprefs style info opt =- let ns = optionNames $ optMain opt- mv = stringChunk $ optMetaVar opt- descs = map (string . showOption) (sort ns)- desc' = listToChunk (intersperse (descSep style) descs) <<+>> mv- show_opt- | optVisibility opt == Hidden- = descHidden style- | otherwise- = optVisibility opt == Visible- suffix- | hinfoMulti info- = stringChunk . prefMultiSuffix $ pprefs- | otherwise- = mempty- render chunk- | not show_opt- = mempty- | isEmpty chunk || not (descSurround style)- = mappend chunk suffix- | hinfoDefault info- = mappend (fmap brackets chunk) suffix- | null (drop 1 descs)- = mappend chunk suffix- | otherwise- = mappend (fmap parens chunk) suffix- in render desc'--missingStyle :: OptDescStyle-missingStyle = OptDescStyle- { descSep = string "|"- , descHidden = False- , descSurround = True }--maybeToEither :: b -> Maybe a -> Either b a-maybeToEither = flip maybe Right . Left
Options/Applicative/Extra.hs view
@@ -21,8 +21,9 @@ CompletionResult(..), ) where -import Control.Applicative (pure, (<$>), (<|>), (<**>))-import Data.Monoid (mempty, mconcat)+import Control.Applicative+import Data.Monoid+import Prelude import System.Environment (getArgs, getProgName) import System.Exit (exitSuccess, exitWith, ExitCode(..)) import System.IO (hPutStrLn, stderr)@@ -50,9 +51,9 @@ hsubparser :: Mod CommandFields a -> Parser a hsubparser m = mkParser d g rdr where- Mod _ d g = m `mappend` metavar "COMMAND"- (cmds, subs) = mkCommand m- rdr = CmdReader cmds (fmap add_helper . subs)+ Mod _ d g = metavar "COMMAND" `mappend` m+ (groupName, cmds, subs) = mkCommand m+ rdr = CmdReader groupName cmds (fmap add_helper . subs) add_helper pinfo = pinfo { infoParser = infoParser pinfo <**> helper } @@ -146,11 +147,11 @@ in (h, exit_code, prefColumns pprefs) where exit_code = case msg of- ErrorMsg _ -> ExitFailure (infoFailureCode pinfo)- UnknownError -> ExitFailure (infoFailureCode pinfo)- MissingError _ -> ExitFailure (infoFailureCode pinfo)- ShowHelpText -> ExitSuccess- InfoMsg _ -> ExitSuccess+ ErrorMsg _ -> ExitFailure (infoFailureCode pinfo)+ UnknownError -> ExitFailure (infoFailureCode pinfo)+ MissingError _ _ -> ExitFailure (infoFailureCode pinfo)+ ShowHelpText -> ExitSuccess+ InfoMsg _ -> ExitSuccess with_context :: [Context] -> ParserInfo a@@ -166,11 +167,13 @@ , fmap (indent 2) . infoProgDesc $ i ] error_help = errorHelp $ case msg of- ShowHelpText -> mempty- ErrorMsg m -> stringChunk m- InfoMsg m -> stringChunk m- MissingError x -> stringChunk "Missing:" <<+>> fold_tree x- UnknownError -> mempty+ ShowHelpText -> mempty+ ErrorMsg m -> stringChunk m+ InfoMsg m -> stringChunk m+ MissingError CmdStart _ | prefShowHelpOnEmpty pprefs+ -> mempty+ MissingError _ (SomeParser x) -> stringChunk "Missing:" <<+>> missingDesc pprefs x+ UnknownError -> mempty base_help :: ParserInfo a -> ParserHelp base_help i@@ -183,8 +186,10 @@ f = footerHelp (infoFooter i) show_full_help = case msg of- ShowHelpText -> True- _ -> prefShowHelpOnError pprefs+ ShowHelpText -> True+ MissingError CmdStart _ | prefShowHelpOnEmpty pprefs+ -> True+ _ -> prefShowHelpOnError pprefs renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode) renderFailure failure progn =
Options/Applicative/Help/Chunk.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} module Options.Applicative.Help.Chunk ( mappendWith , Chunk(..)@@ -19,6 +18,7 @@ import Control.Monad import Data.Maybe import Data.Monoid+import Prelude import Options.Applicative.Help.Pretty
Options/Applicative/Help/Core.hs view
@@ -1,6 +1,7 @@ module Options.Applicative.Help.Core ( cmdDesc, briefDesc,+ missingDesc, fold_tree, fullDesc, ParserHelp(..),@@ -13,22 +14,65 @@ parserUsage, ) where +import Control.Applicative import Control.Monad (guard)-import Data.Maybe (maybeToList, catMaybes)-import Data.Monoid (mempty)+import Data.Function (on)+import Data.List (sort, intersperse, groupBy)+import Data.Maybe (maybeToList, catMaybes, fromMaybe)+import Data.Monoid+import Prelude import Options.Applicative.Common import Options.Applicative.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk +-- | Style for rendering an option.+data OptDescStyle = OptDescStyle+ { descSep :: Doc+ , descHidden :: Bool+ , descOptional :: Bool+ , descSurround :: Bool }++-- | Generate description for a single option.+optDesc :: ParserPrefs -> OptDescStyle -> OptHelpInfo -> Option a -> Chunk Doc+optDesc pprefs style info opt =+ let ns = optionNames $ optMain opt+ mv = stringChunk $ optMetaVar opt+ descs = map (string . showOption) (sort ns)+ desc' = listToChunk (intersperse (descSep style) descs) <<+>> mv+ show_opt+ | hinfoDefault info && not (descOptional style)+ = False+ | optVisibility opt == Hidden+ = descHidden style+ | otherwise+ = optVisibility opt == Visible+ suffix+ | hinfoMulti info+ = stringChunk . prefMultiSuffix $ pprefs+ | otherwise+ = mempty+ render chunk+ | not show_opt+ = mempty+ | isEmpty chunk || not (descSurround style)+ = mappend chunk suffix+ | hinfoDefault info+ = mappend (fmap brackets chunk) suffix+ | null (drop 1 descs)+ = mappend chunk suffix+ | otherwise+ = mappend (fmap parens chunk) suffix+ in render desc'+ -- | Generate descriptions for commands.-cmdDesc :: Parser a -> Chunk Doc-cmdDesc = vcatChunks . mapParser desc+cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]+cmdDesc = mapParser desc where desc _ opt = case optMain opt of- CmdReader cmds p ->+ CmdReader gn cmds p -> (,) gn $ tabulate [(string cmd, align (extractChunk d)) | cmd <- reverse cmds , d <- maybeToList . fmap infoProgDesc $ p cmd ]@@ -36,11 +80,22 @@ -- | Generate a brief help text for a parser. briefDesc :: ParserPrefs -> Parser a -> Chunk Doc-briefDesc pprefs = fold_tree . treeMapParser (optDesc pprefs style)+briefDesc = briefDesc' True++-- | Generate a brief help text for a parser, only including mandatory+-- options and arguments.+missingDesc :: ParserPrefs -> Parser a -> Chunk Doc+missingDesc = briefDesc' False++-- | Generate a brief help text for a parser, allowing the specification+-- of if optional arguments are show.+briefDesc' :: Bool -> ParserPrefs -> Parser a -> Chunk Doc+briefDesc' showOptional pprefs = fold_tree . treeMapParser (optDesc pprefs style) where style = OptDescStyle { descSep = string "|" , descHidden = False+ , descOptional = showOptional , descSurround = True } fold_tree :: OptTree (Chunk Doc) -> Chunk Doc@@ -72,6 +127,7 @@ style = OptDescStyle { descSep = string "," , descHidden = True+ , descOptional = True , descSurround = False } errorHelp :: Chunk Doc -> ParserHelp@@ -92,9 +148,18 @@ -- | Generate the help text for a program. parserHelp :: ParserPrefs -> Parser a -> ParserHelp parserHelp pprefs p = bodyHelp . vsepChunks $- [ with_title "Available options:" (fullDesc pprefs p)- , with_title "Available commands:" (cmdDesc p) ]+ ( with_title "Available options:" (fullDesc pprefs p) )+ : (group_title <$> cs) where+ def = "Available commands:"++ cs = groupBy ((==) `on` fst) $ cmdDesc p++ group_title a@((n,_):_) = with_title (fromMaybe def n) $+ vcatChunks (snd <$> a)+ group_title _ = mempty++ with_title :: String -> Chunk Doc -> Chunk Doc with_title title = fmap (string title .$.)
Options/Applicative/Help/Types.hs view
@@ -3,7 +3,8 @@ renderHelp ) where -import Data.Monoid+import Data.Semigroup+import Prelude import Options.Applicative.Help.Chunk import Options.Applicative.Help.Pretty@@ -20,7 +21,10 @@ instance Monoid ParserHelp where mempty = ParserHelp mempty mempty mempty mempty mempty- mappend (ParserHelp e1 h1 u1 b1 f1) (ParserHelp e2 h2 u2 b2 f2)+ mappend = (<>)++instance Semigroup ParserHelp where+ (ParserHelp e1 h1 u1 b1 f1) <> (ParserHelp e2 h2 u2 b2 f2) = ParserHelp (mappend e1 e2) (mappend h1 h2) (mappend u1 u2) (mappend b1 b2) (mappend f1 f2)
Options/Applicative/Internal.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} module Options.Applicative.Internal ( P- , Context(..) , MonadP(..) , ParseError(..) @@ -15,8 +14,6 @@ , Completion , runCompletion- , SomeParser(..)- , ComplError(..) , contextNames , ListT@@ -29,7 +26,8 @@ , disamb ) where -import Control.Applicative (Applicative(..), Alternative(..), (<$>))+import Control.Applicative+import Prelude import Control.Monad (MonadPlus(..), liftM, ap, guard) import Control.Monad.Trans.Class (MonadTrans, lift) import Control.Monad.Trans.Except@@ -48,7 +46,7 @@ missingArgP :: ParseError -> Completer -> m a tryP :: m a -> m (Either ParseError a) errorP :: ParseError -> m a- exitP :: Parser b -> Either ParseError a -> m a+ exitP :: IsCmdStart -> Parser b -> Maybe a -> m a newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a) @@ -71,10 +69,6 @@ mzero = P mzero mplus (P x) (P y) = P $ mplus x y --data Context- = forall a . Context String (ParserInfo a)- contextNames :: [Context] -> [String] contextNames ns = let go (Context n _) = n@@ -87,7 +81,7 @@ missingArgP e _ = errorP e tryP (P p) = P $ lift $ runExceptT p- exitP _ = P . (either throwE return)+ exitP i p = P . (maybe (throwE . MissingError i . SomeParser $ p) return) errorP = P . throwE hoistMaybe :: MonadPlus m => Maybe a -> m a@@ -112,12 +106,6 @@ f' (ErrorMsg err) = ErrorMsg (f err) f' e = e -data SomeParser = forall a . SomeParser (Parser a)--data ComplError- = ComplParseError String- | ComplExit- data ComplResult a = ComplParser SomeParser | ComplOption Completer@@ -166,7 +154,7 @@ missingArgP _ = Completion . lift . lift . ComplOption tryP (Completion p) = Completion $ catchE (Right <$> p) (return . Left)- exitP p _ = Completion . lift . lift . ComplParser $ SomeParser p+ exitP _ p _ = Completion . lift . lift . ComplParser $ SomeParser p errorP = Completion . throwE runCompletion :: Completion r -> ParserPrefs -> Maybe (Either SomeParser Completer)
Options/Applicative/Types.hs view
@@ -27,6 +27,9 @@ OptHelpInfo(..), OptTree(..), ParserHelp(..),+ SomeParser(..),+ Context(..),+ IsCmdStart(..), fromM, oneM,@@ -40,31 +43,38 @@ ) where import Control.Applicative- (Applicative(..), Alternative(..), (<$>), optional) import Control.Monad (ap, liftM, MonadPlus, mzero, mplus) import Control.Monad.Trans.Except (Except, throwE) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, ask)-import Data.Monoid (Monoid(..))+import Data.Semigroup hiding (Option)+import Prelude+ import System.Exit (ExitCode(..)) import Options.Applicative.Help.Types import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk + data ParseError = ErrorMsg String | InfoMsg String | ShowHelpText | UnknownError- | MissingError (OptTree (Chunk Doc))+ | MissingError IsCmdStart SomeParser++data IsCmdStart = CmdStart | CmdCont deriving Show instance Monoid ParseError where mempty = UnknownError- mappend m UnknownError = m- mappend _ m = m+ mappend = (<>) +instance Semigroup ParseError where+ m <> UnknownError = m+ _ <> m = m+ -- | A full description for a runnable 'Parser' for a program. data ParserInfo a = ParserInfo { infoParser :: Parser a -- ^ the option parser for the program@@ -88,6 +98,8 @@ -- (default: False) , prefShowHelpOnError :: Bool -- ^ always show help text on parse errors -- (default: False)+ , prefShowHelpOnEmpty :: Bool -- ^ show the help text for a command or subcommand+ -- if it fails with no input (default: False) , prefBacktrack :: Bool -- ^ backtrack to parent parser when a -- subcommand fails (default: True) , prefColumns :: Int -- ^ number of columns in the terminal, used to@@ -119,6 +131,12 @@ , optProps :: OptProperties -- ^ properties of this option } +data SomeParser = forall a . SomeParser (Parser a)++-- | Subparser context, containing the 'name' of the subparser, and its parser info.+-- Used by parserFailure to display relevant usage information when parsing inside a subparser fails.+data Context = forall a . Context String (ParserInfo a)+ instance Show (Option a) where show opt = "Option {optProps = " ++ show (optProps opt) ++ "}" @@ -173,13 +191,14 @@ = OptReader [OptName] (CReader a) ParseError -- ^ option reader | FlagReader [OptName] !a -- ^ flag reader | ArgReader (CReader a) -- ^ argument reader- | CmdReader [String] (String -> Maybe (ParserInfo a)) -- ^ command reader+ | CmdReader (Maybe String)+ [String] (String -> Maybe (ParserInfo a)) -- ^ command reader instance Functor OptReader where fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e fmap f (FlagReader ns x) = FlagReader ns (f x) fmap f (ArgReader cr) = ArgReader (fmap f cr)- fmap f (CmdReader cs g) = CmdReader cs ((fmap . fmap) f . g)+ fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g) -- | A @Parser a@ is an option parser returning a value of type 'a'. data Parser a@@ -298,9 +317,13 @@ type Args = [String] +-- | Policy for how to handle options within the parse data ArgPolicy- = SkipOpts- | AllowOpts+ = SkipOpts -- ^ Inputs beginning with `-` or `--` are treated+ -- as options or flags, and can be mixed with arguments.+ | AllowOpts -- ^ All input is treated as positional arguments.+ -- Used after a bare `--` input, and also with+ -- `noIntersperse` policy. deriving (Eq, Show) data OptHelpInfo = OptHelpInfo
README.md view
@@ -180,20 +180,23 @@ the type will be normally inferred from the context in which the parser is used. -You can also create a custom reader that doesn't use the `Read` typeclass, and-use it to parse option arguments. A custom reader is a value in the `ReadM`-monad.+One can also create a custom reader that doesn't use the `Read` typeclass, and+use it to parse option arguments. A custom reader is a value in the `ReadM`+monad. We provide `eitherReader :: (String -> Either String a) -> ReadM a`+to help create these values, where a `Left` will hold the error message+for a failure. ```haskell data FluxCapacitor = ... -parseFluxCapacitor :: Monad m => String -> m FluxCapacitor+parseFluxCapacitor :: ReadM FluxCapacitor+parseFluxCapacitor = eitherReader $ \s -> ... -option (str >>= parseFluxCapacitor)- ( long "flux-capacitor" )+option parseFluxCapacitor ( long "flux-capacitor" ) ``` -Use `readerAbort` or `readerError` within the `ReadM` monad to exit with an+One can also use `ReadM` directly, using `str` to obtain the command line string,+and `readerAbort` or `readerError` within the `ReadM` monad to exit with an error message. ### Flags
optparse-applicative.cabal view
@@ -1,5 +1,5 @@ name: optparse-applicative-version: 0.12.1.0+version: 0.13.0.0 synopsis: Utilities and combinators for parsing command line options description: Here is a simple example of an applicative option parser:@@ -93,6 +93,11 @@ location: https://github.com/pcapriotti/optparse-applicative.git library+ if impl(ghc >= 8)+ ghc-options: -Wall -Wno-redundant-constraints+ else+ ghc-options: -Wall+ exposed-modules: Options.Applicative, Options.Applicative.Arrows, Options.Applicative.BashCompletion,@@ -108,9 +113,31 @@ Options.Applicative.Help.Types, Options.Applicative.Types, Options.Applicative.Internal- ghc-options: -Wall- build-depends: base == 4.*,- transformers >= 0.2 && < 0.6,- transformers-compat >= 0.3 && < 0.6,- process >= 1.0 && < 1.5,- ansi-wl-pprint >= 0.6.6 && < 0.7+++ build-depends: base == 4.*+ , transformers >= 0.2 && < 0.6+ , transformers-compat >= 0.3 && < 0.6+ , process >= 1.0 && < 1.5+ , ansi-wl-pprint >= 0.6.6 && < 0.7++ if !impl(ghc >= 8)+ build-depends: semigroups >= 0.10 && < 0.19+++test-suite optparse-applicative-tests+ type: exitcode-stdio-1.0++ main-is: test.hs++ ghc-options: -Wall -threaded -O2 -funbox-strict-fields++ hs-source-dirs:+ tests++ build-depends: base+ , optparse-applicative+ , QuickCheck == 2.8.*++ if !impl(ghc >= 8)+ build-depends: semigroups
tests/Examples/Cabal.hs view
@@ -4,8 +4,9 @@ import Options.Applicative import Options.Applicative.Arrows -#if __GLASGOW_HASKELL__ <= 702 import Data.Monoid++#if __GLASGOW_HASKELL__ <= 702 (<>) :: Monoid a => a -> a -> a (<>) = mappend #endif
tests/Examples/Commands.hs view
@@ -2,10 +2,10 @@ module Examples.Commands where import Data.List+import Data.Monoid import Options.Applicative #if __GLASGOW_HASKELL__ <= 702-import Data.Monoid (<>) :: Monoid a => a -> a -> a (<>) = mappend #endif@@ -13,7 +13,7 @@ data Sample = Hello [String] | Goodbye- deriving Show+ deriving (Eq, Show) hello :: Parser Sample hello = Hello <$> many (argument str (metavar "TARGET..."))@@ -26,6 +26,16 @@ <> command "goodbye" (info (pure Goodbye) (progDesc "Say goodbye"))+ )+ <|> subparser+ ( command "bonjour"+ (info hello+ (progDesc "Print greeting"))+ <> command "au-revoir"+ (info (pure Goodbye)+ (progDesc "Say goodbye"))+ <> commandGroup "French commands:"+ <> hidden ) run :: Sample -> IO ()
tests/Examples/Formatting.hs view
@@ -1,7 +1,8 @@ module Examples.Formatting where -import Data.Monoid-import Options.Applicative+import Data.Monoid+import Options.Applicative+import Prelude opts :: Parser Int opts = option auto $ mconcat
tests/Examples/Hello.hs view
@@ -1,10 +1,10 @@ {-# LANGUAGE CPP #-} module Examples.Hello where +import Data.Monoid import Options.Applicative #if __GLASGOW_HASKELL__ <= 702-import Data.Monoid (<>) :: Monoid a => a -> a -> a (<>) = mappend #endif
tests/commands.err.txt view
@@ -6,3 +6,7 @@ Available commands: hello Print greeting goodbye Say goodbye++French commands:+ bonjour Print greeting+ au-revoir Say goodbye
tests/commands_header_full.err.txt view
@@ -10,3 +10,7 @@ Available commands: hello Print greeting goodbye Say goodbye++French commands:+ bonjour Print greeting+ au-revoir Say goodbye
+ tests/test.hs view
@@ -0,0 +1,544 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import qualified Examples.Hello as Hello+import qualified Examples.Commands as Commands+import qualified Examples.Cabal as Cabal+import qualified Examples.Alternatives as Alternatives+import qualified Examples.Formatting as Formatting++import Control.Applicative+import Control.Monad+import Data.List hiding (group)+import Data.Semigroup hiding (option)++import System.Exit+import Test.QuickCheck hiding (Success, Failure)+import Test.QuickCheck.Property++import Options.Applicative+import Options.Applicative.Types+import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..))+import qualified Options.Applicative.Help.Pretty as Doc+import Options.Applicative.Help.Chunk++import Prelude++run :: ParserInfo a -> [String] -> ParserResult a+run = execParserPure defaultPrefs++assertError :: Show a => ParserResult a+ -> (ParserFailure ParserHelp -> Property) -> Property+assertError x f = case x of+ Success r -> counterexample ("expected failure, got success: " ++ show r) failed+ Failure e -> f e+ CompletionInvoked _ -> counterexample "expected failure, got completion" failed++assertResult :: ParserResult a -> (a -> Property) -> Property+assertResult x f = case x of+ Success r -> f r+ Failure e -> do+ let (msg, _) = renderFailure e "test"+ counterexample ("unexpected parse error\n" ++ msg) failed+ CompletionInvoked _ -> counterexample "expected result, got completion" failed++assertHasLine :: String -> String -> Property+assertHasLine l s = counterexample ("expected line:\n\t" ++ l ++ "\nnot found")+ $ l `elem` lines s++checkHelpTextWith :: Show a => ExitCode -> ParserPrefs -> String+ -> ParserInfo a -> [String] -> Property+checkHelpTextWith ecode pprefs name p args = ioProperty $ do+ let result = execParserPure pprefs p args+ expected <- readFile $ "tests/" ++ name ++ ".err.txt"+ return $ assertError result $ \failure ->+ let (msg, code) = renderFailure failure name+ in (expected === msg ++ "\n") .&&. (ecode === code)++checkHelpText :: Show a => String -> ParserInfo a -> [String] -> Property+checkHelpText = checkHelpTextWith ExitSuccess defaultPrefs++prop_hello :: Property+prop_hello = once $+ checkHelpText "hello" Hello.opts ["--help"]++prop_modes :: Property+prop_modes = once $+ checkHelpText "commands" Commands.opts ["--help"]++prop_cmd_header :: Property+prop_cmd_header = once $+ let i = info (helper <*> Commands.sample) (header "foo")+ r1 = checkHelpTextWith (ExitFailure 1) defaultPrefs+ "commands_header" i ["-zzz"]+ r2 = checkHelpTextWith (ExitFailure 1) (prefs showHelpOnError)+ "commands_header_full" i ["-zzz"]+ in (r1 .&&. r2)++prop_cabal_conf :: Property+prop_cabal_conf = once $+ checkHelpText "cabal" Cabal.pinfo ["configure", "--help"]++prop_args :: Property+prop_args = once $+ let result = run Commands.opts ["hello", "foo", "bar"]+ in assertResult result ((===) (Commands.Hello ["foo", "bar"]))++prop_args_opts :: Property+prop_args_opts = once $+ let result = run Commands.opts ["hello", "foo", "--bar"]+ in assertError result (\_ -> property succeeded)++prop_args_ddash :: Property+prop_args_ddash = once $+ let result = run Commands.opts ["hello", "foo", "--", "--bar", "--", "baz"]+ in assertResult result ((===) (Commands.Hello ["foo", "--bar", "--", "baz"]))++prop_alts :: Property+prop_alts = once $+ let result = run Alternatives.opts ["-b", "-a", "-b", "-a", "-a", "-b"]+ in assertResult result $ \xs ->+ let a = Alternatives.A+ b = Alternatives.B+ in [b, a, b, a, a, b] === xs++prop_show_default :: Property+prop_show_default = once $+ let p = option auto+ ( short 'n'+ <> help "set count"+ <> value (0 :: Int)+ <> showDefault )+ i = info (p <**> helper) idm+ result = run i ["--help"]+ in assertError result $ \failure ->+ let (msg, _) = renderFailure failure "test"+ in assertHasLine+ " -n ARG set count (default: 0)"+ msg++prop_alt_cont :: Property+prop_alt_cont = once $+ let p = Alternatives.a <|> Alternatives.b+ i = info p idm+ result = run i ["-a", "-b"]+ in assertError result (\_ -> property succeeded)++prop_alt_help :: Property+prop_alt_help = once $+ 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+ in checkHelpText "alt" i ["--help"]++prop_nested_commands :: Property+prop_nested_commands = once $+ 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+ in checkHelpTextWith (ExitFailure 1) defaultPrefs "nested" i ["c", "b"]++prop_drops_back_contexts :: Property+prop_drops_back_contexts = once $+ let p3 = strOption (short 'a' <> metavar "A")+ p2 = subparser (command "b" (info p3 idm) <> metavar "B")+ p1 = subparser (command "c" (info p3 idm) <> metavar "C")+ p0 = (,) <$> p2 <*> p1+ i = info (p0 <**> helper) idm+ in checkHelpTextWith (ExitFailure 1) defaultPrefs "dropback" i ["b", "-aA"]++prop_context_carry :: Property+prop_context_carry = once $+ let p3 = strOption (short 'a' <> metavar "A")+ p2 = subparser (command "b" (info p3 idm) <> metavar "B")+ p1 = subparser (command "c" (info p3 idm) <> metavar "C")+ p0 = (,) <$> p2 <*> p1+ i = info (p0 <**> helper) idm+ in checkHelpTextWith (ExitFailure 1) defaultPrefs "carry" i ["b", "-aA", "c"]++prop_help_on_empty :: Property+prop_help_on_empty = once $+ let p3 = strOption (short 'a' <> metavar "A")+ p2 = subparser (command "b" (info p3 idm) <> metavar "B")+ p1 = subparser (command "c" (info p3 idm) <> metavar "C")+ p0 = (,) <$> p2 <*> p1+ i = info (p0 <**> helper) idm+ in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponempty" i []++prop_help_on_empty_sub :: Property+prop_help_on_empty_sub = once $+ let p3 = strOption (short 'a' <> metavar "A" <> help "both commands require this")+ p2 = subparser (command "b" (info p3 idm) <> metavar "B")+ p1 = subparser (command "c" (info p3 idm) <> metavar "C")+ p0 = (,) <$> p2 <*> p1+ i = info (p0 <**> helper) idm+ in checkHelpTextWith (ExitFailure 1) (prefs showHelpOnEmpty) "helponemptysub" i ["b", "-aA", "c"]++prop_many_args :: Property+prop_many_args = forAll (choose (0,2000)) $ \nargs ->+ let p = many (argument str idm)+ i = info p idm+ result = run i (replicate nargs "foo")+ in assertResult result (\xs -> nargs === length xs)++prop_disambiguate :: Property+prop_disambiguate = once $+ let p = flag' (1 :: Int) (long "foo")+ <|> flag' 2 (long "bar")+ <|> flag' 3 (long "baz")+ i = info p idm+ result = execParserPure (prefs disambiguate) i ["--f"]+ in assertResult result ((===) 1)++prop_ambiguous :: Property+prop_ambiguous = once $+ let p = flag' (1 :: Int) (long "foo")+ <|> flag' 2 (long "bar")+ <|> flag' 3 (long "baz")+ i = info p idm+ result = execParserPure (prefs disambiguate) i ["--ba"]+ in assertError result (\_ -> property succeeded)++prop_completion :: Property+prop_completion = once . ioProperty $+ let p = (,)+ <$> strOption (long "foo" <> value "")+ <*> strOption (long "bar" <> value "")+ i = info p idm+ result = run i ["--bash-completion-index", "0"]+ in case result of+ CompletionInvoked (CompletionResult err) -> do+ completions <- lines <$> err "test"+ return $ ["--foo", "--bar"] === completions+ Failure _ -> return $ counterexample "unexpected failure" failed+ Success val -> return $ counterexample ("unexpected result " ++ show val) failed++prop_bind_usage :: Property+prop_bind_usage = once $+ let p = many (argument str (metavar "ARGS..."))+ i = info (p <**> helper) briefDesc+ result = run i ["--help"]+ in assertError result $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in "Usage: test [ARGS...]" === text++prop_issue_19 :: Property+prop_issue_19 = once $+ let p = option (fmap Just str)+ ( short 'x'+ <> value Nothing )+ i = info (p <**> helper) idm+ result = run i ["-x", "foo"]+ in assertResult result (Just "foo" ===)++prop_arguments1_none :: Property+prop_arguments1_none =+ let p = some (argument str idm)+ i = info (p <**> helper) idm+ result = run i []+ in assertError result $ \_ -> property succeeded++prop_arguments1_some :: Property+prop_arguments1_some = once $+ let p = some (argument str idm)+ i = info (p <**> helper) idm+ result = run i ["foo", "--", "bar", "baz"]+ in assertResult result (["foo", "bar", "baz"] ===)++prop_arguments_switch :: Property+prop_arguments_switch = once $+ let p = switch (short 'x')+ *> many (argument str idm)+ i = info p idm+ result = run i ["--", "-x"]+ in assertResult result $ \args -> ["-x"] === args++prop_issue_35 :: Property+prop_issue_35 = once $+ let p = flag' True (short 't' <> hidden)+ <|> flag' False (short 'f')+ i = info p idm+ result = run i []+ in assertError result $ \failure ->+ let text = lines . fst $ renderFailure failure "test"+ in ["Missing: -f", "", "Usage: test -f"] === text++prop_backtracking :: Property+prop_backtracking = once $+ let p2 = switch (short 'a')+ p1 = (,)+ <$> subparser (command "c" (info p2 idm))+ <*> switch (short 'b')+ i = info (p1 <**> helper) idm+ result = execParserPure (prefs noBacktrack) i ["c", "-b"]+ in assertError result $ \_ -> property succeeded++prop_error_context :: Property+prop_error_context = once $+ let p = pk <$> option auto (long "port")+ <*> option auto (long "key")+ i = info p idm+ result = run i ["--port", "foo", "--key", "291"]+ in assertError result $ \failure ->+ let (msg, _) = renderFailure failure "test"+ errMsg = head $ lines msg+ in conjoin [ counterexample "no context in error message (option)" ("port" `isInfixOf` errMsg)+ , counterexample "no context in error message (value)" ("foo" `isInfixOf` errMsg)]+ where+ pk :: Int -> Int -> (Int, Int)+ pk = (,)++condr :: (Int -> Bool) -> ReadM Int+condr f = do+ x <- auto+ guard (f x)+ return x++prop_arg_order_1 :: Property+prop_arg_order_1 = once $+ let p = (,)+ <$> argument (condr even) idm+ <*> argument (condr odd) idm+ i = info p idm+ result = run i ["3", "6"]+ in assertError result $ \_ -> property succeeded++prop_arg_order_2 :: Property+prop_arg_order_2 = once $+ let p = (,,)+ <$> argument (condr even) idm+ <*> option (condr even) (short 'a')+ <*> option (condr odd) (short 'b')+ i = info p idm+ result = run i ["2", "-b", "3", "-a", "6"]+ in assertResult result ((===) (2, 6, 3))++prop_arg_order_3 :: Property+prop_arg_order_3 = once $+ let p = (,)+ <$> ( argument (condr even) idm+ <|> option auto (short 'n') )+ <*> argument (condr odd) idm+ i = info p idm+ result = run i ["-n", "3", "5"]+ in assertResult result ((===) (3, 5))++prop_unix_style :: Int -> Int -> Property+prop_unix_style j k =+ let p = (,)+ <$> flag' j (short 'x')+ <*> flag' k (short 'c')+ i = info p idm+ result = run i ["-xc"]+ in assertResult result ((===) (j,k))++prop_unix_with_options :: Property+prop_unix_with_options = once $+ let p = (,)+ <$> flag' (1 :: Int) (short 'x')+ <*> strOption (short 'a')+ i = info p idm+ result = run i ["-xac"]+ in assertResult result ((===) (1, "c"))++prop_count_flags :: Property+prop_count_flags = once $+ let p = length <$> many (flag' () (short 't'))+ i = info p idm+ result = run i ["-ttt"]+ in assertResult result ((===) 3)++prop_issue_47 :: Property+prop_issue_47 = once $+ let p = option r (long "test" <> value 9) :: Parser Int+ r = readerError "error message"+ result = run (info p idm) ["--test", "x"]+ in assertError result $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in counterexample "no error message" ("error message" `isInfixOf` text)++prop_long_help :: Property+prop_long_help = once $+ let p = Formatting.opts <**> helper+ i = info p+ ( progDesc (concat+ [ "This is a very long program description. "+ , "This text should be automatically wrapped "+ , "to fit the size of the terminal" ]) )+ in checkHelpTextWith ExitSuccess (prefs (columns 50)) "formatting" i ["--help"]++prop_issue_50 :: Property+prop_issue_50 = once $+ let p = argument str (metavar "INPUT")+ <* switch (long "version")+ result = run (info p idm) ["--version", "test"]+ in assertResult result $ \r -> "test" === r++prop_intersperse_1 :: Property+prop_intersperse_1 = once $+ let p = many (argument str (metavar "ARGS"))+ <* switch (short 'x')+ result = run (info p noIntersperse)+ ["a", "-x", "b"]+ in assertResult result $ \args -> ["a", "-x", "b"] === args++prop_intersperse_2 :: Property+prop_intersperse_2 = once $+ let p = subparser+ ( command "run"+ ( info (many (argument str (metavar "OPTIONS")))+ noIntersperse )+ <> command "test"+ ( info (many (argument str (metavar "ARGS")))+ idm ) )+ i = info p idm+ result1 = run i ["run", "-x", "foo"]+ result2 = run i ["test", "-x", "bar"]+ in conjoin [ assertResult result1 $ \args -> ["-x", "foo"] === args+ , assertError result2 $ \_ -> property succeeded ]++prop_issue_52 :: Property+prop_issue_52 = once $+ let p = subparser+ ( metavar "FOO"+ <> command "run" (info (pure "foo") idm) )+ i = info p idm+ in assertError (run i []) $ \failure -> do+ let text = lines . fst $ renderFailure failure "test"+ ["Missing: FOO", "", "Usage: test FOO"] === text++prop_multiple_subparsers :: Property+prop_multiple_subparsers = once $+ let p1 = subparser+ (command "add" (info (pure ())+ ( progDesc "Add a file to the repository" )))+ p2 = subparser+ (command "commit" (info (pure ())+ ( progDesc "Record changes to the repository" )))+ i = info (p1 *> p2 <**> helper) idm+ in checkHelpText "subparsers" i ["--help"]++prop_argument_error :: Property+prop_argument_error = once $+ let r = (auto >>= \x -> x <$ guard (x == 42))+ <|> (str >>= \x -> readerError (x ++ " /= 42"))+ p1 = argument r idm :: Parser Int+ i = info (p1 *> p1) idm+ in assertError (run i ["3", "4"]) $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in "3 /= 42" === text++prop_reader_error_mplus :: Property+prop_reader_error_mplus = once $+ let r = (auto >>= \x -> x <$ guard (x == 42))+ <|> (str >>= \x -> readerError (x ++ " /= 42"))+ p1 = argument r idm :: Parser Int+ i = info p1 idm+ in assertError (run i ["foo"]) $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in "foo /= 42" === text++prop_missing_flags_described :: Property+prop_missing_flags_described = once $+ let p = (,,)+ <$> option str (short 'a')+ <*> option str (short 'b')+ <*> optional (option str (short 'c'))+ i = info p idm+ in assertError (run i ["-b", "3"]) $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in "Missing: -a ARG" === text++prop_many_missing_flags_described :: Property+prop_many_missing_flags_described = once $+ let p = (,)+ <$> option str (short 'a')+ <*> option str (short 'b')+ i = info p idm+ in assertError (run i []) $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in "Missing: -a ARG -b ARG" === text++prop_alt_missing_flags_described :: Property+prop_alt_missing_flags_described = once $+ let p = option str (short 'a') <|> option str (short 'b')+ i = info p idm+ in assertError (run i []) $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in "Missing: (-a ARG | -b ARG)" === text++prop_many_pairs_success :: Property+prop_many_pairs_success = once $+ let p = many $ (,) <$> argument str idm <*> argument str idm+ i = info p idm+ nargs = 10000+ result = run i (replicate nargs "foo")+ in assertResult result $ \xs -> nargs `div` 2 === length xs++prop_many_pairs_failure :: Property+prop_many_pairs_failure = once $+ let p = many $ (,) <$> argument str idm <*> argument str idm+ i = info p idm+ nargs = 9999+ result = run i (replicate nargs "foo")+ in assertError result $ \_ -> property succeeded++prop_many_pairs_lazy_progress :: Property+prop_many_pairs_lazy_progress = once $+ let p = many $ (,) <$> optional (option str (short 'a')) <*> argument str idm+ i = info p idm+ result = run i ["foo", "-abar", "baz"]+ in assertResult result $ \xs -> [(Just "bar", "foo"), (Nothing, "baz")] === xs++---++deriving instance Arbitrary a => Arbitrary (Chunk a)+deriving instance Eq SimpleDoc+deriving instance Show SimpleDoc++equalDocs :: Float -> Int -> Doc -> Doc -> Property+equalDocs f w d1 d2 = Doc.renderPretty f w d1+ === Doc.renderPretty f w d2++prop_listToChunk_1 :: [String] -> Property+prop_listToChunk_1 xs = isEmpty (listToChunk xs) === null xs++prop_listToChunk_2 :: [String] -> Property+prop_listToChunk_2 xs = listToChunk xs === mconcat (fmap pure xs)++prop_extractChunk_1 :: String -> Property+prop_extractChunk_1 x = extractChunk (pure x) === x++prop_extractChunk_2 :: Chunk String -> Property+prop_extractChunk_2 x = extractChunk (fmap pure x) === x++prop_stringChunk_1 :: Positive Float -> Positive Int -> String -> Property+prop_stringChunk_1 (Positive f) (Positive w) s =+ equalDocs f w (extractChunk (stringChunk s))+ (Doc.string s)++prop_stringChunk_2 :: String -> Property+prop_stringChunk_2 s = isEmpty (stringChunk s) === null s++prop_paragraph :: String -> Property+prop_paragraph s = isEmpty (paragraph s) === null (words s)++---++return []+main :: IO ()+main = do+ result <- $(quickCheckAll)+ unless result exitFailure