packages feed

optparse-applicative 0.13.2.0 → 0.19.0.0

raw patch · 59 files changed

Files

CHANGELOG.md view
@@ -1,3 +1,235 @@+## Version 0.19.0.0 (03 June 2025)++- Add `briefHangPoint` modifier. This allows one to specify the command length+  after which the rendering will change from aligned with the end of the+  command name to being indented on the next line.++- Add `parserOptionGroup` for grouping Options together, similar to command+  groups. Requires the breaking change of adding the `propGroup :: OptGroup`+  field to `OptProperties`.+++## Version 0.18.1.0 (29 May 2023)++- Change pretty printer layout algorithm used.++  The layoutSmart algorithm appears to be extremely slow with some command line+  sets, to the point where the program appears to hang.++  Fixes issues:+    * \# 476 - Stack executable 'hangs' with 0.17.1 and 0.18.0.++- Render help text with `AnsiStyle` aware rendering functions.++## Version 0.18.0.0 (22 May 2023)++- Move to 'prettyprinter` library for pretty printing.++  This is a potentially breaking change when one uses the '*Doc' family of functions+  (like `headerDoc`) from `Options.Applicative`. However, as versions of+  'ansi-wl-pprint > 1.0' export a compatible `Doc` type, this can be mitigated by+  using a recent version.++  One can also either import directly from `Options.Applicative.Help` or from the+  `Prettyprinter` module of 'prettyprinter'.++- Allow commands to be disambiguated in a similar manner to flags when the+  `disambiguate` modifier is used.++  This is a potentially breaking change as the internal `CmdReader` constructor+  has been adapted so it is able to be inspected to a greater degree to support+  finding prefix matches.++## Version 0.17.1.0 (22 May 2023)++- Widen bounds for `ansi-wl-pprint`. This supports the use of `prettyprinter`+  in a non-breaking way, as the `ansi-wl-pprint > 1.0` support the newer+  library.++- Export `helpIndent` from `Options.Applicative`.++- Export completion script generators from `Options.Applicative.BashCompletion`.++- Add `simpleVersioner` utility for adding a '--version' option to a parser.++- Improve documentation.++- Drop support for GHC 7.0 and 7.2.++## Version 0.17.0.0 (1 Feb 2022)++- Make tabulation width configurable in usage texts.++- Separate program name and description in ParserHelp type.++- Add `helperWith` function, which can be easily used to+  localize the help flag.++- Improve usage texts when command names are long.++- Improve Documentation.++## Version 0.16.1.0 (21 Nov 2020)++- Guard `process` dependency behind an on by default flag.+  This allows one to shrink the dependency tree significantly+  by turning off the ability to use bash completion actions.++- Remove `bytestring` dependency from the test suite.++## Version 0.16.0.0 (14 Aug 2020)++- Add `Options.Applicative.NonEmpty.some1` function, which+  parses options the same as `some1` from base, but doesn't+  cause duplicates in the usage texts.++- Further improve help text generation in the presence+  of optional values when nesting is involved, and many and+  some when displayed with a suffix.++- Add "global" options to the usage texts for subcommands.+  When using subcommands, a "global options" section can+  now appear below the options and commands sections.++  Global options are *off* by default, to enable them, use+  the `helpShowGlobals` modifier.++  The `noGlobal` builder will suppress a single option being+  displayed in the global options list.++  Fixes issues:+    * \# 175 - List detailed subparser documentation with `--help`+    * \# 294 - Displaying global options when listing options for a command.+    * \# 359 - Subcommand help text lacks required parent command arguments++- Allow the `--help` option to take the name of a command.+  Usage without any arguments is the same, but now, when an+  argument is given, if it is the name of a currently+  reachable command, the help text for that command will+  be show.++  Fixes issues:+    * \# 379 - cmd --help subcmd is not the same as cmd subcmd --help++- Updated dependency bounds.++- Add builder for the all positional parser policy.++- Remove deprecated functions+    * nullOption+    * execParserMaybe+    * customExecParserMaybe++## Version 0.15.1.0 (12 Sep 2019)++- Improve printing of brief descriptions for parsers.+  Previously, the logical structure of the parser,+  such as alternative groups and segments which must+  be defined together, did not influence the layout of+  the brief description. This could lead to some help+  texts being difficult to read.  Now, we use nesting+  and forced line breaks to help improve readability.++## Version 0.15.0.0 (05 Jul 2019)++- Add support for GHC 8.8.1.++- Add `subparserInline` modifier as additional way of+  executing subparsers. When activated, the subparser+  parse tree will be inserted into that of the parent+  instead of being run independently, allowing mixing+  of child and parent options.++- Improve rendering of complex nested parse structures.+  Previously, brackets and parenthesis did not respect+  whether or not options had to be defined together.+  Now the parse tree is more accurately represented in+  the help text.++- Add `helpLongEquals` modifier, which will change how+  long options are printed in the help text, adding an+  equals sign, for example "--input=FILE".++- Updated dependency bounds.++- Clean ups and Documentation.++## Version 0.14.3.0 (03 Oct 2018)++- Updated dependency bounds.++- Fix tab completion with Commands being unreachable.++- Clean ups and Documentation.++## Version 0.14.2.0 (26 Feb 2018)++- Updated dependency bounds.++## Version 0.14.1.0 (23 Feb 2018)++- Updated dependency bounds.++- Export `HasName`, `HasCompleter`, `HasValue`, and+  `HasMetavar` type classes.++- Doc.++## 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.@@ -21,17 +253,17 @@   fires when a command or subcommand is begun, and suppresses the "Missing:"   error text. -- Fix ghc 8.0 warnings+- Fix ghc 8.0 warnings. -- Fix ghc 7.10 warnings+- Fix ghc 7.10 warnings. -- Bump dependency bounds+- Bump dependency bounds. -- Add maybeReader function for convenient ReadM creation+- Add maybeReader function for convenient ReadM creation. -- Move eitherReader to Readers section (for better discoverability)+- Move eitherReader to Readers section (for better discoverability). -- Fix hsubparser metavar override+- Fix hsubparser metavar override.  - Remove ComplError, which was dead code. @@ -47,9 +279,9 @@  - Updated dependency bounds. -- Improve subparser contexts to improve usage error texts+- Improve subparser contexts to improve usage error texts. -- Doc+- Docs.  - Fixed bugs     * \# 164 - Invalid options and invalid arguments after parser has succeeded@@ -69,7 +301,7 @@  - Add `Show` and `Eq` instances to some types for easier debugging. -- Add defaultPrefs, a default preferences value+- Add defaultPrefs, a default preferences value.  - Docs. @@ -167,7 +399,7 @@  ## Version 0.7.0.1 (18 Oct 2013) -- Minor docs fixes+- Minor docs fixes.  ## Version 0.7.0 (17 Oct 2013) @@ -195,15 +427,15 @@     * \#44 - Can the build input restriction process == 1.1.* be relaxed?     * \#28 - Help for subcommands -## Version 0.5.2.1 (24 Dic 2012)+## Version 0.5.2.1 (24 Dec 2012)  - Minor docs fixes. -## Version 0.5.2 (23 Dic 2012)+## Version 0.5.2 (23 Dec 2012)  - Fixed compatibility with GHC 7.2. -## Version 0.5.1 (23 Dic 2012)+## Version 0.5.1 (23 Dec 2012)  - There is a new parser preference `noBacktrack`, that controls whether how a   failure in a subparser is propagated. By default, an unknown option in a@@ -219,7 +451,7 @@     * \#29 - Document Mod     * \#26 - Improve docs for the `Arrow` interface -## Version 0.5.0 (22 Dic 2012)+## Version 0.5.0 (22 Dec 2012)  - Fewer GHC extensions required. @@ -235,7 +467,7 @@ - Fixed bugs     * \#37 - Use (\<\>) instead of (&) in documentation -## Version 0.4.3 (09 Dic 2012)+## Version 0.4.3 (09 Dec 2012)  - Updated dependency bounds. @@ -326,20 +558,20 @@  ## Version 0.1.1 (21 Jul 2012) -- New arrow interface+- New arrow interface.  - Fixed bugs-      * \#7 - "arguments" reads positional arguments in reverse+    * \#7 - "arguments" reads positional arguments in reverse  ## Version 0.1.0 (07 Jul 2012) -- Improved error reporting internals+- Improved error reporting internals. -- Removed template-haskell dependency+- Removed template-haskell dependency.  - Fixed bugs:-      * \#3 - No help for subparsers-      * \#4 - Extra empty lines around command list+    * \#3 - No help for subparsers+    * \#4 - Extra empty lines around command list  ## Version 0.0.1 (09 Jun 2012)
− Options/Applicative.hs 
@@ -1,38 +0,0 @@-module Options.Applicative (-  -- * Applicative option parsers-  ---  -- | This is an empty module which simply re-exports all the public definitions-  -- of this package.-  ---  -- 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.--  -- * 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,--  -- | Utilities to build parsers out of basic primitives.-  module Options.Applicative.Builder,--  -- | Common completion functions.-  module Options.Applicative.Builder.Completer,--  -- | Utilities to run parsers and display a help text.-  module Options.Applicative.Extra,-  ) where---- reexport Applicative here for convenience-import Control.Applicative--import Options.Applicative.Common-import Options.Applicative.Builder-import Options.Applicative.Builder.Completer-import Options.Applicative.Extra--{-# ANN module "HLint: ignore Use import/export shortcut" #-}
− Options/Applicative/Arrows.hs 
@@ -1,75 +0,0 @@--- | This module contains an arrow interface for option parsers, which allows--- to define and combine parsers using the arrow notation and arrow--- combinators.------ The arrow syntax is particularly useful to create parsers of nested--- structures, or records where the order of fields is different from the order--- in which the parsers should be applied.------ For example, an 'Options.Applicative.Builder.arguments` parser often needs--- to be applied last, and that makes it inconvenient to use it for a field--- which is not the last one in a record.------ Using the arrow syntax and the functions in this module, one can write, e.g.:------ > data Options = Options--- >   { optArgs :: [String]--- >   , optVerbose :: Bool }--- >--- > opts :: Parser Options--- > opts = runA $ proc () -> do--- >   verbose <- asA (switch (short 'v')) -< ()--- >   args <- asA (arguments str idm) -< ()--- >   returnA -< Options args verbose------ Parser arrows, created out of regular 'Parser' values using the 'asA'--- function, are arrows taking @()@ as argument and returning the parsed value.-module Options.Applicative.Arrows (-  module Control.Arrow,-  A(..),-  asA,-  runA,-  ParserA,-  ) where--import Control.Arrow-import Control.Category (Category(..))--import Options.Applicative--import Prelude hiding ((.), id)---- | For any 'Applicative' functor @f@, @A f@ is the 'Arrow' instance--- associated to @f@.------ The 'A' constructor can be used to convert a value of type @f (a -> b)@ into--- an arrow.-newtype A f a b = A-  { unA :: f (a -> b) }---- | Convert a value of type @f a@ into an arrow taking @()@ as argument.------ Applied to a value of type 'Parser', it turns it into an arrow that can be--- used inside an arrow command, or passed to arrow combinators.-asA :: Applicative f => f a -> A f () a-asA x = A $ const <$> x---- | Convert an arrow back to an applicative value.------ This function can be used to return a result of type 'Parser' from an arrow--- command.-runA :: Applicative f => A f () a -> f a-runA a = unA a <*> pure ()--instance Applicative f => Category (A f) where-  id = A $ pure id-  -- use reverse composition, because we want effects to run from-  -- top to bottom in the arrow syntax-  (A f) . (A g) = A $ flip (.) <$> g <*> f--instance Applicative f => Arrow (A f) where-  arr = A . pure-  first (A f) = A $ first <$> f---- | The type of arrows associated to the applicative 'Parser' functor.-type ParserA = A Parser
− Options/Applicative/BashCompletion.hs 
@@ -1,92 +0,0 @@--- | You don't need to import this module to enable bash completion.------ See--- <http://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion the wiki>--- for more information on bash completion.-module Options.Applicative.BashCompletion-  ( bashCompletionParser-  ) where--import Control.Applicative-import Prelude-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--bashCompletionParser :: ParserInfo a -> ParserPrefs -> Parser CompletionResult-bashCompletionParser pinfo pprefs = complParser-  where-    failure opts = CompletionResult-      { execCompletion = \progn -> unlines <$> opts progn }--    complParser = asum-      [ failure <$>-        (   bashCompletionQuery pinfo pprefs-        <$> (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)) ]--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 []-  where-    list_options =-        fmap concat-      . sequence-      . mapParser (const opt_completions)--    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--    show_name :: OptName -> String-    show_name (OptShort c) = '-':[c]-    show_name (OptLong name) = "--" ++ name--    show_names :: [OptName] -> [String]-    show_names = filter_names . map show_name--    filter_names :: [String] -> [String]-    filter_names = filter is_completion--    run_completer :: Completer -> IO [String]-    run_completer c = runCompleter c (fromMaybe "" (listToMaybe ws''))--    (ws', ws'') = splitAt i ws--    is_completion :: String -> Bool-    is_completion =-      case ws'' of-        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'"-  , "    CMDLINE=(--bash-completion-index $COMP_CWORD)"-  , ""-  , "    for arg in ${COMP_WORDS[@]}; do"-  , "        CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)"-  , "    done"-  , ""-  , "    COMPREPLY=( $(" ++ prog ++ " \"${CMDLINE[@]}\") )"-  , "}"-  , ""-  , "complete -o filenames -F _" ++ progn ++ " " ++ progn ]
− Options/Applicative/Builder.hs 
@@ -1,438 +0,0 @@-module Options.Applicative.Builder (-  -- * Parser builders-  ---  -- | This module 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 this module 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\".-  subparser,-  strArgument,-  argument,-  flag,-  flag',-  switch,-  abortOption,-  infoOption,-  strOption,-  option,-  nullOption,--  -- * Modifiers-  short,-  long,-  help,-  helpDoc,-  value,-  showDefaultWith,-  showDefault,-  metavar,-  noArgError,-  ParseError(..),-  hidden,-  internal,-  command,-  commandGroup,-  completeWith,-  action,-  completer,-  idm,-  mappend,--  -- * Readers-  ---  -- | A collection of basic 'Option' readers.-  auto,-  str,-  maybeReader,-  eitherReader,-  disabled,-  readerAbort,-  readerError,--  -- * Builder for 'ParserInfo'-  InfoMod,-  fullDesc,-  briefDesc,-  header,-  headerDoc,-  footer,-  footerDoc,-  progDesc,-  progDescDoc,-  failureCode,-  noIntersperse,-  info,--  -- * Builder for 'ParserPrefs'-  PrefsMod,-  multiSuffix,-  disambiguate,-  showHelpOnError,-  showHelpOnEmpty,-  noBacktrack,-  columns,-  prefs,-  defaultPrefs,--  -- * Types-  Mod,-  ReadM,-  OptionFields,-  FlagFields,-  ArgumentFields,-  CommandFields-  ) where--import Control.Applicative-import Data.Semigroup hiding (option)--import Options.Applicative.Builder.Completer-import Options.Applicative.Builder.Internal-import Options.Applicative.Common-import Options.Applicative.Types-import Options.Applicative.Help.Pretty-import Options.Applicative.Help.Chunk---- readers ------ | 'Option' reader based on the 'Read' type class.-auto :: Read a => ReadM a-auto = eitherReader $ \arg -> case reads arg of-  [(r, "")] -> return r-  _         -> Left $ "cannot parse value `" ++ arg ++ "'"---- | String 'Option' reader.-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"---- modifiers ------ | Specify a short name for an option.-short :: HasName f => Char -> Mod f a-short = fieldMod . name . OptShort---- | Specify a long name for an option.-long :: HasName f => String -> Mod f a-long = fieldMod . name . OptLong---- | Specify a default value for an option.------ /Note/: Because this modifier means the parser will never fail,--- do not use it with combinators such as 'some' or 'many', as--- these combinators continue until a failure occurs.--- Careless use will thus result in a hang.------ To display the default value, combine with showDefault or--- showDefaultWith.-value :: HasValue f => a -> Mod f a-value x = Mod id (DefaultProp (Just x) Nothing) id---- | Specify a function to show the default value for an option.-showDefaultWith :: (a -> String) -> Mod f a-showDefaultWith s = Mod id (DefaultProp Nothing (Just s)) id---- | Show the default value for this option using its 'Show' instance.-showDefault :: Show a => Mod f a-showDefault = showDefaultWith show---- | Specify the help text for an option.-help :: String -> Mod f a-help s = optionMod $ \p -> p { propHelp = paragraph s }---- | Specify the help text for an option as a 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-helpDoc :: Maybe Doc -> Mod f a-helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }---- | 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 }---- | Specify a metavariable for the argument.------ Metavariables have no effect on the actual parser, and only serve to specify--- the symbolic name for an argument to be displayed in the help text.-metavar :: HasMetavar f => String -> Mod f a-metavar var = optionMod $ \p -> p { propMetaVar = var }---- | Hide this option from the brief description.-hidden :: Mod f a-hidden = optionMod $ \p ->-  p { propVisibility = min Hidden (propVisibility p) }---- | Add a command to a subparser option.-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.-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)---- | 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)---- | Add a completer to an argument.------ A completer is a function String -> IO String which, given a partial--- argument, returns all possible completions for that argument.-completer :: HasCompleter f => Completer -> Mod f a-completer f = fieldMod $ modCompleter (`mappend` f)---- parsers ------ | Builder for a command parser. The 'command' modifier can be used to--- specify individual commands.-subparser :: Mod CommandFields a -> Parser a-subparser m = mkParser d g rdr-  where-    Mod _ d g = metavar "COMMAND" `mappend` m-    (groupName, cmds, subs) = mkCommand m-    rdr = CmdReader groupName cmds subs---- | Builder for an argument parser.-argument :: ReadM a -> Mod ArgumentFields a -> Parser a-argument p (Mod f d g) = mkParser d g (ArgReader rdr)-  where-    ArgumentFields compl = f (ArgumentFields mempty)-    rdr = CReader compl p---- | Builder for a 'String' argument.-strArgument :: Mod ArgumentFields String -> Parser String-strArgument = argument str---- | Builder for a flag parser.------ A flag that switches from a \"default value\" to an \"active value\" when--- encountered. For a simple boolean value, use `switch` instead.------ /Note/: Because this parser will never fail, it can not be used with--- combinators such as 'some' or 'many', as these combinators continue until--- a failure occurs. See @flag'@.-flag :: a                         -- ^ default value-     -> a                         -- ^ active value-     -> Mod FlagFields a          -- ^ option modifier-     -> Parser a-flag defv actv m = flag' actv m <|> pure defv---- | Builder for a flag parser without a default value.------ Same as 'flag', but with no default value. In particular, this flag will--- never parse successfully by itself.------ It still makes sense to use it as part of a composite parser. For example------ > length <$> many (flag' () (short 't'))------ is a parser that counts the number of "-t" arguments on the command line,--- alternatively------ > flag' True (long "on") <|> flag' False (long "off")------ will require the user to enter '--on' or '--off' on the command line.-flag' :: a                         -- ^ active value-      -> Mod FlagFields a          -- ^ option modifier-      -> Parser a-flag' actv (Mod f d g) = mkParser d g rdr-  where-    rdr = let fields = f (FlagFields [] actv)-          in FlagReader (flagNames fields)-                        (flagActive fields)---- | Builder for a boolean flag.------ /Note/: Because this parser will never fail, it can not be used with--- combinators such as 'some' or 'many', as these combinators continue until--- a failure occurs. See @flag'@.------ > switch = flag False True-switch :: Mod FlagFields Bool -> Parser Bool-switch = flag False True---- | An option that always fails.------ When this option is encountered, the option parser immediately aborts with--- the given parse error.  If you simply want to output a message, use--- 'infoOption' instead.-abortOption :: ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)-abortOption err m = option (readerAbort err) . (`mappend` m) $ mconcat-  [ noArgError err-  , value id-  , metavar "" ]---- | An option that always fails and displays a message.-infoOption :: String -> Mod OptionFields (a -> a) -> Parser (a -> a)-infoOption = abortOption . InfoMsg---- | Builder for an option taking a 'String' argument.-strOption :: Mod OptionFields String -> Parser String-strOption = option str---- | Same as 'option'.-{-# DEPRECATED nullOption "Use 'option' instead" #-}-nullOption :: ReadM a -> Mod OptionFields a -> Parser a-nullOption = option---- | Builder for an option using the given reader.------ This is a regular option, and should always have either a @long@ or--- @short@ name specified in the modifiers (or both).------ > nameParser = option str ( long "name" <> short 'n' )----option :: ReadM a -> Mod OptionFields a -> Parser a-option r m = mkParser d g rdr-  where-    Mod f d g = metavar "ARG" `mappend` m-    fields = f (OptionFields [] mempty (ErrorMsg ""))-    crdr = CReader (optCompleter fields) r-    rdr = OptReader (optNames fields) crdr (optNoArgError fields)---- | Modifier for 'ParserInfo'.-newtype InfoMod a = InfoMod-  { applyInfoMod :: ParserInfo a -> ParserInfo a }--instance Monoid (InfoMod a) where-  mempty = InfoMod id-  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 }---- | Only show a brief description in the help text of this parser.-briefDesc :: InfoMod a-briefDesc = InfoMod $ \i -> i { infoFullDesc = False }---- | Specify a header for this parser.-header :: String -> InfoMod a-header s = InfoMod $ \i -> i { infoHeader = paragraph s }---- | Specify a header for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-headerDoc :: Maybe Doc -> InfoMod a-headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }---- | Specify a footer for this parser.-footer :: String -> InfoMod a-footer s = InfoMod $ \i -> i { infoFooter = paragraph s }---- | Specify a footer for this parser as a 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-footerDoc :: Maybe Doc -> InfoMod a-footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }---- | Specify a short program description.-progDesc :: String -> InfoMod a-progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s }---- | Specify a short program description as a 'Text.PrettyPrint.ANSI.Leijen.Doc'--- value.-progDescDoc :: Maybe Doc -> InfoMod a-progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }---- | Specify an exit code if a parse error occurs.-failureCode :: Int -> InfoMod a-failureCode n = InfoMod $ \i -> i { infoFailureCode = n }---- | Disable parsing of regular options after arguments-noIntersperse :: InfoMod a-noIntersperse = InfoMod $ \p -> p { infoIntersperse = False }---- | Create a 'ParserInfo' given a 'Parser' and a modifier.-info :: Parser a -> InfoMod a -> ParserInfo a-info parser m = applyInfoMod m base-  where-    base = ParserInfo-      { infoParser = parser-      , infoFullDesc = True-      , infoProgDesc = mempty-      , infoHeader = mempty-      , infoFooter = mempty-      , infoFailureCode = 1-      , infoIntersperse = True }--newtype PrefsMod = PrefsMod-  { applyPrefsMod :: ParserPrefs -> ParserPrefs }--instance Monoid PrefsMod where-  mempty = PrefsMod id-  mappend = (<>)--instance Semigroup PrefsMod where-  m1 <> m2 = PrefsMod $ applyPrefsMod m2 . applyPrefsMod m1--multiSuffix :: String -> PrefsMod-multiSuffix s = PrefsMod $ \p -> p { prefMultiSuffix = s }--disambiguate :: PrefsMod-disambiguate = PrefsMod $ \p -> p { prefDisambiguate = True }--showHelpOnError :: PrefsMod-showHelpOnError = PrefsMod $ \p -> p { prefShowHelpOnError = True }--showHelpOnEmpty :: PrefsMod-showHelpOnEmpty = PrefsMod $ \p -> p { prefShowHelpOnEmpty = True }--noBacktrack :: PrefsMod-noBacktrack = PrefsMod $ \p -> p { prefBacktrack = False }--columns :: Int -> PrefsMod-columns cols = PrefsMod $ \p -> p { prefColumns = cols }--prefs :: PrefsMod -> ParserPrefs-prefs m = applyPrefsMod m base-  where-    base = ParserPrefs-      { prefMultiSuffix = ""-      , prefDisambiguate = False-      , prefShowHelpOnError = False-      , prefShowHelpOnEmpty = False-      , prefBacktrack = True-      , prefColumns = 80 }---- convenience shortcuts---- | Trivial option modifier.-idm :: Monoid m => m-idm = mempty---- | Default preferences.-defaultPrefs :: ParserPrefs-defaultPrefs = prefs idm
− Options/Applicative/Builder/Completer.hs 
@@ -1,31 +0,0 @@-module Options.Applicative.Builder.Completer-  ( Completer-  , mkCompleter-  , listIOCompleter-  , listCompleter-  , bashCompleter-  ) where--import Control.Applicative-import Prelude-import Control.Exception (IOException, try)-import Data.List (isPrefixOf)-import System.Process (readProcess)--import Options.Applicative.Types--listIOCompleter :: IO [String] -> Completer-listIOCompleter ss = Completer $ \s ->-  filter (isPrefixOf s) <$> ss--listCompleter :: [String] -> Completer-listCompleter = listIOCompleter . pure--bashCompleter :: String -> Completer-bashCompleter action = Completer $ \word -> do-  let cmd = unwords ["compgen", "-A", action, "--", word]-  result <- tryIO $ readProcess "bash" ["-c", cmd] ""-  return . lines . either (const []) id $ result--tryIO :: IO a -> IO (Either IOException a)-tryIO = try
− Options/Applicative/Builder/Internal.hs 
@@ -1,180 +0,0 @@-module Options.Applicative.Builder.Internal (-  -- * Internals-  Mod(..),-  HasName(..),-  HasCompleter(..),-  HasValue(..),-  HasMetavar(..),-  OptionFields(..),-  FlagFields(..),-  CommandFields(..),-  ArgumentFields(..),-  DefaultProp(..),--  optionMod,-  fieldMod,--  baseProps,-  mkCommand,-  mkParser,-  mkOption,-  mkProps,--  internal-  ) where--import Control.Applicative-import Control.Monad (mplus)-import Data.Semigroup hiding (Option)-import Prelude--import Options.Applicative.Common-import Options.Applicative.Types--data OptionFields a = OptionFields-  { optNames :: [OptName]-  , optCompleter :: Completer-  , optNoArgError :: ParseError }--data FlagFields a = FlagFields-  { flagNames :: [OptName]-  , flagActive :: a }--data CommandFields a = CommandFields-  { cmdCommands :: [(String, ParserInfo a)]-  , cmdGroup :: Maybe String }--data ArgumentFields a = ArgumentFields-  { argCompleter :: Completer }--class HasName f where-  name :: OptName -> f a -> f a--instance HasName OptionFields where-  name n fields = fields { optNames = n : optNames fields }--instance HasName FlagFields where-  name n fields = fields { flagNames = n : flagNames fields }--class HasCompleter f where-  modCompleter :: (Completer -> Completer) -> f a -> f a--instance HasCompleter OptionFields where-  modCompleter f p = p { optCompleter = f (optCompleter p) }--instance HasCompleter ArgumentFields where-  modCompleter f p = p { argCompleter = f (argCompleter p) }--class HasValue f where-  -- this is just so that it is not necessary to specify the kind of f-  hasValueDummy :: f a -> ()-instance HasValue OptionFields where-  hasValueDummy _ = ()-instance HasValue ArgumentFields where-  hasValueDummy _ = ()--class HasMetavar f where-  hasMetavarDummy :: f a -> ()-instance HasMetavar OptionFields where-  hasMetavarDummy _ = ()-instance HasMetavar ArgumentFields where-  hasMetavarDummy _ = ()-instance HasMetavar CommandFields where-  hasMetavarDummy _ = ()---- mod ----data DefaultProp a = DefaultProp-  (Maybe a)-  (Maybe (a -> String))--instance Monoid (DefaultProp a) where-  mempty = DefaultProp Nothing Nothing-  mappend = (<>)--instance Semigroup (DefaultProp a) where-  (DefaultProp d1 s1) <> (DefaultProp d2 s2) =-    DefaultProp (d1 `mplus` d2) (s1 `mplus` s2)---- | An option modifier.------ Option modifiers are values that represent a modification of the properties--- of an option.------ The type parameter @a@ is the return type of the option, while @f@ is a--- record containing its properties (e.g. 'OptionFields' for regular options,--- 'FlagFields' for flags, etc...).------ An option modifier consists of 3 elements:------  - A field modifier, of the form @f a -> f a@. These are essentially---  (compositions of) setters for some of the properties supported by @f@.------  - An optional default value and function to display it.------  - A property modifier, of the form @OptProperties -> OptProperties@. This---  is just like the field modifier, but for properties applicable to any---  option.------ 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--- 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)-                   (DefaultProp a)-                   (OptProperties -> OptProperties)--optionMod :: (OptProperties -> OptProperties) -> Mod f a-optionMod = Mod id mempty--fieldMod :: (f a -> f a) -> Mod f a-fieldMod f = Mod f mempty id--instance Monoid (Mod f a) where-  mempty = Mod id mempty id-  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-  { propMetaVar = ""-  , propVisibility = Visible-  , propHelp = mempty-  , propShowDefault = Nothing }--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 group = f (CommandFields [] Nothing)--mkParser :: DefaultProp a-         -> (OptProperties -> OptProperties)-         -> OptReader a-         -> Parser a-mkParser d@(DefaultProp def _) g rdr = liftOpt opt <|> maybe empty pure def-  where-    opt = mkOption d g rdr--mkOption :: DefaultProp a-         -> (OptProperties -> OptProperties)-         -> OptReader a-         -> Option a-mkOption d g rdr = Option rdr (mkProps d g)--mkProps :: DefaultProp a-        -> (OptProperties -> OptProperties)-        -> OptProperties-mkProps (DefaultProp def sdef) g = props-  where-    props = (g baseProps)-      { propShowDefault = sdef <*> def }---- | Hide this option from the help text-internal :: Mod f a-internal = optionMod $ \p -> p { propVisibility = Internal }
− Options/Applicative/Common.hs 
@@ -1,289 +0,0 @@-{-# LANGUAGE Rank2Types #-}-module Options.Applicative.Common (-  -- * Option parsers-  ---  -- | A 'Parser' is composed of a list of options. Several kinds of options-  -- are supported:-  ---  --  * 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.-  ---  Parser,-  liftOpt,-  showOption,--  -- * Program descriptions-  ---  -- 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 basic 'ParserInfo' with default values for fields can be created using-  -- the 'info' function.-  ---  -- A 'ParserPrefs' contains general preferences for all command-line-  -- options, and can be built with the 'prefs' function.-  ParserInfo(..),-  ParserPrefs(..),--  -- * Running parsers-  runParserInfo,-  runParserFully,-  runParser,-  evalParser,--  -- * Low-level utilities-  mapParser,-  treeMapParser,-  optionNames-  ) where--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)-import Data.Maybe (maybeToList, isJust)-import Prelude--import Options.Applicative.Internal-import Options.Applicative.Types--showOption :: OptName -> String-showOption (OptLong n) = "--" ++ n-showOption (OptShort n) = '-' : [n]--optionNames :: OptReader a -> [OptName]-optionNames (OptReader names _ _) = names-optionNames (FlagReader names _) = names-optionNames _ = []--isOptionPrefix :: OptName -> OptName -> Bool-isOptionPrefix (OptShort x) (OptShort y) = x == y-isOptionPrefix (OptLong x) (OptLong y) = x `isPrefixOf` y-isOptionPrefix _ _ = False---- | Create a parser composed of a single option.-liftOpt :: Option a -> Parser a-liftOpt = OptP--argMatches :: MonadP m => OptReader a -> String-           -> Maybe (StateT Args m a)-argMatches opt arg = case opt of-  ArgReader rdr -> Just . lift $-    runReadM (crReader rdr) arg-  CmdReader _ _ f ->-    flip fmap (f arg) $ \subp -> StateT $ \args -> do-      prefs <- getPrefs-      let runSubparser-            | prefBacktrack prefs = \i a ->-                runParser (getPolicy i) CmdStart (infoParser i) a-            | otherwise = \i a-            -> (,) <$> runParserInfo i a <*> pure []-      enterContext arg subp *> runSubparser subp args <* exitContext-  _ -> Nothing--optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)-optMatches disambiguate opt (OptWord arg1 val) = case opt of-  OptReader names rdr no_arg_err -> do-    guard $ has_name arg1 names-    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-      put args'-      lift $ runReadM (withReadM (errorFor arg1) (crReader rdr)) arg'-  FlagReader names x -> do-    guard $ has_name arg1 names-    Just $ do-      args <- get-      let val' = (\s -> '-' : s) <$> val-      put $ maybeToList val' ++ args-      return x-  _ -> Nothing-  where-    errorFor name msg = "option " ++ showOption name ++ ": " ++ msg--    has_name a-      | disambiguate = any (isOptionPrefix a)-      | otherwise = elem a--isArg :: OptReader a -> Bool-isArg (ArgReader _) = True-isArg _ = False--data OptWord = OptWord OptName (Maybe String)--parseWord :: String -> Maybe OptWord-parseWord ('-' : '-' : w) = Just $ let-  (opt, arg) = case span (/= '=') w of-    (_, "") -> (w, Nothing)-    (w', _ : rest) -> (w', Just rest)-  in OptWord (OptLong opt) arg-parseWord ('-' : w) = case w of-  [] -> Nothing-  (a : rest) -> Just $ let-    arg = rest <$ guard (not (null rest))-    in OptWord (OptShort a) arg-parseWord _ = Nothing--searchParser :: Monad m-             => (forall r . Option r -> NondetT m r)-             -> Parser a -> NondetT m (Parser a)-searchParser _ (NilP _) = mzero-searchParser f (OptP opt) = liftM pure (f opt)-searchParser f (MultP p1 p2) = foldr1 (<!>)-  [ do p1' <- searchParser f p1-       return (p1' <*> p2)-  , do p2' <- searchParser f p2-       return (p1 <*> p2') ]-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 $ \opt -> do-  let disambiguate = prefDisambiguate pprefs-                  && optVisibility opt > Internal-  case optMatches disambiguate (optMain opt) w of-    Just matcher -> lift matcher-    Nothing -> mzero--searchArg :: MonadP m => String -> Parser a-          -> NondetT (StateT Args m) (Parser a)-searchArg arg = searchParser $ \opt -> do-  when (isArg (optMain opt)) cut-  case argMatches (optMain opt) arg of-    Just matcher -> lift matcher-    Nothing -> mzero--stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String-           -> Parser a -> NondetT (StateT Args m) (Parser a)-stepParser pprefs SkipOpts arg p = case parseWord arg of-  Just w -> searchOpt pprefs w p-  Nothing -> searchArg arg p-stepParser _ 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 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 -> hoistMaybe result <|> parseError arg-      Just p' -> runParser policy 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 ++ "'"--getPolicy :: ParserInfo a -> ArgPolicy-getPolicy i = if infoIntersperse i-  then SkipOpts-  else AllowOpts--runParserInfo :: MonadP m => ParserInfo a -> Args -> m a-runParserInfo i = runParserFully (getPolicy 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---- | The default value of a 'Parser'.  This function returns an error if any of--- the options don't have a default value.-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.-mapParser :: (forall x. OptHelpInfo -> Option x -> b)-              -> Parser a -> [b]-mapParser f = flatten . treeMapParser f-  where-    flatten (Leaf x) = [x]-    flatten (MultNode xs) = xs >>= flatten-    flatten (AltNode xs) = xs >>= flatten---- | Like 'mapParser', but collect the results in a tree structure.-treeMapParser :: (forall x . OptHelpInfo -> Option x -> b)-          -> Parser a-          -> OptTree b-treeMapParser g = simplify . go False False g-  where-    has_default :: Parser a -> Bool-    has_default p = isJust (evalParser p)--    go :: Bool -> Bool-       -> (forall x . OptHelpInfo -> Option x -> b)-       -> Parser a-       -> OptTree b-    go _ _ _ (NilP _) = MultNode []-    go m d f (OptP opt)-      | optVisibility opt > Internal-      = Leaf (f (OptHelpInfo m d) 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]-      where d' = d || has_default p1 || has_default p2-    go _ d f (BindP p _) = go True d f p--simplify :: OptTree a -> OptTree a-simplify (Leaf x) = Leaf x-simplify (MultNode xs) =-  case concatMap (remove_mult . simplify) xs of-    [x] -> x-    xs' -> MultNode xs'-  where-    remove_mult (MultNode ts) = ts-    remove_mult t = [t]-simplify (AltNode xs) =-  case concatMap (remove_alt . simplify) xs of-    []  -> MultNode []-    [x] -> x-    xs' -> AltNode xs'-  where-    remove_alt (AltNode ts) = ts-    remove_alt (MultNode []) = []-    remove_alt t = [t]
− Options/Applicative/Extra.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Options.Applicative.Extra (-  -- * Extra parser utilities-  ---  -- | This module contains high-level functions to run parsers.-  helper,-  hsubparser,-  execParser,-  execParserMaybe,-  customExecParser,-  customExecParserMaybe,-  execParserPure,-  getParseResult,-  handleParseResult,-  parserFailure,-  renderFailure,-  ParserFailure(..),-  overFailure,-  ParserResult(..),-  ParserPrefs(..),-  CompletionResult(..),-  ) where--import Control.Applicative-import Data.Monoid-import Prelude-import System.Environment (getArgs, getProgName)-import System.Exit (exitSuccess, exitWith, ExitCode(..))-import System.IO (hPutStrLn, stderr)--import Options.Applicative.BashCompletion-import Options.Applicative.Builder hiding (briefDesc)-import Options.Applicative.Builder.Internal-import Options.Applicative.Common-import Options.Applicative.Help--import Options.Applicative.Internal-import Options.Applicative.Types---- | A hidden \"helper\" option which always fails.-helper :: Parser (a -> a)-helper = abortOption ShowHelpText $ mconcat-  [ long "help"-  , short 'h'-  , help "Show this help text"-  , hidden ]---- | Builder for a command parser with a \"helper\" option attached.--- Used in the same way as `subparser`, but includes a \"--help|-h\" inside--- the subcommand.-hsubparser :: Mod CommandFields a -> Parser a-hsubparser m = mkParser d g rdr-  where-    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 }---- | Run a program description.------ Parse command line arguments. Display help text and exit if any parse error--- occurs.-execParser :: ParserInfo a -> IO a-execParser = customExecParser defaultPrefs---- | Run a program description with custom preferences.-customExecParser :: ParserPrefs -> ParserInfo a -> IO a-customExecParser pprefs pinfo-  = execParserPure pprefs pinfo <$> getArgs-  >>= handleParseResult---- | Handle `ParserResult`.-handleParseResult :: ParserResult a -> IO a-handleParseResult (Success a) = return a-handleParseResult (Failure failure) = do-      progn <- getProgName-      let (msg, exit) = renderFailure failure progn-      case exit of-        ExitSuccess -> putStrLn msg-        _           -> hPutStrLn stderr msg-      exitWith exit-handleParseResult (CompletionInvoked compl) = do-      progn <- getProgName-      msg <- execCompletion compl progn-      putStr msg-      exitSuccess---- | Extract the actual result from a `ParserResult` value.------ This function returns 'Nothing' in case of errors.  Possible error messages--- or completion actions are simply discarded.------ If you want to display error messages and invoke completion actions--- appropriately, use 'handleParseResult' instead.-getParseResult :: ParserResult a -> Maybe a-getParseResult (Success a) = Just a-getParseResult _ = Nothing---- | Run a program description in pure code.------ This function behaves like 'execParser', but can be called from pure code.--- Note that, in case of errors, no message is displayed, and this function--- simply returns 'Nothing'.------ If you need to keep track of error messages, use 'execParserPure' instead.-{-# DEPRECATED execParserMaybe "Use execParserPure together with getParseResult instead" #-}-execParserMaybe :: ParserInfo a -> [String] -> Maybe a-execParserMaybe = customExecParserMaybe defaultPrefs---- | Run a program description with custom preferences in pure code.------ See 'execParserMaybe' for details.-{-# DEPRECATED customExecParserMaybe "Use execParserPure together with getParseResult instead" #-}-customExecParserMaybe :: ParserPrefs -> ParserInfo a -> [String] -> Maybe a-customExecParserMaybe pprefs pinfo args = getParseResult $ execParserPure pprefs pinfo args---- | The most general way to run a program description in pure code.-execParserPure :: ParserPrefs       -- ^ Global preferences for this parser-               -> ParserInfo a      -- ^ Description of the program to run-               -> [String]          -- ^ Program arguments-               -> ParserResult a-execParserPure pprefs pinfo args =-  case runP p pprefs of-    (Right (Right r), _) -> Success r-    (Right (Left c), _) -> CompletionInvoked c-    (Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx-  where-    pinfo' = pinfo-      { infoParser = (Left <$> bashCompletionParser pinfo pprefs)-                 <|> (Right <$> infoParser pinfo) }-    p = runParserInfo pinfo' args---- | Generate a `ParserFailure` from a `ParseError` in a given `Context`.------ This function can be used, for example, to show the help text for a parser:------ @handleParseResult . Failure $ parserFailure pprefs pinfo ShowHelpText mempty@-parserFailure :: ParserPrefs -> ParserInfo a-              -> ParseError -> [Context]-              -> ParserFailure ParserHelp-parserFailure pprefs pinfo msg ctx = ParserFailure $ \progn ->-  let h = with_context ctx pinfo $ \names pinfo' -> mconcat-            [ base_help pinfo'-            , usage_help progn names pinfo'-            , 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--    with_context :: [Context]-                 -> ParserInfo a-                 -> (forall b . [String] -> ParserInfo b -> c)-                 -> c-    with_context [] i f = f [] i-    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 ]--    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--    base_help :: ParserInfo a -> ParserHelp-    base_help i-      | show_full_help-      = mconcat [h, f, parserHelp pprefs (infoParser i)]-      | otherwise-      = mempty-      where-        h = headerHelp (infoHeader i)-        f = footerHelp (infoFooter i)--    show_full_help = case msg of-      ShowHelpText             -> True-      MissingError CmdStart  _ | prefShowHelpOnEmpty pprefs-                               -> True-      _                        -> prefShowHelpOnError pprefs--renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)-renderFailure failure progn =-  let (h, exit, cols) = execFailure failure progn-  in (renderHelp cols h, exit)
− Options/Applicative/Help.hs 
@@ -1,24 +0,0 @@-module Options.Applicative.Help (-  -- | This is an empty module which re-exports-  --   the help text system for optparse.--  -- | Pretty printer. Reexports most combinators-  --   from Text.PrettyPrint.ANSI.Leijen-  module Options.Applicative.Help.Pretty,--  -- | A free monoid over Doc with helpers for-  --   composing help text components.-  module Options.Applicative.Help.Chunk,--  -- | Types required by the help system.-  module Options.Applicative.Help.Types,--  -- | Core implementation of the help text-  --   generator.-  module Options.Applicative.Help.Core,-  ) where--import Options.Applicative.Help.Pretty-import Options.Applicative.Help.Chunk-import Options.Applicative.Help.Types-import Options.Applicative.Help.Core
− Options/Applicative/Help/Chunk.hs 
@@ -1,139 +0,0 @@-module Options.Applicative.Help.Chunk-  ( mappendWith-  , Chunk(..)-  , chunked-  , listToChunk-  , (<<+>>)-  , (<</>>)-  , vcatChunks-  , vsepChunks-  , isEmpty-  , stringChunk-  , paragraph-  , extractChunk-  , tabulate-  ) where--import Control.Applicative-import Control.Monad-import Data.Maybe-import Data.Monoid-import Prelude--import Options.Applicative.Help.Pretty--mappendWith :: Monoid a => a -> a -> a -> a-mappendWith s x y = mconcat [x, s, y]---- | The free monoid on a semigroup 'a'.-newtype Chunk a = Chunk-  { unChunk :: Maybe a }-  deriving (Eq, Show)--instance Functor Chunk where-  fmap f = Chunk . fmap f . unChunk--instance Applicative Chunk where-  pure = Chunk . pure-  Chunk f <*> Chunk x = Chunk (f <*> x)--instance Alternative Chunk where-  empty = Chunk Control.Applicative.empty-  a <|> b = Chunk $ unChunk a <|> unChunk b--instance Monad Chunk where-  return = pure-  m >>= f = Chunk $ unChunk m >>= unChunk . f--instance MonadPlus Chunk where-  mzero = Chunk mzero-  mplus m1 m2 = Chunk $ mplus (unChunk m1) (unChunk m2)---- | Given a semigroup structure on 'a', return a monoid structure on 'Chunk a'.------ Note that this is /not/ the same as 'liftA2'.-chunked :: (a -> a -> a)-        -> Chunk a -> Chunk a -> Chunk a-chunked _ (Chunk Nothing) y = y-chunked _ x (Chunk Nothing) = x-chunked f (Chunk (Just x)) (Chunk (Just y)) = Chunk (Just (f x y))---- | Concatenate a list into a Chunk.  'listToChunk' satisfies:------ > isEmpty . listToChunk = null--- > listToChunk = mconcat . fmap pure-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.------ This is the counit of the adjunction between 'Chunk' and the forgetful--- functor from monoids to semigroups.  It satisfies:------ > extractChunk . pure = id--- > extractChunk . fmap pure = id-extractChunk :: Monoid a => Chunk a -> a-extractChunk = fromMaybe mempty . unChunk--- we could also define:--- duplicate :: Monoid a => Chunk a -> Chunk (Chunk a)--- duplicate = fmap pure---- | Concatenate two 'Chunk's with a space in between.  If one is empty, this--- just returns the other one.------ Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty--- 'Chunk'.-(<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc-(<<+>>) = chunked (<+>)---- | Concatenate two 'Chunk's with a softline in between.  This is exactly like--- '<<+>>', but uses a softline instead of a space.-(<</>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc-(<</>>) = chunked (</>)---- | Concatenate 'Chunk's vertically.-vcatChunks :: [Chunk Doc] -> Chunk Doc-vcatChunks = foldr (chunked (.$.)) mempty---- | Concatenate 'Chunk's vertically separated by empty lines.-vsepChunks :: [Chunk Doc] -> Chunk Doc-vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty---- | Whether a 'Chunk' is empty.  Note that something like 'pure mempty' is not--- considered an empty chunk, even though the underlying 'Doc' is empty.-isEmpty :: Chunk a -> Bool-isEmpty = isNothing . unChunk---- | Convert a 'String' into a 'Chunk'.  This satisfies:------ > isEmpty . stringChunk = null--- > extractChunk . stringChunk = string-stringChunk :: String -> Chunk Doc-stringChunk "" = mempty-stringChunk s = pure (string s)---- | Convert a paragraph into a 'Chunk'.  The resulting chunk is composed by the--- words of the original paragraph separated by softlines, so it will be--- automatically word-wrapped when rendering the underlying document.------ This satisfies:------ > isEmpty . paragraph = null . words-paragraph :: String -> Chunk Doc-paragraph = foldr (chunked (</>) . stringChunk) mempty-          . words--tabulate' :: Int -> [(Doc, Doc)] -> Chunk Doc-tabulate' _ [] = mempty-tabulate' size table = pure $ vcat-  [ indent 2 (fillBreak size key <+> value)-  | (key, value) <- table ]---- | Display pairs of strings in a table.-tabulate :: [(Doc, Doc)] -> Chunk Doc-tabulate = tabulate' 24
− Options/Applicative/Help/Core.hs 
@@ -1,173 +0,0 @@-module Options.Applicative.Help.Core (-  cmdDesc,-  briefDesc,-  missingDesc,-  fold_tree,-  fullDesc,-  ParserHelp(..),-  errorHelp,-  headerHelp,-  usageHelp,-  bodyHelp,-  footerHelp,-  parserHelp,-  parserUsage,-  ) where--import Control.Applicative-import Control.Monad (guard)-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 -> [(Maybe String, Chunk Doc)]-cmdDesc = mapParser desc-  where-    desc _ opt =-      case optMain opt of-        CmdReader gn cmds p -> (,) gn $-          tabulate [(string cmd, align (extractChunk d))-                   | cmd <- reverse cmds-                   , d <- maybeToList . fmap infoProgDesc $ p cmd ]-        _ -> mempty---- | Generate a brief help text for a parser.-briefDesc :: ParserPrefs -> Parser a -> Chunk Doc-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-fold_tree (Leaf x) = x-fold_tree (MultNode xs) = foldr ((<</>>) . fold_tree) mempty xs-fold_tree (AltNode xs) = alt_node-                       . filter (not . isEmpty)-                       . map fold_tree $ xs-  where-    alt_node :: [Chunk Doc] -> Chunk Doc-    alt_node [n] = n-    alt_node ns = fmap parens-                . foldr (chunked (\x y -> x </> char '|' </> y)) mempty-                $ ns---- | Generate a full help text for a parser.-fullDesc :: ParserPrefs -> Parser a -> Chunk Doc-fullDesc pprefs = tabulate . catMaybes . mapParser doc-  where-    doc info opt = do-      guard . not . isEmpty $ n-      guard . not . isEmpty $ h-      return (extractChunk n, align . extractChunk $ h <<+>> hdef)-      where-        n = optDesc pprefs style info opt-        h = optHelp opt-        hdef = Chunk . fmap show_def . optShowDefault $ opt-        show_def s = parens (string "default:" <+> string s)-    style = OptDescStyle-      { descSep = string ","-      , descHidden = True-      , descOptional = True-      , descSurround = False }--errorHelp :: Chunk Doc -> ParserHelp-errorHelp chunk = ParserHelp chunk mempty mempty mempty mempty--headerHelp :: Chunk Doc -> ParserHelp-headerHelp chunk = ParserHelp mempty chunk mempty mempty mempty--usageHelp :: Chunk Doc -> ParserHelp-usageHelp chunk = ParserHelp mempty mempty chunk mempty mempty--bodyHelp :: Chunk Doc -> ParserHelp-bodyHelp chunk = ParserHelp mempty mempty mempty chunk mempty--footerHelp :: Chunk Doc -> ParserHelp-footerHelp chunk = ParserHelp mempty mempty mempty mempty chunk---- | Generate the help text for a program.-parserHelp :: ParserPrefs -> Parser a -> ParserHelp-parserHelp pprefs p = bodyHelp . vsepChunks $-  ( 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 .$.)---- | Generate option summary.-parserUsage :: ParserPrefs -> Parser a -> String -> Doc-parserUsage pprefs p progn = hsep-  [ string "Usage:"-  , string progn-  , align (extractChunk (briefDesc pprefs p)) ]--{-# ANN footerHelp "HLint: ignore Eta reduce" #-}
− Options/Applicative/Help/Pretty.hs 
@@ -1,10 +0,0 @@-module Options.Applicative.Help.Pretty-  ( module Text.PrettyPrint.ANSI.Leijen-  , (.$.)-  ) where--import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>), columns)-import qualified Text.PrettyPrint.ANSI.Leijen as PP--(.$.) :: Doc -> Doc -> Doc-(.$.) = (PP.<$>)
− Options/Applicative/Help/Types.hs 
@@ -1,40 +0,0 @@-module Options.Applicative.Help.Types (-  ParserHelp(..),-  renderHelp-  ) where--import Data.Semigroup-import Prelude--import Options.Applicative.Help.Chunk-import Options.Applicative.Help.Pretty--data ParserHelp = ParserHelp-  { helpError :: Chunk Doc-  , helpHeader :: Chunk Doc-  , helpUsage :: Chunk Doc-  , helpBody :: Chunk Doc-  , helpFooter :: Chunk Doc }--instance Show ParserHelp where-  showsPrec _ h = showString (renderHelp 80 h)--instance Monoid ParserHelp where-  mempty = ParserHelp 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)--helpText :: ParserHelp -> Doc-helpText (ParserHelp e h u b f) = extractChunk . vsepChunks $ [e, h, u, b, f]---- | Convert a help text to 'String'.-renderHelp :: Int -> ParserHelp -> String-renderHelp cols-  = (`displayS` "")-  . renderPretty 1.0 cols-  . helpText
− Options/Applicative/Internal.hs 
@@ -1,269 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-module Options.Applicative.Internal-  ( P-  , MonadP(..)-  , ParseError(..)--  , uncons-  , hoistMaybe-  , hoistEither-  , runReadM-  , withReadM--  , runP--  , Completion-  , runCompletion-  , contextNames--  , ListT-  , takeListT-  , runListT--  , NondetT-  , cut-  , (<!>)-  , disamb-  ) where--import Control.Applicative-import Prelude-import Control.Monad (MonadPlus(..), liftM, ap, guard)-import Control.Monad.Trans.Class (MonadTrans, lift)-import Control.Monad.Trans.Except-  (runExcept, runExceptT, withExcept, ExceptT(..), throwE, catchE)-import Control.Monad.Trans.Reader-  (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)-import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)--import Options.Applicative.Types--class (Alternative m, MonadPlus m) => MonadP m where-  enterContext :: String -> ParserInfo a -> m ()-  exitContext :: m ()-  getPrefs :: m ParserPrefs--  missingArgP :: ParseError -> Completer -> m a-  tryP :: m a -> m (Either ParseError a)-  errorP :: ParseError -> m a-  exitP :: IsCmdStart -> Parser b -> Maybe a -> m a--newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)--instance Functor P where-  fmap f (P m) = P $ fmap f m--instance Applicative P where-  pure a = P $ pure a-  P f <*> P a = P $ f <*> a--instance Alternative P where-  empty = P empty-  P x <|> P y = P $ x <|> y--instance Monad P where-  return a = P $ return a-  P x >>= k = P $ x >>= \a -> case k a of P y -> y--instance MonadPlus P where-  mzero = P mzero-  mplus (P x) (P y) = P $ mplus x y--contextNames :: [Context] -> [String]-contextNames ns =-  let go (Context n _) = n-  in  reverse $ go <$> ns--instance MonadP P where-  enterContext name pinfo = P $ lift $ modify $ (:) $ Context name pinfo-  exitContext = P $ lift $ modify $ drop 1-  getPrefs = P . lift . lift $ ask--  missingArgP e _ = errorP e-  tryP (P p) = P $ lift $ runExceptT p-  exitP i p = P . maybe (throwE . MissingError i . SomeParser $ p) return-  errorP = P . throwE--hoistMaybe :: MonadPlus m => Maybe a -> m a-hoistMaybe = maybe mzero return--hoistEither :: MonadP m => Either ParseError a -> m a-hoistEither = either errorP return--runP :: P a -> ParserPrefs -> (Either ParseError a, [Context])-runP (P p) = runReader . flip runStateT [] . runExceptT $ p--uncons :: [a] -> Maybe (a, [a])-uncons [] = Nothing-uncons (x : xs) = Just (x, xs)--runReadM :: MonadP m => ReadM a -> String -> m a-runReadM (ReadM r) s = hoistEither . runExcept $ runReaderT r s--withReadM :: (String -> String) -> ReadM a -> ReadM a-withReadM f = ReadM . mapReaderT (withExcept f') . unReadM-  where-    f' (ErrorMsg err) = ErrorMsg (f err)-    f' e = e--data ComplResult a-  = ComplParser SomeParser-  | ComplOption Completer-  | ComplResult a--instance Functor ComplResult where-  fmap = liftM--instance Applicative ComplResult where-  pure = ComplResult-  (<*>) = ap--instance Monad ComplResult where-  return = pure-  m >>= f = case m of-    ComplResult r -> f r-    ComplParser p -> ComplParser p-    ComplOption c -> ComplOption c--newtype Completion a =-  Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)--instance Functor Completion where-  fmap f (Completion m) = Completion $ fmap f m--instance Applicative Completion where-  pure a = Completion $ pure a-  Completion f <*> Completion a = Completion $ f <*> a--instance Alternative Completion where-  empty = Completion empty-  Completion x <|> Completion y = Completion $ x <|> y--instance Monad Completion where-  return a = Completion $ return a-  Completion x >>= k = Completion $ x >>= \a -> case k a of Completion y -> y--instance MonadPlus Completion where-  mzero = Completion mzero-  mplus (Completion x) (Completion y) = Completion $ mplus x y--instance MonadP Completion where-  enterContext _ _ = return ()-  exitContext = return ()-  getPrefs = Completion $ lift ask--  missingArgP _ = Completion . lift . lift . ComplOption-  tryP (Completion p) = Completion $ catchE (Right <$> p) (return . Left)-  exitP _ p _ = Completion . lift . lift . ComplParser $ SomeParser p-  errorP = Completion . throwE--runCompletion :: Completion r -> ParserPrefs -> Maybe (Either SomeParser Completer)-runCompletion (Completion c) prefs = case runReaderT (runExceptT c) prefs of-  ComplResult _ -> Nothing-  ComplParser p' -> Just $ Left p'-  ComplOption compl -> Just $ Right compl---- A "ListT done right" implementation--newtype ListT m a = ListT-  { stepListT :: m (TStep a (ListT m a)) }--data TStep a x-  = TNil-  | TCons a x--bimapTStep :: (a -> b) -> (x -> y) -> TStep a x -> TStep b y-bimapTStep _ _ TNil = TNil-bimapTStep f g (TCons a x) = TCons (f a) (g x)--hoistList :: Monad m => [a] -> ListT m a-hoistList = foldr (\x xt -> ListT (return (TCons x xt))) mzero--takeListT :: Monad m => Int -> ListT m a -> ListT m a-takeListT 0 = const mzero-takeListT n = ListT . liftM (bimapTStep id (takeListT (n - 1))) . stepListT--runListT :: Monad m => ListT m a -> m [a]-runListT xs = do-  s <- stepListT xs-  case s of-    TNil -> return []-    TCons x xt -> liftM (x :) (runListT xt)--instance Monad m => Functor (ListT m) where-  fmap f = ListT-         . liftM (bimapTStep f (fmap f))-         . stepListT--instance Monad m => Applicative (ListT m) where-  pure = hoistList . pure-  (<*>) = ap--instance Monad m => Monad (ListT m) where-  return = pure-  xs >>= f = ListT $ do-    s <- stepListT xs-    case s of-      TNil -> return TNil-      TCons x xt -> stepListT $ f x `mplus` (xt >>= f)--instance Monad m => Alternative (ListT m) where-  empty = mzero-  (<|>) = mplus--instance MonadTrans ListT where-  lift = ListT . liftM (`TCons` mzero)--instance Monad m => MonadPlus (ListT m) where-  mzero = ListT (return TNil)-  mplus xs ys = ListT $ do-    s <- stepListT xs-    case s of-      TNil -> stepListT ys-      TCons x xt -> return $ TCons x (xt `mplus` ys)---- nondeterminism monad with cut operator--newtype NondetT m a = NondetT-  { runNondetT :: ListT (StateT Bool m) a }--instance Monad m => Functor (NondetT m) where-  fmap f = NondetT . fmap f . runNondetT--instance Monad m => Applicative (NondetT m) where-  pure = NondetT . pure-  NondetT m1 <*> NondetT m2 = NondetT (m1 <*> m2)--instance Monad m => Monad (NondetT m) where-  return = pure-  NondetT m1 >>= f = NondetT $ m1 >>= runNondetT . f--instance Monad m => MonadPlus (NondetT m) where-  mzero = NondetT mzero-  NondetT m1 `mplus` NondetT m2 = NondetT (m1 `mplus` m2)--instance Monad m => Alternative (NondetT m) where-  empty = mzero-  (<|>) = mplus--instance MonadTrans NondetT where-  lift = NondetT . lift . lift--(<!>) :: Monad m => NondetT m a -> NondetT m a -> NondetT m a-(<!>) m1 m2 = NondetT . mplus (runNondetT m1) $ do-  s <- lift get-  guard (not s)-  runNondetT m2--cut :: Monad m => NondetT m ()-cut = NondetT $ lift (put True)--disamb :: Monad m => Bool -> NondetT m a -> m (Maybe a)-disamb allow_amb xs = do-  xs' <- (`evalStateT` False)-       . runListT-       . takeListT (if allow_amb then 1 else 2)-       . runNondetT $ xs-  return $ case xs' of-    [x] -> Just x-    _   -> Nothing
− Options/Applicative/Types.hs 
@@ -1,350 +0,0 @@-{-# LANGUAGE Rank2Types, ExistentialQuantification #-}-module Options.Applicative.Types (-  ParseError(..),-  ParserInfo(..),-  ParserPrefs(..),--  Option(..),-  OptName(..),-  OptReader(..),-  OptProperties(..),-  OptVisibility(..),-  ReadM(..),-  readerAsk,-  readerAbort,-  readerError,-  CReader(..),-  Parser(..),-  ParserM(..),-  Completer(..),-  mkCompleter,-  CompletionResult(..),-  ParserFailure(..),-  ParserResult(..),-  overFailure,-  Args,-  ArgPolicy(..),-  OptHelpInfo(..),-  OptTree(..),-  ParserHelp(..),-  SomeParser(..),-  Context(..),-  IsCmdStart(..),--  fromM,-  oneM,-  manyM,-  someM,--  optVisibility,-  optMetaVar,-  optHelp,-  optShowDefault-  ) where--import Control.Applicative-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.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 IsCmdStart SomeParser--data IsCmdStart = CmdStart | CmdCont-  deriving Show--instance Monoid ParseError where-  mempty = UnknownError-  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-  , infoFullDesc :: Bool      -- ^ whether the help text should contain full-                              -- documentation-  , infoProgDesc :: Chunk Doc -- ^ brief parser description-  , 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)-  }--instance Functor ParserInfo where-  fmap f i = i { infoParser = fmap f (infoParser i) }---- | Global preferences for a top-level 'Parser'.-data ParserPrefs = ParserPrefs-  { prefMultiSuffix :: String    -- ^ metavar suffix for multiple options-  , prefDisambiguate :: Bool     -- ^ automatically disambiguate abbreviations-                                 -- (default: False)-  , prefShowHelpOnError :: Bool  -- ^ always show help text on parse errors-                                 -- (default: False)-  , 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-                                 -- format the help page (default: 80)-  } deriving (Eq, Show)--data OptName = OptShort !Char-             | OptLong !String-  deriving (Eq, Ord, Show)---- | Visibility of an option in the help text.-data OptVisibility-  = Internal          -- ^ does not appear in the help text at all-  | Hidden            -- ^ only visible in the full description-  | Visible           -- ^ visible both in the full and brief descriptions-  deriving (Eq, Ord, Show)---- | Specification for an individual parser option.-data OptProperties = OptProperties-  { propVisibility :: OptVisibility       -- ^ whether this flag is shown is the brief description-  , 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---- | A single option of a parser.-data Option a = Option-  { optMain :: OptReader a               -- ^ reader for this option-  , 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) ++ "}"--instance Functor Option where-  fmap f (Option m p) = Option (fmap f m) p---- | A newtype over 'ReaderT String Except', used by option readers.-newtype ReadM a = ReadM-  { unReadM :: ReaderT String (Except ParseError) a }--instance Functor ReadM where-  fmap f (ReadM r) = ReadM (fmap f r)--instance Applicative ReadM where-  pure = ReadM . pure-  ReadM x <*> ReadM y = ReadM $ x <*> y--instance Alternative ReadM where-  empty = mzero-  (<|>) = mplus--instance Monad ReadM where-  return = pure-  ReadM r >>= f = ReadM $ r >>= unReadM . f-  fail = readerError--instance MonadPlus ReadM where-  mzero = ReadM mzero-  mplus (ReadM x) (ReadM y) = ReadM $ mplus x y---- | Return the value being read.-readerAsk :: ReadM String-readerAsk = ReadM ask---- | Abort option reader by exiting with a 'ParseError'.-readerAbort :: ParseError -> ReadM a-readerAbort = ReadM . lift . throwE---- | Abort option reader by exiting with an error message.-readerError :: String -> ReadM a-readerError = readerAbort . ErrorMsg--data CReader a = CReader-  { crCompleter :: Completer-  , crReader :: ReadM a }--instance Functor CReader where-  fmap f (CReader c r) = CReader c (fmap f r)---- | An 'OptReader' defines whether an option matches an command line argument.-data OptReader a-  = OptReader [OptName] (CReader a) 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-  fmap f (FlagReader ns x) = FlagReader ns (f x)-  fmap f (ArgReader cr) = ArgReader (fmap f cr)-  fmap f (CmdReader n cs g) = CmdReader n cs ((fmap . fmap) f . g)---- | A @Parser a@ is an option parser returning a value of type 'a'.-data Parser a-  = NilP (Maybe a)-  | OptP (Option a)-  | forall x . MultP (Parser (x -> a)) (Parser x)-  | AltP (Parser a) (Parser a)-  | forall x . BindP (Parser x) (x -> Parser a)--instance Functor Parser where-  fmap f (NilP x) = NilP (fmap f x)-  fmap f (OptP opt) = OptP (fmap f opt)-  fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2-  fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2)-  fmap f (BindP p k) = BindP p (fmap f . k)--instance Applicative Parser where-  pure = NilP . Just-  (<*>) = MultP--newtype ParserM r = ParserM-  { runParserM :: forall x . (r -> Parser x) -> Parser x }--instance Monad ParserM where-  return x = ParserM $ \k -> k x-  ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)--instance Functor ParserM where-  fmap = liftM--instance Applicative ParserM where-  pure = return-  (<*>) = ap--fromM :: ParserM a -> Parser a-fromM (ParserM f) = f pure--oneM :: Parser a -> ParserM a-oneM p = ParserM (BindP p)--manyM :: Parser a -> ParserM [a]-manyM p = do-  mx <- oneM (optional p)-  case mx of-    Nothing -> return []-    Just x -> (x:) <$> manyM p--someM :: Parser a -> ParserM [a]-someM p = (:) <$> oneM p <*> manyM p--instance Alternative Parser where-  empty = NilP Nothing-  (<|>) = AltP-  many p = fromM $ manyM p-  some p = fromM $ (:) <$> oneM p <*> manyM p--newtype Completer = Completer-  { runCompleter :: String -> IO [String] }--mkCompleter :: (String -> IO [String]) -> Completer-mkCompleter = Completer--instance Monoid Completer where-  mempty = Completer $ \_ -> return []-  mappend (Completer c1) (Completer c2) =-    Completer $ \s -> (++) <$> c1 s <*> c2 s--newtype CompletionResult = CompletionResult-  { execCompletion :: String -> IO String }--instance Show CompletionResult where-  showsPrec p _ = showParen (p > 10) $-    showString "CompletionResult _"--newtype ParserFailure h = ParserFailure-  { execFailure :: String -> (h, ExitCode, Int) }--instance Show h => Show (ParserFailure h) where-  showsPrec p (ParserFailure f)-    = showParen (p > 10)-    $ showString "ParserFailure "-    . showsPrec 11 (f "<program>")--instance Functor ParserFailure where-  fmap f (ParserFailure err) = ParserFailure $ \progn ->-    let (h, exit, cols) = err progn in (f h, exit, cols)---- | Result of 'execParserPure'.-data ParserResult a-  = Success a-  | Failure (ParserFailure ParserHelp)-  | CompletionInvoked CompletionResult-  deriving Show--instance Functor ParserResult where-  fmap f (Success a) = Success (f a)-  fmap _ (Failure f) = Failure f-  fmap _ (CompletionInvoked c) = CompletionInvoked c--overFailure :: (ParserHelp -> ParserHelp)-            -> ParserResult a -> ParserResult a-overFailure f (Failure failure) = Failure $ fmap f failure-overFailure _ r = r--instance Applicative ParserResult where-  pure = Success-  Success f <*> r = fmap f r-  Failure f <*> _ = Failure f-  CompletionInvoked c <*> _ = CompletionInvoked c--instance Monad ParserResult where-  return = pure-  Success x >>= f = f x-  Failure f >>= _ = Failure f-  CompletionInvoked c >>= _ = CompletionInvoked c--type Args = [String]---- | 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)--data OptHelpInfo = OptHelpInfo-  { hinfoMulti :: Bool-  , hinfoDefault :: Bool-  } deriving (Eq, Show)--data OptTree a-  = Leaf a-  | MultNode [OptTree a]-  | AltNode [OptTree a]-  deriving Show--optVisibility :: Option a -> OptVisibility-optVisibility = propVisibility . optProps--optHelp :: Option a -> Chunk Doc-optHelp  = propHelp . optProps--optMetaVar :: Option a -> String-optMetaVar = propMetaVar . optProps--optShowDefault :: Option a -> Maybe String-optShowDefault = propShowDefault . optProps
README.md view
@@ -2,21 +2,23 @@  [![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-for composing these options.+the command line, and providing a powerful [applicative] interface+for composing them.  optparse-applicative takes care of reading and validating the arguments passed to the command line, handling and reporting errors, generating a usage line, a comprehensive help screen, and enabling-context-sensitive bash completions.+context-sensitive bash, zsh, and fish completions.  **Table of Contents**  - [Introduction](#introduction) - [Quick Start](#quick-start)-- [Basics](#Basics)+- [Basics](#basics)     - [Parsers](#parsers)     - [Applicative](#applicative)     - [Alternative](#alternative)@@ -34,13 +36,14 @@     - [Disambiguation](#disambiguation)     - [Customising the help screen](#customising-the-help-screen)     - [Command Groups](#command-groups)-- [Bash completion](#bash-completion)+- [Bash completion](#bash-zsh-and-fish-completions)     - [Actions and completers](#actions-and-completers)     - [Internals](#internals) - [Arrow interface](#arrow-interface) - [Applicative Do](#applicative-do) - [FAQ](#faq) - [How it works](#how-it-works)+- [Tutorials](#tutorials)  ## Introduction @@ -72,12 +75,11 @@  ```haskell import Options.Applicative-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 +92,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 +102,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 +118,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 +133,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 +142,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 +167,7 @@ ```haskell target :: Parser String target = strOption-  (  long "target"+  (  long "hello"   <> metavar "TARGET"   <> help "Target for the greeting" ) ```@@ -175,7 +177,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@@ -237,7 +239,7 @@     -q --target world  It is this property which leads us to an Applicative interface-instead of a Monadic one, as all option must be considered in+instead of a Monadic one, as all options must be considered in parallel, and can not depend on the output of other options.  Note, however, that the order of sequencing is still somewhat@@ -300,8 +302,15 @@ parsers are also able to be composed with standard combinators. For example: `optional :: Alternative f => f a -> f (Maybe a)` will mean the user is not required to provide input for the affected-`Parser`.+`Parser`. For example, the following parser will return `Nothing`+instead of failing if the user doesn't supply an `output` option: +```haskell+optional $ strOption+  ( long "output"+ <> metavar "DIRECTORY" )+```+ ### Running parsers  Before we can run a `Parser`, we need to wrap it into a `ParserInfo`@@ -474,8 +483,8 @@  Another interesting use for the `flag'` builder is to count the number of instances on the command line, for example, verbosity-settings could be specified on a scale; the following parser with-count the number of of instances of `-v` on the command line.+settings could be specified on a scale; the following parser will+count the number of instances of `-v` on the command line.  ```haskell length <$> many (flag' () (short 'v'))@@ -501,7 +510,7 @@ `many` or `some` combinator:  ```haskell-some (argument str (metavar "FILES..."))+some (argument str (metavar "FILES")) ```  Note that arguments starting with `-` are considered options by@@ -524,22 +533,6 @@ global options that apply to all of them. Typical examples are version control systems like `git`, or build tools like `cabal`. -A command can be created using the `subparser` builder (or `hsubparser`,-which is identical but for an additional `--help` option on each-command), and commands can be added with the `command` modifier.-For example--```haskell-subparser-  ( command "add" (info addOptions ( progDesc "Add a file to the repository" ))- <> command "commit" (info commitOptions ( progDesc "Record changes to the repository" ))-  )-```--Each command takes a full `ParserInfo` structure, which will be-used to extract a description for this command when generating a-help text.- Note that all the parsers appearing in a command need to have the same type.  For this reason, it is often best to use a sum type which has the same structure as the command itself. For example,@@ -556,6 +549,22 @@   ... ``` +A command can then be created using the `subparser` builder (or+`hsubparser`, which is identical but for an additional `--help` option+on each command), and commands can be added with the `command`+modifier. For example,++```haskell+hsubparser+  ( command "add" (info addCommand ( progDesc "Add a file to the repository" ))+ <> command "commit" (info commitCommand ( progDesc "Record changes to the repository" ))+  )+```++Each command takes a full `ParserInfo` structure, which will be+used to extract a description for this command when generating a+help text.+ Alternatively, you can directly return an `IO` action from a parser, and execute it using `join` from `Control.Monad`. @@ -564,7 +573,7 @@ stop :: IO ()  opts :: Parser (IO ())-opts = subparser+opts = hsubparser   ( command "start" (info (start <$> argument str idm) idm)  <> command "stop"  (info (pure stop) idm) ) @@ -699,6 +708,11 @@  ``` +**Note**. If an option name is a prefix of another option, then it+will never be matched when disambiguation is on. See+[#419](https://github.com/pcapriotti/optparse-applicative/issues/419)+for more details.+ ### Customising the help screen  optparse-applicative has a number of combinators to help customise@@ -708,8 +722,8 @@ specify a brief description or tagline for the program, and detailed information surrounding the generated option and command descriptions. -Internally we actually use the [ansi-wl-pprint][ansi-wl-pprint]-library, and one can use the `headerDoc` combinator and friends if+Internally we actually use the [prettyprinter][prettyprinter]+library, and one can supply either text or prettyprinter `Doc` elements if additional customisation is required.  To display the usage text, the user may type `--help` if the `helper`@@ -735,6 +749,52 @@     p = prefs showHelpOnEmpty ``` +#### Option groups++The `parserOptionGroup` function can be used to group options together under+a common heading. For example, if we have:++```haskell+Args+  <$> parseMain+  <*> parserOptionGroup "Group A" parseA+  <*> parserOptionGroup "Group B" parseB+  <*> parseOther+```++Then the `--help` page `Available options` will look like:++```+Available options:+  <main options>+  <other options>++Group A+  <A options>++Group B+  <B options>+```++Caveats:++- Parser groups are like command groups in that groups are listed in creation+  order, and duplicate groups are consolidated.++- Nested groups are indented:++    ```haskell+    parserOptionGroup "Group Outer" (parserOptionGroup "Group Inner" parseA)+    ```++    Will render as:++    ```+    Group Outer+    - Group Inner+      ...+    ```+ ### Command groups  One experimental feature which may be useful for programs with many@@ -750,11 +810,11 @@ hello = Hello <$> many (argument str (metavar "TARGET..."))  sample :: Parser Sample-sample = subparser+sample = hsubparser        ( command "hello" (info hello (progDesc "Print greeting"))       <> command "goodbye" (info (pure Goodbye) (progDesc "Say goodbye"))        )-      <|> subparser+      <|> hsubparser        ( command "bonjour" (info hello (progDesc "Print greeting"))       <> command "au-revoir" (info (pure Goodbye) (progDesc "Say goodbye"))       <> commandGroup "French commands:"@@ -788,12 +848,13 @@   au-revoir                Say goodbye ``` -## Bash completion+## Bash, Zsh, and Fish Completions -`optparse-applicative` has built-in support for bash completion of-command line options and arguments. Any parser, when run using-`execParser` (and similar functions), is automatically extended-with a few (hidden) options for bash completion:+`optparse-applicative` has built-in support for the completion of+command line options and arguments in bash, zsh, and fish shells.+Any parser, when run using the `execParser` family of functions,+is automatically extended with a few (hidden) options for the+completion system:   - `--bash-completion-script`: this takes the full path of the program as    argument, and prints a bash script, which, when sourced into a bash session,@@ -807,12 +868,20 @@     Normally, the output of `--bash-completion-script` should be shipped with    the program and copied to the appropriate directory (usually-   `/etc/bash_completion.d/`) during installation.+   `/etc/bash_completion.d/`) during installation; + - `--zsh-completion-script`: which is analogous for zsh;++ - `--fish-completion-script`: which is analogous for fish shell;+  - `--bash-completion-index`, `--bash-completion-word`: internal options used    by the completion script to obtain a list of possible completions for a-   given command line.+   given command line; + - `--bash-completion-enriched`: a flag to tell the completion system to emit+   descriptions along with possible completions. This is used to provide help+   along with the completion for `zsh` and `fish`.+ ### Actions and completers  By default, options and commands are always completed. So, for example, if the@@ -830,8 +899,8 @@   - `completeWith`: specifies a list of possible completions to choose from;  - `action`: specifies a completion "action". An action dynamically determines-   a list of possible completions. A full list of actions can be found in the-   [bash documentation];+   a list of possible completions. Common actions are "file" and "directory";+   the full list of actions can be found in the [bash documentation];  - `completer`: a completer is a function `String -> IO [String]`, returning    all possible completions for a given string. You can use this modifier to    specify a custom completion for an argument.@@ -857,7 +926,7 @@  From that we generate a list of possible completions, and print them to standard output. They are then read by the completion script and put into the-`COMPREPLY` variable.+`COMPREPLY` variable (or an appropriate alternative for the other shells).  ## Arrow interface @@ -961,7 +1030,7 @@   ```haskell   import Options.Applicative -  data S3orFile = S3 BucketKey | File FilsePath+  data S3orFile = S3 BucketKey | File FilePath    s3Read, fileRead :: ReadM S3orFile   s3Read = S3 <$> ...@@ -993,6 +1062,14 @@ See [this blog post][blog] for a more detailed explanation based on a simplified implementation. +## Tutorials++These are some tutorials found on the web:++- [A Gentle Introduction to optparse-applicative](https://prborges.com/2023/introduction-to-optparse-applicative/).+- [optparse-applicative quick start](https://ro-che.info/articles/2016-12-30-optparse-applicative-quick-start).+- [Applicative Options Parsing in Haskell](https://thoughtbot.com/blog/applicative-options-parsing-in-haskell).+  [aeson]: http://hackage.haskell.org/package/aeson  [applicative]: http://hackage.haskell.org/package/base/docs/Control-Applicative.html  [arrows]: http://www.haskell.org/arrows/syntax.html@@ -1001,9 +1078,11 @@  [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- [status]: http://travis-ci.org/pcapriotti/optparse-applicative?branch=master- [status-png]: https://api.travis-ci.org/pcapriotti/optparse-applicative.svg?branch=master- [ansi-wl-pprint]: http://hackage.haskell.org/package/ansi-wl-pprint+ [status]: https://github.com/pcapriotti/optparse-applicative/actions/workflows/haskell-ci.yml+ [status-png]: https://github.com/pcapriotti/optparse-applicative/workflows/Haskell-CI/badge.svg+ [prettyprinter]: http://hackage.haskell.org/package/prettyprinter
optparse-applicative.cabal view
@@ -1,15 +1,15 @@ name:                optparse-applicative-version:             0.13.2.0+version:             0.19.0.0 synopsis:            Utilities and combinators for parsing command line options description:     optparse-applicative is a haskell library for parsing options-    on the command line, providing a powerful applicative interface-    for composing these options.+    on the command line, and providing a powerful applicative+    interface for composing them.     .     optparse-applicative takes care of reading and validating the     arguments passed to the command line, handling and reporting     errors, generating a usage line, a comprehensive help screen,-    and enabling context-sensitive bash completions.+    and enabling context-sensitive bash, zsh, and fish completions.     .     See the included README for detailed instructions and examples,     which is also available on github@@ -17,18 +17,13 @@ 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+cabal-version:       >= 1.10 extra-source-files:  CHANGELOG.md                      README.md-                     tests/Examples/Alternatives.hs-                     tests/Examples/Cabal.hs-                     tests/Examples/Commands.hs-                     tests/Examples/Hello.hs-                     tests/Examples/Formatting.hs                      tests/alt.err.txt                      tests/cabal.err.txt                      tests/carry.err.txt@@ -39,63 +34,121 @@                      tests/hello.err.txt                      tests/helponempty.err.txt                      tests/helponemptysub.err.txt+                     tests/long_equals.err.txt                      tests/formatting.err.txt+                     tests/formatting-long-subcommand.err.txt                      tests/nested.err.txt+                     tests/optional.err.txt+                     tests/parser_group_all_grouped.err.txt+                     tests/parser_group_basic.err.txt+                     tests/parser_group_command_groups.err.txt+                     tests/parser_group_duplicate_command_groups.err.txt+                     tests/parser_group_duplicates.err.txt+                     tests/parser_group_nested.err.txt+                     tests/nested_optional.err.txt                      tests/subparsers.err.txt  homepage:            https://github.com/pcapriotti/optparse-applicative bug-reports:         https://github.com/pcapriotti/optparse-applicative/issues+tested-with:+  GHC==9.12.1+  GHC==9.10.1+  GHC==9.8.4+  GHC==9.6.1+  GHC==9.4.4+  GHC==9.2.7+  GHC==9.0.2+  GHC==8.10.7+  GHC==8.8.4+  GHC==8.6.5+  GHC==8.4.4+  GHC==8.2.2+  GHC==8.0.2+  GHC==7.10.3+  GHC==7.8.4+  GHC==7.6.3+  GHC==7.4.2+  GHC==7.2.2+  GHC==7.0.4  source-repository head   type:     git   location: https://github.com/pcapriotti/optparse-applicative.git +flag process+  description:+    Depend on the process package for Bash autocompletion+  default: True+ library-  if impl(ghc >= 8)-    ghc-options:       -Wall -Wno-redundant-constraints-  else-    ghc-options:       -Wall+  hs-source-dirs:      src+  ghc-options:         -Wall+  default-language:    Haskell98 -  exposed-modules:     Options.Applicative,-                       Options.Applicative.Arrows,-                       Options.Applicative.BashCompletion,-                       Options.Applicative.Builder,-                       Options.Applicative.Builder.Completer,-                       Options.Applicative.Builder.Internal,-                       Options.Applicative.Common,-                       Options.Applicative.Extra,-                       Options.Applicative.Help,-                       Options.Applicative.Help.Pretty,-                       Options.Applicative.Help.Chunk,-                       Options.Applicative.Help.Core,-                       Options.Applicative.Help.Types,-                       Options.Applicative.Types,-                       Options.Applicative.Internal+  -- 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+    if impl(ghc < 8.8)+      ghc-options: -Wnoncanonical-monadfail-instances +  exposed-modules:     Options.Applicative+                     , Options.Applicative.Arrows+                     , Options.Applicative.BashCompletion+                     , Options.Applicative.Builder+                     , Options.Applicative.Builder.Completer+                     , Options.Applicative.Builder.Internal+                     , Options.Applicative.Common+                     , Options.Applicative.Extra+                     , Options.Applicative.Help+                     , Options.Applicative.Help.Chunk+                     , Options.Applicative.Help.Core+                     , Options.Applicative.Help.Levenshtein+                     , Options.Applicative.Help.Pretty+                     , Options.Applicative.Help.Types+                     , Options.Applicative.NonEmpty+                     , Options.Applicative.Types+                     , Options.Applicative.Internal -  build-depends:       base                            == 4.*-                     , transformers                    >= 0.2 && < 0.6-                     , transformers-compat             >= 0.3 && < 0.6-                     , process                         >= 1.0 && < 1.7-                     , ansi-wl-pprint                  >= 0.6.6 && < 0.7+  build-depends:       base                            >= 4.5   && < 5+                     , text                            >= 1.2+                     , transformers                    >= 0.5   && < 0.7+                     , prettyprinter                   >= 1.7   && < 1.8+                     , prettyprinter-ansi-terminal     >= 1.1.2 && < 1.2 -  if !impl(ghc >= 8)-    build-depends:     semigroups                      >= 0.10 && < 0.19+  if flag(process)+    build-depends:     process                         >= 1.0   && < 1.7 +  if !impl(ghc >= 8)+    build-depends:     semigroups                      >= 0.10  && < 0.21+                     , fail                            == 4.9.* -test-suite optparse-applicative-tests+test-suite tests   type:                exitcode-stdio-1.0    main-is:             test.hs    ghc-options:         -Wall -threaded -O2 -funbox-strict-fields -  hs-source-dirs:-                       tests+  hs-source-dirs:      tests +  default-language:    Haskell98++  other-modules:       Examples.Alternatives+                     , Examples.Cabal+                     , Examples.Commands+                     , Examples.Formatting+                     , Examples.Hello+                     , Examples.LongSub+                     , Examples.ParserGroup.AllGrouped+                     , Examples.ParserGroup.Basic+                     , Examples.ParserGroup.CommandGroups+                     , Examples.ParserGroup.DuplicateCommandGroups+                     , Examples.ParserGroup.Duplicates+                     , Examples.ParserGroup.Nested+   build-depends:       base                      , optparse-applicative-                     , QuickCheck                      >= 2.8 && < 2.11+                     , QuickCheck                      >= 2.8 && < 2.16    if !impl(ghc >= 8)     build-depends:     semigroups
+ src/Options/Applicative.hs view
@@ -0,0 +1,242 @@+module Options.Applicative (+  -- * Applicative option parsers+  --+  -- | 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 sections below for more detail.++  -- * Exported modules+  --+  -- | The standard @Applicative@ module is re-exported here for convenience.+  module Control.Applicative,++  -- * 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,++  -- ** 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,++  strOption,+  option,++  strArgument,+  argument,++  subparser,+  hsubparser,++  abortOption,+  infoOption,+  helper,+  simpleVersioner,++  -- ** Modifiers+  --+  -- | 'Parser' builders take a modifier, which represents a modification of the+  -- properties of an option, and can be composed as a monoid.+  --+  -- Constraints 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,+  parserOptionGroup,++  OptionFields,+  FlagFields,+  ArgumentFields,+  CommandFields,++  HasName,+  HasCompleter,+  HasValue,+  HasMetavar,++  -- ** 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 t'Data.ByteString.ByteString' and t'Data.Text.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,+  subparserInline,+  columns,+  helpLongEquals,+  helpShowGlobals,+  helpIndent,+  briefHangPoint,+  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+import Control.Applicative++import Options.Applicative.Common+import Options.Applicative.Builder+import Options.Applicative.Builder.Completer+import Options.Applicative.Extra+import Options.Applicative.Types
+ src/Options/Applicative/Arrows.hs view
@@ -0,0 +1,75 @@+-- | This module contains an arrow interface for option parsers, which allows+-- to define and combine parsers using the arrow notation and arrow+-- combinators.+--+-- The arrow syntax is particularly useful to create parsers of nested+-- structures, or records where the order of fields is different from the order+-- in which the parsers should be applied.+--+-- For example, an 'Options.Applicative.Builder.arguments` parser often needs+-- to be applied last, and that makes it inconvenient to use it for a field+-- which is not the last one in a record.+--+-- Using the arrow syntax and the functions in this module, one can write, e.g.:+--+-- > data Options = Options+-- >   { optArgs :: [String]+-- >   , optVerbose :: Bool }+-- >+-- > opts :: Parser Options+-- > opts = runA $ proc () -> do+-- >   verbose <- asA (switch (short 'v')) -< ()+-- >   args <- asA (arguments str idm) -< ()+-- >   returnA -< Options args verbose+--+-- Parser arrows, created out of regular 'Parser' values using the 'asA'+-- function, are arrows taking @()@ as argument and returning the parsed value.+module Options.Applicative.Arrows (+  module Control.Arrow,+  A(..),+  asA,+  runA,+  ParserA,+  ) where++import Control.Arrow+import Control.Category (Category(..))++import Options.Applicative++import Prelude hiding ((.), id)++-- | For any 'Applicative' functor @f@, @A f@ is the 'Arrow' instance+-- associated to @f@.+--+-- The 'A' constructor can be used to convert a value of type @f (a -> b)@ into+-- an arrow.+newtype A f a b = A+  { unA :: f (a -> b) }++-- | Convert a value of type @f a@ into an arrow taking @()@ as argument.+--+-- Applied to a value of type 'Parser', it turns it into an arrow that can be+-- used inside an arrow command, or passed to arrow combinators.+asA :: Applicative f => f a -> A f () a+asA x = A $ const <$> x++-- | Convert an arrow back to an applicative value.+--+-- This function can be used to return a result of type 'Parser' from an arrow+-- command.+runA :: Applicative f => A f () a -> f a+runA a = unA a <*> pure ()++instance Applicative f => Category (A f) where+  id = A $ pure id+  -- use reverse composition, because we want effects to run from+  -- top to bottom in the arrow syntax+  (A f) . (A g) = A $ flip (.) <$> g <*> f++instance Applicative f => Arrow (A f) where+  arr = A . pure+  first (A f) = A $ first <$> f++-- | The type of arrows associated to the applicative 'Parser' functor.+type ParserA = A Parser
+ src/Options/Applicative/BashCompletion.hs view
@@ -0,0 +1,264 @@+-- | You don't need to import this module to enable bash completion.+--+-- See+-- <http://github.com/pcapriotti/optparse-applicative/wiki/Bash-Completion the wiki>+-- for more information on bash completion.+module Options.Applicative.BashCompletion+  ( bashCompletionParser,++    bashCompletionScript,+    fishCompletionScript,+    zshCompletionScript,+  ) where++import Control.Applicative+import Prelude+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+    returnCompletions opts =+      CompletionResult $+        \progn -> unlines <$> opts progn++    scriptRequest =+      CompletionResult . fmap pure++    complParser = asum+      [ returnCompletions <$>+        (  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) )++      , scriptRequest . bashCompletionScript <$>+            strOption (long "bash-completion-script" `mappend` internal)+      , scriptRequest . fishCompletionScript <$>+            strOption (long "fish-completion-script" `mappend` internal)+      , scriptRequest . zshCompletionScript <$>+            strOption (long "zsh-completion-script" `mappend` internal)+      ]++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+    compl = runParserInfo pinfo (drop 1 ws')++    list_options a+      = fmap concat+      . sequence+      . mapParser (opt_completions a)++    --+    -- 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 reachability 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+         | argumentIsUnreachable reachability+        -> return []+         | otherwise+        -> run_completer (crCompleter rdr)+      CmdReader _ ns+         | argumentIsUnreachable reachability+        -> return []+         | otherwise+        -> return . with_cmd_help $ filter (is_completion . fst) ns++    -- 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).+    with_cmd_help :: Functor f => f (String, ParserInfo a) -> f String+    with_cmd_help =+      case richness of+        Standard ->+          fmap fst+        Enriched _ len ->+          fmap $ \(cmd, cmdInfo) ->+            let h = unChunk (infoProgDesc cmdInfo)+            in  maybe cmd (\h' -> cmd ++ "\t" ++ render_line len h') h++    show_names :: [OptName] -> [String]+    show_names = filter is_completion . 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 (prettyString 1 len doc) of+      [] -> ""+      [x] -> x+      x : _ -> x ++ "..."++    run_completer :: Completer -> IO [String]+    run_completer c = runCompleter c (fromMaybe "" (listToMaybe ws''))++    (ws', ws'') = splitAt i ws++    is_completion :: String -> Bool+    is_completion =+      case ws'' of+        w:_ -> isPrefixOf w+        _ -> const True++-- | Generated bash shell completion script+bashCompletionScript :: String -> String -> String+bashCompletionScript prog progn = unlines+  [ "_" ++ progn ++ "()"+  , "{"+  , "    local CMDLINE"+  , "    local IFS=$'\\n'"+  , "    CMDLINE=(--bash-completion-index $COMP_CWORD)"+  , ""+  , "    for arg in ${COMP_WORDS[@]}; do"+  , "        CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)"+  , "    done"+  , ""+  , "    COMPREPLY=( $(" ++ prog ++ " \"${CMDLINE[@]}\") )"+  , "}"+  , ""+  , "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.+-}++-- | Generated fish shell completion script +fishCompletionScript :: String -> String -> String+fishCompletionScript prog progn = unlines+  [ " 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 ++  ")'"+  ]++-- | Generated zsh shell completion script+zshCompletionScript :: String -> String -> String+zshCompletionScript prog progn = unlines+  [ "#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"+  ]
+ src/Options/Applicative/Builder.hs view
@@ -0,0 +1,615 @@+{-# LANGUAGE CPP #-}+module Options.Applicative.Builder (+  -- * Parser builders+  --+  -- | This module 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 this module 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\".+  subparser,+  strArgument,+  argument,+  flag,+  flag',+  switch,+  abortOption,+  infoOption,+  strOption,+  option,++  -- * Modifiers+  short,+  long,+  help,+  helpDoc,+  value,+  showDefaultWith,+  showDefault,+  metavar,+  noArgError,+  ParseError(..),+  hidden,+  internal,+  style,+  command,+  commandGroup,+  completeWith,+  action,+  completer,+  idm,+  mappend,+  parserOptionGroup,++  -- * Readers+  --+  -- | A collection of basic 'Option' readers.+  auto,+  str,+  maybeReader,+  eitherReader,+  disabled,+  readerAbort,+  readerError,++  -- * Builder for 'ParserInfo'+  InfoMod,+  fullDesc,+  briefDesc,+  header,+  headerDoc,+  footer,+  footerDoc,+  progDesc,+  progDescDoc,+  failureCode,+  noIntersperse,+  forwardOptions,+  allPositional,+  info,++  -- * Builder for 'ParserPrefs'+  PrefsMod,+  multiSuffix,+  disambiguate,+  showHelpOnError,+  showHelpOnEmpty,+  noBacktrack,+  subparserInline,+  columns,+  helpLongEquals,+  helpShowGlobals,+  helpIndent,+  briefHangPoint,+  prefs,+  defaultPrefs,++  -- * Types+  Mod,+  ReadM,+  OptionFields,+  FlagFields,+  ArgumentFields,+  CommandFields,++  HasName,+  HasCompleter,+  HasValue,+  HasMetavar+  ) where++import Control.Applicative+#if __GLASGOW_HASKELL__ < 804+import Data.Semigroup hiding (Option, option)+#endif+import Data.String (fromString, IsString)++import Options.Applicative.Builder.Completer+import Options.Applicative.Builder.Internal+import Options.Applicative.Common+import Options.Applicative.Types+import Options.Applicative.Help.Pretty+import Options.Applicative.Help.Chunk+import Options.Applicative.Internal (mapParserOptions)++-- Readers --++-- | 'Option' reader based on the 'Read' type class.+auto :: Read a => ReadM a+auto = eitherReader $ \arg -> case reads arg of+  [(r, "")] -> return r+  _         -> Left $ "cannot parse value `" ++ arg ++ "'"++-- | String 'Option' reader.+--+--   Polymorphic over the `IsString` type class since 0.14.+str :: IsString s => ReadM s+str = fromString <$> readerAsk++-- | 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 producing a 'Maybe' into a reader.+maybeReader :: (String -> Maybe a) -> ReadM a+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+disabled = readerError "disabled option"++-- modifiers --++-- | Specify a short name for an option.+short :: HasName f => Char -> Mod f a+short = fieldMod . name . OptShort++-- | Specify a long name for an option.+long :: HasName f => String -> Mod f a+long = fieldMod . name . OptLong++-- | Specify a default value for an option.+--+-- /Note/: Because this modifier means the parser will never fail,+-- do not use it with combinators such as 'some' or 'many', as+-- these combinators continue until a failure occurs.+-- Careless use will thus result in a hang.+--+-- To display the default value, combine with showDefault or+-- showDefaultWith.+value :: HasValue f => a -> Mod f a+value x = Mod id (DefaultProp (Just x) Nothing) id++-- | Specify a function to show the default value for an option.+showDefaultWith :: (a -> String) -> Mod f a+showDefaultWith s = Mod id (DefaultProp Nothing (Just s)) id++-- | Show the default value for this option using its 'Show' instance.+showDefault :: Show a => Mod f a+showDefault = showDefaultWith show++-- | Specify the help text for an option.+help :: String -> Mod f a+help s = optionMod $ \p -> p { propHelp = paragraph s }++-- | Specify the help text for an option as a 'Prettyprinter.Doc AnsiStyle'+-- value.+helpDoc :: Maybe Doc -> Mod f a+helpDoc doc = optionMod $ \p -> p { propHelp = Chunk doc }++-- | Specify the error to display when no argument is provided to this option.+noArgError :: ParseError -> Mod OptionFields a+noArgError e = fieldMod $ \p -> p { optNoArgError = const e }++-- | Specify a metavariable for the argument.+--+-- Metavariables have no effect on the actual parser, and only serve to specify+-- the symbolic name for an argument to be displayed in the help text.+metavar :: HasMetavar f => String -> Mod f a+metavar var = optionMod $ \p -> p { propMetaVar = var }++-- | Hide this option from the brief description.+--+-- Use 'internal' to hide the option from the help text too.+hidden :: Mod f a+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 (annotate bold))+--+-- /NOTE/: This builder is more flexible than its name and example+-- allude. One of the motivating examples for its addition was to+-- use `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 = 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 = completer . bashCompleter++-- | Add a completer to an argument.+--+-- A completer is a function String -> IO String which, given a partial+-- argument, returns all possible completions for that argument.+completer :: HasCompleter f => Completer -> Mod f a+completer f = fieldMod $ modCompleter (`mappend` f)++-- parsers --++-- | Builder for a command parser. The 'command' modifier can be used to+-- specify individual commands.+--+-- By default, sub-parsers allow backtracking to their parent's options when+-- they are completed. To allow full mixing of parent and sub-parser options,+-- turn on 'subparserInline'; otherwise, to disable backtracking completely,+-- use 'noBacktrack'.+subparser :: Mod CommandFields a -> Parser a+subparser m = mkParser d g rdr+  where+    Mod _ d g = metavar "COMMAND" `mappend` m+    (groupName, cmds) = mkCommand m+    rdr = CmdReader groupName cmds++-- | Builder for an argument parser.+argument :: ReadM a -> Mod ArgumentFields a -> Parser a+argument p m = mkParser d g (ArgReader rdr)+  where+    (Mod f d g) = noGlobal `mappend` m+    ArgumentFields compl = f (ArgumentFields mempty)+    rdr = CReader compl p++-- | Builder for a 'String' argument.+strArgument :: IsString s => Mod ArgumentFields s -> Parser s+strArgument = argument str++-- | Builder for a flag parser.+--+-- A flag that switches from a \"default value\" to an \"active value\" when+-- encountered. For a simple boolean value, use `switch` instead.+--+-- /Note/: Because this parser will never fail, it can not be used with+-- combinators such as 'some' or 'many', as these combinators continue until+-- a failure occurs. See @flag'@.+flag :: a                         -- ^ default value+     -> a                         -- ^ active value+     -> Mod FlagFields a          -- ^ option modifier+     -> Parser a+flag defv actv m = flag' actv m <|> pure defv++-- | Builder for a flag parser without a default value.+--+-- Same as 'flag', but with no default value. In particular, this flag will+-- never parse successfully by itself.+--+-- It still makes sense to use it as part of a composite parser. For example+--+-- > length <$> many (flag' () (short 't'))+--+-- is a parser that counts the number of "-t" arguments on the command line,+-- alternatively+--+-- > flag' True (long "on") <|> flag' False (long "off")+--+-- will require the user to enter '--on' or '--off' on the command line.+flag' :: a                         -- ^ active value+      -> Mod FlagFields a          -- ^ option modifier+      -> Parser a+flag' actv (Mod f d g) = mkParser d g rdr+  where+    rdr = let fields = f (FlagFields [] actv)+          in FlagReader (flagNames fields)+                        (flagActive fields)++-- | Builder for a boolean flag.+--+-- /Note/: Because this parser will never fail, it can not be used with+-- combinators such as 'some' or 'many', as these combinators continue until+-- a failure occurs. See @flag'@.+--+-- > switch = flag False True+switch :: Mod FlagFields Bool -> Parser Bool+switch = flag False True++-- | An option that always fails.+--+-- When this option is encountered, the option parser immediately aborts with+-- the given parse error.  If you simply want to output a message, use+-- 'infoOption' instead.+abortOption :: ParseError -> Mod OptionFields (a -> a) -> Parser (a -> a)+abortOption err m = option (readerAbort err) . (`mappend` m) $ mconcat+  [ noArgError err+  , value id+  , metavar "" ]++-- | An option that always fails and displays a message.+infoOption :: String -> Mod OptionFields (a -> a) -> Parser (a -> a)+infoOption = abortOption . InfoMsg++-- | Builder for an option taking a 'String' argument.+strOption :: IsString s => Mod OptionFields s -> Parser s+strOption = option str++-- | Builder for an option using the given reader.+--+-- This is a regular option, and should always have either a @long@ or+-- @short@ name specified in the modifiers (or both).+--+-- > nameParser = option str ( long "name" <> short 'n' )+--+option :: ReadM a -> Mod OptionFields a -> Parser a+option r m = mkParser d g rdr+  where+    Mod f d g = metavar "ARG" `mappend` m+    fields = f (OptionFields [] mempty ExpectsArgError)+    crdr = CReader (optCompleter fields) r+    rdr = OptReader (optNames fields) crdr (optNoArgError fields)++-- | Prepends a group to 'OptProperties'. Nested groups are indented e.g.+--+-- @+--   optPropertiesGroup "Group Outer" (optPropertiesGroup "Group Inner" o)+-- @+--+-- will render as:+--+-- @+--  Group Outer+--  - Group Inner+--    ...+-- @+optPropertiesGroup :: String -> OptProperties -> OptProperties+optPropertiesGroup g o = o { propGroup = OptGroup (g : oldGroup) }+  where+    OptGroup oldGroup = propGroup o++-- | Prepends a group per 'optPropertiesGroup'.+optionGroup :: String -> Option a -> Option a+optionGroup grp o = o { optProps = props' }+  where+    props' = optPropertiesGroup grp (optProps o)++-- | Group options together under a common heading in the help text.+--+-- For example, if we have:+--+-- > Args+-- >   <$> parseMain+-- >   <*> parserOptionGroup "Group A" parseA+-- >   <*> parserOptionGroup "Group B" parseB+-- >   <*> parseOther+--+-- Then the help page will look like:+--+-- > Available options:+-- >   <main options>+-- >   <other options>+-- >+-- > Group A+-- >   <A options>+-- >+-- > Group B+-- >   <B options>+--+-- @since 0.19.0.0+parserOptionGroup :: String -> Parser a -> Parser a+parserOptionGroup g = mapParserOptions (optionGroup g)++-- | Modifier for 'ParserInfo'.+newtype InfoMod a = InfoMod+  { applyInfoMod :: ParserInfo a -> ParserInfo a }++instance Monoid (InfoMod a) where+  mempty = InfoMod id+  mappend = (<>)++instance Semigroup (InfoMod a) where+  m1 <> m2 = InfoMod $ applyInfoMod m2 . applyInfoMod m1++-- | Show a full description in the help text of this parser (default).+fullDesc :: InfoMod a+fullDesc = InfoMod $ \i -> i { infoFullDesc = True }++-- | Only show a brief description in the help text of this parser.+briefDesc :: InfoMod a+briefDesc = InfoMod $ \i -> i { infoFullDesc = False }++-- | Specify a header for this parser.+header :: String -> InfoMod a+header s = InfoMod $ \i -> i { infoHeader = paragraph s }++-- | Specify a header for this parser as a 'Prettyprinter.Doc AnsiStyle'+-- value.+headerDoc :: Maybe Doc -> InfoMod a+headerDoc doc = InfoMod $ \i -> i { infoHeader = Chunk doc }++-- | Specify a footer for this parser.+footer :: String -> InfoMod a+footer s = InfoMod $ \i -> i { infoFooter = paragraph s }++-- | Specify a footer for this parser as a 'Prettyprinter.Doc AnsiStyle'+-- value.+footerDoc :: Maybe Doc -> InfoMod a+footerDoc doc = InfoMod $ \i -> i { infoFooter = Chunk doc }++-- | Specify a short program description.+progDesc :: String -> InfoMod a+progDesc s = InfoMod $ \i -> i { infoProgDesc = paragraph s }++-- | Specify a short program description as a 'Prettyprinter.Doc AnsiStyle'+-- value.+progDescDoc :: Maybe Doc -> InfoMod a+progDescDoc doc = InfoMod $ \i -> i { infoProgDesc = Chunk doc }++-- | Specify an exit code if a parse error occurs.+failureCode :: Int -> InfoMod a+failureCode n = InfoMod $ \i -> i { infoFailureCode = n }++-- | 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 { 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 }++-- | Disable parsing of regular options completely. All options and arguments+--   will be treated as a positional arguments. Obviously not recommended in+--   general as options will be unreachable.+--   This is the same behaviour one sees after the "--" pseudo-argument.+allPositional :: InfoMod a+allPositional = InfoMod $ \p -> p { infoPolicy = AllPositionals }+++-- | Create a 'ParserInfo' given a 'Parser' and a modifier.+info :: Parser a -> InfoMod a -> ParserInfo a+info parser m = applyInfoMod m base+  where+    base = ParserInfo+      { infoParser = parser+      , infoFullDesc = True+      , infoProgDesc = mempty+      , infoHeader = mempty+      , infoFooter = mempty+      , infoFailureCode = 1+      , infoPolicy = Intersperse }++newtype PrefsMod = PrefsMod+  { applyPrefsMod :: ParserPrefs -> ParserPrefs }++instance Monoid PrefsMod where+  mempty = PrefsMod id+  mappend = (<>)++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 = NoBacktrack }++-- | Allow full mixing of subcommand and parent arguments by inlining+-- selected subparsers into the parent parser.+--+-- /NOTE:/ When this option is used, preferences for the subparser which+-- effect the parser behaviour (such as noIntersperse) are ignored.+subparserInline :: PrefsMod+subparserInline = PrefsMod $ \p -> p { prefBacktrack = SubparserInline }++-- | Set the maximum width of the generated help text.+columns :: Int -> PrefsMod+columns cols = PrefsMod $ \p -> p { prefColumns = cols }++-- | Show equals sign, rather than space, in usage and help text for options with+-- long names.+helpLongEquals :: PrefsMod+helpLongEquals = PrefsMod $ \p -> p { prefHelpLongEquals = True }++-- | Show global help information in subparser usage.+helpShowGlobals :: PrefsMod+helpShowGlobals = PrefsMod $ \p -> p { prefHelpShowGlobal = True }++-- | Set fill width in help text presentation.+helpIndent :: Int -> PrefsMod+helpIndent w = PrefsMod $ \p -> p { prefTabulateFill = w }++-- | Set the width at which to hang the brief help text.+briefHangPoint :: Int -> PrefsMod+briefHangPoint php = PrefsMod $ \p -> p { prefBriefHangPoint = php }+++-- | Create a `ParserPrefs` given a modifier+prefs :: PrefsMod -> ParserPrefs+prefs m = applyPrefsMod m base+  where+    base = ParserPrefs+      { prefMultiSuffix = ""+      , prefDisambiguate = False+      , prefShowHelpOnError = False+      , prefShowHelpOnEmpty = False+      , prefBacktrack = Backtrack+      , prefColumns = 80+      , prefHelpLongEquals = False+      , prefHelpShowGlobal = False+      , prefTabulateFill = 24+      , prefBriefHangPoint = 35 }++-- Convenience shortcuts++-- | Trivial option modifier.+idm :: Monoid m => m+idm = mempty++-- | Default preferences.+defaultPrefs :: ParserPrefs+defaultPrefs = prefs idm
+ src/Options/Applicative/Builder/Completer.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP #-}++module Options.Applicative.Builder.Completer+  ( Completer+  , mkCompleter+  , listIOCompleter+  , listCompleter+  , bashCompleter++  , requote+  ) where++import Control.Applicative+import Prelude+import Control.Exception (IOException, try)+import Data.List (isPrefixOf)+#ifdef MIN_VERSION_process+import System.Process (readProcess)+#endif++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+#ifdef MIN_VERSION_process+bashCompleter action = Completer $ \word -> do+  let cmd = unwords ["compgen", "-A", action, "--", requote word]+  result <- tryIO $ readProcess "bash" ["-c", cmd] ""+  return . lines . either (const []) id $ result+#else+bashCompleter = const $ Completer $ const $ return []+#endif++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 []+          = []
+ src/Options/Applicative/Builder/Internal.hs view
@@ -0,0 +1,197 @@+module Options.Applicative.Builder.Internal (+  -- * Internals+  Mod(..),+  HasName(..),+  HasCompleter(..),+  HasValue(..),+  HasMetavar(..),+  OptionFields(..),+  FlagFields(..),+  CommandFields(..),+  ArgumentFields(..),+  DefaultProp(..),++  optionMod,+  fieldMod,++  baseProps,+  mkCommand,+  mkParser,+  mkOption,+  mkProps,++  internal,+  noGlobal+  ) where++import Control.Applicative+import Control.Monad (mplus)+import Data.Semigroup hiding (Option)+import Prelude++import Options.Applicative.Common+import Options.Applicative.Types++data OptionFields a = OptionFields+  { optNames :: [OptName]+  , optCompleter :: Completer+  , optNoArgError :: String -> ParseError }++data FlagFields a = FlagFields+  { flagNames :: [OptName]+  , flagActive :: a }++data CommandFields a = CommandFields+  { cmdCommands :: [(String, ParserInfo a)]+  , cmdGroup :: Maybe String }++data ArgumentFields a = ArgumentFields+  { argCompleter :: Completer }++class HasName f where+  name :: OptName -> f a -> f a++instance HasName OptionFields where+  name n fields = fields { optNames = n : optNames fields }++instance HasName FlagFields where+  name n fields = fields { flagNames = n : flagNames fields }++class HasCompleter f where+  modCompleter :: (Completer -> Completer) -> f a -> f a++instance HasCompleter OptionFields where+  modCompleter f p = p { optCompleter = f (optCompleter p) }++instance HasCompleter ArgumentFields where+  modCompleter f p = p { argCompleter = f (argCompleter p) }++class HasValue f where+  -- this is just so that it is not necessary to specify the kind of f+  hasValueDummy :: f a -> ()+instance HasValue OptionFields where+  hasValueDummy _ = ()+instance HasValue ArgumentFields where+  hasValueDummy _ = ()++class HasMetavar f where+  hasMetavarDummy :: f a -> ()+instance HasMetavar OptionFields where+  hasMetavarDummy _ = ()+instance HasMetavar ArgumentFields where+  hasMetavarDummy _ = ()+instance HasMetavar CommandFields where+  hasMetavarDummy _ = ()++-- mod --++data DefaultProp a = DefaultProp+  (Maybe a)+  (Maybe (a -> String))++instance Monoid (DefaultProp a) where+  mempty = DefaultProp Nothing Nothing+  mappend = (<>)++instance Semigroup (DefaultProp a) where+  (DefaultProp d1 s1) <> (DefaultProp d2 s2) =+    DefaultProp (d1 `mplus` d2) (s1 `mplus` s2)++-- | An option modifier.+--+-- Option modifiers are values that represent a modification of the properties+-- of an option.+--+-- The type parameter @a@ is the return type of the option, while @f@ is a+-- record containing its properties (e.g. 'OptionFields' for regular options,+-- 'FlagFields' for flags, etc...).+--+-- An option modifier consists of 3 elements:+--+--  - A field modifier, of the form @f a -> f a@. These are essentially+--  (compositions of) setters for some of the properties supported by @f@.+--+--  - An optional default value and function to display it.+--+--  - A property modifier, of the form @OptProperties -> OptProperties@. This+--  is just like the field modifier, but for properties applicable to any+--  option.+--+-- Modifiers are instances of 'Monoid', and can be composed as such.+--+-- One rarely needs to deal with modifiers directly, as most of the times it is+-- sufficient to pass them to builders (such as 'Options.Applicative.strOption'+-- or 'Options.Applicative.flag') to+-- create options (see 'Options.Applicative.Builder').+data Mod f a = Mod (f a -> f a)+                   (DefaultProp a)+                   (OptProperties -> OptProperties)++optionMod :: (OptProperties -> OptProperties) -> Mod f a+optionMod = Mod id mempty++fieldMod :: (f a -> f a) -> Mod f a+fieldMod f = Mod f mempty id++instance Monoid (Mod f a) where+  mempty = Mod id mempty id+  mappend = (<>)++-- | @since 0.13.0.0+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+  { propMetaVar = ""+  , propVisibility = Visible+  , propHelp = mempty+  , propShowDefault = Nothing+  , propDescMod = Nothing+  , propShowGlobal = True+  , propGroup = OptGroup []+  }++mkCommand :: Mod CommandFields a -> (Maybe String, [(String, ParserInfo a)])+mkCommand m = (group, cmds)+  where+    Mod f _ _ = m+    CommandFields cmds group = f (CommandFields [] Nothing)++mkParser :: DefaultProp a+         -> (OptProperties -> OptProperties)+         -> OptReader a+         -> Parser a+mkParser d@(DefaultProp def _) g rdr =+  let+    o = liftOpt $ mkOption d g rdr+  in+    maybe o (\a -> o <|> pure a) def++mkOption :: DefaultProp a+         -> (OptProperties -> OptProperties)+         -> OptReader a+         -> Option a+mkOption d g rdr = Option rdr (mkProps d g)++mkProps :: DefaultProp a+        -> (OptProperties -> OptProperties)+        -> OptProperties+mkProps (DefaultProp def sdef) g = props+  where+    props = (g baseProps)+      { propShowDefault = sdef <*> def }++-- | Hide this option completely from the help text+--+-- Use 'Options.Applicative.hidden' if the option should remain visible in the+-- full description.+internal :: Mod f a+internal = optionMod $ \p -> p { propVisibility = Internal }+++-- | Suppress this option from appearing in global options+noGlobal :: Mod f a+noGlobal = optionMod $ \pp -> pp { propShowGlobal = False }
+ src/Options/Applicative/Common.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE Rank2Types #-}+module Options.Applicative.Common (+  -- * Option parsers+  --+  -- | A 'Parser' is composed of a list of options. Several kinds of options+  -- are supported:+  --+  --  * 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.+  --+  Parser,+  liftOpt,+  showOption,++  -- * Program descriptions+  --+  -- 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 basic 'ParserInfo' with default values for fields can be created using+  -- the 'info' function.+  --+  -- A 'ParserPrefs' contains general preferences for all command-line+  -- options, and can be built with the 'prefs' function.+  ParserInfo(..),+  ParserPrefs(..),++  -- * Running parsers+  runParserInfo,+  runParserFully,+  runParserStep,+  runParser,+  evalParser,++  -- * Low-level utilities+  mapParser,+  treeMapParser,+  optionNames+  ) where++import Control.Applicative+import Control.Monad (guard, mzero, msum, when)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State (StateT(..), get, put, runStateT)+import Data.List (isPrefixOf)+import Data.Maybe (maybeToList, isJust, isNothing)+import Prelude++import Options.Applicative.Internal+import Options.Applicative.Types++showOption :: OptName -> String+showOption (OptLong n) = "--" ++ n+showOption (OptShort n) = '-' : [n]++optionNames :: OptReader a -> [OptName]+optionNames (OptReader names _ _) = names+optionNames (FlagReader names _) = names+optionNames _ = []++isOptionPrefix :: OptName -> OptName -> Bool+isOptionPrefix (OptShort x) (OptShort y) = x == y+isOptionPrefix (OptLong x) (OptLong y) = x `isPrefixOf` y+isOptionPrefix _ _ = False++-- | Create a parser composed of a single option.+liftOpt :: Option a -> Parser a+liftOpt = OptP++optMatches :: MonadP m => Bool -> OptReader a -> OptWord -> Maybe (StateT Args m a)+optMatches disambiguate opt (OptWord arg1 val) = case opt of+  OptReader names rdr no_arg_err -> do+    guard $ has_name arg1 names+    Just $ do+      args <- get+      let mb_args = uncons $ maybeToList val ++ args+      let missing_arg = missingArgP (no_arg_err $ showOption arg1) (crCompleter rdr)+      (arg', args') <- maybe (lift missing_arg) return mb_args+      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 $ isShortName arg1 || isNothing val+    Just $ do+      args <- get+      let val' = ('-' :) <$> val+      put $ maybeToList val' ++ args+      return x+  _ -> Nothing+  where+    errorFor name msg = "option " ++ showOption name ++ ": " ++ msg++    has_name a+      | disambiguate = any (isOptionPrefix a)+      | otherwise = elem a++isArg :: OptReader a -> Bool+isArg (ArgReader _) = True+isArg _ = False++data OptWord = OptWord OptName (Maybe String)++parseWord :: String -> Maybe OptWord+parseWord ('-' : '-' : w) = Just $ let+  (opt, arg) = case span (/= '=') w of+    (_, "") -> (w, Nothing)+    (w', _ : rest) -> (w', Just rest)+  in OptWord (OptLong opt) arg+parseWord ('-' : w) = case w of+  [] -> Nothing+  (a : rest) -> Just $ let+    arg = rest <$ guard (not (null rest))+    in OptWord (OptShort a) arg+parseWord _ = Nothing++searchParser :: Monad m+             => (forall r . Option r -> NondetT m (Parser r))+             -> Parser a -> NondetT m (Parser a)+searchParser _ (NilP _) = mzero+searchParser f (OptP opt) = f opt+searchParser f (MultP p1 p2) = foldr1 (<!>)+  [ do p1' <- searchParser f p1+       return (p1' <*> p2)+  , do p2' <- searchParser f p2+       return (p1 <*> p2') ]+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 $ \opt -> do+  let disambiguate = prefDisambiguate pprefs+                  && optVisibility opt > Internal+  case optMatches disambiguate (optMain opt) w of+    Just matcher -> lift $ fmap pure matcher+    Nothing -> mzero++searchArg :: MonadP m => ParserPrefs -> String -> Parser a+          -> NondetT (StateT Args m) (Parser a)+searchArg prefs arg =+  searchParser $ \opt -> do+    when (isArg (optMain opt)) cut+    case optMain opt of+      CmdReader _ cs -> do+        subp <- hoistList (cmdMatches cs)+        case prefBacktrack prefs of+          NoBacktrack -> lift $ do+            args <- get <* put []+            fmap pure . lift $ enterContext arg subp *> runParserInfo subp args <* exitContext++          Backtrack -> fmap pure . lift . StateT $ \args ->+            enterContext arg subp *> runParser (infoPolicy subp) CmdStart (infoParser subp) args <* exitContext++          SubparserInline -> lift $ do+            lift $ enterContext arg subp+            return $ infoParser subp++      ArgReader rdr ->+        fmap pure . lift . lift $ runReadM (crReader rdr) arg++      _ ->+        mzero++  where+    cmdMatches cs+      | prefDisambiguate prefs = snd <$> filter (isPrefixOf arg . fst) cs+      | otherwise = maybeToList (lookup arg cs)++stepParser :: MonadP m => ParserPrefs -> ArgPolicy -> String+           -> Parser a -> NondetT (StateT Args m) (Parser a)+stepParser pprefs AllPositionals arg p =+  searchArg pprefs arg p+stepParser pprefs ForwardOptions arg p = case parseWord arg of+  Just w -> searchOpt pprefs w p <|> searchArg pprefs arg p+  Nothing -> searchArg pprefs arg p+stepParser pprefs _ arg p = case parseWord arg of+  Just w -> searchOpt pprefs w p+  Nothing -> searchArg pprefs 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 policy _ p ("--" : argt) | policy /= AllPositionals+                                   = runParser AllPositionals CmdCont p argt+runParser policy isCmdStart p args = case args of+  [] -> exitP isCmdStart policy p result+  (arg : argt) -> do+    (mp', args') <- do_step arg argt+    case mp' of+      Nothing -> hoistMaybe result <|> parseError arg p+      Just p' -> runParser (newPolicy arg) CmdCont p' args'+  where+    result =+      (,) <$> evalParser p <*> pure args+    do_step =+      runParserStep policy p++    newPolicy a = case policy of+      NoIntersperse -> if isJust (parseWord a) then NoIntersperse else AllPositionals+      x             -> x++runParserStep :: MonadP m => ArgPolicy -> Parser a -> String -> Args -> m (Maybe (Parser a), Args)+runParserStep policy p arg args = do+  prefs <- getPrefs+  flip runStateT args+    $ disamb (not (prefDisambiguate prefs))+    $ stepParser prefs policy arg p++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 (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 (pure ())++-- | The default value of a 'Parser'.  This function returns an error if any of+-- the options don't have a default value.+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.+mapParser :: (forall x. ArgumentReachability -> Option x -> b)+          -> Parser a -> [b]+mapParser f = flatten . treeMapParser f+  where+    flatten (Leaf x) = [x]+    flatten (MultNode xs) = xs >>= flatten+    flatten (AltNode _ xs) = xs >>= flatten+    flatten (BindNode x) = flatten x++-- | Like 'mapParser', but collect the results in a tree structure.+treeMapParser :: (forall x. ArgumentReachability -> Option x -> b)+              -> Parser a+              -> OptTree b+treeMapParser g = simplify . go False g+  where+    has_default :: Parser a -> Bool+    has_default p = isJust (evalParser p)++    go :: Bool+       -> (forall x. ArgumentReachability -> Option x -> b)+       -> Parser a+       -> OptTree b+    go _ _ (NilP _) = MultNode []+    go r f (OptP opt)+      | optVisibility opt > Internal+      = Leaf (f (ArgumentReachability r) opt)+      | otherwise+      = MultNode []+    go r f (MultP p1 p2) =+      MultNode [go r f p1, go r' f p2]+      where r' = r || hasArg p1+    go r f (AltP p1 p2) =+      AltNode altNodeType [go r f p1, go r f p2]+      where+        -- The 'AltNode' indicates if one of the branches has a default.+        -- This is used for rendering brackets, as well as filtering+        -- out optional arguments when generating the "missing:" text.+        altNodeType =+          if has_default p1 || has_default p2+            then MarkDefault+            else NoDefault++    go r f (BindP p k) =+      let go' = go r f p+      in case evalParser p of+        Nothing -> BindNode go'+        Just aa -> BindNode (MultNode [ go', go r f (k aa) ])++    hasArg :: Parser a -> Bool+    hasArg (NilP _) = False+    hasArg (OptP p) = (isArg . optMain) p+    hasArg (MultP p1 p2) = hasArg p1 || hasArg p2+    hasArg (AltP p1 p2) = hasArg p1 || hasArg p2+    hasArg (BindP p _) = hasArg p++simplify :: OptTree a -> OptTree a+simplify (Leaf x) = Leaf x+simplify (MultNode xs) =+  case concatMap (remove_mult . simplify) xs of+    [x] -> x+    xs' -> MultNode xs'+  where+    remove_mult (MultNode ts) = ts+    remove_mult t = [t]+simplify (AltNode b xs) =+  AltNode b (concatMap (remove_alt . simplify) xs)+  where+    remove_alt (AltNode _ ts) = ts+    remove_alt (MultNode []) = []+    remove_alt t = [t]+simplify (BindNode x) =+  BindNode $ simplify x
+ src/Options/Applicative/Extra.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE RankNTypes #-}+module Options.Applicative.Extra (+  -- * Extra parser utilities+  --+  -- | This module contains high-level functions to run parsers.+  helper,+  helperWith,+  hsubparser,+  simpleVersioner,+  execParser,+  customExecParser,+  execParserPure,+  getParseResult,+  handleParseResult,+  parserFailure,+  renderFailure,+  ParserFailure(..),+  overFailure,+  ParserResult(..),+  ParserPrefs(..),+  CompletionResult(..),+  ) where++import Control.Applicative+import Control.Monad (void)+import Data.Monoid+import Data.Foldable (traverse_)+import Prelude+import System.Environment (getArgs, getProgName)+import System.Exit (exitSuccess, exitWith, ExitCode(..))+import System.IO (hPutStrLn, stderr)++import Options.Applicative.BashCompletion+import Options.Applicative.Builder+import Options.Applicative.Builder.Internal+import Options.Applicative.Common+import Options.Applicative.Help++import Options.Applicative.Internal+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 =+  helperWith (mconcat [+    long "help",+    short 'h',+    help "Show this help text"+  ])++-- | Like helper, but with a minimal set of modifiers that can be extended+-- as desired.+--+-- > opts :: ParserInfo Sample+-- > opts = info (sample <**> helperWith (mconcat [+-- >          long "help",+-- >          short 'h',+-- >          help "Show this help text",+-- >          hidden+-- >        ])) mempty+helperWith :: Mod OptionFields (a -> a) -> Parser (a -> a)+helperWith modifiers =+  option helpReader $+    mconcat+      [ value id,+        metavar "",+        noGlobal,+        noArgError (ShowHelpText Nothing),+        hidden,+        modifiers+      ]+  where+    helpReader = do+      potentialCommand <- readerAsk+      readerAbort $+        ShowHelpText (Just potentialCommand)++-- | Builder for a command parser with a \"helper\" option attached.+-- Used in the same way as `subparser`, but includes a \"--help|-h\" inside+-- the subcommand.+hsubparser :: Mod CommandFields a -> Parser a+hsubparser m = mkParser d g rdr+  where+    Mod _ d g = metavar "COMMAND" `mappend` m+    (groupName, cmds) = mkCommand m+    rdr = CmdReader groupName ((fmap . fmap) add_helper cmds)+    add_helper pinfo = pinfo+      { infoParser = infoParser pinfo <**> helper }++-- | A hidden \"--version\" option that displays the version.+--+-- > opts :: ParserInfo Sample+-- > opts = info (sample <**> simpleVersioner "v1.2.3") mempty+simpleVersioner :: String -- ^ Version string to be shown+                -> Parser (a -> a)+simpleVersioner version = infoOption version $+  mconcat+    [ long "version"+    , help "Show version information"+    , hidden+    ]++-- | Run a program description.+--+-- Parse command line arguments. Display help text and exit if any parse error+-- occurs.+execParser :: ParserInfo a -> IO a+execParser = customExecParser defaultPrefs++-- | Run a program description with custom preferences.+customExecParser :: ParserPrefs -> ParserInfo a -> IO a+customExecParser pprefs pinfo+  = execParserPure pprefs pinfo <$> getArgs+  >>= handleParseResult++-- | Handle `ParserResult`.+handleParseResult :: ParserResult a -> IO a+handleParseResult (Success a) = return a+handleParseResult (Failure failure) = do+      progn <- getProgName+      let (msg, exit) = renderFailure failure progn+      case exit of+        ExitSuccess -> putStrLn msg+        _           -> hPutStrLn stderr msg+      exitWith exit+handleParseResult (CompletionInvoked compl) = do+      progn <- getProgName+      msg <- execCompletion compl progn+      putStr msg+      exitSuccess++-- | Extract the actual result from a `ParserResult` value.+--+-- This function returns 'Nothing' in case of errors.  Possible error messages+-- or completion actions are simply discarded.+--+-- If you want to display error messages and invoke completion actions+-- appropriately, use 'handleParseResult' instead.+getParseResult :: ParserResult a -> Maybe a+getParseResult (Success a) = Just a+getParseResult _ = Nothing++-- | The most general way to run a program description in pure code.+execParserPure :: ParserPrefs       -- ^ Global preferences for this parser+               -> ParserInfo a      -- ^ Description of the program to run+               -> [String]          -- ^ Program arguments+               -> ParserResult a+execParserPure pprefs pinfo args =+  case runP p pprefs of+    (Right (Right r), _) -> Success r+    (Right (Left c), _) -> CompletionInvoked c+    (Left err, ctx) -> Failure $ parserFailure pprefs pinfo err ctx+  where+    pinfo' = pinfo+      { infoParser = (Left <$> bashCompletionParser pinfo pprefs)+                 <|> (Right <$> infoParser pinfo) }+    p = runParserInfo pinfo' args++-- | Generate a `ParserFailure` from a `ParseError` in a given `Context`.+--+-- This function can be used, for example, to show the help text for a parser:+--+-- @handleParseResult . Failure $ parserFailure pprefs pinfo (ShowHelpText Nothing) mempty@+parserFailure :: ParserPrefs -> ParserInfo a+              -> ParseError -> [Context]+              -> ParserFailure ParserHelp+parserFailure pprefs pinfo msg ctx0 = ParserFailure $ \progn ->+  let h = with_context ctx pinfo $ \names pinfo' -> mconcat+            [ base_help pinfo'+            , usage_help progn names pinfo'+            , suggestion_help+            , globals ctx+            , error_help ]+  in (h, exit_code, prefColumns pprefs)+  where+    --+    -- Add another context layer if the argument to --help is+    -- a valid command.+    ctx = case msg of+      ShowHelpText (Just potentialCommand) ->+        let ctx1 = with_context ctx0 pinfo $ \_ pinfo' ->+              snd+                $ flip runP defaultPrefs { prefBacktrack = SubparserInline }+                $ runParserStep (infoPolicy pinfo') (infoParser pinfo') potentialCommand []+        in ctx1 `mappend` ctx0+      _ ->+        ctx0++    exit_code = case msg of+      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+                 -> (forall b . [String] -> ParserInfo b -> c)+                 -> c+    with_context [] i f = f [] i+    with_context c@(Context _ i:_) _ f = f (contextNames c) i++    globals :: [Context] -> ParserHelp+    globals cs =+      let+        voided =+          fmap (\(Context _ p) -> void p) cs `mappend` pure (void pinfo)++        globalParsers =+          traverse_ infoParser $+            drop 1 voided+      in+        if prefHelpShowGlobal pprefs then+          parserGlobals pprefs globalParsers+        else+          mempty++    usage_help progn names i = case msg of+      InfoMsg _+        -> mempty+      _+        -> mconcat [+            usageHelp (pure . parserUsage pprefs (infoParser i) . unwords $ progn : names)+          , descriptionHelp (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++      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 reachability opt = case optMain opt of+              OptReader ns _ _ -> fmap showOption ns+              FlagReader ns _  -> fmap showOption ns+              ArgReader _      -> []+              CmdReader _ ns    | argumentIsUnreachable reachability+                               -> []+                                | otherwise+                               -> fst <$> ns+      _+        -> mempty++    base_help :: ParserInfo a -> ParserHelp+    base_help i+      | show_full_help+      = mconcat [h, f, parserHelp pprefs (infoParser i)]+      | otherwise+      = mempty+      where+        h = headerHelp (infoHeader i)+        f = footerHelp (infoFooter i)++    show_full_help = case msg of+      ShowHelpText {}          -> True+      MissingError CmdStart  _  | prefShowHelpOnEmpty pprefs+                               -> True+      InfoMsg _                -> False+      _                        -> prefShowHelpOnError pprefs++renderFailure :: ParserFailure ParserHelp -> String -> (String, ExitCode)+renderFailure failure progn =+  let (h, exit, cols) = execFailure failure progn+  in (renderHelp cols h, exit)
+ src/Options/Applicative/Help.hs view
@@ -0,0 +1,28 @@+module Options.Applicative.Help (+  -- | This is an empty module which re-exports+  --   the help text system for optparse.++  -- | Pretty printer. Reexports most combinators+  --   from Text.PrettyPrint.ANSI.Leijen+  module Options.Applicative.Help.Pretty,++  -- | A free monoid over Doc with helpers for+  --   composing help text components.+  module Options.Applicative.Help.Chunk,++  -- | Types required by the help system.+  module Options.Applicative.Help.Types,++  -- | 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.Chunk+import Options.Applicative.Help.Core+import Options.Applicative.Help.Levenshtein+import Options.Applicative.Help.Pretty+import Options.Applicative.Help.Types
+ src/Options/Applicative/Help/Chunk.hs view
@@ -0,0 +1,137 @@+module Options.Applicative.Help.Chunk+  ( Chunk(..)+  , chunked+  , listToChunk+  , (<<+>>)+  , (<</>>)+  , vcatChunks+  , vsepChunks+  , isEmpty+  , stringChunk+  , paragraph+  , extractChunk+  , tabulate+  ) where++import Control.Applicative+import Control.Monad+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Semigroup+import Prelude++import Options.Applicative.Help.Pretty++-- | The free monoid on a semigroup @a@.+newtype Chunk a = Chunk+  { unChunk :: Maybe a }+  deriving (Eq, Show)++instance Functor Chunk where+  fmap f = Chunk . fmap f . unChunk++instance Applicative Chunk where+  pure = Chunk . pure+  Chunk f <*> Chunk x = Chunk (f <*> x)++instance Alternative Chunk where+  empty = Chunk Control.Applicative.empty+  a <|> b = Chunk $ unChunk a <|> unChunk b++instance Monad Chunk where+  return = pure+  m >>= f = Chunk $ unChunk m >>= unChunk . f++instance Semigroup a => Semigroup (Chunk a) where+  (<>) = chunked (<>)++instance Semigroup 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)++-- | Given a semigroup structure on @a@, return a monoid structure on+-- @'Chunk' a@.+--+-- Note that this is /not/ the same as 'liftA2'.+chunked :: (a -> a -> a)+        -> Chunk a -> Chunk a -> Chunk a+chunked _ (Chunk Nothing) y = y+chunked _ x (Chunk Nothing) = x+chunked f (Chunk (Just x)) (Chunk (Just y)) = Chunk (Just (f x y))++-- | Concatenate a list into a Chunk.  'listToChunk' satisfies:+--+-- > isEmpty . listToChunk = null+-- > listToChunk = mconcat . fmap pure+listToChunk :: Semigroup a => [a] -> Chunk a+listToChunk [] = mempty+listToChunk (x:xs) = pure (sconcat (x :| xs))++-- | Part of a constrained comonad instance.+--+-- This is the counit of the adjunction between 'Chunk' and the forgetful+-- functor from monoids to semigroups.  It satisfies:+--+-- > extractChunk . pure = id+-- > extractChunk . fmap pure = id+extractChunk :: Monoid a => Chunk a -> a+extractChunk = fromMaybe mempty . unChunk+-- we could also define:+-- duplicate :: Monoid a => Chunk a -> Chunk (Chunk a)+-- duplicate = fmap pure++-- | Concatenate two 'Chunk's with a space in between.  If one is empty, this+-- just returns the other one.+--+-- Unlike '<+>' for 'Doc', this operation has a unit element, namely the empty+-- 'Chunk'.+(<<+>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc+(<<+>>) = chunked (<+>)++-- | Concatenate two 'Chunk's with a softline in between.  This is exactly like+-- '<<+>>', but uses a softline instead of a space.+(<</>>) :: Chunk Doc -> Chunk Doc -> Chunk Doc+(<</>>) = chunked (</>)++-- | Concatenate 'Chunk's vertically.+vcatChunks :: [Chunk Doc] -> Chunk Doc+vcatChunks = foldr (chunked (.$.)) mempty++-- | Concatenate 'Chunk's vertically separated by empty lines.+vsepChunks :: [Chunk Doc] -> Chunk Doc+vsepChunks = foldr (chunked (\x y -> x .$. mempty .$. y)) mempty++-- | Whether a 'Chunk' is empty.  Note that something like 'pure mempty' is not+-- considered an empty chunk, even though the underlying 'Doc' is empty.+isEmpty :: Chunk a -> Bool+isEmpty = isNothing . unChunk++-- | Convert a 'String' into a 'Chunk'.  This satisfies:+--+-- > isEmpty . stringChunk = null+-- > extractChunk . stringChunk = string+stringChunk :: String -> Chunk Doc+stringChunk "" = mempty+stringChunk s = pure (pretty s)++-- | Convert a paragraph into a 'Chunk'.  The resulting chunk is composed by the+-- words of the original paragraph separated by softlines, so it will be+-- automatically word-wrapped when rendering the underlying document.+--+-- This satisfies:+--+-- > isEmpty . paragraph = null . words+paragraph :: String -> Chunk Doc+paragraph = foldr (chunked (</>) . stringChunk) mempty+          . words++-- | Display pairs of strings in a table.+tabulate :: Int -> [(Doc, Doc)] -> Chunk Doc+tabulate _ [] = mempty+tabulate size table = pure $ vcat+  [ indent 2 (fillBreak size key <+> value)+  | (key, value) <- table ]
+ src/Options/Applicative/Help/Core.hs view
@@ -0,0 +1,486 @@+{-# LANGUAGE CPP #-}+module Options.Applicative.Help.Core (+  cmdDesc,+  briefDesc,+  missingDesc,+  fullDesc,+  globalDesc,+  ParserHelp(..),+  errorHelp,+  headerHelp,+  suggestionsHelp,+  usageHelp,+  descriptionHelp,+  bodyHelp,+  footerHelp,+  globalsHelp,+  parserHelp,+  parserUsage,+  parserGlobals+  ) where++import           Control.Applicative+import           Control.Monad (guard)++import           Data.Foldable (any, foldl')+import           Data.Function (on)+import qualified Data.List as List+import           Data.List.NonEmpty (NonEmpty ((:|)))+import qualified Data.List.NonEmpty as NE+import           Data.Maybe (fromMaybe, catMaybes)++import           Prelude hiding (any)++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,+        descGlobal :: Bool+      }++safelast :: [a] -> Maybe a+safelast = foldl' (const Just) Nothing++-- | Generate description for a single option.+optDesc :: ParserPrefs -> OptDescStyle -> ArgumentReachability -> Option a -> (OptGroup, Chunk Doc, Parenthetic)+optDesc pprefs style _reachability opt =+  let names =+        List.sort . optionNames . optMain $ opt+      meta =+        stringChunk $ optMetaVar opt+      grp = propGroup $ optProps opt+      descs =+        map (pretty . showOption) names+      descriptions =+        listToChunk (List.intersperse (descSep style) descs)+      desc+        | prefHelpLongEquals pprefs && not (isEmpty meta) && any isLongName (safelast names) =+          descriptions <> stringChunk "=" <> meta+        | otherwise =+          descriptions <<+>> meta+      show_opt+        | descGlobal style && not (propShowGlobal (optProps opt)) =+          False+        | optVisibility opt == Hidden =+          descHidden style+        | otherwise =+          optVisibility opt == Visible+      wrapping+        | null names =+          NeverRequired+        | length names == 1 =+          MaybeRequired+        | otherwise =+          AlwaysRequired+      rendered+        | not show_opt =+          mempty+        | otherwise =+          desc+      modified =+        maybe id fmap (optDescMod opt) rendered+   in (grp, modified, wrapping)++-- | Generate descriptions for commands.+cmdDesc :: ParserPrefs -> Parser a -> [(Maybe String, Chunk Doc)]+cmdDesc pprefs = mapParser desc+  where+    desc _ opt =+      case optMain opt of+        CmdReader gn cmds ->+          (,) gn $+            tabulate (prefTabulateFill pprefs)+              [ (pretty nm, align (extractChunk (infoProgDesc cmd)))+              | (nm, cmd) <- reverse cmds+              ]+        _ -> mempty++-- | Generate a brief help text for a parser.+briefDesc :: ParserPrefs -> Parser a -> Chunk Doc+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 =+  wrapOver NoDefault MaybeRequired+    . foldTree pprefs style+    . mFilterOptional+    . treeMapParser optDesc'+  where+    mFilterOptional+      | showOptional =+        id+      | otherwise =+        filterOptional+    style = OptDescStyle+      { descSep = pretty '|',+        descHidden = False,+        descGlobal = False+      }+    optDesc' reach opt =+      let+        (_, a, b) =+          optDesc pprefs style reach opt+      in+        (a, b)++-- | Wrap a doc in parentheses or brackets if required.+wrapOver :: AltNodeType -> Parenthetic -> (Chunk Doc, Parenthetic) -> Chunk Doc+wrapOver altnode mustWrapBeyond (chunk, wrapping)+  | altnode == MarkDefault =+    fmap brackets chunk+  | wrapping > mustWrapBeyond =+    fmap parens chunk+  | otherwise =+    chunk++-- Fold a tree of option docs into a single doc with fully marked+-- optional areas and groups.+foldTree :: ParserPrefs -> OptDescStyle -> OptTree (Chunk Doc, Parenthetic) -> (Chunk Doc, Parenthetic)+foldTree _ _ (Leaf x) =+  x+foldTree prefs s (MultNode xs) =+  let go =+        (<</>>) . wrapOver NoDefault MaybeRequired . foldTree prefs s+      x =+        foldr go mempty xs+      wrapLevel =+        multi_wrap xs+   in (x, wrapLevel)+  where+    multi_wrap [_] = NeverRequired+    multi_wrap _ = MaybeRequired+foldTree prefs s (AltNode b xs) =+  (\x -> (x, NeverRequired))+    . fmap groupOrNestLine+    . wrapOver b MaybeRequired+    . alt_node+    . filter (not . isEmpty . fst)+    . map (foldTree prefs s)+    $ xs+  where+    alt_node :: [(Chunk Doc, Parenthetic)] -> (Chunk Doc, Parenthetic)+    alt_node [n] = n+    alt_node ns =+      (\y -> (y, AlwaysRequired))+        . foldr (chunked altSep . wrapOver NoDefault MaybeRequired) mempty+        $ ns+foldTree prefs s (BindNode x) =+  let rendered =+        wrapOver NoDefault NeverRequired (foldTree prefs s x)++      -- We always want to display the rendered option+      -- if it exists, and only attach the suffix then.+      withSuffix =+        rendered >>= (\r -> pure r <> stringChunk (prefMultiSuffix prefs))+   in (withSuffix, NeverRequired)++-- | Generate a full help text for a parser+fullDesc :: ParserPrefs -> Parser a -> Chunk Doc+fullDesc = optionsDesc False++-- | Generate a help text for the parser, showing+--   only what is relevant in the "Global options: section"+globalDesc :: ParserPrefs -> Parser a -> Chunk Doc+globalDesc = optionsDesc True++-- | Common generator for full descriptions and globals+optionsDesc :: Bool -> ParserPrefs -> Parser a -> Chunk Doc+optionsDesc global pprefs p =+  vsepChunks+    . formatTitle'+    . fmap tabulateGroup+    . groupByTitle+    $ docs+  where+    docs :: [Maybe (OptGroup, (Doc, Doc))]+    docs = mapParser doc p++    groupByTitle :: [Maybe (OptGroup, (Doc, Doc))] -> [[(OptGroup, (Doc, Doc))]]+    groupByTitle xs = groupFstAll . catMaybes $ xs++    -- NOTE: [Nested group alignment]+    --+    -- For nested groups, we want to produce output like:+    --+    -- Group 1+    --   --opt-1 INT          Option 1+    --+    -- - Group 2+    --     --opt-2 INT        Option 2+    --+    --   - Group 3+    --       - opt-3 INT      Option 3+    --+    -- That is, we have the following constraints:+    --+    --   1. Nested groups are prefixed with a hyphen '- ', where the hyphen+    --     starts on the same column as the parent group.+    --+    --   2. We still want the listed options to be indented twice under the+    --     group name, so this means nested options need to be indented+    --     again by the standard amount (2), due to the hyphen.+    --+    --   3. Help text should be __globally__ aligned.++    tabulateGroup :: [(OptGroup, (Doc, Doc))] -> (OptGroup, Chunk Doc)+    tabulateGroup l@((title,_):_) =+      (title, tabulate (prefTabulateFill pprefs) (getGroup <$> l))+      where+        -- Handle NOTE: [Nested group alignment] 3. here i.e. indent the+        -- right Doc (help text) according to its indention level and+        -- global maxGroupLevel. Notice there is an inverse relationship here,+        -- as the further the entire group is indented, the less we need to+        -- indent the help text.+        getGroup :: (OptGroup, (Doc, Doc)) -> (Doc, Doc)+        getGroup o@(_, (x, y)) =+          let helpIndent = calcOptHelpIndent o+          in (x, indent helpIndent y)++        -- Indents the option help text, taking the option's group level and+        -- maximum group level into account.+        calcOptHelpIndent :: (OptGroup, a) -> Int+        calcOptHelpIndent g =+          let groupLvl = optGroupToLevel g+          in lvlIndent * (maxGroupLevel - groupLvl)++    tabulateGroup [] = (OptGroup [], mempty)++    -- Fold so we can update the (printedGroups :: [String]) arg as we+    -- iterate. End with a reverse since we use foldl'.+    formatTitle' :: [(OptGroup, Chunk Doc)] -> [Chunk Doc]+    formatTitle' = reverse . snd . foldl' formatTitle ([], [])++    formatTitle :: ([String], [Chunk Doc]) -> (OptGroup, Chunk Doc) -> ([String], [Chunk Doc])+    formatTitle (printedGroups, acc) o@(OptGroup groups, opts) =+      case parentGroups of+        -- No nested groups: No special logic.+        [] -> (groupTitle : printedGroups, ((\d -> pretty groupTitle .$. d) <$> opts) : acc)+        -- We have at least one parent group title P for current group G: P has+        -- already been printed iff it is attached to another (non-grouped)+        -- option. In other words, P has __not__ been printed if its only+        -- member is another group.+        --+        -- The parameter (printedGroups :: [String]) holds all groups that+        -- have already been printed.+        parents@(_ : _) ->+          let groupLvl = optGroupToLevel o+              -- indent opts an extra lvlIndent to account for hyphen+              indentOpts = indent lvlIndent++              -- new printedGroups is all previous + this and parents.+              printedGroups' = groupTitle : parents ++ printedGroups++              parentsWithIndent = zip [0 .. ] parents++              -- docs for unprinted parent title groups+              parentDocs = pure $ mkParentDocs printedGroups parentsWithIndent++              -- docs for the current group+              thisDocs =+                (\d -> lvlIndentNSub1 groupLvl $ (hyphenate groupTitle) .$. indentOpts d)+                  <$> opts++              allDocs = parentDocs <> thisDocs++          in (printedGroups', allDocs : acc)+      where+        -- Separate parentGroups and _this_ group, in case we need to also+        -- print parent groups.+        (parentGroups, groupTitle) = case unsnoc groups of+          Nothing -> ([], defTitle)+          Just (parentGrps, grp) -> (parentGrps, grp)++        defTitle =+          if global+            then "Global options:"+            else "Available options:"++    maxGroupLevel :: Int+    maxGroupLevel = findMaxGroupLevel docs++    -- Finds the maxium OptGroup level.+    findMaxGroupLevel :: [Maybe (OptGroup, (Doc, Doc))] -> Int+    findMaxGroupLevel = foldl' (\acc -> max acc . optGroupToLevel) 0 . catMaybes++    optGroupToLevel :: (OptGroup, a) -> Int+    -- 0 (defTitle) and 1 (custom group name) are handled identically+    -- w.r.t indenation (not indented). Hence the subtraction here.+    optGroupToLevel (OptGroup [], _) = 0+    optGroupToLevel (OptGroup xs@(_ : _), _) = length xs - 1++    doc :: ArgumentReachability -> Option a -> Maybe (OptGroup, (Doc, Doc))+    doc info opt = do+      guard . not . isEmpty $ n+      guard . not . isEmpty $ h+      return (grp, (extractChunk n, align . extractChunk $ h <</>> hdef))+      where+        (grp, n, _) = optDesc pprefs style info opt+        h = optHelp opt+        hdef = Chunk . fmap show_def . optShowDefault $ opt+        show_def s = parens (pretty "default:" <+> pretty s)+    style = OptDescStyle+      { descSep = pretty ',',+        descHidden = True,+        descGlobal = global+      }++    --+    -- Prints all parent titles that have not already been printed+    -- (i.e. in printedGroups).+    mkParentDocs :: [String] -> [(Int, String)] -> Doc+    mkParentDocs printedGroups =+        foldr g mempty+      where+        g :: (Int, String) -> Doc ->  Doc+        g (i, s) acc+          | s `List.elem` printedGroups = acc+          | i == 0 = pretty s .$. acc+          | otherwise = lvlIndentNSub1 i $ hyphenate s .$. acc++    hyphenate s = pretty ("- " <> s)++    lvlIndentNSub1 :: Int -> Doc -> Doc+    lvlIndentNSub1 n = indent (lvlIndent * (n - 1))++    lvlIndent :: Int+    lvlIndent = 2++errorHelp :: Chunk Doc -> ParserHelp+errorHelp chunk = mempty { helpError = chunk }++headerHelp :: Chunk Doc -> ParserHelp+headerHelp chunk = mempty { helpHeader = chunk }++suggestionsHelp :: Chunk Doc -> ParserHelp+suggestionsHelp chunk = mempty { helpSuggestions = chunk }++globalsHelp :: Chunk Doc -> ParserHelp+globalsHelp chunk = mempty { helpGlobals = chunk }++usageHelp :: Chunk Doc -> ParserHelp+usageHelp chunk = mempty { helpUsage = chunk }++descriptionHelp :: Chunk Doc -> ParserHelp+descriptionHelp chunk = mempty { helpDescription = chunk }++bodyHelp :: Chunk Doc -> ParserHelp+bodyHelp chunk = mempty { helpBody = chunk }++footerHelp :: Chunk Doc -> ParserHelp+footerHelp chunk = mempty { helpFooter = chunk }++-- | Generate the help text for a program.+parserHelp :: ParserPrefs -> Parser a -> ParserHelp+parserHelp pprefs p =+  bodyHelp . vsepChunks $+    fullDesc pprefs p+      : (group_title <$> cs)+  where+    def = "Available commands:"+    cs = groupFstAll $ cmdDesc pprefs 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 (pretty title .$.)+++parserGlobals :: ParserPrefs -> Parser a -> ParserHelp+parserGlobals pprefs p =+  globalsHelp $ globalDesc pprefs p++++-- | Generate option summary.+parserUsage :: ParserPrefs -> Parser a -> String -> Doc+parserUsage pprefs p progn =+  group $+    hsep+      [ pretty "Usage:",+        pretty progn,+        hangAtIfOver 9 (prefBriefHangPoint pprefs) (extractChunk (briefDesc pprefs p))+      ]++-- | Peek at the structure of the rendered tree within.+--+--   For example, if a child is an option with multiple+--   alternatives, such as -a or -b, we need to know this+--   when wrapping it. For example, whether it's optional:+--   we don't want to have [(-a|-b)], rather [-a|-b] or+--   (-a|-b).+data Parenthetic+  = NeverRequired+  -- ^ Parenthesis are not required.+  | MaybeRequired+  -- ^ Parenthesis should be used if this group can be repeated+  | AlwaysRequired+  -- ^ Parenthesis should always be used.+  deriving (Eq, Ord, Show)++-- | Groups on the first element of the tuple. This differs from the simple+-- @groupBy ((==) `on` fst)@ in that non-adjacent groups are __also__ grouped+-- together. For example:+--+-- @+--   groupFst = groupBy ((==) `on` fst)+--+--   let xs = [(1, "a"), (1, "b"), (3, "c"), (2, "d"), (3, "e"), (2, "f")]+--+--   groupFst xs === [[(1,"a"),(1,"b")],[(3,"c")],[(2,"d")],[(3,"e")],[(2,"f")]]+--   groupFstAll xs === [[(1,"a"),(1,"b")],[(3,"c"),(3,"e")],[(2,"d"),(2,"f")]]+-- @+--+-- Notice that the original order is preserved i.e. we do not first sort on+-- the first element.+--+-- @since 0.19.0.0+groupFstAll :: Ord a => [(a, b)] -> [[(a, b)]]+groupFstAll =+  -- In order to group all (adjacent + non-adjacent) Eq elements together, we+  -- sort the list so that the Eq elements are in fact adjacent, _then_ group.+  -- We don't want to destroy the original order, however, so we add a+  -- temporary index that maintains this original order. The full logic is:+  --+  -- 1. Add index i that preserves original order.+  -- 2. Sort on tuple's fst.+  -- 3. Group by fst.+  -- 4. Sort by i, restoring original order.+  -- 5. Drop index i.+  fmap (NE.toList . dropIdx)+    . List.sortOn toIdx+    . NE.groupBy ((==) `on` fst')+    . List.sortOn fst'+    . zipWithIndex+  where+    dropIdx :: NonEmpty (Int, (a, b)) -> NonEmpty (a, b)+    dropIdx = fmap snd++    toIdx :: NonEmpty (Int, (a, b)) -> Int+    toIdx ((x, _) :| _) = x++    -- Like fst, ignores our added index+    fst' :: (Int, (a, b)) -> a+    fst' (_, (x, _)) = x++    zipWithIndex :: [(a, b)] -> [(Int, (a, b))]+    zipWithIndex = zip [1 ..]++-- | From base-4.19.0.0.+unsnoc :: [a] -> Maybe ([a], a)+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+ src/Options/Applicative/Help/Levenshtein.hs view
@@ -0,0 +1,79 @@+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.+--+--   Complexity+--     O(|a|*(1 + editDistance a b))+editDistance :: Eq a => [a] -> [a] -> Int+editDistance a b =+  let+    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++    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 =+          let+            me =+              if ach == bch then+                nw+              else+                1 + min3 (head w) nw (head n)+          in+            me : doDiag as bs me (tail n) (tail w)++        firstelt = 1 + head diagBelow+        thisdiag = firstelt : doDiag a' b' firstelt diagAbove (tail diagBelow)++    eachDiag _ [] _ = []+    eachDiag _ _ [] = []+    eachDiag a' (_:bs) (lastDiag:diags) =+      let+        nextDiag = head (tail diags)+      in+        oneDiag a' bs nextDiag lastDiag : eachDiag a' bs diags++    lab =+      length a - length b++    min3 x y z =+      if x < y then+        x+      else+        min y z++  in+    last $+      if lab == 0 then+        mainDiag+      else if lab > 0 then+        lowers !! (lab - 1)+      else+        uppers !! (-1 - lab)
+ src/Options/Applicative/Help/Pretty.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE CPP #-}+module Options.Applicative.Help.Pretty+  ( module Prettyprinter+  , module Prettyprinter.Render.Terminal+  , Doc+  , SimpleDoc++  , (.$.)+  , (</>)++  , groupOrNestLine+  , altSep+  , hangAtIfOver++  , prettyString+  ) where++#if !MIN_VERSION_base(4,11,0)+import           Data.Semigroup ((<>), mempty)+#endif+import qualified Data.Text.Lazy as Lazy++import           Prettyprinter hiding (Doc)+import qualified Prettyprinter as PP+import           Prettyprinter.Render.Terminal++import           Prelude++type Doc = PP.Doc AnsiStyle+type SimpleDoc = SimpleDocStream AnsiStyle++linebreak :: Doc+linebreak = flatAlt line mempty++(.$.) :: Doc -> Doc -> Doc+x .$. y = x <> line <> y+(</>) :: Doc -> Doc -> Doc+x </> y = x <> softline <> y++-- | Apply the function if we're not at the+--   start of our nesting level.+ifNotAtRoot :: (Doc -> Doc) -> Doc -> Doc+ifNotAtRoot =+  ifElseAtRoot id++-- | Apply the function if we're not at the+--   start of our nesting level.+ifAtRoot :: (Doc -> Doc) -> Doc -> Doc+ifAtRoot =+  flip ifElseAtRoot id++-- | Apply the function if we're not at the+--   start of our nesting level.+ifElseAtRoot :: (Doc -> Doc) -> (Doc -> Doc) -> Doc -> Doc+ifElseAtRoot f g doc =+  nesting $ \i ->+    column $ \j ->+      if i == j+        then f doc+        else g doc++-- | Render flattened text on this line, or start+--   a new line before rendering any text.+--+--   This will also nest subsequent lines in the+--   group.+groupOrNestLine :: Doc -> Doc+groupOrNestLine =+  group . ifNotAtRoot (linebreak <>) . nest 2+++-- | Separate items in an alternative with a pipe.+--+--   If the first document and the pipe don't fit+--   on the line, then mandatorily flow the next entry+--   onto the following line.+--+--   The (<//>) softbreak ensures that if the document+--   does fit on the line, there is at least a space,+--   but it's possible for y to still appear on the+--   next line.+altSep :: Doc -> Doc -> Doc+altSep x y =+  group (x <+> pretty '|' <> line) <> group linebreak <>  y+++-- | Printer hacks to get nice indentation for long commands+--   and subcommands.+--+--   If we're starting this section over the desired width+--   (usually 1/3 of the ribbon), then we will make a line+--   break, indent all of the usage, and go.+--+--   The ifAtRoot is an interesting clause. If this whole+--   operation is put under a `group` then the linebreak+--   will disappear; then item d will therefore not be at+--   the starting column, and it won't be indented more.+hangAtIfOver :: Int -> Int -> Doc -> Doc+hangAtIfOver i j d =+  column $ \k ->+    if k <= j then+      align d+    else+      linebreak <> ifAtRoot (indent i) d+++renderPretty :: Double -> Int -> Doc -> SimpleDocStream AnsiStyle+renderPretty ribbonFraction lineWidth+  = layoutPretty LayoutOptions+      { layoutPageWidth = AvailablePerLine lineWidth ribbonFraction }++prettyString :: Double -> Int -> Doc -> String+prettyString ribbonFraction lineWidth+  = streamToString+  . renderPretty ribbonFraction lineWidth++streamToString :: SimpleDocStream AnsiStyle -> String+streamToString sdoc =+  let+    rendered =+      Prettyprinter.Render.Terminal.renderLazy sdoc+  in+    Lazy.unpack rendered
+ src/Options/Applicative/Help/Types.hs view
@@ -0,0 +1,46 @@+module Options.Applicative.Help.Types (+    ParserHelp (..)+  , renderHelp+  ) where++import Data.Semigroup+import Prelude++import Options.Applicative.Help.Chunk+import Options.Applicative.Help.Pretty++data ParserHelp = ParserHelp+  { helpError :: Chunk Doc+  , helpSuggestions :: Chunk Doc+  , helpHeader :: Chunk Doc+  , helpUsage :: Chunk Doc+  , helpDescription :: Chunk Doc+  , helpBody :: Chunk Doc+  , helpGlobals :: Chunk Doc+  , helpFooter :: Chunk Doc+  }++instance Show ParserHelp where+  showsPrec _ h = showString (renderHelp 80 h)++instance Monoid ParserHelp where+  mempty = ParserHelp mempty mempty mempty mempty mempty mempty mempty mempty+  mappend = (<>)++instance Semigroup ParserHelp where+  (ParserHelp e1 s1 h1 u1 d1 b1 g1 f1) <> (ParserHelp e2 s2 h2 u2 d2 b2 g2 f2)+    = ParserHelp (mappend e1 e2) (mappend s1 s2)+                 (mappend h1 h2) (mappend u1 u2)+                 (mappend d1 d2) (mappend b1 b2)+                 (mappend g1 g2) (mappend f1 f2)++helpText :: ParserHelp -> Doc+helpText (ParserHelp e s h u d b g f) =+  extractChunk $+    vsepChunks [e, s, h, u, fmap (indent 2) d, b, g, f]++-- | Convert a help text to 'String'.+renderHelp :: Int -> ParserHelp -> String+renderHelp cols+  = prettyString 1.0 cols+  . helpText
+ src/Options/Applicative/Internal.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE RankNTypes #-}++module Options.Applicative.Internal+  ( P+  , MonadP(..)+  , ParseError(..)++  , uncons+  , hoistMaybe+  , hoistEither+  , runReadM+  , withReadM++  , runP++  , Completion+  , runCompletion+  , contextNames++  , ListT+  , takeListT+  , runListT+  , hoistList++  , NondetT+  , cut+  , (<!>)+  , disamb++  , mapParserOptions+  ) where++import Control.Applicative+import Prelude+import Control.Monad (MonadPlus(..), liftM, ap, guard)+import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Monad.Trans.Except+  (runExcept, runExceptT, withExcept, ExceptT(..), throwE)+import Control.Monad.Trans.Reader+  (mapReaderT, runReader, runReaderT, Reader, ReaderT, ask)+import Control.Monad.Trans.State (StateT, get, put, modify, evalStateT, runStateT)+++import Options.Applicative.Types++class (Alternative m, MonadPlus m) => MonadP m where+  enterContext :: String -> ParserInfo a -> m ()+  exitContext :: m ()+  getPrefs :: m ParserPrefs++  missingArgP :: ParseError -> Completer -> m a+  errorP :: ParseError -> m a+  exitP :: IsCmdStart -> ArgPolicy -> Parser b -> Maybe a -> m a++newtype P a = P (ExceptT ParseError (StateT [Context] (Reader ParserPrefs)) a)++instance Functor P where+  fmap f (P m) = P $ fmap f m++instance Applicative P where+  pure a = P $ pure a+  P f <*> P a = P $ f <*> a++instance Alternative P where+  empty = P empty+  P x <|> P y = P $ x <|> y++instance Monad P where+  return = pure+  P x >>= k = P $ x >>= \a -> case k a of P y -> y++instance MonadPlus P where+  mzero = P mzero+  mplus (P x) (P y) = P $ mplus x y++contextNames :: [Context] -> [String]+contextNames ns =+  let go (Context n _) = n+  in  reverse $ go <$> ns++instance MonadP P where+  enterContext name pinfo = P $ lift $ modify $ (:) $ Context name pinfo+  exitContext = P $ lift $ modify $ drop 1+  getPrefs = P . lift . lift $ ask++  missingArgP e _ = errorP e+  exitP i _ p = P . maybe (throwE . MissingError i . SomeParser $ p) return+  errorP = P . throwE++hoistMaybe :: MonadPlus m => Maybe a -> m a+hoistMaybe = maybe mzero return++hoistEither :: MonadP m => Either ParseError a -> m a+hoistEither = either errorP return++runP :: P a -> ParserPrefs -> (Either ParseError a, [Context])+runP (P p) = runReader . flip runStateT [] . runExceptT $ p++uncons :: [a] -> Maybe (a, [a])+uncons [] = Nothing+uncons (x : xs) = Just (x, xs)++runReadM :: MonadP m => ReadM a -> String -> m a+runReadM (ReadM r) s = hoistEither . runExcept $ runReaderT r s++withReadM :: (String -> String) -> ReadM a -> ReadM a+withReadM f = ReadM . mapReaderT (withExcept f') . unReadM+  where+    f' (ErrorMsg err) = ErrorMsg (f err)+    f' e = e++data ComplResult a+  = ComplParser SomeParser ArgPolicy+  | ComplOption Completer+  | ComplResult a++instance Functor ComplResult where+  fmap = liftM++instance Applicative ComplResult where+  pure = ComplResult+  (<*>) = ap++instance Monad ComplResult where+  return = pure+  m >>= f = case m of+    ComplResult r -> f r+    ComplParser p a -> ComplParser p a+    ComplOption c -> ComplOption c++newtype Completion a =+  Completion (ExceptT ParseError (ReaderT ParserPrefs ComplResult) a)++instance Functor Completion where+  fmap f (Completion m) = Completion $ fmap f m++instance Applicative Completion where+  pure a = Completion $ pure a+  Completion f <*> Completion a = Completion $ f <*> a++instance Alternative Completion where+  empty = Completion empty+  Completion x <|> Completion y = Completion $ x <|> y++instance Monad Completion where+  return = pure+  Completion x >>= k = Completion $ x >>= \a -> case k a of Completion y -> y++instance MonadPlus Completion where+  mzero = Completion mzero+  mplus (Completion x) (Completion y) = Completion $ mplus x y++instance MonadP Completion where+  enterContext _ _ = return ()+  exitContext = return ()+  getPrefs = Completion $ lift ask++  missingArgP _ = Completion . lift . lift . ComplOption+  exitP _ a p _ = Completion . lift . lift $ ComplParser (SomeParser p) a+  errorP = Completion . throwE++runCompletion :: Completion r -> ParserPrefs -> Maybe (Either (SomeParser, ArgPolicy) Completer)+runCompletion (Completion c) prefs = case runReaderT (runExceptT c) prefs of+  ComplResult _ -> Nothing+  ComplParser p' a' -> Just $ Left (p', a')+  ComplOption compl -> Just $ Right compl++-- A "ListT done right" implementation++newtype ListT m a = ListT+  { stepListT :: m (TStep a (ListT m a)) }++data TStep a x+  = TNil+  | TCons a x++bimapTStep :: (a -> b) -> (x -> y) -> TStep a x -> TStep b y+bimapTStep _ _ TNil = TNil+bimapTStep f g (TCons a x) = TCons (f a) (g x)++takeListT :: Monad m => Int -> ListT m a -> ListT m a+takeListT 0 = const mzero+takeListT n = ListT . liftM (bimapTStep id (takeListT (n - 1))) . stepListT++runListT :: Monad m => ListT m a -> m [a]+runListT xs = do+  s <- stepListT xs+  case s of+    TNil -> return []+    TCons x xt -> liftM (x :) (runListT xt)++instance Monad m => Functor (ListT m) where+  fmap f = ListT+         . liftM (bimapTStep f (fmap f))+         . stepListT++instance Monad m => Applicative (ListT m) where+  pure a = ListT (return (TCons a mzero))+  (<*>) = ap++instance Monad m => Monad (ListT m) where+  return = pure+  xs >>= f = ListT $ do+    s <- stepListT xs+    case s of+      TNil -> return TNil+      TCons x xt -> stepListT $ f x `mplus` (xt >>= f)++instance Monad m => Alternative (ListT m) where+  empty = mzero+  (<|>) = mplus++instance MonadTrans ListT where+  lift = ListT . liftM (`TCons` mzero)++instance Monad m => MonadPlus (ListT m) where+  mzero = ListT (return TNil)+  mplus xs ys = ListT $ do+    s <- stepListT xs+    case s of+      TNil -> stepListT ys+      TCons x xt -> return $ TCons x (xt `mplus` ys)++-- nondeterminism monad with cut operator++newtype NondetT m a = NondetT+  { runNondetT :: ListT (StateT Bool m) a }++instance Monad m => Functor (NondetT m) where+  fmap f = NondetT . fmap f . runNondetT++instance Monad m => Applicative (NondetT m) where+  pure = NondetT . pure+  NondetT m1 <*> NondetT m2 = NondetT (m1 <*> m2)++instance Monad m => Monad (NondetT m) where+  return = pure+  NondetT m1 >>= f = NondetT $ m1 >>= runNondetT . f++instance Monad m => MonadPlus (NondetT m) where+  mzero = NondetT mzero+  NondetT m1 `mplus` NondetT m2 = NondetT (m1 `mplus` m2)++instance Monad m => Alternative (NondetT m) where+  empty = mzero+  (<|>) = mplus++instance MonadTrans NondetT where+  lift = NondetT . lift . lift++(<!>) :: Monad m => NondetT m a -> NondetT m a -> NondetT m a+(<!>) m1 m2 = NondetT . mplus (runNondetT m1) $ do+  s <- lift get+  guard (not s)+  runNondetT m2++cut :: Monad m => NondetT m ()+cut = NondetT $ lift (put True)++disamb :: Monad m => Bool -> NondetT m a -> m (Maybe a)+disamb allow_amb xs = do+  xs' <- (`evalStateT` False)+       . runListT+       . takeListT (if allow_amb then 1 else 2)+       . runNondetT $ xs+  return $ case xs' of+    [x] -> Just x+    _   -> Nothing++hoistList :: Alternative m => [a] -> m a+hoistList = foldr cons empty+  where+    cons x xs = pure x <|> xs++-- | Maps an Option modifying function over the Parser.+--+-- @since 0.19.0.0+mapParserOptions :: (forall x. Option x -> Option x) -> Parser a -> Parser a+mapParserOptions f = go+  where+    go :: forall y. Parser y -> Parser y+    go (NilP x) = NilP x+    go (OptP o) = OptP (f o)+    go (MultP p1 p2) = MultP (go p1) (go p2)+    go (AltP p1 p2) = AltP (go p1) (go p2)+    go (BindP p1 p2) = BindP (go p1) (\x -> go (p2 x))
+ src/Options/Applicative/NonEmpty.hs view
@@ -0,0 +1,16 @@+module Options.Applicative.NonEmpty (+  some1+) where++import Data.List.NonEmpty (NonEmpty (..))++import Options.Applicative.Types+import Control.Applicative+import Prelude++-- | Sequences an action one or more times.+--+--   Functionally identical to 'Data.List.NonEmpty.some1',+--   but is preferred as it gives a nicer help text.+some1 :: Parser a -> Parser (NonEmpty a)+some1 p = fromM $ (:|) <$> oneM p <*> manyM p
+ src/Options/Applicative/Types.hs view
@@ -0,0 +1,459 @@+{-# LANGUAGE CPP, Rank2Types, ExistentialQuantification #-}+module Options.Applicative.Types (+  ParseError(..),+  ParserInfo(..),+  ParserPrefs(..),++  Option(..),+  OptName(..),+  isShortName,+  isLongName,++  OptReader(..),+  OptProperties(..),+  OptGroup(..),+  OptVisibility(..),+  Backtracking(..),+  ReadM(..),+  readerAsk,+  readerAbort,+  readerError,+  CReader(..),+  Parser(..),+  ParserM(..),+  Completer(..),+  mkCompleter,+  CompletionResult(..),+  ParserFailure(..),+  ParserResult(..),+  overFailure,+  Args,+  ArgPolicy(..),+  ArgumentReachability(..),+  AltNodeType(..),+  OptTree(..),+  ParserHelp(..),+  SomeParser(..),+  Context(..),+  IsCmdStart(..),++  fromM,+  oneM,+  manyM,+  someM,++  filterOptional,+  optVisibility,+  optMetaVar,+  optHelp,+  optShowDefault,+  optDescMod+  ) where++import Control.Applicative+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 qualified Control.Monad.Fail as Fail+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 (Maybe String)+  | UnknownError+  | MissingError IsCmdStart SomeParser+  | ExpectsArgError String+  | UnexpectedError String SomeParser++data IsCmdStart = CmdStart | CmdCont+  deriving Show++instance Monoid ParseError where+  mempty = UnknownError+  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+  , infoFullDesc :: Bool      -- ^ whether the help text should contain full+                              -- documentation+  , infoProgDesc :: Chunk Doc -- ^ brief parser description+  , 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+  , infoPolicy :: ArgPolicy   -- ^ allow regular options and flags to occur+                              -- after arguments (default: InterspersePolicy)+  }++instance Functor ParserInfo where+  fmap f i = i { infoParser = fmap f (infoParser i) }++data Backtracking+  = Backtrack+  | NoBacktrack+  | SubparserInline+  deriving (Eq, Show)++-- | Global preferences for a top-level 'Parser'.+data ParserPrefs = ParserPrefs+  { prefMultiSuffix :: String     -- ^ metavar suffix for multiple options+  , prefDisambiguate :: Bool      -- ^ automatically disambiguate abbreviations+                                  -- (default: False)+  , prefShowHelpOnError :: Bool   -- ^ always show help text on parse errors+                                  -- (default: False)+  , prefShowHelpOnEmpty :: Bool   -- ^ show the help text for a command or subcommand+                                  -- if it fails with no input (default: False)+  , prefBacktrack :: Backtracking -- ^ backtrack to parent parser when a+                                  -- subcommand fails (default: Backtrack)+  , prefColumns :: Int            -- ^ number of columns in the terminal, used to+                                  -- format the help page (default: 80)+  , prefHelpLongEquals :: Bool    -- ^ when displaying long names in usage and help,+                                  -- use an '=' sign for long names, rather than a+                                  -- single space (default: False)+  , prefHelpShowGlobal :: Bool    -- ^ when displaying subparsers' usage help,+                                  -- show parent options under a "global options"+                                  -- section (default: False)+  , prefTabulateFill ::Int        -- ^ Indentation width for tables+  , prefBriefHangPoint :: Int     -- ^ Width at which to hang the brief description+  } deriving (Eq, Show)++data OptName = OptShort !Char+             | OptLong !String+  deriving (Eq, Ord, Show)++isShortName :: OptName -> Bool+isShortName (OptShort _) = True+isShortName (OptLong _)  = False++isLongName :: OptName -> Bool+isLongName = not . isShortName++-- | Visibility of an option in the help text.+data OptVisibility+  = Internal          -- ^ does not appear in the help text at all+  | Hidden            -- ^ only visible in the full description+  | Visible           -- ^ visible both in the full and brief descriptions+  deriving (Eq, Ord, Show)++-- | Groups for optionals. Can be multiple in the case of nested groups.+--+-- @since 0.19.0.0+newtype OptGroup = OptGroup [String]+  deriving (Eq, Ord, Show)++-- | Specification for an individual parser option.+data OptProperties = OptProperties+  { propVisibility :: OptVisibility       -- ^ whether this flag is shown in the brief description+  , propHelp :: Chunk Doc                 -- ^ help text for this option+  , propMetaVar :: String                 -- ^ metavariable for this option+  , propShowDefault :: Maybe String       -- ^ what to show in the help text as the default+  , propShowGlobal :: Bool                -- ^ whether the option is presented in global options text+  , propDescMod :: Maybe ( Doc -> Doc )   -- ^ a function to run over the brief description+  , propGroup :: OptGroup+    -- ^ optional group(s)+    --+    -- @since 0.19.0.0+  }++instance Show OptProperties where+  showsPrec p (OptProperties pV pH pMV pSD pSG _ pGrp)+    = showParen (p >= 11)+    $ showString "OptProperties { propVisibility = " . shows pV+    . showString ", propHelp = " . shows pH+    . showString ", propMetaVar = " . shows pMV+    . showString ", propShowDefault = " . shows pSD+    . showString ", propShowGlobal = " . shows pSG+    . showString ", propDescMod = _"+    . showString ", propGroup = " . shows pGrp+    . showString "}"++-- | A single option of a parser.+data Option a = Option+  { optMain :: OptReader a               -- ^ reader for this option+  , 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 'Options.Applicative.Extra.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) ++ "}"++instance Functor Option where+  fmap f (Option m p) = Option (fmap f m) p++-- | A newtype over 'ReaderT String Except', used by option readers.+newtype ReadM a = ReadM+  { unReadM :: ReaderT String (Except ParseError) a }++instance Functor ReadM where+  fmap f (ReadM r) = ReadM (fmap f r)++instance Applicative ReadM where+  pure = ReadM . pure+  ReadM x <*> ReadM y = ReadM $ x <*> y++instance Alternative ReadM where+  empty = mzero+  (<|>) = mplus++instance Monad ReadM where+  return = pure+  ReadM r >>= f = ReadM $ r >>= unReadM . f++#if !(MIN_VERSION_base(4,13,0))+  fail = Fail.fail+#endif++instance Fail.MonadFail ReadM where+  fail = readerError++instance MonadPlus ReadM where+  mzero = ReadM mzero+  mplus (ReadM x) (ReadM y) = ReadM $ mplus x y++-- | Return the value being read.+readerAsk :: ReadM String+readerAsk = ReadM ask++-- | Abort option reader by exiting with a 'ParseError'.+readerAbort :: ParseError -> ReadM a+readerAbort = ReadM . lift . throwE++-- | Abort option reader by exiting with an error message.+readerError :: String -> ReadM a+readerError = readerAbort . ErrorMsg++data CReader a = CReader+  { crCompleter :: Completer+  , crReader :: ReadM a }++instance Functor CReader where+  fmap f (CReader c r) = CReader c (fmap f r)++-- | An 'OptReader' defines whether an option matches an command line argument.+data OptReader a+  = OptReader [OptName] (CReader a) (String -> ParseError)+  -- ^ option reader+  | FlagReader [OptName] !a+  -- ^ flag reader+  | ArgReader (CReader a)+  -- ^ argument reader+  | CmdReader (Maybe String) [(String, 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 n cs) = CmdReader n ((fmap . fmap . fmap) f cs)++-- | A @Parser a@ is an option parser returning a value of type @a@.+data Parser a+  = NilP (Maybe a)+  | OptP (Option a)+  | forall x . MultP (Parser (x -> a)) (Parser x)+  | AltP (Parser a) (Parser a)+  | forall x . BindP (Parser x) (x -> Parser a)++instance Functor Parser where+  fmap f (NilP x) = NilP (fmap f x)+  fmap f (OptP opt) = OptP (fmap f opt)+  fmap f (MultP p1 p2) = MultP (fmap (f.) p1) p2+  fmap f (AltP p1 p2) = AltP (fmap f p1) (fmap f p2)+  fmap f (BindP p k) = BindP p (fmap f . k)++instance Applicative Parser where+  pure = NilP . Just+  (<*>) = MultP++newtype ParserM r = ParserM+  { runParserM :: forall x . (r -> Parser x) -> Parser x }++instance Monad ParserM where+  return = pure+  ParserM f >>= g = ParserM $ \k -> f (\x -> runParserM (g x) k)++instance Functor ParserM where+  fmap = liftM++instance Applicative ParserM where+  pure x = ParserM $ \k -> k x+  (<*>) = ap++fromM :: ParserM a -> Parser a+fromM (ParserM f) = f pure++oneM :: Parser a -> ParserM a+oneM p = ParserM (BindP p)++manyM :: Parser a -> ParserM [a]+manyM p = do+  mx <- oneM (optional p)+  case mx of+    Nothing -> return []+    Just x -> (x:) <$> manyM p++someM :: Parser a -> ParserM [a]+someM p = (:) <$> oneM p <*> manyM p++instance Alternative Parser where+  empty = NilP Nothing+  (<|>) = AltP+  many = fromM . manyM+  some = fromM . someM++-- | 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 = (<>)++newtype CompletionResult = CompletionResult+  { execCompletion :: String -> IO String }++instance Show CompletionResult where+  showsPrec p _ = showParen (p > 10) $+    showString "CompletionResult _"++newtype ParserFailure h = ParserFailure+  { execFailure :: String -> (h, ExitCode, Int) }++instance Show h => Show (ParserFailure h) where+  showsPrec p (ParserFailure f)+    = showParen (p > 10)+    $ showString "ParserFailure"+    . showsPrec 11 (f "<program>")++instance Functor ParserFailure where+  fmap f (ParserFailure err) = ParserFailure $ \progn ->+    let (h, exit, cols) = err progn in (f h, exit, cols)++-- | Result of 'Options.Applicative.execParserPure'.+data ParserResult a+  = Success a+  | Failure (ParserFailure ParserHelp)+  | CompletionInvoked CompletionResult+  deriving Show++instance Functor ParserResult where+  fmap f (Success a) = Success (f a)+  fmap _ (Failure f) = Failure f+  fmap _ (CompletionInvoked c) = CompletionInvoked c++overFailure :: (ParserHelp -> ParserHelp)+            -> ParserResult a -> ParserResult a+overFailure f (Failure failure) = Failure $ fmap f failure+overFailure _ r = r++instance Applicative ParserResult where+  pure = Success+  Success f <*> r = fmap f r+  Failure f <*> _ = Failure f+  CompletionInvoked c <*> _ = CompletionInvoked c++instance Monad ParserResult where+  return = pure+  Success x >>= f = f x+  Failure f >>= _ = Failure f+  CompletionInvoked c >>= _ = CompletionInvoked c++type Args = [String]++-- | Policy for how to handle options within the parse+data ArgPolicy+  = 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)++newtype ArgumentReachability = ArgumentReachability+  { argumentIsUnreachable :: Bool -- ^ If the result is a positional, if it can't be+                                  --    accessed in the current parser position ( first arg )+  } deriving (Eq, Show)++-- | This type encapsulates whether an 'AltNode' of an 'OptTree' should be displayed+-- with brackets around it.+data AltNodeType = MarkDefault | NoDefault+  deriving (Show, Eq)++data OptTree a+  = Leaf a+  | MultNode [OptTree a]+  | AltNode AltNodeType [OptTree a]+  | BindNode (OptTree a)+  deriving Show++filterOptional :: OptTree a -> OptTree a+filterOptional t = case t of+  Leaf a+    -> Leaf a+  MultNode xs+    -> MultNode (map filterOptional xs)+  AltNode MarkDefault _+    -> AltNode MarkDefault []+  AltNode NoDefault xs+    -> AltNode NoDefault (map filterOptional xs)+  BindNode xs+    -> BindNode (filterOptional xs)++optVisibility :: Option a -> OptVisibility+optVisibility = propVisibility . optProps++optHelp :: Option a -> Chunk Doc+optHelp  = propHelp . optProps++optMetaVar :: Option a -> String+optMetaVar = propMetaVar . optProps++optShowDefault :: Option a -> Maybe String+optShowDefault = propShowDefault . optProps++optDescMod :: Option a -> Maybe ( Doc -> Doc )+optDescMod = propDescMod . optProps
tests/Examples/Cabal.hs view
@@ -39,10 +39,6 @@   { buildDir :: FilePath }   deriving Show -version :: Parser (a -> a)-version = infoOption "0.0.0"-  (  long "version"-  <> help "Print version information" )  parser :: Parser Args parser = runA $ proc () -> do@@ -60,7 +56,7 @@            <> command "build"               (info buildParser                     (progDesc "Make this package ready for installation")) ) -< ()-  A version >>> A helper -< Args opts cmds+  A (simpleVersioner "0.0.0") >>> A helper -< Args opts cmds  commonOpts :: Parser CommonOpts commonOpts = CommonOpts@@ -124,5 +120,5 @@  main :: IO () main = do-  r <- execParser pinfo+  r <- customExecParser (prefs helpShowGlobals) pinfo   print r
+ tests/Examples/LongSub.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}+module Examples.LongSub where++import Data.Monoid+import Options.Applicative++#if __GLASGOW_HASKELL__ <= 702+(<>) :: Monoid a => a -> a -> a+(<>) = mappend+#endif++data Sample+  = Hello [String]+  | Goodbye+  deriving (Eq, Show)++hello :: Parser Sample+hello =+  Hello+    <$> many (argument str (metavar "TARGET..."))+    <*  switch (long "first-flag")+    <*  switch (long "second-flag")+    <*  switch (long "third-flag")+    <*  switch (long "fourth-flag")++sample :: Parser Sample+sample = hsubparser+       ( command "hello-very-long-sub"+         (info hello+               (progDesc "Print greeting"))+       )++opts :: ParserInfo Sample+opts = info (sample <**> helper) idm
+ tests/Examples/ParserGroup/AllGrouped.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.AllGrouped (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- Tests the help page when every option belongs to some group i.e. there are+-- no top-level options. Notice we put the helper (<**> helper) __inside__+-- one of the groups, so that it is not a top-level option.+--+-- Also notice that although we add cmdParser to the same group, it is __not__+-- rendered as part of this group. This is what we want, as it is an Argument+-- and should not be rendered with the Options.++data LogGroup = LogGroup+  { logPath :: Maybe String,+    logVerbosity :: Maybe Int+  }+  deriving (Show)++data SystemGroup = SystemGroup+  { poll :: Bool,+    timeout :: Int+  }+  deriving (Show)++data Sample = Sample+  { logGroup :: LogGroup,+    systemGroup :: SystemGroup,+    cmd :: String+  }+  deriving (Show)++sample :: Parser Sample+sample =+  Sample+    <$> parseLogGroup+    <*> parseSystemGroup+    <*> parseCmd++  where+    parseLogGroup =+      parserOptionGroup "Logging" $+        LogGroup+          <$> optional+            ( strOption+                ( long "file-log-path"+                    <> metavar "PATH"+                    <> help "Log file path"+                )+            )+          <*> optional+            ( option+                auto+                ( long "file-log-verbosity"+                    <> metavar "INT"+                    <> help "File log verbosity"+                )+            )+            <**> helper++    parseSystemGroup =+      parserOptionGroup "System Options" $+        SystemGroup+          <$> switch+            ( long "poll"+                <> help "Whether to poll"+            )+          <*> option+                auto+                ( long "timeout"+                    <> metavar "INT"+                    <> help "Whether to time out"+                )++    parseCmd = argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+  info+    sample+    ( fullDesc+        <> progDesc "Every option is grouped"+        <> header "parser_group.all_grouped - a test for optparse-applicative"+    )++main :: IO ()+main = do+  r <- customExecParser (prefs helpShowGlobals) opts+  print r
+ tests/Examples/ParserGroup/Basic.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.Basic (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++data LogGroup = LogGroup+  { logPath :: Maybe String,+    logVerbosity :: Maybe Int+  }+  deriving (Show)++data SystemGroup = SystemGroup+  { poll :: Bool,+    timeout :: Int+  }+  deriving (Show)++data Sample = Sample+  { hello :: String,+    logGroup :: LogGroup,+    quiet :: Bool,+    systemGroup :: SystemGroup,+    verbosity :: Int,+    cmd :: String+  }+  deriving (Show)++sample :: Parser Sample+sample =+  Sample+    <$> parseHello+    <*> parseLogGroup+    <*> parseQuiet+    <*> parseSystemGroup+    <*> parseVerbosity+    <*> parseCmd++  where+    parseHello =+      strOption+        ( long "hello"+            <> metavar "TARGET"+            <> help "Target for the greeting"+        )++    parseLogGroup =+      parserOptionGroup "Logging" $+        LogGroup+          <$> optional+            ( strOption+                ( long "file-log-path"+                    <> metavar "PATH"+                    <> help "Log file path"+                )+            )+          <*> optional+            ( option+                auto+                ( long "file-log-verbosity"+                    <> metavar "INT"+                    <> help "File log verbosity"+                )+            )++    parseQuiet =+      switch+        ( long "quiet"+            <> short 'q'+            <> help "Whether to be quiet"+        )++    parseSystemGroup =+      parserOptionGroup "System Options" $+        SystemGroup+          <$> switch+            ( long "poll"+                <> help "Whether to poll"+            )+          <*> ( option+                  auto+                  ( long "timeout"+                      <> metavar "INT"+                      <> help "Whether to time out"+                  )+              )++    parseVerbosity =+      option+        auto+        ( long "verbosity"+            <> short 'v'+            <> help "Console verbosity"+        )++    parseCmd = argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+  info+    (sample <**> helper)+    ( fullDesc+        <> progDesc "Shows parser groups"+        <> header "parser_group.basic - a test for optparse-applicative"+    )++main :: IO ()+main = do+  r <- customExecParser (prefs helpShowGlobals) opts+  print r
+ tests/Examples/ParserGroup/CommandGroups.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Examples.ParserGroup.CommandGroups (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++data LogGroup = LogGroup+  { logPath :: Maybe String,+    logVerbosity :: Maybe Int+  }+  deriving (Show)++data SystemGroup = SystemGroup+  { poll :: Bool,+    timeout :: Int+  }+  deriving (Show)++data Command+  = Delete+  | List+  | Print+  | Query+  deriving (Show)++data Sample = Sample+  { hello :: String,+    logGroup :: LogGroup,+    quiet :: Bool,+    systemGroup :: SystemGroup,+    verbosity :: Int,+    cmd :: Command+  }+  deriving (Show)++sample :: Parser Sample+sample =+  Sample+    <$> parseHello+    <*> parseLogGroup+    <*> parseQuiet+    <*> parseSystemGroup+    <*> parseVerbosity+    <*> parseCommand++  where+    parseHello =+      strOption+        ( long "hello"+            <> metavar "TARGET"+            <> help "Target for the greeting"+        )++    parseLogGroup =+      parserOptionGroup "Logging" $+        LogGroup+          <$> optional+            ( strOption+                ( long "file-log-path"+                    <> metavar "PATH"+                    <> help "Log file path"+                )+            )+          <*> optional+            ( option+                auto+                ( long "file-log-verbosity"+                    <> metavar "INT"+                    <> help "File log verbosity"+                )+            )++    parseQuiet =+      switch+        ( long "quiet"+            <> short 'q'+            <> help "Whether to be quiet"+        )++    parseSystemGroup =+      parserOptionGroup "System Options" $+        SystemGroup+          <$> switch+            ( long "poll"+                <> help "Whether to poll"+            )+          <*> ( option+                  auto+                  ( long "timeout"+                      <> metavar "INT"+                      <> help "Whether to time out"+                  )+              )++    parseVerbosity =+      option+        auto+        ( long "verbosity"+            <> short 'v'+            <> help "Console verbosity"+        )++    parseCommand =+      hsubparser+        ( command "list 2" (info (pure List) $ progDesc "Lists elements")+        )+        <|> hsubparser+        ( command "list" (info (pure List) $ progDesc "Lists elements")+            <> command "print" (info (pure Print) $ progDesc "Prints table")+            <> commandGroup "Info commands"+        )+        <|> hsubparser+          ( command "delete" (info (pure Delete) $ progDesc "Deletes elements")+          )+        <|> hsubparser+          ( command "query" (info (pure Query) $ progDesc "Runs a query")+              <> commandGroup "Query commands"+          )++opts :: ParserInfo Sample+opts =+  info+    (sample <**> helper)+    ( fullDesc+        <> progDesc "Option and command groups"+        <> header "parser_group.command_groups - a test for optparse-applicative"+    )++main :: IO ()+main = do+  r <- customExecParser (prefs helpShowGlobals) opts+  print r
+ tests/Examples/ParserGroup/DuplicateCommandGroups.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Examples.ParserGroup.DuplicateCommandGroups (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- This test demonstrates that duplicate + consecutive groups are merged,+-- while duplicate + non-consecutive groups are not merged.++data Command+  = Delete+  | Insert+  | List+  | Print+  | Query+  deriving (Show)++data Sample = Sample+  { hello :: String,+    quiet :: Bool,+    verbosity :: Int,+    cmd :: Command+  }+  deriving (Show)++sample :: Parser Sample+sample =+  Sample+    <$> parseHello+    <*> parseQuiet+    <*> parseVerbosity+    <*> parseCommand++  where+    parseHello =+      strOption+        ( long "hello"+            <> metavar "TARGET"+            <> help "Target for the greeting"+        )++    parseQuiet =+      switch+        ( long "quiet"+            <> short 'q'+            <> help "Whether to be quiet"+        )++    parseVerbosity =+      option+        auto+        ( long "verbosity"+            <> short 'v'+            <> help "Console verbosity"+        )++    parseCommand =+      hsubparser+        ( command "list" (info (pure List) $ progDesc "Lists elements")+            <> commandGroup "Info commands"+        )+        <|> hsubparser+          ( command "delete" (info (pure Delete) $ progDesc "Deletes elements")+              <> commandGroup "Update commands"+          )+        <|> hsubparser+          ( command "insert" (info (pure Insert) $ progDesc "Inserts elements")+              <> commandGroup "Update commands"+          )+        <|> hsubparser+          ( command "query" (info (pure Query) $ progDesc "Runs a query")+          )+        <|> hsubparser+        ( command "print" (info (pure Print) $ progDesc "Prints table")+            <> commandGroup "Info commands"+        )++opts :: ParserInfo Sample+opts =+  info+    (sample <**> helper)+    ( fullDesc+        <> progDesc "Duplicate consecutive command groups consolidated"+        <> header "parser_group.duplicate_command_groups - a test for optparse-applicative"+    )++main :: IO ()+main = do+  r <- customExecParser (prefs helpShowGlobals) opts+  print r
+ tests/Examples/ParserGroup/Duplicates.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.Duplicates (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- NOTE: This is the same structure as ParserGroup.Basic __except__+-- we have two (non-consecutive) "Logging" groups and two (consecutive)+-- System groups. This test demonstrates two things:+--+-- 1. Non-consecutive groups are not merged (i.e. we display two "Logging"+--    sections).+-- 2. Consecutive groups are merged (i.e. we display only one "System" group).+--+-- This is like command groups.++data LogGroup1 = LogGroup1+  { logPath :: Maybe String,+    logVerbosity :: Maybe Int+  }+  deriving (Show)++data LogGroup2 = LogGroup2+  { logNamespace :: String+  }+  deriving (Show)++data SystemGroup1 = SystemGroup1+  { poll :: Bool,+    timeout :: Int+  }+  deriving (Show)++newtype SystemGroup2 = SystemGroup2+  { sysFlag :: Bool+  }+  deriving (Show)++data Sample = Sample+  { hello :: String,+    logGroup1 :: LogGroup1,+    quiet :: Bool,+    systemGroup1 :: SystemGroup1,+    systemGroup2 :: SystemGroup2,+    logGroup2 :: LogGroup2,+    verbosity :: Int,+    cmd :: String+  }+  deriving (Show)++sample :: Parser Sample+sample =+  Sample+    <$> parseHello+    <*> parseLogGroup1+    <*> parseQuiet+    <*> parseSystemGroup1+    <*> parseSystemGroup2+    <*> parseLogGroup2+    <*> parseVerbosity+    <*> parseCmd++  where+    parseHello =+      strOption+        ( long "hello"+            <> metavar "TARGET"+            <> help "Target for the greeting"+        )++    parseLogGroup1 =+      parserOptionGroup "Logging" $+        LogGroup1+          <$> optional+            ( strOption+                ( long "file-log-path"+                    <> metavar "PATH"+                    <> help "Log file path"+                )+            )+          <*> optional+            ( option+                auto+                ( long "file-log-verbosity"+                    <> metavar "INT"+                    <> help "File log verbosity"+                )+            )++    parseQuiet =+      switch+        ( long "quiet"+            <> short 'q'+            <> help "Whether to be quiet"+        )++    parseSystemGroup1 =+      parserOptionGroup "System" $+        SystemGroup1+          <$> switch+            ( long "poll"+                <> help "Whether to poll"+            )+          <*> option+                auto+                ( long "timeout"+                    <> metavar "INT"+                    <> help "Whether to time out"+                )++    parseSystemGroup2 =+      parserOptionGroup "System" $+        SystemGroup2+          <$> switch+            ( long "sysFlag"+                <> help "Some flag"+            )++    parseLogGroup2 =+      parserOptionGroup "Logging" $+        LogGroup2+            <$>+              strOption+                ( long "log-namespace"+                    <> metavar "STR"+                    <> help "Log namespace"+                )++    parseVerbosity =+      option+        auto+        ( long "verbosity"+            <> short 'v'+            <> help "Console verbosity"+        )++    parseCmd = argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+  info+    (sample <**> helper)+    ( fullDesc+        <> progDesc "Duplicate consecutive groups consolidated"+        <> header "parser_group.duplicates - a test for optparse-applicative"+    )++main :: IO ()+main = do+  r <- customExecParser (prefs helpShowGlobals) opts+  print r+
+ tests/Examples/ParserGroup/Nested.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE NamedFieldPuns #-}++module Examples.ParserGroup.Nested (opts, main) where++import Data.Semigroup ((<>))+import Options.Applicative++-- Nested groups. Demonstrates that group can nest.++data LogGroup = LogGroup+  { logPath :: Maybe String,+    systemGroup :: SystemGroup,+    logVerbosity :: Maybe Int+  }+  deriving (Show)++data SystemGroup = SystemGroup+  { poll :: Bool,+    deepNested :: Nested2,+    timeout :: Int+  }+  deriving (Show)++data Nested2 = Nested2+  { nested2Str :: String,+    nested3 :: Nested3+  }+  deriving (Show)++newtype Nested3 = Nested3+  { nested3Str :: String+  }+  deriving (Show)++data Sample = Sample+  { hello :: String,+    logGroup :: LogGroup,+    quiet :: Bool,+    verbosity :: Int,+    group2 :: (Int, Int),+    cmd :: String+  }+  deriving (Show)++sample :: Parser Sample+sample =+  Sample+    <$> parseHello+    <*> parseLogGroup+    <*> parseQuiet+    <*> parseVerbosity+    <*> parseGroup2+    <*> parseCmd++  where+    parseHello =+      strOption+        ( long "hello"+            <> metavar "TARGET"+            <> help "Target for the greeting"+        )++    parseLogGroup =+      parserOptionGroup "First group" $+      parserOptionGroup "Second group" $+      parserOptionGroup "Logging" $+        LogGroup+          <$> parseLogPath+          <*> parseSystemGroup+          <*> parseLogVerbosity++      where+        parseLogPath =+          optional+            ( strOption+                ( long "file-log-path"+                    <> metavar "PATH"+                    <> help "Log file path"+                )+            )+        parseLogVerbosity =+          optional+            ( option+                auto+                ( long "file-log-verbosity"+                    <> metavar "INT"+                    <> help "File log verbosity"+                )+            )++    parseQuiet =+      switch+        ( long "quiet"+            <> short 'q'+            <> help "Whether to be quiet"+        )++    parseSystemGroup =+      parserOptionGroup "System Options" $+        SystemGroup+          <$> switch (long "poll" <> help "Whether to poll")+          <*> parseNested2+          <*> option auto (long "timeout" <> metavar "INT" <> help "Whether to time out")++    parseNested2 =+      parserOptionGroup "Nested2" $+        Nested2+          <$> option auto (long "double-nested" <> metavar "STR" <> help "Some nested option")+          <*> parseNested3++    parseNested3 =+      parserOptionGroup "Nested3" $+        Nested3 <$> option auto (long "triple-nested" <> metavar "STR" <> help "Another option")++    parseGroup2 :: Parser (Int, Int)+    parseGroup2 = parserOptionGroup "Group 2" $+      (,)+        <$> parserOptionGroup "G 2.1" (option auto (long "one" <> help "Option 1"))+        <*> parserOptionGroup "G 2.2" (option auto (long "two" <> help "Option 2"))++    parseVerbosity =+      option auto (long "verbosity" <> short 'v' <> help "Console verbosity")++    parseCmd =+      argument str (metavar "Command")++opts :: ParserInfo Sample+opts =+  info+    (sample <**> helper)+    ( fullDesc+        <> progDesc "Nested parser groups"+        <> header "parser_group.nested - a test for optparse-applicative"+    )++main :: IO ()+main = do+  r <- customExecParser (prefs helpShowGlobals) opts+  print r
tests/cabal.err.txt view
@@ -1,7 +1,12 @@ Usage: cabal configure [--enable-tests] [-f|--flags FLAGS]+   Prepare to build the package  Available options:   --enable-tests           Enable compilation of test suites   -f,--flags FLAGS         Enable the given flag   -h,--help                Show this help text++Global options:+  -v,--verbose LEVEL       Set verbosity to LEVEL+  --version                Show version information
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/formatting-long-subcommand.err.txt view
@@ -0,0 +1,9 @@+Usage: formatting-long-subcommand hello-very-long-sub +         [TARGET...] [--first-flag] +         [--second-flag] [--third-flag] +         [--fourth-flag]++  Print greeting++Available options:+  -h,--help                Show this help text
tests/formatting.err.txt view
@@ -1,4 +1,5 @@ Usage: formatting [-t|--test FOO_BAR_BAZ_LONG_METAVARIABLE]+   This is a very long program description. This   text should be automatically wrapped to fit the   size of the terminal
tests/hello.err.txt view
@@ -1,6 +1,7 @@ hello - a test for optparse-applicative  Usage: hello --hello TARGET [-q|--quiet] [--repeat INT]+   Print a greeting for TARGET  Available options:
+ tests/long_equals.err.txt view
@@ -0,0 +1,6 @@+Usage: long_equals (-i|-j|--intval|--intval2=ARG)++Available options:+  -i,-j,--intval,--intval2=ARG+                           integer value+  -h,--help                Show this help text
+ tests/nested_optional.err.txt view
@@ -0,0 +1,7 @@+Usage: nested_optional (-a|--a A) [--b0 B0 [--b1 B1]]++Available options:+  -a,--a A                 value a+  --b0 B0                  value b0+  --b1 B1                  value b1+  -h,--help                Show this help text
+ tests/optional.err.txt view
@@ -0,0 +1,6 @@+Usage: optional [--a A --b B]++Available options:+  --a A                    value a+  --b B                    value b+  -h,--help                Show this help text
+ tests/parser_group_all_grouped.err.txt view
@@ -0,0 +1,16 @@+parser_group.all_grouped - a test for optparse-applicative++Usage: parser_group_all_grouped [--file-log-path PATH] +                                [--file-log-verbosity INT] [--poll]+                                --timeout INT Command++  Every option is grouped++Logging+  --file-log-path PATH     Log file path+  --file-log-verbosity INT File log verbosity+  -h,--help                Show this help text++System Options+  --poll                   Whether to poll+  --timeout INT            Whether to time out
+ tests/parser_group_basic.err.txt view
@@ -0,0 +1,21 @@+parser_group.basic - a test for optparse-applicative++Usage: parser_group_basic --hello TARGET [--file-log-path PATH] +                          [--file-log-verbosity INT] [-q|--quiet] [--poll]+                          --timeout INT (-v|--verbosity ARG) Command++  Shows parser groups++Available options:+  --hello TARGET           Target for the greeting+  -q,--quiet               Whether to be quiet+  -v,--verbosity ARG       Console verbosity+  -h,--help                Show this help text++Logging+  --file-log-path PATH     Log file path+  --file-log-verbosity INT File log verbosity++System Options+  --poll                   Whether to poll+  --timeout INT            Whether to time out
+ tests/parser_group_command_groups.err.txt view
@@ -0,0 +1,33 @@+parser_group.command_groups - a test for optparse-applicative++Usage: parser_group_command_groups --hello TARGET [--file-log-path PATH] +                                   [--file-log-verbosity INT] [-q|--quiet] +                                   [--poll] --timeout INT (-v|--verbosity ARG) +                                   (COMMAND | COMMAND | COMMAND | COMMAND)++  Option and command groups++Available options:+  --hello TARGET           Target for the greeting+  -q,--quiet               Whether to be quiet+  -v,--verbosity ARG       Console verbosity+  -h,--help                Show this help text++Logging+  --file-log-path PATH     Log file path+  --file-log-verbosity INT File log verbosity++System Options+  --poll                   Whether to poll+  --timeout INT            Whether to time out++Available commands:+  list 2                   Lists elements+  delete                   Deletes elements++Info commands+  list                     Lists elements+  print                    Prints table++Query commands+  query                    Runs a query
+ tests/parser_group_duplicate_command_groups.err.txt view
@@ -0,0 +1,24 @@+parser_group.duplicate_command_groups - a test for optparse-applicative++Usage: parser_group_duplicate_command_groups +         --hello TARGET [-q|--quiet] (-v|--verbosity ARG) +         (COMMAND | COMMAND | COMMAND | COMMAND | COMMAND)++  Duplicate consecutive command groups consolidated++Available options:+  --hello TARGET           Target for the greeting+  -q,--quiet               Whether to be quiet+  -v,--verbosity ARG       Console verbosity+  -h,--help                Show this help text++Available commands:+  query                    Runs a query++Info commands+  list                     Lists elements+  print                    Prints table++Update commands+  delete                   Deletes elements+  insert                   Inserts elements
+ tests/parser_group_duplicates.err.txt view
@@ -0,0 +1,24 @@+parser_group.duplicates - a test for optparse-applicative++Usage: parser_group_duplicates --hello TARGET [--file-log-path PATH] +                               [--file-log-verbosity INT] [-q|--quiet] [--poll]+                               --timeout INT [--sysFlag] --log-namespace STR+                               (-v|--verbosity ARG) Command++  Duplicate consecutive groups consolidated++Available options:+  --hello TARGET           Target for the greeting+  -q,--quiet               Whether to be quiet+  -v,--verbosity ARG       Console verbosity+  -h,--help                Show this help text++Logging+  --file-log-path PATH     Log file path+  --file-log-verbosity INT File log verbosity+  --log-namespace STR      Log namespace++System+  --poll                   Whether to poll+  --timeout INT            Whether to time out+  --sysFlag                Some flag
+ tests/parser_group_nested.err.txt view
@@ -0,0 +1,37 @@+parser_group.nested - a test for optparse-applicative++Usage: parser_group_nested --hello TARGET [--file-log-path PATH] [--poll]+                           --double-nested STR --triple-nested STR --timeout INT+                           [--file-log-verbosity INT] [-q|--quiet]+                           (-v|--verbosity ARG) --one ARG --two ARG Command++  Nested parser groups++Available options:+  --hello TARGET                     Target for the greeting+  -q,--quiet                         Whether to be quiet+  -v,--verbosity ARG                 Console verbosity+  -h,--help                          Show this help text++First group+- Second group+  - Logging+      --file-log-path PATH           Log file path+      --file-log-verbosity INT       File log verbosity++    - System Options+        --poll                       Whether to poll+        --timeout INT                Whether to time out++      - Nested2+          --double-nested STR        Some nested option++        - Nested3+            --triple-nested STR      Another option++Group 2+- G 2.1+    --one ARG                        Option 1++- G 2.2+    --two ARG                        Option 2
tests/test.hs view
@@ -9,11 +9,21 @@ import qualified Examples.Cabal as Cabal import qualified Examples.Alternatives as Alternatives import qualified Examples.Formatting as Formatting+import qualified Examples.LongSub as LongSub+import qualified Examples.ParserGroup.AllGrouped as ParserGroup.AllGrouped+import qualified Examples.ParserGroup.Basic as ParserGroup.Basic+import qualified Examples.ParserGroup.CommandGroups as ParserGroup.CommandGroups+import qualified Examples.ParserGroup.DuplicateCommandGroups as ParserGroup.DuplicateCommandGroups+import qualified Examples.ParserGroup.Duplicates as ParserGroup.Duplicates+import qualified Examples.ParserGroup.Nested as ParserGroup.Nested  import           Control.Applicative import           Control.Monad+import           Data.Function (on) import           Data.List hiding (group)+import           Data.List.NonEmpty (NonEmpty ((:|))) import           Data.Semigroup hiding (option)+import           Data.String  import           System.Exit import           Test.QuickCheck hiding (Success, Failure)@@ -21,9 +31,14 @@  import           Options.Applicative import           Options.Applicative.Types-import           Options.Applicative.Help.Pretty (Doc, SimpleDoc(..))+import qualified Options.Applicative.NonEmpty+++import qualified Options.Applicative.Help as H+import           Options.Applicative.Help.Pretty (Doc) import qualified Options.Applicative.Help.Pretty as Doc import           Options.Applicative.Help.Chunk+import           Options.Applicative.Help.Levenshtein  import           Prelude @@ -73,14 +88,14 @@ 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 prop_cabal_conf = once $-  checkHelpText "cabal" Cabal.pinfo ["configure", "--help"]+  checkHelpTextWith ExitSuccess (prefs helpShowGlobals) "cabal" Cabal.pinfo ["configure", "--help"]  prop_args :: Property prop_args = once $@@ -129,7 +144,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"@@ -142,9 +158,102 @@       i = info (p <**> helper) idm   in checkHelpText "alt" i ["--help"] +prop_optional_help :: Property+prop_optional_help = once $+  let p :: Parser (Maybe (String, String))+      p = optional ((,)+                    <$> strOption ( long "a"+                                    <> metavar "A"+                                    <> help "value a" )+                    <*> strOption ( long "b"+                                    <> metavar "B"+                                    <> help "value b" ) )+      i = info (p <**> helper) idm+  in checkHelpText "optional" i ["--help"]++prop_optional_requiring_parens :: Property+prop_optional_requiring_parens = once $+  let p = optional $+            (,)+            <$> flag' () ( short 'a' <> long "a" )+            <*> flag' () ( short 'b' <> long "b" )+      i = info (p <**> helper) briefDesc+      result = run i ["--help"]+  in assertError result $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "Usage: test [(-a|--a) (-b|--b)]" === text++prop_optional_alt_requiring_parens :: Property+prop_optional_alt_requiring_parens = once $+  let p = optional $+                flag' () ( short 'a' <> long "a" )+            <|> flag' () ( short 'b' <> long "b" )+      i = info (p <**> helper) briefDesc+      result = run i ["--help"]+  in assertError result $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "Usage: test [(-a|--a) | (-b|--b)]" === text++prop_nested_optional_help :: Property+prop_nested_optional_help = once $+  let p :: Parser (String, Maybe (String, Maybe String))+      p = (,) <$>+          (strOption ( short 'a'+                       <> long "a"+                       <> metavar "A"+                       <> help "value a" ) ) <*>+          (optional+           ((,) <$>+            (strOption ( long "b0"+                         <> metavar "B0"+                         <> help "value b0" ) ) <*>+            (optional (strOption ( long "b1"+                                   <> metavar "B1"+                                   <> help "value b1" )))))+      i = info (p <**> helper) idm+  in checkHelpText "nested_optional" i ["--help"]++prop_long_equals :: Property+prop_long_equals = once $+  let p :: Parser String+      p = option auto (   long "intval"+                       <> short 'j'+                       <> long "intval2"+                       <> short 'i'+                       <> help "integer value")+      i = info (p <**> helper) fullDesc+  in checkHelpTextWith ExitSuccess (prefs helpLongEquals) "long_equals" i ["--help"]++prop_long_equals_doesnt_do_shorts :: Property+prop_long_equals_doesnt_do_shorts = once $+  let p :: Parser String+      p = option auto (   short 'i'+                       <> help "integer value")+      i = info (p <**> helper) fullDesc+      result = execParserPure (prefs helpLongEquals) i ["--help"]+  in assertError result $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "Usage: test -i ARG" === text++prop_nested_fun :: Property+prop_nested_fun = once $+  let p :: Parser (String, Maybe (String, Maybe String))+      p = (,) <$>+          (strOption (short 'a' <> long "a" <> metavar "A")) <*>+          (optional+           ((,) <$>+            (strOption (short 'b' <> long "b" <> metavar "B")) <*>+            (optional (strOption (short 'c' <> long "c" <> metavar "C")))))+      i = info (p <**> helper) briefDesc+      result = run i ["--help"]+  in assertError result $ \failure ->+    let text = head . lines . fst $ renderFailure failure "test"+    in  "Usage: test (-a|--a A) [(-b|--b B) [-c|--c C]]" === text+ 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 +261,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 +271,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 +281,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 +291,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 +301,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)@@ -211,6 +325,49 @@       result = execParserPure (prefs disambiguate) i ["--ba"]   in  assertError result (\_ -> property succeeded) ++prop_disambiguate_in_same_subparsers :: Property+prop_disambiguate_in_same_subparsers = once $+  let p0 = subparser (command "oranges" (info (pure "oranges") idm) <> command "apples" (info (pure "apples") idm) <> metavar "B")+      i = info (p0 <**> helper) idm+      result = execParserPure (prefs disambiguate) i ["orang"]+  in  assertResult result ((===) "oranges")++prop_disambiguate_commands_in_separate_subparsers :: Property+prop_disambiguate_commands_in_separate_subparsers = once $+  let p2 = subparser (command "oranges" (info (pure "oranges") idm)  <> metavar "B")+      p1 = subparser (command "apples" (info (pure "apples") idm)  <> metavar "C")+      p0 = p1 <|> p2+      i = info (p0 <**> helper) idm+      result = execParserPure (prefs disambiguate) i ["orang"]+  in  assertResult result ((===) "oranges")++prop_fail_ambiguous_commands_in_same_subparser :: Property+prop_fail_ambiguous_commands_in_same_subparser = once $+  let p0 = subparser (command "oranges" (info (pure ()) idm) <> command "orangutans" (info (pure ()) idm) <> metavar "B")+      i = info (p0 <**> helper) idm+      result = execParserPure (prefs disambiguate) i ["orang"]+  in  assertError result (\_ -> property succeeded)++prop_fail_ambiguous_commands_in_separate_subparser :: Property+prop_fail_ambiguous_commands_in_separate_subparser = once $+  let p2 = subparser (command "oranges" (info (pure ()) idm)  <> metavar "B")+      p1 = subparser (command "orangutans" (info (pure ()) idm)  <> metavar "C")+      p0 = p1 <|> p2+      i = info (p0 <**> helper) idm+      result = execParserPure (prefs disambiguate) i ["orang"]+  in  assertError result (\_ -> property succeeded)++prop_without_disambiguation_same_named_commands_should_parse_in_order :: Property+prop_without_disambiguation_same_named_commands_should_parse_in_order = once $+  let p3 = subparser (command "b" (info (pure ()) idm)  <> metavar "B")+      p2 = subparser (command "a" (info (pure ()) idm)  <> metavar "B")+      p1 = subparser (command "a" (info (pure ()) idm)  <> metavar "C")+      p0 = (,,) <$> p1 <*> p2 <*> p3+      i = info (p0 <**> helper) idm+      result = execParserPure defaultPrefs i ["b", "a", "a"]+  in  assertResult result ((===) ((), (), ()))+ prop_completion :: Property prop_completion = once . ioProperty $   let p = (,)@@ -225,9 +382,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 +497,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"]@@ -285,6 +540,16 @@       result = execParserPure (prefs noBacktrack) i ["c", "-b"]   in assertError result $ \_ -> property succeeded +prop_subparser_inline :: Property+prop_subparser_inline = once $+  let p2 = switch (short 'a')+      p1 = (,)+        <$> subparser (command "c" (info p2 idm))+        <*> switch (short 'b')+      i = info (p1 <**> helper) idm+      result = execParserPure (prefs subparserInline) i ["c", "-b", "-a" ]+  in assertResult result ((True, True) ===)+ prop_error_context :: Property prop_error_context = once $   let p = pk <$> option auto (long "port")@@ -404,11 +669,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 +739,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 +751,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 +762,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 +789,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,21 +798,194 @@  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 "first"   (info (pure ()) idm))+      p1 = subparser (command "fst"     (info (pure ()) idm))+      p3 = subparser (command "far-off" (info (pure ()) idm))+      p  = p2 *> p1 *> p3+      i  = info p idm+      result = run i ["fist"]+  in assertError result $ \failure ->+    let (msg, _)  = renderFailure failure "prog"+    in  counterexample msg+       $  isInfixOf "Did you mean one of these?\n    first\n    fst" msg++prop_grouped_some_option_ellipsis :: Property+prop_grouped_some_option_ellipsis = once $+  let x :: Parser String+      x = strOption (short 'x' <> metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> some x)+  in r === "-x X (-x X)..."++prop_grouped_many_option_ellipsis :: Property+prop_grouped_many_option_ellipsis = once $+  let x :: Parser String+      x = strOption (short 'x' <> metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> many x)+  in r === "-x X [-x X]..."++prop_grouped_some_argument_ellipsis :: Property+prop_grouped_some_argument_ellipsis = once $+  let x :: Parser String+      x = strArgument (metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> some x)+  in r === "X X..."++prop_grouped_many_argument_ellipsis :: Property+prop_grouped_many_argument_ellipsis = once $+  let x :: Parser String+      x = strArgument (metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> many x)+  in r === "X [X]..."++prop_grouped_some_pairs_argument_ellipsis :: Property+prop_grouped_some_pairs_argument_ellipsis = once $+  let x :: Parser String+      x = strArgument (metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> some (x *> x))+  in r === "X (X X)..."++prop_grouped_many_pairs_argument_ellipsis :: Property+prop_grouped_many_pairs_argument_ellipsis = once $+  let x :: Parser String+      x = strArgument (metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> many (x *> x))+  in r === "X [X X]..."++prop_grouped_some_dual_option_ellipsis :: Property+prop_grouped_some_dual_option_ellipsis = once $+  let x :: Parser String+      x = strOption (short 'a' <> short 'b' <> metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> some x)+  in r === "(-a|-b X) (-a|-b X)..."++prop_grouped_many_dual_option_ellipsis :: Property+prop_grouped_many_dual_option_ellipsis = once $+  let x :: Parser String+      x = strOption (short 'a' <> short 'b' <> metavar "X")+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> many x)+  in r === "(-a|-b X) [-a|-b X]..."++prop_grouped_some_dual_flag_ellipsis :: Property+prop_grouped_some_dual_flag_ellipsis = once $+  let x = flag' () (short 'a' <> short 'b')+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> some x)+  in r === "(-a|-b) (-a|-b)..."++prop_grouped_many_dual_flag_ellipsis :: Property+prop_grouped_many_dual_flag_ellipsis = once $+  let x = flag' () (short 'a' <> short 'b')+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p (x *> many x)+  in r === "(-a|-b) [-a|-b]..."++prop_issue_402 :: Property+prop_issue_402 = once $+  let x = some (flag' () (short 'a')) <|> some (flag' () (short 'b' <> internal))+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p x+  in r === "(-a)..."++prop_nice_some1 :: Property+prop_nice_some1 = once $+  let x = Options.Applicative.NonEmpty.some1 (flag' () (short 'a'))+      p = prefs (multiSuffix "...")+      r = show . extractChunk $ H.briefDesc p x+  in r === "(-a)..."++prop_some1_works :: Property+prop_some1_works = once $+  let p = Options.Applicative.NonEmpty.some1 (flag' () (short 'a'))+      i = info p idm+      result = run i ["-a", "-a"]+  in assertResult result $ \xs -> () :| [()] === xs++prop_help_contexts :: Property+prop_help_contexts = once $+  let+    grabHelpMessage (Failure failure) =+      let (msg, ExitSuccess) = renderFailure failure "<text>"+      in msg+    grabHelpMessage _ = error "Parse did not render help text"++    i = Cabal.pinfo+    pre = run i ["install", "--help"]+    post = run i ["--help", "install"]+  in grabHelpMessage pre === grabHelpMessage post++prop_help_unknown_context :: Property+prop_help_unknown_context = once $+  let+    grabHelpMessage (Failure failure) =+      let (msg, ExitSuccess) = renderFailure failure "<text>"+      in msg+    grabHelpMessage _ = error "Parse did not render help text"++    i = Cabal.pinfo+    pre = run i ["--help"]+    post = run i ["--help", "not-a-command"]+  in grabHelpMessage pre === grabHelpMessage post+++prop_long_command_line_flow :: Property+prop_long_command_line_flow = once $+  let p = LongSub.sample <**> 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-long-subcommand" i ["hello-very-long-sub", "--help"]++prop_parser_group_basic :: Property+prop_parser_group_basic = once $+  checkHelpText "parser_group_basic" ParserGroup.Basic.opts ["--help"]++prop_parser_group_command_groups :: Property+prop_parser_group_command_groups = once $+  checkHelpText "parser_group_command_groups" ParserGroup.CommandGroups.opts ["--help"]++prop_parser_group_duplicate_command_groups :: Property+prop_parser_group_duplicate_command_groups = once $+  checkHelpText "parser_group_duplicate_command_groups" ParserGroup.DuplicateCommandGroups.opts ["--help"]++prop_parser_group_duplicates :: Property+prop_parser_group_duplicates = once $+  checkHelpText "parser_group_duplicates" ParserGroup.Duplicates.opts ["--help"]++prop_parser_group_all_grouped :: Property+prop_parser_group_all_grouped = once $+  checkHelpText "parser_group_all_grouped" ParserGroup.AllGrouped.opts ["--help"]++prop_parser_group_nested :: Property+prop_parser_group_nested = once $+  checkHelpText "parser_group_nested" ParserGroup.Nested.opts ["--help"]+ ---  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 +equalDocs :: Double -> Int -> Doc -> Doc -> Property+equalDocs f w d1 d2 = Doc.prettyString f w d1+                  === Doc.prettyString f w d2+ prop_listToChunk_1 :: [String] -> Property prop_listToChunk_1 xs = isEmpty (listToChunk xs) === null xs @@ -524,16 +998,48 @@ 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 Double -> Positive Int -> String -> Property prop_stringChunk_1 (Positive f) (Positive w) s =   equalDocs f w (extractChunk (stringChunk s))-                (Doc.string s)+                (Doc.pretty 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)++---++--+-- 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  ---