optparse-applicative 0.13.2.0 → 0.14.0.0
raw patch · 20 files changed
+1232/−207 lines, 20 filesdep +bytestringdep +faildep ~base
Dependencies added: bytestring, fail
Dependency ranges changed: base
Files
- CHANGELOG.md +55/−0
- Options/Applicative.hs +204/−11
- Options/Applicative/BashCompletion.hs +189/−27
- Options/Applicative/Builder.hs +88/−17
- Options/Applicative/Builder/Completer.hs +92/−1
- Options/Applicative/Builder/Internal.hs +5/−3
- Options/Applicative/Common.hs +60/−32
- Options/Applicative/Extra.hs +111/−18
- Options/Applicative/Help.hs +6/−2
- Options/Applicative/Help/Chunk.hs +8/−5
- Options/Applicative/Help/Core.hs +10/−6
- Options/Applicative/Help/Levenshtein.hs +61/−0
- Options/Applicative/Help/Types.hs +9/−8
- Options/Applicative/Internal.hs +9/−9
- Options/Applicative/Types.hs +67/−21
- README.md +17/−14
- optparse-applicative.cabal +12/−9
- tests/commands_header.err.txt +4/−1
- tests/commands_header_full.err.txt +4/−1
- tests/test.hs +221/−22
CHANGELOG.md view
@@ -1,3 +1,58 @@+## Version 0.14.0.0 (09 Jun 2017)++- Upgrade `str` and related builders to be polymorphic over+ `IsString`. This allows `Text` and `Bytestring` to be used+ naturally with `strOption` and `strArgument` and friends.++ *Note:* This change may require additional type signatures+ in cases where the reader was necessary for type+ inference.++- Export public API explicitly from `Options.Applicative`+ instead of re-exporting other modules.++ *Note:* Minor changes to exports were made in conjunction+ to this change. `ParserHelp` no longer requires an+ an extra import, and some internally used functions+ from `Options.Applicative.Common` are no longer+ exported from the main module.++- Add Zsh and Fish completions with rich descriptions for+ options and commands.++ Use "--zsh-completion-script" and "fish-completion-script"+ to generate scripts for these shells.++- Fix bash completions with quoted sections, tilde expansions+ and completions after "--".++- Add suggestions to error message when a user mistypes a+ command or option.++- Add `style` builder, for styling option descriptions.++- Improve error message for options when a required argument+ is not supplied.++- Fix #242 regarding flags with long options, where a flag given+ a long option could be interpreted incorrectly.++- Fix `noIntersperse` to be more like its namesakes in other+ libraries. When on, options will be accepted until an argument+ is passed, after which all options will be treated as positional+ arguments.++- Add `forwardOptions` builder, which will allow unknown options+ and flags to be passed to an argument builder.+ This is useful to mixed parsing environments, or wrappers to+ other commands.++- Add `Semigroup` instances for `Completer` and `Chunk`.++- Forwards compatibility with `MonadFail` proposal.++- Doc+ ## Version 0.13.2.0 (9 Mar 2017) - Updated dependency bounds.
Options/Applicative.hs view
@@ -1,30 +1,222 @@ module Options.Applicative ( -- * Applicative option parsers --- -- | This is an empty module which simply re-exports all the public definitions- -- of this package.+ -- | This module exports all one should need for defining and using+ -- optparse-applicative command line option parsers. -- -- See <https://github.com/pcapriotti/optparse-applicative> for a tutorial, -- and a general introduction to applicative option parsers. --- -- See the documentation of individual modules for more details.+ -- See the sections below for more detail -- * Exported modules -- -- | The standard @Applicative@ module is re-exported here for convenience. module Control.Applicative, - -- | Parser type and low-level parsing functionality.- module Options.Applicative.Common,+ -- * Option Parsers+ --+ -- | A 'Parser' is the core type in optparse-applicative. A value of type+ -- @Parser a@ represents a specification for a set of options, which will+ -- yield a value of type a when the command line arguments are successfully+ -- parsed.+ --+ -- There are several types of primitive 'Parser'.+ --+ -- * Flags: simple no-argument options. When a flag is encountered on the+ -- command line, its value is returned.+ --+ -- * Options: options with an argument. An option can define a /reader/,+ -- which converts its argument from String to the desired value, or throws a+ -- parse error if the argument does not validate correctly.+ --+ -- * Arguments: positional arguments, validated in the same way as option+ -- arguments.+ --+ -- * Commands. A command defines a completely independent sub-parser. When a+ -- command is encountered, the whole command line is passed to the+ -- corresponding parser.+ --+ -- See the "Parser Builders" section for how to construct and customise+ -- these parsers.+ Parser, - -- | Utilities to build parsers out of basic primitives.- module Options.Applicative.Builder,+ -- ** Parser builders+ --+ -- | This section contains utility functions and combinators to create parsers+ -- for individual options.+ --+ -- Each parser builder takes an option modifier. A modifier can be created by+ -- composing the basic modifiers provided by here using the 'Monoid' operations+ -- 'mempty' and 'mappend', or their aliases 'idm' and '<>'.+ --+ -- For example:+ --+ -- > out = strOption+ -- > ( long "output"+ -- > <> short 'o'+ -- > <> metavar "FILENAME" )+ --+ -- creates a parser for an option called \"output\".+ flag,+ flag',+ switch, - -- | Common completion functions.- module Options.Applicative.Builder.Completer,+ strOption,+ option, - -- | Utilities to run parsers and display a help text.- module Options.Applicative.Extra,+ strArgument,+ argument,++ subparser,+ hsubparser,++ abortOption,+ infoOption,+ helper,++ -- ** Modifiers+ --+ -- | 'Parser' builders take a modifier, which represents a modification of the+ -- properties of an option, and can be composed as a monoid.+ --+ -- Contraints are often used to ensure that the modifiers can be sensibly applied.+ -- For example, positional arguments can't be specified by long or short names,+ -- so the 'HasName' constraint is used to ensure we have a flag or option.+ Mod,++ short,+ long,+ help,+ helpDoc,+ value,+ showDefaultWith,+ showDefault,+ metavar,+ noArgError,+ hidden,+ internal,+ style,+ command,+ commandGroup,+ completeWith,+ action,+ completer,+ idm,+ mappend,++ OptionFields,+ FlagFields,+ ArgumentFields,+ CommandFields,++ -- ** Readers+ --+ -- | A reader is used by the 'option' and 'argument' builders to parse+ -- the data passed by the user on the command line into a data type.+ --+ -- The most common are 'str' which is used for 'String' like types,+ -- including 'ByteString' and 'Text'; and 'auto', which uses the 'Read'+ -- typeclass, and is good for simple types like 'Int' or 'Double'.+ --+ -- More complex types can use the 'eitherReader' or 'maybeReader'+ -- functions to pattern match or use a more expressive parser like a+ -- member of the 'Parsec' family.+ ReadM,++ auto,+ str,+ maybeReader,+ eitherReader,+ disabled,+ readerAbort,+ readerError,++ -- * Program descriptions+ --+ -- ** 'ParserInfo'+ --+ -- | A 'ParserInfo' describes a command line program, used to generate a help+ -- screen. Two help modes are supported: brief and full. In brief mode, only+ -- an option and argument summary is displayed, while in full mode each+ -- available option and command, including hidden ones, is described.+ --+ -- A 'ParserInfo' should be created with the 'info' function and a set of+ -- 'InfoMod' modifiers.+ --+ info,++ ParserInfo(..),++ InfoMod,+ fullDesc,+ briefDesc,+ header,+ headerDoc,+ footer,+ footerDoc,+ progDesc,+ progDescDoc,+ failureCode,+ noIntersperse,+ forwardOptions,++ -- * Running parsers+ --+ -- | The execParser family of functions are used to run parsers+ execParser,+ customExecParser,+ execParserPure,++ -- ** Handling parser results manually+ getParseResult,+ handleParseResult,+ parserFailure,+ renderFailure,+ overFailure,++ -- ** 'ParserPrefs'+ --+ -- | A 'ParserPrefs' contains general preferences for all command-line+ -- options, and should be built with the 'prefs' function.+ prefs,++ ParserPrefs(..),++ PrefsMod,+ multiSuffix,+ disambiguate,+ showHelpOnError,+ showHelpOnEmpty,+ noBacktrack,+ columns,+ defaultPrefs,++ -- * Completions+ --+ -- | optparse-applicative supplies a rich completion system for bash,+ -- zsh, and fish shells.+ --+ -- 'Completer' functions are used for option and argument to complete+ -- their values.+ --+ -- Use the 'completer' builder to use these.+ -- The 'action' and 'completeWith' builders are also provided for+ -- convenience, to use 'bashCompleter' and 'listCompleter' as a 'Mod'.+ Completer,+ mkCompleter,+ listIOCompleter,++ listCompleter,+ bashCompleter,++ -- * Types+ ParseError(..),+ ParserHelp(..),+ ParserFailure(..),+ ParserResult(..),+ CompletionResult(..)+ ) where -- reexport Applicative here for convenience@@ -34,5 +226,6 @@ import Options.Applicative.Builder import Options.Applicative.Builder.Completer import Options.Applicative.Extra+import Options.Applicative.Types {-# ANN module "HLint: ignore Use import/export shortcut" #-}
Options/Applicative/BashCompletion.hs view
@@ -9,15 +9,28 @@ import Control.Applicative import Prelude-import Data.Foldable (asum)-import Data.List (isPrefixOf)-import Data.Maybe (fromMaybe, listToMaybe)+import Data.Foldable ( asum )+import Data.List ( isPrefixOf )+import Data.Maybe ( fromMaybe, listToMaybe ) import Options.Applicative.Builder import Options.Applicative.Common import Options.Applicative.Internal import Options.Applicative.Types+import Options.Applicative.Help.Pretty+import Options.Applicative.Help.Chunk +-- | Provide basic or rich command completions+data Richness+ = Standard+ -- ^ Add no help descriptions to the completions+ | Enriched Int Int+ -- ^ Include tab separated description for options+ -- and commands when available.+ -- Takes option description length and command+ -- description length.+ deriving (Eq, Ord, Show)+ bashCompletionParser :: ParserInfo a -> ParserPrefs -> Parser CompletionResult bashCompletionParser pinfo pprefs = complParser where@@ -26,38 +39,112 @@ complParser = asum [ failure <$>- ( bashCompletionQuery pinfo pprefs- <$> (many . strOption) (long "bash-completion-word"+ ( bashCompletionQuery pinfo pprefs+ -- To get rich completions, one just needs the first+ -- command. To customise the lengths, use either of+ -- the `desc-length` options.+ -- zsh commands can go on a single line, so they might+ -- want to be longer.+ <$> ( flag' Enriched (long "bash-completion-enriched" `mappend` internal)+ <*> option auto (long "bash-completion-option-desc-length" `mappend` internal `mappend` value 40)+ <*> option auto (long "bash-completion-command-desc-length" `mappend` internal `mappend` value 40)+ <|> pure Standard+ )+ <*> (many . strOption) (long "bash-completion-word" `mappend` internal) <*> option auto (long "bash-completion-index" `mappend` internal) ) , failure <$> (bashCompletionScript <$>- strOption (long "bash-completion-script" `mappend` internal)) ]+ strOption (long "bash-completion-script" `mappend` internal))+ , failure <$>+ (fishCompletionScript <$>+ strOption (long "fish-completion-script" `mappend` internal))+ , failure <$>+ (zshCompletionScript <$>+ strOption (long "zsh-completion-script" `mappend` internal))+ ] -bashCompletionQuery :: ParserInfo a -> ParserPrefs -> [String] -> Int -> String -> IO [String]-bashCompletionQuery pinfo pprefs ws i _ = case runCompletion compl pprefs of- Just (Left (SomeParser p)) -> list_options p- Just (Right c) -> run_completer c- _ -> return []+bashCompletionQuery :: ParserInfo a -> ParserPrefs -> Richness -> [String] -> Int -> String -> IO [String]+bashCompletionQuery pinfo pprefs richness ws i _ = case runCompletion compl pprefs of+ Just (Left (SomeParser p, a))+ -> list_options a p+ Just (Right c)+ -> run_completer c+ Nothing+ -> return [] where- list_options =- fmap concat+ compl = runParserInfo pinfo (drop 1 ws')++ list_options a+ = fmap concat . sequence- . mapParser (const opt_completions)+ . mapParser (opt_completions a) - opt_completions opt = case optMain opt of- OptReader ns _ _ -> return $ show_names ns- FlagReader ns _ -> return $ show_names ns- ArgReader rdr -> run_completer (crCompleter rdr)- CmdReader _ ns _ -> return $ filter_names ns+ --+ -- Prior to 0.14 there was a subtle bug which would+ -- mean that completions from positional arguments+ -- further into the parse would be shown.+ --+ -- We therefore now check to see that+ -- hinfoUnreachableArgs is off before running the+ -- completion for position arguments.+ --+ -- For options and flags, ensure that the user+ -- hasn't disabled them with `--`.+ opt_completions argPolicy hinfo opt = case optMain opt of+ OptReader ns _ _+ | argPolicy /= AllPositionals+ -> return . add_opt_help opt $ show_names ns+ | otherwise+ -> return []+ FlagReader ns _+ | argPolicy /= AllPositionals+ -> return . add_opt_help opt $ show_names ns+ | otherwise+ -> return []+ ArgReader rdr+ | hinfoUnreachableArgs hinfo+ -> return []+ | otherwise+ -> run_completer (crCompleter rdr)+ CmdReader _ ns p+ | hinfoUnreachableArgs hinfo+ -> return []+ | otherwise+ -> return . add_cmd_help p $ filter_names ns - show_name :: OptName -> String- show_name (OptShort c) = '-':[c]- show_name (OptLong name) = "--" ++ name+ -- When doing enriched completions, add any help specified+ -- to the completion variables (tab separated).+ add_opt_help :: Functor f => Option a -> f String -> f String+ add_opt_help opt = case richness of+ Standard+ -> id+ Enriched len _+ -> fmap (\o -> let h = unChunk $ optHelp opt+ in maybe o (\h' -> o ++ "\t" ++ render_line len h') h) + -- When doing enriched completions, add the command description+ -- to the completion variables (tab separated).+ add_cmd_help :: Functor f => (String -> Maybe (ParserInfo a)) -> f String -> f String+ add_cmd_help p = case richness of+ Standard+ -> id+ Enriched _ len+ -> fmap (\cmd -> let h = p cmd >>= unChunk . infoProgDesc+ in maybe cmd (\h' -> cmd ++ "\t" ++ render_line len h') h)+ show_names :: [OptName] -> [String]- show_names = filter_names . map show_name+ show_names = filter_names . map showOption + -- We only want to show a single line in the completion results description.+ -- If there was a line break, it would come across as a different completion+ -- possibility.+ render_line :: Int -> Doc -> String+ render_line len doc = case lines (displayS (renderPretty 1 len doc) "") of+ [] -> ""+ [x] -> x+ x : _ -> x ++ "..."+ filter_names :: [String] -> [String] filter_names = filter is_completion @@ -72,14 +159,12 @@ w:_ -> isPrefixOf w _ -> const True - compl = runParserInfo pinfo (drop 1 ws')- bashCompletionScript :: String -> String -> IO [String] bashCompletionScript prog progn = return [ "_" ++ progn ++ "()" , "{"- , " local cmdline"- , " local IFS=$'\n'"+ , " local CMDLINE"+ , " local IFS=$'\\n'" , " CMDLINE=(--bash-completion-index $COMP_CWORD)" , "" , " for arg in ${COMP_WORDS[@]}; do"@@ -90,3 +175,80 @@ , "}" , "" , "complete -o filenames -F _" ++ progn ++ " " ++ progn ]++{-+/Note/: Fish Shell++Derived from Drezil's post in #169.++@+commandline+-c or --cut-at-cursor only print selection up until the current cursor position+-o or --tokenize tokenize the selection and print one string-type token per line+@++We tokenize so that the call to count (and hence --bash-completion-index)+gets the right number use cut-at-curstor to not bother sending anything+after the cursor position, which allows for completion of the middle of+words.++Tab characters separate items from descriptions.+-}+fishCompletionScript :: String -> String -> IO [String]+fishCompletionScript prog progn = return+ [ " function _" ++ progn+ , " set -l cl (commandline --tokenize --current-process)"+ , " # Hack around fish issue #3934"+ , " set -l cn (commandline --tokenize --cut-at-cursor --current-process)"+ , " set -l cn (count $cn)"+ , " set -l tmpline --bash-completion-enriched --bash-completion-index $cn"+ , " for arg in $cl"+ , " set tmpline $tmpline --bash-completion-word $arg"+ , " end"+ , " for opt in (" ++ prog ++ " $tmpline)"+ , " if test -d $opt"+ , " echo -E \"$opt/\""+ , " else"+ , " echo -E \"$opt\""+ , " end"+ , " end"+ , "end"+ , ""+ , "complete --no-files --command " ++ progn ++ " --arguments '(_" ++ progn ++ ")'"+ ]++zshCompletionScript :: String -> String -> IO [String]+zshCompletionScript prog progn = return+ [ "#compdef " ++ progn+ , ""+ , "local request"+ , "local completions"+ , "local word"+ , "local index=$((CURRENT - 1))"+ , ""+ , "request=(--bash-completion-enriched --bash-completion-index $index)"+ , "for arg in ${words[@]}; do"+ , " request=(${request[@]} --bash-completion-word $arg)"+ , "done"+ , ""+ , "IFS=$'\\n' completions=($( " ++ prog ++ " \"${request[@]}\" ))"+ , ""+ , "for word in $completions; do"+ , " local -a parts"+ , ""+ , " # Split the line at a tab if there is one."+ , " IFS=$'\\t' parts=($( echo $word ))"+ , ""+ , " if [[ -n $parts[2] ]]; then"+ , " if [[ $word[1] == \"-\" ]]; then"+ , " local desc=(\"$parts[1] ($parts[2])\")"+ , " compadd -d desc -- $parts[1]"+ , " else"+ , " local desc=($(print -f \"%-019s -- %s\" $parts[1] $parts[2]))"+ , " compadd -l -d desc -- $parts[1]"+ , " fi"+ , " else"+ , " compadd -f -- $word"+ , " fi"+ , "done"+ ]
Options/Applicative/Builder.hs view
@@ -41,6 +41,7 @@ ParseError(..), hidden, internal,+ style, command, commandGroup, completeWith,@@ -72,6 +73,7 @@ progDescDoc, failureCode, noIntersperse,+ forwardOptions, info, -- * Builder for 'ParserPrefs'@@ -96,6 +98,7 @@ import Control.Applicative import Data.Semigroup hiding (option)+import Data.String (fromString, IsString) import Options.Applicative.Builder.Completer import Options.Applicative.Builder.Internal@@ -104,7 +107,7 @@ import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk --- readers --+-- Readers -- -- | 'Option' reader based on the 'Read' type class. auto :: Read a => ReadM a@@ -113,17 +116,28 @@ _ -> Left $ "cannot parse value `" ++ arg ++ "'" -- | String 'Option' reader.-str :: ReadM String-str = readerAsk+--+-- Polymorphic over the `IsString` type class since 0.14.+str :: IsString s => ReadM s+str = fromString <$> readerAsk --- | Convert a function in the 'Either' monad to a reader.+-- | Convert a function producing an 'Either' into a reader.+--+-- As an example, one can create a ReadM from an attoparsec Parser+-- easily with+--+-- > import qualified Data.Attoparsec.Text as A+-- > import qualified Data.Text as T+-- > attoparsecReader :: A.Parser a => ReadM a+-- > attoparsecReader p = eitherReader (A.parseOnly p . T.pack) eitherReader :: (String -> Either String a) -> ReadM a eitherReader f = readerAsk >>= either readerError return . f --- | Convert a function in the 'Maybe' monad to a reader.+-- | Convert a function producing a 'Maybe' into a reader. maybeReader :: (String -> Maybe a) -> ReadM a-maybeReader f = eitherReader $ \arg ->- maybe (Left $ "cannot parse value `" ++ arg ++ "'") pure . f $ arg+maybeReader f = do+ arg <- readerAsk+ maybe (readerError $ "cannot parse value `" ++ arg ++ "'") return . f $ arg -- | Null 'Option' reader. All arguments will fail validation. disabled :: ReadM a@@ -170,7 +184,7 @@ -- | 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 }+noArgError e = fieldMod $ \p -> p { optNoArgError = const e } -- | Specify a metavariable for the argument. --@@ -184,26 +198,55 @@ hidden = optionMod $ \p -> p { propVisibility = min Hidden (propVisibility p) } +-- | Apply a function to the option description in the usage text.+--+-- > import Options.Applicative.Help+-- > flag' () (short 't' <> style bold)+--+-- /NOTE/: This builder is more flexible than its name and example+-- allude. One of the motivating examples for its addition was to+-- used `const` to completely replace the usage text of an option.+style :: ( Doc -> Doc ) -> Mod f a+style x = optionMod $ \p ->+ p { propDescMod = Just x }+ -- | Add a command to a subparser option.+--+-- Suggested usage for multiple commands is to add them to a single subparser. e.g.+--+-- @+-- sample :: Parser Sample+-- sample = subparser+-- ( command "hello"+-- (info hello (progDesc "Print greeting"))+-- <> command "goodbye"+-- (info goodbye (progDesc "Say goodbye"))+-- )+-- @ command :: String -> ParserInfo a -> Mod CommandFields a command cmd pinfo = fieldMod $ \p -> p { cmdCommands = (cmd, pinfo) : cmdCommands p } -- | Add a description to a group of commands.+--+-- Advanced feature for separating logical groups of commands on the parse line.+--+-- If using the same `metavar` for each group of commands, it may yield a more+-- attractive usage text combined with `hidden` for some groups. 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)+completeWith = completer . listCompleter -- | Add a bash completion action. Common actions include @file@ and -- @directory@. See -- <http://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html#Programmable-Completion-Builtins> -- for a complete list. action :: HasCompleter f => String -> Mod f a-action act = completer (bashCompleter act)+action = completer . bashCompleter -- | Add a completer to an argument. --@@ -231,7 +274,7 @@ rdr = CReader compl p -- | Builder for a 'String' argument.-strArgument :: Mod ArgumentFields String -> Parser String+strArgument :: IsString s => Mod ArgumentFields s -> Parser s strArgument = argument str -- | Builder for a flag parser.@@ -298,7 +341,7 @@ infoOption = abortOption . InfoMsg -- | Builder for an option taking a 'String' argument.-strOption :: Mod OptionFields String -> Parser String+strOption :: IsString s => Mod OptionFields s -> Parser s strOption = option str -- | Same as 'option'.@@ -317,7 +360,7 @@ option r m = mkParser d g rdr where Mod f d g = metavar "ARG" `mappend` m- fields = f (OptionFields [] mempty (ErrorMsg ""))+ fields = f (OptionFields [] mempty ExpectsArgError) crdr = CReader (optCompleter fields) r rdr = OptReader (optNames fields) crdr (optNoArgError fields) @@ -371,10 +414,23 @@ failureCode :: Int -> InfoMod a failureCode n = InfoMod $ \i -> i { infoFailureCode = n } --- | Disable parsing of regular options after arguments+-- | Disable parsing of regular options after arguments. After a positional+-- argument is parsed, all remaining options and arguments will be treated+-- as a positional arguments. Not recommended in general as users often+-- expect to be able to freely intersperse regular options and flags within+-- command line options. noIntersperse :: InfoMod a-noIntersperse = InfoMod $ \p -> p { infoIntersperse = False }+noIntersperse = InfoMod $ \p -> p { infoPolicy = NoIntersperse } +-- | Intersperse matched options and arguments normally, but allow unmatched+-- options to be treated as positional arguments.+-- This is sometimes useful if one is wrapping a third party cli tool and+-- needs to pass options through, while also providing a handful of their+-- own options. Not recommended in general as typos by the user may not+-- yield a parse error and cause confusion.+forwardOptions :: InfoMod a+forwardOptions = InfoMod $ \p -> p { infoPolicy = ForwardOptions }+ -- | Create a 'ParserInfo' given a 'Parser' and a modifier. info :: Parser a -> InfoMod a -> ParserInfo a info parser m = applyInfoMod m base@@ -386,7 +442,7 @@ , infoHeader = mempty , infoFooter = mempty , infoFailureCode = 1- , infoIntersperse = True }+ , infoPolicy = Intersperse } newtype PrefsMod = PrefsMod { applyPrefsMod :: ParserPrefs -> ParserPrefs }@@ -398,24 +454,39 @@ instance Semigroup PrefsMod where m1 <> m2 = PrefsMod $ applyPrefsMod m2 . applyPrefsMod m1 +-- | Include a suffix to attach to the metavar when multiple values+-- can be entered. multiSuffix :: String -> PrefsMod multiSuffix s = PrefsMod $ \p -> p { prefMultiSuffix = s } +-- | Turn on disambiguation.+--+-- See+-- https://github.com/pcapriotti/optparse-applicative#disambiguation disambiguate :: PrefsMod disambiguate = PrefsMod $ \p -> p { prefDisambiguate = True } +-- | Show full help text on any error. showHelpOnError :: PrefsMod showHelpOnError = PrefsMod $ \p -> p { prefShowHelpOnError = True } +-- | Show the help text if the user enters only the program name or+-- subcommand.+--+-- This will suppress a "Missing:" error and show the full usage+-- instead if a user just types the name of the program. showHelpOnEmpty :: PrefsMod showHelpOnEmpty = PrefsMod $ \p -> p { prefShowHelpOnEmpty = True } +-- | Turn off backtracking after subcommand is parsed. noBacktrack :: PrefsMod noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False } +-- | Set the maximum width of the generated help text. columns :: Int -> PrefsMod columns cols = PrefsMod $ \p -> p { prefColumns = cols } +-- | Create a `ParserPrefs` given a modifier prefs :: PrefsMod -> ParserPrefs prefs m = applyPrefsMod m base where@@ -427,7 +498,7 @@ , prefBacktrack = True , prefColumns = 80 } --- convenience shortcuts+-- Convenience shortcuts -- | Trivial option modifier. idm :: Monoid m => m
Options/Applicative/Builder/Completer.hs view
@@ -14,18 +14,109 @@ import Options.Applicative.Types +-- | Create a 'Completer' from an IO action listIOCompleter :: IO [String] -> Completer listIOCompleter ss = Completer $ \s -> filter (isPrefixOf s) <$> ss +-- | Create a 'Completer' from a constant+-- list of strings. listCompleter :: [String] -> Completer listCompleter = listIOCompleter . pure +-- | Run a compgen completion action.+--+-- Common actions include @file@ and+-- @directory@. See+-- <http://www.gnu.org/software/bash/manual/html_node/Programmable-Completion-Builtins.html#Programmable-Completion-Builtins>+-- for a complete list. bashCompleter :: String -> Completer bashCompleter action = Completer $ \word -> do- let cmd = unwords ["compgen", "-A", action, "--", word]+ let cmd = unwords ["compgen", "-A", action, "--", requote word] result <- tryIO $ readProcess "bash" ["-c", cmd] "" return . lines . either (const []) id $ result tryIO :: IO a -> IO (Either IOException a) tryIO = try++-- | Strongly quote the string we pass to compgen.+--+-- We need to do this so bash doesn't expand out any ~ or other+-- chars we want to complete on, or emit an end of line error+-- when seeking the close to the quote.+requote :: String -> String+requote s =+ let+ -- Bash doesn't appear to allow "mixed" escaping+ -- in bash completions. So we don't have to really+ -- worry about people swapping between strong and+ -- weak quotes.+ unescaped =+ case s of+ -- It's already strongly quoted, so we+ -- can use it mostly as is, but we must+ -- ensure it's closed off at the end and+ -- there's no single quotes in the+ -- middle which might confuse bash.+ ('\'': rs) -> unescapeN rs++ -- We're weakly quoted.+ ('"': rs) -> unescapeD rs++ -- We're not quoted at all.+ -- We need to unescape some characters like+ -- spaces and quotation marks.+ elsewise -> unescapeU elsewise+ in+ strong unescaped++ where+ strong ss = '\'' : foldr go "'" ss+ where+ -- If there's a single quote inside the+ -- command: exit from the strong quote and+ -- emit it the quote escaped, then resume.+ go '\'' t = "'\\''" ++ t+ go h t = h : t++ -- Unescape a strongly quoted string+ -- We have two recursive functions, as we+ -- can enter and exit the strong escaping.+ unescapeN = goX+ where+ goX ('\'' : xs) = goN xs+ goX (x : xs) = x : goX xs+ goX [] = []++ goN ('\\' : '\'' : xs) = '\'' : goN xs+ goN ('\'' : xs) = goX xs+ goN (x : xs) = x : goN xs+ goN [] = []++ -- Unescape an unquoted string+ unescapeU = goX+ where+ goX [] = []+ goX ('\\' : x : xs) = x : goX xs+ goX (x : xs) = x : goX xs++ -- Unescape a weakly quoted string+ unescapeD = goX+ where+ -- Reached an escape character+ goX ('\\' : x : xs)+ -- If it's true escapable, strip the+ -- slashes, as we're going to strong+ -- escape instead.+ | x `elem` "$`\"\\\n" = x : goX xs+ | otherwise = '\\' : x : goX xs+ -- We've ended quoted section, so we+ -- don't recurse on goX, it's done.+ goX ('"' : xs)+ = xs+ -- Not done, but not a special character+ -- just continue the fold.+ goX (x : xs)+ = x : goX xs+ goX []+ = []
Options/Applicative/Builder/Internal.hs view
@@ -34,7 +34,7 @@ data OptionFields a = OptionFields { optNames :: [OptName] , optCompleter :: Completer- , optNoArgError :: ParseError }+ , optNoArgError :: String -> ParseError } data FlagFields a = FlagFields { flagNames :: [OptName]@@ -118,7 +118,7 @@ -- -- Modifiers are instances of 'Monoid', and can be composed as such. ----- You rarely need to deal with modifiers directly, as most of the times it is+-- One rarely needs to deal with modifiers directly, as most of the times it is -- sufficient to pass them to builders (such as 'strOption' or 'flag') to -- create options (see 'Options.Applicative.Builder'). data Mod f a = Mod (f a -> f a)@@ -145,7 +145,9 @@ { propMetaVar = "" , propVisibility = Visible , propHelp = mempty- , propShowDefault = Nothing }+ , propShowDefault = Nothing+ , propDescMod = Nothing+ } mkCommand :: Mod CommandFields a -> (Maybe String, [String], String -> Maybe (ParserInfo a)) mkCommand m = (group, map fst cmds, (`lookup` cmds))
Options/Applicative/Common.hs view
@@ -55,7 +55,7 @@ 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 Prelude import Options.Applicative.Internal@@ -89,7 +89,7 @@ prefs <- getPrefs let runSubparser | prefBacktrack prefs = \i a ->- runParser (getPolicy i) CmdStart (infoParser i) a+ runParser (infoPolicy i) CmdStart (infoParser i) a | otherwise = \i a -> (,) <$> runParserInfo i a <*> pure [] enterContext arg subp *> runSubparser subp args <* exitContext@@ -102,12 +102,18 @@ Just $ do args <- get let mb_args = uncons $ maybeToList val ++ args- let missing_arg = lift $ missingArgP no_arg_err (crCompleter rdr)- (arg', args') <- maybe missing_arg return mb_args+ let missing_arg = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr)+ (arg', args') <- maybe (lift missing_arg) return mb_args put args' lift $ runReadM (withReadM (errorFor arg1) (crReader rdr)) arg'+ FlagReader names x -> do guard $ has_name arg1 names+ -- #242 Flags/switches succeed incorrectly when given an argument.+ -- We'll not match a long option for a flag if there's a word attached.+ -- This was revealing an implementation detail as+ -- `--foo=val` was being parsed as `--foo -val`, which is gibberish.+ guard $ is_short arg1 || isNothing val Just $ do args <- get let val' = (\s -> '-' : s) <$> val@@ -117,6 +123,9 @@ where errorFor name msg = "option " ++ showOption name ++ ": " ++ msg + is_short (OptShort _) = True+ is_short (OptLong _) = False+ has_name a | disambiguate = any (isOptionPrefix a) | otherwise = elem a@@ -179,52 +188,52 @@ stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String -> Parser a -> NondetT (StateT Args m) (Parser a)-stepParser pprefs SkipOpts arg p = case parseWord arg of+stepParser _ AllPositionals arg p =+ searchArg arg p+stepParser pprefs ForwardOptions arg p = case parseWord arg of+ Just w -> searchOpt pprefs w p <|> searchArg arg p+ Nothing -> searchArg arg p+stepParser pprefs _ arg p = case parseWord arg of Just w -> 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 -> IsCmdStart -> Parser a -> Args -> m (a, Args)-runParser SkipOpts _ p ("--" : argt) = runParser AllowOpts CmdCont p argt+runParser policy _ p ("--" : argt) | policy /= AllPositionals+ = runParser AllPositionals CmdCont p argt runParser policy isCmdStart p args = case args of- [] -> exitP isCmdStart p result+ [] -> exitP isCmdStart policy p result (arg : argt) -> do prefs <- getPrefs (mp', args') <- do_step prefs arg argt case mp' of- Nothing -> hoistMaybe result <|> parseError arg- Just p' -> runParser policy CmdCont p' args'+ Nothing -> hoistMaybe result <|> parseError arg p+ Just p' -> runParser (newPolicy arg) CmdCont p' args' where result = (,) <$> evalParser p <*> pure args do_step prefs arg argt = (`runStateT` argt) . disamb (not (prefDisambiguate prefs)) $ stepParser prefs policy arg p -parseError :: MonadP m => String -> m a-parseError arg = errorP . ErrorMsg $ msg- where- msg = case arg of- ('-':_) -> "Invalid option `" ++ arg ++ "'"- _ -> "Invalid argument `" ++ arg ++ "'"+ newPolicy a = case policy of+ NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals+ x -> x -getPolicy :: ParserInfo a -> ArgPolicy-getPolicy i = if infoIntersperse i- then SkipOpts- else AllowOpts+parseError :: MonadP m => String -> Parser x -> m a+parseError arg = errorP . UnexpectedError arg . SomeParser runParserInfo :: MonadP m => ParserInfo a -> Args -> m a-runParserInfo i = runParserFully (getPolicy i) (infoParser i)+runParserInfo i = runParserFully (infoPolicy i) (infoParser i) runParserFully :: MonadP m => ArgPolicy -> Parser a -> Args -> m a runParserFully policy p args = do (r, args') <- runParser policy CmdStart p args case args' of [] -> return r- a:_ -> parseError a+ a:_ -> parseError a (pure ()) -- | The default value of a 'Parser'. This function returns an error if any of -- the options don't have a default value.@@ -238,7 +247,7 @@ -- | Map a polymorphic function over all the options of a parser, and collect -- the results in a list. mapParser :: (forall x. OptHelpInfo -> Option x -> b)- -> Parser a -> [b]+ -> Parser a -> [b] mapParser f = flatten . treeMapParser f where flatten (Leaf x) = [x]@@ -249,25 +258,44 @@ treeMapParser :: (forall x . OptHelpInfo -> Option x -> b) -> Parser a -> OptTree b-treeMapParser g = simplify . go False False g+treeMapParser g = simplify . go False False False g where has_default :: Parser a -> Bool has_default p = isJust (evalParser p) - go :: Bool -> Bool+ go :: Bool -> Bool -> Bool -> (forall x . OptHelpInfo -> Option x -> b) -> Parser a -> OptTree b- go _ _ _ (NilP _) = MultNode []- go m d f (OptP opt)+ go _ _ _ _ (NilP _) = MultNode []+ go m d r f (OptP opt) | optVisibility opt > Internal- = Leaf (f (OptHelpInfo m d) opt)+ = Leaf (f (OptHelpInfo m d r) opt) | otherwise = MultNode []- go m d f (MultP p1 p2) = MultNode [go m d f p1, go m d f p2]- go m d f (AltP p1 p2) = AltNode [go m d' f p1, go m d' f p2]+ go m d r f (MultP p1 p2) = MultNode [go m d r f p1, go m d r' f p2]+ where r' = r || has_positional p1+ go m d r f (AltP p1 p2) = AltNode [go m d' r f p1, go m d' r f p2] where d' = d || has_default p1 || has_default p2- go _ d f (BindP p _) = go True d f p+ go _ d r f (BindP p k) =+ let go' = go True d r f p+ in case evalParser p of+ Nothing -> go'+ Just aa -> MultNode [ go', go True d r f (k aa) ]++ has_positional :: Parser a -> Bool+ has_positional (NilP _) = False+ has_positional (OptP p) = (is_positional . optMain) p+ has_positional (MultP p1 p2) = has_positional p1 || has_positional p2+ has_positional (AltP p1 p2) = has_positional p1 || has_positional p2+ has_positional (BindP p _) = has_positional p++ is_positional :: OptReader a -> Bool+ is_positional (OptReader {}) = False+ is_positional (FlagReader {}) = False+ is_positional (ArgReader {}) = True+ is_positional (CmdReader {}) = True+ simplify :: OptTree a -> OptTree a simplify (Leaf x) = Leaf x
Options/Applicative/Extra.hs view
@@ -29,7 +29,7 @@ import System.IO (hPutStrLn, stderr) import Options.Applicative.BashCompletion-import Options.Applicative.Builder hiding (briefDesc)+import Options.Applicative.Builder import Options.Applicative.Builder.Internal import Options.Applicative.Common import Options.Applicative.Help@@ -38,6 +38,13 @@ import Options.Applicative.Types -- | A hidden \"helper\" option which always fails.+--+-- A common usage pattern is to apply this applicatively when+-- creating a 'ParserInfo'+--+-- > opts :: ParserInfo Sample+-- > opts = info (sample <**> helper) mempty+ helper :: Parser (a -> a) helper = abortOption ShowHelpText $ mconcat [ long "help"@@ -143,15 +150,18 @@ let h = with_context ctx pinfo $ \names pinfo' -> mconcat [ base_help pinfo' , usage_help progn names pinfo'+ , suggestion_help , error_help ] 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)+ ExpectsArgError {} -> ExitFailure (infoFailureCode pinfo)+ UnexpectedError {} -> ExitFailure (infoFailureCode pinfo)+ ShowHelpText -> ExitSuccess+ InfoMsg {} -> ExitSuccess with_context :: [Context] -> ParserInfo a@@ -161,20 +171,103 @@ with_context c@(Context _ i:_) _ f = f (contextNames c) i usage_help progn names i = case msg of- InfoMsg _ -> mempty- _ -> usageHelp $ vcatChunks- [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names- , fmap (indent 2) . infoProgDesc $ i ]+ InfoMsg _+ -> mempty+ _+ -> usageHelp $ vcatChunks+ [ pure . parserUsage pprefs (infoParser i) . unwords $ progn : names+ , fmap (indent 2) . infoProgDesc $ i ] error_help = errorHelp $ case msg of- 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+ ShowHelpText+ -> mempty + ErrorMsg m+ -> stringChunk m++ InfoMsg m+ -> stringChunk m++ MissingError CmdStart _+ | prefShowHelpOnEmpty pprefs+ -> mempty++ MissingError _ (SomeParser x)+ -> stringChunk "Missing:" <<+>> missingDesc pprefs x++ ExpectsArgError x+ -> stringChunk $ "The option `" ++ x ++ "` expects an argument."++ UnexpectedError arg _+ -> stringChunk msg'+ where+ --+ -- This gives us the same error we have always+ -- reported+ msg' = case arg of+ ('-':_) -> "Invalid option `" ++ arg ++ "'"+ _ -> "Invalid argument `" ++ arg ++ "'"++ UnknownError+ -> mempty+++ suggestion_help = suggestionsHelp $ case msg of+ UnexpectedError arg (SomeParser x)+ --+ -- We have an unexpected argument and the parser which+ -- it's running over.+ --+ -- We can make a good help suggestion here if we do+ -- a levenstein distance between all possible suggestions+ -- and the supplied option or argument.+ -> suggestions+ where+ --+ -- Not using chunked here, as we don't want to+ -- show "Did you mean" if there's nothing there+ -- to show+ suggestions = (.$.) <$> prose+ <*> (indent 4 <$> (vcatChunks . fmap stringChunk $ good ))++ --+ -- We won't worry about the 0 case, it won't be+ -- shown anyway.+ prose = if length good < 2+ then stringChunk "Did you mean this?"+ else stringChunk "Did you mean one of these?"+ --+ -- Suggestions we will show, they're close enough+ -- to what the user wrote+ good = filter isClose possibles++ --+ -- Bit of an arbitrary decision here.+ -- Edit distances of 1 or 2 will give hints+ isClose a = editDistance a arg < 3++ --+ -- Similar to how bash completion works.+ -- We map over the parser and get the names+ -- ( no IO here though, unlike for completers )+ possibles = concat $ mapParser opt_completions x++ --+ -- Look at the option and give back the possible+ -- 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 hinfo opt = case optMain opt of+ OptReader ns _ _ -> fmap showOption ns+ FlagReader ns _ -> fmap showOption ns+ ArgReader _ -> []+ CmdReader _ ns _ | hinfoUnreachableArgs hinfo+ -> []+ | otherwise+ -> ns+ _+ -> mempty+ base_help :: ParserInfo a -> ParserHelp base_help i | show_full_help@@ -187,7 +280,7 @@ show_full_help = case msg of ShowHelpText -> True- MissingError CmdStart _ | prefShowHelpOnEmpty pprefs+ MissingError CmdStart _ | prefShowHelpOnEmpty pprefs -> True _ -> prefShowHelpOnError pprefs
Options/Applicative/Help.hs view
@@ -16,9 +16,13 @@ -- | Core implementation of the help text -- generator. module Options.Applicative.Help.Core,++ -- | Edit distance calculations for suggestions+ module Options.Applicative.Help.Levenshtein ) where -import Options.Applicative.Help.Pretty import Options.Applicative.Help.Chunk-import Options.Applicative.Help.Types import Options.Applicative.Help.Core+import Options.Applicative.Help.Levenshtein+import Options.Applicative.Help.Pretty+import Options.Applicative.Help.Types
Options/Applicative/Help/Chunk.hs view
@@ -17,7 +17,7 @@ import Control.Applicative import Control.Monad import Data.Maybe-import Data.Monoid+import Data.Semigroup import Prelude import Options.Applicative.Help.Pretty@@ -45,6 +45,13 @@ return = pure m >>= f = Chunk $ unChunk m >>= unChunk . f +instance Monoid a => Semigroup (Chunk a) where+ (<>) = chunked mappend++instance Monoid a => Monoid (Chunk a) where+ mempty = Chunk Nothing+ mappend = (<>)+ instance MonadPlus Chunk where mzero = Chunk mzero mplus m1 m2 = Chunk $ mplus (unChunk m1) (unChunk m2)@@ -65,10 +72,6 @@ listToChunk :: Monoid a => [a] -> Chunk a listToChunk [] = mempty listToChunk xs = pure (mconcat xs)--instance Monoid a => Monoid (Chunk a) where- mempty = Chunk Nothing- mappend = chunked mappend -- | Part of a constrained comonad instance. --
Options/Applicative/Help/Core.hs view
@@ -7,6 +7,7 @@ ParserHelp(..), errorHelp, headerHelp,+ suggestionsHelp, usageHelp, bodyHelp, footerHelp,@@ -64,7 +65,7 @@ = mappend chunk suffix | otherwise = mappend (fmap parens chunk) suffix- in render desc'+ in maybe id fmap (optDescMod opt) (render desc') -- | Generate descriptions for commands. cmdDesc :: Parser a -> [(Maybe String, Chunk Doc)]@@ -131,19 +132,22 @@ , descSurround = False } errorHelp :: Chunk Doc -> ParserHelp-errorHelp chunk = ParserHelp chunk mempty mempty mempty mempty+errorHelp chunk = mempty { helpError = chunk } headerHelp :: Chunk Doc -> ParserHelp-headerHelp chunk = ParserHelp mempty chunk mempty mempty mempty+headerHelp chunk = mempty { helpHeader = chunk } +suggestionsHelp :: Chunk Doc -> ParserHelp+suggestionsHelp chunk = mempty { helpSuggestions = chunk }+ usageHelp :: Chunk Doc -> ParserHelp-usageHelp chunk = ParserHelp mempty mempty chunk mempty mempty+usageHelp chunk = mempty { helpUsage = chunk } bodyHelp :: Chunk Doc -> ParserHelp-bodyHelp chunk = ParserHelp mempty mempty mempty chunk mempty+bodyHelp chunk = mempty { helpBody = chunk } footerHelp :: Chunk Doc -> ParserHelp-footerHelp chunk = ParserHelp mempty mempty mempty mempty chunk+footerHelp chunk = mempty { helpFooter = chunk } -- | Generate the help text for a program. parserHelp :: ParserPrefs -> Parser a -> ParserHelp
+ Options/Applicative/Help/Levenshtein.hs view
@@ -0,0 +1,61 @@+module Options.Applicative.Help.Levenshtein (+ editDistance+ ) where++-- | Calculate the Damerau-Levenshtein edit distance+-- between two lists (strings).+--+-- This is modified from+-- https://wiki.haskell.org/Edit_distance+-- and is originally from Lloyd Allison's paper+-- "Lazy Dynamic-Programming can be Eager"+--+-- It's been changed though from Levenshtein to+-- Damerau-Levenshtein, which treats transposition+-- of adjacent characters as one change instead of+-- two.+editDistance :: Eq a => [a] -> [a] -> Int+editDistance a b = last $+ case () of+ _ | lab == 0+ -> mainDiag+ | lab > 0+ -> lowers !! (lab - 1)+ | otherwise+ -> uppers !! (-1 - lab)+ where+ mainDiag = oneDiag a b (head uppers) (-1 : head lowers)+ uppers = eachDiag a b (mainDiag : uppers) -- upper diagonals+ lowers = eachDiag b a (mainDiag : lowers) -- lower diagonals+ eachDiag _ [] _ = []+ eachDiag _ _ [] = []+ eachDiag a' (_:bs) (lastDiag:diags) =+ oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags+ where+ nextDiag = head (tail diags)+ oneDiag a' b' diagAbove diagBelow = thisdiag+ where+ doDiag [] _ _ _ _ = []+ doDiag _ [] _ _ _ = []+ -- Check for a transposition+ -- We don't add anything to nw here, the next character+ -- will be different however and the transposition+ -- will have an edit distance of 1.+ doDiag (ach:ach':as) (bch:bch':bs) nw n w+ | ach' == bch && ach == bch'+ = nw : (doDiag (ach' : as) (bch' : bs) nw (tail n) (tail w))+ -- Standard case+ doDiag (ach:as) (bch:bs) nw n w =+ me : (doDiag as bs me (tail n) (tail w))+ where+ me =+ if ach == bch+ then nw+ else 1 + min3 (head w) nw (head n)+ firstelt = 1 + head diagBelow+ thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow)+ lab = length a - length b+ min3 x y z =+ if x < y+ then x+ else min y z
Options/Applicative/Help/Types.hs view
@@ -1,6 +1,6 @@ module Options.Applicative.Help.Types (- ParserHelp(..),- renderHelp+ ParserHelp (..)+ , renderHelp ) where import Data.Semigroup@@ -11,6 +11,7 @@ data ParserHelp = ParserHelp { helpError :: Chunk Doc+ , helpSuggestions :: Chunk Doc , helpHeader :: Chunk Doc , helpUsage :: Chunk Doc , helpBody :: Chunk Doc@@ -20,17 +21,17 @@ showsPrec _ h = showString (renderHelp 80 h) instance Monoid ParserHelp where- mempty = ParserHelp mempty mempty mempty mempty mempty+ mempty = ParserHelp mempty mempty mempty mempty mempty mempty 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)+ (ParserHelp e1 s1 h1 u1 b1 f1) <> (ParserHelp e2 s2 h2 u2 b2 f2)+ = ParserHelp (mappend e1 e2) (mappend s1 s2)+ (mappend h1 h2) (mappend u1 u2)+ (mappend b1 b2) (mappend f1 f2) helpText :: ParserHelp -> Doc-helpText (ParserHelp e h u b f) = extractChunk . vsepChunks $ [e, h, u, b, f]+helpText (ParserHelp e s h u b f) = extractChunk . vsepChunks $ [e, s, h, u, b, f] -- | Convert a help text to 'String'. renderHelp :: Int -> ParserHelp -> String
Options/Applicative/Internal.hs view
@@ -46,7 +46,7 @@ missingArgP :: ParseError -> Completer -> m a tryP :: m a -> m (Either ParseError a) errorP :: ParseError -> m a- exitP :: IsCmdStart -> Parser b -> Maybe a -> m a+ exitP :: IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> m a newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a) @@ -62,7 +62,7 @@ P x <|> P y = P $ x <|> y instance Monad P where- return a = P $ return a+ return = pure P x >>= k = P $ x >>= \a -> case k a of P y -> y instance MonadPlus P where@@ -81,7 +81,7 @@ missingArgP e _ = errorP e tryP (P p) = P $ lift $ runExceptT p- exitP i p = P . maybe (throwE . MissingError i . SomeParser $ p) return+ exitP i _ p = P . maybe (throwE . MissingError i . SomeParser $ p) return errorP = P . throwE hoistMaybe :: MonadPlus m => Maybe a -> m a@@ -107,7 +107,7 @@ f' e = e data ComplResult a- = ComplParser SomeParser+ = ComplParser SomeParser ArgPolicy | ComplOption Completer | ComplResult a @@ -122,7 +122,7 @@ return = pure m >>= f = case m of ComplResult r -> f r- ComplParser p -> ComplParser p+ ComplParser p a -> ComplParser p a ComplOption c -> ComplOption c newtype Completion a =@@ -140,7 +140,7 @@ Completion x <|> Completion y = Completion $ x <|> y instance Monad Completion where- return a = Completion $ return a+ return = pure Completion x >>= k = Completion $ x >>= \a -> case k a of Completion y -> y instance MonadPlus Completion where@@ -154,13 +154,13 @@ missingArgP _ = Completion . lift . lift . ComplOption tryP (Completion p) = Completion $ catchE (Right <$> p) (return . Left)- exitP _ p _ = Completion . lift . lift . ComplParser $ SomeParser p+ exitP _ a p _ = Completion . lift . lift $ ComplParser (SomeParser p) a errorP = Completion . throwE -runCompletion :: Completion r -> ParserPrefs -> Maybe (Either SomeParser Completer)+runCompletion :: Completion r -> ParserPrefs -> Maybe (Either (SomeParser, ArgPolicy) Completer) runCompletion (Completion c) prefs = case runReaderT (runExceptT c) prefs of ComplResult _ -> Nothing- ComplParser p' -> Just $ Left p'+ ComplParser p' a' -> Just $ Left (p', a') ComplOption compl -> Just $ Right compl -- A "ListT done right" implementation
Options/Applicative/Types.hs view
@@ -39,7 +39,8 @@ optVisibility, optMetaVar, optHelp,- optShowDefault+ optShowDefault,+ optDescMod ) where import Control.Applicative@@ -47,6 +48,7 @@ import Control.Monad.Trans.Except (Except, throwE) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Reader (ReaderT, ask)+import qualified Control.Monad.Fail as Fail import Data.Semigroup hiding (Option) import Prelude @@ -63,6 +65,8 @@ | ShowHelpText | UnknownError | MissingError IsCmdStart SomeParser+ | ExpectsArgError String+ | UnexpectedError String SomeParser data IsCmdStart = CmdStart | CmdCont deriving Show@@ -84,8 +88,8 @@ , infoHeader :: Chunk Doc -- ^ header of the full parser description , infoFooter :: Chunk Doc -- ^ footer of the full parser description , infoFailureCode :: Int -- ^ exit code for a parser failure- , infoIntersperse :: Bool -- ^ allow regular options and flags to occur- -- after arguments (default: True)+ , infoPolicy :: ArgPolicy -- ^ allow regular options and flags to occur+ -- after arguments (default: InterspersePolicy) } instance Functor ParserInfo where@@ -123,8 +127,18 @@ , propHelp :: Chunk Doc -- ^ help text for this option , propMetaVar :: String -- ^ metavariable for this option , propShowDefault :: Maybe String -- ^ what to show in the help text as the default- } deriving Show+ , propDescMod :: Maybe ( Doc -> Doc ) -- ^ a function to run over the brief description+ } +instance Show OptProperties where+ showsPrec p (OptProperties pV pH pMV pSD _)+ = showParen (p >= 11)+ $ showString "OptProperties { propVisibility = " . showsPrec 0 pV+ . showString ", propHelp = " . showsPrec 0 pH+ . showString ", propMetaVar = " . showsPrec 0 pMV+ . showString ", propShowDefault = " . showsPrec 0 pSD+ . showString ", propDescMod = _ }"+ -- | A single option of a parser. data Option a = Option { optMain :: OptReader a -- ^ reader for this option@@ -161,6 +175,9 @@ instance Monad ReadM where return = pure ReadM r >>= f = ReadM $ r >>= unReadM . f+ fail = Fail.fail++instance Fail.MonadFail ReadM where fail = readerError instance MonadPlus ReadM where@@ -188,11 +205,14 @@ -- | An 'OptReader' defines whether an option matches an command line argument. data OptReader a- = OptReader [OptName] (CReader a) ParseError -- ^ option reader- | FlagReader [OptName] !a -- ^ flag reader- | ArgReader (CReader a) -- ^ argument reader- | CmdReader (Maybe String)- [String] (String -> Maybe (ParserInfo a)) -- ^ command reader+ = 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 instance Functor OptReader where fmap f (OptReader ns cr e) = OptReader ns (fmap f cr) e@@ -223,14 +243,14 @@ { runParserM :: forall x . (r -> Parser x) -> Parser x } instance Monad ParserM where- return x = ParserM $ \k -> k x+ return = pure ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k) instance Functor ParserM where fmap = liftM instance Applicative ParserM where- pure = return+ pure x = ParserM $ \k -> k x (<*>) = ap fromM :: ParserM a -> Parser a@@ -255,16 +275,21 @@ many p = fromM $ manyM p some p = fromM $ (:) <$> oneM p <*> manyM p +-- | A shell complete function. newtype Completer = Completer { runCompleter :: String -> IO [String] } +-- | Smart constructor for a 'Completer' mkCompleter :: (String -> IO [String]) -> Completer mkCompleter = Completer +instance Semigroup Completer where+ (Completer c1) <> (Completer c2) =+ Completer $ \s -> (++) <$> c1 s <*> c2 s+ instance Monoid Completer where mempty = Completer $ \_ -> return []- mappend (Completer c1) (Completer c2) =- Completer $ \s -> (++) <$> c1 s <*> c2 s+ mappend = (<>) newtype CompletionResult = CompletionResult { execCompletion :: String -> IO String }@@ -319,16 +344,34 @@ -- | Policy for how to handle options within the parse data ArgPolicy- = 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)+ = Intersperse+ -- ^ The default policy, options and arguments can+ -- be interspersed.+ -- A `--` option can be passed to ensure all following+ -- commands are treated as arguments.+ | NoIntersperse+ -- ^ Options must all come before arguments, once a+ -- single positional argument or subcommand is parsed,+ -- all remaining arguments are treated as positionals.+ -- A `--` option can be passed if the first positional+ -- one needs starts with `-`.+ | AllPositionals+ -- ^ No options are parsed at all, all arguments are+ -- treated as positionals.+ -- Is the policy used after `--` is encountered.+ | ForwardOptions+ -- ^ Options and arguments can be interspersed, but if+ -- a given option is not found, it is treated as a+ -- positional argument. This is sometimes useful if+ -- one is passing through most options to another tool,+ -- but are supplying just a few of their own options.+ deriving (Eq, Ord, Show) data OptHelpInfo = OptHelpInfo- { hinfoMulti :: Bool- , hinfoDefault :: Bool+ { hinfoMulti :: Bool -- ^ Whether this is part of a many or some (approximately)+ , hinfoDefault :: Bool -- ^ Whether this option has a default value+ , hinfoUnreachableArgs :: Bool -- ^ If the result is a positional, if it can't be+ -- accessed in the current parser position ( first arg ) } deriving (Eq, Show) data OptTree a@@ -348,3 +391,6 @@ optShowDefault :: Option a -> Maybe String optShowDefault = propShowDefault . optProps++optDescMod :: Option a -> Maybe ( Doc -> Doc )+optDescMod = propDescMod . optProps
README.md view
@@ -2,6 +2,7 @@ [![Continuous Integration status][status-png]][status] [![Hackage page (downloads and API reference)][hackage-png]][hackage]+[![Hackage-Deps][hackage-deps-png]][hackage-deps] optparse-applicative is a haskell library for parsing options on the command line, providing a powerful [applicative] interface@@ -16,7 +17,7 @@ - [Introduction](#introduction) - [Quick Start](#quick-start)-- [Basics](#Basics)+- [Basics](#basics) - [Parsers](#parsers) - [Applicative](#applicative) - [Alternative](#alternative)@@ -75,9 +76,9 @@ import Data.Semigroup ((<>)) data Sample = Sample- { hello :: String- , quiet :: Bool- , repeat :: Int }+ { hello :: String+ , quiet :: Bool+ , enthusiasm :: Int } sample :: Parser Sample sample = Sample@@ -90,8 +91,8 @@ <> short 'q' <> help "Whether to be quiet" ) <*> option auto- ( long "repeat"- <> help "Repeats for greeting"+ ( long "enthusiasm"+ <> help "How enthusiastically to greet" <> showDefault <> value 1 <> metavar "INT" )@@ -100,8 +101,8 @@ The parser is built using an [applicative] style starting from a set of basic combinators. In this example, hello is defined as an option with a `String` argument, while quiet is a boolean flag-(called switch) and repeat gets parsed as an `Int` with help of the-`Read` type class.+(called a switch) and enthusiasm gets parsed as an `Int` with help+of the `Read` type class. The parser can be used like this:@@ -116,7 +117,7 @@ <> header "hello - a test for optparse-applicative" ) greet :: Sample -> IO ()-greet (Sample h False n) = replicateM_ n . putStrLn $ "Hello, " ++ h+greet (Sample h False n) = putStrLn $ "Hello, " ++ h ++ replicate n '!' greet _ = return () ``` @@ -131,7 +132,7 @@ Missing: --hello TARGET - Usage: hello --hello TARGET [-q|--quiet] [--repeat INT]+ Usage: hello --hello TARGET [-q|--quiet] [--enthusiasm INT] Print a greeting for TARGET Running the program with the `--help` option will display the full help text@@ -140,13 +141,13 @@ ``` hello - a test for optparse-applicative - Usage: hello --hello TARGET [-q|--quiet] [--repeat INT]+ Usage: hello --hello TARGET [-q|--quiet] [--enthusiasm INT] Print a greeting for TARGET Available options: --hello TARGET Target for the greeting -q,--quiet Whether to be quiet- --repeat INT Repeats for greeting (default: 1)+ --enthusiasm INT How enthusiastically to greet (default: 1) -h,--help Show this help text ``` @@ -165,7 +166,7 @@ ```haskell target :: Parser String target = strOption- ( long "target"+ ( long "hello" <> metavar "TARGET" <> help "Target for the greeting" ) ```@@ -175,7 +176,7 @@ and the given help text. This means that the `target` parser defined above will require an option like - --target world+ --hello world on the command line. The metavariable and the help text will appear in the generated help text, but don't otherwise affect the behaviour@@ -1001,6 +1002,8 @@ [blog]: http://paolocapriotti.com/blog/2012/04/27/applicative-option-parser/ [hackage]: http://hackage.haskell.org/package/optparse-applicative [hackage-png]: http://img.shields.io/hackage/v/optparse-applicative.svg+ [hackage-deps]: http://packdeps.haskellers.com/reverse/optparse-applicative+ [hackage-deps-png]: https://img.shields.io/hackage-deps/v/optparse-applicative.svg [monoid]: http://hackage.haskell.org/package/base/docs/Data-Monoid.html [semigroup]: http://hackage.haskell.org/package/base/docs/Data-Semigroup.html [parsec]: http://hackage.haskell.org/package/parsec
optparse-applicative.cabal view
@@ -1,5 +1,5 @@ name: optparse-applicative-version: 0.13.2.0+version: 0.14.0.0 synopsis: Utilities and combinators for parsing command line options description: optparse-applicative is a haskell library for parsing options@@ -17,9 +17,9 @@ license: BSD3 license-file: LICENSE author: Paolo Capriotti, Huw Campbell-maintainer: paolo@capriotti.io+maintainer: huw.campbell@gmail.com copyright: (c) 2012-2017 Paolo Capriotti <paolo@capriotti.io>-category: System+category: System, CLI, Options, Parsing build-type: Simple cabal-version: >= 1.8 extra-source-files: CHANGELOG.md@@ -51,11 +51,12 @@ location: https://github.com/pcapriotti/optparse-applicative.git library- if impl(ghc >= 8)- ghc-options: -Wall -Wno-redundant-constraints- else- ghc-options: -Wall+ ghc-options: -Wall + -- See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0#base-4.9.0.0+ if impl(ghc >= 8.0)+ ghc-options: -Wno-redundant-constraints -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances+ exposed-modules: Options.Applicative, Options.Applicative.Arrows, Options.Applicative.BashCompletion,@@ -65,9 +66,10 @@ Options.Applicative.Common, Options.Applicative.Extra, Options.Applicative.Help,- Options.Applicative.Help.Pretty, Options.Applicative.Help.Chunk, Options.Applicative.Help.Core,+ Options.Applicative.Help.Levenshtein,+ Options.Applicative.Help.Pretty, Options.Applicative.Help.Types, Options.Applicative.Types, Options.Applicative.Internal@@ -81,7 +83,7 @@ if !impl(ghc >= 8) build-depends: semigroups >= 0.10 && < 0.19-+ , fail == 4.9.* test-suite optparse-applicative-tests type: exitcode-stdio-1.0@@ -94,6 +96,7 @@ tests build-depends: base+ , bytestring == 0.10.* , optparse-applicative , QuickCheck >= 2.8 && < 2.11
tests/commands_header.err.txt view
@@ -1,3 +1,6 @@-Invalid option `-zzz'+Invalid option `-zello'++Did you mean this?+ hello Usage: commands_header COMMAND
tests/commands_header_full.err.txt view
@@ -1,4 +1,7 @@-Invalid option `-zzz'+Invalid option `-zello'++Did you mean this?+ hello foo
tests/test.hs view
@@ -12,8 +12,10 @@ import Control.Applicative import Control.Monad+import Data.ByteString (ByteString) import Data.List hiding (group) import Data.Semigroup hiding (option)+import Data.String import System.Exit import Test.QuickCheck hiding (Success, Failure)@@ -24,6 +26,7 @@ import Options.Applicative.Help.Pretty (Doc, SimpleDoc(..)) import qualified Options.Applicative.Help.Pretty as Doc import Options.Applicative.Help.Chunk+import Options.Applicative.Help.Levenshtein import Prelude @@ -73,9 +76,9 @@ prop_cmd_header = once $ let i = info (helper <*> Commands.sample) (header "foo") r1 = checkHelpTextWith (ExitFailure 1) defaultPrefs- "commands_header" i ["-zzz"]+ "commands_header" i ["-zello"] r2 = checkHelpTextWith (ExitFailure 1) (prefs showHelpOnError)- "commands_header_full" i ["-zzz"]+ "commands_header_full" i ["-zello"] in (r1 .&&. r2) prop_cabal_conf :: Property@@ -129,7 +132,8 @@ prop_alt_help :: Property prop_alt_help = once $- let p = p1 <|> p2 <|> p3+ let p :: Parser (Maybe (Either String String))+ p = p1 <|> p2 <|> p3 p1 = (Just . Left) <$> strOption ( long "virtual-machine" <> metavar "VM"@@ -144,7 +148,8 @@ prop_nested_commands :: Property prop_nested_commands = once $- let p3 = strOption (short 'a' <> metavar "A")+ let p3 :: Parser String+ 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@@ -152,7 +157,8 @@ prop_drops_back_contexts :: Property prop_drops_back_contexts = once $- let p3 = strOption (short 'a' <> metavar "A")+ let p3 :: Parser String+ 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@@ -161,7 +167,8 @@ prop_context_carry :: Property prop_context_carry = once $- let p3 = strOption (short 'a' <> metavar "A")+ let p3 :: Parser String+ 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@@ -170,7 +177,8 @@ prop_help_on_empty :: Property prop_help_on_empty = once $- let p3 = strOption (short 'a' <> metavar "A")+ let p3 :: Parser String+ 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@@ -179,7 +187,8 @@ prop_help_on_empty_sub :: Property prop_help_on_empty_sub = once $- let p3 = strOption (short 'a' <> metavar "A" <> help "both commands require this")+ let p3 :: Parser String+ 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@@ -188,7 +197,8 @@ prop_many_args :: Property prop_many_args = forAll (choose (0,2000)) $ \nargs ->- let p = many (argument str idm)+ let p :: Parser [String]+ p = many (argument str idm) i = info p idm result = run i (replicate nargs "foo") in assertResult result (\xs -> nargs === length xs)@@ -225,9 +235,104 @@ Failure _ -> return $ counterexample "unexpected failure" failed Success val -> return $ counterexample ("unexpected result " ++ show val) failed +prop_completion_opt_after_double_dash :: Property+prop_completion_opt_after_double_dash = once . ioProperty $+ let p = (,)+ <$> strOption (long "foo" <> value "")+ <*> argument readerAsk (completeWith ["bar"])+ i = info p idm+ result = run i ["--bash-completion-index", "2"+ , "--bash-completion-word", "test"+ , "--bash-completion-word", "--"]+ in case result of+ CompletionInvoked (CompletionResult err) -> do+ completions <- lines <$> err "test"+ return $ ["bar"] === completions+ Failure _ -> return $ counterexample "unexpected failure" failed+ Success val -> return $ counterexample ("unexpected result " ++ show val) failed++prop_completion_only_reachable :: Property+prop_completion_only_reachable = once . ioProperty $+ let p :: Parser (String,String)+ p = (,)+ <$> strArgument (completeWith ["reachable"])+ <*> strArgument (completeWith ["unreachable"])+ i = info p idm+ result = run i ["--bash-completion-index", "0"]+ in case result of+ CompletionInvoked (CompletionResult err) -> do+ completions <- lines <$> err "test"+ return $ ["reachable"] === completions+ Failure _ -> return $ counterexample "unexpected failure" failed+ Success val -> return $ counterexample ("unexpected result " ++ show val) failed++prop_completion_only_reachable_deep :: Property+prop_completion_only_reachable_deep = once . ioProperty $+ let p :: Parser (String,String)+ p = (,)+ <$> strArgument (completeWith ["seen"])+ <*> strArgument (completeWith ["now-reachable"])+ i = info p idm+ result = run i [ "--bash-completion-index", "2"+ , "--bash-completion-word", "test-prog"+ , "--bash-completion-word", "seen" ]+ in case result of+ CompletionInvoked (CompletionResult err) -> do+ completions <- lines <$> err "test"+ return $ ["now-reachable"] === completions+ Failure _ -> return $ counterexample "unexpected failure" failed+ Success val -> return $ counterexample ("unexpected result " ++ show val) failed++prop_completion_multi :: Property+prop_completion_multi = once . ioProperty $+ let p :: Parser [String]+ p = many (strArgument (completeWith ["reachable"]))+ i = info p idm+ result = run i [ "--bash-completion-index", "3"+ , "--bash-completion-word", "test-prog"+ , "--bash-completion-word", "nope" ]+ in case result of+ CompletionInvoked (CompletionResult err) -> do+ completions <- lines <$> err "test"+ return $ ["reachable"] === completions+ Failure _ -> return $ counterexample "unexpected failure" failed+ Success val -> return $ counterexample ("unexpected result " ++ show val) failed++prop_completion_rich :: Property+prop_completion_rich = once . ioProperty $+ let p = (,)+ <$> option readerAsk (long "foo" <> help "Fo?")+ <*> option readerAsk (long "bar" <> help "Ba?")+ i = info p idm+ result = run i ["--bash-completion-enriched", "--bash-completion-index", "0"]+ in case result of+ CompletionInvoked (CompletionResult err) -> do+ completions <- lines <$> err "test"+ return $ ["--foo\tFo?", "--bar\tBa?"] === completions+ Failure _ -> return $ counterexample "unexpected failure" failed+ Success val -> return $ counterexample ("unexpected result " ++ show val) failed++prop_completion_rich_lengths :: Property+prop_completion_rich_lengths = once . ioProperty $+ let p = (,)+ <$> option readerAsk (long "foo" <> help "Foo hide this")+ <*> option readerAsk (long "bar" <> help "Bar hide this")+ i = info p idm+ result = run i [ "--bash-completion-enriched"+ , "--bash-completion-index=0"+ , "--bash-completion-option-desc-length=3"+ , "--bash-completion-command-desc-length=30"]+ in case result of+ CompletionInvoked (CompletionResult err) -> do+ completions <- lines <$> err "test"+ return $ ["--foo\tFoo...", "--bar\tBar..."] === 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..."))+ let p :: Parser [String]+ p = many (argument str (metavar "ARGS...")) i = info (p <**> helper) briefDesc result = run i ["--help"] in assertError result $ \failure ->@@ -245,21 +350,24 @@ prop_arguments1_none :: Property prop_arguments1_none =- let p = some (argument str idm)+ let p :: Parser [String]+ 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)+ let p :: Parser [String]+ 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')+ let p :: Parser [String]+ p = switch (short 'x') *> many (argument str idm) i = info p idm result = run i ["--", "-x"]@@ -404,11 +512,33 @@ ( 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+ result1 = run i ["run", "foo", "-x"]+ result2 = run i ["test", "bar", "-x"]+ in conjoin [ assertResult result1 $ \args -> ["foo", "-x"] === args , assertError result2 $ \_ -> property succeeded ] +prop_intersperse_3 :: Property+prop_intersperse_3 = once $+ let p = (,,) <$> switch ( long "foo" )+ <*> strArgument ( metavar "FILE" )+ <*> many ( strArgument ( metavar "ARGS..." ) )+ i = info p noIntersperse+ result = run i ["--foo", "myfile", "-a", "-b", "-c"]+ in assertResult result $ \(b,f,as) ->+ conjoin [ ["-a", "-b", "-c"] === as+ , True === b+ , "myfile" === f ]++prop_forward_options :: Property+prop_forward_options = once $+ let p = (,) <$> switch ( long "foo" )+ <*> many ( strArgument ( metavar "ARGS..." ) )+ i = info p forwardOptions+ result = run i ["--fo", "--foo", "myfile"]+ in assertResult result $ \(b,a) ->+ conjoin [ True === b+ , ["--fo", "myfile"] === a ]+ prop_issue_52 :: Property prop_issue_52 = once $ let p = subparser@@ -452,7 +582,8 @@ prop_missing_flags_described :: Property prop_missing_flags_described = once $- let p = (,,)+ let p :: Parser (String, String, Maybe String)+ p = (,,) <$> option str (short 'a') <*> option str (short 'b') <*> optional (option str (short 'c'))@@ -463,7 +594,8 @@ prop_many_missing_flags_described :: Property prop_many_missing_flags_described = once $- let p = (,)+ let p :: Parser (String, String)+ p = (,) <$> option str (short 'a') <*> option str (short 'b') i = info p idm@@ -473,15 +605,26 @@ prop_alt_missing_flags_described :: Property prop_alt_missing_flags_described = once $- let p = option str (short 'a') <|> option str (short 'b')+ let p :: Parser String+ 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_missing_option_parameter_err :: Property+prop_missing_option_parameter_err = once $+ let p :: Parser String+ p = option str (short 'a')+ i = info p idm+ in assertError (run i ["-a"]) $ \failure ->+ let text = head . lines . fst $ renderFailure failure "test"+ in "The option `-a` expects an argument." === text+ prop_many_pairs_success :: Property prop_many_pairs_success = once $- let p = many $ (,) <$> argument str idm <*> argument str idm+ let p :: Parser [(String, String)]+ p = many $ (,) <$> argument str idm <*> argument str idm i = info p idm nargs = 10000 result = run i (replicate nargs "foo")@@ -489,7 +632,8 @@ prop_many_pairs_failure :: Property prop_many_pairs_failure = once $- let p = many $ (,) <$> argument str idm <*> argument str idm+ let p :: Parser [(String, String)]+ p = many $ (,) <$> argument str idm <*> argument str idm i = info p idm nargs = 9999 result = run i (replicate nargs "foo")@@ -497,11 +641,34 @@ prop_many_pairs_lazy_progress :: Property prop_many_pairs_lazy_progress = once $- let p = many $ (,) <$> optional (option str (short 'a')) <*> argument str idm+ let p :: Parser [(Maybe String, String)]+ 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 +prop_suggest :: Property+prop_suggest = once $+ let p2 = subparser (command "reachable" (info (pure ()) idm))+ p1 = subparser (command "unreachable" (info (pure ()) idm))+ p = (,) <$> p2 <*> p1+ i = info p idm+ result = run i ["ureachable"]+ in assertError result $ \failure ->+ let (msg, _) = renderFailure failure "prog"+ in counterexample msg+ $ isInfixOf "Did you mean this?\n reachable" msg+ .&. not (isInfixOf "unreachable" msg)++prop_bytestring_reader :: Property+prop_bytestring_reader = once $+ let t = "testValue"+ p :: Parser ByteString+ p = argument str idm+ i = info p idm+ result = run i ["testValue"]+ in assertResult result $ \xs -> fromString t === xs+ --- deriving instance Arbitrary a => Arbitrary (Chunk a)@@ -534,6 +701,38 @@ prop_paragraph :: String -> Property prop_paragraph s = isEmpty (paragraph s) === null (words s)++---++--+-- From+-- https://en.wikipedia.org/wiki/Damerau%E2%80%93Levenshtein_distance+--+-- In information theory and computer science, the Damerau–Levenshtein+-- distance is a distance (string metric) between two strings, i.e.,+-- finite sequence of symbols, given by counting the minimum number+-- of operations needed to transform one string into the other, where+-- an operation is defined as an insertion, deletion, or substitution+-- of a single character, or a transposition of two adjacent characters.+--+prop_edit_distance_gezero :: String -> String -> Bool+prop_edit_distance_gezero a b = editDistance a b >= 0++prop_edit_insertion :: [Char] -> Char -> [Char] -> Property+prop_edit_insertion as i bs =+ editDistance (as ++ bs) (as ++ [i] ++ bs) === 1++prop_edit_symmetric :: [Char] -> [Char] -> Property+prop_edit_symmetric as bs =+ editDistance as bs === editDistance bs as++prop_edit_substitution :: [Char] -> [Char] -> Char -> Char -> Property+prop_edit_substitution as bs a b = a /= b ==>+ editDistance (as ++ [a] ++ bs) (as ++ [b] ++ bs) === 1++prop_edit_transposition :: [Char] -> [Char] -> Char -> Char -> Property+prop_edit_transposition as bs a b = a /= b ==>+ editDistance (as ++ [a] ++ [b] ++ bs) (as ++ [b] ++ [a] ++ bs) === 1 ---